From 17e3383261dc0515f1bcb3f12decc8de3663398a Mon Sep 17 00:00:00 2001 From: Sina Khani Date: Mon, 22 Jul 2024 14:06:40 -0500 Subject: [PATCH 1/7] Gradient model is added to MOM6 --- parameterizations/lateral/MOM_MEKE.F90 | 2051 ++++++++++ parameterizations/lateral/MOM_MEKE_types.F90 | 34 + .../lateral/MOM_Zanna_Bolton.F90 | 1099 ++++++ parameterizations/lateral/MOM_hor_visc.F90 | 3324 +++++++++++++++++ .../lateral/MOM_interface_filter.F90 | 499 +++ .../lateral/MOM_internal_tides.F90 | 3126 ++++++++++++++++ .../lateral/MOM_lateral_mixing_coeffs.F90 | 1858 +++++++++ .../lateral/MOM_load_love_numbers.F90 | 1486 ++++++++ .../lateral/MOM_mixed_layer_restrat.F90 | 2128 +++++++++++ .../lateral/MOM_self_attr_load.F90 | 277 ++ .../lateral/MOM_spherical_harmonics.F90 | 395 ++ .../lateral/MOM_thickness_diffuse.F90 | 2502 +++++++++++++ .../lateral/MOM_tidal_forcing.F90 | 758 ++++ 13 files changed, 19537 insertions(+) create mode 100644 parameterizations/lateral/MOM_MEKE.F90 create mode 100644 parameterizations/lateral/MOM_MEKE_types.F90 create mode 100644 parameterizations/lateral/MOM_Zanna_Bolton.F90 create mode 100644 parameterizations/lateral/MOM_hor_visc.F90 create mode 100644 parameterizations/lateral/MOM_interface_filter.F90 create mode 100644 parameterizations/lateral/MOM_internal_tides.F90 create mode 100644 parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 create mode 100644 parameterizations/lateral/MOM_load_love_numbers.F90 create mode 100644 parameterizations/lateral/MOM_mixed_layer_restrat.F90 create mode 100644 parameterizations/lateral/MOM_self_attr_load.F90 create mode 100644 parameterizations/lateral/MOM_spherical_harmonics.F90 create mode 100644 parameterizations/lateral/MOM_thickness_diffuse.F90 create mode 100644 parameterizations/lateral/MOM_tidal_forcing.F90 diff --git a/parameterizations/lateral/MOM_MEKE.F90 b/parameterizations/lateral/MOM_MEKE.F90 new file mode 100644 index 0000000000..a44eec7727 --- /dev/null +++ b/parameterizations/lateral/MOM_MEKE.F90 @@ -0,0 +1,2051 @@ +!> Implements the Mesoscale Eddy Kinetic Energy framework +!! with topographic beta effect included in computing beta in Rhines scale + +module MOM_MEKE + +! This file is part of MOM6. See LICENSE.md for the license. +use iso_fortran_env, only : real32 + +use MOM_coms, only : PE_here +use MOM_database_comms, only : dbclient_type, dbcomms_CS_type +use MOM_debugging, only : hchksum, uvchksum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : pass_vector, pass_var +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, MOM_mesg, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : find_eta +use MOM_interpolate, only : init_external_field, time_interp_external +use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : external_field +use MOM_io, only : vardesc, var_desc, slasher +use MOM_isopycnal_slopes, only : calc_isoneutral_slopes +use MOM_restart, only : MOM_restart_CS, register_restart_field, query_initialized +use MOM_string_functions, only : lowercase +use MOM_time_manager, only : time_type_to_real +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : vertvisc_type, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_MEKE_types, only : MEKE_type + + +implicit none ; private + +#include + +public step_forward_MEKE, MEKE_init, MEKE_alloc_register_restart, MEKE_end + +! Constants for this module +integer, parameter :: NUM_FEATURES = 4 !< How many features used to predict EKE +integer, parameter :: MKE_IDX = 1 !< Index of mean kinetic energy in the feature array +integer, parameter :: SLOPE_Z_IDX = 2 !< Index of vertically averaged isopycnal slope in the feature array +integer, parameter :: RV_IDX = 3 !< Index of surface relative vorticity in the feature array +integer, parameter :: RD_DX_Z_IDX = 4 !< Index of the radius of deformation over the grid size in the feature array + +integer, parameter :: EKE_PROG = 1 !< Use prognostic equation to calculate EKE +integer, parameter :: EKE_FILE = 2 !< Read in EKE from a file +integer, parameter :: EKE_DBCLIENT = 3 !< Infer EKE using a neural network + +!> Control structure that contains MEKE parameters and diagnostics handles +type, public :: MEKE_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + ! Parameters + real :: MEKE_FrCoeff !< Efficiency of conversion of ME into MEKE [nondim] + real :: MEKE_GMcoeff !< Efficiency of conversion of PE into MEKE [nondim] + real :: MEKE_GMECoeff !< Efficiency of conversion of MEKE into ME by GME [nondim] + real :: MEKE_damping !< Local depth-independent MEKE dissipation rate [T-1 ~> s-1]. + real :: MEKE_Cd_scale !< The ratio of the bottom eddy velocity to the column mean + !! eddy velocity, i.e. sqrt(2*MEKE), [nondim]. This should be less than 1 + !! to account for the surface intensification of MEKE. + real :: MEKE_Cb !< Coefficient in the \f$\gamma_{bot}\f$ expression [nondim] + real :: MEKE_min_gamma!< Minimum value of gamma_b^2 allowed [nondim] + real :: MEKE_Ct !< Coefficient in the \f$\gamma_{bt}\f$ expression [nondim] + logical :: visc_drag !< If true use the vertvisc_type to calculate bottom drag. + logical :: MEKE_GEOMETRIC !< If true, uses the GM coefficient formulation from the GEOMETRIC + !! framework (Marshall et al., 2012) + real :: MEKE_GEOMETRIC_alpha !< The nondimensional coefficient governing the efficiency of the + !! GEOMETRIC thickness diffusion [nondim]. + logical :: MEKE_equilibrium_alt !< If true, use an alternative calculation for the + !! equilibrium value of MEKE. + logical :: MEKE_equilibrium_restoring !< If true, restore MEKE back to its equilibrium value, + !! which is calculated at each time step. + logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather + !! than the streamfunction for the MEKE GM source term. + real :: MEKE_min_depth_tot !< The minimum total thickness over which to distribute MEKE energy + !! sources from GM energy conversion [H ~> m or kg m-2]. When the total + !! thickness is less than this, the sources are scaled away. + logical :: Rd_as_max_scale !< If true the length scale can not exceed the + !! first baroclinic deformation radius. + logical :: use_old_lscale !< Use the old formula for mixing length scale. + logical :: use_min_lscale !< Use simple minimum for mixing length scale. + real :: lscale_maxval !< The ceiling on the MEKE mixing length scale when use_min_lscale is true [L ~> m]. + real :: cdrag !< The bottom drag coefficient for MEKE, times rescaling factors [H L-1 ~> nondim or kg m-3] + real :: MEKE_BGsrc !< Background energy source for MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). + real :: MEKE_dtScale !< Scale factor to accelerate time-stepping [nondim] + real :: MEKE_KhCoeff !< Scaling factor to convert MEKE into Kh [nondim] + real :: MEKE_Uscale !< MEKE velocity scale for bottom drag [L T-1 ~> m s-1] + real :: MEKE_KH !< Background lateral diffusion of MEKE [L2 T-1 ~> m2 s-1] + real :: MEKE_K4 !< Background bi-harmonic diffusivity (of MEKE) [L4 T-1 ~> m4 s-1] + real :: KhMEKE_Fac !< A factor relating MEKE%Kh to the diffusivity used for + !! MEKE itself [nondim]. + real :: viscosity_coeff_Ku !< The scaling coefficient in the expression for + !! viscosity used to parameterize lateral harmonic momentum mixing + !! by unresolved eddies represented by MEKE [nondim]. + real :: viscosity_coeff_Au !< The scaling coefficient in the expression for + !! viscosity used to parameterize lateral biharmonic momentum mixing + !! by unresolved eddies represented by MEKE [nondim]. + real :: Lfixed !< Fixed mixing length scale [L ~> m]. + real :: aDeform !< Weighting towards deformation scale of mixing length [nondim] + real :: aRhines !< Weighting towards Rhines scale of mixing length [nondim] + real :: aFrict !< Weighting towards frictional arrest scale of mixing length [nondim] + real :: aEady !< Weighting towards Eady scale of mixing length [nondim] + real :: aGrid !< Weighting towards grid scale of mixing length [nondim] + real :: MEKE_advection_factor !< A scaling in front of the advection of MEKE [nondim] + real :: MEKE_topographic_beta !< Weight for how much topographic beta is considered + !! when computing beta in Rhines scale [nondim] + real :: MEKE_restoring_rate !< Inverse of the timescale used to nudge MEKE toward its + !! equilibrium value [T-1 ~> s-1]. + logical :: MEKE_advection_bug !< If true, recover a bug in the calculation of the barotropic + !! transport for the advection of MEKE, wherein only the transports in the + !! deepest layer are used. + logical :: fixed_total_depth !< If true, use the nominal bathymetric depth as the estimate of + !! the time-varying ocean depth. Otherwise base the depth on the total + !! ocean mass per unit area. + real :: rho_fixed_total_depth !< A density used to translate the nominal bathymetric depth into an + !! estimate of the total ocean mass per unit area when MEKE_FIXED_TOTAL_DEPTH + !! is true [R ~> kg m-3] + logical :: kh_flux_enabled !< If true, lateral diffusive MEKE flux is enabled. + logical :: initialize !< If True, invokes a steady state solver to calculate MEKE. + logical :: debug !< If true, write out checksums of data for debugging + integer :: eke_src !< Enum specifying whether EKE is stepped forward prognostically (default), + !! read in from a file, or inferred via a neural network + type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output + !>@{ Diagnostic handles + integer :: id_MEKE = -1, id_Ue = -1, id_Kh = -1, id_src = -1 + integer :: id_Ub = -1, id_Ut = -1 + integer :: id_GM_src = -1, id_mom_src = -1, id_GME_snk = -1, id_decay = -1 + integer :: id_KhMEKE_u = -1, id_KhMEKE_v = -1, id_Ku = -1, id_Au = -1 + integer :: id_Le = -1, id_gamma_b = -1, id_gamma_t = -1 + integer :: id_Lrhines = -1, id_Leady = -1 + integer :: id_MEKE_equilibrium = -1 + !>@} + type(external_field) :: eke_handle !< Handle for reading in EKE from a file + ! Infrastructure + integer :: id_clock_pass !< Clock for group pass calls + type(group_pass_type) :: pass_MEKE !< Group halo pass handle for MEKE%MEKE and maybe MEKE%Kh_diff + type(group_pass_type) :: pass_Kh !< Group halo pass handle for MEKE%Kh, MEKE%Ku, and/or MEKE%Au + + ! MEKE via Machine Learning + type(dbclient_type), pointer :: client => NULL() !< Pointer to the database client + + logical :: online_analysis !< If true, post the EKE used in MOM6 at every timestep + character(len=5) :: model_key = 'mleke' !< Key where the ML-model is stored + character(len=7) :: key_suffix !< Suffix appended to every key sent to Redis + real :: eke_max !< The maximum value of EKE considered physically reasonable [L2 T-2 ~> m2 s-2] + + ! Clock ids + integer :: id_client_init !< Clock id to time initialization of the client + integer :: id_put_tensor !< Clock id to time put_tensor routine + integer :: id_run_model !< Clock id to time running of the ML model + integer :: id_unpack_tensor !< Clock id to time retrieval of EKE prediction + + ! Diagnostic ids + integer :: id_mke = -1 !< Diagnostic id for surface mean kinetic energy + integer :: id_slope_z = -1 !< Diagnostic id for vertically averaged horizontal slope magnitude + integer :: id_slope_x = -1 !< Diagnostic id for isopycnal slope in the x-direction + integer :: id_slope_y = -1 !< Diagnostic id for isopycnal slope in the y-direction + integer :: id_rv = -1 !< Diagnostic id for surface relative vorticity + +end type MEKE_CS + +contains + +!> Integrates forward-in-time the MEKE eddy energy equation. +!! See \ref section_MEKE_equations. +subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, hv, u, v, tv, Time) + type(MEKE_type), intent(inout) :: MEKE !< MEKE data. + type(ocean_grid_type), intent(inout) :: G !< Ocean grid. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. + type(vertvisc_type), intent(in) :: visc !< The vertical viscosity type. + real, intent(in) :: dt !< Model(baroclinic) time-step [T ~> s]. + type(MEKE_CS), intent(inout) :: CS !< MEKE control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: hu !< Accumulated zonal mass flux [H L2 ~> m3 or kg]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: hv !< Accumulated meridional mass flux [H L2 ~> m3 or kg] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + type(thermo_var_ptrs), intent(in) :: tv !< Type containing thermodynamic variables + type(time_type), intent(in) :: Time !< The time used for interpolating EKE + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + data_eke, & ! EKE from file [L2 T-2 ~> m2 s-2] + mass, & ! The total mass of the water column [R Z ~> kg m-2]. + I_mass, & ! The inverse of mass [R-1 Z-1 ~> m2 kg-1]. + depth_tot, & ! The depth of the water column [H ~> m or kg m-2]. + src, & ! The sum of all MEKE sources [L2 T-3 ~> W kg-1] (= m2 s-3). + MEKE_decay, & ! A diagnostic of the MEKE decay timescale [T-1 ~> s-1]. + drag_rate_visc, & ! Near-bottom velocity contribution to bottom drag [H T-1 ~> m s-1 or kg m-2 s-1] + drag_rate, & ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. + del2MEKE, & ! Laplacian of MEKE, used for bi-harmonic diffusion [T-2 ~> s-2]. + del4MEKE, & ! Time-integrated MEKE tendency arising from the biharmonic of MEKE [L2 T-2 ~> m2 s-2]. + LmixScale, & ! Eddy mixing length [L ~> m]. + barotrFac2, & ! Ratio of EKE_barotropic / EKE [nondim] + bottomFac2, & ! Ratio of EKE_bottom / EKE [nondim] + tmp, & ! Temporary variable for computation of diagnostic velocities [L T-1 ~> m s-1] + equilibrium_value ! The equilibrium value of MEKE to be calculated at each + ! time step [L2 T-2 ~> m2 s-2] + + real, dimension(SZIB_(G),SZJ_(G)) :: & + MEKE_uflux, & ! The zonal advective and diffusive flux of MEKE with units of [R Z L4 T-3 ~> kg m2 s-3]. + ! In one place, MEKE_uflux is used as temporary work space with units of [L2 T-2 ~> m2 s-2]. + Kh_u, & ! The zonal diffusivity that is actually used [L2 T-1 ~> m2 s-1]. + baroHu, & ! Depth integrated accumulated zonal mass flux [R Z L2 ~> kg]. + drag_vel_u ! A piston velocity associated with bottom drag at u-points [H T-1 ~> m s-1 or kg m-2 s-1] + real, dimension(SZI_(G),SZJB_(G)) :: & + MEKE_vflux, & ! The meridional advective and diffusive flux of MEKE with units of [R Z L4 T-3 ~> kg m2 s-3]. + ! In one place, MEKE_vflux is used as temporary work space with units of [L2 T-2 ~> m2 s-2]. + Kh_v, & ! The meridional diffusivity that is actually used [L2 T-1 ~> m2 s-1]. + baroHv, & ! Depth integrated accumulated meridional mass flux [R Z L2 ~> kg]. + drag_vel_v ! A piston velocity associated with bottom drag at v-points [H T-1 ~> m s-1 or kg m-2 s-1] + real :: Kh_here ! The local horizontal viscosity [L2 T-1 ~> m2 s-1] + real :: Inv_Kh_max ! The inverse of the local horizontal viscosity [T L-2 ~> s m-2] + real :: K4_here ! The local horizontal biharmonic viscosity [L4 T-1 ~> m4 s-1] + real :: Inv_K4_max ! The inverse of the local horizontal biharmonic viscosity [T L-4 ~> s m-4] + real :: cdrag2 ! The square of the drag coefficient times unit conversion factors [H2 L-2 ~> nondim or kg2 m-6] + real :: advFac ! The product of the advection scaling factor and 1/dt [T-1 ~> s-1] + real :: mass_neglect ! A negligible mass [R Z ~> kg m-2]. + real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. + real :: sdt ! dt to use locally [T ~> s] (could be scaled to accelerate) + real :: sdt_damp ! dt for damping [T ~> s] (sdt could be split). + logical :: use_drag_rate ! Flag to indicate drag_rate is finite + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + real(kind=real32), dimension(size(MEKE%MEKE),NUM_FEATURES) :: features_array ! The array of features + ! needed for the machine learning inference, with different + ! units for the various subarrays [various] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (.not.CS%initialized) call MOM_error(FATAL, & + "MOM_MEKE: Module must be initialized before it is used.") + + if ((CS%MEKE_Cd_scale > 0.0) .or. (CS%MEKE_Cb>0.) .or. CS%visc_drag) then + use_drag_rate = .true. + else + use_drag_rate = .false. + endif + + ! Only integrate the MEKE equations if MEKE is required. + if (.not. allocated(MEKE%MEKE)) then +! call MOM_error(FATAL, "MOM_MEKE: MEKE%MEKE is not associated!") + return + endif + + select case(CS%eke_src) + case(EKE_PROG) + if (CS%debug) then + if (allocated(MEKE%mom_src)) & + call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + if (allocated(MEKE%GME_snk)) & + call hchksum(MEKE%GME_snk, 'MEKE GME_snk', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + if (allocated(MEKE%GM_src)) & + call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + if (allocated(MEKE%MEKE)) & + call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, scale=US%L_T_to_m_s**2) + call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, scale=US%s_to_T, & + scalar_pair=.true.) + call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=0, symmetric=.true., & + scale=GV%H_to_m*(US%L_to_m**2)) + endif + + sdt = dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping + mass_neglect = GV%H_to_RZ * GV%H_subroundoff + cdrag2 = CS%cdrag**2 + + ! With a depth-dependent (and possibly strong) damping, it seems + ! advisable to use Strang splitting between the damping and diffusion. + sdt_damp = sdt ; if (CS%MEKE_KH >= 0.0 .or. CS%MEKE_K4 >= 0.) sdt_damp = 0.5*sdt + + ! Calculate depth integrated mass exchange if doing advection [R Z L2 ~> kg] + if (CS%MEKE_advection_factor>0.) then + do j=js,je ; do I=is-1,ie + baroHu(I,j) = 0. + enddo ; enddo + do k=1,nz + do j=js,je ; do I=is-1,ie + baroHu(I,j) = baroHu(I,j) + hu(I,j,k) * GV%H_to_RZ + enddo ; enddo + enddo + do J=js-1,je ; do i=is,ie + baroHv(i,J) = 0. + enddo ; enddo + do k=1,nz + do J=js-1,je ; do i=is,ie + baroHv(i,J) = baroHv(i,J) + hv(i,J,k) * GV%H_to_RZ + enddo ; enddo + enddo + if (CS%MEKE_advection_bug) then + ! This obviously incorrect code reproduces a bug in the original implementation of + ! the MEKE advection. + do j=js,je ; do I=is-1,ie + baroHu(I,j) = hu(I,j,nz) * GV%H_to_RZ + enddo ; enddo + do J=js-1,je ; do i=is,ie + baroHv(i,J) = hv(i,J,nz) * GV%H_to_RZ + enddo ; enddo + endif + endif + + ! Calculate drag_rate_visc(i,j) which accounts for the model bottom mean flow + if (CS%visc_drag .and. allocated(visc%Kv_bbl_u) .and. allocated(visc%Kv_bbl_v)) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + drag_vel_u(I,j) = 0.0 + if ((G%mask2dCu(I,j) > 0.0) .and. (visc%bbl_thick_u(I,j) > 0.0)) & + drag_vel_u(I,j) = visc%Kv_bbl_u(I,j) / visc%bbl_thick_u(I,j) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + drag_vel_v(i,J) = 0.0 + if ((G%mask2dCv(i,J) > 0.0) .and. (visc%bbl_thick_v(i,J) > 0.0)) & + drag_vel_v(i,J) = visc%Kv_bbl_v(i,J) / visc%bbl_thick_v(i,J) + enddo ; enddo + + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + drag_rate_visc(i,j) = (0.25*G%IareaT(i,j) * & + ((G%areaCu(I-1,j)*drag_vel_u(I-1,j) + & + G%areaCu(I,j)*drag_vel_u(I,j)) + & + (G%areaCv(i,J-1)*drag_vel_v(i,J-1) + & + G%areaCv(i,J)*drag_vel_v(i,J)) ) ) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + drag_rate_visc(i,j) = 0. + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do j=js-1,je+1 + do i=is-1,ie+1 ; mass(i,j) = 0.0 ; enddo + do k=1,nz ; do i=is-1,ie+1 + mass(i,j) = mass(i,j) + G%mask2dT(i,j) * (GV%H_to_RZ * h(i,j,k)) ! [R Z ~> kg m-2] + enddo ; enddo + do i=is-1,ie+1 + I_mass(i,j) = 0.0 + if (mass(i,j) > 0.0) I_mass(i,j) = 1.0 / mass(i,j) ! [R-1 Z-1 ~> m2 kg-1] + enddo + enddo + + if (CS%fixed_total_depth) then + if (GV%Boussinesq) then + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + depth_tot(i,j) = (G%bathyT(i,j) + G%Z_ref) * GV%Z_to_H + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + depth_tot(i,j) = (G%bathyT(i,j) + G%Z_ref) * CS%rho_fixed_total_depth * GV%RZ_to_H + enddo ; enddo + endif + else + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + depth_tot(i,j) = mass(i,j) * GV%RZ_to_H + enddo ; enddo + endif + + if (CS%initialize) then + call MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_mass, depth_tot) + CS%initialize = .false. + endif + + ! Calculates bottomFac2, barotrFac2 and LmixScale + call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, depth_tot, bottomFac2, barotrFac2, LmixScale) + if (CS%debug) then + if (CS%visc_drag) & + call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, & + scale=GV%H_to_mks*US%s_to_T, scalar_pair=.true.) + call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, scale=US%RZ_to_kg_m2) + call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=GV%H_to_mks*US%s_to_T) + call hchksum(bottomFac2, 'MEKE bottomFac2', G%HI) + call hchksum(barotrFac2, 'MEKE barotrFac2', G%HI) + call hchksum(LmixScale, 'MEKE LmixScale', G%HI,scale=US%L_to_m) + endif + + ! Aggregate sources of MEKE (background, frictional and GM) + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src(i,j) = CS%MEKE_BGsrc + enddo ; enddo + + if (allocated(MEKE%mom_src)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src(i,j) = src(i,j) - CS%MEKE_FrCoeff*I_mass(i,j)*MEKE%mom_src(i,j) + enddo ; enddo + endif + + if (allocated(MEKE%GME_snk)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src(i,j) = src(i,j) - CS%MEKE_GMECoeff*I_mass(i,j)*MEKE%GME_snk(i,j) + enddo ; enddo + endif + + if (allocated(MEKE%GM_src)) then + if (CS%GM_src_alt) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src(i,j) = src(i,j) - CS%MEKE_GMcoeff*MEKE%GM_src(i,j) / & + (GV%H_to_RZ * MAX(CS%MEKE_min_depth_tot, depth_tot(i,j))) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src(i,j) = src(i,j) - CS%MEKE_GMcoeff*I_mass(i,j)*MEKE%GM_src(i,j) + enddo ; enddo + endif + endif + + if (CS%MEKE_equilibrium_restoring) then + call MEKE_equilibrium_restoring(CS, G, GV, US, SN_u, SN_v, depth_tot, & + equilibrium_value) + do j=js,je ; do i=is,ie + src(i,j) = src(i,j) - CS%MEKE_restoring_rate*(MEKE%MEKE(i,j) - equilibrium_value(i,j)) + enddo ; enddo + endif + + if (CS%debug) then + call hchksum(src, "MEKE src", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T**3) + endif + + ! Increase EKE by a full time-steps worth of source + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = (MEKE%MEKE(i,j) + sdt*src(i,j))*G%mask2dT(i,j) + enddo ; enddo + + if (use_drag_rate) then + ! Calculate a viscous drag rate (includes BBL contributions from mean flow and eddies) + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + drag_rate(i,j) = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & + cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + drag_rate(i,j) = 0. + enddo ; enddo + endif + + ! First stage of Strang splitting + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + ldamping = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) + if (MEKE%MEKE(i,j) < 0.) ldamping = 0. + ! notice that the above line ensures a damping only if MEKE is positive, + ! while leaving MEKE unchanged if it is negative + MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1.0 + sdt_damp*ldamping) + MEKE_decay(i,j) = ldamping*G%mask2dT(i,j) + enddo ; enddo + + if (CS%kh_flux_enabled .or. CS%MEKE_K4 >= 0.0) then + ! Update MEKE in the halos for lateral or bi-harmonic diffusion + call cpu_clock_begin(CS%id_clock_pass) + call do_group_pass(CS%pass_MEKE, G%Domain) + call cpu_clock_end(CS%id_clock_pass) + endif + + if (CS%MEKE_K4 >= 0.0) then + ! Calculate Laplacian of MEKE using MEKE_uflux and MEKE_vflux as temporary work space. + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do I=is-2,ie+1 + ! MEKE_uflux is used here as workspace with units of [L2 T-2 ~> m2 s-2]. + MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * G%OBCmaskCu(I,j)) * & + (MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j)) + ! This would have units of [R Z L2 T-2 ~> kg s-2] + ! MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * & + ! ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & + ! (MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-2,je+1 ; do i=is-1,ie+1 + ! MEKE_vflux is used here as workspace with units of [L2 T-2 ~> m2 s-2]. + MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * G%OBCmaskCv(i,J)) * & + (MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j)) + ! This would have units of [R Z L2 T-2 ~> kg s-2] + ! MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * & + ! ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & + ! (MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j)) + enddo ; enddo + + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 ! del2MEKE has units [T-2 ~> s-2]. + del2MEKE(i,j) = G%IareaT(i,j) * & + ((MEKE_uflux(I,j) - MEKE_uflux(I-1,j)) + (MEKE_vflux(i,J) - MEKE_vflux(i,J-1))) + enddo ; enddo + + ! Bi-harmonic diffusion of MEKE + !$OMP parallel do default(shared) private(K4_here,Inv_K4_max) + do j=js,je ; do I=is-1,ie + K4_here = CS%MEKE_K4 ! [L4 T-1 ~> m4 s-1] + ! Limit Kh to avoid CFL violations. + Inv_K4_max = 64.0 * sdt * ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * & + max(G%IareaT(i,j), G%IareaT(i+1,j)))**2 + if (K4_here*Inv_K4_max > 0.3) K4_here = 0.3 / Inv_K4_max + + ! Here the units of MEKE_uflux are [R Z L4 T-3 ~> kg m2 s-3]. + MEKE_uflux(I,j) = ((K4_here * (G%dy_Cu(I,j)*G%IdxCu(I,j))) * & + ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & + (del2MEKE(i+1,j) - del2MEKE(i,j)) + enddo ; enddo + !$OMP parallel do default(shared) private(K4_here,Inv_K4_max) + do J=js-1,je ; do i=is,ie + K4_here = CS%MEKE_K4 ! [L4 T-1 ~> m4 s-1] + Inv_K4_max = 64.0 * sdt * ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * max(G%IareaT(i,j), G%IareaT(i,j+1)))**2 + if (K4_here*Inv_K4_max > 0.3) K4_here = 0.3 / Inv_K4_max + + ! Here the units of MEKE_vflux are [R Z L4 T-3 ~> kg m2 s-3]. + MEKE_vflux(i,J) = ((K4_here * (G%dx_Cv(i,J)*G%IdyCv(i,J))) * & + ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & + (del2MEKE(i,j+1) - del2MEKE(i,j)) + enddo ; enddo + ! Store change in MEKE arising from the bi-harmonic in del4MEKE [L2 T-2 ~> m2 s-2]. + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + del4MEKE(i,j) = (sdt*(G%IareaT(i,j)*I_mass(i,j))) * & + ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & + (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) + enddo ; enddo + endif ! + + if (CS%kh_flux_enabled) then + ! Lateral diffusion of MEKE + Kh_here = max(0., CS%MEKE_Kh) + !$OMP parallel do default(shared) firstprivate(Kh_here) private(Inv_Kh_max) + do j=js,je ; do I=is-1,ie + ! Limit Kh to avoid CFL violations. + if (allocated(MEKE%Kh)) & + Kh_here = max(0., CS%MEKE_Kh) + & + CS%KhMEKE_Fac*0.5*(MEKE%Kh(i,j)+MEKE%Kh(i+1,j)) + if (allocated(MEKE%Kh_diff)) & + Kh_here = max(0.,CS%MEKE_Kh) + & + CS%KhMEKE_Fac*0.5*(MEKE%Kh_diff(i,j)+MEKE%Kh_diff(i+1,j)) + Inv_Kh_max = 2.0*sdt * ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * & + max(G%IareaT(i,j),G%IareaT(i+1,j))) + if (Kh_here*Inv_Kh_max > 0.25) Kh_here = 0.25 / Inv_Kh_max + Kh_u(I,j) = Kh_here + + ! Here the units of MEKE_uflux and MEKE_vflux are [R Z L4 T-3 ~> kg m2 s-3]. + MEKE_uflux(I,j) = ((Kh_here * (G%dy_Cu(I,j)*G%IdxCu(I,j))) * & + ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & + (MEKE%MEKE(i,j) - MEKE%MEKE(i+1,j)) + enddo ; enddo + !$OMP parallel do default(shared) firstprivate(Kh_here) private(Inv_Kh_max) + do J=js-1,je ; do i=is,ie + if (allocated(MEKE%Kh)) & + Kh_here = max(0.,CS%MEKE_Kh) + CS%KhMEKE_Fac * 0.5*(MEKE%Kh(i,j)+MEKE%Kh(i,j+1)) + if (allocated(MEKE%Kh_diff)) & + Kh_here = max(0.,CS%MEKE_Kh) + CS%KhMEKE_Fac * 0.5*(MEKE%Kh_diff(i,j)+MEKE%Kh_diff(i,j+1)) + Inv_Kh_max = 2.0*sdt * ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * max(G%IareaT(i,j),G%IareaT(i,j+1))) + if (Kh_here*Inv_Kh_max > 0.25) Kh_here = 0.25 / Inv_Kh_max + Kh_v(i,J) = Kh_here + + ! Here the units of MEKE_uflux and MEKE_vflux are [R Z L4 T-3 ~> kg m2 s-3]. + MEKE_vflux(i,J) = ((Kh_here * (G%dx_Cv(i,J)*G%IdyCv(i,J))) * & + ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & + (MEKE%MEKE(i,j) - MEKE%MEKE(i,j+1)) + enddo ; enddo + if (CS%MEKE_advection_factor>0.) then + advFac = CS%MEKE_advection_factor / sdt ! [T-1 ~> s-1] + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + ! Here the units of the quantities added to MEKE_uflux are [R Z L4 T-3 ~> kg m2 s-3]. + if (baroHu(I,j)>0.) then + MEKE_uflux(I,j) = MEKE_uflux(I,j) + baroHu(I,j)*MEKE%MEKE(i,j)*advFac + elseif (baroHu(I,j)<0.) then + MEKE_uflux(I,j) = MEKE_uflux(I,j) + baroHu(I,j)*MEKE%MEKE(i+1,j)*advFac + endif + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + ! Here the units of the quantities added to MEKE_vflux are [R Z L4 T-3 ~> kg m2 s-3]. + if (baroHv(i,J)>0.) then + MEKE_vflux(i,J) = MEKE_vflux(i,J) + baroHv(i,J)*MEKE%MEKE(i,j)*advFac + elseif (baroHv(i,J)<0.) then + MEKE_vflux(i,J) = MEKE_vflux(i,J) + baroHv(i,J)*MEKE%MEKE(i,j+1)*advFac + endif + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = MEKE%MEKE(i,j) + (sdt*(G%IareaT(i,j)*I_mass(i,j))) * & + ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & + (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) + enddo ; enddo + endif ! MEKE_KH>0 + + ! Add on bi-harmonic tendency + if (CS%MEKE_K4 >= 0.0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = MEKE%MEKE(i,j) + del4MEKE(i,j) + enddo ; enddo + endif + + ! Second stage of Strang splitting + if (CS%MEKE_KH >= 0.0 .or. CS%MEKE_K4 >= 0.0) then + if (sdt>sdt_damp) then + ! Recalculate the drag rate, since MEKE has changed. + if (use_drag_rate) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + drag_rate(i,j) = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & + cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) + enddo ; enddo + endif + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + ldamping = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) + if (MEKE%MEKE(i,j) < 0.) ldamping = 0. + ! notice that the above line ensures a damping only if MEKE is positive, + ! while leaving MEKE unchanged if it is negative + MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1.0 + sdt_damp*ldamping) + MEKE_decay(i,j) = ldamping*G%mask2dT(i,j) + enddo ; enddo + endif + endif ! MEKE_KH>=0 + + if (CS%debug) then + call hchksum(MEKE%MEKE, "MEKE post-update MEKE", G%HI, haloshift=0, scale=US%L_T_to_m_s**2) + endif + + case(EKE_FILE) + call time_interp_external(CS%eke_handle, Time, data_eke, scale=US%m_s_to_L_T**2) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = data_eke(i,j) * G%mask2dT(i,j) + enddo; enddo + call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, depth_tot, bottomFac2, barotrFac2, LmixScale) + case(EKE_DBCLIENT) + call pass_vector(u, v, G%Domain) + call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, depth_tot, bottomFac2, barotrFac2, LmixScale) + call ML_MEKE_calculate_features(G, GV, US, CS, MEKE%Rd_dx_h, u, v, tv, h, dt, features_array) + call predict_meke(G, CS, SIZE(h), Time, features_array, MEKE%MEKE) + case default + call MOM_error(FATAL,"Invalid method specified for calculating EKE") + end select + + call cpu_clock_begin(CS%id_clock_pass) + call do_group_pass(CS%pass_MEKE, G%Domain) + call cpu_clock_end(CS%id_clock_pass) + + ! Calculate diffusivity for main model to use + if (CS%MEKE_KhCoeff>0.) then + if (.not.CS%MEKE_GEOMETRIC) then + if (CS%use_old_lscale) then + if (CS%Rd_as_max_scale) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%Kh(i,j) = (CS%MEKE_KhCoeff * & + sqrt(2.*max(0.,barotrFac2(i,j)*MEKE%MEKE(i,j))*G%areaT(i,j)) ) * & + min(MEKE%Rd_dx_h(i,j), 1.0) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%Kh(i,j) = CS%MEKE_KhCoeff * & + sqrt(2.*max(0., barotrFac2(i,j)*MEKE%MEKE(i,j))*G%areaT(i,j)) + enddo ; enddo + endif + else + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%Kh(i,j) = CS%MEKE_KhCoeff * & + sqrt(2.*max(0., barotrFac2(i,j)*MEKE%MEKE(i,j))) * LmixScale(i,j) + enddo ; enddo + endif + endif + endif + + ! Calculate viscosity for the main model to use + if (CS%viscosity_coeff_Ku /=0.) then + do j=js,je ; do i=is,ie + MEKE%Ku(i,j) = CS%viscosity_coeff_Ku * sqrt(2.*max(0.,MEKE%MEKE(i,j))) * LmixScale(i,j) + enddo ; enddo + endif + + if (CS%viscosity_coeff_Au /=0.) then + do j=js,je ; do i=is,ie + MEKE%Au(i,j) = CS%viscosity_coeff_Au * sqrt(2.*max(0.,MEKE%MEKE(i,j))) * LmixScale(i,j)**3 + enddo ; enddo + endif + + if (allocated(MEKE%Kh) .or. allocated(MEKE%Ku) .or. allocated(MEKE%Au)) then + call cpu_clock_begin(CS%id_clock_pass) + call do_group_pass(CS%pass_Kh, G%Domain) + call cpu_clock_end(CS%id_clock_pass) + endif + + ! Offer fields for averaging. + if (any([CS%id_Ue, CS%id_Ub, CS%id_Ut] > 0)) & + tmp(:,:) = 0. + if (CS%id_MEKE>0) call post_data(CS%id_MEKE, MEKE%MEKE, CS%diag) + if (CS%id_Ue>0) then + do j=js,je ; do i=is,ie + tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j))) + enddo ; enddo + call post_data(CS%id_Ue, tmp, CS%diag) + endif + if (CS%id_Ub>0) then + do j=js,je ; do i=is,ie + tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j) * bottomFac2(i,j))) + enddo ; enddo + call post_data(CS%id_Ub, tmp, CS%diag) + endif + if (CS%id_Ut>0) then + do j=js,je ; do i=is,ie + tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j) * barotrFac2(i,j))) + enddo ; enddo + call post_data(CS%id_Ut, tmp, CS%diag) + endif + if (CS%id_Kh>0) call post_data(CS%id_Kh, MEKE%Kh, CS%diag) + if (CS%id_Ku>0) call post_data(CS%id_Ku, MEKE%Ku, CS%diag) + if (CS%id_Au>0) call post_data(CS%id_Au, MEKE%Au, CS%diag) + if (CS%id_KhMEKE_u>0) call post_data(CS%id_KhMEKE_u, Kh_u, CS%diag) + if (CS%id_KhMEKE_v>0) call post_data(CS%id_KhMEKE_v, Kh_v, CS%diag) + if (CS%id_src>0) call post_data(CS%id_src, src, CS%diag) + if (CS%id_decay>0) call post_data(CS%id_decay, MEKE_decay, CS%diag) + if (CS%id_GM_src>0) call post_data(CS%id_GM_src, MEKE%GM_src, CS%diag) + if (CS%id_mom_src>0) call post_data(CS%id_mom_src, MEKE%mom_src, CS%diag) + if (CS%id_GME_snk>0) call post_data(CS%id_GME_snk, MEKE%GME_snk, CS%diag) + if (CS%id_Le>0) call post_data(CS%id_Le, LmixScale, CS%diag) + if (CS%id_gamma_b>0) then + do j=js,je ; do i=is,ie + bottomFac2(i,j) = sqrt(bottomFac2(i,j)) + enddo ; enddo + call post_data(CS%id_gamma_b, bottomFac2, CS%diag) + endif + if (CS%id_gamma_t>0) then + do j=js,je ; do i=is,ie + barotrFac2(i,j) = sqrt(barotrFac2(i,j)) + enddo ; enddo + call post_data(CS%id_gamma_t, barotrFac2, CS%diag) + endif + +end subroutine step_forward_MEKE + +!> Calculates the equilibrium solution where the source depends only on MEKE diffusivity +!! and there is no lateral diffusion of MEKE. +!! Results is in MEKE%MEKE. +subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_mass, depth_tot) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MEKE_CS), intent(in) :: CS !< MEKE control structure. + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: drag_rate_visc !< Mean flow velocity contribution + !! to the MEKE drag rate [H T-1 ~> m s-1 or kg m-2 s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: I_mass !< Inverse of column mass [R-1 Z-1 ~> m2 kg-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The thickness of the water column [H ~> m or kg m-2]. + + ! Local variables + real :: beta ! Combined topographic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] + real :: SN ! The local Eady growth rate [T-1 ~> s-1] + real :: bottomFac2, barotrFac2 ! Vertical structure factors [nondim] + real :: LmixScale, LRhines, LEady ! Various mixing length scales [L ~> m] + real :: KhCoeff ! A copy of MEKE_KhCoeff from the control structure [nondim] + real :: Kh ! A lateral diffusivity [L2 T-1 ~> m2 s-1] + real :: Ubg2 ! Background (tidal?) velocity squared [L2 T-2 ~> m2 s-2] + real :: cd2 ! The square of the drag coefficient times unit conversion factors [H2 L-2 ~> nondim or kg2 m-6] + real :: drag_rate ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. + real :: src ! The sum of MEKE sources [L2 T-3 ~> W kg-1] + real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. + real :: EKE, EKEmin, EKEmax, EKEerr ! [L2 T-2 ~> m2 s-2] + real :: resid, ResMin, ResMax ! Residuals [L2 T-3 ~> W kg-1] + real :: FatH ! Coriolis parameter at h points; to compute topographic beta [T-1 ~> s-1] + real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [T-1 L-1 ~> s-1 m-1] + real :: h_neglect ! A negligible thickness [H ~> m or kg m-2] + integer :: i, j, is, ie, js, je, n1, n2 + real :: tolerance ! Width of EKE bracket [L2 T-2 ~> m2 s-2]. + logical :: useSecant, debugIteration + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + debugIteration = .false. + KhCoeff = CS%MEKE_KhCoeff + Ubg2 = CS%MEKE_Uscale**2 + cd2 = CS%cdrag**2 + tolerance = 1.0e-12*US%m_s_to_L_T**2 + h_neglect = GV%H_subroundoff + +!$OMP do + do j=js,je ; do i=is,ie + ! SN = 0.25*max( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)), 0.) + ! This avoids extremes values in equilibrium solution due to bad values in SN_u, SN_v + SN = min(SN_u(I,j), SN_u(I-1,j), SN_v(i,J), SN_v(i,J-1)) + + if (CS%MEKE_equilibrium_alt) then + MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * depth_tot(i,j))**2 / cd2 + else + FatH = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))) ! Coriolis parameter at h points + + ! Since zero-bathymetry cells are masked, this avoids calculations on land + if (CS%MEKE_topographic_beta == 0. .or. (depth_tot(i,j) == 0.0)) then + beta_topo_x = 0. ; beta_topo_y = 0. + else + !### Consider different combinations of these estimates of topographic beta. + beta_topo_x = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (depth_tot(i+1,j)-depth_tot(i,j)) * G%IdxCu(I,j) & + / max(depth_tot(i+1,j), depth_tot(i,j), h_neglect) & + + (depth_tot(i,j)-depth_tot(i-1,j)) * G%IdxCu(I-1,j) & + / max(depth_tot(i,j), depth_tot(i-1,j), h_neglect) ) + beta_topo_y = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (depth_tot(i,j+1)-depth_tot(i,j)) * G%IdyCv(i,J) & + / max(depth_tot(i,j+1), depth_tot(i,j), h_neglect) + & + (depth_tot(i,j)-depth_tot(i,j-1)) * G%IdyCv(i,J-1) & + / max(depth_tot(i,j), depth_tot(i,j-1), h_neglect) ) + endif + beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + & + (G%dF_dy(i,j) + beta_topo_y)**2 ) + + if (KhCoeff*SN*I_mass(i,j)>0.) then + ! Solve resid(E) = 0, where resid = Kh(E) * (SN)^2 - damp_rate(E) E + EKEmin = 0. ! Use the trivial root as the left bracket + ResMin = 0. ! Need to detect direction of left residual + EKEmax = 0.01*US%m_s_to_L_T**2 ! First guess at right bracket + useSecant = .false. ! Start using a bisection method + + ! First find right bracket for which resid<0 + resid = 1.0*US%m_to_L**2*US%T_to_s**3 ; n1 = 0 + do while (resid>0.) + n1 = n1 + 1 + EKE = EKEmax + call MEKE_lengthScales_0d(CS, US, G%areaT(i,j), beta, depth_tot(i,j), & + MEKE%Rd_dx_h(i,j), SN, EKE, & + bottomFac2, barotrFac2, LmixScale, LRhines, LEady) + ! TODO: Should include resolution function in Kh + Kh = (KhCoeff * sqrt(2.*barotrFac2*EKE) * LmixScale) + src = Kh * (SN * SN) + drag_rate = (GV%H_to_RZ * I_mass(i,j)) * sqrt(drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) + ldamping = CS%MEKE_damping + drag_rate * bottomFac2 + resid = src - ldamping * EKE + ! if (debugIteration) then + ! write(0,*) n1, 'EKE=',EKE,'resid=',resid + ! write(0,*) 'EKEmin=',EKEmin,'ResMin=',ResMin + ! write(0,*) 'src=',src,'ldamping=',ldamping + ! write(0,*) 'gamma-b=',bottomFac2,'gamma-t=',barotrFac2 + ! write(0,*) 'drag_visc=',drag_rate_visc(i,j),'Ubg2=',Ubg2 + ! endif + if (resid>0.) then ! EKE is to the left of the root + EKEmin = EKE ! so we move the left bracket here + EKEmax = 10. * EKE ! and guess again for the right bracket + if (resid 2.e17*US%m_s_to_L_T**2) then + if (debugIteration) stop 'Something has gone very wrong' + debugIteration = .true. + resid = 1. ; n1 = 0 + EKEmin = 0. ; ResMin = 0. + EKEmax = 0.01*US%m_s_to_L_T**2 + useSecant = .false. + endif + endif + enddo ! while(resid>0.) searching for right bracket + ResMax = resid + + ! Bisect the bracket + n2 = 0 ; EKEerr = EKEmax - EKEmin + do while (EKEerr > tolerance) + n2 = n2 + 1 + if (useSecant) then + EKE = EKEmin + (EKEmax - EKEmin) * (ResMin / (ResMin - ResMax)) + else + EKE = 0.5 * (EKEmin + EKEmax) + endif + EKEerr = min( EKE-EKEmin, EKEmax-EKE ) + ! TODO: Should include resolution function in Kh + Kh = (KhCoeff * sqrt(2.*barotrFac2*EKE) * LmixScale) + src = Kh * (SN * SN) + drag_rate = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) + ldamping = CS%MEKE_damping + drag_rate * bottomFac2 + resid = src - ldamping * EKE + if (useSecant .and. resid>ResMin) useSecant = .false. + if (resid>0.) then ! EKE is to the left of the root + EKEmin = EKE ! so we move the left bracket here + if (resid EKE is exactly at the root + endif + if (n2>200) stop 'Failing to converge?' + enddo ! while(EKEmax-EKEmin>tolerance) + + else + EKE = 0. + endif + MEKE%MEKE(i,j) = EKE + endif + enddo ; enddo + +end subroutine MEKE_equilibrium + + +!< This subroutine calculates a new equilibrium value for MEKE at each time step. This is not copied into +!! MEKE%MEKE; rather, it is used as a restoring term to nudge MEKE%MEKE back to an equilibrium value +subroutine MEKE_equilibrium_restoring(CS, G, GV, US, SN_u, SN_v, depth_tot, & + equilibrium_value) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type. + type(MEKE_CS), intent(in) :: CS !< MEKE control structure. + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The thickness of the water column [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: equilibrium_value + !< Equilbrium value of MEKE to be calculated at each time step [L2 T-2 ~> m2 s-2] + + ! Local variables + real :: SN ! The local Eady growth rate [T-1 ~> s-1] + integer :: i, j, is, ie, js, je ! local indices + real :: cd2 ! The square of the drag coefficient [nondim] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + cd2 = CS%cdrag**2 + equilibrium_value(:,:) = 0.0 + +!$OMP do + do j=js,je ; do i=is,ie + ! SN = 0.25*max( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)), 0.) + ! This avoids extremes values in equilibrium solution due to bad values in SN_u, SN_v + SN = min(SN_u(I,j), SN_u(I-1,j), SN_v(i,J), SN_v(i,J-1)) + equilibrium_value(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * depth_tot(i,j))**2 / cd2 + enddo ; enddo + + if (CS%id_MEKE_equilibrium>0) call post_data(CS%id_MEKE_equilibrium, equilibrium_value, CS%diag) +end subroutine MEKE_equilibrium_restoring + +!> Calculates the eddy mixing length scale and \f$\gamma_b\f$ and \f$\gamma_t\f$ +!! functions that are ratios of either bottom or barotropic eddy energy to the +!! column eddy energy, respectively. See \ref section_MEKE_equations. +subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, EKE, depth_tot, & + bottomFac2, barotrFac2, LmixScale) + type(MEKE_CS), intent(in) :: CS !< MEKE control structure. + type(MEKE_type), intent(in) :: MEKE !< MEKE field + type(ocean_grid_type), intent(inout) :: G !< Ocean grid. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: EKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The thickness of the water column [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: bottomFac2 !< gamma_b^2 [nondim] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: barotrFac2 !< gamma_t^2 [nondim] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: LmixScale !< Eddy mixing length [L ~> m]. + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: LRhines, LEady ! Possible mixing length scales [L ~> m] + real :: beta ! Combined topographic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] + real :: SN ! The local Eady growth rate [T-1 ~> s-1] + real :: FatH ! Coriolis parameter at h points [T-1 ~> s-1] + real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [T-1 L-1 ~> s-1 m-1] + real :: h_neglect ! A negligible thickness [H ~> m or kg m-2] + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + h_neglect = GV%H_subroundoff + +!$OMP do + do j=js,je ; do i=is,ie + if (.not.CS%use_old_lscale) then + if (CS%aEady > 0.) then + SN = 0.25 * ( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)) ) + else + SN = 0. + endif + FatH = 0.25* ( ( G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1) ) + & + ( G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1) ) ) ! Coriolis parameter at h points + + ! If depth_tot is zero, then a division by zero FPE will be raised. In this + ! case, we apply Adcroft's rule of reciprocals and set the term to zero. + ! Since zero-bathymetry cells are masked, this should not affect values. + if (CS%MEKE_topographic_beta == 0. .or. (depth_tot(i,j) == 0.0)) then + beta_topo_x = 0. ; beta_topo_y = 0. + else + !### Consider different combinations of these estimates of topographic beta. + beta_topo_x = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (depth_tot(i+1,j)-depth_tot(i,j)) * G%IdxCu(I,j) & + / max(depth_tot(i+1,j), depth_tot(i,j), h_neglect) & + + (depth_tot(i,j)-depth_tot(i-1,j)) * G%IdxCu(I-1,j) & + / max(depth_tot(i,j), depth_tot(i-1,j), h_neglect) ) + beta_topo_y = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (depth_tot(i,j+1)-depth_tot(i,j)) * G%IdyCv(i,J) & + / max(depth_tot(i,j+1), depth_tot(i,j), h_neglect) + & + (depth_tot(i,j)-depth_tot(i,j-1)) * G%IdyCv(i,J-1) & + / max(depth_tot(i,j), depth_tot(i,j-1), h_neglect) ) + endif + beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + & + (G%dF_dy(i,j) + beta_topo_y)**2 ) + + else + beta = 0. + endif + ! Returns bottomFac2, barotrFac2 and LmixScale + call MEKE_lengthScales_0d(CS, US, G%areaT(i,j), beta, depth_tot(i,j), & + MEKE%Rd_dx_h(i,j), SN, MEKE%MEKE(i,j), & + bottomFac2(i,j), barotrFac2(i,j), LmixScale(i,j), & + LRhines(i,j), LEady(i,j)) + enddo ; enddo + if (CS%id_Lrhines>0) call post_data(CS%id_LRhines, LRhines, CS%diag) + if (CS%id_Leady>0) call post_data(CS%id_LEady, LEady, CS%diag) + +end subroutine MEKE_lengthScales + +!> Calculates the eddy mixing length scale and \f$\gamma_b\f$ and \f$\gamma_t\f$ +!! functions that are ratios of either bottom or barotropic eddy energy to the +!! column eddy energy, respectively. See \ref section_MEKE_equations. +subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth_tot, Rd_dx, SN, EKE, & + bottomFac2, barotrFac2, LmixScale, Lrhines, Leady) + type(MEKE_CS), intent(in) :: CS !< MEKE control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: area !< Grid cell area [L2 ~> m2] + real, intent(in) :: beta !< Planetary beta = \f$ \nabla f\f$ [T-1 L-1 ~> s-1 m-1] + real, intent(in) :: depth_tot !< The total thickness of the water column [H ~> m or kg m-2] + real, intent(in) :: Rd_dx !< Resolution Ld/dx [nondim]. + real, intent(in) :: SN !< Eady growth rate [T-1 ~> s-1]. + real, intent(in) :: EKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2]. + real, intent(out) :: bottomFac2 !< gamma_b^2 [nondim] + real, intent(out) :: barotrFac2 !< gamma_t^2 [nondim] + real, intent(out) :: LmixScale !< Eddy mixing length [L ~> m]. + real, intent(out) :: Lrhines !< Rhines length scale [L ~> m]. + real, intent(out) :: Leady !< Eady length scale [L ~> m]. + ! Local variables + real :: Lgrid, Ldeform, Lfrict ! Length scales [L ~> m] + real :: Ue ! An eddy velocity [L T-1 ~> m s-1] + + ! Length scale for MEKE derived diffusivity + Lgrid = sqrt(area) ! Grid scale + Ldeform = Lgrid * Rd_dx ! Deformation scale + Lfrict = depth_tot / CS%cdrag ! Frictional arrest scale + ! gamma_b^2 is the ratio of bottom eddy energy to mean column eddy energy + ! used in calculating bottom drag + bottomFac2 = CS%MEKE_CD_SCALE**2 + if (Lfrict*CS%MEKE_Cb>0.) bottomFac2 = bottomFac2 + 1./( 1. + CS%MEKE_Cb*(Ldeform/Lfrict) )**0.8 + bottomFac2 = max(bottomFac2, CS%MEKE_min_gamma) + ! gamma_t^2 is the ratio of barotropic eddy energy to mean column eddy energy + ! used in the velocity scale for diffusivity + barotrFac2 = 1. + if (Lfrict*CS%MEKE_Ct>0.) barotrFac2 = 1. / ( 1. + CS%MEKE_Ct*(Ldeform/Lfrict) )**0.25 + barotrFac2 = max(barotrFac2, CS%MEKE_min_gamma) + if (CS%use_old_lscale) then + if (CS%Rd_as_max_scale) then + LmixScale = min(Ldeform, Lgrid) ! The smaller of Ld or dx + else + LmixScale = Lgrid + endif + else + Ue = sqrt( 2.0 * max( 0., barotrFac2*EKE ) ) ! Barotropic eddy flow scale + Lrhines = sqrt( Ue / max( beta, 1.e-30*US%T_to_s*US%L_to_m ) ) ! Rhines scale + if (CS%aEady > 0.) then + Leady = Ue / max( SN, 1.e-15*US%T_to_s ) ! Bound Eady time-scale < 1e15 seconds + else + Leady = 0. + endif + if (CS%use_min_lscale) then + LmixScale = CS%lscale_maxval + if (CS%aDeform*Ldeform > 0.) LmixScale = min(LmixScale,CS%aDeform*Ldeform) + if (CS%aFrict *Lfrict > 0.) LmixScale = min(LmixScale,CS%aFrict *Lfrict) + if (CS%aRhines*Lrhines > 0.) LmixScale = min(LmixScale,CS%aRhines*Lrhines) + if (CS%aEady *Leady > 0.) LmixScale = min(LmixScale,CS%aEady *Leady) + if (CS%aGrid *Lgrid > 0.) LmixScale = min(LmixScale,CS%aGrid *Lgrid) + if (CS%Lfixed > 0.) LmixScale = min(LmixScale,CS%Lfixed) + else + LmixScale = 0. + if (CS%aDeform*Ldeform > 0.) LmixScale = LmixScale + 1./(CS%aDeform*Ldeform) + if (CS%aFrict *Lfrict > 0.) LmixScale = LmixScale + 1./(CS%aFrict *Lfrict) + if (CS%aRhines*Lrhines > 0.) LmixScale = LmixScale + 1./(CS%aRhines*Lrhines) + if (CS%aEady *Leady > 0.) LmixScale = LmixScale + 1./(CS%aEady *Leady) + if (CS%aGrid *Lgrid > 0.) LmixScale = LmixScale + 1./(CS%aGrid *Lgrid) + if (CS%Lfixed > 0.) LmixScale = LmixScale + 1./CS%Lfixed + if (LmixScale > 0.) LmixScale = 1. / LmixScale + endif + endif + +end subroutine MEKE_lengthScales_0d + +!> Initializes the MOM_MEKE module and reads parameters. +!! Returns True if module is to be used, otherwise returns False. +logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, MEKE, restart_CS, meke_in_dynamics) + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. + type(dbcomms_CS_type), intent(in) :: dbcomms_CS !< Database communications control structure + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics structure. + type(MEKE_CS), intent(inout) :: CS !< MEKE control structure. + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure + logical, intent( out) :: meke_in_dynamics !< If true, MEKE is stepped forward in dynamics + !! otherwise in tracer dynamics + + ! Local variables + real :: MEKE_restoring_timescale ! The timescale used to nudge MEKE toward its equilibrium value [T ~> s] + real :: cdrag ! The default bottom drag coefficient [nondim]. + character(len=200) :: eke_filename, eke_varname, inputdir + character(len=16) :: eke_source_str + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + logical :: laplacian, biharmonic, coldStart + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_MEKE" ! This module's name. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + ! Determine whether this module will be used + call get_param(param_file, mdl, "USE_MEKE", MEKE_init, default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, "", all_default=.not.MEKE_init) + call get_param(param_file, mdl, "USE_MEKE", MEKE_init, & + "If true, turns on the MEKE scheme which calculates "// & + "a sub-grid mesoscale eddy kinetic energy budget.", & + default=.false.) + if (.not. MEKE_init) return + CS%initialized = .true. + call get_param(param_file, mdl, "MEKE_IN_DYNAMICS", meke_in_dynamics, & + "If true, step MEKE forward with the dynamics"// & + "otherwise with the tracer timestep.", & + default=.true.) + + call get_param(param_file, mdl, "EKE_SOURCE", eke_source_str, & + "Determine the where EKE comes from:\n" // & + " 'prog': Calculated solving EKE equation\n"// & + " 'file': Read in from a file\n" // & + " 'dbclient': Retrieved from ML-database", default='prog') + + call MOM_mesg("MEKE_init: reading parameters ", 5) + + select case (lowercase(eke_source_str)) + case("file") + CS%eke_src = EKE_FILE + call time_interp_external_init + call get_param(param_file, mdl, "EKE_FILE", eke_filename, & + "A file in which to find the eddy kineteic energy variable.", & + default="eke_file.nc") + call get_param(param_file, mdl, "EKE_VARIABLE", eke_varname, & + "The name of the eddy kinetic energy variable to read from "//& + "EKE_FILE to use in MEKE.", & + default="eke") + call get_param(param_file, mdl, "INPUTDIR", inputdir, & + "The directory in which all input files are found.", & + default=".", do_not_log=.true.) + inputdir = slasher(inputdir) + + eke_filename = trim(inputdir) // trim(eke_filename) + CS%eke_handle = init_external_field(eke_filename, eke_varname, domain=G%Domain%mpp_domain) + case("prog") + CS%eke_src = EKE_PROG + ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mdl, "MEKE_DAMPING", CS%MEKE_damping, & + "The local depth-independent MEKE dissipation rate.", & + units="s-1", default=0.0, scale=US%T_to_s) + call get_param(param_file, mdl, "MEKE_CD_SCALE", CS%MEKE_Cd_scale, & + "The ratio of the bottom eddy velocity to the column mean "//& + "eddy velocity, i.e. sqrt(2*MEKE). This should be less than 1 "//& + "to account for the surface intensification of MEKE.", & + units="nondim", default=0.) + call get_param(param_file, mdl, "MEKE_CB", CS%MEKE_Cb, & + "A coefficient in the expression for the ratio of bottom projected "//& + "eddy energy and mean column energy (see Jansen et al. 2015).",& + units="nondim", default=25.) + call get_param(param_file, mdl, "MEKE_MIN_GAMMA2", CS%MEKE_min_gamma, & + "The minimum allowed value of gamma_b^2.",& + units="nondim", default=0.0001) + call get_param(param_file, mdl, "MEKE_CT", CS%MEKE_Ct, & + "A coefficient in the expression for the ratio of barotropic "//& + "eddy energy and mean column energy (see Jansen et al. 2015).",& + units="nondim", default=50.) + call get_param(param_file, mdl, "MEKE_GMCOEFF", CS%MEKE_GMcoeff, & + "The efficiency of the conversion of potential energy "//& + "into MEKE by the thickness mixing parameterization. "//& + "If MEKE_GMCOEFF is negative, this conversion is not "//& + "used or calculated.", units="nondim", default=-1.0) + call get_param(param_file, mdl, "MEKE_GEOMETRIC", CS%MEKE_GEOMETRIC, & + "If MEKE_GEOMETRIC is true, uses the GM coefficient formulation "//& + "from the GEOMETRIC framework (Marshall et al., 2012).", default=.false.) + call get_param(param_file, mdl, "MEKE_GEOMETRIC_ALPHA", CS%MEKE_GEOMETRIC_alpha, & + "The nondimensional coefficient governing the efficiency of the GEOMETRIC \n"//& + "thickness diffusion.", units="nondim", default=0.05) + call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_ALT", CS%MEKE_equilibrium_alt, & + "If true, use an alternative formula for computing the (equilibrium)"//& + "initial value of MEKE.", default=.false.) + call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_RESTORING", CS%MEKE_equilibrium_restoring, & + "If true, restore MEKE back to its equilibrium value, which is calculated at "//& + "each time step.", default=.false.) + if (CS%MEKE_equilibrium_restoring) then + call get_param(param_file, mdl, "MEKE_RESTORING_TIMESCALE", MEKE_restoring_timescale, & + "The timescale used to nudge MEKE toward its equilibrium value.", & + units="s", default=1e6, scale=US%s_to_T) + CS%MEKE_restoring_rate = 1.0 / MEKE_restoring_timescale + endif + + call get_param(param_file, mdl, "MEKE_FRCOEFF", CS%MEKE_FrCoeff, & + "The efficiency of the conversion of mean energy into "//& + "MEKE. If MEKE_FRCOEFF is negative, this conversion "//& + "is not used or calculated.", units="nondim", default=-1.0) + call get_param(param_file, mdl, "MEKE_GMECOEFF", CS%MEKE_GMECoeff, & + "The efficiency of the conversion of MEKE into mean energy "//& + "by GME. If MEKE_GMECOEFF is negative, this conversion "//& + "is not used or calculated.", units="nondim", default=-1.0) + call get_param(param_file, mdl, "MEKE_BGSRC", CS%MEKE_BGsrc, & + "A background energy source for MEKE.", & + units="W kg-1", default=0.0, scale=US%m_to_L**2*US%T_to_s**3) + call get_param(param_file, mdl, "MEKE_KH", CS%MEKE_Kh, & + "A background lateral diffusivity of MEKE. "//& + "Use a negative value to not apply lateral diffusion to MEKE.", & + units="m2 s-1", default=-1.0, scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "MEKE_K4", CS%MEKE_K4, & + "A lateral bi-harmonic diffusivity of MEKE. "//& + "Use a negative value to not apply bi-harmonic diffusion to MEKE.", & + units="m4 s-1", default=-1.0, scale=US%m_to_L**4*US%T_to_s) + call get_param(param_file, mdl, "MEKE_DTSCALE", CS%MEKE_dtScale, & + "A scaling factor to accelerate the time evolution of MEKE.", & + units="nondim", default=1.0) + case("dbclient") + CS%eke_src = EKE_DBCLIENT + call ML_MEKE_init(diag, G, US, Time, param_file, dbcomms_CS, CS) + case default + call MOM_error(FATAL, "Invalid method selected for calculating EKE") + end select + ! GMM, make sure all parameters used to calculated MEKE are within the above if + + call get_param(param_file, mdl, "MEKE_KHCOEFF", CS%MEKE_KhCoeff, & + "A scaling factor in the expression for eddy diffusivity "//& + "which is otherwise proportional to the MEKE velocity- "//& + "scale times an eddy mixing-length. This factor "//& + "must be >0 for MEKE to contribute to the thickness/ "//& + "and tracer diffusivity in the rest of the model.", & + units="nondim", default=1.0) + call get_param(param_file, mdl, "MEKE_USCALE", CS%MEKE_Uscale, & + "The background velocity that is combined with MEKE to "//& + "calculate the bottom drag.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "MEKE_GM_SRC_ALT", CS%GM_src_alt, & + "If true, use the GM energy conversion form S^2*N^2*kappa rather "//& + "than the streamfunction for the MEKE GM source term.", default=.false.) + call get_param(param_file, mdl, "MEKE_MIN_DEPTH_TOT", CS%MEKE_min_depth_tot, & + "The minimum total depth over which to distribute MEKE energy sources. "//& + "When the total depth is less than this, the sources are scaled away.", & + units="m", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%GM_src_alt) + call get_param(param_file, mdl, "MEKE_VISC_DRAG", CS%visc_drag, & + "If true, use the vertvisc_type to calculate the bottom "//& + "drag acting on MEKE.", default=.true.) + call get_param(param_file, mdl, "MEKE_KHTH_FAC", MEKE%KhTh_fac, & + "A factor that maps MEKE%Kh to KhTh.", units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_KHTR_FAC", MEKE%KhTr_fac, & + "A factor that maps MEKE%Kh to KhTr.", units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_KHMEKE_FAC", CS%KhMEKE_Fac, & + "A factor that maps MEKE%Kh to Kh for MEKE itself.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_OLD_LSCALE", CS%use_old_lscale, & + "If true, use the old formula for length scale which is "//& + "a function of grid spacing and deformation radius.", & + default=.false.) + call get_param(param_file, mdl, "MEKE_MIN_LSCALE", CS%use_min_lscale, & + "If true, use a strict minimum of provided length scales "//& + "rather than harmonic mean.", & + default=.false.) + call get_param(param_file, mdl, "MEKE_LSCALE_MAX_VAL", CS%lscale_maxval, & + "The ceiling on the value of the MEKE length scale when MEKE_MIN_LSCALE=True. "//& + "The default is the distance from the equator to the pole on Earth, as "//& + "estimated by enlightenment era scientists, but should probably scale with RAD_EARTH.", & + units="m", default=1.0e7, scale=US%m_to_L, do_not_log=.not.CS%use_min_lscale) + call get_param(param_file, mdl, "MEKE_RD_MAX_SCALE", CS%Rd_as_max_scale, & + "If true, the length scale used by MEKE is the minimum of "//& + "the deformation radius or grid-spacing. Only used if "//& + "MEKE_OLD_LSCALE=True", default=.false.) + call get_param(param_file, mdl, "MEKE_VISCOSITY_COEFF_KU", CS%viscosity_coeff_Ku, & + "If non-zero, is the scaling coefficient in the expression for"//& + "viscosity used to parameterize harmonic lateral momentum mixing by"//& + "unresolved eddies represented by MEKE. Can be negative to"//& + "represent backscatter from the unresolved eddies.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_VISCOSITY_COEFF_AU", CS%viscosity_coeff_Au, & + "If non-zero, is the scaling coefficient in the expression for"//& + "viscosity used to parameterize biharmonic lateral momentum mixing by"//& + "unresolved eddies represented by MEKE. Can be negative to"//& + "represent backscatter from the unresolved eddies.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_FIXED_MIXING_LENGTH", CS%Lfixed, & + "If positive, is a fixed length contribution to the expression "//& + "for mixing length used in MEKE-derived diffusivity.", & + units="m", default=0.0, scale=US%m_to_L) + call get_param(param_file, mdl, "MEKE_FIXED_TOTAL_DEPTH", CS%fixed_total_depth, & + "If true, use the nominal bathymetric depth as the estimate of the "//& + "time-varying ocean depth. Otherwise base the depth on the total ocean mass"//& + "per unit area.", default=.true.) + call get_param(param_file, mdl, "MEKE_TOTAL_DEPTH_RHO", CS%rho_fixed_total_depth, & + "A density used to translate the nominal bathymetric depth into an estimate "//& + "of the total ocean mass per unit area when MEKE_FIXED_TOTAL_DEPTH is true.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(GV%Boussinesq.or.(.not.CS%fixed_total_depth))) + + call get_param(param_file, mdl, "MEKE_ALPHA_DEFORM", CS%aDeform, & + "If positive, is a coefficient weighting the deformation scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_ALPHA_RHINES", CS%aRhines, & + "If positive, is a coefficient weighting the Rhines scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_ALPHA_EADY", CS%aEady, & + "If positive, is a coefficient weighting the Eady length scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_ALPHA_FRICT", CS%aFrict, & + "If positive, is a coefficient weighting the frictional arrest scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_ALPHA_GRID", CS%aGrid, & + "If positive, is a coefficient weighting the grid-spacing as a scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_COLD_START", coldStart, & + "If true, initialize EKE to zero. Otherwise a local equilibrium solution "//& + "is used as an initial condition for EKE.", default=.false.) + call get_param(param_file, mdl, "MEKE_BACKSCAT_RO_C", MEKE%backscatter_Ro_c, & + "The coefficient in the Rossby number function for scaling the biharmonic "//& + "frictional energy source. Setting to non-zero enables the Rossby number function.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_BACKSCAT_RO_POW", MEKE%backscatter_Ro_pow, & + "The power in the Rossby number function for scaling the biharmonic "//& + "frictional energy source.", units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_ADVECTION_FACTOR", CS%MEKE_advection_factor, & + "A scale factor in front of advection of eddy energy. Zero turns advection off. "//& + "Using unity would be normal but other values could accommodate a mismatch "//& + "between the advecting barotropic flow and the vertical structure of MEKE.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "MEKE_ADVECTION_BUG", CS%MEKE_advection_bug, & + "If true, recover a bug in the calculation of the barotropic transport for "//& + "the advection of MEKE. With the bug, only the transports in the deepest "//& + "layer are used.", default=.false., do_not_log=(CS%MEKE_advection_factor<=0.)) + call get_param(param_file, mdl, "MEKE_TOPOGRAPHIC_BETA", CS%MEKE_topographic_beta, & + "A scale factor to determine how much topographic beta is weighed in " //& + "computing beta in the expression of Rhines scale. Use 1 if full "//& + "topographic beta effect is considered; use 0 if it's completely ignored.", & + units="nondim", default=0.0) + + ! Nonlocal module parameters + call get_param(param_file, mdl, "CDRAG", cdrag, & + "CDRAG is the drag coefficient relating the magnitude of the velocity "//& + "field to the bottom stress.", units="nondim", default=0.003) + call get_param(param_file, mdl, "MEKE_CDRAG", CS%cdrag, & + "Drag coefficient relating the magnitude of the velocity "//& + "field to the bottom stress in MEKE.", units="nondim", default=cdrag, scale=US%L_to_m*GV%m_to_H) + call get_param(param_file, mdl, "LAPLACIAN", laplacian, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "BIHARMONIC", biharmonic, default=.false., do_not_log=.true.) + + if (CS%viscosity_coeff_Ku/=0. .and. .not. laplacian) call MOM_error(FATAL, & + "LAPLACIAN must be true if MEKE_VISCOSITY_COEFF_KU is true.") + + if (CS%viscosity_coeff_Au/=0. .and. .not. biharmonic) call MOM_error(FATAL, & + "BIHARMONIC must be true if MEKE_VISCOSITY_COEFF_AU is true.") + + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) + + ! Identify if any lateral diffusive processes are active + CS%kh_flux_enabled = .false. + if ((CS%MEKE_KH >= 0.0) .or. (CS%KhMEKE_FAC > 0.0) .or. (CS%MEKE_advection_factor > 0.0)) & + CS%kh_flux_enabled = .true. + +! Register fields for output from this module. + CS%diag => diag + CS%id_MEKE = register_diag_field('ocean_model', 'MEKE', diag%axesT1, Time, & + 'Mesoscale Eddy Kinetic Energy', 'm2 s-2', conversion=US%L_T_to_m_s**2) + if (.not. allocated(MEKE%MEKE)) CS%id_MEKE = -1 + CS%id_Kh = register_diag_field('ocean_model', 'MEKE_KH', diag%axesT1, Time, & + 'MEKE derived diffusivity', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + if (.not. allocated(MEKE%Kh)) CS%id_Kh = -1 + CS%id_Ku = register_diag_field('ocean_model', 'MEKE_KU', diag%axesT1, Time, & + 'MEKE derived lateral viscosity', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + if (.not. allocated(MEKE%Ku)) CS%id_Ku = -1 + CS%id_Au = register_diag_field('ocean_model', 'MEKE_AU', diag%axesT1, Time, & + 'MEKE derived lateral biharmonic viscosity', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T) + if (.not. allocated(MEKE%Au)) CS%id_Au = -1 + CS%id_Ue = register_diag_field('ocean_model', 'MEKE_Ue', diag%axesT1, Time, & + 'MEKE derived eddy-velocity scale', 'm s-1', conversion=US%L_T_to_m_s) + if (.not. allocated(MEKE%MEKE)) CS%id_Ue = -1 + CS%id_Ub = register_diag_field('ocean_model', 'MEKE_Ub', diag%axesT1, Time, & + 'MEKE derived bottom eddy-velocity scale', 'm s-1', conversion=US%L_T_to_m_s) + if (.not. allocated(MEKE%MEKE)) CS%id_Ub = -1 + CS%id_Ut = register_diag_field('ocean_model', 'MEKE_Ut', diag%axesT1, Time, & + 'MEKE derived barotropic eddy-velocity scale', 'm s-1', conversion=US%L_T_to_m_s) + if (.not. allocated(MEKE%MEKE)) CS%id_Ut = -1 + CS%id_src = register_diag_field('ocean_model', 'MEKE_src', diag%axesT1, Time, & + 'MEKE energy source', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_decay = register_diag_field('ocean_model', 'MEKE_decay', diag%axesT1, Time, & + 'MEKE decay rate', 's-1', conversion=US%s_to_T) + CS%id_GM_src = register_diag_field('ocean_model', 'MEKE_GM_src', diag%axesT1, Time, & + 'MEKE energy available from thickness mixing', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + if (.not. allocated(MEKE%GM_src)) CS%id_GM_src = -1 + CS%id_mom_src = register_diag_field('ocean_model', 'MEKE_mom_src',diag%axesT1, Time, & + 'MEKE energy available from momentum', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + if (.not. allocated(MEKE%mom_src)) CS%id_mom_src = -1 + CS%id_GME_snk = register_diag_field('ocean_model', 'MEKE_GME_snk',diag%axesT1, Time, & + 'MEKE energy lost to GME backscatter', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + if (.not. allocated(MEKE%GME_snk)) CS%id_GME_snk = -1 + CS%id_Le = register_diag_field('ocean_model', 'MEKE_Le', diag%axesT1, Time, & + 'Eddy mixing length used in the MEKE derived eddy diffusivity', 'm', conversion=US%L_to_m) + CS%id_Lrhines = register_diag_field('ocean_model', 'MEKE_Lrhines', diag%axesT1, Time, & + 'Rhines length scale used in the MEKE derived eddy diffusivity', 'm', conversion=US%L_to_m) + CS%id_Leady = register_diag_field('ocean_model', 'MEKE_Leady', diag%axesT1, Time, & + 'Eady length scale used in the MEKE derived eddy diffusivity', 'm', conversion=US%L_to_m) + CS%id_gamma_b = register_diag_field('ocean_model', 'MEKE_gamma_b', diag%axesT1, Time, & + 'Ratio of bottom-projected eddy velocity to column-mean eddy velocity', 'nondim') + CS%id_gamma_t = register_diag_field('ocean_model', 'MEKE_gamma_t', diag%axesT1, Time, & + 'Ratio of barotropic eddy velocity to column-mean eddy velocity', 'nondim') + + if (CS%kh_flux_enabled) then + CS%id_KhMEKE_u = register_diag_field('ocean_model', 'KHMEKE_u', diag%axesCu1, Time, & + 'Zonal diffusivity of MEKE', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_KhMEKE_v = register_diag_field('ocean_model', 'KHMEKE_v', diag%axesCv1, Time, & + 'Meridional diffusivity of MEKE', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + endif + + if (CS%MEKE_equilibrium_restoring) then + CS%id_MEKE_equilibrium = register_diag_field('ocean_model', 'MEKE_equilibrium', diag%axesT1, Time, & + 'Equilibrated Mesoscale Eddy Kinetic Energy', 'm2 s-2', conversion=US%L_T_to_m_s**2) + endif + + CS%id_clock_pass = cpu_clock_id('(Ocean continuity halo updates)', grain=CLOCK_ROUTINE) + + ! Detect whether this instance of MEKE_init() is at the beginning of a run + ! or after a restart. If at the beginning, we will initialize MEKE to a local + ! equilibrium. + CS%initialize = .not.query_initialized(MEKE%MEKE, "MEKE", restart_CS) + if (coldStart) CS%initialize = .false. + if (CS%initialize) call MOM_error(WARNING, & + "MEKE_init: Initializing MEKE with a local equilibrium balance.") + + ! Set up group passes. In the case of a restart, these fields need a halo update now. + if (allocated(MEKE%MEKE)) then + call create_group_pass(CS%pass_MEKE, MEKE%MEKE, G%Domain) + if (allocated(MEKE%Kh_diff)) call create_group_pass(CS%pass_MEKE, MEKE%Kh_diff, G%Domain) + if (.not.CS%initialize) call do_group_pass(CS%pass_MEKE, G%Domain) + endif + if (allocated(MEKE%Kh)) call create_group_pass(CS%pass_Kh, MEKE%Kh, G%Domain) + if (allocated(MEKE%Ku)) call create_group_pass(CS%pass_Kh, MEKE%Ku, G%Domain) + if (allocated(MEKE%Au)) call create_group_pass(CS%pass_Kh, MEKE%Au, G%Domain) + + if (allocated(MEKE%Kh) .or. allocated(MEKE%Ku) .or. allocated(MEKE%Au)) & + call do_group_pass(CS%pass_Kh, G%Domain) + +end function MEKE_init + +!> Initializer for the variant of MEKE that uses ML to predict eddy kinetic energy +subroutine ML_MEKE_init(diag, G, US, Time, param_file, dbcomms_CS, CS) + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics structure. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(time_type), intent(in) :: Time !< The current model time. + type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. + type(dbcomms_CS_type), intent(in) :: dbcomms_CS !< Control structure for database communication + type(MEKE_CS), intent(inout) :: CS !< Control structure for this module + + character(len=200) :: inputdir, backend, model_filename + integer :: db_return_code, batch_size + character(len=40) :: mdl = "MOM_ML_MEKE" + + ! Store pointers in control structure + write(CS%key_suffix, '(A,I6.6)') '_', PE_here() + ! Put some basic information into the database + db_return_code = 0 + db_return_code = CS%client%put_tensor("meta"//CS%key_suffix, & + REAL([G%isd_global, G%idg_offset, G%jsd_global, G%jdg_offset]),[4]) + db_return_code + db_return_code = CS%client%put_tensor("geolat"//CS%key_suffix, G%geoLatT, shape(G%geoLatT)) + db_return_code + db_return_code = CS%client%put_tensor("geolon"//CS%key_suffix, G%geoLonT, shape(G%geoLonT)) + db_return_code + db_return_code = CS%client%put_tensor("EKE_shape"//CS%key_suffix, shape(G%geolonT), [2]) + db_return_code + + if (CS%client%SR_error_parser(db_return_code)) call MOM_error(FATAL, "Putting metadata into the database failed") + + call read_param(param_file, "INPUTDIR", inputdir) + inputdir = slasher(inputdir) + + call get_param(param_file, mdl, "BATCH_SIZE", batch_size, "Batch size to use for inference", default=1) + call get_param(param_file, mdl, "EKE_BACKEND", backend, & + "The computational backend to use for EKE inference (CPU or GPU)", default="GPU") + call get_param(param_file, mdl, "EKE_MODEL", model_filename, & + "Filename of the a saved pyTorch model to use", fail_if_missing = .true.) + call get_param(param_file, mdl, "EKE_MAX", CS%eke_max, & + "Maximum value of EKE allowed when inferring EKE", & + units="m2 s-2", default=2., scale=US%L_T_to_m_s**2) + + ! Set the machine learning model + if (dbcomms_CS%colocated) then + if (modulo(PE_here(),dbcomms_CS%colocated_stride) == 0) then + db_return_code = CS%client%set_model_from_file(CS%model_key, trim(inputdir)//trim(model_filename), & + "TORCH", backend, batch_size=batch_size) + endif + else + if (is_root_pe()) then + db_return_code = CS%client%set_model_from_file(CS%model_key, trim(inputdir)//trim(model_filename), & + "TORCH", backend, batch_size=batch_size) + endif + endif + if (CS%client%SR_error_parser(db_return_code)) then + call MOM_error(FATAL, "MEKE: set_model failed") + endif + + call get_param(param_file, mdl, "ONLINE_ANALYSIS", CS%online_analysis, & + "If true, post EKE used in MOM6 to the database for analysis", default=.true.) + + ! Set various clock ids + CS%id_client_init = cpu_clock_id('(ML_MEKE client init)', grain=CLOCK_ROUTINE) + CS%id_put_tensor = cpu_clock_id('(ML_MEKE put tensor)', grain=CLOCK_ROUTINE) + CS%id_run_model = cpu_clock_id('(ML_MEKE run model)', grain=CLOCK_ROUTINE) + CS%id_unpack_tensor = cpu_clock_id('(ML_MEKE unpack tensor )', grain=CLOCK_ROUTINE) + + ! Diagnostics for ML_MEKE + CS%id_mke = register_diag_field('ocean_model', 'MEKE_MKE', diag%axesT1, Time, & + 'Surface mean (resolved) kinetic energy used in MEKE', 'm2 s-2', conversion=US%L_T_to_m_s**2) + CS%id_slope_z= register_diag_field('ocean_model', 'MEKE_slope_z', diag%axesT1, Time, & + 'Vertically averaged isopyncal slope magnitude used in MEKE', 'nondim', conversion=US%Z_to_L) + CS%id_slope_x= register_diag_field('ocean_model', 'MEKE_slope_x', diag%axesCui, Time, & + 'Isopycnal slope in the x-direction used in MEKE', 'nondim', conversion=US%Z_to_L) + CS%id_slope_y= register_diag_field('ocean_model', 'MEKE_slope_y', diag%axesCvi, Time, & + 'Isopycnal slope in the y-direction used in MEKE', 'nondim', conversion=US%Z_to_L) + CS%id_rv = register_diag_field('ocean_model', 'MEKE_RV', diag%axesT1, Time, & + 'Surface relative vorticity used in MEKE', 's-1', conversion=US%s_to_T) + +end subroutine ML_MEKE_init + +!> Calculate the various features used for the machine learning prediction +subroutine ML_MEKE_calculate_features(G, GV, US, CS, Rd_dx_h, u, v, tv, h, dt, features_array) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MEKE_CS), intent(in) :: CS !< Control structure for MEKE + real, dimension(SZI_(G),SZJ_(G)), intent(in ) :: Rd_dx_h !< Rossby radius of deformation over + !! the grid length scale [nondim] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + type(thermo_var_ptrs), intent(in) :: tv !< Type containing thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, intent(in) :: dt !< Model(baroclinic) time-step [T ~> s]. + real(kind=real32), dimension(SIZE(h),num_features), intent( out) :: features_array + !< The array of features needed for machine + !! learning inference, with different units + !! for the various subarrays [various] + + real, dimension(SZI_(G),SZJ_(G)) :: mke ! Surface kinetic energy per unit mass [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJ_(G)) :: slope_z ! Vertically averaged isoneutral slopes [Z L-1 ~> nondim] + real, dimension(SZIB_(G),SZJB_(G)) :: rv_z ! Surface relative vorticity [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)) :: rv_z_t ! Surface relative vorticity interpolated to tracer points [T-1 ~> s-1] + + real, dimension(SZIB_(G),SZJ_(G), SZK_(G)) :: h_u ! Thickness at u point [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G), SZK_(G)) :: h_v ! Thickness at v point [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1) :: slope_x ! Isoneutral slope at U point [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1) :: slope_y ! Isoneutral slope at V point [Z L-1 ~> nondim] + real, dimension(SZIB_(G),SZJ_(G)) :: slope_x_vert_avg ! Isoneutral slope at U point [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G)) :: slope_y_vert_avg ! Isoneutral slope at V point [Z L-1 ~> nondim] + real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: e ! The interface heights relative to mean sea level [Z ~> m]. + real :: slope_t ! Slope interpolated to thickness points [Z L-1 ~> nondim] + real :: u_t, v_t ! u and v interpolated to thickness points [L T-1 ~> m s-1] + real :: dvdx, dudy ! Components of relative vorticity [T-1 ~> s-1] + real :: a_e, a_w, a_n, a_s ! Fractional areas of neighboring cells for interpolating velocities [nondim] + real :: Idenom ! A normalizing factor in calculating weighted averages of areas [L-2 ~> m-2] + real :: sum_area ! A sum of adjacent cell areas [L2 ~> m2] + + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + + 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 + + ! Calculate various features for used to infer eddy kinetic energy + ! Linear interpolation to estimate thickness at a velocity points + do k=1,nz; do j=js-1,je+1; do i=is-1,ie+1 + h_u(I,j,k) = 0.5*(h(i,j,k)*G%mask2dT(i,j) + h(i+1,j,k)*G%mask2dT(i+1,j)) + GV%Angstrom_H + h_v(i,J,k) = 0.5*(h(i,j,k)*G%mask2dT(i,j) + h(i,j+1,k)*G%mask2dT(i,j+1)) + GV%Angstrom_H + enddo; enddo; enddo; + call find_eta(h, tv, G, GV, US, e, halo_size=2) + ! Note the hard-coded dimenisional constant in the following line. + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*1.e-7*GV%m2_s_to_HZ_T, .false., slope_x, slope_y) + call pass_vector(slope_x, slope_y, G%Domain) + do j=js-1,je+1; do i=is-1,ie+1 + slope_x_vert_avg(I,j) = vertical_average_interface(slope_x(i,j,:), h_u(i,j,:), GV%H_subroundoff) + slope_y_vert_avg(i,J) = vertical_average_interface(slope_y(i,j,:), h_v(i,j,:), GV%H_subroundoff) + enddo; enddo + slope_z(:,:) = 0. + + call pass_vector(slope_x_vert_avg, slope_y_vert_avg, G%Domain) + do j=js,je; do i=is,ie + ! Calculate weights for interpolation from velocity points to h points + sum_area = G%areaCu(I-1,j) + G%areaCu(I,j) + if (sum_area>0.0) then + Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) + a_w = G%areaCu(I-1,j) * Idenom + a_e = G%areaCu(I,j) * Idenom + else + a_w = 0.0 ; a_e = 0.0 + endif + + sum_area = G%areaCv(i,J-1) + G%areaCv(i,J) + if (sum_area>0.0) then + Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) + a_s = G%areaCv(i,J-1) * Idenom + a_n = G%areaCv(i,J) * Idenom + else + a_s = 0.0 ; a_n = 0.0 + endif + + ! Calculate mean kinetic energy + u_t = a_e*u(I,j,1)+a_w*u(I-1,j,1) + v_t = a_n*v(i,J,1)+a_s*v(i,J-1,1) + mke(i,j) = 0.5*( u_t*u_t + v_t*v_t ) + + ! Calculate the magnitude of the slope + slope_t = slope_x_vert_avg(I,j)*a_e+slope_x_vert_avg(I-1,j)*a_w + slope_z(i,j) = sqrt(slope_t*slope_t) + slope_t = slope_y_vert_avg(i,J)*a_n+slope_y_vert_avg(i,J-1)*a_s + slope_z(i,j) = 0.5*(slope_z(i,j) + sqrt(slope_t*slope_t))*G%mask2dT(i,j) + enddo; enddo + call pass_var(slope_z, G%Domain) + + ! Calculate relative vorticity + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + dvdx = (v(i+1,J,1)*G%dyCv(i+1,J) - v(i,J,1)*G%dyCv(i,J)) + dudy = (u(I,j+1,1)*G%dxCu(I,j+1) - u(I,j,1)*G%dxCu(I,j)) + ! Assumed no slip + rv_z(I,J) = (2.0-G%mask2dBu(I,J)) * (dvdx - dudy) * G%IareaBu(I,J) + enddo; enddo + ! Interpolate RV to t-point, revisit this calculation to include metrics + do j=js,je; do i=is,ie + rv_z_t(i,j) = 0.25*(rv_z(i-1,j) + rv_z(i,j) + rv_z(i-1,j-1) + rv_z(i,j-1)) + enddo; enddo + + + ! Construct the feature array + features_array(:,mke_idx) = pack(mke,.true.) + features_array(:,slope_z_idx) = pack(slope_z,.true.) + features_array(:,rd_dx_z_idx) = pack(Rd_dx_h,.true.) + features_array(:,rv_idx) = pack(rv_z_t,.true.) + + if (CS%id_rv>0) call post_data(CS%id_rv, rv_z, CS%diag) + if (CS%id_mke>0) call post_data(CS%id_mke, mke, CS%diag) + if (CS%id_slope_z>0) call post_data(CS%id_slope_z, slope_z, CS%diag) + if (CS%id_slope_x>0) call post_data(CS%id_slope_x, slope_x, CS%diag) + if (CS%id_slope_y>0) call post_data(CS%id_slope_y, slope_y, CS%diag) +end subroutine ML_MEKE_calculate_features + +!> Use the machine learning interface to predict EKE +subroutine predict_MEKE(G, CS, npts, Time, features_array, MEKE) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid + type(MEKE_CS), intent(in ) :: CS !< Control structure for MEKE + integer, intent(in ) :: npts !< Number of T-grid cells on the local + !! domain + type(time_type), intent(in ) :: Time !< The current model time + real(kind=real32), dimension(npts,num_features), intent(in ) :: features_array + !< The array of features needed for machine + !! learning inference + real, dimension(SZI_(G),SZJ_(G)), intent( out) :: MEKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2] + integer :: db_return_code + character(len=255), dimension(1) :: model_out, model_in + character(len=255) :: time_suffix + real(kind=real32), dimension(SIZE(MEKE)) :: MEKE_vec + + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec +!> Use the database client to call a machine learning model to predict eddy kinetic energy + call cpu_clock_begin(CS%id_put_tensor) + db_return_code = CS%client%put_tensor("features"//CS%key_suffix, features_array, shape(features_array)) + call cpu_clock_end(CS%id_put_tensor) + + ! Run the ML model to predict EKE and return the result + model_out(1) = "EKE"//CS%key_suffix + model_in(1) = "features"//CS%key_suffix + call cpu_clock_begin(CS%id_run_model) + db_return_code = CS%client%run_model(CS%model_key, model_in, model_out) + call cpu_clock_end(CS%id_run_model) + if (CS%client%SR_error_parser(db_return_code)) then + call MOM_error(FATAL, "MEKE: run_model failed") + endif + call cpu_clock_begin(CS%id_unpack_tensor) + db_return_code = CS%client%unpack_tensor( model_out(1), MEKE_vec, shape(MEKE_vec) ) + call cpu_clock_end(CS%id_unpack_tensor) + + MEKE = reshape(MEKE_vec, shape(MEKE)) + do j=js,je; do i=is,ie + MEKE(i,j) = MIN(MAX(exp(MEKE(i,j)),0.),CS%eke_max) + enddo; enddo + call pass_var(MEKE,G%Domain) + + if (CS%online_analysis) then + write(time_suffix,"(F16.0)") time_type_to_real(Time) + db_return_code = CS%client%put_tensor(trim("EKE_")//trim(adjustl(time_suffix))//CS%key_suffix, MEKE, shape(MEKE)) + endif +end subroutine predict_MEKE + +!> Compute average of interface quantities weighted by the thickness of the surrounding layers +real function vertical_average_interface(h, w, h_min) + + real, dimension(:), intent(in) :: h !< Layer Thicknesses [H ~> m or kg m-2] + real, dimension(:), intent(in) :: w !< Quantity to average [arbitrary] + real, intent(in) :: h_min !< The vanishingly small layer thickness [H ~> m or kg m-2] + + real :: htot ! Twice the sum of the layer thicknesses interpolated to interior interfaces [H ~> m or kg m-2] + real :: inv_htot ! The inverse of htot [H-1 ~> m-1 or m2 kg-1] + integer :: k, nk + + nk = size(h) + htot = h_min + do k=2,nk + htot = htot + (h(k-1)+h(k)) + enddo + inv_htot = 1./htot + + vertical_average_interface = 0. + do K=2,nk + vertical_average_interface = vertical_average_interface + (w(k)*(h(k-1)+h(k)))*inv_htot + enddo +end function vertical_average_interface + +!> Allocates memory and register restart fields for the MOM_MEKE module. +subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) +! Arguments + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + + ! Local variables + real :: MEKE_GMcoeff, MEKE_FrCoeff, MEKE_GMECoeff ! Coefficients for various terms [nondim] + real :: MEKE_KHCoeff, MEKE_viscCoeff_Ku, MEKE_viscCoeff_Au ! Coefficients for various terms [nondim] + logical :: Use_KH_in_MEKE + logical :: useMEKE + integer :: isd, ied, jsd, jed + +! Determine whether this module will be used + useMEKE = .false.; call read_param(param_file,"USE_MEKE",useMEKE) + +! Read these parameters to determine what should be in the restarts + MEKE_GMcoeff = -1. ; call read_param(param_file,"MEKE_GMCOEFF",MEKE_GMcoeff) + MEKE_FrCoeff = -1. ; call read_param(param_file,"MEKE_FRCOEFF",MEKE_FrCoeff) + MEKE_GMEcoeff = -1. ; call read_param(param_file,"MEKE_GMECOEFF",MEKE_GMEcoeff) + MEKE_KhCoeff = 1. ; call read_param(param_file,"MEKE_KHCOEFF",MEKE_KhCoeff) + MEKE_viscCoeff_Ku = 0. ; call read_param(param_file,"MEKE_VISCOSITY_COEFF_KU",MEKE_viscCoeff_Ku) + MEKE_viscCoeff_Au = 0. ; call read_param(param_file,"MEKE_VISCOSITY_COEFF_AU",MEKE_viscCoeff_Au) + Use_KH_in_MEKE = .false. ; call read_param(param_file,"USE_KH_IN_MEKE", Use_KH_in_MEKE) + + if (.not. useMEKE) return + +! Allocate memory + call MOM_mesg("MEKE_alloc_register_restart: allocating and registering", 5) + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed + allocate(MEKE%MEKE(isd:ied,jsd:jed), source=0.0) + call register_restart_field(MEKE%MEKE, "MEKE", .false., restart_CS, & + longname="Mesoscale Eddy Kinetic Energy", units="m2 s-2", conversion=US%L_T_to_m_s**2) + + if (MEKE_GMcoeff>=0.) allocate(MEKE%GM_src(isd:ied,jsd:jed), source=0.0) + if (MEKE_FrCoeff>=0. .or. MEKE_GMECoeff>=0.) & + allocate(MEKE%mom_src(isd:ied,jsd:jed), source=0.0) + if (MEKE_GMECoeff>=0.) allocate(MEKE%GME_snk(isd:ied,jsd:jed), source=0.0) + if (MEKE_KhCoeff>=0.) then + allocate(MEKE%Kh(isd:ied,jsd:jed), source=0.0) + call register_restart_field(MEKE%Kh, "MEKE_Kh", .false., restart_CS, & + longname="Lateral diffusivity from Mesoscale Eddy Kinetic Energy", & + units="m2 s-1", conversion=US%L_to_m**2*US%s_to_T) + endif + allocate(MEKE%Rd_dx_h(isd:ied,jsd:jed), source=0.0) + if (MEKE_viscCoeff_Ku/=0.) then + allocate(MEKE%Ku(isd:ied,jsd:jed), source=0.0) + call register_restart_field(MEKE%Ku, "MEKE_Ku", .false., restart_CS, & + longname="Lateral viscosity from Mesoscale Eddy Kinetic Energy", & + units="m2 s-1", conversion=US%L_to_m**2*US%s_to_T) + endif + if (Use_Kh_in_MEKE) then + allocate(MEKE%Kh_diff(isd:ied,jsd:jed), source=0.0) + call register_restart_field(MEKE%Kh_diff, "MEKE_Kh_diff", .false., restart_CS, & + longname="Copy of thickness diffusivity for diffusing MEKE", & + units="m2 s-1", conversion=US%L_to_m**2*US%s_to_T) + endif + + if (MEKE_viscCoeff_Au/=0.) then + allocate(MEKE%Au(isd:ied,jsd:jed), source=0.0) + call register_restart_field(MEKE%Au, "MEKE_Au", .false., restart_CS, & + longname="Lateral biharmonic viscosity from Mesoscale Eddy Kinetic Energy", & + units="m4 s-1", conversion=US%L_to_m**4*US%s_to_T) + endif + +end subroutine MEKE_alloc_register_restart + +!> Deallocates any variables allocated in MEKE_alloc_register_restart. +subroutine MEKE_end(MEKE) + type(MEKE_type), intent(inout) :: MEKE !< A structure with MEKE-related fields. + + ! NOTE: MEKE will always be allocated by MEKE_init, even if MEKE is disabled. + ! So these must all be conditional, even though MEKE%MEKE and MEKE%Rd_dx_h + ! are always allocated (when MEKE is enabled) + + if (allocated(MEKE%Au)) deallocate(MEKE%Au) + if (allocated(MEKE%Kh_diff)) deallocate(MEKE%Kh_diff) + if (allocated(MEKE%Ku)) deallocate(MEKE%Ku) + if (allocated(MEKE%Rd_dx_h)) deallocate(MEKE%Rd_dx_h) + if (allocated(MEKE%Kh)) deallocate(MEKE%Kh) + if (allocated(MEKE%GME_snk)) deallocate(MEKE%GME_snk) + if (allocated(MEKE%mom_src)) deallocate(MEKE%mom_src) + if (allocated(MEKE%GM_src)) deallocate(MEKE%GM_src) + if (allocated(MEKE%MEKE)) deallocate(MEKE%MEKE) +end subroutine MEKE_end + +!> \namespace mom_meke +!! +!! \section section_MEKE The Mesoscale Eddy Kinetic Energy (MEKE) framework +!! +!! The MEKE framework accounts for the mean potential energy removed by +!! the first order closures used to parameterize mesoscale eddies. +!! It requires closure at the second order, namely dissipation and transport +!! of eddy energy. +!! +!! Monitoring the sub-grid scale eddy energy budget provides a means to predict +!! a sub-grid eddy-velocity scale which can be used in the lower order closures. +!! +!! \subsection section_MEKE_equations MEKE equations +!! +!! The eddy kinetic energy equation is: +!! \f[ \partial_{\tilde{t}} E = +!! \overbrace{ \dot{E}_b + \gamma_\eta \dot{E}_\eta + \gamma_v \dot{E}_v +!! }^\text{sources} +!! - \overbrace{ ( \lambda + C_d | U_d | \gamma_b^2 ) E +!! }^\text{local dissipation} +!! + \overbrace{ \nabla \cdot ( ( \kappa_E + \gamma_M \kappa_M ) \nabla E +!! - \kappa_4 \nabla^3 E ) +!! }^\text{smoothing} +!! \f] +!! where \f$ E \f$ is the eddy kinetic energy (variable MEKE) with units of +!! m2s-2, +!! and \f$\tilde{t} = a t\f$ is a scaled time. The non-dimensional factor +!! \f$ a\geq 1 \f$ is used to accelerate towards equilibrium. +!! +!! The MEKE equation is two-dimensional and obtained by depth averaging the +!! the three-dimensional eddy energy equation. In the following expressions +!! \f$ \left< \phi \right> = \frac{1}{H} \int^\eta_{-D} \phi \, dz \f$ maps +!! three dimensional terms into the two-dimensional quantities needed. +!! +!! \subsubsection section_MEKE_source_terms MEKE source terms +!! +!! The source term \f$ \dot{E}_b \f$ is a constant background source +!! of energy intended to avoid the limit \f$E\rightarrow 0\f$. +!! +!! The "GM" source term +!! \f[ \dot{E}_\eta = - \left< \overline{w^\prime b^\prime} \right> +!! = \left< \kappa_h N^2S^2 \right> +!! \approx \left< \kappa_h g\prime |\nabla_\sigma \eta|^2 \right>\f] +!! equals the mean potential energy removed by the Gent-McWilliams closure, +!! and is excluded/included in the MEKE budget by the efficiency parameter +!! \f$ \gamma_\eta \in [0,1] \f$. +!! +!! The "frictional" source term +!! \f[ \dot{E}_{v} = \left< \partial_i u_j \tau_{ij} \right> \f] +!! equals the mean kinetic energy removed by lateral viscous fluxes, and +!! is excluded/included in the MEKE budget by the efficiency parameter +!! \f$ \gamma_v \in [0,1] \f$. +!! +!! \subsubsection section_MEKE_dissipation_terms MEKE dissipation terms +!! +!! The local dissipation of \f$ E \f$ is parameterized through a linear +!! damping, \f$\lambda\f$, and bottom drag, \f$ C_d | U_d | \gamma_b^2 \f$. +!! The \f$ \gamma_b \f$ accounts for the weak projection of the column-mean +!! eddy velocity to the bottom. In other words, the bottom velocity is +!! estimated as \f$ \gamma_b U_e \f$. +!! The bottom drag coefficient, \f$ C_d \f$ is the same as that used in the bottom +!! friction in the mean model equations. +!! +!! The bottom drag velocity scale, \f$ U_d \f$, has contributions from the +!! resolved state and \f$ E \f$: +!! \f[ U_d = \sqrt{ U_b^2 + |u|^2_{z=-D} + |\gamma_b U_e|^2 } .\f] +!! where the eddy velocity scale, \f$ U_e \f$, is given by: +!! \f[ U_e = \sqrt{ 2 E } .\f] +!! \f$ U_b \f$ is a constant background bottom velocity scale and is +!! typically not used (i.e. set to zero). +!! +!! Following Jansen et al., 2015, the projection of eddy energy on to the bottom +!! is given by the ratio of bottom energy to column mean energy: +!! \f[ +!! \gamma_b^2 = \frac{E_b}{E} = \gamma_{d0} +!! + \left( 1 + c_{b} \frac{L_d}{L_f} \right)^{-\frac{4}{5}} +!! , +!! \f] +!! \f[ +!! \gamma_b^2 \leftarrow \max{\left( \gamma_b^2, \gamma_{min}^2 \right)} +!! . +!! \f] +!! +!! \subsection section_MEKE_smoothing MEKE smoothing terms +!! +!! \f$ E \f$ is laterally diffused by a diffusivity \f$ \kappa_E + \gamma_M +!! \kappa_M \f$ where \f$ \kappa_E \f$ is a constant diffusivity and the term +!! \f$ \gamma_M \kappa_M \f$ is a "self diffusion" using the diffusivity +!! calculated in the section \ref section_MEKE_diffusivity. +!! \f$ \kappa_4 \f$ is a constant bi-harmonic diffusivity. +!! +!! \subsection section_MEKE_diffusivity Diffusivity derived from MEKE +!! +!! The predicted eddy velocity scale, \f$ U_e \f$, can be combined with a +!! mixing length scale to form a diffusivity. +!! The primary use of a MEKE derived diffusivity is for use in thickness +!! diffusion (module mom_thickness_diffuse) and optionally in along +!! isopycnal mixing of tracers (module mom_tracer_hor_diff). +!! The original form used (enabled with MEKE_OLD_LSCALE=True): +!! +!! \f[ \kappa_M = \gamma_\kappa \sqrt{ \gamma_t^2 U_e^2 A_\Delta } \f] +!! +!! where \f$ A_\Delta \f$ is the area of the grid cell. +!! Following Jansen et al., 2015, we now use +!! +!! \f[ \kappa_M = \gamma_\kappa l_M \sqrt{ \gamma_t^2 U_e^2 } \f] +!! +!! where \f$ \gamma_\kappa \in [0,1] \f$ is a non-dimensional factor and, +!! following Jansen et al., 2015, \f$\gamma_t^2\f$ is the ratio of barotropic +!! eddy energy to column mean eddy energy given by +!! \f[ +!! \gamma_t^2 = \frac{E_t}{E} = \left( 1 + c_{t} \frac{L_d}{L_f} \right)^{-\frac{1}{4}} +!! , +!! \f] +!! \f[ +!! \gamma_t^2 \leftarrow \max{\left( \gamma_t^2, \gamma_{min}^2 \right)} +!! . +!! \f] +!! +!! The length-scale is a configurable combination of multiple length scales: +!! +!! \f[ +!! l_M = \left( +!! \frac{\alpha_d}{L_d} +!! + \frac{\alpha_f}{L_f} +!! + \frac{\alpha_R}{L_R} +!! + \frac{\alpha_e}{L_e} +!! + \frac{\alpha_\Delta}{L_\Delta} +!! + \frac{\delta[L_c]}{L_c} +!! \right)^{-1} +!! \f] +!! +!! where +!! +!! \f{eqnarray*}{ +!! L_d & = & \sqrt{\frac{c_g^2}{f^2+2\beta c_g}} \sim \frac{ c_g }{f} \\\\ +!! L_R & = & \sqrt{\frac{U_e}{\beta^*}} \\\\ +!! L_e & = & \frac{U_e}{|S| N} \\\\ +!! L_f & = & \frac{H}{c_d} \\\\ +!! L_\Delta & = & \sqrt{A_\Delta} . +!! \f} +!! +!! \f$L_c\f$ is a constant and \f$\delta[L_c]\f$ is the impulse function so that the term +!! \f$\frac{\delta[L_c]}{L_c}\f$ evaluates to \f$\frac{1}{L_c}\f$ when \f$L_c\f$ is non-zero +!! but is dropped if \f$L_c=0\f$. +!! +!! \f$\beta^*\f$ is the effective \f$\beta\f$ that combines both the planetary vorticity +!! gradient (i.e. \f$\beta=\nabla f\f$) and the topographic \f$\beta\f$ effect, +!! with the latter weighed by a weighting constant, \f$c_\beta\f$, that varies +!! from 0 to 1, so that \f$c_\beta=0\f$ means the topographic \f$\beta\f$ effect is ignored, +!! while \f$c_\beta=1\f$ means it is fully considered. The new \f$\beta^*\f$ therefore +!! takes the form of +!! +!! \f[ +!! \beta^* = \sqrt{( \partial_xf - c_\beta\frac{f}{D}\partial_xD )^2 + +!! ( \partial_yf - c_\beta\frac{f}{D}\partial_yD )^2} +!! \f] +!! where \f$D\f$ is water column depth at T points. +!! +!! \subsection section_MEKE_viscosity Viscosity derived from MEKE +!! +!! As for \f$ \kappa_M \f$, the predicted eddy velocity scale can be +!! used to form a harmonic eddy viscosity, +!! +!! \f[ \kappa_u = \gamma_u \sqrt{ U_e^2 A_\Delta } \f] +!! +!! as well as a biharmonic eddy viscosity, +!! +!! \f[ \kappa_4 = \gamma_4 \sqrt{ U_e^2 A_\Delta^3 } \f] +!! +!! \subsection section_MEKE_limit_case Limit cases for local source-dissipative balance +!! +!! Note that in steady-state (or when \f$ a>>1 \f$) and there is no +!! diffusion of \f$ E \f$ then +!! \f[ \overline{E} \approx \frac{ \dot{E}_b + \gamma_\eta \dot{E}_\eta + +!! \gamma_v \dot{E}_v }{ \lambda + C_d|U_d|\gamma_b^2 } . \f] +!! +!! In the linear drag limit, where +!! \f$ U_e << \min(U_b, |u|_{z=-D}, C_d^{-1}\lambda) \f$, the equilibrium becomes +!! \f$ \overline{E} \approx \frac{ \dot{E}_b + \gamma_\eta \dot{E}_\eta + +!! \gamma_v \dot{E}_v }{ \lambda + C_d \sqrt{ U_b^2 + |u|^2_{z=-D} } } \f$. +!! +!! In the nonlinear drag limit, where \f$ U_e >> \max(U_b, |u|_{z=-D}, C_d^{-1}\lambda) \f$, +!! the equilibrium becomes +!! \f$ \overline{E} \approx \left( \frac{ \dot{E}_b + \gamma_\eta \dot{E}_\eta + +!! \gamma_v \dot{E}_v }{ \sqrt{2} C_d \gamma_b^3 } \right)^\frac{2}{3} \f$. +!! +!! \subsubsection section_MEKE_module_parameters MEKE module parameters +!! +!! | Symbol | Module parameter | +!! | ------ | --------------- | +!! | - | USE_MEKE | +!! | \f$ a \f$ | MEKE_DTSCALE | +!! | \f$ \dot{E}_b \f$ | MEKE_BGSRC | +!! | \f$ \gamma_\eta \f$ | MEKE_GMCOEFF | +!! | \f$ \gamma_v \f$ | MEKE_FrCOEFF | +!! | \f$ \lambda \f$ | MEKE_DAMPING | +!! | \f$ U_b \f$ | MEKE_USCALE | +!! | \f$ \gamma_{d0} \f$ | MEKE_CD_SCALE | +!! | \f$ c_{b} \f$ | MEKE_CB | +!! | \f$ c_{t} \f$ | MEKE_CT | +!! | \f$ \kappa_E \f$ | MEKE_KH | +!! | \f$ \kappa_4 \f$ | MEKE_K4 | +!! | \f$ \gamma_\kappa \f$ | MEKE_KHCOEFF | +!! | \f$ \gamma_M \f$ | MEKE_KHMEKE_FAC | +!! | \f$ \gamma_u \f$ | MEKE_VISCOSITY_COEFF_KU | +!! | \f$ \gamma_4 \f$ | MEKE_VISCOSITY_COEFF_AU | +!! | \f$ \gamma_{min}^2 \f$| MEKE_MIN_GAMMA2 | +!! | \f$ \alpha_d \f$ | MEKE_ALPHA_DEFORM | +!! | \f$ \alpha_f \f$ | MEKE_ALPHA_FRICT | +!! | \f$ \alpha_R \f$ | MEKE_ALPHA_RHINES | +!! | \f$ \alpha_e \f$ | MEKE_ALPHA_EADY | +!! | \f$ \alpha_\Delta \f$ | MEKE_ALPHA_GRID | +!! | \f$ L_c \f$ | MEKE_FIXED_MIXING_LENGTH | +!! | \f$ c_\beta \f$ | MEKE_TOPOGRAPHIC_BETA | +!! | - | MEKE_KHTH_FAC | +!! | - | MEKE_KHTR_FAC | +!! +!! | Symbol | Model parameter | +!! | ------ | --------------- | +!! | \f$ C_d \f$ | CDRAG | +!! +!! \subsection section_MEKE_references References +!! +!! Jansen, M. F., A. J. Adcroft, R. Hallberg, and I. M. Held, 2015: Parameterization of eddy fluxes based on a +!! mesoscale energy budget. Ocean Modelling, 92, 28--41, http://doi.org/10.1016/j.ocemod.2015.05.007 . +!! +!! Marshall, D. P., and A. J. Adcroft, 2010: Parameterization of ocean eddies: Potential vorticity mixing, energetics +!! and Arnold first stability theorem. Ocean Modelling, 32, 188--204, http://doi.org/10.1016/j.ocemod.2010.02.001 . + +end module MOM_MEKE + diff --git a/parameterizations/lateral/MOM_MEKE_types.F90 b/parameterizations/lateral/MOM_MEKE_types.F90 new file mode 100644 index 0000000000..e51f558ce3 --- /dev/null +++ b/parameterizations/lateral/MOM_MEKE_types.F90 @@ -0,0 +1,34 @@ +module MOM_MEKE_types + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +!> This type is used to exchange information related to the MEKE calculations. +type, public :: MEKE_type + ! Variables + real, allocatable :: MEKE(:,:) !< Vertically averaged eddy kinetic energy [L2 T-2 ~> m2 s-2]. + real, allocatable :: GM_src(:,:) !< MEKE source due to thickness mixing (GM) [R Z L2 T-3 ~> W m-2]. + real, allocatable :: mom_src(:,:) !< MEKE source from lateral friction in the + !! momentum equations [R Z L2 T-3 ~> W m-2]. + real, allocatable :: GME_snk(:,:) !< MEKE sink from GME backscatter in the momentum equations [R Z L2 T-3 ~> W m-2]. + real, allocatable :: Kh(:,:) !< The MEKE-derived lateral mixing coefficient [L2 T-1 ~> m2 s-1]. + real, allocatable :: Kh_diff(:,:) !< Uses the non-MEKE-derived thickness diffusion coefficient to diffuse + !! MEKE [L2 T-1 ~> m2 s-1]. + real, allocatable :: Rd_dx_h(:,:) !< The deformation radius compared with the grid spacing [nondim]. + !! Rd_dx_h is copied from VarMix_CS. + real, allocatable :: Ku(:,:) !< The MEKE-derived lateral viscosity coefficient + !! [L2 T-1 ~> m2 s-1]. This viscosity can be negative when representing + !! backscatter from unresolved eddies (see Jansen and Held, 2014). + real, allocatable :: Au(:,:) !< The MEKE-derived lateral biharmonic viscosity + !! coefficient [L4 T-1 ~> m4 s-1]. + + ! Parameters + real :: KhTh_fac = 1.0 !< Multiplier to map Kh(MEKE) to KhTh [nondim] + real :: KhTr_fac = 1.0 !< Multiplier to map Kh(MEKE) to KhTr [nondim]. + real :: backscatter_Ro_pow = 0.0 !< Power in Rossby number function for backscatter [nondim]. + real :: backscatter_Ro_c = 0.0 !< Coefficient in Rossby number function for backscatter [nondim]. + +end type MEKE_type + +end module MOM_MEKE_types diff --git a/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/parameterizations/lateral/MOM_Zanna_Bolton.F90 new file mode 100644 index 0000000000..b49d123377 --- /dev/null +++ b/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -0,0 +1,1099 @@ +!> Calculates Zanna and Bolton 2020 parameterization +!! Implemented by Perezhogin P.A. Contact: pperezhogin@gmail.com +module MOM_Zanna_Bolton + +! This file is part of MOM6. See LICENSE.md for the license. +use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type, & + start_group_pass, complete_group_pass +use MOM_domains, only : To_North, To_East +use MOM_domains, only : pass_var, CORNER +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE + +implicit none ; private + +#include + +public ZB2020_lateral_stress, ZB2020_init, ZB2020_end, ZB2020_copy_gradient_and_thickness + +!> Control structure for Zanna-Bolton-2020 parameterization. +type, public :: ZB2020_CS ; private + ! Parameters + real :: amplitude !< The nondimensional scaling factor in ZB model, + !! typically 0.1 - 10 [nondim]. + integer :: ZB_type !< Select how to compute the trace part of ZB model: + !! 0 - both deviatoric and trace components are computed + !! 1 - only deviatoric component is computed + !! 2 - only trace component is computed + integer :: ZB_cons !< Select a discretization scheme for ZB model + !! 0 - non-conservative scheme + !! 1 - conservative scheme for deviatoric component + integer :: HPF_iter !< Number of sharpening passes for the Velocity Gradient (VG) components + !! in ZB model. + integer :: Stress_iter !< Number of smoothing passes for the Stress tensor components + !! in ZB model. + real :: Klower_R_diss !< Attenuation of + !! the ZB parameterization in the regions of + !! geostrophically-unbalanced flows (Klower 2018, Juricke2020,2019) + !! Subgrid stress is multiplied by 1/(1+(shear/(f*R_diss))) + !! R_diss=-1: attenuation is not used; typical value R_diss=1.0 [nondim] + integer :: Klower_shear !< Type of expression for shear in Klower formula + !! 0: sqrt(sh_xx**2 + sh_xy**2) + !! 1: sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) + integer :: Marching_halo !< The number of filter iterations per a single MPI + !! exchange + + real, dimension(:,:,:), allocatable :: & + sh_xx, & !< Horizontal tension (du/dx - dv/dy) in h (CENTER) + !! points including metric terms [T-1 ~> s-1] + sh_xy, & !< Horizontal shearing strain (du/dy + dv/dx) in q (CORNER) + !! points including metric terms [T-1 ~> s-1] + vort_xy, & !< Vertical vorticity (dv/dx - du/dy) in q (CORNER) + !! points including metric terms [T-1 ~> s-1] + hq !< Thickness in CORNER points [H ~> m or kg m-2] + + real, dimension(:,:,:), allocatable :: & + Txx, & !< Subgrid stress xx component in h [L2 T-2 ~> m2 s-2] + Tyy, & !< Subgrid stress yy component in h [L2 T-2 ~> m2 s-2] + Txy !< Subgrid stress xy component in q [L2 T-2 ~> m2 s-2] + + real, dimension(:,:), allocatable :: & + kappa_h, & !< Scaling coefficient in h points [L2 ~> m2] + kappa_q !< Scaling coefficient in q points [L2 ~> m2] + + real, allocatable :: & + ICoriolis_h(:,:), & !< Inverse Coriolis parameter at h points [T ~> s] + c_diss(:,:,:) !< Attenuation parameter at h points + !! (Klower 2018, Juricke2019,2020) [nondim] + + real, dimension(:,:), allocatable :: & + maskw_h, & !< Mask of land point at h points multiplied by filter weight [nondim] + maskw_q !< Same mask but for q points [nondim] + + type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output + !>@{ Diagnostic handles + integer :: id_ZB2020u = -1, id_ZB2020v = -1, id_KE_ZB2020 = -1 + integer :: id_Txx = -1 + integer :: id_Tyy = -1 + integer :: id_Txy = -1 + integer :: id_cdiss = -1 + !>@} + + !>@{ CPU time clock IDs + integer :: id_clock_module + integer :: id_clock_copy + integer :: id_clock_cdiss + integer :: id_clock_stress + integer :: id_clock_divergence + integer :: id_clock_mpi + integer :: id_clock_filter + integer :: id_clock_post + integer :: id_clock_source + !>@} + + !>@{ MPI group passes + type(group_pass_type) :: & + pass_Tq, pass_Th, & !< handles for halo passes of Txy and Txx, Tyy + pass_xx, pass_xy !< handles for halo passes of sh_xx and sh_xy, vort_xy + integer :: Stress_halo = -1, & !< The halo size in filter of the stress tensor + HPF_halo = -1 !< The halo size in filter of the velocity gradient + !>@} + +end type ZB2020_CS + +contains + +!> Read parameters, allocate and precompute arrays, +!! register diagnosicts used in Zanna_Bolton_2020(). +subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020) + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics structure. + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + logical, intent(out) :: use_ZB2020 !< If true, turns on ZB scheme. + + real :: subroundoff_Cor ! A negligible parameter which avoids division by zero + ! but small compared to Coriolis parameter [T-1 ~> s-1] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j + + ! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mdl = "MOM_Zanna_Bolton" ! This module's name. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "USE_ZB2020", use_ZB2020, & + "If true, turns on Zanna-Bolton-2020 (ZB) " //& + "subgrid momentum parameterization of mesoscale eddies.", default=.false.) + if (.not. use_ZB2020) return + + call get_param(param_file, mdl, "ZB_SCALING", CS%amplitude, & + "The nondimensional scaling factor in ZB model, " //& + "typically 0.5-2.5", units="nondim", default=0.5) + + call get_param(param_file, mdl, "ZB_TRACE_MODE", CS%ZB_type, & + "Select how to compute the trace part of ZB model:\n" //& + "\t 0 - both deviatoric and trace components are computed\n" //& + "\t 1 - only deviatoric component is computed\n" //& + "\t 2 - only trace component is computed", default=0) + + call get_param(param_file, mdl, "ZB_SCHEME", CS%ZB_cons, & + "Select a discretization scheme for ZB model:\n" //& + "\t 0 - non-conservative scheme\n" //& + "\t 1 - conservative scheme for deviatoric component", default=1) + + call get_param(param_file, mdl, "VG_SHARP_PASS", CS%HPF_iter, & + "Number of sharpening passes for the Velocity Gradient (VG) components " //& + "in ZB model.", default=0) + + call get_param(param_file, mdl, "STRESS_SMOOTH_PASS", CS%Stress_iter, & + "Number of smoothing passes for the Stress tensor components " //& + "in ZB model.", default=0) + + call get_param(param_file, mdl, "ZB_KLOWER_R_DISS", CS%Klower_R_diss, & + "Attenuation of " //& + "the ZB parameterization in the regions of " //& + "geostrophically-unbalanced flows (Klower 2018, Juricke2020,2019). " //& + "Subgrid stress is multiplied by 1/(1+(shear/(f*R_diss))):\n" //& + "\t R_diss=-1. - attenuation is not used\n\t R_diss= 1. - typical value", & + units="nondim", default=-1.) + + call get_param(param_file, mdl, "ZB_KLOWER_SHEAR", CS%Klower_shear, & + "Type of expression for shear in Klower formula:\n" //& + "\t 0: sqrt(sh_xx**2 + sh_xy**2)\n" //& + "\t 1: sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2)", & + default=1, do_not_log=.not.CS%Klower_R_diss>0) + + call get_param(param_file, mdl, "ZB_MARCHING_HALO", CS%Marching_halo, & + "The number of filter iterations per single MPI " //& + "exchange", default=4, do_not_log=(CS%Stress_iter==0).and.(CS%HPF_iter==0)) + + ! Register fields for output from this module. + CS%diag => diag + + CS%id_ZB2020u = register_diag_field('ocean_model', 'ZB2020u', diag%axesCuL, Time, & + 'Zonal Acceleration from Zanna-Bolton 2020', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_ZB2020v = register_diag_field('ocean_model', 'ZB2020v', diag%axesCvL, Time, & + 'Meridional Acceleration from Zanna-Bolton 2020', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_KE_ZB2020 = register_diag_field('ocean_model', 'KE_ZB2020', diag%axesTL, Time, & + 'Kinetic Energy Source from Horizontal Viscosity', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + + CS%id_Txx = register_diag_field('ocean_model', 'Txx', diag%axesTL, Time, & + 'Diagonal term (Txx) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + CS%id_Tyy = register_diag_field('ocean_model', 'Tyy', diag%axesTL, Time, & + 'Diagonal term (Tyy) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + CS%id_Txy = register_diag_field('ocean_model', 'Txy', diag%axesBL, Time, & + 'Off-diagonal term (Txy) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + if (CS%Klower_R_diss > 0) then + CS%id_cdiss = register_diag_field('ocean_model', 'c_diss', diag%axesTL, Time, & + 'Klower (2018) attenuation coefficient', 'nondim') + endif + + ! Clock IDs + ! Only module is measured with syncronization. While smaller + ! parts are measured without - because these are nested clocks. + CS%id_clock_module = cpu_clock_id('(Ocean Zanna-Bolton-2020)', grain=CLOCK_MODULE) + CS%id_clock_copy = cpu_clock_id('(ZB2020 copy fields)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_cdiss = cpu_clock_id('(ZB2020 compute c_diss)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_stress = cpu_clock_id('(ZB2020 compute stress)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_divergence = cpu_clock_id('(ZB2020 compute divergence)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_mpi = cpu_clock_id('(ZB2020 filter MPI exchanges)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_filter = cpu_clock_id('(ZB2020 filter no MPI)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_post = cpu_clock_id('(ZB2020 post data)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_source = cpu_clock_id('(ZB2020 compute energy source)', grain=CLOCK_ROUTINE, sync=.false.) + + ! Allocate memory + ! We set the stress tensor and velocity gradient tensor to zero + ! with full halo because they potentially may be filtered + ! with marching halo algorithm + allocate(CS%sh_xx(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%sh_xy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%vort_xy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%hq(SZIB_(G),SZJB_(G),SZK_(GV))) + + allocate(CS%Txx(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%Tyy(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%Txy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%kappa_h(SZI_(G),SZJ_(G))) + allocate(CS%kappa_q(SZIB_(G),SZJB_(G))) + + ! Precomputing the scaling coefficient + ! Mask is included to automatically satisfy B.C. + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%kappa_h(i,j) = -CS%amplitude * G%areaT(i,j) * G%mask2dT(i,j) + enddo; enddo + + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + CS%kappa_q(I,J) = -CS%amplitude * G%areaBu(I,J) * G%mask2dBu(I,J) + enddo; enddo + + if (CS%Klower_R_diss > 0) then + allocate(CS%ICoriolis_h(SZI_(G),SZJ_(G))) + allocate(CS%c_diss(SZI_(G),SZJ_(G),SZK_(GV))) + + subroundoff_Cor = 1e-30 * US%T_to_s + ! Precomputing 1/(f * R_diss) + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%ICoriolis_h(i,j) = 1. / ((abs(0.25 * ((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) & + + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1)))) + subroundoff_Cor) & + * CS%Klower_R_diss) + enddo; enddo + endif + + if (CS%Stress_iter > 0 .or. CS%HPF_iter > 0) then + ! Include 1/16. factor to the mask for filter implementation + allocate(CS%maskw_h(SZI_(G),SZJ_(G))); CS%maskw_h(:,:) = G%mask2dT(:,:) * 0.0625 + allocate(CS%maskw_q(SZIB_(G),SZJB_(G))); CS%maskw_q(:,:) = G%mask2dBu(:,:) * 0.0625 + endif + + ! Initialize MPI group passes + if (CS%Stress_iter > 0) then + ! reduce size of halo exchange accordingly to + ! Marching halo, number of iterations and the array size + ! But let exchange width be at least 1 + CS%Stress_halo = max(min(CS%Marching_halo, CS%Stress_iter, & + G%Domain%nihalo, G%Domain%njhalo), 1) + + call create_group_pass(CS%pass_Tq, CS%Txy, G%Domain, halo=CS%Stress_halo, & + position=CORNER) + call create_group_pass(CS%pass_Th, CS%Txx, G%Domain, halo=CS%Stress_halo) + call create_group_pass(CS%pass_Th, CS%Tyy, G%Domain, halo=CS%Stress_halo) + endif + + if (CS%HPF_iter > 0) then + ! The minimum halo size is 2 because it is requirement for the + ! outputs of function filter_velocity_gradients + CS%HPF_halo = max(min(CS%Marching_halo, CS%HPF_iter, & + G%Domain%nihalo, G%Domain%njhalo), 2) + + call create_group_pass(CS%pass_xx, CS%sh_xx, G%Domain, halo=CS%HPF_halo) + call create_group_pass(CS%pass_xy, CS%sh_xy, G%Domain, halo=CS%HPF_halo, & + position=CORNER) + call create_group_pass(CS%pass_xy, CS%vort_xy, G%Domain, halo=CS%HPF_halo, & + position=CORNER) + endif + +end subroutine ZB2020_init + +!> Deallocate any variables allocated in ZB_2020_init +subroutine ZB2020_end(CS) + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + deallocate(CS%sh_xx) + deallocate(CS%sh_xy) + deallocate(CS%vort_xy) + deallocate(CS%hq) + + deallocate(CS%Txx) + deallocate(CS%Tyy) + deallocate(CS%Txy) + deallocate(CS%kappa_h) + deallocate(CS%kappa_q) + + if (CS%Klower_R_diss > 0) then + deallocate(CS%ICoriolis_h) + deallocate(CS%c_diss) + endif + + if (CS%Stress_iter > 0 .or. CS%HPF_iter > 0) then + deallocate(CS%maskw_h) + deallocate(CS%maskw_q) + endif + +end subroutine ZB2020_end + +!> Save precomputed velocity gradients and thickness +!! from the horizontal eddy viscosity module +!! We save as much halo for velocity gradients as possible +!! In symmetric (preferable) memory model: halo 2 for sh_xx +!! and halo 1 for sh_xy and vort_xy +!! We apply zero boundary conditions to velocity gradients +!! which is required for filtering operations +subroutine ZB2020_copy_gradient_and_thickness(sh_xx, sh_xy, vort_xy, hq, & + G, GV, CS, k) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: sh_xy !< horizontal shearing strain (du/dy + dv/dx) + !! including metric terms [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: vort_xy !< Vertical vorticity (dv/dx - du/dy) + !! including metric terms [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: hq !< harmonic mean of the harmonic means + !! of the u- & v point thicknesses [H ~> m or kg m-2] + + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: sh_xx !< horizontal tension (du/dx - dv/dy) + !! including metric terms [T-1 ~> s-1] + + integer, intent(in) :: k !< The vertical index of the layer to be passed. + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j + + call cpu_clock_begin(CS%id_clock_copy) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + do J=js-1,Jeq ; do I=is-1,Ieq + CS%hq(I,J,k) = hq(I,J) + enddo; enddo + + ! No physical B.C. is required for + ! sh_xx in ZB2020. However, filtering + ! may require BC + do j=Jsq-1,je+2 ; do i=Isq-1,ie+2 + CS%sh_xx(i,j,k) = sh_xx(i,j) * G%mask2dT(i,j) + enddo ; enddo + + ! We multiply by mask to remove + ! implicit dependence on CS%no_slip + ! flag in hor_visc module + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%sh_xy(I,J,k) = sh_xy(I,J) * G%mask2dBu(I,J) + enddo; enddo + + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%vort_xy(I,J,k) = vort_xy(I,J) * G%mask2dBu(I,J) + enddo; enddo + + call cpu_clock_end(CS%id_clock_copy) + +end subroutine ZB2020_copy_gradient_and_thickness + +!> Baroclinic Zanna-Bolton-2020 parameterization, see +!! eq. 6 in https://laurezanna.github.io/files/Zanna-Bolton-2020.pdf +!! We compute the lateral stress tensor according to ZB2020 model +!! and update the acceleration due to eddy viscosity (diffu, diffv) +!! as follows: +!! diffu = diffu + ZB2020u +!! diffv = diffv + ZB2020v +subroutine ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS, & + dx2h, dy2h, dx2q, dy2q) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: diffu !< Zonal acceleration due to eddy viscosity. + !! It is updated with ZB closure [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: diffv !< Meridional acceleration due to eddy viscosity. + !! It is updated with ZB closure [L T-2 ~> m s-2] + + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: dx2h !< dx^2 at h points [L2 ~> m2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: dy2h !< dy^2 at h points [L2 ~> m2] + + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: dx2q !< dx^2 at q points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: dy2q !< dy^2 at q points [L2 ~> m2] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n + + call cpu_clock_begin(CS%id_clock_module) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + ! Compute attenuation if specified + call compute_c_diss(G, GV, CS) + + ! Sharpen velocity gradients if specified + call filter_velocity_gradients(G, GV, CS) + + ! Compute the stress tensor given the + ! (optionally sharpened) velocity gradients + call compute_stress(G, GV, CS) + + ! Smooth the stress tensor if specified + call filter_stress(G, GV, CS) + + ! Update the acceleration due to eddy viscosity (diffu, diffv) + ! with the ZB2020 lateral parameterization + call compute_stress_divergence(u, v, h, diffu, diffv, & + dx2h, dy2h, dx2q, dy2q, & + G, GV, CS) + + call cpu_clock_begin(CS%id_clock_post) + if (CS%id_Txx>0) call post_data(CS%id_Txx, CS%Txx, CS%diag) + if (CS%id_Tyy>0) call post_data(CS%id_Tyy, CS%Tyy, CS%diag) + if (CS%id_Txy>0) call post_data(CS%id_Txy, CS%Txy, CS%diag) + + if (CS%id_cdiss>0) call post_data(CS%id_cdiss, CS%c_diss, CS%diag) + call cpu_clock_end(CS%id_clock_post) + + call cpu_clock_end(CS%id_clock_module) + +end subroutine ZB2020_lateral_stress + +!> Compute the attenuation parameter similarly +!! to Klower2018, Juricke2019,2020: c_diss = 1/(1+(shear/(f*R_diss))) +!! where shear = sqrt(sh_xx**2 + sh_xy**2) or shear = sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) +!! In symmetric memory model, components of velocity gradient tensor +!! should have halo 1 and zero boundary conditions. The result: c_diss having halo 1. +subroutine compute_c_diss(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n + + real :: shear ! Shear in Klower2018 formula at h points [T-1 ~> s-1] + + if (.not. CS%Klower_R_diss > 0) & + return + + call cpu_clock_begin(CS%id_clock_cdiss) + + 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 + + do k=1,nz + + ! sqrt(sh_xx**2 + sh_xy**2) + if (CS%Klower_shear == 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + shear = sqrt(CS%sh_xx(i,j,k)**2 + 0.25 * ( & + (CS%sh_xy(I-1,J-1,k)**2 + CS%sh_xy(I,J ,k)**2) & + + (CS%sh_xy(I-1,J ,k)**2 + CS%sh_xy(I,J-1,k)**2) & + )) + CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j)) + enddo; enddo + + ! sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) + elseif (CS%Klower_shear == 1) then + do j=js-1,je+1 ; do i=is-1,ie+1 + shear = sqrt(CS%sh_xx(i,j,k)**2 + 0.25 * ( & + ((CS%sh_xy(I-1,J-1,k)**2 + CS%vort_xy(I-1,J-1,k)**2) & + + (CS%sh_xy(I,J,k)**2 + CS%vort_xy(I,J,k)**2)) & + + ((CS%sh_xy(I-1,J,k)**2 + CS%vort_xy(I-1,J,k)**2) & + + (CS%sh_xy(I,J-1,k)**2 + CS%vort_xy(I,J-1,k)**2)) & + )) + CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j)) + enddo; enddo + endif + + enddo ! end of k loop + + call cpu_clock_end(CS%id_clock_cdiss) + +end subroutine compute_c_diss + +!> Compute stress tensor T = +!! (Txx, Txy; +!! Txy, Tyy) +!! Which consists of the deviatoric and trace components, respectively: +!! T = (-vort_xy * sh_xy, vort_xy * sh_xx; +!! vort_xy * sh_xx, vort_xy * sh_xy) + +!! 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2, 0; +!! 0, vort_xy^2 + sh_xy^2 + sh_xx^2) +!! This stress tensor is multiplied by precomputed kappa=-CS%amplitude * G%area: +!! T -> T * kappa +!! The sign of the stress tensor is such that (neglecting h): +!! (du/dt, dv/dt) = div(T) +!! In symmetric memory model: sh_xy and vort_xy should have halo 1 +!! and zero B.C.; sh_xx should have halo 2 and zero B.C. +!! Result: Txx, Tyy, Txy with halo 1 and zero B.C. +subroutine compute_stress(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + real :: & + vort_xy_h, & ! Vorticity interpolated to h point [T-1 ~> s-1] + sh_xy_h ! Shearing strain interpolated to h point [T-1 ~> s-1] + + real :: & + sh_xx_q ! Horizontal tension interpolated to q point [T-1 ~> s-1] + + ! Local variables + real :: sum_sq ! 1/2*(vort_xy^2 + sh_xy^2 + sh_xx^2) in h point [T-2 ~> s-2] + real :: vort_sh ! vort_xy*sh_xy in h point [T-2 ~> s-2] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n + + logical :: sum_sq_flag ! Flag to compute trace + logical :: vort_sh_scheme_0, vort_sh_scheme_1 ! Flags to compute diagonal trace-free part + + call cpu_clock_begin(CS%id_clock_stress) + + 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 + + sum_sq = 0. + vort_sh = 0. + + sum_sq_flag = CS%ZB_type /= 1 + vort_sh_scheme_0 = CS%ZB_type /= 2 .and. CS%ZB_cons == 0 + vort_sh_scheme_1 = CS%ZB_type /= 2 .and. CS%ZB_cons == 1 + + do k=1,nz + + ! compute Txx, Tyy tensor + do j=js-1,je+1 ; do i=is-1,ie+1 + ! It is assumed that B.C. is applied to sh_xy and vort_xy + sh_xy_h = 0.25 * ( (CS%sh_xy(I-1,J-1,k) + CS%sh_xy(I,J,k)) & + + (CS%sh_xy(I-1,J,k) + CS%sh_xy(I,J-1,k)) ) + + vort_xy_h = 0.25 * ( (CS%vort_xy(I-1,J-1,k) + CS%vort_xy(I,J,k)) & + + (CS%vort_xy(I-1,J,k) + CS%vort_xy(I,J-1,k)) ) + + if (sum_sq_flag) then + sum_sq = 0.5 * & + ((vort_xy_h * vort_xy_h & + + sh_xy_h * sh_xy_h) & + + CS%sh_xx(i,j,k) * CS%sh_xx(i,j,k) & + ) + endif + + if (vort_sh_scheme_0) & + vort_sh = vort_xy_h * sh_xy_h + + if (vort_sh_scheme_1) then + ! It is assumed that B.C. is applied to sh_xy and vort_xy + vort_sh = 0.25 * ( & + ((G%areaBu(I-1,J-1) * CS%vort_xy(I-1,J-1,k)) * CS%sh_xy(I-1,J-1,k) + & + (G%areaBu(I ,J ) * CS%vort_xy(I ,J ,k)) * CS%sh_xy(I ,J ,k)) + & + ((G%areaBu(I-1,J ) * CS%vort_xy(I-1,J ,k)) * CS%sh_xy(I-1,J ,k) + & + (G%areaBu(I ,J-1) * CS%vort_xy(I ,J-1,k)) * CS%sh_xy(I ,J-1,k)) & + ) * G%IareaT(i,j) + endif + + ! B.C. is already applied in kappa_h + CS%Txx(i,j,k) = CS%kappa_h(i,j) * (- vort_sh + sum_sq) + CS%Tyy(i,j,k) = CS%kappa_h(i,j) * (+ vort_sh + sum_sq) + + enddo ; enddo + + ! Here we assume that Txy is initialized to zero + if (CS%ZB_type /= 2) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + sh_xx_q = 0.25 * ( (CS%sh_xx(i+1,j+1,k) + CS%sh_xx(i,j,k)) & + + (CS%sh_xx(i+1,j,k) + CS%sh_xx(i,j+1,k))) + ! B.C. is already applied in kappa_q + CS%Txy(I,J,k) = CS%kappa_q(I,J) * (CS%vort_xy(I,J,k) * sh_xx_q) + + enddo ; enddo + endif + + enddo ! end of k loop + + call cpu_clock_end(CS%id_clock_stress) + +end subroutine compute_stress + +!> Compute the divergence of subgrid stress +!! weighted with thickness, i.e. +!! (fx,fy) = 1/h Div(h * [Txx, Txy; Txy, Tyy]) +!! and update the acceleration due to eddy viscosity as +!! diffu = diffu + dx; diffv = diffv + dy +!! Optionally, before computing the divergence, we attenuate the stress +!! according to the Klower formula. +!! In symmetric memory model: Txx, Tyy, Txy, c_diss should have halo 1 +!! with applied zero B.C. +subroutine compute_stress_divergence(u, v, h, diffu, diffv, dx2h, dy2h, dx2q, dy2q, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: diffu !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: diffv !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: dx2h !< dx^2 at h points [L2 ~> m2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: dy2h !< dy^2 at h points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: dx2q !< dx^2 at q points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: dy2q !< dy^2 at q points [L2 ~> m2] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + Mxx, & ! Subgrid stress Txx multiplied by thickness and dy^2 [H L4 T-2 ~> m5 s-2] + Myy ! Subgrid stress Tyy multiplied by thickness and dx^2 [H L4 T-2 ~> m5 s-2] + + real, dimension(SZIB_(G),SZJB_(G)) :: & + Mxy ! Subgrid stress Txy multiplied by thickness [H L2 T-2 ~> m3 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + ZB2020u !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor for ZB model + !! [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + ZB2020v !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor for ZB model + !! [L T-2 ~> m s-2] + + real :: h_u ! Thickness interpolated to u points [H ~> m or kg m-2]. + real :: h_v ! Thickness interpolated to v points [H ~> m or kg m-2]. + real :: fx ! Zonal acceleration [L T-2 ~> m s-2] + real :: fy ! Meridional acceleration [L T-2 ~> m s-2] + + real :: h_neglect ! Thickness so small it can be lost in + ! roundoff and so neglected [H ~> m or kg m-2] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k + logical :: save_ZB2020u, save_ZB2020v ! Save the acceleration due to ZB2020 model + + call cpu_clock_begin(CS%id_clock_divergence) + + save_ZB2020u = (CS%id_ZB2020u > 0) .or. (CS%id_KE_ZB2020 > 0) + save_ZB2020v = (CS%id_ZB2020v > 0) .or. (CS%id_KE_ZB2020 > 0) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + h_neglect = GV%H_subroundoff + + do k=1,nz + if (CS%Klower_R_diss > 0) then + do J=js-1,Jeq ; do I=is-1,Ieq + Mxy(I,J) = (CS%Txy(I,J,k) * & + (0.25 * ( (CS%c_diss(i,j ,k) + CS%c_diss(i+1,j+1,k)) & + + (CS%c_diss(i,j+1,k) + CS%c_diss(i+1,j ,k))) & + ) & + ) * CS%hq(I,J,k) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + Mxy(I,J) = CS%Txy(I,J,k) * CS%hq(I,J,k) + enddo ; enddo + endif + + if (CS%Klower_R_diss > 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + Mxx(i,j) = ((CS%Txx(i,j,k) * CS%c_diss(i,j,k)) * h(i,j,k)) * dy2h(i,j) + Myy(i,j) = ((CS%Tyy(i,j,k) * CS%c_diss(i,j,k)) * h(i,j,k)) * dx2h(i,j) + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + Mxx(i,j) = ((CS%Txx(i,j,k)) * h(i,j,k)) * dy2h(i,j) + Myy(i,j) = ((CS%Tyy(i,j,k)) * h(i,j,k)) * dx2h(i,j) + enddo ; enddo + endif + + ! Evaluate 1/h x.Div(h S) (Line 1495 of MOM_hor_visc.F90) + ! Minus occurs because in original file (du/dt) = - div(S), + ! but here is the discretization of div(S) + do j=js,je ; do I=Isq,Ieq + h_u = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) + h_neglect + fx = -((G%IdyCu(I,j)*(Mxx(i,j) - & + Mxx(i+1,j)) + & + G%IdxCu(I,j)*(dx2q(I,J-1)*Mxy(I,J-1) - & + dx2q(I,J) *Mxy(I,J))) * & + G%IareaCu(I,j)) / h_u + diffu(I,j,k) = diffu(I,j,k) + fx + if (save_ZB2020u) & + ZB2020u(I,j,k) = fx + enddo ; enddo + + ! Evaluate 1/h y.Div(h S) (Line 1517 of MOM_hor_visc.F90) + do J=Jsq,Jeq ; do i=is,ie + h_v = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) + h_neglect + fy = -((G%IdyCv(i,J)*(dy2q(I-1,J)*Mxy(I-1,J) - & + dy2q(I,J) *Mxy(I,J)) + & ! NOTE this plus + G%IdxCv(i,J)*(Myy(i,j) - & + Myy(i,j+1))) * & + G%IareaCv(i,J)) / h_v + diffv(i,J,k) = diffv(i,J,k) + fy + if (save_ZB2020v) & + ZB2020v(i,J,k) = fy + enddo ; enddo + + enddo ! end of k loop + + call cpu_clock_end(CS%id_clock_divergence) + + call cpu_clock_begin(CS%id_clock_post) + if (CS%id_ZB2020u>0) call post_data(CS%id_ZB2020u, ZB2020u, CS%diag) + if (CS%id_ZB2020v>0) call post_data(CS%id_ZB2020v, ZB2020v, CS%diag) + call cpu_clock_end(CS%id_clock_post) + + call compute_energy_source(u, v, h, ZB2020u, ZB2020v, G, GV, CS) + +end subroutine compute_stress_divergence + +!> Filtering of the velocity gradients sh_xx, sh_xy, vort_xy. +!! Here instead of smoothing we do sharpening, i.e. +!! return (initial - smoothed) fields. +!! The algorithm: marching halo with non-blocking grouped MPI +!! exchanges. The input array sh_xx should have halo 2 with +!! applied zero B.C. The arrays sh_xy and vort_xy should have +!! halo 1 with applied B.C. The output have the same halo and B.C. +subroutine filter_velocity_gradients(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & + sh_xx ! Copy of CS%sh_xx [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & + sh_xy, vort_xy ! Copy of CS%sh_xy and CS%vort_xy [T-1 ~> s-1] + + integer :: xx_halo, xy_halo, vort_halo ! currently available halo for gradient components + integer :: xx_iter, xy_iter, vort_iter ! remaining number of iterations + integer :: niter ! required number of iterations + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n + + niter = CS%HPF_iter + + if (niter == 0) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (.not. G%symmetric) & + call do_group_pass(CS%pass_xx, G%Domain, & + clock=CS%id_clock_mpi) + + ! This is just copy of the array + call cpu_clock_begin(CS%id_clock_filter) + do k=1,nz + ! Halo of size 2 is valid + do j=js-2,je+2; do i=is-2,ie+2 + sh_xx(i,j,k) = CS%sh_xx(i,j,k) + enddo; enddo + ! Only halo of size 1 is valid + do J=Jsq-1,Jeq+1; do I=Isq-1,Ieq+1 + sh_xy(I,J,k) = CS%sh_xy(I,J,k) + vort_xy(I,J,k) = CS%vort_xy(I,J,k) + enddo; enddo + enddo + call cpu_clock_end(CS%id_clock_filter) + + xx_halo = 2; xy_halo = 1; vort_halo = 1; + xx_iter = niter; xy_iter = niter; vort_iter = niter; + + do while & + (xx_iter > 0 .or. xy_iter > 0 .or. & ! filter iterations remain to be done + xx_halo < 2 .or. xy_halo < 1) ! there is no halo for VG tensor + + ! ---------- filtering sh_xx --------- + if (xx_halo < 2) then + call complete_group_pass(CS%pass_xx, G%Domain, clock=CS%id_clock_mpi) + xx_halo = CS%HPF_halo + endif + + call filter_hq(G, GV, CS, xx_halo, xx_iter, h=CS%sh_xx) + + if (xx_halo < 2) & + call start_group_pass(CS%pass_xx, G%Domain, clock=CS%id_clock_mpi) + + ! ------ filtering sh_xy, vort_xy ---- + if (xy_halo < 1) then + call complete_group_pass(CS%pass_xy, G%Domain, clock=CS%id_clock_mpi) + xy_halo = CS%HPF_halo; vort_halo = CS%HPF_halo + endif + + call filter_hq(G, GV, CS, xy_halo, xy_iter, q=CS%sh_xy) + call filter_hq(G, GV, CS, vort_halo, vort_iter, q=CS%vort_xy) + + if (xy_halo < 1) & + call start_group_pass(CS%pass_xy, G%Domain, clock=CS%id_clock_mpi) + + enddo + + ! We implement sharpening by computing residual + ! B.C. are already applied to all fields + call cpu_clock_begin(CS%id_clock_filter) + do k=1,nz + do j=js-2,je+2; do i=is-2,ie+2 + CS%sh_xx(i,j,k) = sh_xx(i,j,k) - CS%sh_xx(i,j,k) + enddo; enddo + do J=Jsq-1,Jeq+1; do I=Isq-1,Ieq+1 + CS%sh_xy(I,J,k) = sh_xy(I,J,k) - CS%sh_xy(I,J,k) + CS%vort_xy(I,J,k) = vort_xy(I,J,k) - CS%vort_xy(I,J,k) + enddo; enddo + enddo + call cpu_clock_end(CS%id_clock_filter) + + if (.not. G%symmetric) & + call do_group_pass(CS%pass_xy, G%Domain, & + clock=CS%id_clock_mpi) + +end subroutine filter_velocity_gradients + +!> Filtering of the stress tensor Txx, Tyy, Txy. +!! The algorithm: marching halo with non-blocking grouped MPI +!! exchanges. The input arrays (Txx, Tyy, Txy) must have halo 1 +!! with zero B.C. applied. The output have the same halo and B.C. +subroutine filter_stress(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + integer :: Txx_halo, Tyy_halo, Txy_halo ! currently available halo for stress components + integer :: Txx_iter, Tyy_iter, Txy_iter ! remaining number of iterations + integer :: niter ! required number of iterations + + niter = CS%Stress_iter + + if (niter == 0) return + + Txx_halo = 1; Tyy_halo = 1; Txy_halo = 1; ! these are required halo for Txx, Tyy, Txy + Txx_iter = niter; Tyy_iter = niter; Txy_iter = niter; + + do while & + (Txx_iter > 0 .or. Txy_iter > 0 .or. & ! filter iterations remain to be done + Txx_halo < 1 .or. Txy_halo < 1) ! there is no halo for Txx or Txy + + ! ---------- filtering Txy ----------- + if (Txy_halo < 1) then + call complete_group_pass(CS%pass_Tq, G%Domain, clock=CS%id_clock_mpi) + Txy_halo = CS%Stress_halo + endif + + call filter_hq(G, GV, CS, Txy_halo, Txy_iter, q=CS%Txy) + + if (Txy_halo < 1) & + call start_group_pass(CS%pass_Tq, G%Domain, clock=CS%id_clock_mpi) + + ! ------- filtering Txx, Tyy --------- + if (Txx_halo < 1) then + call complete_group_pass(CS%pass_Th, G%Domain, clock=CS%id_clock_mpi) + Txx_halo = CS%Stress_halo; Tyy_halo = CS%Stress_halo + endif + + call filter_hq(G, GV, CS, Txx_halo, Txx_iter, h=CS%Txx) + call filter_hq(G, GV, CS, Tyy_halo, Tyy_iter, h=CS%Tyy) + + if (Txx_halo < 1) & + call start_group_pass(CS%pass_Th, G%Domain, clock=CS%id_clock_mpi) + + enddo + +end subroutine filter_stress + +!> Wrapper for filter_3D function. The border indices for q and h +!! arrays are substituted. +subroutine filter_hq(G, GV, CS, current_halo, remaining_iterations, q, h) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, & + intent(inout) :: h !< Input/output array in h points [arbitrary] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), optional, & + intent(inout) :: q !< Input/output array in q points [arbitrary] + integer, intent(inout) :: current_halo !< Currently available halo points + integer, intent(inout) :: remaining_iterations !< The number of iterations to perform + + logical :: direction ! The direction of the first 1D filter + + direction = (MOD(G%first_direction,2) == 0) + + call cpu_clock_begin(CS%id_clock_filter) + + if (present(h)) then + call filter_3D(h, CS%maskw_h, & + G%isd, G%ied, G%jsd, G%jed, & + G%isc, G%iec, G%jsc, G%jec, GV%ke, & + current_halo, remaining_iterations, & + direction) + endif + + if (present(q)) then + call filter_3D(q, CS%maskw_q, & + G%IsdB, G%IedB, G%JsdB, G%JedB, & + G%IscB, G%IecB, G%JscB, G%JecB, GV%ke, & + current_halo, remaining_iterations, & + direction) + endif + + call cpu_clock_end(CS%id_clock_filter) +end subroutine filter_hq + +!> Spatial lateral filter applied to 3D array. The lateral filter is given +!! by the convolutional kernel: +!! [1 2 1] +!! C = |2 4 2| * 1/16 +!! [1 2 1] +!! The fast algorithm decomposes the 2D filter into two 1D filters as follows: +!! [1] +!! C = |2| * [1 2 1] * 1/16 +!! [1] +!! The input array must have zero B.C. applied. B.C. is applied for output array. +!! Note that maskw contains both land mask and 1/16 factor. +!! Filter implements marching halo. The available halo is specified and as many +!! filter iterations as possible and as needed are performed. +subroutine filter_3D(x, maskw, isd, ied, jsd, jed, is, ie, js, je, nz, & + current_halo, remaining_iterations, & + direction) + integer, intent(in) :: isd !< Indices of array size + integer, intent(in) :: ied !< Indices of array size + integer, intent(in) :: jsd !< Indices of array size + integer, intent(in) :: jed !< Indices of array size + integer, intent(in) :: is !< Indices of owned points + integer, intent(in) :: ie !< Indices of owned points + integer, intent(in) :: js !< Indices of owned points + integer, intent(in) :: je !< Indices of owned points + integer, intent(in) :: nz !< Vertical array size + real, dimension(isd:ied,jsd:jed,nz), & + intent(inout) :: x !< Input/output array [arbitrary] + real, dimension(isd:ied,jsd:jed), & + intent(in) :: maskw !< Mask array of land points divided by 16 [nondim] + integer, intent(inout) :: current_halo !< Currently available halo points + integer, intent(inout) :: remaining_iterations !< The number of iterations to perform + logical, intent(in) :: direction !< The direction of the first 1D filter + + real, parameter :: weight = 2. ! Filter weight [nondim] + integer :: i, j, k, iter, niter, halo + + real :: tmp(isd:ied, jsd:jed) ! Array with temporary results [arbitrary] + + ! Do as many iterations as needed and possible + niter = min(current_halo, remaining_iterations) + if (niter == 0) return ! nothing to do + + ! Update remaining iterations + remaining_iterations = remaining_iterations - niter + ! Update halo information + current_halo = current_halo - niter + + do k=1,Nz + halo = niter-1 + & + current_halo ! Save as many halo points as possible + do iter=1,niter + + if (direction) then + do j = js-halo, je+halo; do i = is-halo-1, ie+halo+1 + tmp(i,j) = weight * x(i,j,k) + (x(i,j-1,k) + x(i,j+1,k)) + enddo; enddo + + do j = js-halo, je+halo; do i = is-halo, ie+halo; + x(i,j,k) = (weight * tmp(i,j) + (tmp(i-1,j) + tmp(i+1,j))) * maskw(i,j) + enddo; enddo + else + do j = js-halo-1, je+halo+1; do i = is-halo, ie+halo + tmp(i,j) = weight * x(i,j,k) + (x(i-1,j,k) + x(i+1,j,k)) + enddo; enddo + + do j = js-halo, je+halo; do i = is-halo, ie+halo; + x(i,j,k) = (weight * tmp(i,j) + (tmp(i,j-1) + tmp(i,j+1))) * maskw(i,j) + enddo; enddo + endif + + halo = halo - 1 + enddo + enddo + +end subroutine filter_3D + +!> Computes the 3D energy source term for the ZB2020 scheme +!! similarly to MOM_diagnostics.F90, specifically 1125 line. +subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: fx !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: fy !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor [L T-2 ~> m s-2] + + real :: KE_term(SZI_(G),SZJ_(G),SZK_(GV)) ! A term in the kinetic energy budget + ! [H L2 T-3 ~> m3 s-3 or W m-2] + real :: KE_u(SZIB_(G),SZJ_(G)) ! The area integral of a KE term in a layer at u-points + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + real :: KE_v(SZI_(G),SZJB_(G)) ! The area integral of a KE term in a layer at v-points + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + + real :: uh ! Transport through zonal faces = u*h*dy, + ! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: vh ! Transport through meridional faces = v*h*dx, + ! [H L2 T-1 ~> m3 s-1 or kg s-1]. + + type(group_pass_type) :: pass_KE_uv ! A handle used for group halo passes + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k + + if (CS%id_KE_ZB2020 > 0) then + call cpu_clock_begin(CS%id_clock_source) + call create_group_pass(pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + KE_term(:,:,:) = 0. + ! Calculate the KE source from Zanna-Bolton2020 [H L2 T-3 ~> m3 s-3]. + do k=1,nz + KE_u(:,:) = 0. + KE_v(:,:) = 0. + do j=js,je ; do I=Isq,Ieq + uh = u(I,j,k) * 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) * & + G%dyCu(I,j) + KE_u(I,j) = uh * G%dxCu(I,j) * fx(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + vh = v(i,J,k) * 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) * & + G%dxCv(i,J) + KE_v(i,J) = vh * G%dyCv(i,J) * fy(i,J,k) + enddo ; enddo + call do_group_pass(pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + enddo ; enddo + enddo + + call cpu_clock_end(CS%id_clock_source) + + call cpu_clock_begin(CS%id_clock_post) + call post_data(CS%id_KE_ZB2020, KE_term, CS%diag) + call cpu_clock_end(CS%id_clock_post) + endif + +end subroutine compute_energy_source + +end module MOM_Zanna_Bolton \ No newline at end of file diff --git a/parameterizations/lateral/MOM_hor_visc.F90 b/parameterizations/lateral/MOM_hor_visc.F90 new file mode 100644 index 0000000000..6f707f9e87 --- /dev/null +++ b/parameterizations/lateral/MOM_hor_visc.F90 @@ -0,0 +1,3324 @@ +!> Calculates horizontal viscosity and viscous stresses +module MOM_hor_visc + +! This file is part of MOM6. See LICENSE.md for the license. +use MOM_checksums, only : hchksum, Bchksum, uvchksum +use MOM_coms, only : min_across_PEs +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : post_product_u, post_product_sum_u +use MOM_diag_mediator, only : post_product_v, post_product_sum_v +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_domains, only : pass_var, CORNER, pass_vector, AGRID, BGRID_NE +use MOM_domains, only : To_All, Scalar_Pair +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_lateral_mixing_coeffs, only : VarMix_CS, calc_QG_Leith_viscosity +use MOM_barotropic, only : barotropic_CS, barotropic_get_tav +use MOM_thickness_diffuse, only : thickness_diffuse_CS, thickness_diffuse_get_KH +use MOM_io, only : MOM_read_data, slasher +use MOM_MEKE_types, only : MEKE_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W +use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_NONE +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_variables, only : accel_diag_ptrs +use MOM_Zanna_Bolton, only : ZB2020_lateral_stress, ZB2020_init, ZB2020_end, & + ZB2020_CS, ZB2020_copy_gradient_and_thickness + +implicit none ; private + +#include + +public horizontal_viscosity, hor_visc_init, hor_visc_end + +!> Control structure for horizontal viscosity +type, public :: hor_visc_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: Laplacian !< Use a Laplacian horizontal viscosity if true. + logical :: biharmonic !< Use a biharmonic horizontal viscosity if true. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: no_slip !< If true, no slip boundary conditions are used. + !! Otherwise free slip boundary conditions are assumed. + !! The implementation of the free slip boundary + !! conditions on a C-grid is much cleaner than the + !! no slip boundary conditions. The use of free slip + !! b.c.s is strongly encouraged. The no slip b.c.s + !! are not implemented with the biharmonic viscosity. + logical :: bound_Kh !< If true, the Laplacian coefficient is locally + !! limited to guarantee stability. + logical :: better_bound_Kh !< If true, use a more careful bounding of the + !! Laplacian viscosity to guarantee stability. + logical :: bound_Ah !< If true, the biharmonic coefficient is locally + !! limited to guarantee stability. + logical :: better_bound_Ah !< If true, use a more careful bounding of the + !! biharmonic viscosity to guarantee stability. + real :: Re_Ah !! If nonzero, the biharmonic coefficient is scaled + !< so that the biharmonic Reynolds number is equal to this [nondim]. + real :: bound_coef !< The nondimensional coefficient of the ratio of + !! the viscosity bounds to the theoretical maximum + !! for stability without considering other terms [nondim]. + !! The default is 0.8. + logical :: Smagorinsky_Kh !< If true, use Smagorinsky nonlinear eddy + !! viscosity. KH is the background value. + logical :: Smagorinsky_Ah !< If true, use a biharmonic form of Smagorinsky + !! nonlinear eddy viscosity. AH is the background. + logical :: Leith_Kh !< If true, use 2D Leith nonlinear eddy + !! viscosity. KH is the background value. + logical :: Modified_Leith !< If true, use extra component of Leith viscosity + !! to damp divergent flow. To use, still set Leith_Kh=.TRUE. + logical :: use_beta_in_Leith !< If true, includes the beta term in the Leith viscosity + logical :: Leith_Ah !< If true, use a biharmonic form of 2D Leith + !! nonlinear eddy viscosity. AH is the background. + logical :: use_Leithy !< If true, use a biharmonic form of 2D Leith + !! nonlinear eddy viscosity with harmonic backscatter. + !! Ah is the background. Leithy = Leith+E + real :: c_K !< Fraction of energy dissipated by the biharmonic term + !! that gets backscattered in the Leith+E scheme. [nondim] + logical :: use_QG_Leith_visc !< If true, use QG Leith nonlinear eddy viscosity. + !! KH is the background value. + logical :: bound_Coriolis !< If true & SMAGORINSKY_AH is used, the biharmonic + !! viscosity is modified to include a term that + !! scales quadratically with the velocity shears. + logical :: use_Kh_bg_2d !< Read 2d background viscosity from a file. + logical :: Kh_bg_2d_bug !< If true, retain an answer-changing horizontal indexing bug + !! in setting the corner-point viscosities when USE_KH_BG_2D=True. + real :: Kh_bg_min !< The minimum value allowed for Laplacian horizontal + !! viscosity [L2 T-1 ~> m2 s-1]. The default is 0.0. + logical :: use_land_mask !< Use the land mask for the computation of thicknesses + !! at velocity locations. This eliminates the dependence on + !! arbitrary values over land or outside of the domain. + !! Default is False to maintain answers with legacy experiments + !! but should be changed to True for new experiments. + logical :: anisotropic !< If true, allow anisotropic component to the viscosity. + logical :: add_LES_viscosity!< If true, adds the viscosity from Smagorinsky and Leith to + !! the background viscosity instead of taking the maximum. + real :: Kh_aniso !< The anisotropic viscosity [L2 T-1 ~> m2 s-1]. + logical :: dynamic_aniso !< If true, the anisotropic viscosity is recomputed as a function + !! of state. This is set depending on ANISOTROPIC_MODE. + logical :: res_scale_MEKE !< If true, the viscosity contribution from MEKE is scaled by + !! the resolution function. + logical :: use_GME !< If true, use GME backscatter scheme. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the + !! horizontal viscosity calculations. Values below 20190101 recover + !! the answers from the end of 2018, while higher values use updated + !! and more robust forms of the same expressions. + real :: GME_h0 !< The strength of GME tapers quadratically to zero when the bathymetric + !! total water column thickness is less than GME_H0 [H ~> m or kg m-2] + real :: GME_efficiency !< The nondimensional prefactor multiplying the GME coefficient [nondim] + real :: GME_limiter !< The absolute maximum value the GME coefficient is allowed to take [L2 T-1 ~> m2 s-1]. + real :: min_grid_Kh !< Minimum horizontal Laplacian viscosity used to + !! limit the grid Reynolds number [L2 T-1 ~> m2 s-1] + real :: min_grid_Ah !< Minimun horizontal biharmonic viscosity used to + !! limit grid Reynolds number [L4 T-1 ~> m4 s-1] + logical :: use_cont_thick !< If true, thickness at velocity points adopts h[uv] in BT_cont from continuity solver. + type(ZB2020_CS) :: ZB2020 !< Zanna-Bolton 2020 control structure. + logical :: use_ZB2020 !< If true, use Zanna-Bolton 2020 parameterization. + + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx + !< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1]. + !! The actual viscosity may be the larger of this + !! viscosity and the Smagorinsky and Leith viscosities. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_2d + !< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1]. + !! The actual viscosity may be the larger of this + !! viscosity and the Smagorinsky and Leith viscosities. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Ah_bg_xx + !< The background biharmonic viscosity at h points [L4 T-1 ~> m4 s-1]. + !! The actual viscosity may be the larger of this + !! viscosity and the Smagorinsky and Leith viscosities. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: reduction_xx + !< The amount by which stresses through h points are reduced + !! due to partial barriers [nondim]. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & + Kh_Max_xx, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. + Ah_Max_xx, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. + n1n2_h, & !< Factor n1*n2 in the anisotropic direction tensor at h-points [nondim] + n1n1_m_n2n2_h, & !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points [nondim] + grid_sp_h2, & !< Harmonic mean of the squares of the grid [L2 ~> m2] + grid_sp_h3 !< Harmonic mean of the squares of the grid^(3/2) [L3 ~> m3] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Kh_bg_xy + !< The background Laplacian viscosity at q points [L2 T-1 ~> m2 s-1]. + !! The actual viscosity may be the larger of this + !! viscosity and the Smagorinsky and Leith viscosities. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Ah_bg_xy + !< The background biharmonic viscosity at q points [L4 T-1 ~> m4 s-1]. + !! The actual viscosity may be the larger of this + !! viscosity and the Smagorinsky and Leith viscosities. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: reduction_xy + !< The amount by which stresses through q points are reduced + !! due to partial barriers [nondim]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & + Kh_Max_xy, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. + Ah_Max_xy, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. + n1n2_q, & !< Factor n1*n2 in the anisotropic direction tensor at q-points [nondim] + n1n1_m_n2n2_q !< Factor n1**2-n2**2 in the anisotropic direction tensor at q-points [nondim] + + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & + dx2h, & !< Pre-calculated dx^2 at h points [L2 ~> m2] + dy2h, & !< Pre-calculated dy^2 at h points [L2 ~> m2] + dx_dyT, & !< Pre-calculated dx/dy at h points [nondim] + dy_dxT, & !< Pre-calculated dy/dx at h points [nondim] + m_const_leithy, & !< Pre-calculated .5*sqrt(c_K)*max{dx,dy} [L ~> m] + m_leithy_max !< Pre-calculated 4./max(dx,dy)^2 at h points [L-2 ~> m-2] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & + dx2q, & !< Pre-calculated dx^2 at q points [L2 ~> m2] + dy2q, & !< Pre-calculated dy^2 at q points [L2 ~> m2] + dx_dyBu, & !< Pre-calculated dx/dy at q points [nondim] + dy_dxBu !< Pre-calculated dy/dx at q points [nondim] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & + Idx2dyCu, & !< 1/(dx^2 dy) at u points [L-3 ~> m-3] + Idxdy2u !< 1/(dx dy^2) at u points [L-3 ~> m-3] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & + Idx2dyCv, & !< 1/(dx^2 dy) at v points [L-3 ~> m-3] + Idxdy2v !< 1/(dx dy^2) at v points [L-3 ~> m-3] + + ! The following variables are precalculated time-invariant combinations of + ! parameters and metric terms. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & + Laplac2_const_xx, & !< Laplacian metric-dependent constants [L2 ~> m2] + Biharm6_const_xx, & !< Biharmonic metric-dependent constants [L6 ~> m6] + Laplac3_const_xx, & !< Laplacian metric-dependent constants [L3 ~> m3] + Biharm_const_xx, & !< Biharmonic metric-dependent constants [L4 ~> m4] + Biharm_const2_xx, & !< Biharmonic metric-dependent constants [T L4 ~> s m4] + Re_Ah_const_xx !< Biharmonic metric-dependent constants [L3 ~> m3] + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & + Laplac2_const_xy, & !< Laplacian metric-dependent constants [L2 ~> m2] + Biharm6_const_xy, & !< Biharmonic metric-dependent constants [L6 ~> m6] + Laplac3_const_xy, & !< Laplacian metric-dependent constants [L3 ~> m3] + Biharm_const_xy, & !< Biharmonic metric-dependent constants [L4 ~> m4] + Biharm_const2_xy, & !< Biharmonic metric-dependent constants [T L4 ~> s m4] + Re_Ah_const_xy !< Biharmonic metric-dependent constants [L3 ~> m3] + + type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics + + ! real, allocatable :: hf_diffu(:,:,:) ! Zonal horizontal viscous acceleleration times + ! ! fractional thickness [L T-2 ~> m s-2]. + ! real, allocatable :: hf_diffv(:,:,:) ! Meridional horizontal viscous acceleleration times + ! ! fractional thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. + ! The code is retained for debugging purposes in the future. + + integer :: num_smooth_gme !< number of smoothing passes for the GME fluxes. + !>@{ + !! Diagnostic id + integer :: id_grid_Re_Ah = -1, id_grid_Re_Kh = -1 + integer :: id_diffu = -1, id_diffv = -1 + ! integer :: id_hf_diffu = -1, id_hf_diffv = -1 + integer :: id_h_diffu = -1, id_h_diffv = -1 + integer :: id_hf_diffu_2d = -1, id_hf_diffv_2d = -1 + integer :: id_intz_diffu_2d = -1, id_intz_diffv_2d = -1 + integer :: id_diffu_visc_rem = -1, id_diffv_visc_rem = -1 + integer :: id_Ah_h = -1, id_Ah_q = -1 + integer :: id_Kh_h = -1, id_Kh_q = -1 + integer :: id_GME_coeff_h = -1, id_GME_coeff_q = -1 + integer :: id_dudx_bt = -1, id_dvdy_bt = -1 + integer :: id_dudy_bt = -1, id_dvdx_bt = -1 + integer :: id_vort_xy_q = -1, id_div_xx_h = -1 + integer :: id_sh_xy_q = -1, id_sh_xx_h = -1 + integer :: id_FrictWork = -1, id_FrictWorkIntz = -1 + integer :: id_FrictWork_GME = -1 + integer :: id_normstress = -1, id_shearstress = -1 + !>@} + +end type hor_visc_CS + +contains + +!> Calculates the acceleration due to the horizontal viscosity. +!! +!! A combination of biharmonic and Laplacian forms can be used. The coefficient +!! may either be a constant or a shear-dependent form. The biharmonic is +!! determined by twice taking the divergence of an appropriately defined stress +!! tensor. The Laplacian is determined by doing so once. +!! +!! To work, the following fields must be set outside of the usual +!! is:ie range before this subroutine is called: +!! u[is-2:ie+2,js-2:je+2] +!! v[is-2:ie+2,js-2:je+2] +!! h[is-1:ie+1,js-1:je+1] +subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, & + CS, OBC, BT, TD, ADp, hu_cont, hv_cont) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: diffu !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: diffv !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor [L T-2 ~> m s-2]. + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + !! related to Mesoscale Eddy Kinetic Energy. + type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure + type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type + type(barotropic_CS), intent(in), optional :: BT !< Barotropic control structure + type(thickness_diffuse_CS), intent(in), optional :: TD !< Thickness diffusion control structure + type(accel_diag_ptrs), intent(in), optional :: ADp !< Acceleration diagnostics + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: hu_cont !< Layer thickness at u-points [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(in) :: hv_cont !< Layer thickness at v-points [H ~> m or kg m-2]. + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G)) :: & + Del2u, & ! The u-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] + h_u, & ! Thickness interpolated to u points [H ~> m or kg m-2]. + vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] + vort_xy_dy_smooth, & ! y-derivative of smoothed vertical vorticity [L-1 T-1 ~> m-1 s-1] + div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] + ubtav, & ! zonal barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] + u_smooth ! Zonal velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G)) :: & + Del2v, & ! The v-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] + h_v, & ! Thickness interpolated to v points [H ~> m or kg m-2]. + vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] + vort_xy_dx_smooth, & ! x-derivative of smoothed vertical vorticity [L-1 T-1 ~> m-1 s-1] + div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] + vbtav, & ! meridional barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] + v_smooth ! Meridional velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G)) :: & + dudx_bt, dvdy_bt, & ! components in the barotropic horizontal tension [T-1 ~> s-1] + div_xx, & ! Estimate of horizontal divergence at h-points [T-1 ~> s-1] + sh_xx, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] + sh_xx_smooth, & ! horizontal tension from smoothed velocity including metric terms [T-1 ~> s-1] + sh_xx_bt, & ! barotropic horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] + str_xx,& ! str_xx is the diagonal term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2], but + ! at some points in the code it is not yet layer integrated, so is in [L2 T-2 ~> m2 s-2]. + str_xx_GME,& ! smoothed diagonal term in the stress tensor from GME [L2 T-2 ~> m2 s-2] + bhstr_xx, & ! A copy of str_xx that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2] + FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [R L2 T-3 ~> W m-2] + grad_vort_mag_h, & ! Magnitude of vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] + grad_vort_mag_h_2d, & ! Magnitude of 2d vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] + grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1] + dudx, dvdy, & ! components in the horizontal tension [T-1 ~> s-1] + dudx_smooth, dvdy_smooth, & ! components in the horizontal tension from smoothed velocity [T-1 ~> s-1] + GME_effic_h, & ! The filtered efficiency of the GME terms at h points [nondim] + htot, & ! The total thickness of all layers [H ~> m or kg m-2] + m_leithy ! Kh=m_leithy*Ah in Leith+E parameterization [L-2 ~> m-2] + real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] + real :: grad_vel_mag_bt_h ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] + real :: boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] + + real, dimension(SZIB_(G),SZJB_(G)) :: & + dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] + dvdx_smooth, dudy_smooth, & ! components in the shearing strain from smoothed velocity [T-1 ~> s-1] + dDel2vdx, dDel2udy, & ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1] + dvdx_bt, dudy_bt, & ! components in the barotropic shearing strain [T-1 ~> s-1] + sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1] + sh_xy_smooth, & ! horizontal shearing strain from smoothed velocity including metric terms [T-1 ~> s-1] + sh_xy_bt, & ! barotropic horizontal shearing strain (du/dy + dv/dx) inc. metric terms [T-1 ~> s-1] + str_xy, & ! str_xy is the cross term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2], but + ! at some points in the code it is not yet layer integrated, so is in [L2 T-2 ~> m2 s-2]. + str_xy_GME, & ! smoothed cross term in the stress tensor from GME [L2 T-2 ~> m2 s-2] + bhstr_xy, & ! A copy of str_xy that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2] + vort_xy, & ! Vertical vorticity (dv/dx - du/dy) including metric terms [T-1 ~> s-1] + vort_xy_smooth, & ! Vertical vorticity including metric terms, smoothed [T-1 ~> s-1] + grad_vort_mag_q, & ! Magnitude of vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] + grad_vort_mag_q_2d, & ! Magnitude of 2d vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] + Del2vort_q, & ! Laplacian of vorticity at q-points [L-2 T-1 ~> m-2 s-1] + grad_div_mag_q, & ! Magnitude of divergence gradient at q-points [L-1 T-1 ~> m-1 s-1] + hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] + ! This form guarantees that hq/hu < 4. + GME_effic_q ! The filtered efficiency of the GME terms at q points [nondim] + real :: grad_vel_mag_bt_q ! Magnitude of the barotropic velocity gradient tensor squared at q-points [T-2 ~> s-2] + real :: boundary_mask_q ! A mask that zeroes out cells with at least one land edge [nondim] + + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & + Ah_q, & ! biharmonic viscosity at corner points [L4 T-1 ~> m4 s-1] + Kh_q, & ! Laplacian viscosity at corner points [L2 T-1 ~> m2 s-1] + vort_xy_q, & ! vertical vorticity at corner points [T-1 ~> s-1] + sh_xy_q, & ! horizontal shearing strain at corner points [T-1 ~> s-1] + GME_coeff_q, & !< GME coeff. at q-points [L2 T-1 ~> m2 s-1] + ShSt ! A diagnostic array of shear stress [T-1 ~> s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & + KH_u_GME !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & + KH_v_GME !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + Ah_h, & ! biharmonic viscosity at thickness points [L4 T-1 ~> m4 s-1] + Kh_h, & ! Laplacian viscosity at thickness points [L2 T-1 ~> m2 s-1] + FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] + FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] + div_xx_h, & ! horizontal divergence [T-1 ~> s-1] + sh_xx_h, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] + NoSt ! A diagnostic array of normal stress [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + grid_Re_Kh, & ! Grid Reynolds number for Laplacian horizontal viscosity at h points [nondim] + grid_Re_Ah, & ! Grid Reynolds number for Biharmonic horizontal viscosity at h points [nondim] + GME_coeff_h ! GME coefficient at h-points [L2 T-1 ~> m2 s-1] + + real :: AhSm ! Smagorinsky biharmonic viscosity [L4 T-1 ~> m4 s-1] + real :: AhLth ! 2D Leith biharmonic viscosity [L4 T-1 ~> m4 s-1] + real :: AhLthy ! 2D Leith+E biharmonic viscosity [L4 T-1 ~> m4 s-1] + real :: Shear_mag_bc ! Shear_mag value in backscatter [T-1 ~> s-1] + real :: sh_xx_sq ! Square of tension (sh_xx) [T-2 ~> s-2] + real :: sh_xy_sq ! Square of shearing strain (sh_xy) [T-2 ~> s-2] + real :: h2uq, h2vq ! temporary variables [H2 ~> m2 or kg2 m-4]. + real :: hu, hv ! Thicknesses interpolated by arithmetic means to corner + ! points; these are first interpolated to u or v velocity + ! points where masks are applied [H ~> m or kg m-2]. + real :: h_arith_q ! The arithmetic mean total thickness at q points [H ~> m or kg m-2] + real :: I_GME_h0 ! The inverse of GME tapering scale [H-1 ~> m-1 or m2 kg-1] + real :: h_neglect ! thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] + real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] + real :: h_min ! Minimum h at the 4 neighboring velocity points [H ~> m] + real :: RoScl ! The scaling function for MEKE source term [nondim] + real :: FatH ! abs(f) at h-point for MEKE source term [T-1 ~> s-1] + real :: local_strain ! Local variable for interpolating computed strain rates [T-1 ~> s-1]. + real :: meke_res_fn ! A copy of the resolution scaling factor if being applied to MEKE [nondim]. Otherwise = 1. + real :: GME_coeff ! The GME (negative) viscosity coefficient [L2 T-1 ~> m2 s-1] + real :: DY_dxBu ! Ratio of meridional over zonal grid spacing at vertices [nondim] + real :: DX_dyBu ! Ratio of zonal over meridional grid spacing at vertices [nondim] + real :: Sh_F_pow ! The ratio of shear over the absolute value of f raised to some power and rescaled [nondim] + real :: backscat_subround ! The ratio of f over Shear_mag that is so small that the backscatter + ! calculation gives the same value as if f were 0 [nondim]. + real :: KE ! Local kinetic energy [L2 T-2 ~> m2 s-2] + real :: d_del2u ! dy-weighted Laplacian(u) diff in x [L-2 T-1 ~> m-2 s-1] + real :: d_del2v ! dx-weighted Laplacian(v) diff in y [L-2 T-1 ~> m-2 s-1] + real :: d_str ! Stress tensor update [L2 T-2 ~> m2 s-2] + real :: grad_vort ! Vorticity gradient magnitude [L-1 T-1 ~> m-1 s-1] + real :: grad_vort_qg ! QG-based vorticity gradient magnitude [L-1 T-1 ~> m-1 s-1] + real :: grid_Kh ! Laplacian viscosity bound by grid [L2 T-1 ~> m2 s-1] + real :: grid_Ah ! Biharmonic viscosity bound by grid [L4 T-1 ~> m4 s-1] + + logical :: rescale_Kh, legacy_bound + logical :: find_FrictWork + logical :: apply_OBC = .false. + logical :: use_MEKE_Ku + logical :: use_MEKE_Au + logical :: use_cont_huv + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n + real :: inv_PI3, inv_PI2, inv_PI6 ! Powers of the inverse of pi [nondim] + + ! Fields evaluated on active layers, used for constructing 3D stress fields + ! NOTE: The position of these declarations can impact performance, due to the + ! very large number of stack arrays in this function. Move with caution! + ! NOTE: Several of these are declared with the memory extent of q-points, but the + ! same arrays are also used at h-points to reduce the memory footprint of this + ! module, so they should never be used in halo point or checksum calls. + real, dimension(SZIB_(G),SZJB_(G)) :: & + Ah, & ! biharmonic viscosity (h or q) [L4 T-1 ~> m4 s-1] + Kh, & ! Laplacian viscosity (h or q) [L2 T-1 ~> m2 s-1] + Shear_mag, & ! magnitude of the shear (h or q) [T-1 ~> s-1] + vert_vort_mag, & ! magnitude of the vertical vorticity gradient (h or q) [L-1 T-1 ~> m-1 s-1] + vert_vort_mag_smooth, & ! magnitude of gradient of smoothed vertical vorticity (h or q) [L-1 T-1 ~> m-1 s-1] + hrat_min, & ! h_min divided by the thickness at the stress point (h or q) [nondim] + visc_bound_rem ! fraction of overall viscous bounds that remain to be applied (h or q) [nondim] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + h_neglect = GV%H_subroundoff + !h_neglect3 = h_neglect**3 + h_neglect3 = h_neglect*h_neglect*h_neglect + inv_PI3 = 1.0/((4.0*atan(1.0))**3) + inv_PI2 = 1.0/((4.0*atan(1.0))**2) + inv_PI6 = inv_PI3 * inv_PI3 + + m_leithy(:,:) = 0.0 ! Initialize + + if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then + apply_OBC = OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally + apply_OBC = .true. + endif ; endif ; endif + + if (.not.CS%initialized) call MOM_error(FATAL, & + "MOM_hor_visc: Module must be initialized before it is used.") + + if (.not.(CS%Laplacian .or. CS%biharmonic)) return + + find_FrictWork = (CS%id_FrictWork > 0) + if (CS%id_FrictWorkIntz > 0) find_FrictWork = .true. + + if (allocated(MEKE%mom_src)) find_FrictWork = .true. + backscat_subround = 0.0 + if (find_FrictWork .and. allocated(MEKE%mom_src) .and. (MEKE%backscatter_Ro_c > 0.0) .and. & + (MEKE%backscatter_Ro_Pow /= 0.0)) & + backscat_subround = (1.0e-16/MEKE%backscatter_Ro_c)**(1.0/MEKE%backscatter_Ro_Pow) + + ! Toggle whether to use a Laplacian viscosity derived from MEKE + use_MEKE_Ku = allocated(MEKE%Ku) + use_MEKE_Au = allocated(MEKE%Au) + + use_cont_huv = CS%use_cont_thick .and. present(hu_cont) .and. present(hv_cont) + + rescale_Kh = .false. + if (VarMix%use_variable_mixing) then + rescale_Kh = VarMix%Resoln_scaled_Kh + if ((rescale_Kh .or. CS%res_scale_MEKE) & + .and. (.not. allocated(VarMix%Res_fn_h) .or. .not. allocated(VarMix%Res_fn_q))) & + call MOM_error(FATAL, "MOM_hor_visc: VarMix%Res_fn_h and VarMix%Res_fn_q "//& + "both need to be associated with Resoln_scaled_Kh or RES_SCALE_MEKE_VISC.") + elseif (CS%res_scale_MEKE) then + call MOM_error(FATAL, "MOM_hor_visc: VarMix needs to be associated if "//& + "RES_SCALE_MEKE_VISC is True.") + endif + + legacy_bound = (CS%Smagorinsky_Kh .or. CS%Leith_Kh) .and. & + (CS%bound_Kh .and. .not.CS%better_bound_Kh) + + if (CS%use_GME) then + + ! Initialize diagnostic arrays with zeros + GME_coeff_h(:,:,:) = 0.0 + GME_coeff_q(:,:,:) = 0.0 + str_xx_GME(:,:) = 0.0 + str_xy_GME(:,:) = 0.0 + + ! Get barotropic velocities and their gradients + call barotropic_get_tav(BT, ubtav, vbtav, G, US) + + call pass_vector(ubtav, vbtav, G%Domain) + call pass_var(h, G%domain, halo=2) + + ! Calculate the barotropic horizontal tension + do J=js-2,je+2 ; do I=is-2,ie+2 + dudx_bt(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * ubtav(I,j) - & + G%IdyCu(I-1,j) * ubtav(I-1,j)) + dvdy_bt(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * vbtav(i,J) - & + G%IdxCv(i,J-1) * vbtav(i,J-1)) + enddo ; enddo + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + sh_xx_bt(i,j) = dudx_bt(i,j) - dvdy_bt(i,j) + enddo ; enddo + + ! Components for the barotropic shearing strain + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + dvdx_bt(I,J) = CS%DY_dxBu(I,J)*(vbtav(i+1,J)*G%IdyCv(i+1,J) & + - vbtav(i,J)*G%IdyCv(i,J)) + dudy_bt(I,J) = CS%DX_dyBu(I,J)*(ubtav(I,j+1)*G%IdxCu(I,j+1) & + - ubtav(I,j)*G%IdxCu(I,j)) + enddo ; enddo + + if (CS%no_slip) then + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + sh_xy_bt(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) + enddo ; enddo + else + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + sh_xy_bt(I,J) = G%mask2dBu(I,J) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) + enddo ; enddo + endif + + do j=js-2,je+2 ; do i=is-2,ie+2 + htot(i,j) = 0.0 + enddo ; enddo + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + htot(i,j) = htot(i,j) + h(i,j,k) + enddo ; enddo ; enddo + + I_GME_h0 = 1.0 / CS%GME_h0 + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + boundary_mask_h = (G%mask2dCu(I,j) * G%mask2dCu(I-1,j)) * (G%mask2dCv(i,J) * G%mask2dCv(i,J-1)) + grad_vel_mag_bt_h = G%mask2dT(I,J) * boundary_mask_h * (dudx_bt(i,j)**2 + dvdy_bt(i,j)**2 + & + (0.25*((dvdx_bt(I,J)+dvdx_bt(I-1,J-1)) + (dvdx_bt(I,J-1)+dvdx_bt(I-1,J))))**2 + & + (0.25*((dudy_bt(I,J)+dudy_bt(I-1,J-1)) + (dudy_bt(I,J-1)+dudy_bt(I-1,J))))**2) + ! Probably the following test could be simplified to + ! if (boundary_mask_h * G%mask2dT(I,J) > 0.0) then + if (grad_vel_mag_bt_h > 0.0) then + GME_effic_h(i,j) = CS%GME_efficiency * G%mask2dT(I,J) * (MIN(htot(i,j) * I_GME_h0, 1.0)**2) + else + GME_effic_h(i,j) = 0.0 + endif + enddo ; enddo + + do J=js-2,je+1 ; do I=is-2,ie+1 + boundary_mask_q = (G%mask2dCv(i,J) * G%mask2dCv(i+1,J)) * (G%mask2dCu(I,j) * G%mask2dCu(I,j+1)) + grad_vel_mag_bt_q = G%mask2dBu(I,J) * boundary_mask_q * (dvdx_bt(I,J)**2 + dudy_bt(I,J)**2 + & + (0.25*((dudx_bt(i,j)+dudx_bt(i+1,j+1)) + (dudx_bt(i,j+1)+dudx_bt(i+1,j))))**2 + & + (0.25*((dvdy_bt(i,j)+dvdy_bt(i+1,j+1)) + (dvdy_bt(i,j+1)+dvdy_bt(i+1,j))))**2) + ! Probably the following test could be simplified to + ! if (boundary_mask_q * G%mask2dBu(I,J) > 0.0) then + if (grad_vel_mag_bt_q > 0.0) then + h_arith_q = 0.25 * ((htot(i,j) + htot(i+1,j+1)) + (htot(i+1,j) + htot(i,j+1))) + GME_effic_q(I,J) = CS%GME_efficiency * G%mask2dBu(I,J) * (MIN(h_arith_q * I_GME_h0, 1.0)**2) + else + GME_effic_q(I,J) = 0.0 + endif + enddo ; enddo + + call thickness_diffuse_get_KH(TD, KH_u_GME, KH_v_GME, G, GV) + + call pass_vector(KH_u_GME, KH_v_GME, G%domain, To_All+Scalar_Pair) + + if (CS%debug) & + call uvchksum("GME KH[u,v]_GME", KH_u_GME, KH_v_GME, G%HI, haloshift=2, scale=US%L_to_m**2*US%s_to_T) + + endif ! use_GME + + !$OMP parallel do default(none) & + !$OMP shared( & + !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, & + !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & + !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & + !$OMP use_MEKE_Ku, use_MEKE_Au, use_cont_huv, & + !$OMP backscat_subround, GME_effic_h, GME_effic_q, & + !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & + !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & + !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & + !$OMP KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt, hu_cont, hv_cont & + !$OMP ) & + !$OMP private( & + !$OMP i, j, k, n, & + !$OMP dudx, dudy, dvdx, dvdy, sh_xx, sh_xy, h_u, h_v, & + !$OMP Del2u, Del2v, DY_dxBu, DX_dyBu, sh_xx_bt, sh_xy_bt, & + !$OMP str_xx, str_xy, bhstr_xx, bhstr_xy, str_xx_GME, str_xy_GME, & + !$OMP vort_xy, vort_xy_dx, vort_xy_dy, div_xx, div_xx_dx, div_xx_dy, & + !$OMP grad_div_mag_h, grad_div_mag_q, grad_vort_mag_h, grad_vort_mag_q, & + !$OMP grad_vort, grad_vort_qg, grad_vort_mag_h_2d, grad_vort_mag_q_2d, & + !$OMP sh_xx_sq, sh_xy_sq, & + !$OMP meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, h_min, hrat_min, visc_bound_rem, & + !$OMP grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, & + !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & + !$OMP dDel2vdx, dDel2udy, Del2vort_q, Del2vort_h, KE, & + !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff, & + !$OMP dudx_smooth, dudy_smooth, dvdx_smooth, dvdy_smooth, & + !$OMP vort_xy_smooth, vort_xy_dx_smooth, vort_xy_dy_smooth, & + !$OMP sh_xx_smooth, sh_xy_smooth, u_smooth, v_smooth, & + !$OMP vert_vort_mag_smooth, m_leithy, AhLthy & + !$OMP ) + do k=1,nz + + ! The following are the forms of the horizontal tension and horizontal + ! shearing strain advocated by Smagorinsky (1993) and discussed in + ! Griffies and Hallberg (2000). + + ! NOTE: There is a ~1% speedup when the tension and shearing loops below + ! are fused (presumably due to shared access of Id[xy]C[uv]). However, + ! this breaks the center/vertex index case convention, and also evaluates + ! the dudx and dvdy terms beyond their valid bounds. + ! TODO: Explore methods for retaining both the syntax and speedup. + + ! Calculate horizontal tension + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + dudx(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * u(I,j,k) - & + G%IdyCu(I-1,j) * u(I-1,j,k)) + dvdy(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * v(i,J,k) - & + G%IdxCv(i,J-1) * v(i,J-1,k)) + sh_xx(i,j) = dudx(i,j) - dvdy(i,j) + enddo ; enddo + + ! Components for the shearing strain + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + dvdx(I,J) = CS%DY_dxBu(I,J)*(v(i+1,J,k)*G%IdyCv(i+1,J) - v(i,J,k)*G%IdyCv(i,J)) + dudy(I,J) = CS%DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j)) + enddo ; enddo + + if (CS%use_Leithy) then + ! Smooth the velocity. Right now it happens twice. In the future + ! one might make the number of smoothing cycles a user-specified parameter + u_smooth(:,:) = u(:,:,k) + v_smooth(:,:) = v(:,:,k) + call smooth_x9(CS, G, field_u=u_smooth,field_v=v_smooth) ! one call applies the filter twice + ! Calculate horizontal tension from smoothed velocity + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + dudx_smooth(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * u_smooth(I,j) - & + G%IdyCu(I-1,j) * u_smooth(I-1,j)) + dvdy_smooth(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * v_smooth(i,J) - & + G%IdxCv(i,J-1) * v_smooth(i,J-1)) + sh_xx_smooth(i,j) = dudx_smooth(i,j) - dvdy_smooth(i,j) + enddo ; enddo + + ! Components for the shearing strain from smoothed velocity + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + dvdx_smooth(I,J) = CS%DY_dxBu(I,J) * & + (v_smooth(i+1,J)*G%IdyCv(i+1,J) - v_smooth(i,J)*G%IdyCv(i,J)) + dudy_smooth(I,J) = CS%DX_dyBu(I,J) * & + (u_smooth(I,j+1)*G%IdxCu(I,j+1) - u_smooth(I,j)*G%IdxCu(I,j)) + enddo ; enddo + end if ! use Leith+E + + if (CS%id_normstress > 0) then + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + NoSt(i,j,k) = sh_xx(i,j) + enddo ; enddo + endif + + ! Interpolate the thicknesses to velocity points. + ! The extra wide halos are to accommodate the cross-corner-point projections + ! in OBCs, which are not ordinarily be necessary, and might not be necessary + ! even with OBCs if the accelerations are zeroed at OBC points, in which + ! case the j-loop for h_u could collapse to j=js=1,je+1. -RWH + if (CS%use_land_mask) then + do j=js-2,je+2 ; do I=Isq-1,Ieq+1 + h_u(I,j) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 + h_v(i,J) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) + enddo ; enddo + else + do j=js-2,je+2 ; do I=Isq-1,Ieq+1 + h_u(I,j) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 + h_v(i,J) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + enddo ; enddo + endif + + ! The following should obviously be combined with the previous block if adopted. + if (use_cont_huv) then + do j=js-2,je+2 ; do I=Isq-1,Ieq+1 + h_u(I,j) = hu_cont(I,j,k) + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 + h_v(i,J) = hv_cont(i,J,k) + enddo ; enddo + endif + + ! Adjust contributions to shearing strain and interpolated values of + ! thicknesses on open boundaries. + if (apply_OBC) then ; do n=1,OBC%number_of_segments + J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB + if (OBC%zero_strain .or. OBC%freeslip_strain .or. OBC%computed_strain) then + if (OBC%segment(n)%is_N_or_S .and. (J >= js-2) .and. (J <= Jeq+1)) then + do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + if (OBC%zero_strain) then + dvdx(I,J) = 0. ; dudy(I,J) = 0. + elseif (OBC%freeslip_strain) then + dudy(I,J) = 0. + elseif (OBC%computed_strain) then + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = 2.0*CS%DX_dyBu(I,J)* & + (OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%IdxCu(I,j) + else + dudy(I,J) = 2.0*CS%DX_dyBu(I,J)* & + (u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdxCu(I,j+1) + endif + elseif (OBC%specified_strain) then + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j)*G%dxBu(I,J) + else + dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j+1)*G%dxBu(I,J) + endif + endif + enddo + elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-2) .and. (I <= Ieq+1)) then + do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + if (OBC%zero_strain) then + dvdx(I,J) = 0. ; dudy(I,J) = 0. + elseif (OBC%freeslip_strain) then + dvdx(I,J) = 0. + elseif (OBC%computed_strain) then + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)* & + (OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%IdyCv(i,J) + else + dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)* & + (v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdyCv(i+1,J) + endif + elseif (OBC%specified_strain) then + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i,J)*G%dxBu(I,J) + else + dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i+1,J)*G%dxBu(I,J) + endif + endif + enddo + endif + endif + + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + ! There are extra wide halos here to accommodate the cross-corner-point + ! OBC projections, but they might not be necessary if the accelerations + ! are always zeroed out at OBC points, in which case the i-loop below + ! becomes do i=is-1,ie+1. -RWH + if ((J >= Jsq-1) .and. (J <= Jeq+1)) then + do i = max(is-2,OBC%segment(n)%HI%isd), min(ie+2,OBC%segment(n)%HI%ied) + h_v(i,J) = h(i,j,k) + enddo + endif + elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then + if ((J >= Jsq-1) .and. (J <= Jeq+1)) then + do i = max(is-2,OBC%segment(n)%HI%isd), min(ie+2,OBC%segment(n)%HI%ied) + h_v(i,J) = h(i,j+1,k) + enddo + endif + elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then + if ((I >= Isq-1) .and. (I <= Ieq+1)) then + do j = max(js-2,OBC%segment(n)%HI%jsd), min(je+2,OBC%segment(n)%HI%jed) + h_u(I,j) = h(i,j,k) + enddo + endif + elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then + if ((I >= Isq-1) .and. (I <= Ieq+1)) then + do j = max(js-2,OBC%segment(n)%HI%jsd), min(je+2,OBC%segment(n)%HI%jed) + h_u(I,j) = h(i+1,j,k) + enddo + endif + endif + enddo ; endif + ! Now project thicknesses across corner points on OBCs. + if (apply_OBC) then ; do n=1,OBC%number_of_segments + J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + if ((J >= js-2) .and. (J <= je)) then + do I = max(Isq-1,OBC%segment(n)%HI%IsdB), min(Ieq+1,OBC%segment(n)%HI%IedB) + h_u(I,j+1) = h_u(I,j) + enddo + endif + elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then + if ((J >= js-1) .and. (J <= je+1)) then + do I = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+1,OBC%segment(n)%HI%ied) + h_u(I,j) = h_u(I,j+1) + enddo + endif + elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then + if ((I >= is-2) .and. (I <= ie)) then + do J = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed) + h_v(i+1,J) = h_v(i,J) + enddo + endif + elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then + if ((I >= is-1) .and. (I <= ie+1)) then + do J = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed) + h_v(i,J) = h_v(i+1,J) + enddo + endif + endif + enddo ; endif + + ! Shearing strain (including no-slip boundary conditions at the 2-D land-sea mask). + ! dudy and dvdx include modifications at OBCs from above. + if (CS%no_slip) then + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + sh_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) + dudy(I,J) ) + if (CS%id_shearstress > 0) ShSt(I,J,k) = sh_xy(I,J) + enddo ; enddo + else + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + sh_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) + dudy(I,J) ) + if (CS%id_shearstress > 0) ShSt(I,J,k) = sh_xy(I,J) + enddo ; enddo + endif + + if (CS%use_Leithy) then + ! Shearing strain (including no-slip boundary conditions at the 2-D land-sea mask). + ! dudy_smooth and dvdx_smooth do not (yet) include modifications at OBCs from above. + if (CS%no_slip) then + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + sh_xy_smooth(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_smooth(I,J) + dudy_smooth(I,J) ) + enddo ; enddo + else + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + sh_xy_smooth(I,J) = G%mask2dBu(I,J) * ( dvdx_smooth(I,J) + dudy_smooth(I,J) ) + enddo ; enddo + endif + endif ! use Leith+E + + ! Evaluate Del2u = x.Div(Grad u) and Del2v = y.Div( Grad u) + if (CS%biharmonic) then + do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 + Del2u(I,j) = CS%Idxdy2u(I,j)*(CS%dy2h(i+1,j)*sh_xx(i+1,j) - CS%dy2h(i,j)*sh_xx(i,j)) + & + CS%Idx2dyCu(I,j)*(CS%dx2q(I,J)*sh_xy(I,J) - CS%dx2q(I,J-1)*sh_xy(I,J-1)) + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do i=is-1,Ieq+1 + Del2v(i,J) = CS%Idxdy2v(i,J)*(CS%dy2q(I,J)*sh_xy(I,J) - CS%dy2q(I-1,J)*sh_xy(I-1,J)) - & + CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*sh_xx(i,j+1) - CS%dx2h(i,j)*sh_xx(i,j)) + enddo ; enddo + if (apply_OBC) then ; if (OBC%zero_biharmonic) then + do n=1,OBC%number_of_segments + I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB + if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then + do I=OBC%segment(n)%HI%isd,OBC%segment(n)%HI%ied + Del2v(i,J) = 0. + enddo + elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then + do j=OBC%segment(n)%HI%jsd,OBC%segment(n)%HI%jed + Del2u(I,j) = 0. + enddo + endif + enddo + endif ; endif + endif + + ! Vorticity + if (CS%no_slip) then + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + else + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + endif + + if (CS%use_Leithy) then + if (CS%no_slip) then + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + vort_xy_smooth(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_smooth(I,J) - dudy_smooth(I,J) ) + enddo ; enddo + else + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + vort_xy_smooth(I,J) = G%mask2dBu(I,J) * ( dvdx_smooth(I,J) - dudy_smooth(I,J) ) + enddo ; enddo + endif + endif + + ! Divergence + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + div_xx(i,j) = dudx(i,j) + dvdy(i,j) + enddo ; enddo + + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then + + ! Vorticity gradient + do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) + vort_xy_dx(i,J) = DY_dxBu * (vort_xy(I,J) * G%IdyCu(I,j) - vort_xy(I-1,J) * G%IdyCu(I-1,j)) + enddo ; enddo + + do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 + DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) + vort_xy_dy(I,j) = DX_dyBu * (vort_xy(I,J) * G%IdxCv(i,J) - vort_xy(I,J-1) * G%IdxCv(i,J-1)) + enddo ; enddo + + if (CS%use_Leithy) then + ! Gradient of smoothed vorticity + do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) + vort_xy_dx_smooth(i,J) = DY_dxBu * & + (vort_xy_smooth(I,J) * G%IdyCu(I,j) - vort_xy_smooth(I-1,J) * G%IdyCu(I-1,j)) + enddo ; enddo + + do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 + DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) + vort_xy_dy_smooth(I,j) = DX_dyBu * & + (vort_xy_smooth(I,J) * G%IdxCv(i,J) - vort_xy_smooth(I,J-1) * G%IdxCv(i,J-1)) + enddo ; enddo + endif ! If Leithy + + ! Laplacian of vorticity + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) + DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) + + Del2vort_q(I,J) = DY_dxBu * (vort_xy_dx(i+1,J) * G%IdyCv(i+1,J) - vort_xy_dx(i,J) * G%IdyCv(i,J)) + & + DX_dyBu * (vort_xy_dy(I,j+1) * G%IdyCu(I,j+1) - vort_xy_dy(I,j) * G%IdyCu(I,j)) + enddo ; enddo + + if (CS%modified_Leith) then + + ! Divergence gradient + do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 + div_xx_dx(I,j) = G%IdxCu(I,j)*(div_xx(i+1,j) - div_xx(i,j)) + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + div_xx_dy(i,J) = G%IdyCv(i,J)*(div_xx(i,j+1) - div_xx(i,j)) + enddo ; enddo + + ! Magnitude of divergence gradient + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + grad_div_mag_h(i,j) = sqrt((0.5*(div_xx_dx(I,j) + div_xx_dx(I-1,j)))**2 + & + (0.5*(div_xx_dy(i,J) + div_xx_dy(i,J-1)))**2) + enddo ; enddo + do j=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+1 + grad_div_mag_q(I,J) = sqrt((0.5*(div_xx_dx(I,j) + div_xx_dx(I,j+1)))**2 + & + (0.5*(div_xx_dy(i,J) + div_xx_dy(i+1,J)))**2) + enddo ; enddo + + else + + do j=Jsq-1,Jeq+2 ; do I=is-2,Ieq+1 + div_xx_dx(I,j) = 0.0 + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + div_xx_dy(i,J) = 0.0 + enddo ; enddo + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + grad_div_mag_h(i,j) = 0.0 + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + grad_div_mag_q(I,J) = 0.0 + enddo ; enddo + + endif ! CS%modified_Leith + + ! Add in beta for the Leith viscosity + if (CS%use_beta_in_Leith) then + do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 + vort_xy_dx(i,J) = vort_xy_dx(i,J) + 0.5 * ( G%dF_dx(i,j) + G%dF_dx(i,j+1)) + enddo ; enddo + do j=js-1,Jeq+1 ; do I=is-2,Ieq+1 + vort_xy_dy(I,j) = vort_xy_dy(I,j) + 0.5 * ( G%dF_dy(i,j) + G%dF_dy(i+1,j)) + enddo ; enddo + endif ! CS%use_beta_in_Leith + + if (CS%use_QG_Leith_visc) then + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + grad_vort_mag_h_2d(i,j) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i,J-1)))**2 + & + (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j)))**2 ) + enddo ; enddo + do J=js-1,Jeq ; do I=is-1,Ieq + grad_vort_mag_q_2d(I,J) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i+1,J)))**2 + & + (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2 ) + enddo ; enddo + + ! This accumulates terms, some of which are in VarMix, so rescaling can not be done here. + call calc_QG_Leith_viscosity(VarMix, G, GV, US, h, k, div_xx_dx, div_xx_dy, & + vort_xy_dx, vort_xy_dy) + + endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + grad_vort_mag_h(i,j) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i,J-1)))**2 + & + (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j)))**2 ) + enddo ; enddo + do J=js-1,Jeq ; do I=is-1,Ieq + grad_vort_mag_q(I,J) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i+1,J)))**2 + & + (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2 ) + enddo ; enddo + + if (CS%use_Leithy) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + vert_vort_mag_smooth(i,j) = SQRT((0.5*(vort_xy_dx_smooth(i,J) + & + vort_xy_dx_smooth(i,J-1)))**2 + & + (0.5*(vort_xy_dy_smooth(I,j) + & + vort_xy_dy_smooth(I-1,j)))**2 ) + enddo ; enddo + endif ! Leithy + + endif ! CS%Leith_Kh + + if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + sh_xx_sq = sh_xx(i,j)**2 + sh_xy_sq = 0.25 * ( (sh_xy(I-1,J-1)**2 + sh_xy(I,J)**2) & + + (sh_xy(I-1,J)**2 + sh_xy(I,J-1)**2) ) + Shear_mag(i,j) = sqrt(sh_xx_sq + sh_xy_sq) + enddo ; enddo + endif + + if (CS%better_bound_Ah .or. CS%better_bound_Kh) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + h_min = min(h_u(I,j), h_u(I-1,j), h_v(i,J), h_v(i,J-1)) + hrat_min(i,j) = min(1.0, h_min / (h(i,j,k) + h_neglect)) + enddo ; enddo + + if (CS%better_bound_Kh) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + visc_bound_rem(i,j) = 1.0 + enddo ; enddo + endif + endif + + if (CS%Laplacian) then + ! Determine the Laplacian viscosity at h points, using the + ! largest value from several parameterizations. Also get + ! the Laplacian component of str_xx. + + if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + if (CS%use_QG_Leith_visc) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + grad_vort = grad_vort_mag_h(i,j) + grad_div_mag_h(i,j) + grad_vort_qg = 3. * grad_vort_mag_h_2d(i,j) + vert_vort_mag(i,j) = min(grad_vort, grad_vort_qg) + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + vert_vort_mag(i,j) = grad_vort_mag_h(i,j) + grad_div_mag_h(i,j) + enddo ; enddo + endif + endif + + ! Static (pre-computed) background viscosity + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh(i,j) = CS%Kh_bg_xx(i,j) + enddo ; enddo + + ! NOTE: The following do-block can be decomposed and vectorized after the + ! stack size has been reduced. + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (CS%add_LES_viscosity) then + if (CS%Smagorinsky_Kh) & + Kh(i,j) = Kh(i,j) + CS%Laplac2_const_xx(i,j) * Shear_mag(i,j) + if (CS%Leith_Kh) & + Kh(i,j) = Kh(i,j) + CS%Laplac3_const_xx(i,j) * vert_vort_mag(i,j) * inv_PI3 + else + if (CS%Smagorinsky_Kh) & + Kh(i,j) = max(Kh(i,j), CS%Laplac2_const_xx(i,j) * Shear_mag(i,j)) + if (CS%Leith_Kh) & + Kh(i,j) = max(Kh(i,j), CS%Laplac3_const_xx(i,j) * vert_vort_mag(i,j) * inv_PI3) + endif + enddo ; enddo + + ! All viscosity contributions above are subject to resolution scaling + + if (rescale_Kh) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh(i,j) = VarMix%Res_fn_h(i,j) * Kh(i,j) + enddo ; enddo + endif + + if (legacy_bound) then + ! Older method of bounding for stability + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh(i,j) = min(Kh(i,j), CS%Kh_Max_xx(i,j)) + enddo ; enddo + endif + + ! Place a floor on the viscosity, if desired. + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh(i,j) = max(Kh(i,j), CS%Kh_bg_min) + enddo ; enddo + + if (use_MEKE_Ku) then + ! *Add* the MEKE contribution (which might be negative) + if (CS%res_scale_MEKE) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) + enddo ; enddo + endif + endif + + if (CS%anisotropic) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ! *Add* the tension component of anisotropic viscosity + Kh(i,j) = Kh(i,j) + CS%Kh_aniso * (1. - CS%n1n2_h(i,j)**2) + enddo ; enddo + endif + + ! Newer method of bounding for stability + if (CS%better_bound_Kh) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (Kh(i,j) >= hrat_min(i,j) * CS%Kh_Max_xx(i,j)) then + visc_bound_rem(i,j) = 0.0 + Kh(i,j) = hrat_min(i,j) * CS%Kh_Max_xx(i,j) + else ! if (Kh(i,j) > 0.0) then !### Change this to avoid a zero denominator. + visc_bound_rem(i,j) = 1.0 - Kh(i,j) / (hrat_min(i,j) * CS%Kh_Max_xx(i,j)) + endif + enddo ; enddo + endif + + ! In Leith+E parameterization Kh is computed after Ah in the biharmonic loop. + ! The harmonic component of str_xx is added in the biharmonic loop. + if (CS%use_Leithy) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh(i,j) = 0. + enddo ; enddo + end if + + if (CS%id_Kh_h>0 .or. CS%debug) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh_h(i,j,k) = Kh(i,j) + enddo ; enddo + endif + + if (CS%id_grid_Re_Kh>0) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + grid_Kh = max(Kh(i,j), CS%min_grid_Kh) + grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j))) / grid_Kh + enddo ; enddo + endif + + if (CS%id_div_xx_h>0) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + div_xx_h(i,j,k) = div_xx(i,j) + enddo ; enddo + endif + + if (CS%id_sh_xx_h>0) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + sh_xx_h(i,j,k) = sh_xx(i,j) + enddo ; enddo + endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + str_xx(i,j) = -Kh(i,j) * sh_xx(i,j) + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + str_xx(i,j) = 0.0 + enddo ; enddo + endif ! Get Kh at h points and get Laplacian component of str_xx + + if (CS%anisotropic) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ! Shearing-strain averaged to h-points + local_strain = 0.25 * ( (sh_xy(I,J) + sh_xy(I-1,J-1)) + (sh_xy(I-1,J) + sh_xy(I,J-1)) ) + ! *Add* the shear-strain contribution to the xx-component of stress + str_xx(i,j) = str_xx(i,j) - CS%Kh_aniso * CS%n1n2_h(i,j) * CS%n1n1_m_n2n2_h(i,j) * local_strain + enddo ; enddo + endif + + if (CS%biharmonic) then + ! Determine the biharmonic viscosity at h points, using the + ! largest value from several parameterizations. Also get the + ! biharmonic component of str_xx. + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah(i,j) = CS%Ah_bg_xx(i,j) + enddo ; enddo + + if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then + if (CS%Smagorinsky_Ah) then + if (CS%bound_Coriolis) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + AhSm = Shear_mag(i,j) * (CS%Biharm_const_xx(i,j) & + + CS%Biharm_const2_xx(i,j) * Shear_mag(i,j) & + ) + Ah(i,j) = max(Ah(i,j), AhSm) + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + AhSm = CS%Biharm_const_xx(i,j) * Shear_mag(i,j) + Ah(i,j) = max(Ah(i,j), AhSm) + enddo ; enddo + endif + endif + + if (CS%Leith_Ah) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & + (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) + AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h) * inv_PI6 + Ah(i,j) = max(Ah(i,j), AhLth) + enddo ; enddo + endif + + if (CS%use_Leithy) then + ! Get m_leithy + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & + (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) + AhLth = CS%Biharm6_const_xx(i,j) * inv_PI6 * abs(Del2vort_h) + if (AhLth <= CS%Ah_bg_xx(i,j)) then + m_leithy(i,j) = 0.0 + else + if ((CS%m_const_leithy(i,j)*vert_vort_mag(i,j)) < abs(vort_xy_smooth(i,j))) then + m_leithy(i,j) = CS%c_K * (vert_vort_mag(i,j) / vort_xy_smooth(i,j))**2 + else + m_leithy(i,j) = CS%m_leithy_max(i,j) + endif + endif + enddo ; enddo + ! Smooth m_leithy + call smooth_x9(CS, G, field_h=m_leithy, zero_land=.true.) + ! Get Ah + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & + (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) + AhLthy = CS%Biharm6_const_xx(i,j) * inv_PI6 * & + sqrt(max(0.,Del2vort_h**2 - m_leithy(i,j)*vert_vort_mag_smooth(i,j)**2)) + Ah(i,j) = max(CS%Ah_bg_xx(i,j), AhLthy) + enddo ; enddo + ! Smooth Ah before applying upper bound + ! square, then smooth, then square root + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah_h(i,j,k) = Ah(i,j)**2 + enddo ; enddo + call smooth_x9(CS, G, field_h=Ah_h(:,:,k)) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah_h(i,j,k) = sqrt(Ah_h(i,j,k)) + Ah(i,j) = Ah_h(i,j,k) + enddo ; enddo + endif + + if (CS%bound_Ah .and. .not. CS%better_bound_Ah) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah(i,j) = min(Ah(i,j), CS%Ah_Max_xx(i,j)) + enddo ; enddo + endif + endif ! Smagorinsky_Ah or Leith_Ah or Leith+E + + if (use_MEKE_Au) then + ! *Add* the MEKE contribution + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah(i,j) = Ah(i,j) + MEKE%Au(i,j) + enddo ; enddo + endif + + if (CS%Re_Ah > 0.0) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + Ah(i,j) = sqrt(KE) * CS%Re_Ah_const_xx(i,j) + enddo ; enddo + endif + + if (CS%better_bound_Ah) then + if (CS%better_bound_Kh) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah(i,j) = min(Ah(i,j), visc_bound_rem(i,j) * hrat_min(i,j) * CS%Ah_Max_xx(i,j)) + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah(i,j) = min(Ah(i,j), hrat_min(i,j) * CS%Ah_Max_xx(i,j)) + enddo ; enddo + endif + endif + + if ((CS%id_Ah_h>0) .or. CS%debug) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah_h(i,j,k) = Ah(i,j) + enddo ; enddo + endif + + if (CS%use_Leithy) then + ! Compute Leith+E Kh after bounds have been applied to Ah + ! and after it has been smoothed. Kh = -m_leithy * Ah + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh(i,j) = -m_leithy(i,j) * Ah(i,j) + Kh_h(i,j,k) = Kh(i,j) + enddo ; enddo + endif + + if (CS%id_grid_Re_Ah>0) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + KE = 0.125 * ((u(I,j,k) + u(I-1,j,k))**2 + (v(i,J,k) + v(i,J-1,k))**2) + grid_Ah = max(Ah(i,j), CS%min_grid_Ah) + grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j)) / grid_Ah + enddo ; enddo + endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + d_del2u = G%IdyCu(I,j) * Del2u(I,j) - G%IdyCu(I-1,j) * Del2u(I-1,j) + d_del2v = G%IdxCv(i,J) * Del2v(i,J) - G%IdxCv(i,J-1) * Del2v(i,J-1) + d_str = Ah(i,j) * (CS%DY_dxT(i,j) * d_del2u - CS%DX_dyT(i,j) * d_del2v) + + str_xx(i,j) = str_xx(i,j) + d_str + + if (CS%use_Leithy) str_xx(i,j) = str_xx(i,j) - Kh(i,j) * sh_xx_smooth(i,j) + + ! Keep a copy of the biharmonic contribution for backscatter parameterization + bhstr_xx(i,j) = d_str * (h(i,j,k) * CS%reduction_xx(i,j)) + enddo ; enddo + endif ! Get biharmonic coefficient at h points and biharmonic part of str_xx + + if (CS%biharmonic) then + ! Gradient of Laplacian, for use in bi-harmonic term + do J=js-1,Jeq ; do I=is-1,Ieq + dDel2vdx(I,J) = CS%DY_dxBu(I,J)*(Del2v(i+1,J)*G%IdyCv(i+1,J) - Del2v(i,J)*G%IdyCv(i,J)) + dDel2udy(I,J) = CS%DX_dyBu(I,J)*(Del2u(I,j+1)*G%IdxCu(I,j+1) - Del2u(I,j)*G%IdxCu(I,j)) + enddo ; enddo + ! Adjust contributions to shearing strain on open boundaries. + if (apply_OBC) then ; if (OBC%zero_strain .or. OBC%freeslip_strain) then + do n=1,OBC%number_of_segments + J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB + if (OBC%segment(n)%is_N_or_S .and. (J >= js-1) .and. (J <= Jeq)) then + do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + if (OBC%zero_strain) then + dDel2vdx(I,J) = 0. ; dDel2udy(I,J) = 0. + elseif (OBC%freeslip_strain) then + dDel2udy(I,J) = 0. + endif + enddo + elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= Ieq)) then + do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + if (OBC%zero_strain) then + dDel2vdx(I,J) = 0. ; dDel2udy(I,J) = 0. + elseif (OBC%freeslip_strain) then + dDel2vdx(I,J) = 0. + endif + enddo + endif + enddo + endif ; endif + endif + + meke_res_fn = 1. + + if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then + do J=js-1,Jeq ; do I=is-1,Ieq + sh_xy_sq = sh_xy(I,J)**2 + sh_xx_sq = 0.25 * ( (sh_xx(i,j)**2 + sh_xx(i+1,j+1)**2) & + + (sh_xx(i,j+1)**2 + sh_xx(i+1,j)**2) ) + Shear_mag(I,J) = sqrt(sh_xy_sq + sh_xx_sq) + enddo ; enddo + endif + + do J=js-1,Jeq ; do I=is-1,Ieq + h2uq = 4.0 * (h_u(I,j) * h_u(I,j+1)) + h2vq = 4.0 * (h_v(i,J) * h_v(i+1,J)) + hq(I,J) = (2.0 * (h2uq * h2vq)) & + / (h_neglect3 + (h2uq + h2vq) * ((h_u(I,j) + h_u(I,j+1)) + (h_v(i,J) + h_v(i+1,J)))) + enddo ; enddo + + if (CS%better_bound_Ah .or. CS%better_bound_Kh) then + do J=js-1,Jeq ; do I=is-1,Ieq + h_min = min(h_u(I,j), h_u(I,j+1), h_v(i,J), h_v(i+1,J)) + hrat_min(I,J) = min(1.0, h_min / (hq(I,J) + h_neglect)) + enddo ; enddo + + if (CS%better_bound_Kh) then + do J=js-1,Jeq ; do I=is-1,Ieq + visc_bound_rem(I,J) = 1.0 + enddo ; enddo + endif + endif + + if (CS%no_slip) then + do J=js-1,Jeq ; do I=is-1,Ieq + if (CS%no_slip .and. (G%mask2dBu(I,J) < 0.5)) then + if ((G%mask2dCu(I,j) + G%mask2dCu(I,j+1)) + & + (G%mask2dCv(i,J) + G%mask2dCv(i+1,J)) > 0.0) then + ! This is a coastal vorticity point, so modify hq and hrat_min. + + hu = G%mask2dCu(I,j) * h_u(I,j) + G%mask2dCu(I,j+1) * h_u(I,j+1) + hv = G%mask2dCv(i,J) * h_v(i,J) + G%mask2dCv(i+1,J) * h_v(i+1,J) + if ((G%mask2dCu(I,j) + G%mask2dCu(I,j+1)) * & + (G%mask2dCv(i,J) + G%mask2dCv(i+1,J)) == 0.0) then + ! Only one of hu and hv is nonzero, so just add them. + hq(I,J) = hu + hv + hrat_min(I,J) = 1.0 + else + ! Both hu and hv are nonzero, so take the harmonic mean. + hq(I,J) = 2.0 * (hu * hv) / ((hu + hv) + h_neglect) + hrat_min(I,J) = min(1.0, min(hu, hv) / (hq(I,J) + h_neglect) ) + endif + endif + endif + enddo ; enddo + endif + + ! Pass the velocity gradients and thickness to ZB2020 + if (CS%use_ZB2020) then + call ZB2020_copy_gradient_and_thickness( & + sh_xx, sh_xy, vort_xy, & + hq, & + G, GV, CS%ZB2020, k) + endif + + if (CS%Laplacian) then + ! Determine the Laplacian viscosity at q points, using the + ! largest value from several parameterizations. Also get the + ! Laplacian component of str_xy. + + if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + if (CS%use_QG_Leith_visc) then + do J=js-1,Jeq ; do I=is-1,Ieq + grad_vort = grad_vort_mag_q(I,J) + grad_div_mag_q(I,J) + grad_vort_qg = 3. * grad_vort_mag_q_2d(I,J) + vert_vort_mag(I,J) = min(grad_vort, grad_vort_qg) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + vert_vort_mag(I,J) = grad_vort_mag_q(I,J) + grad_div_mag_q(I,J) + enddo ; enddo + endif + endif + + ! Static (pre-computed) background viscosity + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(I,J) = CS%Kh_bg_xy(I,J) + enddo ; enddo + + if (CS%Smagorinsky_Kh) then + if (CS%add_LES_viscosity) then + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(I,J) = Kh(I,J) + CS%Laplac2_const_xy(I,J) * Shear_mag(I,J) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(I,J) = max(Kh(I,J), CS%Laplac2_const_xy(I,J) * Shear_mag(I,J) ) + enddo ; enddo + endif + endif + + if (CS%Leith_Kh) then + if (CS%add_LES_viscosity) then + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(I,J) = Kh(I,J) + CS%Laplac3_const_xy(I,J) * vert_vort_mag(I,J) * inv_PI3 ! Is this right? -AJA + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(I,J) = max(Kh(I,J), CS%Laplac3_const_xy(I,J) * vert_vort_mag(I,J) * inv_PI3) + enddo ; enddo + endif + endif + + ! All viscosity contributions above are subject to resolution scaling + + ! NOTE: The following do-block can be decomposed and vectorized after the + ! stack size has been reduced. + do J=js-1,Jeq ; do I=is-1,Ieq + if (rescale_Kh) & + Kh(I,J) = VarMix%Res_fn_q(I,J) * Kh(I,J) + + if (CS%res_scale_MEKE) & + meke_res_fn = VarMix%Res_fn_q(I,J) + + ! Older method of bounding for stability + if (legacy_bound) & + Kh(I,J) = min(Kh(I,J), CS%Kh_Max_xy(I,J)) + + Kh(I,J) = max(Kh(I,J), CS%Kh_bg_min) ! Place a floor on the viscosity, if desired. + + if (use_MEKE_Ku) then + ! *Add* the MEKE contribution (might be negative) + Kh(I,J) = Kh(I,J) + 0.25*( (MEKE%Ku(i,j) + MEKE%Ku(i+1,j+1)) + & + (MEKE%Ku(i+1,j) + MEKE%Ku(i,j+1)) ) * meke_res_fn + endif + + if (CS%anisotropic) & + ! *Add* the shear component of anisotropic viscosity + Kh(I,J) = Kh(I,J) + CS%Kh_aniso * CS%n1n2_q(I,J)**2 + + ! Newer method of bounding for stability + if (CS%better_bound_Kh) then + if (Kh(I,J) >= hrat_min(I,J) * CS%Kh_Max_xy(I,J)) then + visc_bound_rem(I,J) = 0.0 + Kh(I,J) = hrat_min(I,J) * CS%Kh_Max_xy(I,J) + elseif (hrat_min(I,J)*CS%Kh_Max_xy(I,J)>0.) then !### Change to elseif (Kh(I,J) > 0.0) then + visc_bound_rem(I,J) = 1.0 - Kh(I,J) / (hrat_min(I,J) * CS%Kh_Max_xy(I,J)) + endif + endif + + ! Leith+E doesn't recompute Kh at q points, it just interpolates it from h to q points + if (CS%use_Leithy) then + Kh(I,J) = Kh_h(i+1,j+1,k) + end if + + if (CS%id_Kh_q>0 .or. CS%debug) & + Kh_q(I,J,k) = Kh(I,J) + + if (CS%id_vort_xy_q>0) & + vort_xy_q(I,J,k) = vort_xy(I,J) + + if (CS%id_sh_xy_q>0) & + sh_xy_q(I,J,k) = sh_xy(I,J) + enddo ; enddo + + if ( .not. CS%use_Leithy) then + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = -Kh(I,J) * sh_xy(I,J) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = -Kh(I,J) * sh_xy_smooth(I,J) + enddo ; enddo + endif + else + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = 0. + enddo ; enddo + endif ! get harmonic coefficient Kh at q points and harmonic part of str_xy + + if (CS%anisotropic) then + do J=js-1,Jeq ; do I=is-1,Ieq + ! Horizontal-tension averaged to q-points + local_strain = 0.25 * ( (sh_xx(i,j) + sh_xx(i+1,j+1)) + (sh_xx(i+1,j) + sh_xx(i,j+1)) ) + ! *Add* the tension contribution to the xy-component of stress + str_xy(I,J) = str_xy(I,J) - CS%Kh_aniso * CS%n1n2_q(I,J) * CS%n1n1_m_n2n2_q(I,J) * local_strain + enddo ; enddo + endif + + if (CS%biharmonic) then + ! Determine the biharmonic viscosity at q points, using the + ! largest value from several parameterizations. Also get the + ! biharmonic component of str_xy. + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(I,J) = CS%Ah_bg_xy(I,J) + enddo ; enddo + + if (CS%Smagorinsky_Ah .or. CS%Leith_Ah) then + if (CS%Smagorinsky_Ah) then + if (CS%bound_Coriolis) then + do J=js-1,Jeq ; do I=is-1,Ieq + AhSm = Shear_mag(I,J) * (CS%Biharm_const_xy(I,J) & + + CS%Biharm_const2_xy(I,J) * Shear_mag(I,J) & + ) + Ah(I,J) = max(Ah(I,J), AhSm) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + AhSm = CS%Biharm_const_xy(I,J) * Shear_mag(I,J) + Ah(I,J) = max(Ah(I,J), AhSm) + enddo ; enddo + endif + endif + + if (CS%Leith_Ah) then + do J=js-1,Jeq ; do I=is-1,Ieq + AhLth = CS%Biharm6_const_xy(I,J) * abs(Del2vort_q(I,J)) * inv_PI6 + Ah(I,J) = max(Ah(I,J), AhLth) + enddo ; enddo + endif + + if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(I,J) = min(Ah(I,J), CS%Ah_Max_xy(I,J)) + enddo ; enddo + endif + endif ! Smagorinsky_Ah or Leith_Ah + + if (use_MEKE_Au) then + ! *Add* the MEKE contribution + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(I,J) = Ah(I,J) + 0.25 * ( & + (MEKE%Au(i,j) + MEKE%Au(i+1,j+1)) + (MEKE%Au(i+1,j) + MEKE%Au(i,j+1)) & + ) + enddo ; enddo + endif + + if (CS%Re_Ah > 0.0) then + do J=js-1,Jeq ; do I=is-1,Ieq + KE = 0.125 * ((u(I,j,k) + u(I,j+1,k))**2 + (v(i,J,k) + v(i+1,J,k))**2) + Ah(I,J) = sqrt(KE) * CS%Re_Ah_const_xy(I,J) + enddo ; enddo + endif + + if (CS%better_bound_Ah) then + if (CS%better_bound_Kh) then + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(I,J) = min(Ah(I,J), visc_bound_rem(I,J) * hrat_min(I,J) * CS%Ah_Max_xy(I,J)) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(I,J) = min(Ah(I,J), hrat_min(I,J) * CS%Ah_Max_xy(I,J)) + enddo ; enddo + endif + endif + + ! Leith+E doesn't recompute Ah at q points, it just interpolates it from h to q points + if (CS%use_Leithy) then + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(I,J) = Ah_h(i+1,j+1,k) + enddo ; enddo + end if + + if (CS%id_Ah_q>0 .or. CS%debug) then + do J=js-1,Jeq ; do I=is-1,Ieq + Ah_q(I,J,k) = Ah(I,J) + enddo ; enddo + endif + + ! Again, need to initialize str_xy as if its biharmonic + do J=js-1,Jeq ; do I=is-1,Ieq + d_str = Ah(I,J) * (dDel2vdx(I,J) + dDel2udy(I,J)) + + str_xy(I,J) = str_xy(I,J) + d_str + + ! Keep a copy of the biharmonic contribution for backscatter parameterization + bhstr_xy(I,J) = d_str * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J)) + enddo ; enddo + endif ! Get Ah at q points and biharmonic part of str_xy + + if (CS%use_GME) then + ! The wider halo here is to permit one pass of smoothing without a halo update. + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + GME_coeff = GME_effic_h(i,j) * 0.25 * & + ((KH_u_GME(I,j,k)+KH_u_GME(I-1,j,k)) + (KH_v_GME(i,J,k)+KH_v_GME(i,J-1,k))) + GME_coeff = MIN(GME_coeff, CS%GME_limiter) + + if ((CS%id_GME_coeff_h>0) .or. find_FrictWork) GME_coeff_h(i,j,k) = GME_coeff + str_xx_GME(i,j) = GME_coeff * sh_xx_bt(i,j) + enddo ; enddo + + ! The wider halo here is to permit one pass of smoothing without a halo update. + do J=js-2,je+1 ; do I=is-2,ie+1 + GME_coeff = GME_effic_q(I,J) * 0.25 * & + ((KH_u_GME(I,j,k)+KH_u_GME(I,j+1,k)) + (KH_v_GME(i,J,k)+KH_v_GME(i+1,J,k))) + GME_coeff = MIN(GME_coeff, CS%GME_limiter) + + if (CS%id_GME_coeff_q>0) GME_coeff_q(I,J,k) = GME_coeff + str_xy_GME(I,J) = GME_coeff * sh_xy_bt(I,J) + enddo ; enddo + + ! Applying GME diagonal term. This is linear and the arguments can be rescaled. + call smooth_GME(CS, G, GME_flux_h=str_xx_GME) + call smooth_GME(CS, G, GME_flux_q=str_xy_GME) + + ! This changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + str_xx(i,j) = (str_xx(i,j) + str_xx_GME(i,j)) * (h(i,j,k) * CS%reduction_xx(i,j)) + enddo ; enddo + + ! This adds in GME and changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. + if (CS%no_slip) then + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = (str_xy(I,J) + str_xy_GME(I,J)) * (hq(I,J) * CS%reduction_xy(I,J)) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = (str_xy(I,J) + str_xy_GME(I,J)) * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J)) + enddo ; enddo + endif + + else ! .not. use_GME + ! This changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. + do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + str_xx(i,j) = str_xx(i,j) * (h(i,j,k) * CS%reduction_xx(i,j)) + enddo ; enddo + + ! This changes the units of str_xy from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. + if (CS%no_slip) then + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = str_xy(I,J) * (hq(I,J) * CS%reduction_xy(I,J)) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = str_xy(I,J) * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J)) + enddo ; enddo + endif + endif ! use_GME + + ! Evaluate 1/h x.Div(h Grad u) or the biharmonic equivalent. + do j=js,je ; do I=Isq,Ieq + diffu(I,j,k) = ((G%IdyCu(I,j)*(CS%dy2h(i,j)*str_xx(i,j) - CS%dy2h(i+1,j)*str_xx(i+1,j)) + & + G%IdxCu(I,j)*(CS%dx2q(I,J-1)*str_xy(I,J-1) - CS%dx2q(I,J)*str_xy(I,J))) * & + G%IareaCu(I,j)) / (h_u(I,j) + h_neglect) + enddo ; enddo + + if (apply_OBC) then + ! This is not the right boundary condition. If all the masking of tendencies are done + ! correctly later then eliminating this block should not change answers. + do n=1,OBC%number_of_segments + if (OBC%segment(n)%is_E_or_W) then + I = OBC%segment(n)%HI%IsdB + do j=OBC%segment(n)%HI%jsd,OBC%segment(n)%HI%jed + diffu(I,j,k) = 0. + enddo + endif + enddo + endif + + ! Evaluate 1/h y.Div(h Grad u) or the biharmonic equivalent. + do J=Jsq,Jeq ; do i=is,ie + diffv(i,J,k) = ((G%IdyCv(i,J)*(CS%dy2q(I-1,J)*str_xy(I-1,J) - CS%dy2q(I,J)*str_xy(I,J)) - & + G%IdxCv(i,J)*(CS%dx2h(i,j)*str_xx(i,j) - CS%dx2h(i,j+1)*str_xx(i,j+1))) * & + G%IareaCv(i,J)) / (h_v(i,J) + h_neglect) + enddo ; enddo + + if (apply_OBC) then + ! This is not the right boundary condition. If all the masking of tendencies are done + ! correctly later then eliminating this block should not change answers. + do n=1,OBC%number_of_segments + if (OBC%segment(n)%is_N_or_S) then + J = OBC%segment(n)%HI%JsdB + do i=OBC%segment(n)%HI%isd,OBC%segment(n)%HI%ied + diffv(i,J,k) = 0. + enddo + endif + enddo + endif + + if (find_FrictWork) then ; do j=js,je ; do i=is,ie + ! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v) + ! This is the old formulation that includes energy diffusion + FrictWork(i,j,k) = GV%H_to_RZ * ( & + (str_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & + - str_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + + 0.25*((str_xy(I,J) * & + ((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & + + (v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)) & + + str_xy(I-1,J-1) * & + ((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & + + (v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)) ) & + + (str_xy(I-1,J) * & + ((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & + + (v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)) & + + str_xy(I,J-1) * & + ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) + enddo ; enddo ; endif + + if (CS%use_GME) then ; do j=js,je ; do i=is,ie + ! Diagnose str_xx_GME*d_x u - str_yy_GME*d_y v + str_xy_GME*(d_y u + d_x v) + ! This is the old formulation that includes energy diffusion + FrictWork_GME(i,j,k) = GV%H_to_RZ * ( & + (str_xx_GME(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & + - str_xx_GME(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + + 0.25*((str_xy_GME(I,J) * & + ((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & + + (v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)) & + + str_xy_GME(I-1,J-1) * & + ((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & + + (v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)) ) & + + (str_xy_GME(I-1,J) * & + ((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & + + (v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)) & + + str_xy_GME(I,J-1) * & + ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) + enddo ; enddo ; endif + + ! Make a similar calculation as for FrictWork above but accumulating into + ! the vertically integrated MEKE source term, and adjusting for any + ! energy loss seen as a reduction in the (biharmonic) frictional source term. + if (find_FrictWork .and. allocated(MEKE%mom_src)) then + if (k==1) then + do j=js,je ; do i=is,ie + MEKE%mom_src(i,j) = 0. + enddo ; enddo + if (allocated(MEKE%GME_snk)) then + do j=js,je ; do i=is,ie + MEKE%GME_snk(i,j) = 0. + enddo ; enddo + endif + endif + if (MEKE%backscatter_Ro_c /= 0.) then + do j=js,je ; do i=is,ie + FatH = 0.25*( (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1))) ) + Shear_mag_bc = sqrt(sh_xx(i,j) * sh_xx(i,j) + & + 0.25*((sh_xy(I-1,J-1)*sh_xy(I-1,J-1) + sh_xy(I,J)*sh_xy(I,J)) + & + (sh_xy(I-1,J)*sh_xy(I-1,J) + sh_xy(I,J-1)*sh_xy(I,J-1)))) + if (CS%answer_date > 20190101) then + FatH = (US%s_to_T*FatH)**MEKE%backscatter_Ro_pow ! f^n + ! Note the hard-coded dimensional constant in the following line that can not + ! be rescaled for dimensional consistency. + Shear_mag_bc = (((US%s_to_T * Shear_mag_bc)**MEKE%backscatter_Ro_pow) + 1.e-30) & + * MEKE%backscatter_Ro_c ! c * D^n + ! The Rossby number function is g(Ro) = 1/(1+c.Ro^n) + ! RoScl = 1 - g(Ro) + RoScl = Shear_mag_bc / (FatH + Shear_mag_bc) ! = 1 - f^n/(f^n+c*D^n) + else + if (FatH <= backscat_subround*Shear_mag_bc) then + RoScl = 1.0 + else + Sh_F_pow = MEKE%backscatter_Ro_c * (Shear_mag_bc / FatH)**MEKE%backscatter_Ro_pow + RoScl = Sh_F_pow / (1.0 + Sh_F_pow) ! = 1 - f^n/(f^n+c*D^n) + endif + endif + + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_RZ * ( & + ((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & + -(str_xx(i,j)-RoScl*bhstr_xx(i,j))*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + + 0.25*(((str_xy(I,J)-RoScl*bhstr_xy(I,J)) * & + ((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & + + (v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & + + (str_xy(I-1,J-1)-RoScl*bhstr_xy(I-1,J-1)) * & + ((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & + + (v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)) ) & + + ((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J)) * & + ((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & + + (v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)) & + + (str_xy(I,J-1)-RoScl*bhstr_xy(I,J-1)) * & + ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) + enddo ; enddo + endif ! MEKE%backscatter_Ro_c + + do j=js,je ; do i=is,ie + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) + enddo ; enddo + + if (CS%use_GME .and. allocated(MEKE%GME_snk)) then + do j=js,je ; do i=is,ie + MEKE%GME_snk(i,j) = MEKE%GME_snk(i,j) + FrictWork_GME(i,j,k) + enddo ; enddo + endif + + endif ! find_FrictWork and associated(mom_src) + + enddo ! end of k loop + + ! Offer fields for diagnostic averaging. + if (CS%id_normstress > 0) call post_data(CS%id_normstress, NoSt, CS%diag) + if (CS%id_shearstress > 0) call post_data(CS%id_shearstress, ShSt, CS%diag) + if (CS%id_diffu>0) call post_data(CS%id_diffu, diffu, CS%diag) + if (CS%id_diffv>0) call post_data(CS%id_diffv, diffv, CS%diag) + if (CS%id_FrictWork>0) call post_data(CS%id_FrictWork, FrictWork, CS%diag) + if (CS%id_Ah_h>0) call post_data(CS%id_Ah_h, Ah_h, CS%diag) + if (CS%id_grid_Re_Ah>0) call post_data(CS%id_grid_Re_Ah, grid_Re_Ah, CS%diag) + if (CS%id_div_xx_h>0) call post_data(CS%id_div_xx_h, div_xx_h, CS%diag) + if (CS%id_vort_xy_q>0) call post_data(CS%id_vort_xy_q, vort_xy_q, CS%diag) + if (CS%id_sh_xx_h>0) call post_data(CS%id_sh_xx_h, sh_xx_h, CS%diag) + if (CS%id_sh_xy_q>0) call post_data(CS%id_sh_xy_q, sh_xy_q, CS%diag) + if (CS%id_Ah_q>0) call post_data(CS%id_Ah_q, Ah_q, CS%diag) + if (CS%id_Kh_h>0) call post_data(CS%id_Kh_h, Kh_h, CS%diag) + if (CS%id_grid_Re_Kh>0) call post_data(CS%id_grid_Re_Kh, grid_Re_Kh, CS%diag) + if (CS%id_Kh_q>0) call post_data(CS%id_Kh_q, Kh_q, CS%diag) + if (CS%use_GME) then ! post barotropic tension and strain + if (CS%id_GME_coeff_h > 0) call post_data(CS%id_GME_coeff_h, GME_coeff_h, CS%diag) + if (CS%id_GME_coeff_q > 0) call post_data(CS%id_GME_coeff_q, GME_coeff_q, CS%diag) + if (CS%id_FrictWork_GME>0) call post_data(CS%id_FrictWork_GME, FrictWork_GME, CS%diag) + if (CS%id_dudx_bt > 0) call post_data(CS%id_dudx_bt, dudx_bt, CS%diag) + if (CS%id_dvdy_bt > 0) call post_data(CS%id_dvdy_bt, dvdy_bt, CS%diag) + if (CS%id_dudy_bt > 0) call post_data(CS%id_dudy_bt, dudy_bt, CS%diag) + if (CS%id_dvdx_bt > 0) call post_data(CS%id_dvdx_bt, dvdx_bt, CS%diag) + endif + + if (CS%debug) then + if (CS%Laplacian) then + call hchksum(Kh_h, "Kh_h", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + call Bchksum(Kh_q, "Kh_q", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + endif + if (CS%biharmonic) call hchksum(Ah_h, "Ah_h", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) + if (CS%biharmonic) call Bchksum(Ah_q, "Ah_q", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) + endif + + if (CS%id_FrictWorkIntz > 0) then + do j=js,je + do i=is,ie ; FrictWorkIntz(i,j) = FrictWork(i,j,1) ; enddo + do k=2,nz ; do i=is,ie + FrictWorkIntz(i,j) = FrictWorkIntz(i,j) + FrictWork(i,j,k) + enddo ; enddo + enddo + call post_data(CS%id_FrictWorkIntz, FrictWorkIntz, CS%diag) + endif + + if (present(ADp)) then + ! Diagnostics of the fractional thicknesses times momentum budget terms + ! 3D diagnostics of hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. + ! The code is retained for debugging purposes in the future. + !if (CS%id_hf_diffu > 0) call post_product_u(CS%id_hf_diffu, diffu, ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_diffv > 0) call post_product_v(CS%id_hf_diffv, diffv, ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for thickness-weighted vertically averaged momentum budget terms + if (CS%id_hf_diffu_2d > 0) call post_product_sum_u(CS%id_hf_diffu_2d, diffu, ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_diffv_2d > 0) call post_product_sum_v(CS%id_hf_diffv_2d, diffv, ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for the vertical sum of layer thickness x momentum budget terms + if (CS%id_intz_diffu_2d > 0) call post_product_sum_u(CS%id_intz_diffu_2d, diffu, ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_diffv_2d > 0) call post_product_sum_v(CS%id_intz_diffv_2d, diffv, ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics for thickness x momentum budget terms + if (CS%id_h_diffu > 0) call post_product_u(CS%id_h_diffu, diffu, ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_diffv > 0) call post_product_v(CS%id_h_diffv, diffv, ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics for momentum budget terms multiplied by visc_rem_[uv], + if (CS%id_diffu_visc_rem > 0) call post_product_u(CS%id_diffu_visc_rem, diffu, ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_diffv_visc_rem > 0) call post_product_v(CS%id_diffv_visc_rem, diffv, ADp%visc_rem_v, G, nz, CS%diag) + endif + + if (CS%use_ZB2020) then + call ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS%ZB2020, & + CS%dx2h, CS%dy2h, CS%dx2q, CS%dy2q) + endif + +end subroutine horizontal_viscosity + +!> Allocates space for and calculates static variables used by horizontal_viscosity(). +!! hor_visc_init calculates and stores the values of a number of metric functions that +!! are used in horizontal_viscosity(). +subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) + type(time_type), intent(in) :: Time !< Current model time. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(diag_ctrl), target, intent(inout) :: diag !< Structure to regulate diagnostic output. + type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure + type(accel_diag_ptrs), intent(in), optional :: ADp !< Acceleration diagnostics + + ! u0v is the Laplacian sensitivities to the v velocities at u points, with u0u, v0u, and v0v defined analogously. + real, dimension(SZIB_(G),SZJ_(G)) :: u0u, u0v ! Laplacian sensitivities at u points [L-2 ~> m-2] + real, dimension(SZI_(G),SZJB_(G)) :: v0u, v0v ! Laplacian sensitivities at v points [L-2 ~> m-2] + real :: grid_sp_h2 ! Harmonic mean of the squares of the grid [L2 ~> m2] + real :: grid_sp_h3 ! Harmonic mean of the squares of the grid^(3/2) [L3 ~> m3] + real :: grid_sp_q2 ! spacings at h and q points [L2 ~> m2] + real :: grid_sp_q3 ! spacings at h and q points^(3/2) [L3 ~> m3] + real :: min_grid_sp_h2 ! Minimum value of grid_sp_h2 [L2 ~> m2] + real :: min_grid_sp_h4 ! Minimum value of grid_sp_h2**2 [L4 ~> m4] + real :: Kh_Limit ! A coefficient [T-1 ~> s-1] used, along with the + ! grid spacing, to limit Laplacian viscosity. + real :: fmax ! maximum absolute value of f at the four + ! vorticity points around a thickness point [T-1 ~> s-1] + real :: BoundCorConst ! A constant used when using viscosity to bound the Coriolis accelerations + ! [T2 L-2 ~> s2 m-2] + real :: Ah_Limit ! coefficient [T-1 ~> s-1] used, along with the + ! grid spacing, to limit biharmonic viscosity + real :: Kh ! Lapacian horizontal viscosity [L2 T-1 ~> m2 s-1] + real :: Ah ! biharmonic horizontal viscosity [L4 T-1 ~> m4 s-1] + real :: Kh_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing gives Laplacian viscosity + real :: Ah_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing cubed gives biharmonic viscosity + real :: Ah_time_scale ! damping time-scale for biharmonic visc [T ~> s] + real :: Smag_Lap_const ! nondimensional Laplacian Smagorinsky constant [nondim] + real :: Smag_bi_const ! nondimensional biharmonic Smagorinsky constant [nondim] + real :: Leith_Lap_const ! nondimensional Laplacian Leith constant [nondim] + real :: Leith_bi_const ! nondimensional biharmonic Leith constant [nondim] + real :: dt ! The dynamics time step [T ~> s] + real :: Idt ! The inverse of dt [T-1 ~> s-1] + real :: denom ! work variable; the denominator of a fraction [L-2 ~> m-2] or [L-4 ~> m-4] + real :: maxvel ! largest permitted velocity components [L T-1 ~> m s-1] + real :: bound_Cor_vel ! grid-scale velocity variations at which value + ! the quadratically varying biharmonic viscosity + ! balances Coriolis acceleration [L T-1 ~> m s-1] + real :: Kh_sin_lat ! Amplitude of latitudinally dependent viscosity [L2 T-1 ~> m2 s-1] + real :: Kh_pwr_of_sine ! Power used to raise sin(lat) when using Kh_sin_lat [nondim] + logical :: bound_Cor_def ! parameter setting of BOUND_CORIOLIS + logical :: split ! If true, use the split time stepping scheme. + ! If false and USE_GME = True, issue a FATAL error. + logical :: use_MEKE ! If true, the MEKE parameterization is in use. + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags + character(len=200) :: inputdir, filename ! Input file names and paths + character(len=80) :: Kh_var ! Input variable names + real :: deg2rad ! Converts degrees to radians [radians degree-1] + real :: slat_fn ! sin(lat)**Kh_pwr_of_sine [nondim] + real :: aniso_grid_dir(2) ! Vector (n1,n2) for anisotropic direction [nondim] + integer :: aniso_mode ! Selects the mode for setting the anisotropic direction + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer :: i, j + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_hor_visc" ! module name + 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 + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + ! init control structure + call ZB2020_init(Time, G, GV, US, param_file, diag, CS%ZB2020, CS%use_ZB2020) + + CS%initialized = .true. + + CS%diag => diag + ! Read parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + ! All parameters are read in all cases to enable parameter spelling checks. + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "HOR_VISC_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the horizontal "//& + "viscosity calculations. Values below 20190101 recover the answers from the "//& + "end of 2018, while higher values use updated and more robust forms of the "//& + "same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) + call get_param(param_file, mdl, "USE_CONT_THICKNESS", CS%use_cont_thick, & + "If true, use thickness at velocity points from continuity solver. This option"//& + "currently only works with split mode.", default=.false.) + call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, & + "If true, use a Laplacian horizontal viscosity.", & + default=.false.) + + call get_param(param_file, mdl, "KH", Kh, & + "The background Laplacian horizontal viscosity.", & + units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s, & + do_not_log=.not.CS%Laplacian) + call get_param(param_file, mdl, "KH_BG_MIN", CS%Kh_bg_min, & + "The minimum value allowed for Laplacian horizontal viscosity, KH.", & + units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s, & + do_not_log=.not.CS%Laplacian) + call get_param(param_file, mdl, "KH_VEL_SCALE", Kh_vel_scale, & + "The velocity scale which is multiplied by the grid "//& + "spacing to calculate the Laplacian viscosity. "//& + "The final viscosity is the largest of this scaled "//& + "viscosity, the Smagorinsky and Leith viscosities, and KH.", & + units="m s-1", default=0.0, scale=US%m_s_to_L_T, & + do_not_log=.not.CS%Laplacian) + call get_param(param_file, mdl, "KH_SIN_LAT", Kh_sin_lat, & + "The amplitude of a latitudinally-dependent background "//& + "viscosity of the form KH_SIN_LAT*(SIN(LAT)**KH_PWR_OF_SINE).", & + units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s, & + do_not_log=.not.CS%Laplacian) + call get_param(param_file, mdl, "KH_PWR_OF_SINE", Kh_pwr_of_sine, & + "The power used to raise SIN(LAT) when using a latitudinally "//& + "dependent background viscosity.", & + units="nondim", default=4.0, & + do_not_log=.not.(CS%Laplacian .and. (Kh_sin_lat>0.)) ) + call get_param(param_file, mdl, "SMAGORINSKY_KH", CS%Smagorinsky_Kh, & + "If true, use a Smagorinsky nonlinear eddy viscosity.", & + default=.false., do_not_log=.not.CS%Laplacian) + if (.not.CS%Laplacian) CS%Smagorinsky_Kh = .false. + call get_param(param_file, mdl, "SMAG_LAP_CONST", Smag_Lap_const, & + "The nondimensional Laplacian Smagorinsky constant, "//& + "often 0.15.", units="nondim", default=0.0, & + fail_if_missing=CS%Smagorinsky_Kh, do_not_log=.not.CS%Smagorinsky_Kh) + call get_param(param_file, mdl, "LEITH_KH", CS%Leith_Kh, & + "If true, use a Leith nonlinear eddy viscosity.", & + default=.false., do_not_log=.not.CS%Laplacian) + if (.not.CS%Laplacian) CS%Leith_Kh = .false. + call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, & + "The nondimensional Laplacian Leith constant, "//& + "often set to 1.0", units="nondim", default=0.0, & + fail_if_missing=CS%Leith_Kh, do_not_log=.not.CS%Leith_Kh) + call get_param(param_file, mdl, "USE_MEKE", use_MEKE, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "RES_SCALE_MEKE_VISC", CS%res_scale_MEKE, & + "If true, the viscosity contribution from MEKE is scaled by "//& + "the resolution function.", default=.false., & + do_not_log=.not.(CS%Laplacian.and.use_MEKE)) + if (.not.(CS%Laplacian.and.use_MEKE)) CS%res_scale_MEKE = .false. + + call get_param(param_file, mdl, "BOUND_KH", CS%bound_Kh, & + "If true, the Laplacian coefficient is locally limited "//& + "to be stable.", default=.true., do_not_log=.not.CS%Laplacian) + call get_param(param_file, mdl, "BETTER_BOUND_KH", CS%better_bound_Kh, & + "If true, the Laplacian coefficient is locally limited "//& + "to be stable with a better bounding than just BOUND_KH.", & + default=CS%bound_Kh, do_not_log=.not.CS%Laplacian) + if (.not.CS%Laplacian) CS%bound_Kh = .false. + if (.not.CS%Laplacian) CS%better_bound_Kh = .false. + call get_param(param_file, mdl, "ANISOTROPIC_VISCOSITY", CS%anisotropic, & + "If true, allow anistropic viscosity in the Laplacian "//& + "horizontal viscosity.", default=.false., & + do_not_log=.not.CS%Laplacian) + if (.not.CS%Laplacian) CS%anisotropic = .false. ! This replicates the prior code, but is it intended? + call get_param(param_file, mdl, "ADD_LES_VISCOSITY", CS%add_LES_viscosity, & + "If true, adds the viscosity from Smagorinsky and Leith to the "//& + "background viscosity instead of taking the maximum.", default=.false., & + do_not_log=.not.CS%Laplacian) + + call get_param(param_file, mdl, "KH_ANISO", CS%Kh_aniso, & + "The background Laplacian anisotropic horizontal viscosity.", & + units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s, & + do_not_log=.not.CS%anisotropic) + call get_param(param_file, mdl, "ANISOTROPIC_MODE", aniso_mode, & + "Selects the mode for setting the direction of anisotropy.\n"//& + "\t 0 - Points along the grid i-direction.\n"//& + "\t 1 - Points towards East.\n"//& + "\t 2 - Points along the flow direction, U/|U|.", & + default=0, do_not_log=.not.CS%anisotropic) + if (aniso_mode == 0) then + call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & + "The vector pointing in the direction of anisotropy for horizontal viscosity. "//& + "n1,n2 are the i,j components relative to the grid.", & + units="nondim", fail_if_missing=CS%anisotropic, do_not_log=.not.CS%anisotropic) + elseif (aniso_mode == 1) then + call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & + "The vector pointing in the direction of anisotropy for horizontal viscosity. "//& + "n1,n2 are the i,j components relative to the spherical coordinates.", & + units="nondim", fail_if_missing=CS%anisotropic, do_not_log=.not.CS%anisotropic) + else + call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & + "The vector pointing in the direction of anisotropy for horizontal viscosity.", & + units="nondim", fail_if_missing=.false., do_not_log=.true.) + endif + + call get_param(param_file, mdl, "BIHARMONIC", CS%biharmonic, & + "If true, use a biharmonic horizontal viscosity. "//& + "BIHARMONIC may be used with LAPLACIAN.", & + default=.true.) + call get_param(param_file, mdl, "AH", Ah, & + "The background biharmonic horizontal viscosity.", & + units="m4 s-1", default=0.0, scale=US%m_to_L**4*US%T_to_s, & + do_not_log=.not.CS%biharmonic) + call get_param(param_file, mdl, "AH_VEL_SCALE", Ah_vel_scale, & + "The velocity scale which is multiplied by the cube of "//& + "the grid spacing to calculate the biharmonic viscosity. "//& + "The final viscosity is the largest of this scaled "//& + "viscosity, the Smagorinsky and Leith viscosities, and AH.", & + units="m s-1", default=0.0, scale=US%m_s_to_L_T, do_not_log=.not.CS%biharmonic) + call get_param(param_file, mdl, "AH_TIME_SCALE", Ah_time_scale, & + "A time scale whose inverse is multiplied by the fourth "//& + "power of the grid spacing to calculate biharmonic viscosity. "//& + "The final viscosity is the largest of all viscosity "//& + "formulations in use. 0.0 means that it's not used.", & + units="s", default=0.0, scale=US%s_to_T, do_not_log=.not.CS%biharmonic) + call get_param(param_file, mdl, "SMAGORINSKY_AH", CS%Smagorinsky_Ah, & + "If true, use a biharmonic Smagorinsky nonlinear eddy "//& + "viscosity.", default=.false., do_not_log=.not.CS%biharmonic) + if (.not.CS%biharmonic) CS%Smagorinsky_Ah = .false. + call get_param(param_file, mdl, "LEITH_AH", CS%Leith_Ah, & + "If true, use a biharmonic Leith nonlinear eddy "//& + "viscosity.", default=.false., do_not_log=.not.CS%biharmonic) + if (.not.CS%biharmonic) CS%Leith_Ah = .false. + call get_param(param_file, mdl, "USE_LEITHY", CS%use_Leithy, & + "If true, use a biharmonic Leith nonlinear eddy "//& + "viscosity together with a harmonic backscatter.", & + default=.false.) + call get_param(param_file, mdl, "BOUND_AH", CS%bound_Ah, & + "If true, the biharmonic coefficient is locally limited "//& + "to be stable.", default=.true., do_not_log=.not.CS%biharmonic) + call get_param(param_file, mdl, "BETTER_BOUND_AH", CS%better_bound_Ah, & + "If true, the biharmonic coefficient is locally limited "//& + "to be stable with a better bounding than just BOUND_AH.", & + default=CS%bound_Ah, do_not_log=.not.CS%biharmonic) + if (.not.CS%biharmonic) CS%bound_Ah = .false. + if (.not.CS%biharmonic) CS%better_bound_Ah = .false. + call get_param(param_file, mdl, "RE_AH", CS%Re_Ah, & + "If nonzero, the biharmonic coefficient is scaled "//& + "so that the biharmonic Reynolds number is equal to this.", & + units="nondim", default=0.0, do_not_log=.not.CS%biharmonic) + + call get_param(param_file, mdl, "SMAG_BI_CONST",Smag_bi_const, & + "The nondimensional biharmonic Smagorinsky constant, "//& + "typically 0.015 - 0.06.", units="nondim", default=0.0, & + fail_if_missing=CS%Smagorinsky_Ah, do_not_log=.not.CS%Smagorinsky_Ah) + + call get_param(param_file, mdl, "USE_BETA_IN_LEITH", CS%use_beta_in_Leith, & + "If true, include the beta term in the Leith nonlinear eddy viscosity.", & + default=CS%Leith_Kh, do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) + call get_param(param_file, mdl, "MODIFIED_LEITH", CS%modified_Leith, & + "If true, add a term to Leith viscosity which is "//& + "proportional to the gradient of divergence.", & + default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) + call get_param(param_file, mdl, "USE_QG_LEITH_VISC", CS%use_QG_Leith_visc, & + "If true, use QG Leith nonlinear eddy viscosity.", & + default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) + if (CS%use_QG_Leith_visc) then + call MOM_error(FATAL, "USE_QG_LEITH_VISC=True activates code that is a work-in-progress and "//& + "should not be used until a number of bugs are fixed. Specifically it does not "//& + "reproduce across PE count or layout, and may use arrays that have not been properly "//& + "set or allocated. See github.com/mom-ocean/MOM6/issues/1590 for a discussion.") + endif + if (CS%use_QG_Leith_visc .and. .not. (CS%Leith_Kh .or. CS%Leith_Ah) ) then + call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init:"//& + "LEITH_KH or LEITH_AH must be True when USE_QG_LEITH_VISC=True.") + endif + + call get_param(param_file, mdl, "BOUND_CORIOLIS", bound_Cor_def, default=.false.) + call get_param(param_file, mdl, "BOUND_CORIOLIS_BIHARM", CS%bound_Coriolis, & + "If true use a viscosity that increases with the square "//& + "of the velocity shears, so that the resulting viscous "//& + "drag is of comparable magnitude to the Coriolis terms "//& + "when the velocity differences between adjacent grid "//& + "points is 0.5*BOUND_CORIOLIS_VEL. The default is the "//& + "value of BOUND_CORIOLIS (or false).", default=bound_Cor_def, & + do_not_log=.not.CS%Smagorinsky_Ah) + if (.not.CS%Smagorinsky_Ah) CS%bound_Coriolis = .false. + call get_param(param_file, mdl, "MAXVEL", maxvel, & + units="m s-1", default=3.0e8, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "BOUND_CORIOLIS_VEL", bound_Cor_vel, & + "The velocity scale at which BOUND_CORIOLIS_BIHARM causes "//& + "the biharmonic drag to have comparable magnitude to the "//& + "Coriolis acceleration. The default is set by MAXVEL.", & + units="m s-1", default=maxvel*US%L_T_to_m_s, scale=US%m_s_to_L_T, & + do_not_log=.not.(CS%Smagorinsky_Ah .and. CS%bound_Coriolis)) + call get_param(param_file, mdl, "LEITH_BI_CONST", Leith_bi_const, & + "The nondimensional biharmonic Leith constant, "//& + "typical values are thus far undetermined.", units="nondim", default=0.0, & + fail_if_missing=(CS%Leith_Ah .or. CS%use_Leithy), & + do_not_log=.not.(CS%Leith_Ah .or. CS%use_Leithy)) + call get_param(param_file, mdl, "USE_LAND_MASK_FOR_HVISC", CS%use_land_mask, & + "If true, use the land mask for the computation of thicknesses "//& + "at velocity locations. This eliminates the dependence on arbitrary "//& + "values over land or outside of the domain.", default=.true.) + call get_param(param_file, mdl, "HORVISC_BOUND_COEF", CS%bound_coef, & + "The nondimensional coefficient of the ratio of the "//& + "viscosity bounds to the theoretical maximum for "//& + "stability without considering other terms.", units="nondim", & + default=0.8, do_not_log=.not.(CS%better_bound_Ah .or. CS%better_bound_Kh)) + call get_param(param_file, mdl, "NOSLIP", CS%no_slip, & + "If true, no slip boundary conditions are used; otherwise "//& + "free slip boundary conditions are assumed. The "//& + "implementation of the free slip BCs on a C-grid is much "//& + "cleaner than the no slip BCs. The use of free slip BCs "//& + "is strongly encouraged, and no slip BCs are not used with "//& + "the biharmonic viscosity.", default=.false.) + call get_param(param_file, mdl, "USE_KH_BG_2D", CS%use_Kh_bg_2d, & + "If true, read a file containing 2-d background harmonic "//& + "viscosities. The final viscosity is the maximum of the other "//& + "terms and this background value.", default=.false., do_not_log=.not.CS%Laplacian) + if (.not.CS%Laplacian) CS%use_Kh_bg_2d = .false. + call get_param(param_file, mdl, "KH_BG_2D_BUG", CS%Kh_bg_2d_bug, & + "If true, retain an answer-changing horizontal indexing bug in setting "//& + "the corner-point viscosities when USE_KH_BG_2D=True. This is"//& + "not recommended.", default=.false., do_not_log=.not.CS%use_Kh_bg_2d) + + call get_param(param_file, mdl, "USE_GME", CS%use_GME, & + "If true, use the GM+E backscatter scheme in association \n"//& + "with the Gent and McWilliams parameterization.", default=.false.) + call get_param(param_file, mdl, "SPLIT", split, & + "Use the split time stepping if true.", default=.true., do_not_log=.true.) + if (CS%use_Leithy) then + if (.not.(CS%biharmonic .and. CS%Laplacian)) then + call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init:"//& + "LAPLACIAN and BIHARMONIC must both be True when USE_LEITHY=True.") + endif + call get_param(param_file, mdl, "LEITHY_CK", CS%c_K, & + "Fraction of biharmonic dissipation that gets backscattered, "//& + "in Leith+E.", units="nondim", default=1.0) + endif + + if (CS%use_GME .and. .not.split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & + "cannot be used with SPLIT=False.") + + if (CS%use_GME) then + call get_param(param_file, mdl, "GME_NUM_SMOOTHINGS", CS%num_smooth_gme, & + "Number of smoothing passes for the GME fluxes.", & + default=1) + call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & + "The strength of GME tapers quadratically to zero when the bathymetric "//& + "depth is shallower than GME_H0.", & + units="m", scale=GV%m_to_H, default=1000.0) + call get_param(param_file, mdl, "GME_EFFICIENCY", CS%GME_efficiency, & + "The nondimensional prefactor multiplying the GME coefficient.", & + units="nondim", default=1.0) + call get_param(param_file, mdl, "GME_LIMITER", CS%GME_limiter, & + "The absolute maximum value the GME coefficient is allowed to take.", & + units="m2 s-1", scale=US%m_to_L**2*US%T_to_s, default=1.0e7) + endif + + if (CS%Laplacian .or. CS%biharmonic) then + call get_param(param_file, mdl, "DT", dt, & + "The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T, & + fail_if_missing=.true.) + Idt = 1.0 / dt + endif + if (CS%no_slip .and. CS%biharmonic) & + call MOM_error(FATAL,"ERROR: NOSLIP and BIHARMONIC cannot be defined "// & + "at the same time in MOM.") + if (.not.(CS%Laplacian .or. CS%biharmonic)) then + ! Only issue inviscid warning if not in single column mode (usually 2x2 domain) + if ( max(G%domain%niglobal, G%domain%njglobal)>2 ) call MOM_error(WARNING, & + "hor_visc_init: It is usually a very bad idea not to use either "//& + "LAPLACIAN or BIHARMONIC viscosity.") + return ! We are not using either Laplacian or Bi-harmonic lateral viscosity + endif + deg2rad = atan(1.0) / 45. + ALLOC_(CS%dx2h(isd:ied,jsd:jed)) ; CS%dx2h(:,:) = 0.0 + ALLOC_(CS%dy2h(isd:ied,jsd:jed)) ; CS%dy2h(:,:) = 0.0 + ALLOC_(CS%dx2q(IsdB:IedB,JsdB:JedB)) ; CS%dx2q(:,:) = 0.0 + ALLOC_(CS%dy2q(IsdB:IedB,JsdB:JedB)) ; CS%dy2q(:,:) = 0.0 + ALLOC_(CS%dx_dyT(isd:ied,jsd:jed)) ; CS%dx_dyT(:,:) = 0.0 + ALLOC_(CS%dy_dxT(isd:ied,jsd:jed)) ; CS%dy_dxT(:,:) = 0.0 + ALLOC_(CS%dx_dyBu(IsdB:IedB,JsdB:JedB)) ; CS%dx_dyBu(:,:) = 0.0 + ALLOC_(CS%dy_dxBu(IsdB:IedB,JsdB:JedB)) ; CS%dy_dxBu(:,:) = 0.0 + if (CS%Laplacian) then + ALLOC_(CS%grid_sp_h2(isd:ied,jsd:jed)) ; CS%grid_sp_h2(:,:) = 0.0 + ALLOC_(CS%Kh_bg_xx(isd:ied,jsd:jed)) ; CS%Kh_bg_xx(:,:) = 0.0 + ALLOC_(CS%Kh_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_bg_xy(:,:) = 0.0 + if (CS%bound_Kh .or. CS%better_bound_Kh) then + ALLOC_(CS%Kh_Max_xx(Isd:Ied,Jsd:Jed)) ; CS%Kh_Max_xx(:,:) = 0.0 + ALLOC_(CS%Kh_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_Max_xy(:,:) = 0.0 + endif + if (CS%Smagorinsky_Kh) then + ALLOC_(CS%Laplac2_const_xx(isd:ied,jsd:jed)) ; CS%Laplac2_const_xx(:,:) = 0.0 + ALLOC_(CS%Laplac2_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Laplac2_const_xy(:,:) = 0.0 + endif + if (CS%Leith_Kh) then + ALLOC_(CS%Laplac3_const_xx(isd:ied,jsd:jed)) ; CS%Laplac3_const_xx(:,:) = 0.0 + ALLOC_(CS%Laplac3_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Laplac3_const_xy(:,:) = 0.0 + endif + endif + ALLOC_(CS%reduction_xx(isd:ied,jsd:jed)) ; CS%reduction_xx(:,:) = 0.0 + ALLOC_(CS%reduction_xy(IsdB:IedB,JsdB:JedB)) ; CS%reduction_xy(:,:) = 0.0 + + CS%dynamic_aniso = .false. + if (CS%anisotropic) then + ALLOC_(CS%n1n2_h(isd:ied,jsd:jed)) ; CS%n1n2_h(:,:) = 0.0 + ALLOC_(CS%n1n1_m_n2n2_h(isd:ied,jsd:jed)) ; CS%n1n1_m_n2n2_h(:,:) = 0.0 + ALLOC_(CS%n1n2_q(IsdB:IedB,JsdB:JedB)) ; CS%n1n2_q(:,:) = 0.0 + ALLOC_(CS%n1n1_m_n2n2_q(IsdB:IedB,JsdB:JedB)) ; CS%n1n1_m_n2n2_q(:,:) = 0.0 + select case (aniso_mode) + case (0) + call align_aniso_tensor_to_grid(CS, aniso_grid_dir(1), aniso_grid_dir(2)) + case (1) + ! call align_aniso_tensor_to_grid(CS, aniso_grid_dir(1), aniso_grid_dir(2)) + case (2) + CS%dynamic_aniso = .true. + case default + call MOM_error(FATAL, "MOM_hor_visc: "//& + "Runtime parameter ANISOTROPIC_MODE is out of range.") + end select + endif + + call get_param(param_file, mdl, "KH_BG_2D_FILENAME", filename, & + 'The filename containing a 2d map of "Kh".', & + default='KH_background_2d.nc', do_not_log=.not.CS%use_Kh_bg_2d) + call get_param(param_file, mdl, "KH_BG_2D_VARNAME", Kh_var, & + 'The name in the input file of the horizontal viscosity variable.', & + default='Kh', do_not_log=.not.CS%use_Kh_bg_2d) + + if (CS%use_Kh_bg_2d) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + ALLOC_(CS%Kh_bg_2d(isd:ied,jsd:jed)) ; CS%Kh_bg_2d(:,:) = 0.0 + call MOM_read_data(trim(inputdir)//trim(filename), Kh_var, CS%Kh_bg_2d, & + G%domain, timelevel=1, scale=US%m_to_L**2*US%T_to_s) + call pass_var(CS%Kh_bg_2d, G%domain) + endif + if (CS%biharmonic) then + ALLOC_(CS%Idx2dyCu(IsdB:IedB,jsd:jed)) ; CS%Idx2dyCu(:,:) = 0.0 + ALLOC_(CS%Idx2dyCv(isd:ied,JsdB:JedB)) ; CS%Idx2dyCv(:,:) = 0.0 + ALLOC_(CS%Idxdy2u(IsdB:IedB,jsd:jed)) ; CS%Idxdy2u(:,:) = 0.0 + ALLOC_(CS%Idxdy2v(isd:ied,JsdB:JedB)) ; CS%Idxdy2v(:,:) = 0.0 + ALLOC_(CS%Ah_bg_xx(isd:ied,jsd:jed)) ; CS%Ah_bg_xx(:,:) = 0.0 + ALLOC_(CS%Ah_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_bg_xy(:,:) = 0.0 + ALLOC_(CS%grid_sp_h3(isd:ied,jsd:jed)) ; CS%grid_sp_h3(:,:) = 0.0 + if (CS%bound_Ah .or. CS%better_bound_Ah) then + ALLOC_(CS%Ah_Max_xx(isd:ied,jsd:jed)) ; CS%Ah_Max_xx(:,:) = 0.0 + ALLOC_(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy(:,:) = 0.0 + endif + if (CS%Smagorinsky_Ah) then + ALLOC_(CS%Biharm_const_xx(isd:ied,jsd:jed)) ; CS%Biharm_const_xx(:,:) = 0.0 + ALLOC_(CS%Biharm_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Biharm_const_xy(:,:) = 0.0 + if (CS%bound_Coriolis) then + ALLOC_(CS%Biharm_const2_xx(isd:ied,jsd:jed)) ; CS%Biharm_const2_xx(:,:) = 0.0 + ALLOC_(CS%Biharm_const2_xy(IsdB:IedB,JsdB:JedB)) ; CS%Biharm_const2_xy(:,:) = 0.0 + endif + endif + if ((CS%Leith_Ah) .or. (CS%use_Leithy)) then + ALLOC_(CS%biharm6_const_xx(isd:ied,jsd:jed)) ; CS%biharm6_const_xx(:,:) = 0.0 + ALLOC_(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm6_const_xy(:,:) = 0.0 + endif + if (CS%use_Leithy) then + ALLOC_(CS%m_const_leithy(isd:ied,jsd:jed)) ; CS%m_const_leithy(:,:) = 0.0 + ALLOC_(CS%m_leithy_max(isd:ied,jsd:jed)) ; CS%m_leithy_max(:,:) = 0.0 + endif + if (CS%Re_Ah > 0.0) then + ALLOC_(CS%Re_Ah_const_xx(isd:ied,jsd:jed)); CS%Re_Ah_const_xx(:,:) = 0.0 + ALLOC_(CS%Re_Ah_const_xy(IsdB:IedB,JsdB:JedB)); CS%Re_Ah_const_xy(:,:) = 0.0 + endif + endif + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%dx2q(I,J) = G%dxBu(I,J)*G%dxBu(I,J) ; CS%dy2q(I,J) = G%dyBu(I,J)*G%dyBu(I,J) + CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) + enddo ; enddo + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + CS%dx2h(i,j) = G%dxT(i,j)*G%dxT(i,j) ; CS%dy2h(i,j) = G%dyT(i,j)*G%dyT(i,j) + CS%DX_dyT(i,j) = G%dxT(i,j)*G%IdyT(i,j) ; CS%DY_dxT(i,j) = G%dyT(i,j)*G%IdxT(i,j) + enddo ; enddo + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + CS%reduction_xx(i,j) = 1.0 + if ((G%dy_Cu(I,j) > 0.0) .and. (G%dy_Cu(I,j) < G%dyCu(I,j)) .and. & + (G%dy_Cu(I,j) < G%dyCu(I,j) * CS%reduction_xx(i,j))) & + CS%reduction_xx(i,j) = G%dy_Cu(I,j) / (G%dyCu(I,j)) + if ((G%dy_Cu(I-1,j) > 0.0) .and. (G%dy_Cu(I-1,j) < G%dyCu(I-1,j)) .and. & + (G%dy_Cu(I-1,j) < G%dyCu(I-1,j) * CS%reduction_xx(i,j))) & + CS%reduction_xx(i,j) = G%dy_Cu(I-1,j) / (G%dyCu(I-1,j)) + if ((G%dx_Cv(i,J) > 0.0) .and. (G%dx_Cv(i,J) < G%dxCv(i,J)) .and. & + (G%dx_Cv(i,J) < G%dxCv(i,J) * CS%reduction_xx(i,j))) & + CS%reduction_xx(i,j) = G%dx_Cv(i,J) / (G%dxCv(i,J)) + if ((G%dx_Cv(i,J-1) > 0.0) .and. (G%dx_Cv(i,J-1) < G%dxCv(i,J-1)) .and. & + (G%dx_Cv(i,J-1) < G%dxCv(i,J-1) * CS%reduction_xx(i,j))) & + CS%reduction_xx(i,j) = G%dx_Cv(i,J-1) / (G%dxCv(i,J-1)) + enddo ; enddo + do J=js-1,Jeq ; do I=is-1,Ieq + CS%reduction_xy(I,J) = 1.0 + if ((G%dy_Cu(I,j) > 0.0) .and. (G%dy_Cu(I,j) < G%dyCu(I,j)) .and. & + (G%dy_Cu(I,j) < G%dyCu(I,j) * CS%reduction_xy(I,J))) & + CS%reduction_xy(I,J) = G%dy_Cu(I,j) / (G%dyCu(I,j)) + if ((G%dy_Cu(I,j+1) > 0.0) .and. (G%dy_Cu(I,j+1) < G%dyCu(I,j+1)) .and. & + (G%dy_Cu(I,j+1) < G%dyCu(I,j+1) * CS%reduction_xy(I,J))) & + CS%reduction_xy(I,J) = G%dy_Cu(I,j+1) / (G%dyCu(I,j+1)) + if ((G%dx_Cv(i,J) > 0.0) .and. (G%dx_Cv(i,J) < G%dxCv(i,J)) .and. & + (G%dx_Cv(i,J) < G%dxCv(i,J) * CS%reduction_xy(I,J))) & + CS%reduction_xy(I,J) = G%dx_Cv(i,J) / (G%dxCv(i,J)) + if ((G%dx_Cv(i+1,J) > 0.0) .and. (G%dx_Cv(i+1,J) < G%dxCv(i+1,J)) .and. & + (G%dx_Cv(i+1,J) < G%dxCv(i+1,J) * CS%reduction_xy(I,J))) & + CS%reduction_xy(I,J) = G%dx_Cv(i+1,J) / (G%dxCv(i+1,J)) + enddo ; enddo + if (CS%Laplacian) then + ! The 0.3 below was 0.4 in MOM1.10. The change in hq requires + ! this to be less than 1/3, rather than 1/2 as before. + if (CS%bound_Kh .or. CS%bound_Ah) Kh_Limit = 0.3 / (dt*4.0) + ! Calculate and store the background viscosity at h-points + + min_grid_sp_h2 = huge(1.) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ! Static factors in the Smagorinsky and Leith schemes + grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j) + CS%dy2h(i,j)) + CS%grid_sp_h2(i,j) = grid_sp_h2 + grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2) + if (CS%Smagorinsky_Kh) CS%Laplac2_const_xx(i,j) = Smag_Lap_const * grid_sp_h2 + if (CS%Leith_Kh) CS%Laplac3_const_xx(i,j) = Leith_Lap_const * grid_sp_h3 + ! Maximum of constant background and MICOM viscosity + CS%Kh_bg_xx(i,j) = MAX(Kh, Kh_vel_scale * sqrt(grid_sp_h2)) + ! Use the larger of the above and values read from a file + if (CS%use_Kh_bg_2d) CS%Kh_bg_xx(i,j) = MAX(CS%Kh_bg_2d(i,j), CS%Kh_bg_xx(i,j)) + ! Use the larger of the above and a function of sin(latitude) + if (Kh_sin_lat>0.) then + slat_fn = abs( sin( deg2rad * G%geoLatT(i,j) ) ) ** Kh_pwr_of_sine + CS%Kh_bg_xx(i,j) = MAX(Kh_sin_lat * slat_fn, CS%Kh_bg_xx(i,j)) + endif + if (CS%bound_Kh .and. .not.CS%better_bound_Kh) then + ! Limit the background viscosity to be numerically stable + CS%Kh_Max_xx(i,j) = Kh_Limit * grid_sp_h2 + CS%Kh_bg_xx(i,j) = MIN(CS%Kh_bg_xx(i,j), CS%Kh_Max_xx(i,j)) + endif + min_grid_sp_h2 = min(grid_sp_h2, min_grid_sp_h2) + enddo ; enddo + call min_across_PEs(min_grid_sp_h2) + + ! Calculate and store the background viscosity at q-points + do J=js-1,Jeq ; do I=is-1,Ieq + ! Static factors in the Smagorinsky and Leith schemes + grid_sp_q2 = (2.0*CS%dx2q(I,J)*CS%dy2q(I,J)) / (CS%dx2q(I,J) + CS%dy2q(I,J)) + grid_sp_q3 = grid_sp_q2*sqrt(grid_sp_q2) + if (CS%Smagorinsky_Kh) CS%Laplac2_const_xy(I,J) = Smag_Lap_const * grid_sp_q2 + if (CS%Leith_Kh) CS%Laplac3_const_xy(I,J) = Leith_Lap_const * grid_sp_q3 + ! Maximum of constant background and MICOM viscosity + CS%Kh_bg_xy(I,J) = MAX(Kh, Kh_vel_scale * sqrt(grid_sp_q2)) + ! Use the larger of the above and values read from a file + if (CS%use_Kh_bg_2d) then + if (CS%Kh_bg_2d_bug) then + ! This option is unambiguously wrong but is needed to recover old answers + CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_2d(i,j), CS%Kh_bg_xy(I,J)) + else + CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_xy(I,J), & + 0.25*((CS%Kh_bg_2d(i,j) + CS%Kh_bg_2d(i+1,j+1)) + & + (CS%Kh_bg_2d(i+1,j) + CS%Kh_bg_2d(i,j+1))) ) + endif + endif + + ! Use the larger of the above and a function of sin(latitude) + if (Kh_sin_lat>0.) then + slat_fn = abs( sin( deg2rad * G%geoLatBu(I,J) ) ) ** Kh_pwr_of_sine + CS%Kh_bg_xy(I,J) = MAX(Kh_sin_lat * slat_fn, CS%Kh_bg_xy(I,J)) + endif + if (CS%bound_Kh .and. .not.CS%better_bound_Kh) then + ! Limit the background viscosity to be numerically stable + CS%Kh_Max_xy(I,J) = Kh_Limit * grid_sp_q2 + CS%Kh_bg_xy(I,J) = MIN(CS%Kh_bg_xy(I,J), CS%Kh_Max_xy(I,J)) + endif + enddo ; enddo + endif + if (CS%biharmonic) then + do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 + CS%Idx2dyCu(I,j) = (G%IdxCu(I,j)*G%IdxCu(I,j)) * G%IdyCu(I,j) + CS%Idxdy2u(I,j) = G%IdxCu(I,j) * (G%IdyCu(I,j)*G%IdyCu(I,j)) + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do i=is-1,Ieq+1 + CS%Idx2dyCv(i,J) = (G%IdxCv(i,J)*G%IdxCv(i,J)) * G%IdyCv(i,J) + CS%Idxdy2v(i,J) = G%IdxCv(i,J) * (G%IdyCv(i,J)*G%IdyCv(i,J)) + enddo ; enddo + CS%Ah_bg_xy(:,:) = 0.0 + ! The 0.3 below was 0.4 in HIM 1.10. The change in hq requires + ! this to be less than 1/3, rather than 1/2 as before. + if (CS%better_bound_Ah .or. CS%bound_Ah) Ah_Limit = 0.3 / (dt*64.0) + if (CS%Smagorinsky_Ah .and. CS%bound_Coriolis) & + BoundCorConst = 1.0 / (5.0*(bound_Cor_vel*bound_Cor_vel)) + + min_grid_sp_h4 = huge(1.) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j)+CS%dy2h(i,j)) + grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2) + CS%grid_sp_h3(i,j) = grid_sp_h3 + if (CS%Smagorinsky_Ah) then + CS%Biharm_const_xx(i,j) = Smag_bi_const * (grid_sp_h2 * grid_sp_h2) + if (CS%bound_Coriolis) then + fmax = MAX(abs(G%CoriolisBu(I-1,J-1)), abs(G%CoriolisBu(I,J-1)), & + abs(G%CoriolisBu(I-1,J)), abs(G%CoriolisBu(I,J))) + CS%Biharm_const2_xx(i,j) = (grid_sp_h2 * grid_sp_h2 * grid_sp_h2) * & + (fmax * BoundCorConst) + endif + endif + if (CS%Leith_Ah) then + CS%biharm6_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h3) + endif + if (CS%use_Leithy) then + CS%biharm6_const_xx(i,j) = Leith_bi_const * max(G%dxT(i,j),G%dyT(i,j))**6 + CS%m_const_leithy(i,j) = 0.5 * sqrt(CS%c_K) * max(G%dxT(i,j),G%dyT(i,j)) + CS%m_leithy_max(i,j) = 4. / max(G%dxT(i,j),G%dyT(i,j))**2 + endif + CS%Ah_bg_xx(i,j) = MAX(Ah, Ah_vel_scale * grid_sp_h2 * sqrt(grid_sp_h2)) + if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xx(i,j) = grid_sp_h3 / CS%Re_Ah + if (Ah_time_scale > 0.) CS%Ah_bg_xx(i,j) = & + MAX(CS%Ah_bg_xx(i,j), (grid_sp_h2 * grid_sp_h2) / Ah_time_scale) + if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then + CS%Ah_Max_xx(i,j) = Ah_Limit * (grid_sp_h2 * grid_sp_h2) + CS%Ah_bg_xx(i,j) = MIN(CS%Ah_bg_xx(i,j), CS%Ah_Max_xx(i,j)) + endif + min_grid_sp_h4 = min(grid_sp_h2**2, min_grid_sp_h4) + enddo ; enddo + call min_across_PEs(min_grid_sp_h4) + + do J=js-1,Jeq ; do I=is-1,Ieq + grid_sp_q2 = (2.0*CS%dx2q(I,J)*CS%dy2q(I,J)) / (CS%dx2q(I,J)+CS%dy2q(I,J)) + grid_sp_q3 = grid_sp_q2*sqrt(grid_sp_q2) + if (CS%Smagorinsky_Ah) then + CS%Biharm_const_xy(I,J) = Smag_bi_const * (grid_sp_q2 * grid_sp_q2) + if (CS%bound_Coriolis) then + CS%Biharm_const2_xy(I,J) = (grid_sp_q2 * grid_sp_q2 * grid_sp_q2) * & + (abs(G%CoriolisBu(I,J)) * BoundCorConst) + endif + endif + if ((CS%Leith_Ah) .or. (CS%use_Leithy))then + CS%biharm6_const_xy(I,J) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) + endif + CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) + if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xy(i,j) = grid_sp_q3 / CS%Re_Ah + if (Ah_time_scale > 0.) CS%Ah_bg_xy(i,j) = & + MAX(CS%Ah_bg_xy(i,j), (grid_sp_q2 * grid_sp_q2) / Ah_time_scale) + if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then + CS%Ah_Max_xy(I,J) = Ah_Limit * (grid_sp_q2 * grid_sp_q2) + CS%Ah_bg_xy(I,J) = MIN(CS%Ah_bg_xy(I,J), CS%Ah_Max_xy(I,J)) + endif + enddo ; enddo + endif + ! The Laplacian bounds should avoid overshoots when CS%bound_coef < 1. + if (CS%Laplacian .and. CS%better_bound_Kh) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + denom = max( & + (CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) * & + max(G%IdyCu(I,j)*G%IareaCu(I,j), G%IdyCu(I-1,j)*G%IareaCu(I-1,j)) ), & + (CS%dx2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) * & + max(G%IdxCv(i,J)*G%IareaCv(i,J), G%IdxCv(i,J-1)*G%IareaCv(i,J-1)) ) ) + CS%Kh_Max_xx(i,j) = 0.0 + if (denom > 0.0) & + CS%Kh_Max_xx(i,j) = CS%bound_coef * 0.25 * Idt / denom + enddo ; enddo + do J=js-1,Jeq ; do I=is-1,Ieq + denom = max( & + (CS%dx2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j)) * & + max(G%IdxCu(I,j)*G%IareaCu(I,j), G%IdxCu(I,j+1)*G%IareaCu(I,j+1)) ), & + (CS%dy2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) * & + max(G%IdyCv(i,J)*G%IareaCv(i,J), G%IdyCv(i+1,J)*G%IareaCv(i+1,J)) ) ) + CS%Kh_Max_xy(I,J) = 0.0 + if (denom > 0.0) & + CS%Kh_Max_xy(I,J) = CS%bound_coef * 0.25 * Idt / denom + enddo ; enddo + if (CS%debug) then + call hchksum(CS%Kh_Max_xx, "Kh_Max_xx", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + call Bchksum(CS%Kh_Max_xy, "Kh_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + endif + endif + ! The biharmonic bounds should avoid overshoots when CS%bound_coef < 0.5, but + ! empirically work for CS%bound_coef <~ 1.0 + if (CS%biharmonic .and. CS%better_bound_Ah) then + do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 + u0u(I,j) = (CS%Idxdy2u(I,j)*(CS%dy2h(i+1,j)*CS%DY_dxT(i+1,j)*(G%IdyCu(I+1,j) + G%IdyCu(I,j)) + & + CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) ) + & + CS%Idx2dyCu(I,j)*(CS%dx2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j)) + & + CS%dx2q(I,J-1)*CS%DX_dyBu(I,J-1)*(G%IdxCu(I,j) + G%IdxCu(I,j-1)) ) ) + u0v(I,j) = (CS%Idxdy2u(I,j)*(CS%dy2h(i+1,j)*CS%DX_dyT(i+1,j)*(G%IdxCv(i+1,J) + G%IdxCv(i+1,J-1)) + & + CS%dy2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) ) + & + CS%Idx2dyCu(I,j)*(CS%dx2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) + & + CS%dx2q(I,J-1)*CS%DY_dxBu(I,J-1)*(G%IdyCv(i+1,J-1) + G%IdyCv(i,J-1)) ) ) + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do i=is-1,Ieq+1 + v0u(i,J) = (CS%Idxdy2v(i,J)*(CS%dy2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j)) + & + CS%dy2q(I-1,J)*CS%DX_dyBu(I-1,J)*(G%IdxCu(I-1,j+1) + G%IdxCu(I-1,j)) ) + & + CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*CS%DY_dxT(i,j+1)*(G%IdyCu(I,j+1) + G%IdyCu(I-1,j+1)) + & + CS%dx2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) ) ) + v0v(i,J) = (CS%Idxdy2v(i,J)*(CS%dy2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) + & + CS%dy2q(I-1,J)*CS%DY_dxBu(I-1,J)*(G%IdyCv(i,J) + G%IdyCv(i-1,J)) ) + & + CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*CS%DX_dyT(i,j+1)*(G%IdxCv(i,J+1) + G%IdxCv(i,J)) + & + CS%dx2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) ) ) + enddo ; enddo + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + denom = max( & + (CS%dy2h(i,j) * & + (CS%DY_dxT(i,j)*(G%IdyCu(I,j)*u0u(I,j) + G%IdyCu(I-1,j)*u0u(I-1,j)) + & + CS%DX_dyT(i,j)*(G%IdxCv(i,J)*v0u(i,J) + G%IdxCv(i,J-1)*v0u(i,J-1))) * & + max(G%IdyCu(I,j)*G%IareaCu(I,j), G%IdyCu(I-1,j)*G%IareaCu(I-1,j)) ), & + (CS%dx2h(i,j) * & + (CS%DY_dxT(i,j)*(G%IdyCu(I,j)*u0v(I,j) + G%IdyCu(I-1,j)*u0v(I-1,j)) + & + CS%DX_dyT(i,j)*(G%IdxCv(i,J)*v0v(i,J) + G%IdxCv(i,J-1)*v0v(i,J-1))) * & + max(G%IdxCv(i,J)*G%IareaCv(i,J), G%IdxCv(i,J-1)*G%IareaCv(i,J-1)) ) ) + CS%Ah_Max_xx(I,J) = 0.0 + if (denom > 0.0) & + CS%Ah_Max_xx(I,J) = CS%bound_coef * 0.5 * Idt / denom + enddo ; enddo + do J=js-1,Jeq ; do I=is-1,Ieq + denom = max( & + (CS%dx2q(I,J) * & + (CS%DX_dyBu(I,J)*(u0u(I,j+1)*G%IdxCu(I,j+1) + u0u(I,j)*G%IdxCu(I,j)) + & + CS%DY_dxBu(I,J)*(v0u(i+1,J)*G%IdyCv(i+1,J) + v0u(i,J)*G%IdyCv(i,J))) * & + max(G%IdxCu(I,j)*G%IareaCu(I,j), G%IdxCu(I,j+1)*G%IareaCu(I,j+1)) ), & + (CS%dy2q(I,J) * & + (CS%DX_dyBu(I,J)*(u0v(I,j+1)*G%IdxCu(I,j+1) + u0v(I,j)*G%IdxCu(I,j)) + & + CS%DY_dxBu(I,J)*(v0v(i+1,J)*G%IdyCv(i+1,J) + v0v(i,J)*G%IdyCv(i,J))) * & + max(G%IdyCv(i,J)*G%IareaCv(i,J), G%IdyCv(i+1,J)*G%IareaCv(i+1,J)) ) ) + CS%Ah_Max_xy(I,J) = 0.0 + if (denom > 0.0) & + CS%Ah_Max_xy(I,J) = CS%bound_coef * 0.5 * Idt / denom + enddo ; enddo + if (CS%debug) then + call hchksum(CS%Ah_Max_xx, "Ah_Max_xx", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) + call Bchksum(CS%Ah_Max_xy, "Ah_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) + endif + endif + ! Register fields for output from this module. + CS%id_normstress = register_diag_field('ocean_model', 'NoSt', diag%axesTL, Time, & + 'Normal Stress', 's-1', conversion=US%s_to_T) + CS%id_shearstress = register_diag_field('ocean_model', 'ShSt', diag%axesBL, Time, & + 'Shear Stress', 's-1', conversion=US%s_to_T) + CS%id_diffu = register_diag_field('ocean_model', 'diffu', diag%axesCuL, Time, & + 'Zonal Acceleration from Horizontal Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_diffv = register_diag_field('ocean_model', 'diffv', diag%axesCvL, Time, & + 'Meridional Acceleration from Horizontal Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + + !CS%id_hf_diffu = register_diag_field('ocean_model', 'hf_diffu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if ((CS%id_hf_diffu > 0) .and. (present(ADp))) then + ! call safe_alloc_alloc(CS%hf_diffu,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) + ! call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) + !endif + + !CS%id_hf_diffv = register_diag_field('ocean_model', 'hf_diffv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if ((CS%id_hf_diffv > 0) .and. (present(ADp))) then + ! call safe_alloc_alloc(CS%hf_diffv,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) + !endif + + CS%id_hf_diffu_2d = register_diag_field('ocean_model', 'hf_diffu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if ((CS%id_hf_diffu_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) + endif + + CS%id_hf_diffv_2d = register_diag_field('ocean_model', 'hf_diffv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if ((CS%id_hf_diffv_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) + endif + + CS%id_h_diffu = register_diag_field('ocean_model', 'h_diffu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Horizontal Viscosity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if ((CS%id_h_diffu > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hu,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) + endif + + CS%id_h_diffv = register_diag_field('ocean_model', 'h_diffv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Horizontal Viscosity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if ((CS%id_h_diffv > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hv,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) + endif + + CS%id_intz_diffu_2d = register_diag_field('ocean_model', 'intz_diffu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Acceleration from Horizontal Viscosity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if ((CS%id_intz_diffu_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hu,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) + endif + + CS%id_intz_diffv_2d = register_diag_field('ocean_model', 'intz_diffv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Acceleration from Horizontal Viscosity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if ((CS%id_intz_diffv_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hv,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) + endif + + CS%id_diffu_visc_rem = register_diag_field('ocean_model', 'diffu_visc_rem', diag%axesCuL, Time, & + 'Zonal Acceleration from Horizontal Viscosity multiplied by viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if ((CS%id_diffu_visc_rem > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%visc_rem_u,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) + endif + + CS%id_diffv_visc_rem = register_diag_field('ocean_model', 'diffv_visc_rem', diag%axesCvL, Time, & + 'Meridional Acceleration from Horizontal Viscosity multiplied by viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if ((CS%id_diffv_visc_rem > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%visc_rem_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) + endif + + if (CS%biharmonic) then + CS%id_Ah_h = register_diag_field('ocean_model', 'Ahh', diag%axesTL, Time, & + 'Biharmonic Horizontal Viscosity at h Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T, & + cmor_field_name='difmxybo', & + cmor_long_name='Ocean lateral biharmonic viscosity', & + cmor_standard_name='ocean_momentum_xy_biharmonic_diffusivity') + CS%id_Ah_q = register_diag_field('ocean_model', 'Ahq', diag%axesBL, Time, & + 'Biharmonic Horizontal Viscosity at q Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T) + CS%id_grid_Re_Ah = register_diag_field('ocean_model', 'grid_Re_Ah', diag%axesTL, Time, & + 'Grid Reynolds number for the Biharmonic horizontal viscosity at h points', 'nondim') + + if (CS%id_grid_Re_Ah > 0) & + ! Compute the smallest biharmonic viscosity capable of modifying the + ! velocity at floating point precision. + CS%min_grid_Ah = spacing(1.) * min_grid_sp_h4 * Idt + endif + if (CS%Laplacian) then + CS%id_Kh_h = register_diag_field('ocean_model', 'Khh', diag%axesTL, Time, & + 'Laplacian Horizontal Viscosity at h Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T, & + cmor_field_name='difmxylo', & + cmor_long_name='Ocean lateral Laplacian viscosity', & + cmor_standard_name='ocean_momentum_xy_laplacian_diffusivity') + CS%id_Kh_q = register_diag_field('ocean_model', 'Khq', diag%axesBL, Time, & + 'Laplacian Horizontal Viscosity at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_grid_Re_Kh = register_diag_field('ocean_model', 'grid_Re_Kh', diag%axesTL, Time, & + 'Grid Reynolds number for the Laplacian horizontal viscosity at h points', 'nondim') + CS%id_vort_xy_q = register_diag_field('ocean_model', 'vort_xy_q', diag%axesBL, Time, & + 'Vertical vorticity at q Points', 's-1', conversion=US%s_to_T) + CS%id_div_xx_h = register_diag_field('ocean_model', 'div_xx_h', diag%axesTL, Time, & + 'Horizontal divergence at h Points', 's-1', conversion=US%s_to_T) + CS%id_sh_xy_q = register_diag_field('ocean_model', 'sh_xy_q', diag%axesBL, Time, & + 'Shearing strain at q Points', 's-1', conversion=US%s_to_T) + CS%id_sh_xx_h = register_diag_field('ocean_model', 'sh_xx_h', diag%axesTL, Time, & + 'Horizontal tension at h Points', 's-1', conversion=US%s_to_T) + + if (CS%id_grid_Re_Kh > 0) & + ! Compute a smallest Laplacian viscosity capable of modifying the + ! velocity at floating point precision. + CS%min_grid_Kh = spacing(1.) * min_grid_sp_h2 * Idt + endif + if (CS%use_GME) then + CS%id_dudx_bt = register_diag_field('ocean_model', 'dudx_bt', diag%axesT1, Time, & + 'Zonal component of the barotropic shearing strain at h points', 's-1', & + conversion=US%s_to_T) + CS%id_dudy_bt = register_diag_field('ocean_model', 'dudy_bt', diag%axesB1, Time, & + 'Zonal component of the barotropic shearing strain at q points', 's-1', & + conversion=US%s_to_T) + CS%id_dvdy_bt = register_diag_field('ocean_model', 'dvdy_bt', diag%axesT1, Time, & + 'Meridional component of the barotropic shearing strain at h points', 's-1', & + conversion=US%s_to_T) + CS%id_dvdx_bt = register_diag_field('ocean_model', 'dvdx_bt', diag%axesB1, Time, & + 'Meridional component of the barotropic shearing strain at q points', 's-1', & + conversion=US%s_to_T) + CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & + 'GME coefficient at h Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_GME_coeff_q = register_diag_field('ocean_model', 'GME_coeff_q', diag%axesBL, Time, & + 'GME coefficient at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_FrictWork_GME = register_diag_field('ocean_model','FrictWork_GME',diag%axesTL,Time,& + 'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + endif + CS%id_FrictWork = register_diag_field('ocean_model','FrictWork',diag%axesTL,Time,& + 'Integral work done by lateral friction terms. If GME is turned on, this '//& + 'includes the GME contribution.', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + CS%id_FrictWorkIntz = register_diag_field('ocean_model','FrictWorkIntz',diag%axesT1,Time, & + 'Depth integrated work done by lateral friction', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2, & + cmor_field_name='dispkexyfo', & + cmor_long_name='Depth integrated ocean kinetic energy dissipation due to lateral friction',& + cmor_standard_name='ocean_kinetic_energy_dissipation_per_unit_area_due_to_xy_friction') + +end subroutine hor_visc_init + +!> Calculates factors in the anisotropic orientation tensor to be align with the grid. +!! With n1=1 and n2=0, this recovers the approach of Large et al, 2001. +subroutine align_aniso_tensor_to_grid(CS, n1, n2) + type(hor_visc_CS), intent(inout) :: CS !< Control structure for horizontal viscosity + real, intent(in) :: n1 !< i-component of direction vector [nondim] + real, intent(in) :: n2 !< j-component of direction vector [nondim] + ! Local variables + real :: recip_n2_norm ! The inverse of the squared magnitude of n1 and n2 [nondim] + ! For normalizing n=(n1,n2) in case arguments are not a unit vector + recip_n2_norm = n1**2 + n2**2 + if (recip_n2_norm > 0.) recip_n2_norm = 1. / recip_n2_norm + CS%n1n2_h(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm + CS%n1n2_q(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm + CS%n1n1_m_n2n2_h(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm + CS%n1n1_m_n2n2_q(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm +end subroutine align_aniso_tensor_to_grid + +!> Apply a 1-1-4-1-1 Laplacian filter one time on GME diffusive flux to reduce any +!! horizontal two-grid-point noise +subroutine smooth_GME(CS, G, GME_flux_h, GME_flux_q) + type(hor_visc_CS), intent(in) :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: GME_flux_h!< GME diffusive flux + !! at h points [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: GME_flux_q!< GME diffusive flux + !! at q points [L2 T-2 ~> m2 s-2] + ! local variables + real, dimension(SZI_(G),SZJ_(G)) :: GME_flux_h_original ! The previous value of GME_flux_h [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original ! The previous value of GME_flux_q [L2 T-2 ~> m2 s-2] + real :: wc, ww, we, wn, ws ! averaging weights for smoothing [nondim] + integer :: i, j, s, halosz + integer :: xh, xq ! The number of valid extra halo points for h and q points. + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + xh = 0 ; xq = 0 + + do s=1,CS%num_smooth_gme + if (present(GME_flux_h)) then + if (xh < 0) then + ! Update halos if needed, but avoid doing so more often than is needed. + halosz = min(G%isc-G%isd, G%jsc-G%jsd, 2+CS%num_smooth_gme-s) + call pass_var(GME_flux_h, G%Domain, halo=halosz) + xh = halosz - 2 + endif + GME_flux_h_original(:,:) = GME_flux_h(:,:) + ! apply smoothing on GME + do j=Jsq-xh,Jeq+1+xh ; do i=Isq-xh,Ieq+1+xh + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + ! compute weights + ww = 0.125 * G%mask2dT(i-1,j) + we = 0.125 * G%mask2dT(i+1,j) + ws = 0.125 * G%mask2dT(i,j-1) + wn = 0.125 * G%mask2dT(i,j+1) + wc = 1.0 - ((ww+we)+(wn+ws)) + GME_flux_h(i,j) = wc * GME_flux_h_original(i,j) & + + ((ww * GME_flux_h_original(i-1,j) + we * GME_flux_h_original(i+1,j)) & + + (ws * GME_flux_h_original(i,j-1) + wn * GME_flux_h_original(i,j+1))) + enddo ; enddo + xh = xh - 1 + endif + if (present(GME_flux_q)) then + if (xq < 0) then + ! Update halos if needed, but avoid doing so more often than is needed. + halosz = min(G%isc-G%isd, G%jsc-G%jsd, 2+CS%num_smooth_gme-s) + call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true., halo=halosz) + xq = halosz - 2 + endif + GME_flux_q_original(:,:) = GME_flux_q(:,:) + ! apply smoothing on GME + do J=js-1-xq,je+xq ; do I=is-1-xq,ie+xq + ! skip land points + if (G%mask2dBu(I,J)==0.) cycle + ! compute weights + ww = 0.125 * G%mask2dBu(I-1,J) + we = 0.125 * G%mask2dBu(I+1,J) + ws = 0.125 * G%mask2dBu(I,J-1) + wn = 0.125 * G%mask2dBu(I,J+1) + wc = 1.0 - ((ww+we)+(wn+ws)) + GME_flux_q(I,J) = wc * GME_flux_q_original(I,J) & + + ((ww * GME_flux_q_original(I-1,J) + we * GME_flux_q_original(I+1,J)) & + + (ws * GME_flux_q_original(I,J-1) + wn * GME_flux_q_original(I,J+1))) + enddo ; enddo + xq = xq - 1 + endif + enddo ! s-loop +end subroutine smooth_GME + +!> Apply a 9-point smoothing filter twice to reduce horizontal two-grid-point noise +!! Note that this subroutine does not conserve mass or angular momentum, so don't use it +!! in situations where you need conservation. Also can't apply it to Ah and Kh in the +!! horizontal_viscosity subroutine because they are not supposed to be halo-updated. +!! But you _can_ apply them to Kh_h and Ah_h. +subroutine smooth_x9(CS, G, field_h, field_u, field_v, field_q, zero_land) + type(hor_visc_CS), intent(in) :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: field_h !< field to be smoothed + !! at h points + real, dimension(SZIB_(G),SZJ_(G)), optional, intent(inout) :: field_u !< field to be smoothed + !! at u points + real, dimension(SZI_(G),SZJB_(G)), optional, intent(inout) :: field_v !< field to be smoothed + !! at v points + real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: field_q !< field to be smoothed + !! at q points + logical, optional, intent(in) :: zero_land !< An optional argument + !! indicating whether to set values + !! on land to zero (.true.) or + !! whether to ignore land values + !! (.false. or not present) + ! local variables. It would be good to make the _original variables allocatable. + real, dimension(SZI_(G),SZJ_(G)) :: field_h_original + real, dimension(SZIB_(G),SZJ_(G)) :: field_u_original + real, dimension(SZI_(G),SZJB_(G)) :: field_v_original + real, dimension(SZIB_(G),SZJB_(G)) :: field_q_original + real, dimension(3,3) :: weights, local_weights ! averaging weights for smoothing, nondimensional + logical :: zero_land_val ! actual value of zero_land optional argument + integer :: i, j, s + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + weights = reshape([1., 2., 1., 2., 4., 2., 1., 2., 1.],shape(weights))/16. + + if (present(zero_land)) then + zero_land_val = zero_land + else + zero_land_val = .false. + endif + + if (present(field_h)) then + call pass_var(field_h, G%Domain, halo=2) ! Halo size 2 ensures that you can smooth twice + do s=1,0,-1 + field_h_original(:,:) = field_h(:,:) + ! apply smoothing on field_h + do j=js-s,je+s ; do i=is-s,ie+s + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + ! compute local weights + local_weights = weights*G%mask2dT(i-1:i+1,j-1:j+1) + if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) + field_h(i,j) = sum(local_weights*field_h_original(i-1:i+1,j-1:j+1)) + enddo ; enddo + enddo + call pass_var(field_h, G%Domain) + endif + + if (present(field_u)) then + call pass_vector(field_u, field_v, G%Domain, halo=2) + do s=1,0,-1 + field_u_original(:,:) = field_u(:,:) + ! apply smoothing on field_u + do j=js-s,je+s ; do I=Isq-s,Ieq+s + ! skip land points + if (G%mask2dCu(I,j)==0.) cycle + ! compute local weights + local_weights = weights*G%mask2dCu(I-1:I+1,j-1:j+1) + if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) + field_u(I,j) = sum(local_weights*field_u_original(I-1:I+1,j-1:j+1)) + enddo ; enddo + + field_v_original(:,:) = field_v(:,:) + ! apply smoothing on field_v + do J=Jsq-s,Jeq+s ; do i=is-s,ie+s + ! skip land points + if (G%mask2dCv(i,J)==0.) cycle + ! compute local weights + local_weights = weights*G%mask2dCv(i-1:i+1,J-1:J+1) + if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) + field_v(i,J) = sum(local_weights*field_v_original(i-1:i+1,J-1:J+1)) + enddo ; enddo + enddo + call pass_vector(field_u, field_v, G%Domain) + endif + + if (present(field_q)) then + call pass_var(field_q, G%Domain, halo=2, position=CORNER) + do s=1,0,-1 + field_q_original(:,:) = field_q(:,:) + ! apply smoothing on field_q + do J=Jsq-s,Jeq+s ; do I=Isq-s,Ieq+s + ! skip land points + if (G%mask2dBu(I,J)==0.) cycle + ! compute local weights + local_weights = weights*G%mask2dBu(I-1:I+1,J-1:J+1) + if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) + field_q(I,J) = sum(local_weights*field_q_original(I-1:I+1,J-1:J+1)) + enddo ; enddo + enddo + call pass_var(field_q, G%Domain, position=CORNER) + endif + +end subroutine smooth_x9 + +!> Deallocates any variables allocated in hor_visc_init. +subroutine hor_visc_end(CS) + type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure + if (CS%Laplacian .or. CS%biharmonic) then + DEALLOC_(CS%dx2h) ; DEALLOC_(CS%dx2q) ; DEALLOC_(CS%dy2h) ; DEALLOC_(CS%dy2q) + DEALLOC_(CS%dx_dyT) ; DEALLOC_(CS%dy_dxT) ; DEALLOC_(CS%dx_dyBu) ; DEALLOC_(CS%dy_dxBu) + DEALLOC_(CS%reduction_xx) ; DEALLOC_(CS%reduction_xy) + endif + if (CS%Laplacian) then + DEALLOC_(CS%Kh_bg_xx) ; DEALLOC_(CS%Kh_bg_xy) + DEALLOC_(CS%grid_sp_h2) + if (CS%bound_Kh) then + DEALLOC_(CS%Kh_Max_xx) ; DEALLOC_(CS%Kh_Max_xy) + endif + if (CS%Smagorinsky_Kh) then + DEALLOC_(CS%Laplac2_const_xx) ; DEALLOC_(CS%Laplac2_const_xy) + endif + if (CS%Leith_Kh) then + DEALLOC_(CS%Laplac3_const_xx) ; DEALLOC_(CS%Laplac3_const_xy) + endif + endif + if (CS%biharmonic) then + DEALLOC_(CS%grid_sp_h3) + DEALLOC_(CS%Idx2dyCu) ; DEALLOC_(CS%Idx2dyCv) + DEALLOC_(CS%Idxdy2u) ; DEALLOC_(CS%Idxdy2v) + DEALLOC_(CS%Ah_bg_xx) ; DEALLOC_(CS%Ah_bg_xy) + if (CS%bound_Ah) then + DEALLOC_(CS%Ah_Max_xx) ; DEALLOC_(CS%Ah_Max_xy) + endif + if (CS%Smagorinsky_Ah) then + DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) + endif + if ((CS%Leith_Ah) .or. (CS%use_Leithy)) then + DEALLOC_(CS%Biharm6_const_xx) ; DEALLOC_(CS%Biharm6_const_xy) + endif + if (CS%use_Leithy) then + DEALLOC_(CS%m_const_leithy) + DEALLOC_(CS%m_leithy_max) + endif + if (CS%Re_Ah > 0.0) then + DEALLOC_(CS%Re_Ah_const_xx) ; DEALLOC_(CS%Re_Ah_const_xy) + endif + endif + if (CS%anisotropic) then + DEALLOC_(CS%n1n2_h) + DEALLOC_(CS%n1n2_q) + DEALLOC_(CS%n1n1_m_n2n2_h) + DEALLOC_(CS%n1n1_m_n2n2_q) + endif + + if (CS%use_ZB2020) then + call ZB2020_end(CS%ZB2020) + endif + +end subroutine hor_visc_end +!> \namespace mom_hor_visc +!! +!! This module contains the subroutine horizontal_viscosity() that calculates the +!! effects of horizontal viscosity, including parameterizations of the value of +!! the viscosity itself. horizontal_viscosity() calculates the acceleration due to +!! some combination of a biharmonic viscosity and a Laplacian viscosity. Either or +!! both may use a coefficient that depends on the shear and strain of the flow. +!! All metric terms are retained. The Laplacian is calculated as the divergence of +!! a stress tensor, using the form suggested by Smagorinsky (1993). The biharmonic +!! is calculated by twice applying the divergence of the stress tensor that is +!! used to calculate the Laplacian, but without the dependence on thickness in the +!! first pass. This form permits a variable viscosity, and indicates no +!! acceleration for either resting fluid or solid body rotation. +!! +!! The form of the viscous accelerations is discussed extensively in Griffies and +!! Hallberg (2000), and the implementation here follows that discussion closely. +!! We use the notation of Smith and McWilliams (2003) with the exception that the +!! isotropic viscosity is \f$\kappa_h\f$. +!! +!! \section section_horizontal_viscosity Horizontal viscosity in MOM +!! +!! In general, the horizontal stress tensor can be written as +!! \f[ +!! {\bf \sigma} = +!! \begin{pmatrix} +!! \frac{1}{2} \left( \sigma_D + \sigma_T \right) & \frac{1}{2} \sigma_S \\\\ +!! \frac{1}{2} \sigma_S & \frac{1}{2} \left( \sigma_D - \sigma_T \right) +!! \end{pmatrix} +!! \f] +!! where \f$\sigma_D\f$, \f$\sigma_T\f$ and \f$\sigma_S\f$ are stresses associated with +!! invariant factors in the strain-rate tensor. For a Newtonian fluid, the stress +!! tensor is usually linearly related to the strain-rate tensor. The horizontal +!! strain-rate tensor is +!! \f[ +!! \dot{\bf e} = +!! \begin{pmatrix} +!! \frac{1}{2} \left( \dot{e}_D + \dot{e}_T \right) & \frac{1}{2} \dot{e}_S \\\\ +!! \frac{1}{2} \dot{e}_S & \frac{1}{2} \left( \dot{e}_D - \dot{e}_T \right) +!! \end{pmatrix} +!! \f] +!! where \f$\dot{e}_D = \partial_x u + \partial_y v\f$ is the horizontal divergence, +!! \f$\dot{e}_T = \partial_x u - \partial_y v\f$ is the horizontal tension, and +!! \f$\dot{e}_S = \partial_y u + \partial_x v\f$ is the horizontal shear strain. +!! +!! The trace of the stress tensor, \f$tr(\bf \sigma) = \sigma_D\f$, is usually +!! absorbed into the pressure and only the deviatoric stress tensor considered. +!! From here on, we drop \f$\sigma_D\f$. The trace of the strain tensor, \f$tr(\bf e) = +!! \dot{e}_D\f$ is non-zero for horizontally divergent flow but only enters the +!! stress tensor through \f$\sigma_D\f$ and so we will drop \f$\sigma_D\f$ from +!! calculations of the strain tensor in the code. Therefore the horizontal stress +!! tensor can be considered to be +!! \f[ +!! {\bf \sigma} = +!! \begin{pmatrix} +!! \frac{1}{2} \sigma_T & \frac{1}{2} \sigma_S \\\\ +!! \frac{1}{2} \sigma_S & - \frac{1}{2} \sigma_T +!! \end{pmatrix} +!! .\f] +!! +!! The stresses above are linearly related to the strain through a viscosity +!! coefficient, \f$\kappa_h\f$: +!! \f{eqnarray*}{ +!! \sigma_T & = & 2 \kappa_h \dot{e}_T \\\\ +!! \sigma_S & = & 2 \kappa_h \dot{e}_S +!! . +!! \f} +!! +!! The viscosity \f$\kappa_h\f$ may either be a constant or variable. For example, +!! \f$\kappa_h\f$ may vary with the shear, as proposed by Smagorinsky (1993). +!! +!! The accelerations resulting form the divergence of the stress tensor are +!! \f{eqnarray*}{ +!! \hat{\bf x} \cdot \left( \nabla \cdot {\bf \sigma} \right) +!! & = & +!! \partial_x \left( \frac{1}{2} \sigma_T \right) +!! + \partial_y \left( \frac{1}{2} \sigma_S \right) +!! \\\\ +!! & = & +!! \partial_x \left( \kappa_h \dot{e}_T \right) +!! + \partial_y \left( \kappa_h \dot{e}_S \right) +!! \\\\ +!! \hat{\bf y} \cdot \left( \nabla \cdot {\bf \sigma} \right) +!! & = & +!! \partial_x \left( \frac{1}{2} \sigma_S \right) +!! + \partial_y \left( - \frac{1}{2} \sigma_T \right) +!! \\\\ +!! & = & +!! \partial_x \left( \kappa_h \dot{e}_S \right) +!! + \partial_y \left( - \kappa_h \dot{e}_T \right) +!! . +!! \f} +!! +!! The form of the Laplacian viscosity in general coordinates is: +!! \f{eqnarray*}{ +!! \hat{\bf x} \cdot \left( \nabla \cdot \sigma \right) +!! & = & +!! \frac{1}{h} \left[ \partial_x \left( \kappa_h h \dot{e}_T \right) +!! + \partial_y \left( \kappa_h h \dot{e}_S \right) \right] +!! \\\\ +!! \hat{\bf y} \cdot \left( \nabla \cdot \sigma \right) +!! & = & +!! \frac{1}{h} \left[ \partial_x \left( \kappa_h h \dot{e}_S \right) +!! - \partial_y \left( \kappa_h h \dot{e}_T \right) \right] +!! . +!! \f} +!! +!! \subsection section_laplacian_viscosity_coefficient Laplacian viscosity coefficient +!! +!! The horizontal viscosity coefficient, \f$\kappa_h\f$, can have multiple components. +!! The isotropic components are: +!! - A uniform background component, \f$\kappa_{bg}\f$. +!! - A constant but spatially variable 2D map, \f$\kappa_{2d}(x,y)\f$. +!! - A ''MICOM'' viscosity, \f$U_\nu \Delta(x,y)\f$, which uses a constant +!! velocity scale, \f$U_\nu\f$ and a measure of the grid-spacing \f$\Delta(x,y)^2 = +!! \frac{2 \Delta x^2 \Delta y^2}{\Delta x^2 + \Delta y^2}\f$. +!! - A function of +!! latitude, \f$\kappa_{\phi}(x,y) = \kappa_{\pi/2} |\sin(\phi)|^n\f$. +!! - A dynamic Smagorinsky viscosity, \f$\kappa_{Sm}(x,y,t) = C_{Sm} \Delta^2 \sqrt{\dot{e}_T^2 + \dot{e}_S^2}\f$. +!! - A dynamic Leith viscosity, \f$\kappa_{Lth}(x,y,t) = +!! C_{Lth} \Delta^3 \sqrt{|\nabla \zeta|^2 + |\nabla \dot{e}_D|^2}\f$. +!! +!! A maximum stable viscosity, \f$\kappa_{max}(x,y)\f$ is calculated based on the +!! grid-spacing and time-step and used to clip calculated viscosities. +!! +!! The static components of \f$\kappa_h\f$ are first combined as follows: +!! \f[ +!! \kappa_{static} = \min \left[ \max\left( +!! \kappa_{bg}, +!! U_\nu \Delta(x,y), +!! \kappa_{2d}(x,y), +!! \kappa_\phi(x,y) +!! \right) +!! , \kappa_{max}(x,y) \right] +!! \f] +!! and stored in the module control structure as variables Kh_bg_xx and +!! Kh_bg_xy for the tension (h-points) and shear (q-points) components +!! respectively. +!! +!! The full viscosity includes the dynamic components as follows: +!! \f[ +!! \kappa_h(x,y,t) = r(\Delta,L_d) +!! \max \left( \kappa_{static}, \kappa_{Sm}, \kappa_{Lth} \right) +!! \f] +!! where \f$r(\Delta,L_d)\f$ is a resolution function. +!! +!! The dynamic Smagorinsky and Leith viscosity schemes are exclusive with each +!! other. +!! +!! \subsection section_viscous_boundary_conditions Viscous boundary conditions +!! +!! Free slip boundary conditions have been coded, although no slip boundary +!! conditions can be used with the Laplacian viscosity based on the 2D land-sea +!! mask. For a western boundary, for example, the boundary conditions with the +!! biharmonic operator would be written as: +!! \f[ +!! \partial_x v = 0 ; \partial_x^3 v = 0 ; u = 0 ; \partial_x^2 u = 0 , +!! \f] +!! while for a Laplacian operator, they are simply +!! \f[ +!! \partial_x v = 0 ; u = 0 . +!! \f] +!! These boundary conditions are largely dictated by the use of an Arakawa +!! C-grid and by the varying layer thickness. +!! +!! \subsection section_anisotropic_viscosity Anisotropic viscosity +!! +!! Large et al., 2001, proposed enhancing viscosity in a particular direction and the +!! approach was generalized in Smith and McWilliams, 2003. We use the second form of their +!! two coefficient anisotropic viscosity (section 4.3). We also replace their +!! \f$A^\prime\f$ and $D$ such that \f$2A^\prime = 2 \kappa_h + D\f$ and +!! \f$\kappa_a = D\f$ so that \f$\kappa_h\f$ can be considered the isotropic +!! viscosity and \f$\kappa_a=D\f$ can be consider the anisotropic viscosity. The +!! direction of anisotropy is defined by a unit vector \f$\hat{\bf +!! n}=(n_1,n_2)\f$. +!! +!! The contributions to the stress tensor are +!! \f[ +!! \begin{pmatrix} +!! \sigma_T \\\\ \sigma_S +!! \end{pmatrix} +!! = +!! \left[ +!! \begin{pmatrix} +!! 2 \kappa_h + \kappa_a & 0 \\\\ +!! 0 & 2 \kappa_h +!! \end{pmatrix} +!! + 2 \kappa_a n_1 n_2 +!! \begin{pmatrix} +!! - 2 n_1 n_2 & n_1^2 - n_2^2 \\\\ +!! n_1^2 - n_2^2 & 2 n_1 n_2 +!! \end{pmatrix} +!! \right] +!! \begin{pmatrix} +!! \dot{e}_T \\\\ \dot{e}_S +!! \end{pmatrix} +!! \f] +!! Dissipation of kinetic energy requires \f$\kappa_h \geq 0\f$ and \f$2 \kappa_h + \kappa_a \geq 0\f$. +!! Note that when anisotropy is aligned with the x-direction, \f$n_1 = \pm 1\f$, then +!! \f$n_2 = 0\f$ and the cross terms vanish. The accelerations in this aligned limit +!! with constant coefficients become +!! \f{eqnarray*}{ +!! \hat{\bf x} \cdot \nabla \cdot {\bf \sigma} +!! & = & +!! \partial_x \left( \left( \kappa_h + \frac{1}{2} \kappa_a \right) \dot{e}_T \right) +!! + \partial_y \left( \kappa_h \dot{e}_S \right) +!! \\\\ +!! & = & +!! \left( \kappa_h + \kappa_a \right) \partial_{xx} u +!! + \kappa_h \partial_{yy} u +!! - \frac{1}{2} \kappa_a \partial_x \left( \partial_x u + \partial_y v \right) +!! \\\\ +!! \hat{\bf y} \cdot \nabla \cdot {\bf \sigma} +!! & = & +!! \partial_x \left( \kappa_h \dot{e}_S \right) +!! - \partial_y \left( \left( \kappa_h + \frac{1}{2} \kappa_a \right) \dot{e}_T \right) +!! \\\\ +!! & = & +!! \kappa_h \partial_{xx} v +!! + \left( \kappa_h + \kappa_a \right) \partial_{yy} v +!! - \frac{1}{2} \kappa_a \partial_y \left( \partial_x u + \partial_y v \right) +!! \f} +!! which has contributions akin to a negative divergence damping (a divergence +!! enhancement?) but which is weaker than the enhanced tension terms by half. +!! +!! \subsection section_viscous_discretization Discretization +!! +!! The horizontal tension, \f$\dot{e}_T\f$, is stored in variable sh_xx and +!! discretized as +!! \f[ +!! \dot{e}_T +!! = \frac{\Delta y}{\Delta x} \delta_i \left( \frac{1}{\Delta y} u \right) +!! - \frac{\Delta x}{\Delta y} \delta_j \left( \frac{1}{\Delta x} v \right) +!! . +!! \f] +!! The horizontal divergent strain, \f$\dot{e}_D\f$, is stored in variable +!! div_xx and discretized as +!! \f[ +!! \dot{e}_D +!! = \frac{1}{h A} \left( \delta_i \left( \overline{h}^i \Delta y \, u \right) +!! + \delta_j \left( \overline{h}^j\Delta x \, v \right) \right) +!! . +!! \f] +!! Note that for expediency this is the exact discretization used in the +!! continuity equation. +!! +!! The horizontal shear strain, \f$\dot{e}_S\f$, is stored in variable sh_xy +!! and discretized as +!! \f[ +!! \dot{e}_S = v_x + u_y +!! \f] +!! where +!! \f{align*}{ +!! v_x &= \frac{\Delta y}{\Delta x} \delta_i \left( \frac{1}{\Delta y} v \right) \\\\ +!! u_y &= \frac{\Delta x}{\Delta y} \delta_j \left( \frac{1}{\Delta x} u \right) +!! \f} +!! which are calculated separately so that no-slip or free-slip boundary +!! conditions can be applied to \f$v_x\f$ and \f$u_y\f$ where appropriate. +!! +!! The tendency for the x-component of the divergence of stress is stored in +!! variable diffu and discretized as +!! \f[ +!! \hat{\bf x} \cdot \left( \nabla \cdot {\bf \sigma} \right) = +!! \frac{1}{A \overline{h}^i} \left( +!! \frac{1}{\Delta y} \delta_i \left( h \Delta y^2 \kappa_h \dot{e}_T \right) + +!! \frac{1}{\Delta x} \delta_j \left( \tilde{h}^{ij} \Delta x^2 \kappa_h \dot{e}_S \right) +!! \right) +!! . +!! \f] +!! +!! The tendency for the y-component of the divergence of stress is stored in +!! variable diffv and discretized as +!! \f[ +!! \hat{\bf y} \cdot \left( \nabla \cdot {\bf \sigma} \right) = +!! \frac{1}{A \overline{h}^j} \left( +!! \frac{1}{\Delta y} \delta_i \left( \tilde{h}^{ij} \Delta y^2 A_M \dot{e}_S \right) +!! - \frac{1}{\Delta x} \delta_j \left( h \Delta x^2 A_M \dot{e}_T \right) +!! \right) +!! . +!! \f] +!! +!! \subsection section_viscous_refs References +!! +!! Griffies, S.M., and Hallberg, R.W., 2000: Biharmonic friction with a +!! Smagorinsky-like viscosity for use in large-scale eddy-permitting ocean models. +!! Monthly Weather Review, 128(8), 2935-2946. +!! https://doi.org/10.1175/1520-0493(2000)128%3C2935:BFWASL%3E2.0.CO;2 +!! +!! Large, W.G., Danabasoglu, G., McWilliams, J.C., Gent, P.R. and Bryan, F.O., +!! 2001: Equatorial circulation of a global ocean climate model with +!! anisotropic horizontal viscosity. +!! Journal of Physical Oceanography, 31(2), pp.518-536. +!! https://doi.org/10.1175/1520-0485(2001)031%3C0518:ECOAGO%3E2.0.CO;2 +!! +!! Smagorinsky, J., 1993: Some historical remarks on the use of nonlinear +!! viscosities. Large eddy simulation of complex engineering and geophysical +!! flows, 1, 69-106. +!! +!! Smith, R.D., and McWilliams, J.C., 2003: Anisotropic horizontal viscosity for +!! ocean models. Ocean Modelling, 5(2), 129-156. +!! https://doi.org/10.1016/S1463-5003(02)00016-1 +end module MOM_hor_visc diff --git a/parameterizations/lateral/MOM_interface_filter.F90 b/parameterizations/lateral/MOM_interface_filter.F90 new file mode 100644 index 0000000000..07b698e294 --- /dev/null +++ b/parameterizations/lateral/MOM_interface_filter.F90 @@ -0,0 +1,499 @@ +!> Interface height filtering module +module MOM_interface_filter + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : hchksum, uvchksum +use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type +use MOM_domains, only : pass_var, CORNER, pass_vector +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : find_eta +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, cont_diag_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public interface_filter, interface_filter_init, interface_filter_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure for interface height filtering +type, public :: interface_filter_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + real :: max_smoothing_CFL !< Maximum value of the smoothing CFL for interface height filtering [nondim] + real :: filter_rate !< The rate at which grid-scale anomalies are damped away [T-1 ~> s-1] + integer :: filter_order !< The even power of the interface height smoothing. + !! At present valid values are 0, 2, or 4. + logical :: interface_filter !< If true, interfaces heights are diffused. + logical :: isotropic_filter !< If true, use the same filtering lengthscales in both directions, + !! otherwise use filtering lengthscales in each direction that scale + !! with the grid spacing in that direction. + logical :: debug !< write verbose checksums for debugging purposes + + type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics + + !>@{ + !! Diagnostic identifier + integer :: id_uh_sm = -1, id_vh_sm = -1 + integer :: id_L2_u = -1, id_L2_v = -1 + integer :: id_sfn_x = -1, id_sfn_y = -1 + !>@} +end type interface_filter_CS + +contains + +!> Apply a transport that leads to a smoothing of interface height, subject to limits that +!! ensure stability and positive definiteness of layer thicknesses. +!! It also updates the along-layer mass fluxes used in the tracer transport equations. +subroutine interface_filter(h, uhtr, vhtr, tv, dt, G, GV, US, CDp, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [L2 H ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [L2 H ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, intent(in) :: dt !< Time increment [T ~> s] + type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation + type(interface_filter_CS), intent(inout) :: CS !< Control structure for interface height + !! filtering + ! Local variables + real :: e(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Heights of interfaces, relative to mean + ! sea level [Z ~> m], positive up. + real :: de_smooth(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Change in the heights of interfaces after one pass + ! of Laplacian smoothing [Z ~> m], positive downward to avoid + ! having to change other signs in the call to interface_filter. + real :: uhD(SZIB_(G),SZJ_(G),SZK_(GV)) ! Smoothing u*h fluxes within a timestep [L2 H ~> m3 or kg] + real :: vhD(SZI_(G),SZJB_(G),SZK_(GV)) ! Smoothing v*h fluxes within a timestep [L2 H ~> m3 or kg] + + real, dimension(SZIB_(G),SZJ_(G)) :: & + Lsm2_u ! Interface height squared smoothing lengths per timestep at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G)) :: & + Lsm2_v ! Interface height squared smoothing lengths per timestep at v-points [L2 ~> m2] + + real :: diag_sfn_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction + ! [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: diag_sfn_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction + ! [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: filter_strength ! The amount of filtering within a each iteration [nondim] + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + integer :: itt, filter_itts ! The number of iterations of the filter, set as 1/2 the power. + integer :: i, j, k, is, ie, js, je, nz, hs + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_interface_filter: "//& + "Module must be initialized before it is used.") + + if ((.not.CS%interface_filter) .or. (CS%filter_rate <= 0.0) .or. (CS%filter_order < 2)) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + h_neglect = GV%H_subroundoff + + filter_itts = CS%filter_order / 2 + Idt = 1.0 / dt + + if (filter_itts > min(G%isc-G%isd, G%jsc-G%jsd)) call MOM_error(FATAL, & + "interface_filter: The halos are not wide enough to accommodate the filter "//& + "order specified by INTERFACE_FILTER_ORDER.") + + ! Calculates interface heights, e, in [Z ~> m]. + call find_eta(h, tv, G, GV, US, e, halo_size=filter_itts) + + ! Set the smoothing length scales to apply at each iteration. + if (filter_itts == 1) then + filter_strength = min(CS%filter_rate*dt, CS%max_smoothing_CFL) + elseif (filter_itts == 2) then + filter_strength = min(sqrt(CS%filter_rate*dt), CS%max_smoothing_CFL) + else + filter_strength = min((CS%filter_rate*dt)**(1.0/filter_itts), CS%max_smoothing_CFL) + endif + hs = filter_itts-1 + if (CS%isotropic_filter) then + !$OMP parallel do default(shared) + do j=js-hs,je+hs ; do I=is-(hs+1),ie+hs + Lsm2_u(I,j) = (0.25*filter_strength) / (G%IdxCu(I,j)**2 + G%IdyCu(I,j)**2) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-(hs+1),je+hs ; do i=is-hs,ie+hs + Lsm2_v(i,J) = (0.25*filter_strength) / (G%IdxCv(i,J)**2 + G%IdyCv(i,J)**2) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js-hs,je+hs ; do I=is-(hs+1),ie+hs + Lsm2_u(I,j) = (0.125*filter_strength) * (min(G%areaT(i,j), G%areaT(i+1,j)) * G%IdyCu(I,j))**2 + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-(hs+1),je+hs ; do i=is-hs,ie+hs + Lsm2_v(i,J) = (0.125*filter_strength) * (min(G%areaT(i,j), G%areaT(i,j+1)) * G%IdxCv(i,J))**2 + enddo ; enddo + endif + + if (CS%debug) then + call uvchksum("Kh_[uv]", Lsm2_u, Lsm2_v, G%HI, haloshift=hs, & + scale=US%L_to_m**2, scalar_pair=.true.) + call hchksum(h, "interface_filter_1 h", G%HI, haloshift=hs+1, scale=GV%H_to_m) + call hchksum(e, "interface_filter_1 e", G%HI, haloshift=hs+1, scale=US%Z_to_m) + endif + + ! Calculate uhD, vhD from h, e, Lsm2_u, Lsm2_v + call filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_size=filter_itts-1) + + + do itt=2,filter_itts + hs = (filter_itts - itt) + 1 ! Set the halo size to work on. + !$OMP parallel do default(shared) + do j=js-hs,je+hs + do i=is-hs,ie+hs ; de_smooth(i,j,nz+1) = 0.0 ; enddo + + if (allocated(tv%SpV_avg)) then + ! This is the fully non-Boussinesq version. + do k=nz,1,-1 ; do i=is-hs,ie+hs + de_smooth(i,j,K) = de_smooth(i,j,K+1) + (GV%H_to_RZ * tv%SpV_avg(i,j,k)) * G%IareaT(i,j) * & + ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) + enddo ; enddo + else + do k=nz,1,-1 ; do i=is-hs,ie+hs + de_smooth(i,j,K) = de_smooth(i,j,K+1) + GV%H_to_Z * G%IareaT(i,j) * & + ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) + enddo ; enddo + endif + enddo + + ! Calculate uhD, vhD from h, de_smooth, Lsm2_u, Lsm2_v + call filter_interface(h, de_smooth, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_size=filter_itts-itt) + enddo + + ! Offer diagnostic fields for averaging. This must occur before updating the layer thicknesses + ! so that the diagnostics can be remapped properly to other diagnostic vertical coordinates. + if (query_averaging_enabled(CS%diag)) then + if (CS%id_sfn_x > 0) then + diag_sfn_x(:,:,1) = 0.0 ; diag_sfn_x(:,:,nz+1) = 0.0 + do K=nz,2,-1 ; do j=js,je ; do I=is-1,ie + if (CS%id_sfn_x>0) diag_sfn_x(I,j,K) = diag_sfn_x(I,j,K+1) + uhD(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_sfn_x, diag_sfn_x, CS%diag) + endif + if (CS%id_sfn_y > 0) then + diag_sfn_y(:,:,1) = 0.0 ; diag_sfn_y(:,:,nz+1) = 0.0 + do K=nz,2,-1 ; do J=js-1,je ; do i=is,ie + diag_sfn_y(i,J,K) = diag_sfn_y(i,J,K+1) + vhD(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_sfn_y, diag_sfn_y, CS%diag) + endif + if (CS%id_uh_sm > 0) call post_data(CS%id_uh_sm, Idt*uhD(:,:,:), CS%diag) + if (CS%id_vh_sm > 0) call post_data(CS%id_vh_sm, Idt*vhD(:,:,:), CS%diag) + if (CS%id_L2_u > 0) call post_data(CS%id_L2_u, Lsm2_u, CS%diag) + if (CS%id_L2_v > 0) call post_data(CS%id_L2_v, Lsm2_v, CS%diag) + endif + + ! Update the layer thicknesses, and store the transports that will be needed for the tracers. + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=is-1,ie + uhtr(I,j,k) = uhtr(I,j,k) + uhD(I,j,k) + enddo ; enddo + do J=js-1,je ; do i=is,ie + vhtr(i,J,k) = vhtr(i,J,k) + vhD(i,J,k) + enddo ; enddo + do j=js,je ; do i=is,ie + h(i,j,k) = h(i,j,k) - G%IareaT(i,j) * & + ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) + if (h(i,j,k) < GV%Angstrom_H) h(i,j,k) = GV%Angstrom_H + enddo ; enddo + + ! Store the transports associated with the smoothing if they are needed for diagnostics. + if (associated(CDp%uh_smooth)) then ; do j=js,je ; do I=is-1,ie + CDp%uh_smooth(I,j,k) = uhD(I,j,k)*Idt + enddo ; enddo ; endif + if (associated(CDp%vh_smooth)) then ; do J=js-1,je ; do i=is,ie + CDp%vh_smooth(i,J,k) = vhD(i,J,k)*Idt + enddo ; enddo ; endif + + enddo + + if (CS%debug) then + call uvchksum("interface_filter [uv]hD", uhD, vhD, & + G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2) + call uvchksum("interface_filter [uv]htr", uhtr, vhtr, & + G%HI, haloshift=0, scale=US%L_to_m**2*GV%H_to_m) + call hchksum(h, "interface_filter h", G%HI, haloshift=0, scale=GV%H_to_m) + endif + +end subroutine interface_filter + +!> Calculates parameterized layer transports for use in the continuity equation. +!! Fluxes are limited to give positive definite thicknesses. +!! Called by interface_filter(). +subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_size) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface positions [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Lsm2_u !< Interface smoothing lengths squared + !! at u points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Lsm2_v !< Interface smoothing lengths squared + !! at v points [L2 ~> m2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: uhD !< Zonal mass fluxes + !! [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: vhD !< Meridional mass fluxes + !! [H L2 ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + integer, optional, intent(in) :: halo_size !< The size of the halo to work on, + !! 0 by default. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + h_avail ! The mass available for diffusion out of each face [H L2 ~> m3 or kg]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + h_avail_rsum ! The running sum of h_avail above an interface [H L2 ~> m3 or kg]. + real :: uhtot(SZIB_(G),SZJ_(G)) ! The vertical sum of uhD [H L2 ~> m3 or kg]. + real :: vhtot(SZI_(G),SZJB_(G)) ! The vertical sum of vhD [H L2 ~> m3 or kg]. + real :: Slope ! The slope of density surfaces, calculated in a way that is always + ! between -1 and 1 after undoing dimensional scaling, [Z L-1 ~> nondim] + real :: Sfn_est ! A preliminary estimate (before limiting) of the overturning + ! streamfunction [H L2 ~> m3 or kg]. + real :: Sfn ! The overturning streamfunction [H L2 ~> m3 or kg]. + real :: Rho_avg ! The in situ density averaged to an interface [R ~> kg m-3] + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: hn_2 ! Half of h_neglect [H ~> m or kg m-2]. + integer :: i, j, k, is, ie, js, je, nz, hs + + hs = 0 ; if (present(halo_size)) hs = halo_size + is = G%isc-hs ; ie = G%iec+hs ; js = G%jsc-hs ; je = G%jec+hs ; nz = GV%ke + + h_neglect = GV%H_subroundoff ; hn_2 = 0.5*h_neglect + + ! Find the maximum and minimum permitted streamfunction. + !$OMP parallel do default(shared) + do j=js-1,je+1 + do i=is-1,ie+1 + h_avail_rsum(i,j,1) = 0.0 + h_avail(i,j,1) = max(0.25*G%areaT(i,j)*(h(i,j,1)-GV%Angstrom_H),0.0) + h_avail_rsum(i,j,2) = h_avail(i,j,1) + enddo + do k=2,nz ; do i=is-1,ie+1 + h_avail(i,j,k) = max(0.25*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + h_avail_rsum(i,j,k+1) = h_avail_rsum(i,j,k) + h_avail(i,j,k) + enddo ; enddo + enddo + + !$OMP parallel do default(shared) private(Slope,Sfn_est,Sfn) + do j=js,je + do I=is-1,ie ; uhtot(I,j) = 0.0 ; enddo + do K=nz,2,-1 + do I=is-1,ie + Slope = ((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) * G%OBCmaskCu(I,j) + + if (allocated(tv%SpV_avg)) then + ! This is the fully non-Boussinesq version. + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i+1,j,k) + h(i+1,j,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i+1,j,k)+hn_2)*tv%SpV_avg(i+1,j,k) + (h(i+1,j,k-1)+hn_2)*tv%SpV_avg(i+1,j,k-1)) ) + Sfn_est = (Lsm2_u(I,j)*G%dy_Cu(I,j)) * (GV%RZ_to_H * Slope) * Rho_avg + else + Sfn_est = (Lsm2_u(I,j)*G%dy_Cu(I,j)) * (GV%Z_to_H * Slope) + endif + + ! Make sure that there is enough mass above to allow the streamfunction + ! to satisfy the boundary condition of 0 at the surface. + Sfn = min(max(Sfn_est, -h_avail_rsum(i,j,K)), h_avail_rsum(i+1,j,K)) + + ! The actual transport is limited by the mass available in the two + ! neighboring grid cells. + uhD(I,j,k) = max(min((Sfn - uhtot(I,j)), h_avail(i,j,k)), & + -h_avail(i+1,j,k)) + + ! sfn_x(I,j,K) = max(min(Sfn, uhtot(I,j)+h_avail(i,j,k)), & + ! uhtot(I,j)-h_avail(i+1,j,K)) + + uhtot(I,j) = uhtot(I,j) + uhD(I,j,k) + + enddo + enddo ! end of k-loop + + ! In layer 1, enforce the boundary conditions that Sfn(z=0) = 0.0 + do I=is-1,ie ; uhD(I,j,1) = -uhtot(I,j) ; enddo + enddo ! end of j-loop + + ! Calculate the meridional fluxes and gradients. + + !$OMP parallel do default(shared) private(Slope,Sfn_est,Sfn) + do J=js-1,je + do i=is,ie ; vhtot(i,J) = 0.0 ; enddo + do K=nz,2,-1 + do i=is,ie + Slope = ((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) * G%OBCmaskCv(i,J) + + if (allocated(tv%SpV_avg)) then + ! This is the fully non-Boussinesq version. + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i,j+1,k) + h(i,j+1,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i,j+1,k)+hn_2)*tv%SpV_avg(i,j+1,k) + (h(i,j+1,k-1)+hn_2)*tv%SpV_avg(i,j+1,k-1)) ) + Sfn_est = (Lsm2_v(i,J)*G%dx_Cv(i,J)) * (GV%RZ_to_H * Slope) * Rho_avg + else + Sfn_est = (Lsm2_v(i,J)*G%dx_Cv(i,J)) * (GV%Z_to_H * Slope) + endif + + ! Make sure that there is enough mass above to allow the streamfunction + ! to satisfy the boundary condition of 0 at the surface. + Sfn = min(max(Sfn_est, -h_avail_rsum(i,j,K)), h_avail_rsum(i,j+1,K)) + + ! The actual transport is limited by the mass available in the two neighboring grid cells. + vhD(i,J,k) = max(min((Sfn - vhtot(i,J)), h_avail(i,j,k)), -h_avail(i,j+1,k)) + + ! sfn_y(i,J,K) = max(min(Sfn, vhtot(i,J)+h_avail(i,j,k)), & + ! vhtot(i,J)-h_avail(i,j+1,k)) + + vhtot(i,J) = vhtot(i,J) + vhD(i,J,k) + + enddo + enddo ! end of k-loop + ! In layer 1, enforce the boundary conditions that Sfn(z=0) = 0.0 + do i=is,ie ; vhD(i,J,1) = -vhtot(i,J) ; enddo + enddo ! end of j-loop + +end subroutine filter_interface + +!> Initialize the interface height filtering module/structure +subroutine interface_filter_init(Time, G, GV, US, param_file, diag, CDp, CS) + type(time_type), intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handles + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation diagnostics + type(interface_filter_CS), intent(inout) :: CS !< Control structure for interface height filtering + + ! Local variables + character(len=40) :: mdl = "MOM_interface_filter" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + real :: grid_sp ! The local grid spacing [L ~> m] + real :: interface_filter_time ! The grid-scale interface height filtering timescale [T ~> s] + integer :: i, j + + CS%initialized = .true. + CS%diag => diag + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "INTERFACE_FILTER_TIME", interface_filter_time, & + "If positive, interface heights are subjected to a grid-scale "//& + "dependent biharmonic filter, using a rate based on this timescale.", & + default=0.0, units="s", scale=US%s_to_T) + CS%filter_rate = 0.0 + if (interface_filter_time > 0.0) CS%filter_rate = 1.0 / interface_filter_time + CS%interface_filter = (interface_filter_time > 0.0) + call get_param(param_file, mdl, "INTERFACE_FILTER_MAX_CFL", CS%max_smoothing_CFL, & + "The maximum value of the local CFL ratio that "//& + "is permitted for the interface height smoothing. 1.0 is the "//& + "marginally unstable value.", units="nondimensional", default=0.8) + if (CS%max_smoothing_CFL < 0.0) CS%max_smoothing_CFL = 0.0 + + call get_param(param_file, mdl, "INTERFACE_FILTER_ORDER", CS%filter_order, & + "The even power of the interface height smoothing. "//& + "At present valid values are 0, 2, 4 or 6.", default=4) + if (CS%filter_order == 0) then + CS%filter_rate = 0.0 + elseif ((CS%filter_order /= 2) .and. (CS%filter_order /= 4) .and. (CS%filter_order /= 6)) then + call MOM_error(FATAL, "Unsupported value of INTERFACE_FILTER_ORDER specified. "//& + "Only 0, 2, 4 or 6 are supported.") + endif + call get_param(param_file, mdl, "INTERFACE_FILTER_ISOTROPIC", CS%isotropic_filter, & + "If true, use the same filtering lengthscales in both directions; "//& + "otherwise use filtering lengthscales in each direction that scale "//& + "with the grid spacing in that direction.", default=.true.) + + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + + if (CS%filter_order > 0) then + CS%id_uh_sm = register_diag_field('ocean_model', 'uh_smooth', diag%axesCuL, Time, & + 'Interface Smoothing Zonal Thickness Flux', & + 'kg s-1', conversion=GV%H_to_kg_m2*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) + CS%id_vh_sm = register_diag_field('ocean_model', 'vh_smooth', diag%axesCvL, Time, & + 'Interface Smoothing Meridional Thickness Flux', & + 'kg s-1', conversion=GV%H_to_kg_m2*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) + + CS%id_L2_u = register_diag_field('ocean_model', 'Lsmooth2_u', diag%axesCu1, Time, & + 'Interface height smoothing length-scale squared at U-points', & + 'm2', conversion=US%L_to_m**2) + CS%id_L2_v = register_diag_field('ocean_model', 'Lsmooth2_u', diag%axesCv1, Time, & + 'Interface height smoothing length-scale squared at V-points', & + 'm2', conversion=US%L_to_m**2) + + CS%id_sfn_x = register_diag_field('ocean_model', 'Smooth_sfn_x', diag%axesCui, Time, & + 'Interface smoothing Zonal Overturning Streamfunction', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) + CS%id_sfn_y = register_diag_field('ocean_model', 'Smooth_sfn_y', diag%axesCvi, Time, & + 'Interface smoothing Meridional Overturning Streamfunction', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) + endif + +end subroutine interface_filter_init + +!> Deallocate the interface height filtering control structure +subroutine interface_filter_end(CS, CDp) + type(interface_filter_CS), intent(inout) :: CS !< Control structure for interface height filtering + type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity diagnostic control structure + + ! NOTE: [uv]h_smooth are not yet used in diagnostics, but they are here for now for completeness. + if (associated(CDp%uh_smooth)) deallocate(CDp%uh_smooth) + if (associated(CDp%vh_smooth)) deallocate(CDp%vh_smooth) + +end subroutine interface_filter_end + +!> \namespace mom_interface_filter +!! +!! \section section_interface_filter Interface height filtering +!! +!! Interface height filtering is implemented via along-layer mass fluxes +!! \f[ +!! h^\dagger \leftarrow h^n - \Delta t \nabla \cdot ( \vec{uh}^* ) +!! \f] +!! where the mass fluxes are cast as the difference in vector streamfunction +!! +!! \f[ +!! \vec{uh}^* = \delta_k \vec{\psi} . +!! \f] +!! +!! The streamfunction is proportional to the slope in the difference between +!! unsmoothed interface heights and those smoothed with one (or more) passes of a Laplacian +!! filter, depending on the order of the filter, or to the slope for a Laplacian +!! filter +!! \f[ +!! \vec{\psi} = - \kappa_h {\nabla \eta - \eta_smooth} +!! \f] +!! +!! The result of the above expression is subsequently bounded by minimum and maximum values, including a +!! maximum smoothing rate for numerical stability (\f$ \kappa_{h} \f$ is calculated internally). +!! +!! \subsection section_filter_module_parameters Module mom_interface_filter parameters +!! +!! | Symbol | Module parameter | +!! | ------ | --------------- | +!! | - | APPLY_INTERFACE_FILTER | +!! | - | INTERFACE_FILTER_TIME | +!! | - | INTERFACE_FILTER_MAX_CFL | +!! | - | INTERFACE_FILTER_ORDER | +!! + +end module MOM_interface_filter diff --git a/parameterizations/lateral/MOM_internal_tides.F90 b/parameterizations/lateral/MOM_internal_tides.F90 new file mode 100644 index 0000000000..a8b0d3f813 --- /dev/null +++ b/parameterizations/lateral/MOM_internal_tides.F90 @@ -0,0 +1,3126 @@ +!> Subroutines that use the ray-tracing equations to propagate the internal tide energy density. +!! +!! \author Benjamin Mater & Robert Hallberg, 2015 +module MOM_internal_tides + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : is_NaN +use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_axis_init +use MOM_diag_mediator, only : disable_averaging, enable_averages +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr +use MOM_diag_mediator, only : axes_grp, define_axes_group +use MOM_domains, only : AGRID, To_South, To_West, To_All +use MOM_domains, only : create_group_pass, do_group_pass, pass_var +use MOM_domains, only : group_pass_type, start_group_pass, complete_group_pass +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_int_tide_input, only: int_tide_input_CS, get_input_TKE, get_barotropic_tidal_vel +use MOM_io, only : slasher, MOM_read_data, file_exists, axis_info +use MOM_io, only : set_axis_info, get_axis_info +use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart +use MOM_restart, only : lock_check, restart_registry_lock +use MOM_spatial_means, only : global_area_integral +use MOM_string_functions, only: extract_real +use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_wave_speed, only : wave_speeds, wave_speed_CS, wave_speed_init + +implicit none ; private + +#include + +public propagate_int_tide, register_int_tide_restarts +public internal_tides_init, internal_tides_end +public get_lowmode_loss + +!> This control structure has parameters for the MOM_internal_tides module +type, public :: int_tide_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: do_int_tides !< If true, use the internal tide code. + integer :: nFreq = 0 !< The number of internal tide frequency bands + integer :: nMode = 1 !< The number of internal tide vertical modes + integer :: nAngle = 24 !< The number of internal tide angular orientations + integer :: energized_angle = -1 !< If positive, only this angular band is energized for debugging purposes + real :: uniform_test_cg !< Uniform group velocity of internal tide + !! for testing internal tides [L T-1 ~> m s-1] + logical :: corner_adv !< If true, use a corner advection rather than PPM. + logical :: upwind_1st !< If true, use a first-order upwind scheme. + logical :: simple_2nd !< If true, use a simple second order (arithmetic mean) interpolation + !! of the edge values instead of the higher order interpolation. + logical :: vol_CFL !< If true, use the ratio of the open face lengths to the tracer cell + !! areas when estimating CFL numbers. Without aggress_adjust, + !! the default is false; it is always true with aggress_adjust. + logical :: use_PPMang !< If true, use PPM for advection of energy in angular space. + + real, allocatable, dimension(:,:) :: fraction_tidal_input + !< how the energy from one tidal component is distributed + !! over the various vertical modes, 2d in frequency and mode [nondim] + real, allocatable, dimension(:,:) :: refl_angle + !< local coastline/ridge/shelf angles read from file [rad] + ! (could be in G control structure) + real :: nullangle = -999.9 !< placeholder value in cells with no reflection [rad] + real, allocatable, dimension(:,:) :: refl_pref + !< partial reflection coeff for each "coast cell" [nondim] + ! (could be in G control structure) + logical, allocatable, dimension(:,:) :: refl_pref_logical + !< true if reflecting cell with partial reflection + ! (could be in G control structure) + logical, allocatable, dimension(:,:) :: refl_dbl + !< identifies reflection cells where double reflection + !! is possible (i.e. ridge cells) + ! (could be in G control structure) + real, allocatable, dimension(:,:) :: trans + !< partial transmission coeff for each "coast cell" [nondim] + real, allocatable, dimension(:,:) :: residual + !< residual of reflection and transmission coeff for each "coast cell" [nondim] + real, allocatable, dimension(:,:,:,:) :: cp + !< horizontal phase speed [L T-1 ~> m s-1] + real, allocatable, dimension(:,:,:,:,:) :: TKE_leak_loss + !< energy lost due to misc background processes [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:,:,:,:) :: TKE_quad_loss + !< energy lost due to quadratic bottom drag [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:,:,:,:) :: TKE_Froude_loss + !< energy lost due to wave breaking [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:) :: TKE_itidal_loss_fixed + !< Fixed part of the energy lost due to small-scale drag [R Z3 L-2 ~> kg m-2] here; + !! This will be multiplied by N and the squared near-bottom velocity (and by + !! the near-bottom density in non-Boussinesq mode) to get the energy losses + !! in [R Z4 H-1 L-2 ~> kg m-2 or m] + real, allocatable, dimension(:,:,:,:,:) :: TKE_itidal_loss + !< energy lost due to small-scale wave drag [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:,:,:,:) :: TKE_residual_loss + !< internal tide energy loss due to the residual at slopes [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:) :: tot_leak_loss !< Energy loss rates due to misc background processes, + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:) :: tot_quad_loss !< Energy loss rates due to quadratic bottom drag, + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:) :: tot_itidal_loss !< Energy loss rates due to small-scale drag, + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:) :: tot_Froude_loss !< Energy loss rates due to wave breaking, + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:) :: tot_residual_loss !< Energy loss rates due to residual on slopes, + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:) :: tot_allprocesses_loss !< Energy loss rates due to all processes, + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:,:,:) :: w_struct !< Vertical structure of vertical velocity (normalized) + !! for each frequency and each mode [nondim] + real, allocatable, dimension(:,:,:,:) :: u_struct !< Vertical structure of horizontal velocity (normalized and + !! divided by layer thicknesses) for each frequency and each mode [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:) :: u_struct_max !< Maximum of u_struct, + !! for each mode [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:) :: u_struct_bot !< Bottom value of u_struct, + !! for each mode [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:) :: int_w2 !< Vertical integral of w_struct squared, + !! for each mode [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: int_U2 !< Vertical integral of u_struct squared, + !! for each mode [H Z-2 ~> m-1 or kg m-4] + real, allocatable, dimension(:,:,:) :: int_N2w2 !< Depth-integrated Brunt Vaissalla freqency times + !! vertical profile squared, for each mode [H T-2 ~> m s-2 or kg m-2 s-2] + real :: q_itides !< fraction of local dissipation [nondim] + real :: En_sum !< global sum of energy for use in debugging, in MKS units [J] + type(time_type), pointer :: Time => NULL() !< A pointer to the model's clock. + character(len=200) :: inputdir !< directory to look for coastline angle file + real :: decay_rate !< A constant rate at which internal tide energy is + !! lost to the interior ocean internal wave field [T-1 ~> s-1]. + real :: cdrag !< The bottom drag coefficient [nondim]. + real :: drag_min_depth !< The minimum total ocean thickness that will be used in the denominator + !! of the quadratic drag terms for internal tides when + !! INTERNAL_TIDE_QUAD_DRAG is true [H ~> m or kg m-2] + logical :: apply_background_drag + !< If true, apply a drag due to background processes as a sink. + logical :: apply_bottom_drag + !< If true, apply a quadratic bottom drag as a sink. + logical :: apply_wave_drag + !< If true, apply scattering due to small-scale roughness as a sink. + logical :: apply_Froude_drag + !< If true, apply wave breaking as a sink. + real :: En_check_tol !< An energy density tolerance for flagging points with an imbalance in the + !! internal tide energy budget when apply_Froude_drag is True [R Z3 T-2 ~> J m-2] + logical :: apply_residual_drag + !< If true, apply sink from residual term of reflection/transmission. + real, allocatable :: En(:,:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,frequency,mode) + !! integrated within an angular and frequency band [R Z3 T-2 ~> J m-2] + real, allocatable :: En_restart_mode1(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 1 + real, allocatable :: En_restart_mode2(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 2 + real, allocatable :: En_restart_mode3(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 3 + real, allocatable :: En_restart_mode4(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 4 + real, allocatable :: En_restart_mode5(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 5 + + real, allocatable, dimension(:) :: frequency !< The frequency of each band [T-1 ~> s-1]. + + type(wave_speed_CS) :: wave_speed !< Wave speed control structure + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the + !! timing of diagnostic output. + + !>@{ Diag handles + ! Diag handles relevant to all modes, frequencies, and angles + integer :: id_cg1 = -1 ! diagnostic handle for mode-1 speed + integer, allocatable, dimension(:) :: id_cn ! diagnostic handle for all mode speeds + integer :: id_tot_En = -1 + integer :: id_refl_pref = -1, id_refl_ang = -1, id_land_mask = -1 + integer :: id_trans = -1, id_residual = -1 + integer :: id_dx_Cv = -1, id_dy_Cu = -1 + ! Diag handles considering: sums over all modes, frequencies, and angles + integer :: id_tot_leak_loss = -1, id_tot_quad_loss = -1, id_tot_itidal_loss = -1 + integer :: id_tot_Froude_loss = -1, id_tot_residual_loss = -1, id_tot_allprocesses_loss = -1 + ! Diag handles considering: all modes & frequencies; summed over angles + integer, allocatable, dimension(:,:) :: & + id_En_mode, & + id_itidal_loss_mode, & + id_leak_loss_mode, & + id_quad_loss_mode, & + id_Froude_loss_mode, & + id_residual_loss_mode, & + id_allprocesses_loss_mode, & + id_itide_drag, & + id_Ub_mode, & + id_cp_mode + ! Diag handles considering: all modes, frequencies, and angles + integer, allocatable, dimension(:,:) :: & + id_En_ang_mode, & + id_itidal_loss_ang_mode + integer, allocatable, dimension(:) :: & + id_TKE_itidal_input, & + id_Ustruct_mode, & + id_Wstruct_mode, & + id_int_w2_mode, & + id_int_U2_mode, & + id_int_N2w2_mode + !>@} + +end type int_tide_CS + +!> A structure with the active energy loop bounds. +type :: loop_bounds_type ; private + !>@{ The active loop bounds + integer :: ish, ieh, jsh, jeh + !>@} +end type loop_bounds_type + +contains + +!> Calls subroutines in this file that are needed to refract, propagate, +!! and dissipate energy density of the internal tide. +subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_CSp, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Pointer to thermodynamic variables + !! (needed for wave structure). + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Nb !< Near-bottom buoyancy frequency [T-1 ~> s-1]. + !! In some cases the input values are used, but in + !! others this is set along with the wave speeds. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Rho_bot !< Near-bottom density or the Boussinesq + !! reference density [R ~> kg m-3]. + real, intent(in) :: dt !< Length of time over which to advance + !! the internal tides [T ~> s]. + type(int_tide_input_CS), intent(in) :: inttide_input_CSp !< Internal tide input control structure + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),CS%nFreq) :: & + TKE_itidal_input, & !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. + + real, dimension(SZI_(G),SZJ_(G),2) :: & + test ! A test unit vector used to determine grid rotation in halos [nondim] + real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & + cn ! baroclinic internal gravity wave speeds for each mode [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & + tot_En_mode, & ! energy summed over angles only [R Z3 T-2 ~> J m-2] + Ub, & ! near-bottom horizontal velocity of wave (modal) [L T-1 ~> m s-1] + Umax ! Maximum horizontal velocity of wave (modal) [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & + drag_scale ! bottom drag scale [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G)) :: & + tot_vel_btTide2, & + tot_En, & ! energy summed over angles, modes, frequencies [R Z3 T-2 ~> J m-2] + tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_residual_loss, tot_allprocesses_loss, & + ! energy loss rates summed over angle, freq, and mode [R Z3 T-3 ~> W m-2] + htot, & ! The vertical sum of the layer thicknesses [H ~> m or kg m-2] + itidal_loss_mode, & ! Energy lost due to small-scale wave drag, summed over angles [R Z3 T-3 ~> W m-2] + leak_loss_mode, & + quad_loss_mode, & + Froude_loss_mode, & + residual_loss_mode, & + allprocesses_loss_mode ! Total energy loss rates for a given mode and frequency (summed over + ! all angles) [R Z3 T-3 ~> W m-2] + + real :: frac_per_sector ! The inverse of the number of angular, modal and frequency bins [nondim] + real :: f2 ! The squared Coriolis parameter interpolated to a tracer point [T-2 ~> s-2] + real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] + real :: I_D_here ! The inverse of the local water column thickness [H-1 ~> m-1 or m2 kg-1] + real :: I_mass ! The inverse of the local water mass [R-1 Z-1 ~> m2 kg-1] + real :: freq2 ! The frequency squared [T-2 ~> s-2] + real :: PE_term ! total potential energy of profile [R Z ~> kg m-2] + real :: KE_term ! total kinetic energy of profile [R Z ~> kg m-2] + real :: U_mag ! rescaled magnitude of horizontal profile [L Z T-1 ~> m2 s-1] + real :: W0 ! rescaled magnitude of vertical profile [Z T-1 ~> m s-1] + real :: c_phase ! The phase speed [L T-1 ~> m s-1] + real :: loss_rate ! An energy loss rate [T-1 ~> s-1] + real :: Fr2_max ! The column maximum internal wave Froude number squared [nondim] + real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] + real :: en_subRO ! A tiny energy to prevent division by zero [R Z3 T-2 ~> J m-2] + real :: En_new, En_check ! Energies for debugging [R Z3 T-2 ~> J m-2] + real :: En_initial, Delta_E_check ! Energies for debugging [R Z3 T-2 ~> J m-2] + real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [R Z3 T-3 ~> W m-2] + character(len=160) :: mesg ! The text of an error message + integer :: En_halo_ij_stencil ! The halo size needed for energy advection + integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle + integer :: id_g, jd_g ! global (decomp-invar) indices (for debugging) + type(group_pass_type), save :: pass_test, pass_En + type(time_type) :: time_end + logical:: avg_enabled + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nAngle = CS%NAngle + + cn_subRO = 1e-30*US%m_s_to_L_T + en_subRO = 1e-30*US%W_m2_to_RZ3_T3*US%s_to_T + + ! initialize local arrays + TKE_itidal_input(:,:,:) = 0. + vel_btTide(:,:,:) = 0. + tot_vel_btTide2(:,:) = 0. + drag_scale(:,:,:,:) = 0. + Ub(:,:,:,:) = 0. + Umax(:,:,:,:) = 0. + + cn(:,:,:) = 0. + + ! Rebuild energy density array from multiple restarts + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + if (CS%nMode >= 2) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 3) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 4) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 5) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + endif + + ! Set properties related to the internal tides, such as the wave speeds, storing some + ! of them in the control structure for this module. + if (CS%uniform_test_cg > 0.0) then + do m=1,CS%nMode ; cn(:,:,m) = CS%uniform_test_cg ; enddo + else + call wave_speeds(h, tv, G, GV, US, CS%nMode, cn, CS%wave_speed, & + CS%w_struct, CS%u_struct, CS%u_struct_max, CS%u_struct_bot, & + Nb, CS%int_w2, CS%int_U2, CS%int_N2w2, halo_size=2) + ! The value of halo_size above would have to be larger if there were + ! not a halo update between the calls to propagate_x and propagate_y. + ! It can be 1 point smaller if teleport is not used. + endif + + ! Set the wave speeds for the modes, using cg(n) ~ cg(1)/n.********************** + ! This is wrong, of course, but it works reasonably in some cases. + ! Uncomment if wave_speed is not used to calculate the true values (BDM). + !do m=1,CS%nMode ; do j=js-2,je+2 ; do i=is-2,ie+2 + ! cn(i,j,m) = cn(i,j,1) / real(m) + !enddo ; enddo ; enddo + + ! Add the forcing.*************************************************************** + + call get_input_TKE(G, TKE_itidal_input, CS%nFreq, inttide_input_CSp) + + if (CS%energized_angle <= 0) then + frac_per_sector = 1.0 / real(CS%nAngle) + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) + if (CS%frequency(fr)**2 > f2) & + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) + enddo ; enddo ; enddo ; enddo ; enddo + elseif (CS%energized_angle <= CS%nAngle) then + frac_per_sector = 1.0 + a = CS%energized_angle + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie + f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) + if (CS%frequency(fr)**2 > f2) & + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) + enddo ; enddo ; enddo ; enddo + else + call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& + "band that does not exist.") + endif + + ! Pass a test vector to check for grid rotation in the halo updates. + do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 1.0 ; test(i,j,2) = 0.0 ; enddo ; enddo + do m=1,CS%nMode ; do fr=1,CS%nFreq + call create_group_pass(pass_En, CS%En(:,:,:,fr,m), G%domain) + enddo ; enddo + call create_group_pass(pass_test, test(:,:,1), test(:,:,2), G%domain, stagger=AGRID) + call start_group_pass(pass_test, G%domain) + + ! Apply half the refraction. + do m=1,CS%nMode ; do fr=1,CS%nFreq + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & + G, US, CS%nAngle, CS%use_PPMang) + enddo ; enddo + ! A this point, CS%En is only valid on the computational domain. + + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + CS%En(i,j,a,fr,m) = 0.0 +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + + call do_group_pass(pass_En, G%domain) + + call complete_group_pass(pass_test, G%domain) + + ! Set the halo size to work on, using similar logic to that used in propagate. This may need + ! to be adjusted depending on the advection scheme and whether teleport is used. + if (CS%upwind_1st) then ; En_halo_ij_stencil = 2 + else ; En_halo_ij_stencil = 3 ; endif + + ! Rotate points in the halos as necessary. + call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) + + ! Propagate the waves. + do m=1,CS%nMode ; do fr=1,CS%Nfreq + + ! initialize residual loss, will be computed in propagate + CS%TKE_residual_loss(:,:,:,fr,m) = 0. + + call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & + G, US, CS, CS%NAngle, CS%TKE_residual_loss(:,:,:,fr,m)) + enddo ; enddo + + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset + if (abs(CS%En(i,j,a,fr,m))>1.0) then ! only print if large + write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + + ! Apply the other half of the refraction. + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & + G, US, CS%NAngle, CS%use_PPMang) + enddo ; enddo + ! A this point, CS%En is only valid on the computational domain. + + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + CS%En(i,j,a,fr,m) = 0.0 +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + + ! Apply various dissipation mechanisms. + if (CS%apply_background_drag .or. CS%apply_bottom_drag & + .or. CS%apply_wave_drag .or. CS%apply_Froude_drag & + .or. (CS%id_tot_En > 0)) then + tot_En(:,:) = 0.0 + tot_En_mode(:,:,:,:) = 0.0 + do m=1,CS%nMode ; do fr=1,CS%Nfreq + do j=js,je ; do i=is,ie ; do a=1,CS%nAngle + tot_En(i,j) = tot_En(i,j) + CS%En(i,j,a,fr,m) + tot_En_mode(i,j,fr,m) = tot_En_mode(i,j,fr,m) + CS%En(i,j,a,fr,m) + enddo ; enddo ; enddo + enddo ; enddo + endif + + ! Extract the energy for mixing due to misc. processes (background leakage)------ + if (CS%apply_background_drag) then + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale + ! to each En component (technically not correct; fix later) + CS%TKE_leak_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * CS%decay_rate ! loss rate [R Z3 T-3 ~> W m-2] + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%decay_rate) ! implicit update + enddo ; enddo ; enddo ; enddo ; enddo + endif + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After leak loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + CS%En(i,j,a,fr,m) = 0.0 +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + + ! Extract the energy for mixing due to bottom drag------------------------------- + if (CS%apply_bottom_drag) then + do j=jsd,jed ; do i=isd,ied ; htot(i,j) = 0.0 ; enddo ; enddo + + call get_barotropic_tidal_vel(G, vel_btTide, CS%nFreq, inttide_input_CSp) + + do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied + tot_vel_btTide2(i,j) = tot_vel_btTide2(i,j) + vel_btTide(i,j,fr)**2 + enddo ; enddo ; enddo + + do k=1,GV%ke ; do j=jsd,jed ; do i=isd,ied + htot(i,j) = htot(i,j) + h(i,j,k) + enddo ; enddo ; enddo + if (GV%Boussinesq) then + ! This is mathematically equivalent to the form in the option below, but they differ at roundoff. + do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied + I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) + drag_scale(i,j,fr,m) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & + tot_En_mode(i,j,fr,m) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here + enddo ; enddo ; enddo ; enddo + else + do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied + I_mass = GV%RZ_to_H / (max(htot(i,j), CS%drag_min_depth)) + drag_scale(i,j,fr,m) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & + sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & + tot_En_mode(i,j,fr,m) * I_mass)) + enddo ; enddo ; enddo ; enddo + endif + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale + ! to each En component (technically not correct; fix later) + CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j,fr,m) ! loss rate + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * drag_scale(i,j,fr,m)) ! implicit update + enddo ; enddo ; enddo ; enddo ; enddo + endif + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After bottom loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + CS%En(i,j,a,fr,m) = 0.0 +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + !stop + endif + enddo ; enddo + enddo ; enddo ; enddo + + ! Extract the energy for mixing due to scattering (wave-drag)-------------------- + ! still need to allow a portion of the extracted energy to go to higher modes. + ! First, find velocity profiles + if (CS%apply_wave_drag .or. CS%apply_Froude_drag) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + + ! compute near-bottom and max horizontal baroclinic velocity values at each point + do j=js,je ; do i=is,ie + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + + ! Calculate wavenumber magnitude + freq2 = CS%frequency(fr)**2 + + f2 = (0.25*(G%CoriolisBu(I,J) + G%CoriolisBu(max(I-1,1),max(J-1,1)) + & + G%CoriolisBu(I,max(J-1,1)) + G%CoriolisBu(max(I-1,1),J)))**2 + Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2) + + + ! Back-calculate amplitude from energy equation + if ( (G%mask2dT(i,j) > 0.5) .and. (freq2*Kmag2 > 0.0)) then + ! Units here are [R Z ~> kg m-2] + KE_term = 0.25*GV%H_to_RZ*( ((freq2 + f2) / (freq2*Kmag2))*US%L_to_Z**2*CS%int_U2(i,j,m) + & + CS%int_w2(i,j,m) ) + PE_term = 0.25*GV%H_to_RZ*( CS%int_N2w2(i,j,m) / freq2 ) + + if (KE_term + PE_term > 0.0) then + W0 = sqrt( tot_En_mode(i,j,fr,m) / (KE_term + PE_term) ) + else + !call MOM_error(WARNING, "MOM internal tides: KE + PE <= 0.0; setting to W0 to 0.0") + W0 = 0.0 + endif + + U_mag = W0 * sqrt((freq2 + f2) / (2.0*freq2*Kmag2)) + ! scaled maximum tidal velocity + Umax(i,j,fr,m) = abs(U_mag * CS%u_struct_max(i,j,m)) + ! scaled bottom tidal velocity + Ub(i,j,fr,m) = abs(U_mag * CS%u_struct_bot(i,j,m)) + else + Umax(i,j,fr,m) = 0. + Ub(i,j,fr,m) = 0. + endif + + enddo ; enddo ! i-loop, j-loop + enddo ; enddo ! fr-loop, m-loop + endif ! apply_wave or _Froude_drag (Ub or Umax needed) + ! Finally, apply loss + if (CS%apply_wave_drag) then + ! Calculate loss rate and apply loss over the time step + call itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, CS%En, CS%TKE_itidal_loss_fixed, & + CS%TKE_itidal_loss, dt, halo_size=0) + endif + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After wave drag loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + CS%En(i,j,a,fr,m) = 0.0 +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + + ! Extract the energy for mixing due to wave breaking----------------------------- + if (CS%apply_Froude_drag) then + ! Pick out maximum baroclinic velocity values; calculate Fr=max(u)/cg + do m=1,CS%nMode ; do fr=1,CS%Nfreq + freq2 = CS%frequency(fr)**2 + do j=js,je ; do i=is,ie + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + ! Calculate horizontal phase velocity magnitudes + f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) + Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2) + c_phase = 0.0 + if (Kmag2 > 0.0) then + c_phase = sqrt(freq2/Kmag2) + Fr2_max = (Umax(i,j,fr,m) / c_phase)**2 + ! Dissipate energy if Fr>1; done here with an arbitrary time scale + if (Fr2_max > 1.0) then + En_initial = sum(CS%En(i,j,:,fr,m)) ! for debugging + ! Calculate effective decay rate [T-1 ~> s-1] if breaking occurs over a time step + loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt) + do a=1,CS%nAngle + ! Determine effective dissipation rate (Wm-2) + CS%TKE_Froude_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * abs(loss_rate) + ! Update energy + En_new = CS%En(i,j,a,fr,m)/Fr2_max ! for debugging + En_check = CS%En(i,j,a,fr,m) - CS%TKE_Froude_loss(i,j,a,fr,m)*dt ! for debugging + ! Re-scale (reduce) energy due to breaking + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m)/Fr2_max + ! Check (for debugging only) + if (abs(En_new - En_check) > CS%En_check_tol) then + call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr-breaking.", & + all_print=.true.) + write(mesg,*) "En_new=", En_new , "En_check=", En_check + call MOM_error(WARNING, "MOM_internal_tides: "//trim(mesg), all_print=.true.) + endif + enddo + ! Check (for debugging) + Delta_E_check = En_initial - sum(CS%En(i,j,:,fr,m)) + TKE_Froude_loss_check = abs(Delta_E_check)/dt + TKE_Froude_loss_tot = sum(CS%TKE_Froude_loss(i,j,:,fr,m)) + if (abs(TKE_Froude_loss_check - TKE_Froude_loss_tot)*dt > CS%En_check_tol) then + call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr energy update.", & + all_print=.true.) + write(mesg,*) "TKE_Froude_loss_check=", TKE_Froude_loss_check, & + "TKE_Froude_loss_tot=", TKE_Froude_loss_tot + call MOM_error(WARNING, "MOM_internal_tides: "//trim(mesg), all_print=.true.) + endif + endif ! Fr2>1 + endif ! Kmag2>0 + CS%cp(i,j,fr,m) = c_phase + enddo ; enddo + enddo ; enddo + endif + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset + write(mesg,*) 'After Froude loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + CS%En(i,j,a,fr,m) = 0.0 +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + !stop + endif + enddo ; enddo + enddo ; enddo ; enddo + + ! loss from residual of reflection/transmission coefficients + if (CS%apply_residual_drag) then + + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + ! implicit form + !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%TKE_residual_loss(i,j,a,fr,m) / & + ! (CS%En(i,j,a,fr,m) + en_subRO)) + ! rewritten to minimize number of divisions: + CS%En(i,j,a,fr,m) = (CS%En(i,j,a,fr,m) * (CS%En(i,j,a,fr,m) + en_subRO)) / & + ((CS%En(i,j,a,fr,m) + en_subRO) + dt * CS%TKE_residual_loss(i,j,a,fr,m)) + + ! explicit form + !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) - dt * CS%TKE_residual_loss(i,j,a,fr,m) + enddo ; enddo ; enddo ; enddo ; enddo + endif + + + ! Check for energy conservation on computational domain.************************* + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide') + enddo ; enddo + + ! Output diagnostics.************************************************************ + avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) + call enable_averages(dt, time_end, CS%diag) + + if (query_averaging_enabled(CS%diag)) then + ! Output internal wave modal wave speeds + if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn(:,:,1),CS%diag) + do m=1,CS%nMode ; if (CS%id_cn(m) > 0) call post_data(CS%id_cn(m), cn(:,:,m), CS%diag) ; enddo + + ! Output two-dimensional diagnostics + if (CS%id_tot_En > 0) call post_data(CS%id_tot_En, tot_En, CS%diag) + do fr=1,CS%nFreq + if (CS%id_TKE_itidal_input(fr) > 0) call post_data(CS%id_TKE_itidal_input(fr), & + TKE_itidal_input(:,:,fr), CS%diag) + enddo + + do m=1,CS%nMode ; do fr=1,CS%nFreq + if (CS%id_itide_drag(fr,m) > 0) call post_data(CS%id_itide_drag(fr,m), drag_scale(:,:,fr,m), CS%diag) + enddo ; enddo + + ! Output 2-D energy density (summed over angles) for each frequency and mode + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_En_mode(fr,m) > 0) then + tot_En(:,:) = 0.0 + do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + tot_En(i,j) = tot_En(i,j) + CS%En(i,j,a,fr,m) + enddo ; enddo ; enddo + call post_data(CS%id_En_mode(fr,m), tot_En, CS%diag) + endif ; enddo ; enddo + + ! split energy array into multiple restarts + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode1(i,j,a,fr) = CS%En(i,j,a,fr,1) + enddo ; enddo ; enddo ; enddo + + if (CS%nMode >= 2) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode2(i,j,a,fr) = CS%En(i,j,a,fr,2) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 3) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode3(i,j,a,fr) = CS%En(i,j,a,fr,3) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 4) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode4(i,j,a,fr) = CS%En(i,j,a,fr,4) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 5) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode5(i,j,a,fr) = CS%En(i,j,a,fr,5) + enddo ; enddo ; enddo ; enddo + endif + + ! Output 3-D (i,j,a) energy density for each frequency and mode + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_En_ang_mode(fr,m) > 0) then + call post_data(CS%id_En_ang_mode(fr,m), CS%En(:,:,:,fr,m) , CS%diag) + endif ; enddo ; enddo + + ! Output 2-D energy loss (summed over angles, freq, modes) + tot_leak_loss(:,:) = 0.0 + tot_quad_loss(:,:) = 0.0 + tot_itidal_loss(:,:) = 0.0 + tot_Froude_loss(:,:) = 0.0 + tot_residual_loss(:,:) = 0.0 + tot_allprocesses_loss(:,:) = 0.0 + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + tot_leak_loss(i,j) = tot_leak_loss(i,j) + CS%TKE_leak_loss(i,j,a,fr,m) + tot_quad_loss(i,j) = tot_quad_loss(i,j) + CS%TKE_quad_loss(i,j,a,fr,m) + tot_itidal_loss(i,j) = tot_itidal_loss(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) + tot_Froude_loss(i,j) = tot_Froude_loss(i,j) + CS%TKE_Froude_loss(i,j,a,fr,m) + tot_residual_loss(i,j) = tot_residual_loss(i,j) + CS%TKE_residual_loss(i,j,a,fr,m) + enddo ; enddo ; enddo ; enddo ; enddo + do j=js,je ; do i=is,ie + tot_allprocesses_loss(i,j) = ((((tot_leak_loss(i,j) + tot_quad_loss(i,j)) + & + tot_itidal_loss(i,j)) + tot_Froude_loss(i,j)) + & + tot_residual_loss(i,j)) + enddo ; enddo + CS%tot_leak_loss = tot_leak_loss + CS%tot_quad_loss = tot_quad_loss + CS%tot_itidal_loss = tot_itidal_loss + CS%tot_Froude_loss = tot_Froude_loss + CS%tot_residual_loss = tot_residual_loss + CS%tot_allprocesses_loss = tot_allprocesses_loss + if (CS%id_tot_leak_loss > 0) then + call post_data(CS%id_tot_leak_loss, tot_leak_loss, CS%diag) + endif + if (CS%id_tot_quad_loss > 0) then + call post_data(CS%id_tot_quad_loss, tot_quad_loss, CS%diag) + endif + if (CS%id_tot_itidal_loss > 0) then + call post_data(CS%id_tot_itidal_loss, tot_itidal_loss, CS%diag) + endif + if (CS%id_tot_Froude_loss > 0) then + call post_data(CS%id_tot_Froude_loss, tot_Froude_loss, CS%diag) + endif + if (CS%id_tot_residual_loss > 0) then + call post_data(CS%id_tot_residual_loss, tot_residual_loss, CS%diag) + endif + if (CS%id_tot_allprocesses_loss > 0) then + call post_data(CS%id_tot_allprocesses_loss, tot_allprocesses_loss, CS%diag) + endif + + ! Output 2-D energy loss (summed over angles) for each frequency and mode + do m=1,CS%nMode ; do fr=1,CS%Nfreq + if (CS%id_itidal_loss_mode(fr,m) > 0 .or. CS%id_allprocesses_loss_mode(fr,m) > 0) then + itidal_loss_mode(:,:) = 0.0 ! wave-drag processes (could do others as well) + leak_loss_mode(:,:) = 0.0 + quad_loss_mode(:,:) = 0.0 + Froude_loss_mode(:,:) = 0.0 + residual_loss_mode(:,:) = 0.0 + allprocesses_loss_mode(:,:) = 0.0 ! all processes summed together + do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + itidal_loss_mode(i,j) = itidal_loss_mode(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) + leak_loss_mode(i,j) = leak_loss_mode(i,j) + CS%TKE_leak_loss(i,j,a,fr,m) + quad_loss_mode(i,j) = quad_loss_mode(i,j) + CS%TKE_quad_loss(i,j,a,fr,m) + Froude_loss_mode(i,j) = Froude_loss_mode(i,j) + CS%TKE_Froude_loss(i,j,a,fr,m) + residual_loss_mode(i,j) = residual_loss_mode(i,j) + CS%TKE_residual_loss(i,j,a,fr,m) + allprocesses_loss_mode(i,j) = allprocesses_loss_mode(i,j) + & + ((((CS%TKE_leak_loss(i,j,a,fr,m) + CS%TKE_quad_loss(i,j,a,fr,m)) + & + CS%TKE_itidal_loss(i,j,a,fr,m)) + CS%TKE_Froude_loss(i,j,a,fr,m)) + & + CS%TKE_residual_loss(i,j,a,fr,m)) + enddo ; enddo ; enddo + call post_data(CS%id_itidal_loss_mode(fr,m), itidal_loss_mode, CS%diag) + call post_data(CS%id_leak_loss_mode(fr,m), leak_loss_mode, CS%diag) + call post_data(CS%id_quad_loss_mode(fr,m), quad_loss_mode, CS%diag) + call post_data(CS%id_Froude_loss_mode(fr,m), Froude_loss_mode, CS%diag) + call post_data(CS%id_residual_loss_mode(fr,m), residual_loss_mode, CS%diag) + call post_data(CS%id_allprocesses_loss_mode(fr,m), allprocesses_loss_mode, CS%diag) + endif ; enddo ; enddo + + ! Output 3-D (i,j,a) energy loss for each frequency and mode + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_itidal_loss_ang_mode(fr,m) > 0) then + call post_data(CS%id_itidal_loss_ang_mode(fr,m), CS%TKE_itidal_loss(:,:,:,fr,m) , CS%diag) + endif ; enddo ; enddo + + ! Output 2-D period-averaged horizontal near-bottom mode velocity for each frequency and mode + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_Ub_mode(fr,m) > 0) then + call post_data(CS%id_Ub_mode(fr,m), Ub(:,:,fr,m), CS%diag) + endif ; enddo ; enddo + + do m=1,CS%nMode ; if (CS%id_Ustruct_mode(m) > 0) then + call post_data(CS%id_Ustruct_mode(m), CS%u_struct(:,:,:,m), CS%diag) + endif ; enddo + + do m=1,CS%nMode ; if (CS%id_Wstruct_mode(m) > 0) then + call post_data(CS%id_Wstruct_mode(m), CS%w_struct(:,:,:,m), CS%diag) + endif ; enddo + + do m=1,CS%nMode ; if (CS%id_int_w2_mode(m) > 0) then + call post_data(CS%id_int_w2_mode(m), CS%int_w2(:,:,m), CS%diag) + endif ; enddo + + do m=1,CS%nMode ; if (CS%id_int_U2_mode(m) > 0) then + call post_data(CS%id_int_U2_mode(m), CS%int_U2(:,:,m), CS%diag) + endif ; enddo + + do m=1,CS%nMode ; if (CS%id_int_N2w2_mode(m) > 0) then + call post_data(CS%id_int_N2w2_mode(m), CS%int_N2w2(:,:,m), CS%diag) + endif ; enddo + + ! Output 2-D horizontal phase velocity for each frequency and mode + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_cp_mode(fr,m) > 0) then + call post_data(CS%id_cp_mode(fr,m), CS%cp(:,:,fr,m), CS%diag) + endif ; enddo ; enddo + + endif + + call disable_averaging(CS%diag) + +end subroutine propagate_int_tide + +!> Checks for energy conservation on computational domain +subroutine sum_En(G, US, CS, En, label) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure + real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle), & + intent(in) :: En !< The energy density of the internal tides [R Z3 T-2 ~> J m-2]. + character(len=*), intent(in) :: label !< A label to use in error messages + ! Local variables + real :: En_sum ! The total energy in MKS units for potential output [J] + integer :: a + ! real :: En_sum_diff ! Change in energy from the expected value [J] + ! real :: En_sum_pdiff ! Percentage change in energy from the expected value [nondim] + ! character(len=160) :: mesg ! The text of an error message + ! real :: days ! The time in days for use in output messages [days] + + En_sum = 0.0 + do a=1,CS%nAngle + En_sum = En_sum + global_area_integral(En(:,:,a), G, scale=US%RZ3_T3_to_W_m2*US%T_to_s) + enddo + CS%En_sum = En_sum + !En_sum_diff = En_sum - CS%En_sum + !if (CS%En_sum /= 0.0) then + ! En_sum_pdiff= (En_sum_diff/CS%En_sum)*100.0 + !else + ! En_sum_pdiff= 0.0 + !endif + !! Print to screen + !if (is_root_pe()) then + ! days = time_type_to_real(CS%Time) / 86400.0 + ! write(mesg,*) trim(label)//': days =', days, ', En_sum=', En_sum, & + ! ', En_sum_diff=', En_sum_diff, ', Percent change=', En_sum_pdiff, '%' + ! call MOM_mesg(mesg) + !if (is_root_pe() .and. (abs(En_sum_pdiff) > 1.0)) & + ! call MOM_error(FATAL, "Run stopped due to excessive internal tide energy change.") + !endif + +end subroutine sum_En + +!> Calculates the energy lost from the propagating internal tide due to +!! scattering over small-scale roughness along the lines of Jayne & St. Laurent (2001). +subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixed, TKE_loss, dt, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(in) :: Nb !< Near-bottom stratification [T-1 ~> s-1]. + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(in) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%nFreq,CS%nMode), & + intent(inout) :: Ub !< RMS (over one period) near-bottom horizontal + !! mode velocity [L T-1 ~> m s-1]. + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [R Z4 H-1 L-2 ~> kg m-2 or m] + !! (rho*kappa*h^2) or (kappa*h^2). + real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & + intent(inout) :: En !< Energy density of the internal waves [R Z3 T-2 ~> J m-2]. + real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & + intent(out) :: TKE_loss !< Energy loss rate [R Z3 T-3 ~> W m-2] + !! (q*rho*kappa*h^2*N*U^2). + real, intent(in) :: dt !< Time increment [T ~> s]. + integer, optional, intent(in) :: halo_size !< The halo size over which to do the calculations + ! Local variables + integer :: j, i, m, fr, a, is, ie, js, je, halo + real :: En_tot ! energy for a given mode, frequency, and point summed over angles [R Z3 T-2 ~> J m-2] + real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles [R Z3 T-3 ~> W m-2] + real :: frac_per_sector ! fraction of energy in each wedge [nondim] + real :: q_itides ! fraction of energy actually lost to mixing (remainder, 1-q, is + ! assumed to stay in propagating mode for now - BDM) [nondim] + real :: loss_rate ! approximate loss rate for implicit calc [T-1 ~> s-1] + real :: En_negl ! negligibly small number to prevent division by zero [R Z3 T-2 ~> J m-2] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + q_itides = CS%q_itides + En_negl = 1e-30*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2 + + if (present(halo_size)) then + halo = halo_size + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + endif + + do j=js,je ; do i=is,ie ; do m=1,CS%nMode ; do fr=1,CS%nFreq + + ! Sum energy across angles + En_tot = 0.0 + do a=1,CS%nAngle + En_tot = En_tot + En(i,j,a,fr,m) + enddo + + ! Calculate TKE loss rate; units of [R Z3 T-3 ~> W m-2] here. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + TKE_loss_tot = q_itides * GV%Z_to_H * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + else + TKE_loss_tot = q_itides * (GV%RZ_to_H * Rho_bot(i,j)) * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + endif + + ! Update energy remaining (this is a pseudo implicit calc) + ! (E(t+1)-E(t))/dt = -TKE_loss(E(t+1)/E(t)), which goes to zero as E(t+1) goes to zero + if (En_tot > 0.0) then + do a=1,CS%nAngle + frac_per_sector = En(i,j,a,fr,m)/En_tot + TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! [R Z3 T-3 ~> W m-2] + loss_rate = TKE_loss(i,j,a,fr,m) / (En(i,j,a,fr,m) + En_negl) ! [T-1 ~> s-1] + En(i,j,a,fr,m) = En(i,j,a,fr,m) / (1.0 + dt*loss_rate) + enddo + else + ! no loss if no energy + do a=1,CS%nAngle + TKE_loss(i,j,a,fr,m) = 0.0 + enddo + endif + + ! Update energy remaining (this is the old explicit calc) + !if (En_tot > 0.0) then + ! do a=1,CS%nAngle + ! frac_per_sector = En(i,j,a,fr,m)/En_tot + ! TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot + ! if (TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then + ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt + ! else + ! call MOM_error(WARNING, "itidal_lowmode_loss: energy loss greater than available, "// & + ! " setting En to zero.", all_print=.true.) + ! En(i,j,a,fr,m) = 0.0 + ! endif + ! enddo + !else + ! ! no loss if no energy + ! TKE_loss(i,j,:,fr,m) = 0.0 + !endif + + enddo ; enddo ; enddo ; enddo + +end subroutine itidal_lowmode_loss + +!> This subroutine extracts the energy lost from the propagating internal which has +!> been summed across all angles, frequencies, and modes for a given mechanism and location. +!! +!> It can be called from another module to get values from this module's (private) CS. +subroutine get_lowmode_loss(i,j,G,CS,mechanism,TKE_loss_sum) + integer, intent(in) :: i !< The i-index of the value to be reported. + integer, intent(in) :: j !< The j-index of the value to be reported. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + character(len=*), intent(in) :: mechanism !< The named mechanism of loss to return + real, intent(out) :: TKE_loss_sum !< Total energy loss rate due to specified + !! mechanism [R Z3 T-3 ~> W m-2]. + + if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) ! not used for mixing yet + if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) ! not used for mixing yet + if (mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) ! currently used for mixing + if (mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) ! not used for mixing yet + +end subroutine get_lowmode_loss + +!> Implements refraction on the internal waves at a single frequency. +subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & + intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space and angular resolution, + !! [R Z3 T-2 ~> J m-2]. + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. + real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. + real, intent(in) :: dt !< Time step [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: use_PPMang !< If true, use PPM for advection rather + !! than upwind. + ! Local variables + integer, parameter :: stencil = 2 + real, dimension(SZI_(G),1-stencil:NAngle+stencil) :: & + En2d ! The internal gravity wave energy density in zonal slices [R Z3 T-2 ~> J m-2] + real, dimension(1-stencil:NAngle+stencil) :: & + cos_angle, sin_angle ! The cosine and sine of each angle [nondim] + real, dimension(SZI_(G)) :: & + Dk_Dt_Kmag, Dl_Dt_Kmag ! Rates of angular refraction [T-1 ~> s-1] + real, dimension(SZI_(G),0:nAngle) :: & + Flux_E ! The flux of energy between successive angular wedges within a timestep [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G),1-stencil:NAngle+stencil) :: & + CFL_ang ! The CFL number of angular refraction [nondim] + real, dimension(G%IsdB:G%IedB,G%jsd:G%jed) :: cn_u !< Internal wave group velocity at U-point [L T-1 ~> m s-1] + real, dimension(G%isd:G%ied,G%JsdB:G%JedB) :: cn_v !< Internal wave group velocity at V-point [L T-1 ~> m s-1] + real, dimension(G%isd:G%ied,G%jsd:G%jed) :: cnmask !< Local mask for group velocity [nondim] + real :: f2 ! The squared Coriolis parameter [T-2 ~> s-2]. + real :: favg ! The average Coriolis parameter at a point [T-1 ~> s-1]. + real :: df_dy, df_dx ! The x- and y- gradients of the Coriolis parameter [T-1 L-1 ~> s-1 m-1]. + real :: dlnCn_dx ! The x-gradient of the wave speed divided by itself [L-1 ~> m-1]. + real :: dlnCn_dy ! The y-gradient of the wave speed divided by itself [L-1 ~> m-1]. + real :: Angle_size ! The size of each wedge of angles [rad] + real :: dt_Angle_size ! The time step divided by the angle size [T rad-1 ~> s rad-1] + real :: angle ! The central angle of each wedge [rad] + real :: Ifreq ! The inverse of the wave frequency [T ~> s] + real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] + real :: I_Kmag ! The inverse of the magnitude of the horizontal wavenumber [L ~> m] + real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] + integer :: is, ie, js, je, asd, aed, na + integer :: i, j, a + real :: wgt1, wgt2 ! Weights in an average, both of which may be 0 [nondim] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; na = size(En,3) + asd = 1-stencil ; aed = NAngle+stencil + + cnmask(:,:) = merge(0., 1., cn(:,:) == 0.) + + do j=js,je ; do i=is-1,ie + ! wgt = 0 if local cn == 0, wgt = 0.5 if both contiguous values != 0 + ! and wgt = 1 if neighbour cn == 0 + wgt1 = cnmask(i,j) - 0.5 * cnmask(i,j) * cnmask(i+1,j) + wgt2 = cnmask(i+1,j) - 0.5 * cnmask(i,j) * cnmask(i+1,j) + cn_u(I,j) = wgt1*cn(i,j) + wgt2*cn(i+1,j) + enddo ; enddo + + do j=js-1,je ; do i=is,ie + wgt1 = cnmask(i,j) - 0.5 * cnmask(i,j) * cnmask(i,j+1) + wgt2 = cnmask(i,j+1) - 0.5 * cnmask(i,j) * cnmask(i,j+1) + cn_v(i,J) = wgt1*cn(i,j) + wgt2*cn(i,j+1) + enddo ; enddo + + Ifreq = 1.0 / freq + cn_subRO = 1e-30*US%m_s_to_L_T + Angle_size = (8.0*atan(1.0)) / (real(NAngle)) + dt_Angle_size = dt / Angle_size + + do A=asd,aed + angle = (real(A) - 0.5) * Angle_size + cos_angle(A) = cos(angle) ; sin_angle(A) = sin(angle) + enddo + + !### There should also be refraction due to cn.grad(grid_orientation). + CFL_ang(:,:,:) = 0.0 + do j=js,je + ! Copy En into angle space with halos. + do a=1,na ; do i=is,ie + En2d(i,a) = En(i,j,a) + enddo ; enddo + do a=asd,0 ; do i=is,ie + En2d(i,a) = En2d(i,a+NAngle) + En2d(i,NAngle+stencil+a) = En2d(i,stencil+a) + enddo ; enddo + + ! Do the refraction. + do i=is,ie + f2 = 0.25* ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) + favg = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J))) + df_dx = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) - & + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I-1,J-1))) * G%IdxT(i,j) + df_dy = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) - & + (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J-1))) * G%IdyT(i,j) + + dlnCn_dx = G%IdxT(i,j) * (cn_u(I,j) - cn_u(I-1,j)) / (0.5 * (cn_u(I,j) + cn_u(I-1,j)) + cn_subRO) + dlnCn_dy = G%IdyT(i,j) * (cn_v(i,J) - cn_v(i,J-1)) / (0.5 * (cn_v(i,J) + cn_v(i,J-1)) + cn_subRO) + + Kmag2 = (freq**2 - f2) / (cn(i,j)**2 + cn_subRO**2) + if (Kmag2 > 0.0) then + I_Kmag = 1.0 / sqrt(Kmag2) + Dk_Dt_Kmag(i) = -Ifreq * (favg*df_dx + (freq**2 - f2) * dlnCn_dx) * I_Kmag + Dl_Dt_Kmag(i) = -Ifreq * (favg*df_dy + (freq**2 - f2) * dlnCn_dy) * I_Kmag + else + Dk_Dt_Kmag(i) = 0.0 + Dl_Dt_Kmag(i) = 0.0 + endif + enddo + + ! Determine the energy fluxes in angular orientation space. + do A=asd,aed ; do i=is,ie + CFL_ang(i,j,A) = (cos_angle(A) * Dl_Dt_Kmag(i) - sin_angle(A) * Dk_Dt_Kmag(i)) * dt_Angle_size + if (abs(CFL_ang(i,j,A)) > 1.0) then + call MOM_error(WARNING, "refract: CFL exceeds 1.", .true.) + if (CFL_ang(i,j,A) > 0.0) then ; CFL_ang(i,j,A) = 1.0 ; else ; CFL_ang(i,j,A) = -1.0 ; endif + endif + enddo ; enddo + + ! Advect in angular space + if (.not.use_PPMang) then + ! Use simple upwind + do A=0,na ; do i=is,ie + if (CFL_ang(i,j,A) > 0.0) then + Flux_E(i,A) = CFL_ang(i,j,A) * En2d(i,A) + else + Flux_E(i,A) = CFL_ang(i,j,A) * En2d(i,A+1) + endif + enddo ; enddo + else + ! Use PPM + do i=is,ie + call PPM_angular_advect(En2d(i,:),CFL_ang(i,j,:),Flux_E(i,:),NAngle,dt,stencil) + enddo + endif + + ! Update and copy back to En. + do a=1,na ; do i=is,ie + !if (En2d(i,a)+(Flux_E(i,A-1)-Flux_E(i,A)) < 0.0) then ! for debugging + ! call MOM_error(FATAL, "refract: OutFlux>Available") + !endif + En(i,j,a) = En2d(i,a) + (Flux_E(i,A-1) - Flux_E(i,A)) + enddo ; enddo + enddo ! j-loop +end subroutine refract + +!> This subroutine calculates the 1-d flux for advection in angular space using a monotonic +!! piecewise parabolic scheme. This needs to be called from within i and j spatial loops. +subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum [nondim] + real, intent(in) :: dt !< Time increment [T ~> s]. + integer, intent(in) :: halo_ang !< The halo size in angular space + real, dimension(1-halo_ang:NAngle+halo_ang), & + intent(in) :: En2d !< The internal gravity wave energy density as a + !! function of angular resolution [R Z3 T-2 ~> J m-2]. + real, dimension(1-halo_ang:NAngle+halo_ang), & + intent(in) :: CFL_ang !< The CFL number of the energy advection across angles [nondim] + real, dimension(0:NAngle), intent(out) :: Flux_En !< The time integrated internal wave energy flux + !! across angles [R Z3 T-2 ~> J m-2]. + ! Local variables + real :: flux ! The internal wave energy flux across angles [R Z3 T-3 ~> W m-2]. + real :: u_ang ! Angular propagation speed [Rad T-1 ~> Rad s-1] + real :: Angle_size ! The size of each orientation wedge in radians [Rad] + real :: I_Angle_size ! The inverse of the orientation wedges [Rad-1] + real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] + real :: aR, aL ! Left and right edge estimates of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] + real :: Ep, Ec, Em ! Mean angular energy density for three successive wedges in angular + ! orientation [R Z3 T-2 rad-1 ~> J m-2 rad-1] + real :: dA, curv_3 ! Difference and curvature of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] + real, parameter :: oneSixth = 1.0/6.0 ! One sixth [nondim] + integer :: a + + I_dt = 1 / dt + Angle_size = (8.0*atan(1.0)) / (real(NAngle)) + I_Angle_size = 1 / Angle_size + Flux_En(:) = 0 + + do A=0,NAngle + u_ang = CFL_ang(A)*Angle_size*I_dt + if (u_ang >= 0.0) then + ! Implementation of PPM-H3 + ! Convert wedge-integrated energy density into angular energy densities for three successive + ! wedges around the source wedge for this flux [R Z3 T-2 rad-1 ~> J m-2 rad-1]. + Ep = En2d(a+1)*I_Angle_size + Ec = En2d(a) *I_Angle_size + Em = En2d(a-1)*I_Angle_size + ! Calculate and bound edge values of energy density. + aL = ( 5.*Ec + ( 2.*Em - Ep ) ) * oneSixth ! H3 estimate + aL = max( min(Ec,Em), aL) ; aL = min( max(Ec,Em), aL) ! Bound + aR = ( 5.*Ec + ( 2.*Ep - Em ) ) * oneSixth ! H3 estimate + aR = max( min(Ec,Ep), aR) ; aR = min( max(Ec,Ep), aR) ! Bound + dA = aR - aL + if ((Ep-Ec)*(Ec-Em) <= 0.) then + aL = Ec ; aR = Ec ! use PCM for local extremum + elseif ( 3.0*dA*(2.*Ec - (aR + aL)) > (dA*dA) ) then + aL = 3.*Ec - 2.*aR ! Flatten the profile to move the extremum to the left edge + elseif ( 3.0*dA*(2.*Ec - (aR + aL)) < - (dA*dA) ) then + aR = 3.*Ec - 2.*aL ! Flatten the profile to move the extremum to the right edge + endif + curv_3 = (aR + aL) - 2.0*Ec ! Curvature + ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] + flux = u_ang*( aR + CFL_ang(A) * ( 0.5*(aL - aR) + curv_3 * (CFL_ang(A) - 1.5) ) ) + ! Calculate amount of energy fluxed between wedges [R Z3 T-2 ~> J m-2] + Flux_En(A) = dt * flux + !Flux_En(A) = (dt * I_Angle_size) * flux + else + ! Implementation of PPM-H3 + ! Convert wedge-integrated energy density into angular energy densities for three successive + ! wedges around the source wedge for this flux [R Z3 T-2 rad-1 ~> J m-2 rad-1]. + Ep = En2d(a+2)*I_Angle_size + Ec = En2d(a+1)*I_Angle_size + Em = En2d(a) *I_Angle_size + ! Calculate and bound edge values of energy density. + aL = ( 5.*Ec + ( 2.*Em - Ep ) ) * oneSixth ! H3 estimate + aL = max( min(Ec,Em), aL) ; aL = min( max(Ec,Em), aL) ! Bound + aR = ( 5.*Ec + ( 2.*Ep - Em ) ) * oneSixth ! H3 estimate + aR = max( min(Ec,Ep), aR) ; aR = min( max(Ec,Ep), aR) ! Bound + dA = aR - aL + if ((Ep-Ec)*(Ec-Em) <= 0.) then + aL = Ec ; aR = Ec ! use PCM for local extremum + elseif ( 3.0*dA*(2.*Ec - (aR + aL)) > (dA*dA) ) then + aL = 3.*Ec - 2.*aR ! Flatten the profile to move the extremum to the left edge + elseif ( 3.0*dA*(2.*Ec - (aR + aL)) < - (dA*dA) ) then + aR = 3.*Ec - 2.*aL ! Flatten the profile to move the extremum to the right edge + endif + curv_3 = (aR + aL) - 2.0*Ec ! Curvature + ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] + ! Note that CFL_ang is negative here, so it looks odd compared with equivalent expressions. + flux = u_ang*( aL - CFL_ang(A) * ( 0.5*(aR - aL) + curv_3 * (-CFL_ang(A) - 1.5) ) ) + ! Calculate amount of energy fluxed between wedges [R Z3 T-2 ~> J m-2] + Flux_En(A) = dt * flux + !Flux_En(A) = (dt * I_Angle_size) * flux + endif + enddo +end subroutine PPM_angular_advect + +!> Propagates internal waves at a single frequency. +subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & + intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space and angular resolution, + !! [R Z3 T-2 ~> J m-2]. + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. + real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. + real, intent(in) :: dt !< Time step [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & + intent(inout) :: residual_loss !< internal tide energy loss due + !! to the residual at slopes [R Z3 T-3 ~> W m-2]. + ! Local variables + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: & + speed ! The magnitude of the group velocity at the q points for corner adv [L T-1 ~> m s-1]. + integer, parameter :: stencil = 2 + real, dimension(SZIB_(G),SZJ_(G)) :: & + speed_x ! The magnitude of the group velocity at the Cu points [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G)) :: & + speed_y ! The magnitude of the group velocity at the Cv points [L T-1 ~> m s-1]. + real, dimension(0:NAngle) :: & + cos_angle, sin_angle ! The cosine and sine of each angle [nondim] + real, dimension(NAngle) :: & + Cgx_av, & ! The average projection of the wedge into the x-direction [nondim] + Cgy_av, & ! The average projection of the wedge into the y-direction [nondim] + dCgx, & ! The difference in x-projections between the edges of each angular band [nondim]. + dCgy ! The difference in y-projections between the edges of each angular band [nondim]. + real :: f2 ! The squared Coriolis parameter [T-2 ~> s-2]. + real :: Angle_size ! The size of each wedge of angles [rad] + real :: I_Angle_size ! The inverse of the size of each wedge of angles [rad-1] + real :: angle ! The central angle of each wedge [rad] + real :: Ifreq ! The inverse of the frequency [T ~> s] + real :: freq2 ! The frequency squared [T-2 ~> s-2] + type(loop_bounds_type) :: LB + integer :: is, ie, js, je, asd, aed, na + integer :: ish, ieh, jsh, jeh + integer :: i, j, a + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; na = size(En,3) + asd = 1-stencil ; aed = NAngle+stencil + + Ifreq = 1.0 / freq + freq2 = freq**2 + + ! Define loop bounds: Need extensions on j-loop so propagate_y + ! (done after propagate_x) will have updated values in the halo + ! for correct PPM reconstruction. Use if no teleporting and + ! no pass_var between propagate_x and propagate_y. + !jsh = js-3 ; jeh = je+3 ; ish = is ; ieh = ie + + ! Define loop bounds: Need 1-pt extensions on loops because + ! teleporting eats up a halo point. Use if teleporting. + ! Also requires pass_var before propagate_y. + jsh = js-1 ; jeh = je+1 ; ish = is-1 ; ieh = ie+1 + + Angle_size = (8.0*atan(1.0)) / real(NAngle) + I_Angle_size = 1.0 / Angle_size + + if (CS%corner_adv) then + ! IMPLEMENT CORNER ADVECTION IN HORIZONTAL-------------------- + ! FIND AVERAGE GROUP VELOCITY (SPEED) AT CELL CORNERS + ! NOTE: THIS HAS NOT BE ADAPTED FOR REFLECTION YET (BDM)!! + ! Fix indexing here later + speed(:,:) = 0.0 + do J=jsh-1,jeh ; do I=ish-1,ieh + f2 = G%CoriolisBu(I,J)**2 + speed(I,J) = 0.25*((cn(i,j) + cn(i+1,j+1)) + (cn(i+1,j) + cn(i,j+1))) * & + sqrt(max(freq2 - f2, 0.0)) * Ifreq + enddo ; enddo + do a=1,na + ! Apply the propagation WITH CORNER ADVECTION/FINITE VOLUME APPROACH. + LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie + call propagate_corner_spread(En(:,:,a), a, NAngle, speed, dt, G, CS, LB) + enddo ! a-loop + else + ! IMPLEMENT PPM ADVECTION IN HORIZONTAL----------------------- + ! These could be in the control structure, as they do not vary. + do A=0,na + ! These are the angles at the cell edges... + angle = (real(A) - 0.5) * Angle_size + cos_angle(A) = cos(angle) ; sin_angle(A) = sin(angle) + enddo + + do a=1,na + Cgx_av(a) = (sin_angle(A) - sin_angle(A-1)) * I_Angle_size + Cgy_av(a) = -(cos_angle(A) - cos_angle(A-1)) * I_Angle_size + dCgx(a) = sqrt(0.5 + 0.5*(sin_angle(A)*cos_angle(A) - & + sin_angle(A-1)*cos_angle(A-1)) * I_Angle_size - & + Cgx_av(a)**2) + dCgy(a) = sqrt(0.5 - 0.5*(sin_angle(A)*cos_angle(A) - & + sin_angle(A-1)*cos_angle(A-1)) * I_Angle_size - & + Cgy_av(a)**2) + enddo + + do j=jsh,jeh ; do I=ish-1,ieh + f2 = 0.5 * (G%CoriolisBu(I,J)**2 + G%CoriolisBu(I,J-1)**2) + speed_x(I,j) = 0.5*(cn(i,j) + cn(i+1,j)) * G%mask2dCu(I,j) * & + sqrt(max(freq2 - f2, 0.0)) * Ifreq + enddo ; enddo + do J=jsh-1,jeh ; do i=ish,ieh + f2 = 0.5 * (G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J)**2) + speed_y(i,J) = 0.5*(cn(i,j) + cn(i,j+1)) * G%mask2dCv(i,J) * & + sqrt(max(freq2 - f2, 0.0)) * Ifreq + enddo ; enddo + + ! Apply propagation in x-direction (reflection included) + LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh + call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss) + + ! Check for energy conservation on computational domain (for debugging) + !call sum_En(G, US, CS, En, 'post-propagate_x') + + ! Update halos + call pass_var(En, G%domain) + call pass_var(residual_loss, G%domain) + + ! Apply propagation in y-direction (reflection included) + ! LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie ! Use if no teleport + LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh + call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss) + + ! Check for energy conservation on computational domain (for debugging) + !call sum_En(G, US, CS, En, 'post-propagate_y') + endif + +end subroutine propagate + +!> This subroutine does first-order corner advection. It was written with the hopes +!! of smoothing out the garden sprinkler effect, but is too numerically diffusive to +!! be of much use as of yet. It is not yet compatible with reflection schemes (BDM). +subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS, LB) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(inout) :: En !< The energy density integrated over an angular + !! band [R Z3 T-2 ~> J m-2]. + real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed), & + intent(in) :: speed !< The magnitude of the group velocity at the cell + !! corner points [L T-1 ~> m s-1]. + integer, intent(in) :: energized_wedge !< Index of current ray direction. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + ! Local variables + integer :: i, j, ish, ieh, jsh, jeh, m + real :: TwoPi ! The radius of the circumference of a circle to its radius [nondim] + real :: Angle_size ! The size of each angular wedge [radians] + real :: energized_angle ! angle through center of current wedge [radians] + real :: theta ! angle at edge of each sub-wedge [radians] + real :: Nsubrays ! number of sub-rays for averaging [nondim] + ! count includes the two rays that bound the current wedge, + ! i.e. those at -dtheta/2 and +dtheta/2 from energized angle + real :: I_Nsubwedges ! inverse of number of sub-wedges [nondim] + real :: cos_thetaDT, sin_thetaDT ! cos(theta)*dt, sin(theta)*dt [T ~> s] + real :: xNE, xNW, xSW, xSE ! corner point x-coordinates of advected fluid parcel [L ~> m] + real :: yNE, yNW, ySW, ySE ! corner point y-coordinates of advected fluid parcel [L ~> m] + real :: CFL_xNE, CFL_xNW, CFL_xSW, CFL_xSE ! Various x-direction CFL numbers for propagation [nondim] + real :: CFL_yNE, CFL_yNW, CFL_ySW, CFL_ySE ! Various y-direction CFL numbers for propagation [nondim] + real :: CFL_max ! The maximum of the x- and y-CFL numbers for propagation [nondim] + real :: xN, xS, xE, xW ! intersection point x-coordinates of parcel edges and grid [L ~> m] + real :: yN, yS, yE, yW ! intersection point y-coordinates of parcel edges and grid [L ~> m] + real :: xCrn, yCrn ! Coordinates of grid point contained within advected fluid parcel [L ~> m] + real :: xg, yg ! Positions of grid point of interest [L ~> m] + real :: slopeN, slopeW, slopeS, slopeE ! Coordinate-space slopes of parcel sides [nondim] + real :: bN, bW, bS, bE ! parameters defining parcel sides [L ~> m] + real :: aNE, aN, aNW, aW, aSW, aS, aSE, aE, aC ! sub-areas of advected parcel [L2 ~> m2] + real :: a_total ! total area of advected parcel [L2 ~> m2] + ! real :: a1,a2,a3,a4 ! areas used in calculating polygon areas (sub-areas) of advected parcel [L2 ~> m2] + real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: x, y ! coordinates of cell corners [L ~> m] + real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: Idx, Idy ! inverse of dx,dy at cell corners [L-1 ~> m-1] + real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: dx, dy ! dx,dy at cell corners [L ~> m] + real, dimension(2) :: E_new ! Energy in cell after advection for subray [R Z3 T-2 ~> J m-2]; set size + ! here to define Nsubrays - this should be made an input option later! + + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh + TwoPi = (8.0*atan(1.0)) + Nsubrays = real(size(E_new)) + I_Nsubwedges = 1./(Nsubrays - 1) + + Angle_size = TwoPi / real(NAngle) + energized_angle = Angle_size * real(energized_wedge - 1) ! for a=1 aligned with x-axis + !energized_angle = Angle_size * real(energized_wedge - 1) + 2.0*Angle_size ! + !energized_angle = Angle_size * real(energized_wedge - 1) + 0.5*Angle_size ! + do J=jsh-1,jeh ; do I=ish-1,ieh + ! This will only work for a Cartesian grid for which G%geoLonBu is in the same units has dx. + ! This needs to be extensively revised to work for a general grid. + x(I,J) = G%US%m_to_L*G%geoLonBu(I,J) + y(I,J) = G%US%m_to_L*G%geoLatBu(I,J) + Idx(I,J) = G%IdxBu(I,J) ; dx(I,J) = G%dxBu(I,J) + Idy(I,J) = G%IdyBu(I,J) ; dy(I,J) = G%dyBu(I,J) + enddo ; enddo + + do j=jsh,jeh ; do i=ish,ieh + do m=1,int(Nsubrays) + theta = (energized_angle - 0.5*Angle_size) + real(m - 1)*Angle_size*I_Nsubwedges + if (theta < 0.0) then + theta = theta + TwoPi + elseif (theta > TwoPi) then + theta = theta - TwoPi + endif + cos_thetaDT = cos(theta)*dt + sin_thetaDT = sin(theta)*dt + + ! corner point coordinates of advected fluid parcel ---------- + xg = x(I,J); yg = y(I,J) + xNE = xg - speed(I,J)*cos_thetaDT + yNE = yg - speed(I,J)*sin_thetaDT + CFL_xNE = (xg-xNE)*Idx(I,J) + CFL_yNE = (yg-yNE)*Idy(I,J) + + xg = x(I-1,J); yg = y(I-1,J) + xNW = xg - speed(I-1,J)*cos_thetaDT + yNW = yg - speed(I-1,J)*sin_thetaDT + CFL_xNW = (xg-xNW)*Idx(I-1,J) + CFL_yNW = (yg-yNW)*Idy(I-1,J) + + xg = x(I-1,J-1); yg = y(I-1,J-1) + xSW = xg - speed(I-1,J-1)*cos_thetaDT + ySW = yg - speed(I-1,J-1)*sin_thetaDT + CFL_xSW = (xg-xSW)*Idx(I-1,J-1) + CFL_ySW = (yg-ySW)*Idy(I-1,J-1) + + xg = x(I,J-1); yg = y(I,J-1) + xSE = xg - speed(I,J-1)*cos_thetaDT + ySE = yg - speed(I,J-1)*sin_thetaDT + CFL_xSE = (xg-xSE)*Idx(I,J-1) + CFL_ySE = (yg-ySE)*Idy(I,J-1) + + CFL_max = max(abs(CFL_xNE),abs(CFL_xNW),abs(CFL_xSW), & + abs(CFL_xSE),abs(CFL_yNE),abs(CFL_yNW), & + abs(CFL_ySW),abs(CFL_ySE)) + if (CFL_max > 1.0) then + call MOM_error(WARNING, "propagate_corner_spread: CFL exceeds 1.", .true.) + endif + + ! intersection point coordinates of parcel edges and cell edges --- + if (0.0 <= theta .and. theta < 0.25*TwoPi) then + xN = x(I-1,J-1) + yW = y(I-1,J-1) + elseif (0.25*TwoPi <= theta .and. theta < 0.5*TwoPi) then + xN = x(I,J-1) + yW = y(I,J-1) + elseif (0.5*TwoPi <= theta .and. theta < 0.75*TwoPi) then + xN = x(I,J) + yW = y(I,J) + elseif (0.75*TwoPi <= theta .and. theta <= 1.00*TwoPi) then + xN = x(I-1,J) + yW = y(I-1,J) + endif + xS = xN + yE = yW + + ! north intersection + slopeN = (yNE - yNW)/(xNE - xNW) + bN = -slopeN*xNE + yNE + yN = slopeN*xN + bN + ! west intersection + if (xNW == xSW) then + xW = xNW + else + slopeW = (yNW - ySW)/(xNW - xSW) + bW = -slopeW*xNW + yNW + xW = (yW - bW)/slopeW + endif + ! south intersection + slopeS = (ySW - ySE)/(xSW - xSE) + bS = -slopeS*xSW + ySW + yS = slopeS*xS + bS + ! east intersection + if (xNE == xSE) then + xE = xNE + else + slopeE = (ySE - yNE)/(xSE - xNE) + bE = -slopeE*xSE + ySE + xE = (yE - bE)/slopeE + endif + + ! areas -------------------------------------------- + aNE = 0.0; aN = 0.0; aNW = 0.0; ! initialize areas + aW = 0.0; aSW = 0.0; aS = 0.0; ! initialize areas + aSE = 0.0; aE = 0.0; aC = 0.0; ! initialize areas + if (0.0 <= theta .and. theta < 0.25*TwoPi) then + xCrn = x(I-1,J-1); yCrn = y(I-1,J-1) + ! west area + !a1 = (yN - yCrn)*(0.5*(xN + xCrn)) + !a2 = (yCrn - yW)*(0.5*(xCrn + xW)) + !a3 = (yW - yNW)*(0.5*(xW + xNW)) + !a4 = (yNW - yN)*(0.5*(xNW + xN)) + !aW = a1 + a2 + a3 + a4 + aW = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW)) + ! southwest area + !a1 = (yCrn - yS)*(0.5*(xCrn + xS)) + !a2 = (yS - ySW)*(0.5*(xS + xSW)) + !a3 = (ySW - yW)*(0.5*(xSW + xW)) + !a4 = (yW - yCrn)*(0.5*(xW + xCrn)) + !aSW = a1 + a2 + a3 + a4 + aSW = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS)) + ! south area + !a1 = (yE - ySE)*(0.5*(xE + xSE)) + !a2 = (ySE - yS)*(0.5*(xSE + xS)) + !a3 = (yS - yCrn)*(0.5*(xS + xCrn)) + !a4 = (yCrn - yE)*(0.5*(xCrn + xE)) + !aS = a1 + a2 + a3 + a4 + aS = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE)) + ! area within cell + !a1 = (yNE - yE)*(0.5*(xNE + xE)) + !a2 = (yE - yCrn)*(0.5*(xE + xCrn)) + !a3 = (yCrn - yN)*(0.5*(xCrn + xN)) + !a4 = (yN - yNE)*(0.5*(xN + xNE)) + !aC = a1 + a2 + a3 + a4 + aC = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN)) + elseif (0.25*TwoPi <= theta .and. theta < 0.5*TwoPi) then + xCrn = x(I,J-1); yCrn = y(I,J-1) + ! south area + !a1 = (yCrn - yS)*(0.5*(xCrn + xS)) + !a2 = (yS - ySW)*(0.5*(xS + xSW)) + !a3 = (ySW - yW)*(0.5*(xSW + xW)) + !a4 = (yW - yCrn)*(0.5*(xW + xCrn)) + !aS = a1 + a2 + a3 + a4 + aS = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS)) + ! southeast area + !a1 = (yE - ySE)*(0.5*(xE + xSE)) + !a2 = (ySE - yS)*(0.5*(xSE + xS)) + !a3 = (yS - yCrn)*(0.5*(xS + xCrn)) + !a4 = (yCrn - yE)*(0.5*(xCrn + xE)) + !aSE = a1 + a2 + a3 + a4 + aSE = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE)) + ! east area + !a1 = (yNE - yE)*(0.5*(xNE + xE)) + !a2 = (yE - yCrn)*(0.5*(xE + xCrn)) + !a3 = (yCrn - yN)*(0.5*(xCrn + xN)) + !a4 = (yN - yNE)*(0.5*(xN + xNE)) + !aE = a1 + a2 + a3 + a4 + aE = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN)) + ! area within cell + !a1 = (yN - yCrn)*(0.5*(xN + xCrn)) + !a2 = (yCrn - yW)*(0.5*(xCrn + xW)) + !a3 = (yW - yNW)*(0.5*(xW + xNW)) + !a4 = (yNW - yN)*(0.5*(xNW + xN)) + !aC = a1 + a2 + a3 + a4 + aC = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW)) + elseif (0.5*TwoPi <= theta .and. theta < 0.75*TwoPi) then + xCrn = x(I,J); yCrn = y(I,J) + ! east area + !a1 = (yE - ySE)*(0.5*(xE + xSE)) + !a2 = (ySE - yS)*(0.5*(xSE + xS)) + !a3 = (yS - yCrn)*(0.5*(xS + xCrn)) + !a4 = (yCrn - yE)*(0.5*(xCrn + xE)) + !aE = a1 + a2 + a3 + a4 + aE = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE)) + ! northeast area + !a1 = (yNE - yE)*(0.5*(xNE + xE)) + !a2 = (yE - yCrn)*(0.5*(xE + xCrn)) + !a3 = (yCrn - yN)*(0.5*(xCrn + xN)) + !a4 = (yN - yNE)*(0.5*(xN + xNE)) + !aNE = a1 + a2 + a3 + a4 + aNE = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN)) + ! north area + !a1 = (yN - yCrn)*(0.5*(xN + xCrn)) + !a2 = (yCrn - yW)*(0.5*(xCrn + xW)) + !a3 = (yW - yNW)*(0.5*(xW + xNW)) + !a4 = (yNW - yN)*(0.5*(xNW + xN)) + !aN = a1 + a2 + a3 + a4 + aN = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW)) + ! area within cell + !a1 = (yCrn - yS)*(0.5*(xCrn + xS)) + !a2 = (yS - ySW)*(0.5*(xS + xSW)) + !a3 = (ySW - yW)*(0.5*(xSW + xW)) + !a4 = (yW - yCrn)*(0.5*(xW + xCrn)) + !aC = a1 + a2 + a3 + a4 + aC = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS)) + elseif (0.75*TwoPi <= theta .and. theta <= 1.00*TwoPi) then + xCrn = x(I-1,J); yCrn = y(I-1,J) + ! north area + !a1 = (yNE - yE)*(0.5*(xNE + xE)) + !a2 = (yE - yCrn)*(0.5*(xE + xCrn)) + !a3 = (yCrn - yN)*(0.5*(xCrn + xN)) + !a4 = (yN - yNE)*(0.5*(xN + xNE)) + !aN = a1 + a2 + a3 + a4 + aN = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN)) + ! northwest area + !a1 = (yN - yCrn)*(0.5*(xN + xCrn)) + !a2 = (yCrn - yW)*(0.5*(xCrn + xW)) + !a3 = (yW - yNW)*(0.5*(xW + xNW)) + !a4 = (yNW - yN)*(0.5*(xNW + xN)) + !aNW = a1 + a2 + a3 + a4 + aNW = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW)) + ! west area + !a1 = (yCrn - yS)*(0.5*(xCrn + xS)) + !a2 = (yS - ySW)*(0.5*(xS + xSW)) + !a3 = (ySW - yW)*(0.5*(xSW + xW)) + !a4 = (yW - yCrn)*(0.5*(xW + xCrn)) + !aW = a1 + a2 + a3 + a4 + aW = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS)) + ! area within cell + !a1 = (yE - ySE)*(0.5*(xE + xSE)) + !a2 = (ySE - yS)*(0.5*(xSE + xS)) + !a3 = (yS - yCrn)*(0.5*(xS + xCrn)) + !a4 = (yCrn - yE)*(0.5*(xCrn + xE)) + !aC = a1 + a2 + a3 + a4 + aC = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE)) + endif + + ! energy weighting ---------------------------------------- + a_total = (((aNE + aSW) + (aNW + aSE)) + ((aN + aS) + (aW + aE))) + aC + + E_new(m) = ( ( ( ( aNE*En(i+1,j+1) + aSW*En(i-1,j-1) ) + & + ( aNW*En(i-1,j+1) + aSE*En(i+1,j-1) ) ) + & + ( ( aN*En(i,j+1) + aS*En(i,j-1) ) + & + ( aW*En(i-1,j) + aE*En(i+1,j) ) ) ) + & + aC*En(i,j) ) / ( dx(i,j)*dy(i,j) ) + enddo ! m-loop + ! update energy in cell + En(i,j) = sum(E_new)/Nsubrays + enddo ; enddo +end subroutine propagate_corner_spread + +!> Propagates the internal wave energy in the logical x-direction. +subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, residual_loss) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & + intent(inout) :: En !< The energy density integrated over an angular + !! band [R Z3 T-2 ~> J m-2]. + real, dimension(G%IsdB:G%IedB,G%jsd:G%jed), & + intent(in) :: speed_x !< The magnitude of the group velocity at the + !! Cu points [L T-1 ~> m s-1]. + real, dimension(Nangle), intent(in) :: Cgx_av !< The average x-projection in each angular band [nondim] + real, dimension(Nangle), intent(in) :: dCgx !< The difference in x-projections between the + !! edges of each angular band [nondim]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & + intent(inout) :: residual_loss !< internal tide energy loss due + !! to the residual at slopes [R Z3 T-3 ~> W m-2]. + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + EnL, EnR ! Left and right face energy densities [R Z3 T-2 ~> J m-2]. + real, dimension(SZIB_(G),SZJ_(G)) :: & + flux_x ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + real, dimension(SZIB_(G)) :: & + cg_p, & ! The x-direction group velocity [L T-1 ~> m s-1] + flux1 ! A 1-d copy of the x-direction internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & + Fdt_m, Fdt_p! Left and right energy fluxes [R Z3 L2 T-2 ~> J] + integer :: i, j, ish, ieh, jsh, jeh, a + + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh + do a=1,Nangle + ! This sets EnL and EnR. + if (CS%upwind_1st) then + do j=jsh,jeh ; do i=ish-1,ieh+1 + EnL(i,j) = En(i,j,a) ; EnR(i,j) = En(i,j,a) + enddo ; enddo + else + call PPM_reconstruction_x(En(:,:,a), EnL, EnR, G, LB, simple_2nd=CS%simple_2nd) + endif + + do j=jsh,jeh + ! This is done once with single speed (GARDEN SPRINKLER EFFECT POSSIBLE) + do I=ish-1,ieh + cg_p(I) = speed_x(I,j) * (Cgx_av(a)) + enddo + call zonal_flux_En(cg_p, En(:,j,a), EnL(:,j), EnR(:,j), flux1, & + dt, G, US, j, ish, ieh, CS%vol_CFL) + do I=ish-1,ieh ; flux_x(I,j) = flux1(I); enddo + enddo + + do j=jsh,jeh ; do i=ish,ieh + Fdt_m(i,j,a) = dt*flux_x(I-1,j) ! left face influx [R Z3 L2 T-2 ~> J] + Fdt_p(i,j,a) = -dt*flux_x(I,j) ! right face influx [R Z3 L2 T-2 ~> J] + + residual_loss(i,j,a) = residual_loss(i,j,a) + & + (abs(flux_x(I-1,j)) * CS%residual(i,j) * G%IareaT(i,j) + & + abs(flux_x(I,j)) * CS%residual(i,j) * G%IareaT(i,j)) + enddo ; enddo + + enddo ! a-loop + + ! Only reflect newly arrived energy; existing energy in incident wedge is not reflected + ! and will eventually propagate out of cell. (This code only reflects if En > 0.) + call reflect(Fdt_m, Nangle, CS, G, LB) + !call teleport(Fdt_m, Nangle, CS, G, LB) + call reflect(Fdt_p, Nangle, CS, G, LB) + !call teleport(Fdt_p, Nangle, CS, G, LB) + + ! Update reflected energy [R Z3 T-2 ~> J m-2] + do a=1,Nangle ; do j=jsh,jeh ; do i=ish,ieh + ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) & ! for debugging + ! call MOM_error(FATAL, "propagate_x: OutFlux>Available") + En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)) + enddo ; enddo ; enddo + +end subroutine propagate_x + +!> Propagates the internal wave energy in the logical y-direction. +subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, residual_loss) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & + intent(inout) :: En !< The energy density integrated over an angular + !! band [R Z3 T-2 ~> J m-2]. + real, dimension(G%isd:G%ied,G%JsdB:G%JedB), & + intent(in) :: speed_y !< The magnitude of the group velocity at the + !! Cv points [L T-1 ~> m s-1]. + real, dimension(Nangle), intent(in) :: Cgy_av !< The average y-projection in each angular band. + real, dimension(Nangle), intent(in) :: dCgy !< The difference in y-projections between the + !! edges of each angular band. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & + intent(inout) :: residual_loss !< internal tide energy loss due + !! to the residual at slopes [R Z3 T-3 ~> W m-2]. + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + EnL, EnR ! South and north face energy densities [R Z3 T-2 ~> J m-2]. + real, dimension(SZI_(G),SZJB_(G)) :: & + flux_y ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + real, dimension(SZI_(G)) :: & + cg_p, & ! The y-direction group velocity [L T-1 ~> m s-1] + flux1 ! A 1-d copy of the y-direction internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & + Fdt_m, Fdt_p! South and north energy fluxes [R Z3 L2 T-2 ~> J] + integer :: i, j, ish, ieh, jsh, jeh, a + + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh + do a=1,Nangle + ! This sets EnL and EnR. + if (CS%upwind_1st) then + do j=jsh-1,jeh+1 ; do i=ish,ieh + EnL(i,j) = En(i,j,a) ; EnR(i,j) = En(i,j,a) + enddo ; enddo + else + call PPM_reconstruction_y(En(:,:,a), EnL, EnR, G, LB, simple_2nd=CS%simple_2nd) + endif + + do J=jsh-1,jeh + ! This is done once with single speed (GARDEN SPRINKLER EFFECT POSSIBLE) + do i=ish,ieh + cg_p(i) = speed_y(i,J) * (Cgy_av(a)) + enddo + call merid_flux_En(cg_p, En(:,:,a), EnL(:,:), EnR(:,:), flux1, & + dt, G, US, J, ish, ieh, CS%vol_CFL) + do i=ish,ieh ; flux_y(i,J) = flux1(i); enddo + enddo + + do j=jsh,jeh ; do i=ish,ieh + Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx [R Z3 L2 T-2 ~> J] + Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx [R Z3 L2 T-2 ~> J] + + residual_loss(i,j,a) = residual_loss(i,j,a) + & + (abs(flux_y(i,J-1)) * CS%residual(i,j) * G%IareaT(i,j) + & + abs(flux_y(i,J)) * CS%residual(i,j) * G%IareaT(i,j)) + + !if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) then ! for debugging + ! call MOM_error(WARNING, "propagate_y: OutFlux>Available prior to reflection", .true.) + ! write(mesg,*) "flux_y_south=",flux_y(i,J-1),"flux_y_north=",flux_y(i,J),"En=",En(i,j,a), & + ! "cn_south=", speed_y(i,J-1) * (Cgy_av(a)), "cn_north=", speed_y(i,J) * (Cgy_av(a)) + ! call MOM_error(WARNING, mesg, .true.) + !endif + enddo ; enddo + + enddo ! a-loop + + ! Only reflect newly arrived energy; existing energy in incident wedge is not reflected + ! and will eventually propagate out of cell. (This code only reflects if En > 0.) + call reflect(Fdt_m, Nangle, CS, G, LB) + !call teleport(Fdt_m, Nangle, CS, G, LB) + call reflect(Fdt_p, Nangle, CS, G, LB) + !call teleport(Fdt_p, Nangle, CS, G, LB) + + ! Update reflected energy [R Z3 T-2 ~> J m-2] + do a=1,Nangle ; do j=jsh,jeh ; do i=ish,ieh + ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) & ! for debugging + ! call MOM_error(FATAL, "propagate_y: OutFlux>Available", .true.) + En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)) + enddo ; enddo ; enddo + +end subroutine propagate_y + +!> Evaluates the zonal mass or volume fluxes in a layer. +subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, US, j, ish, ieh, vol_CFL) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZIB_(G)), intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G)), intent(in) :: h !< Energy density used to calculate the fluxes + !! [R Z3 T-2 ~> J m-2]. + real, dimension(SZI_(G)), intent(in) :: hL !< Left- Energy densities in the reconstruction + !! [R Z3 T-2 ~> J m-2]. + real, dimension(SZI_(G)), intent(in) :: hR !< Right- Energy densities in the reconstruction + !! [R Z3 T-2 ~> J m-2]. + real, dimension(SZIB_(G)), intent(inout) :: uh !< The zonal energy transport [R Z3 L2 T-3 ~> J s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: j !< The j-index to work on. + integer, intent(in) :: ish !< The start i-index range to work on. + integer, intent(in) :: ieh !< The end i-index range to work on. + logical, intent(in) :: vol_CFL !< If true, rescale the ratio of face areas to + !! the cell areas when estimating the CFL number. + ! Local variables + real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]. + real :: curv_3 ! A measure of the energy density curvature over a grid length [R Z3 T-2 ~> J m-2] + integer :: i + + do I=ish-1,ieh + ! Set new values of uh and duhdu. + if (u(I) > 0.0) then + if (vol_CFL) then ; CFL = (u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) + else ; CFL = u(I) * dt * G%IdxT(i,j) ; endif + curv_3 = (hL(i) + hR(i)) - 2.0*h(i) + uh(I) = G%dy_Cu(I,j) * u(I) * & + (hR(i) + CFL * (0.5*(hL(i) - hR(i)) + curv_3*(CFL - 1.5))) + elseif (u(I) < 0.0) then + if (vol_CFL) then ; CFL = (-u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) + else ; CFL = -u(I) * dt * G%IdxT(i+1,j) ; endif + curv_3 = (hL(i+1) + hR(i+1)) - 2.0*h(i+1) + uh(I) = G%dy_Cu(I,j) * u(I) * & + (hL(i+1) + CFL * (0.5*(hR(i+1)-hL(i+1)) + curv_3*(CFL - 1.5))) + else + uh(I) = 0.0 + endif + enddo +end subroutine zonal_flux_En + +!> Evaluates the meridional mass or volume fluxes in a layer. +subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G)), intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Energy density used to calculate the + !! fluxes [R Z3 T-2 ~> J m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hL !< Left- Energy densities in the + !! reconstruction [R Z3 T-2 ~> J m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hR !< Right- Energy densities in the + !! reconstruction [R Z3 T-2 ~> J m-2]. + real, dimension(SZI_(G)), intent(inout) :: vh !< The meridional energy transport [R Z3 L2 T-3 ~> J s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: J !< The j-index to work on. + integer, intent(in) :: ish !< The start i-index range to work on. + integer, intent(in) :: ieh !< The end i-index range to work on. + logical, intent(in) :: vol_CFL !< If true, rescale the ratio of face + !! areas to the cell areas when estimating + !! the CFL number. + ! Local variables + real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]. + real :: curv_3 ! A measure of the energy density curvature over a grid length [R Z3 T-2 ~> J m-2] + integer :: i + + do i=ish,ieh + if (v(i) > 0.0) then + if (vol_CFL) then ; CFL = (v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) + else ; CFL = v(i) * dt * G%IdyT(i,j) ; endif + curv_3 = (hL(i,j) + hR(i,j)) - 2.0*h(i,j) + vh(i) = G%dx_Cv(i,J) * v(i) * ( hR(i,j) + CFL * & + (0.5*(hL(i,j) - hR(i,j)) + curv_3*(CFL - 1.5)) ) + elseif (v(i) < 0.0) then + if (vol_CFL) then ; CFL = (-v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) + else ; CFL = -v(i) * dt * G%IdyT(i,j+1) ; endif + curv_3 = (hL(i,j+1) + hR(i,j+1)) - 2.0*h(i,j+1) + vh(i) = G%dx_Cv(i,J) * v(i) * ( hL(i,j+1) + CFL * & + (0.5*(hR(i,j+1)-hL(i,j+1)) + curv_3*(CFL - 1.5)) ) + else + vh(i) = 0.0 + endif + enddo +end subroutine merid_flux_En + +!> Reflection of the internal waves at a single frequency. +subroutine reflect(En, NAngle, CS, G, LB) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & + intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space and angular resolution + !! [R Z3 T-2 ~> J m-2]. + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + + ! Local variables + real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c + ! angle of boundary wrt equator [rad] + real, dimension(G%isd:G%ied,G%jsd:G%jed) :: part_refl + ! fraction of wave energy reflected + ! values should collocate with angle_c [nondim] + logical, dimension(G%isd:G%ied,G%jsd:G%jed) :: ridge + ! tags of cells with double reflection + real, dimension(1:Nangle) :: En_reflected ! Energy reflected [R Z3 T-2 ~> J m-2]. + + real :: TwoPi ! 2*pi = 6.2831853... [nondim] + real :: Angle_size ! size of beam wedge [rad] + integer :: angle_wall ! angle-bin of coast/ridge/shelf wrt equator + integer :: angle_wall0 ! angle-bin of coast/ridge/shelf wrt equator + integer :: angle_r ! angle-bin of reflected ray wrt equator + integer :: angle_r0 ! angle-bin of reflected ray wrt equator + integer :: angle_to_wall ! angle-bin relative to wall + integer :: a, a0 ! loop index for angles + integer :: i, j + integer :: Nangle_d2 ! Nangle / 2 + integer :: isc, iec, jsc, jec ! start and end local indices on PE + ! (values exclude halos) + integer :: ish, ieh, jsh, jeh ! start and end local indices on data domain + ! leaving out outdated halo points (march in) + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh + + TwoPi = 8.0*atan(1.0) + Angle_size = TwoPi / (real(NAngle)) + Nangle_d2 = (Nangle / 2) + + ! init local arrays + angle_c(:,:) = CS%nullangle + part_refl(:,:) = 0. + ridge(:,:) = .false. + + do j=jsh,jeh ; do i=ish,ieh + if (CS%refl_angle(i,j) /= CS%nullangle) then + angle_c(i,j) = mod(CS%refl_angle(i,j) + TwoPi, TwoPi) + endif + part_refl(i,j) = CS%refl_pref(i,j) + ridge(i,j) = CS%refl_dbl(i,j) + enddo ; enddo + En_reflected(:) = 0.0 + + do j=jsh,jeh ; do i=ish,ieh + ! redistribute energy in angular space if ray will hit boundary + ! i.e., if energy is in a reflecting cell + if (angle_c(i,j) /= CS%nullangle) then + ! refection angle is given in rad, convert to the discrete angle + angle_wall = nint(angle_c(i,j)/Angle_size) + 1 + do a=1,NAngle ; if (En(i,j,a) > 0.0) then + ! reindex to 0 -> Nangle-1 for trig + a0 = a - 1 + angle_wall0 = angle_wall - 1 + ! compute relative angle from wall and use cyclic properties + ! to ensure it is bounded by 0 -> Nangle-1 + angle_to_wall = mod((a0 - angle_wall0) + Nangle, Nangle) + + if (ridge(i,j)) then + ! if ray is not incident but in ridge cell, use complementary angle + if ((Nangle_d2 < angle_to_wall) .and. (angle_to_wall < Nangle)) then + angle_wall0 = mod(angle_wall0 + (Nangle_d2 + Nangle), Nangle) + endif + endif + + ! do reflection + if ((0 < angle_to_wall) .and. (angle_to_wall < Nangle_d2)) then + angle_r0 = mod(2*angle_wall0 - a0 + Nangle, Nangle) + angle_r = angle_r0 + 1 !re-index to 1 -> Nangle + if (a /= angle_r) then + En_reflected(angle_r) = part_refl(i,j)*En(i,j,a) + En(i,j,a) = (1.0-part_refl(i,j))*En(i,j,a) + endif + endif + endif ; enddo ! a-loop + do a=1,NAngle + En(i,j,a) = En(i,j,a) + En_reflected(a) + En_reflected(a) = 0.0 ! reset values + enddo ! a-loop + endif + enddo ; enddo ! i- and j-loops + + ! Check to make sure no energy gets onto land (only run for debugging) + ! do a=1,NAngle ; do j=jsc,jec ; do i=isc,iec + ! if (En(i,j,a) > 0.001 .and. G%mask2dT(i,j) == 0) then + ! write (mesg,*) 'En=', En(i,j,a), 'a=', a, 'ig_g=',i+G%idg_offset, 'jg_g=',j+G%jdg_offset + ! call MOM_error(FATAL, "reflect: Energy detected out of bounds: "//trim(mesg), .true.) + ! endif + ! enddo ; enddo ; enddo + +end subroutine reflect + +!> Moves energy across lines of partial reflection to prevent +!! reflection of energy that is supposed to get across. +subroutine teleport(En, NAngle, CS, G, LB) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & + intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space and angular resolution + !! [R Z3 T-2 ~> J m-2]. + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + ! Local variables + real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c + ! angle of boundary wrt equator [rad] + real, dimension(G%isd:G%ied,G%jsd:G%jed) :: part_refl + ! fraction of wave energy reflected + ! values should collocate with angle_c [nondim] + logical, dimension(G%isd:G%ied,G%jsd:G%jed) :: pref_cell + ! flag for partial reflection + logical, dimension(G%isd:G%ied,G%jsd:G%jed) :: ridge + ! tags of cells with double reflection + real :: TwoPi ! 2*pi = 6.2831853... [nondim] + real :: Angle_size ! size of beam wedge [rad] + real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator [rad] + real, dimension(1:NAngle) :: cos_angle ! Cosine of the beam angle relative to eastward [nondim] + real, dimension(1:NAngle) :: sin_angle ! Sine of the beam angle relative to eastward [nondim] + real :: En_tele ! energy to be "teleported" [R Z3 T-2 ~> J m-2] + character(len=160) :: mesg ! The text of an error message + integer :: i, j, a + integer :: ish, ieh, jsh, jeh ! start and end local indices on data domain + ! leaving out outdated halo points (march in) + integer :: id_g, jd_g ! global (decomposition-invariant) indices + integer :: jos, ios ! offsets + real :: cos_normal, sin_normal ! cos/sin of cross-ridge normal direction [nondim] + real :: angle_wall ! The coastline angle or the complementary angle [radians] + + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh + + TwoPi = 8.0*atan(1.0) + Angle_size = TwoPi / (real(NAngle)) + + do a=1,Nangle + ! These are the angles at the cell centers + ! (should do this elsewhere since doesn't change with time) + angle_i(a) = Angle_size * real(a - 1) ! for a=1 aligned with x-axis + cos_angle(a) = cos(angle_i(a)) ; sin_angle(a) = sin(angle_i(a)) + enddo + + angle_c = CS%refl_angle + part_refl = CS%refl_pref + pref_cell = CS%refl_pref_logical + ridge = CS%refl_dbl + + do j=jsh,jeh + do i=ish,ieh + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset + if (pref_cell(i,j)) then + do a=1,Nangle + if (En(i,j,a) > 0) then + ! if ray is incident, keep specified boundary angle + if (sin(angle_i(a) - angle_c(i,j)) >= 0.0) then + angle_wall = angle_c(i,j) + ! if ray is not incident but in ridge cell, use complementary angle + elseif (ridge(i,j)) then + angle_wall = angle_c(i,j) + 0.5*TwoPi + ! if ray is not incident and not in a ridge cell, keep specified angle + else + angle_wall = angle_c(i,j) + endif + ! teleport if incident + if (sin(angle_i(a) - angle_wall) >= 0.0) then + En_tele = En(i,j,a) + cos_normal = cos(angle_wall + 0.25*TwoPi) + sin_normal = sin(angle_wall + 0.25*TwoPi) + ! find preferred zonal offset based on shelf/ridge angle + ios = int(sign(1.,cos_normal)) + ! find preferred meridional offset based on shelf/ridge angle + jos = int(sign(1.,sin_normal)) + ! find receptive ocean cell in direction of offset + if (.not. pref_cell(i+ios,j+jos)) then + En(i,j,a) = En(i,j,a) - En_tele + En(i+ios,j+jos,a) = En(i+ios,j+jos,a) + En_tele + else + write(mesg,*) 'idg=',id_g,'jd_g=',jd_g,'a=',a + call MOM_error(FATAL, "teleport: no receptive ocean cell at "//trim(mesg), .true.) + endif + endif ! incidence check + endif ! energy check + enddo ! a-loop + endif ! pref check + enddo ! i-loop + enddo ! j-loop + +end subroutine teleport + +!> Rotates points in the halos where required to accommodate +!! changes in grid orientation, such as at the tripolar fold. +subroutine correct_halo_rotation(En, test, G, NAngle, halo) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(:,:,:,:,:), intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space, angular orientation, frequency, + !! and vertical mode [R Z3 T-2 ~> J m-2]. + real, dimension(SZI_(G),SZJ_(G),2), & + intent(in) :: test !< An x-unit vector that has been passed through + !! the halo updates, to enable the rotation of the + !! wave energies in the halo region to be corrected [nondim]. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + integer, intent(in) :: halo !< The halo size over which to do the calculations + ! Local variables + real, dimension(G%isd:G%ied,NAngle) :: En2d ! A zonal row of the internal gravity wave energy density + ! in a frequency band and mode [R Z3 T-2 ~> J m-2]. + integer, dimension(G%isd:G%ied) :: a_shift + integer :: i_first, i_last, a_new + integer :: a, i, j, ish, ieh, jsh, jeh, m, fr + character(len=160) :: mesg ! The text of an error message + ish = G%isc-halo ; ieh = G%iec+halo ; jsh = G%jsc-halo ; jeh = G%jec+halo + + do j=jsh,jeh + i_first = ieh+1 ; i_last = ish-1 + do i=ish,ieh + a_shift(i) = 0 + if (test(i,j,1) /= 1.0) then + if (ii_last) i_last = i + + if (test(i,j,1) == -1.0) then ; a_shift(i) = nAngle/2 + elseif (test(i,j,2) == 1.0) then ; a_shift(i) = -nAngle/4 + elseif (test(i,j,2) == -1.0) then ; a_shift(i) = nAngle/4 + else + write(mesg,'("Unrecognized rotation test vector ",2ES9.2," at ",F7.2," E, ",& + &F7.2," N; i,j=",2i4)') & + test(i,j,1), test(i,j,2), G%GeoLonT(i,j), G%GeoLatT(i,j), i, j + call MOM_error(FATAL, mesg) + endif + endif + enddo + + if (i_first <= i_last) then + ! At least one point in this row needs to be rotated. + do m=1,size(En,5) ; do fr=1,size(En,4) + do a=1,nAngle ; do i=i_first,i_last ; if (a_shift(i) /= 0) then + a_new = a + a_shift(i) + if (a_new < 1) a_new = a_new + nAngle + if (a_new > nAngle) a_new = a_new - nAngle + En2d(i,a_new) = En(i,j,a,fr,m) + endif ; enddo ; enddo + do a=1,nAngle ; do i=i_first,i_last ; if (a_shift(i) /= 0) then + En(i,j,a,fr,m) = En2d(i,a) + endif ; enddo ; enddo + enddo ; enddo + endif + enddo +end subroutine correct_halo_rotation + +!> Calculates left/right edge values for PPM reconstruction in x-direction. +subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] + type(loop_bounds_type), intent(in) :: LB !< A structure with the active loop bounds. + logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean + !! energy densities as default edge values + !! for a simple 2nd order scheme. + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width [R Z3 T-2 ~> J m-2] + real, parameter :: oneSixth = 1./6. ! One sixth [nondim] + real :: h_ip1, h_im1 ! The energy densities at adjacent points [R Z3 T-2 ~> J m-2] + real :: dMx, dMn ! The maximum and minimum of values of energy density at adjacent points + ! relative to the center point [R Z3 T-2 ~> J m-2] + character(len=256) :: mesg ! The text of an error message + integer :: i, j, isl, iel, jsl, jel, stencil + + isl = LB%ish-1 ; iel = LB%ieh+1 ; jsl = LB%jsh ; jel = LB%jeh + + ! This is the stencil of the reconstruction, not the scheme overall. + stencil = 2 ; if (simple_2nd) stencil = 1 + + if ((isl-stencil < G%isd) .or. (iel+stencil > G%ied)) then + write(mesg,'("In MOM_internal_tides, PPM_reconstruction_x called with a ", & + & "x-halo that needs to be increased by ",i2,".")') & + stencil + max(G%isd-isl,iel-G%ied) + call MOM_error(FATAL,mesg) + endif + if ((jsl < G%jsd) .or. (jel > G%jed)) then + write(mesg,'("In MOM_internal_tides, PPM_reconstruction_x called with a ", & + & "y-halo that needs to be increased by ",i2,".")') & + max(G%jsd-jsl,jel-G%jed) + call MOM_error(FATAL,mesg) + endif + + if (simple_2nd) then + do j=jsl,jel ; do i=isl,iel + h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j) + h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j) + h_l(i,j) = 0.5*( h_im1 + h_in(i,j) ) + h_r(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + enddo ; enddo + else + do j=jsl,jel ; do i=isl-1,iel+1 + if ((G%mask2dT(i-1,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) == 0.0) then + slp(i,j) = 0.0 + else + ! This uses a simple 2nd order slope. + slp(i,j) = 0.5 * (h_in(i+1,j) - h_in(i-1,j)) + ! Monotonic constraint, see Eq. B2 in Lin 1994, MWR (132) + dMx = max(h_in(i+1,j), h_in(i-1,j), h_in(i,j)) - h_in(i,j) + dMn = h_in(i,j) - min(h_in(i+1,j), h_in(i-1,j), h_in(i,j)) + slp(i,j) = sign(1.,slp(i,j)) * min(abs(slp(i,j)), 2. * min(dMx, dMn)) + ! * (G%mask2dT(i-1,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) + endif + enddo ; enddo + + do j=jsl,jel ; do i=isl,iel + ! Neighboring values should take into account any boundaries. The 3 + ! following sets of expressions are equivalent. + ! h_im1 = h_in(i-1,j,k) ; if (G%mask2dT(i-1,j) < 0.5) h_im1 = h_in(i,j) + ! h_ip1 = h_in(i+1,j,k) ; if (G%mask2dT(i+1,j) < 0.5) h_ip1 = h_in(i,j) + h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j) + h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j) + ! Left/right values following Eq. B2 in Lin 1994, MWR (132) + h_l(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) ) + h_r(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) ) + enddo ; enddo + endif + + call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) +end subroutine PPM_reconstruction_x + +!> Calculates left/right edge valus for PPM reconstruction in y-direction. +subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] + type(loop_bounds_type), intent(in) :: LB !< A structure with the active loop bounds. + logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean + !! energy densities as default edge values + !! for a simple 2nd order scheme. + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width [R Z3 T-2 ~> J m-2] + real, parameter :: oneSixth = 1./6. ! One sixth [nondim] + real :: h_jp1, h_jm1 ! The energy densities at adjacent points [R Z3 T-2 ~> J m-2] + real :: dMx, dMn ! The maximum and minimum of values of energy density at adjacent points + ! relative to the center point [R Z3 T-2 ~> J m-2] + character(len=256) :: mesg ! The text of an error message + integer :: i, j, isl, iel, jsl, jel, stencil + + isl = LB%ish ; iel = LB%ieh ; jsl = LB%jsh-1 ; jel = LB%jeh+1 + + ! This is the stencil of the reconstruction, not the scheme overall. + stencil = 2 ; if (simple_2nd) stencil = 1 + + if ((isl < G%isd) .or. (iel > G%ied)) then + write(mesg,'("In MOM_internal_tides, PPM_reconstruction_y called with a ", & + & "x-halo that needs to be increased by ",i2,".")') & + max(G%isd-isl,iel-G%ied) + call MOM_error(FATAL,mesg) + endif + if ((jsl-stencil < G%jsd) .or. (jel+stencil > G%jed)) then + write(mesg,'("In MOM_internal_tides, PPM_reconstruction_y called with a ", & + & "y-halo that needs to be increased by ",i2,".")') & + stencil + max(G%jsd-jsl,jel-G%jed) + call MOM_error(FATAL,mesg) + endif + + if (simple_2nd) then + do j=jsl,jel ; do i=isl,iel + h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j) + h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j) + h_l(i,j) = 0.5*( h_jm1 + h_in(i,j) ) + h_r(i,j) = 0.5*( h_jp1 + h_in(i,j) ) + enddo ; enddo + else + do j=jsl-1,jel+1 ; do i=isl,iel + if ((G%mask2dT(i,j-1) * G%mask2dT(i,j) * G%mask2dT(i,j+1)) == 0.0) then + slp(i,j) = 0.0 + else + ! This uses a simple 2nd order slope. + slp(i,j) = 0.5 * (h_in(i,j+1) - h_in(i,j-1)) + ! Monotonic constraint, see Eq. B2 in Lin 1994, MWR (132) + dMx = max(h_in(i,j+1), h_in(i,j-1), h_in(i,j)) - h_in(i,j) + dMn = h_in(i,j) - min(h_in(i,j+1), h_in(i,j-1), h_in(i,j)) + slp(i,j) = sign(1.,slp(i,j)) * min(abs(slp(i,j)), 2. * min(dMx, dMn)) + ! * (G%mask2dT(i,j-1) * G%mask2dT(i,j) * G%mask2dT(i,j+1)) + endif + enddo ; enddo + + do j=jsl,jel ; do i=isl,iel + ! Neighboring values should take into account any boundaries. The 3 + ! following sets of expressions are equivalent. + h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j) + h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j) + ! Left/right values following Eq. B2 in Lin 1994, MWR (132) + h_l(i,j) = 0.5*( h_jm1 + h_in(i,j) ) + oneSixth*( slp(i,j-1) - slp(i,j) ) + h_r(i,j) = 0.5*( h_jp1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i,j+1) ) + enddo ; enddo + endif + + call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) +end subroutine PPM_reconstruction_y + +!> Limits the left/right edge values of the PPM reconstruction +!! to give a reconstruction that is positive-definite. Here this is +!! reinterpreted as giving a constant value if the mean value is less +!! than h_min, with a minimum of h_min otherwise. +subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in each sector (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value of reconstruction [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value of reconstruction [R Z3 T-2 ~> J m-2] + real, intent(in) :: h_min !< The minimum value that can be + !! obtained by a concave parabolic fit [R Z3 T-2 ~> J m-2] + integer, intent(in) :: iis !< Start i-index for computations + integer, intent(in) :: iie !< End i-index for computations + integer, intent(in) :: jis !< Start j-index for computations + integer, intent(in) :: jie !< End j-index for computations + ! Local variables + real :: curv ! The cell-area normalized curvature [R Z3 T-2 ~> J m-2] + real :: dh ! The difference between the edge values [R Z3 T-2 ~> J m-2] + real :: scale ! A rescaling factor used to give a minimum cell value of at least h_min [nondim] + integer :: i, j + + do j=jis,jie ; do i=iis,iie + ! This limiter prevents undershooting minima within the domain with + ! values less than h_min. + curv = 3.0*((h_L(i,j) + h_R(i,j)) - 2.0*h_in(i,j)) + if (curv > 0.0) then ! Only minima are limited. + dh = h_R(i,j) - h_L(i,j) + if (abs(dh) < curv) then ! The parabola's minimum is within the cell. + if (h_in(i,j) <= h_min) then + h_L(i,j) = h_in(i,j) ; h_R(i,j) = h_in(i,j) + elseif (12.0*curv*(h_in(i,j) - h_min) < (curv**2 + 3.0*dh**2)) then + ! The minimum value is h_in - (curv^2 + 3*dh^2)/(12*curv), and must + ! be limited in this case. 0 < scale < 1. + scale = 12.0*curv*(h_in(i,j) - h_min) / (curv**2 + 3.0*dh**2) + h_L(i,j) = h_in(i,j) + scale*(h_L(i,j) - h_in(i,j)) + h_R(i,j) = h_in(i,j) + scale*(h_R(i,j) - h_in(i,j)) + endif + endif + endif + enddo ; enddo +end subroutine PPM_limit_pos + +subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(int_tide_CS), pointer :: CS !< Internal tide control structure + type(MOM_restart_CS), pointer :: restart_CS !< MOM restart control structure + + ! This subroutine is used to allocate and register any fields in this module + ! that should be written to or read from the restart file. + logical :: use_int_tides + integer :: num_freq, num_angle , num_mode, period_1 + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, i, j, a, fr + character(64) :: var_name, cfr + + type(axis_info) :: axes_inttides(2) + real, dimension(:), allocatable :: angles, freqs + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (associated(CS)) then + call MOM_error(WARNING, "register_int_tide_restarts called "//& + "with an associated control structure.") + return + endif + + allocate(CS) + + ! write extra axes + call get_param(param_file, "MOM", "INTERNAL_TIDE_ANGLES", num_angle, default=24) + call get_param(param_file, "MOM", "INTERNAL_TIDE_FREQS", num_freq, default=1) + call get_param(param_file, "MOM", "INTERNAL_TIDE_MODES", num_mode, default=1) + + allocate (angles(num_angle)) + allocate (freqs(num_freq)) + + do a=1,num_angle ; angles(a)= a ; enddo + do fr=1,num_freq ; freqs(fr)= fr ; enddo + + call set_axis_info(axes_inttides(1), "angle", "", "angle direction", num_angle, angles, "N", 1) + call set_axis_info(axes_inttides(2), "freq", "", "wave frequency", num_freq, freqs, "N", 1) + + ! full energy array + allocate(CS%En(isd:ied, jsd:jed, num_angle, num_freq, num_mode), source=0.0) + + ! restart strategy: support for 5d restart is not yet available so we split into + ! 4d restarts. Vertical modes >= 6 are dissipated locally and do not propagate + ! so we only allow for 5 vertical modes and each has its own variable + + ! allocate restart arrays + allocate(CS%En_restart_mode1(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 2) allocate(CS%En_restart_mode2(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 3) allocate(CS%En_restart_mode3(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 4) allocate(CS%En_restart_mode4(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 5) allocate(CS%En_restart_mode5(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + + ! register all 4d restarts and copy into full Energy array when restarting from previous state + call register_restart_field(CS%En_restart_mode1(:,:,:,:), "IW_energy_mode1", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 1", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) + + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + if (num_mode >= 2) then + call register_restart_field(CS%En_restart_mode2(:,:,:,:), "IW_energy_mode2", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 2", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) + + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + endif + + if (num_mode >= 3) then + call register_restart_field(CS%En_restart_mode3(:,:,:,:), "IW_energy_mode3", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 3", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) + + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + endif + + if (num_mode >= 4) then + call register_restart_field(CS%En_restart_mode4(:,:,:,:), "IW_energy_mode4", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 4", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) + + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + endif + + if (num_mode >= 5) then + call register_restart_field(CS%En_restart_mode5(:,:,:,:), "IW_energy_mode5", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 5", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) + + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + endif + +end subroutine register_int_tide_restarts + +!> This subroutine initializes the internal tides module. +subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) + type(time_type), target, intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(int_tide_CS), pointer :: CS !< Internal tide control structure + + ! Local variables + real :: Angle_size ! size of wedges [rad] + real, allocatable :: angles(:) ! orientations of wedge centers [rad] + real, dimension(:,:), allocatable :: h2 ! topographic roughness scale squared [Z2 ~> m2] + real :: kappa_itides ! characteristic topographic wave number [L-1 ~> m-1] + real, dimension(:,:), allocatable :: ridge_temp ! array for temporary storage of flags + ! of cells with double-reflecting ridges [nondim] + logical :: use_int_tides, use_temperature + real :: IGW_c1_thresh ! A threshold first mode internal wave speed below which all higher + ! mode speeds are not calculated but simply assigned a speed of 0 [L T-1 ~> m s-1]. + real :: kappa_h2_factor ! A roughness scaling factor [nondim] + real :: RMS_roughness_frac ! The maximum RMS topographic roughness as a fraction of the + ! nominal ocean depth, or a negative value for no limit [nondim] + real :: period_1 ! The period of the gravest modeled mode [T ~> s] + real :: period ! A tidal period read from namelist [T ~> s] + integer :: num_angle, num_freq, num_mode, m, fr + integer :: isd, ied, jsd, jed, a, id_ang, i, j, nz + type(axes_grp) :: axes_ang + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_internal_tides" ! This module's name. + character(len=16), dimension(8) :: freq_name + character(len=40) :: var_name + character(len=160) :: var_descript + character(len=200) :: filename + character(len=200) :: refl_angle_file + character(len=200) :: refl_pref_file, refl_dbl_file, trans_file + character(len=200) :: h2_file + character(len=80) :: rough_var ! Input file variable names + + character(len=240), dimension(:), allocatable :: energy_fractions + character(len=240) :: periods + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + nz = GV%ke + + CS%initialized = .true. + + use_int_tides = .false. + call read_param(param_file, "INTERNAL_TIDES", use_int_tides) + CS%do_int_tides = use_int_tides + if (.not.use_int_tides) return + + use_temperature = .true. + call read_param(param_file, "ENABLE_THERMODYNAMICS", use_temperature) + if (.not.use_temperature) call MOM_error(FATAL, & + "internal_tides_init: internal_tides only works with ENABLE_THERMODYNAMICS defined.") + + ! Set number of frequencies, angles, and modes to consider + num_freq = 1 ; num_angle = 24 ; num_mode = 1 + call read_param(param_file, "INTERNAL_TIDE_FREQS", num_freq) + call read_param(param_file, "INTERNAL_TIDE_ANGLES", num_angle) + call read_param(param_file, "INTERNAL_TIDE_MODES", num_mode) + if (.not.((num_freq > 0) .and. (num_angle > 0) .and. (num_mode > 0))) return + CS%nFreq = num_freq ; CS%nAngle = num_angle ; CS%nMode = num_mode + + allocate(energy_fractions(num_freq)) + allocate(CS%fraction_tidal_input(num_freq,num_mode)) + + call read_param(param_file, "ENERGY_FRACTION_PER_MODE", energy_fractions) + + do fr=1,num_freq ; do m=1,num_mode + CS%fraction_tidal_input(fr,m) = extract_real(energy_fractions(fr), " ,", m, 0.) + enddo ; enddo + + ! Allocate phase speed array + allocate(CS%cp(isd:ied, jsd:jed, num_freq, num_mode), source=0.0) + + ! Allocate and populate frequency array (each a multiple of first for now) + allocate(CS%frequency(num_freq)) + + + ! The periods of the tidal constituents for internal tides raytracing + call read_param(param_file, "TIDAL_PERIODS", periods) + + do fr=1,num_freq + period = extract_real(periods, " ,", fr, 0.) + if (period == 0.) call MOM_error(FATAL, "MOM_internal_tides: invalid tidal period") + CS%frequency(fr) = 8.0*atan(1.0)/period + enddo + + ! Read all relevant parameters and write them to the model log. + + CS%Time => Time ! direct a pointer to the current model time target + + call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") + CS%inputdir = slasher(CS%inputdir) + + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "INTERNAL_TIDE_FREQS", num_freq, & + "The number of distinct internal tide frequency bands "//& + "that will be calculated.", default=1) + call get_param(param_file, mdl, "INTERNAL_TIDE_MODES", num_mode, & + "The number of distinct internal tide modes "//& + "that will be calculated.", default=1) + call get_param(param_file, mdl, "INTERNAL_TIDE_ANGLES", num_angle, & + "The number of angular resolution bands for the internal "//& + "tide calculations.", default=24) + + if (use_int_tides) then + if ((num_freq <= 0) .and. (num_mode <= 0) .and. (num_angle <= 0)) then + call MOM_error(WARNING, "Internal tides were enabled, but the number "//& + "of requested frequencies, modes and angles were not all positive.") + return + endif + else + if ((num_freq > 0) .and. (num_mode > 0) .and. (num_angle > 0)) then + call MOM_error(WARNING, "Internal tides were not enabled, even though "//& + "the number of requested frequencies, modes and angles were all "//& + "positive.") + return + endif + endif + + if (CS%NFreq /= num_freq) call MOM_error(FATAL, "Internal_tides_init: "//& + "Inconsistent number of frequencies.") + if (CS%NAngle /= num_angle) call MOM_error(FATAL, "Internal_tides_init: "//& + "Inconsistent number of angles.") + if (CS%nMode /= num_mode) call MOM_error(FATAL, "Internal_tides_init: "//& + "Inconsistent number of modes.") + if (4*(num_angle/4) /= num_angle) call MOM_error(FATAL, & + "Internal_tides_init: INTERNAL_TIDE_ANGLES must be a multiple of 4.") + + CS%diag => diag + + call get_param(param_file, mdl, "INTERNAL_TIDE_DECAY_RATE", CS%decay_rate, & + "The rate at which internal tide energy is lost to the "//& + "interior ocean internal wave field.", & + units="s-1", default=0.0, scale=US%T_to_s) + call get_param(param_file, mdl, "INTERNAL_TIDE_VOLUME_BASED_CFL", CS%vol_CFL, & + "If true, use the ratio of the open face lengths to the "//& + "tracer cell areas when estimating CFL numbers in the "//& + "internal tide code.", default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_CORNER_ADVECT", CS%corner_adv, & + "If true, internal tide ray-tracing advection uses a "//& + "corner-advection scheme rather than PPM.", default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_SIMPLE_2ND_PPM", CS%simple_2nd, & + "If true, CONTINUITY_PPM uses a simple 2nd order "//& + "(arithmetic mean) interpolation of the edge values. "//& + "This may give better PV conservation properties. While "//& + "it formally reduces the accuracy of the continuity "//& + "solver itself in the strongly advective limit, it does "//& + "not reduce the overall order of accuracy of the dynamic "//& + "core.", default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_UPWIND_1ST", CS%upwind_1st, & + "If true, the internal tide ray-tracing advection uses "//& + "1st-order upwind advection. This scheme is highly "//& + "continuity solver. This scheme is highly "//& + "diffusive but may be useful for debugging.", default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_BACKGROUND_DRAG", CS%apply_background_drag, & + "If true, the internal tide ray-tracing advection uses a background drag "//& + "term as a sink.", default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_QUAD_DRAG", CS%apply_bottom_drag, & + "If true, the internal tide ray-tracing advection uses "//& + "a quadratic bottom drag term as a sink.", default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_WAVE_DRAG", CS%apply_wave_drag, & + "If true, apply scattering due to small-scale roughness as a sink.", & + default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_RESIDUAL_DRAG", CS%apply_residual_drag, & + "If true, TBD", & + default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_DRAG_MIN_DEPTH", CS%drag_min_depth, & + "The minimum total ocean thickness that will be used in the denominator "//& + "of the quadratic drag terms for internal tides.", & + units="m", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%apply_bottom_drag) + CS%drag_min_depth = MAX(CS%drag_min_depth, GV%H_subroundoff) + call get_param(param_file, mdl, "INTERNAL_TIDE_FROUDE_DRAG", CS%apply_Froude_drag, & + "If true, apply wave breaking as a sink.", & + default=.false.) + call get_param(param_file, mdl, "EN_CHECK_TOLERANCE", CS%En_check_tol, & + "An energy density tolerance for flagging points with an imbalance in the "//& + "internal tide energy budget when INTERNAL_TIDE_FROUDE_DRAG is True.", & + units="J m-2", default=1.0e-10, scale=US%W_m2_to_RZ3_T3*US%s_to_T, & + do_not_log=.not.CS%apply_Froude_drag) + call get_param(param_file, mdl, "CDRAG", CS%cdrag, & + "CDRAG is the drag coefficient relating the magnitude of "//& + "the velocity field to the bottom stress.", & + units="nondim", default=0.003) + call get_param(param_file, mdl, "INTERNAL_WAVE_CG1_THRESH", IGW_c1_thresh, & + "A minimal value of the first mode internal wave speed below which all higher "//& + "mode speeds are not calculated but are simply reported as 0. This must be "//& + "non-negative for the wave_speeds routine to be used.", & + units="m s-1", default=0.01, scale=US%m_s_to_L_T) + + call get_param(param_file, mdl, "UNIFORM_TEST_CG", CS%uniform_test_cg, & + "If positive, a uniform group velocity of internal tide for test case", & + default=-1., units="m s-1", scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "INTERNAL_TIDE_ENERGIZED_ANGLE", CS%energized_angle, & + "If positive, only one angular band of the internal tides "//& + "gets all of the energy. (This is for debugging.)", default=-1) + call get_param(param_file, mdl, "USE_PPM_ANGULAR", CS%use_PPMang, & + "If true, use PPM for advection of energy in angular space.", & + default=.false.) + call get_param(param_file, mdl, "GAMMA_ITIDES", CS%q_itides, & + "The fraction of the internal tidal energy that is "//& + "dissipated locally with INT_TIDE_DISSIPATION. "//& + "THIS NAME COULD BE BETTER.", & + units="nondim", default=0.3333) + call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & + "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& + "The default is 2pi/10 km, as in St.Laurent et al. 2002.", & + units="m-1", default=8.e-4*atan(1.0), scale=US%L_to_m) + call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & + "A scaling factor for the roughness amplitude with "//& + "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) + + ! Allocate various arrays needed for loss rates + allocate(h2(isd:ied,jsd:jed), source=0.0) + allocate(CS%TKE_itidal_loss_fixed(isd:ied,jsd:jed), source=0.0) + allocate(CS%TKE_leak_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) + allocate(CS%TKE_quad_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) + allocate(CS%TKE_itidal_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) + allocate(CS%TKE_Froude_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) + allocate(CS%TKE_residual_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) + allocate(CS%tot_leak_loss(isd:ied,jsd:jed), source=0.0) + allocate(CS%tot_quad_loss(isd:ied,jsd:jed), source=0.0) + allocate(CS%tot_itidal_loss(isd:ied,jsd:jed), source=0.0) + allocate(CS%tot_Froude_loss(isd:ied,jsd:jed), source=0.0) + allocate(CS%tot_residual_loss(isd:ied,jsd:jed), source=0.0) + allocate(CS%u_struct_bot(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%u_struct_max(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%int_w2(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%int_U2(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%int_N2w2(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%w_struct(isd:ied,jsd:jed,1:nz+1,num_mode), source=0.0) + allocate(CS%u_struct(isd:ied,jsd:jed,1:nz,num_mode), source=0.0) + + ! Compute the fixed part of the bottom drag loss from baroclinic modes + call get_param(param_file, mdl, "H2_FILE", h2_file, & + "The path to the file containing the sub-grid-scale "//& + "topographic roughness amplitude with INT_TIDE_DISSIPATION.", & + fail_if_missing=.true.) + filename = trim(CS%inputdir) // trim(h2_file) + call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) + call get_param(param_file, mdl, "ROUGHNESS_VARNAME", rough_var, & + "The name in the input file of the squared sub-grid-scale "//& + "topographic roughness amplitude variable.", default="h2") + call get_param(param_file, mdl, "INTERNAL_TIDE_ROUGHNESS_FRAC", RMS_roughness_frac, & + "The maximum RMS topographic roughness as a fraction of the nominal ocean depth, "//& + "or a negative value for no limit.", units="nondim", default=0.1) + + call MOM_read_data(filename, rough_var, h2, G%domain, scale=US%m_to_Z**2) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! Restrict RMS topographic roughness to a fraction (10 percent by default) of the column depth. + if (RMS_roughness_frac >= 0.0) then + h2(i,j) = max(min((RMS_roughness_frac*(G%bathyT(i,j)+G%Z_ref))**2, h2(i,j)), 0.0) + else + h2(i,j) = max(h2(i,j), 0.0) + endif + ! Compute the fixed part; units are [R Z4 H-1 L-2 ~> kg m-2 or m] here + ! will be multiplied by N and the squared near-bottom velocity (and by the + ! near-bottom density in non-Boussinesq mode) to get into [R Z3 T-3 ~> W m-2] + CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor* GV%H_to_RZ * US%L_to_Z*kappa_itides * h2(i,j) + enddo ; enddo + + deallocate(h2) + + ! Read in prescribed coast/ridge/shelf angles from file + call get_param(param_file, mdl, "REFL_ANGLE_FILE", refl_angle_file, & + "The path to the file containing the local angle of "//& + "the coastline/ridge/shelf with respect to the equator.", & + fail_if_missing=.false., default='') + filename = trim(CS%inputdir) // trim(refl_angle_file) + allocate(CS%refl_angle(isd:ied,jsd:jed), source=CS%nullangle) + if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/REFL_ANGLE_FILE", filename) + call MOM_read_data(filename, 'refl_angle', CS%refl_angle, G%domain) + else + if (trim(refl_angle_file) /= '' ) call MOM_error(FATAL, & + "REFL_ANGLE_FILE: "//trim(filename)//" not found") + endif + ! replace NaNs with null value + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle + enddo ; enddo + call pass_var(CS%refl_angle, G%domain) + + ! Read in prescribed partial reflection coefficients from file + call get_param(param_file, mdl, "REFL_PREF_FILE", refl_pref_file, & + "The path to the file containing the reflection coefficients.", & + fail_if_missing=.false., default='') + filename = trim(CS%inputdir) // trim(refl_pref_file) + allocate(CS%refl_pref(isd:ied,jsd:jed), source=1.0) + if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/REFL_PREF_FILE", filename) + call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain) + else + if (trim(refl_pref_file) /= '' ) call MOM_error(FATAL, & + "REFL_PREF_FILE: "//trim(filename)//" not found") + endif + !CS%refl_pref = CS%refl_pref*1 ! adjust partial reflection if desired + call pass_var(CS%refl_pref, G%domain) + + ! Tag reflection cells with partial reflection (done here for speed) + allocate(CS%refl_pref_logical(isd:ied,jsd:jed), source=.false.) + do j=jsd,jed ; do i=isd,ied + ! flag cells with partial reflection + if ((CS%refl_angle(i,j) /= CS%nullangle) .and. & + (CS%refl_pref(i,j) < 1.0) .and. (CS%refl_pref(i,j) > 0.0)) then + CS%refl_pref_logical(i,j) = .true. + endif + enddo ; enddo + + ! Read in double-reflective (ridge) tags from file + call get_param(param_file, mdl, "REFL_DBL_FILE", refl_dbl_file, & + "The path to the file containing the double-reflective ridge tags.", & + fail_if_missing=.false., default='') + filename = trim(CS%inputdir) // trim(refl_dbl_file) + allocate(ridge_temp(isd:ied,jsd:jed), source=0.0) + if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/REFL_DBL_FILE", filename) + call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain) + else + if (trim(refl_dbl_file) /= '' ) call MOM_error(FATAL, & + "REFL_DBL_FILE: "//trim(filename)//" not found") + endif + call pass_var(ridge_temp, G%domain) + allocate(CS%refl_dbl(isd:ied,jsd:jed), source=.false.) + do j=jsd,jed ; do i=isd,ied + CS%refl_dbl(i,j) = (ridge_temp(i,j) == 1) + enddo ; enddo + + ! Read in the transmission coefficient and infer the residual + call get_param(param_file, mdl, "TRANS_FILE", trans_file, & + "The path to the file containing the transmission coefficent for internal tides.", & + fail_if_missing=.false., default='') + filename = trim(CS%inputdir) // trim(trans_file) + allocate(CS%trans(isd:ied,jsd:jed), source=0.0) + if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/TRANS_FILE", filename) + call MOM_read_data(filename, 'trans', CS%trans, G%domain) + else + if (trim(trans_file) /= '' ) call MOM_error(FATAL, & + "TRANS_FILE: "//trim(filename)//" not found") + endif + + call pass_var(CS%trans, G%domain) + + ! residual + allocate(CS%residual(isd:ied,jsd:jed), source=0.0) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%refl_pref_logical(i,j)) then + CS%residual(i,j) = 1. - CS%refl_pref(i,j) - CS%trans(i,j) + endif + enddo ; enddo + call pass_var(CS%residual, G%domain) + + CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & + Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) + allocate(CS%id_cn(CS%nMode), source=-1) + do m=1,CS%nMode + write(var_name, '("cn_mode",i1)') m + write(var_descript, '("Baroclinic (eigen) speed of mode ",i1)') m + CS%id_cn(m) = register_diag_field('ocean_model',var_name, diag%axesT1, & + Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + enddo + + ! Register maps of reflection parameters + CS%id_refl_ang = register_diag_field('ocean_model', 'refl_angle', diag%axesT1, & + Time, 'Local angle of coastline/ridge/shelf with respect to equator', 'rad') + CS%id_refl_pref = register_diag_field('ocean_model', 'refl_pref', diag%axesT1, & + Time, 'Partial reflection coefficients', '') + CS%id_trans = register_diag_field('ocean_model', 'trans', diag%axesT1, & + Time, 'Partial transmission coefficients', '') + CS%id_residual = register_diag_field('ocean_model', 'residual', diag%axesT1, & + Time, 'Residual of reflection and transmission coefficients', '') + CS%id_dx_Cv = register_diag_field('ocean_model', 'dx_Cv', diag%axesT1, & + Time, 'North face unblocked width', 'm', conversion=US%L_to_m) + CS%id_dy_Cu = register_diag_field('ocean_model', 'dy_Cu', diag%axesT1, & + Time, 'East face unblocked width', 'm', conversion=US%L_to_m) + CS%id_land_mask = register_diag_field('ocean_model', 'land_mask', diag%axesT1, & + Time, 'Land mask', 'nondim') + ! Output reflection parameters as diagnostics here (not needed every timestep) + if (CS%id_refl_ang > 0) call post_data(CS%id_refl_ang, CS%refl_angle, CS%diag) + if (CS%id_refl_pref > 0) call post_data(CS%id_refl_pref, CS%refl_pref, CS%diag) + if (CS%id_trans > 0) call post_data(CS%id_trans, CS%trans, CS%diag) + if (CS%id_residual > 0) call post_data(CS%id_residual, CS%residual, CS%diag) + if (CS%id_dx_Cv > 0) call post_data(CS%id_dx_Cv, G%dx_Cv, CS%diag) + if (CS%id_dy_Cu > 0) call post_data(CS%id_dy_Cu, G%dy_Cu, CS%diag) + if (CS%id_land_mask > 0) call post_data(CS%id_land_mask, G%mask2dT, CS%diag) + + ! Register 2-D energy density (summed over angles, freq, modes) + CS%id_tot_En = register_diag_field('ocean_model', 'ITide_tot_En', diag%axesT1, & + Time, 'Internal tide total energy density', & + 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + + allocate(CS%id_itide_drag(CS%nFreq, CS%nMode), source=-1) + allocate(CS%id_TKE_itidal_input(CS%nFreq), source=-1) + do fr=1,CS%nFreq + ! Register 2-D energy input into internal tides for each frequency + write(var_name, '("TKE_itidal_input_freq",i1)') fr + write(var_descript, '("a fraction of which goes into rays in frequency ",i1)') fr + + CS%id_TKE_itidal_input(fr) = register_diag_field('ocean_model', var_name, diag%axesT1, & + Time, 'Conversion from barotropic to baroclinic tide, '//& + var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + enddo + ! Register 2-D energy losses (summed over angles, freq, modes) + CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & + Time, 'Internal tide energy loss to background drag', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_tot_quad_loss = register_diag_field('ocean_model', 'ITide_tot_quad_loss', diag%axesT1, & + Time, 'Internal tide energy loss to bottom drag', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_tot_itidal_loss = register_diag_field('ocean_model', 'ITide_tot_itidal_loss', diag%axesT1, & + Time, 'Internal tide energy loss to wave drag', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_tot_Froude_loss = register_diag_field('ocean_model', 'ITide_tot_Froude_loss', diag%axesT1, & + Time, 'Internal tide energy loss to wave breaking', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_tot_residual_loss = register_diag_field('ocean_model', 'ITide_tot_residual_loss', diag%axesT1, & + Time, 'Internal tide energy loss to residual on slopes', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_tot_allprocesses_loss = register_diag_field('ocean_model', 'ITide_tot_allprocesses_loss', diag%axesT1, & + Time, 'Internal tide energy loss summed over all processes', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + + allocate(CS%id_En_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_En_ang_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_itidal_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_leak_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_quad_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_Froude_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_residual_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_allprocesses_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_itidal_loss_ang_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_Ub_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_Ustruct_mode(CS%nMode), source=-1) + allocate(CS%id_Wstruct_mode(CS%nMode), source=-1) + allocate(CS%id_int_w2_mode(CS%nMode), source=-1) + allocate(CS%id_int_U2_mode(CS%nMode), source=-1) + allocate(CS%id_int_N2w2_mode(CS%nMode), source=-1) + allocate(CS%id_cp_mode(CS%nFreq,CS%nMode), source=-1) + + allocate(angles(CS%NAngle), source=0.0) + Angle_size = (8.0*atan(1.0)) / (real(num_angle)) + do a=1,num_angle ; angles(a) = (real(a) - 1) * Angle_size ; enddo + + id_ang = diag_axis_init("angle", angles, "Radians", "N", "Angular Orientation of Fluxes") + call define_axes_group(diag, (/ diag%axesT1%handles(1), diag%axesT1%handles(2), id_ang /), & + axes_ang, is_h_point=.true.) + do fr=1,CS%nFreq ; write(freq_name(fr), '("freq",i1)') fr ; enddo + do m=1,CS%nMode ; do fr=1,CS%nFreq + ! Register 2-D energy density (summed over angles) for each frequency and mode + write(var_name, '("Itide_En_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy density in frequency ",i1," mode ",i1)') fr, m + CS%id_En_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + ! Register 3-D (i,j,a) energy density for each frequency and mode + write(var_name, '("Itide_En_ang_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide angular energy density in frequency ",i1," mode ",i1)') fr, m + CS%id_En_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & + axes_ang, Time, var_descript, 'J m-2 band-1', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + ! Register 2-D energy loss (summed over angles) for each frequency and mode + ! wave-drag only + write(var_name, '("Itide_wavedrag_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m + CS%id_itidal_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Leakage loss + write(var_name, '("Itide_leak_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy loss due to leakage from frequency ",i1," mode ",i1)') fr, m + CS%id_leak_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Quad loss + write(var_name, '("Itide_quad_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy quad loss from frequency ",i1," mode ",i1)') fr, m + CS%id_quad_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Froude loss + write(var_name, '("Itide_froude_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy Froude loss from frequency ",i1," mode ",i1)') fr, m + CS%id_froude_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! residual losses + write(var_name, '("Itide_residual_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy residual loss from frequency ",i1," mode ",i1)') fr, m + CS%id_residual_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! all loss processes + write(var_name, '("Itide_allprocesses_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy loss due to all processes from frequency ",i1," mode ",i1)') fr, m + CS%id_allprocesses_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + ! Register 3-D (i,j,a) energy loss for each frequency and mode + ! wave-drag only + write(var_name, '("Itide_wavedrag_loss_ang_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m + CS%id_itidal_loss_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & + axes_ang, Time, var_descript, 'W m-2 band-1', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + ! Register 2-D period-averaged near-bottom horizontal velocity for each frequency and mode + write(var_name, '("Itide_Ub_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Near-bottom horizontal velocity for frequency ",i1," mode ",i1)') fr, m + CS%id_Ub_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + ! Register 2-D horizontal phase velocity for each frequency and mode + write(var_name, '("Itide_cp_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Horizontal phase velocity for frequency ",i1," mode ",i1)') fr, m + CS%id_cp_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + ! Register 2-D drag scale used for quadratic bottom drag for each frequency and mode + write(var_name, '("ITide_drag_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Interior and bottom drag int tide decay timescale in frequency ",i1, " mode ",i1)') fr, m + + CS%id_itide_drag(fr,m) = register_diag_field('ocean_model', var_name, diag%axesT1, Time, & + 's-1', conversion=US%s_to_T) + enddo ; enddo + + + do m=1,CS%nMode + + ! Register 3-D internal tide horizonal velocity profile for each mode + write(var_name, '("Itide_Ustruct","_mode",i1)') m + write(var_descript, '("horizonal velocity profile for mode ",i1)') m + CS%id_Ustruct_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesTl, Time, var_descript, 'm-1', conversion=US%m_to_L) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + ! Register 3-D internal tide vertical velocity profile for each mode + write(var_name, '("Itide_Wstruct","_mode",i1)') m + write(var_descript, '("vertical velocity profile for mode ",i1)') m + CS%id_Wstruct_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesTi, Time, var_descript, '[]') + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + write(var_name, '("Itide_int_w2","_mode",i1)') m + write(var_descript, '("integral of w2 for mode ",i1)') m + CS%id_int_w2_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'm', conversion=GV%H_to_m) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + write(var_name, '("Itide_int_U2","_mode",i1)') m + write(var_descript, '("integral of U2 for mode ",i1)') m + CS%id_int_U2_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'm-1', conversion=US%m_to_Z*GV%H_to_Z) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + write(var_name, '("Itide_int_N2w2","_mode",i1)') m + write(var_descript, '("integral of N2w2 for mode ",i1)') m + CS%id_int_N2w2_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'm s-2', conversion=GV%H_to_m*US%s_to_T**2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + enddo + + ! Initialize the module that calculates the wave speeds. + call wave_speed_init(CS%wave_speed, c1_thresh=IGW_c1_thresh) + +end subroutine internal_tides_init + +!> This subroutine deallocates the memory associated with the internal tides control structure +subroutine internal_tides_end(CS) + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure + + if (allocated(CS%En)) deallocate(CS%En) + if (allocated(CS%frequency)) deallocate(CS%frequency) + if (allocated(CS%id_En_mode)) deallocate(CS%id_En_mode) + if (allocated(CS%id_Ub_mode)) deallocate(CS%id_Ub_mode) + if (allocated(CS%id_cp_mode)) deallocate(CS%id_cp_mode) + if (allocated(CS%id_Ustruct_mode)) deallocate(CS%id_Ustruct_mode) + if (allocated(CS%id_Wstruct_mode)) deallocate(CS%id_Wstruct_mode) + if (allocated(CS%id_int_w2_mode)) deallocate(CS%id_int_w2_mode) + if (allocated(CS%id_int_U2_mode)) deallocate(CS%id_int_U2_mode) + if (allocated(CS%id_int_N2w2_mode)) deallocate(CS%id_int_N2w2_mode) + +end subroutine internal_tides_end + +end module MOM_internal_tides diff --git a/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 new file mode 100644 index 0000000000..e2e7eaa5ea --- /dev/null +++ b/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -0,0 +1,1858 @@ +!> Variable mixing coefficients +module MOM_lateral_mixing_coeffs + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, post_data +use MOM_diag_mediator, only : diag_ctrl, time_type, query_averaging_enabled +use MOM_domains, only : create_group_pass, do_group_pass +use MOM_domains, only : group_pass_type, pass_var, pass_vector +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_interface_heights, only : find_eta +use MOM_isopycnal_slopes, only : calc_isoneutral_slopes +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init +use MOM_open_boundary, only : ocean_OBC_type + +implicit none ; private + +#include + +!> Variable mixing coefficients +type, public :: VarMix_CS + logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: use_variable_mixing !< If true, use the variable mixing. +!> logical :: use_gradient_model !< If true, use the gradient model. + logical :: Resoln_scaling_used !< If true, a resolution function is used somewhere to scale + !! away one of the viscosities or diffusivities when the + !! deformation radius is well resolved. + logical :: Resoln_scaled_Kh !< If true, scale away the Laplacian viscosity + !! when the deformation radius is well resolved. + logical :: Resoln_scaled_KhTh !< If true, scale away the thickness diffusivity + !! when the deformation radius is well resolved. + logical :: Depth_scaled_KhTh !< If true, KHTH is scaled away when the depth is + !! shallower than a reference depth. + logical :: Resoln_scaled_KhTr !< If true, scale away the tracer diffusivity + !! when the deformation radius is well resolved. + logical :: interpolate_Res_fn !< If true, interpolate the resolution function + !! to the velocity points from the thickness + !! points; otherwise interpolate the wave + !! speed and calculate the resolution function + !! independently at each point. + logical :: use_stored_slopes !< If true, stores isopycnal slopes in this structure. + logical :: Resoln_use_ebt !< If true, uses the equivalent barotropic wave speed instead + !! of first baroclinic wave for calculating the resolution fn. + logical :: khth_use_ebt_struct !< If true, uses the equivalent barotropic structure + !! as the vertical structure of thickness diffusivity. + logical :: kdgl90_use_ebt_struct !< If true, uses the equivalent barotropic structure + !! as the vertical structure of diffusivity in the GL90 scheme. + logical :: calculate_cg1 !< If true, calls wave_speed() to calculate the first + !! baroclinic wave speed and populate CS%cg1. + !! This parameter is set depending on other parameters. + logical :: calculate_Rd_dx !< If true, calculates Rd/dx and populate CS%Rd_dx_h. + !! This parameter is set depending on other parameters. + logical :: calculate_res_fns !< If true, calculate all the resolution factors. + !! This parameter is set depending on other parameters. + logical :: calculate_depth_fns !< If true, calculate all the depth factors. + !! This parameter is set depending on other parameters. + logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rate. + !! This parameter is set depending on other parameters. + logical :: use_stanley_iso !< If true, use Stanley parameterization in MOM_isopycnal_slopes + logical :: use_simpler_Eady_growth_rate !< If true, use a simpler method to calculate the + !! Eady growth rate that avoids division by layer thickness. + !! This parameter is set depending on other parameters. + real :: cropping_distance !< Distance from surface or bottom to filter out outcropped or + !! incropped interfaces for the Eady growth rate calc [Z ~> m] + real :: h_min_N2 !< The minimum vertical distance to use in the denominator of the + !! bouyancy frequency used in the slope calculation [Z ~> m] + + real, allocatable :: SN_u(:,:) !< S*N at u-points [T-1 ~> s-1] + real, allocatable :: SN_v(:,:) !< S*N at v-points [T-1 ~> s-1] + real, allocatable :: UH_grad(:,:,:) !< Grad model at u-points [T-1 ~> s-1] + real, allocatable :: VH_grad(:,:,:) !< Grad model at v-points [T-1 ~> s-1] + real, allocatable :: L2u(:,:) !< Length scale^2 at u-points [L2 ~> m2] + real, allocatable :: L2v(:,:) !< Length scale^2 at v-points [L2 ~> m2] + real, allocatable :: L2grad_u(:,:) !< Grad length scale^2 at u-points [L2 ~> m2] + real, allocatable :: L2grad_v(:,:) !< Grad length scale^2 at v-points [L2 ~> m2] + real, allocatable :: cg1(:,:) !< The first baroclinic gravity wave speed [L T-1 ~> m s-1]. + real, allocatable :: Res_fn_h(:,:) !< Non-dimensional function of the ratio the first baroclinic + !! deformation radius to the grid spacing at h points [nondim]. + real, allocatable :: Res_fn_q(:,:) !< Non-dimensional function of the ratio the first baroclinic + !! deformation radius to the grid spacing at q points [nondim]. + real, allocatable :: Res_fn_u(:,:) !< Non-dimensional function of the ratio the first baroclinic + !! deformation radius to the grid spacing at u points [nondim]. + real, allocatable :: Res_fn_v(:,:) !< Non-dimensional function of the ratio the first baroclinic + !! deformation radius to the grid spacing at v points [nondim]. + real, allocatable :: Depth_fn_u(:,:) !< Non-dimensional function of the ratio of the depth to + !! a reference depth (maximum 1) at u points [nondim] + real, allocatable :: Depth_fn_v(:,:) !< Non-dimensional function of the ratio of the depth to + !! a reference depth (maximum 1) at v points [nondim] + real, allocatable :: beta_dx2_h(:,:) !< The magnitude of the gradient of the Coriolis parameter + !! times the grid spacing squared at h points [L T-1 ~> m s-1]. + real, allocatable :: beta_dx2_q(:,:) !< The magnitude of the gradient of the Coriolis parameter + !! times the grid spacing squared at q points [L T-1 ~> m s-1]. + real, allocatable :: beta_dx2_u(:,:) !< The magnitude of the gradient of the Coriolis parameter + !! times the grid spacing squared at u points [L T-1 ~> m s-1]. + real, allocatable :: beta_dx2_v(:,:) !< The magnitude of the gradient of the Coriolis parameter + !! times the grid spacing squared at v points [L T-1 ~> m s-1]. + real, allocatable :: f2_dx2_h(:,:) !< The Coriolis parameter squared times the grid + !! spacing squared at h [L2 T-2 ~> m2 s-2]. + real, allocatable :: f2_dx2_q(:,:) !< The Coriolis parameter squared times the grid + !! spacing squared at q [L2 T-2 ~> m2 s-2]. + real, allocatable :: f2_dx2_u(:,:) !< The Coriolis parameter squared times the grid + !! spacing squared at u [L2 T-2 ~> m2 s-2]. + real, allocatable :: f2_dx2_v(:,:) !< The Coriolis parameter squared times the grid + !! spacing squared at v [L2 T-2 ~> m2 s-2]. + real, allocatable :: Rd_dx_h(:,:) !< Deformation radius over grid spacing [nondim] + + real, allocatable :: slope_x(:,:,:) !< Zonal isopycnal slope [Z L-1 ~> nondim] + real, allocatable :: slope_y(:,:,:) !< Meridional isopycnal slope [Z L-1 ~> nondim] + real, allocatable :: ebt_struct(:,:,:) !< Vertical structure function to scale diffusivities with [nondim] + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & + Laplac3_const_u !< Laplacian metric-dependent constants [L3 ~> m3] + + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & + Laplac3_const_v !< Laplacian metric-dependent constants [L3 ~> m3] + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & + KH_u_QG !< QG Leith GM coefficient at u-points [L2 T-1 ~> m2 s-1] + + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & + KH_v_QG !< QG Leith GM coefficient at v-points [L2 T-1 ~> m2 s-1] + + ! Parameters + logical :: use_Visbeck !< Use Visbeck formulation for thickness diffusivity + integer :: VarMix_Ktop !< Top layer to start downward integrals + real :: Visbeck_L_scale !< Fixed length scale in Visbeck formula [L ~> m], or if negative a scaling + real :: grad_L_scale !< Fixed length scale in Gradient formula [non-dimension] + !! factor [nondim] relating this length scale squared to the cell area + real :: Eady_GR_D_scale !< Depth over which to average SN [Z ~> m] + real :: Res_coef_khth !< A coefficient [nondim] that determines the function + !! of resolution, used for thickness and tracer mixing, as: + !! F = 1 / (1 + (Res_coef_khth*Ld/dx)^Res_fn_power) + real :: Res_coef_visc !< A coefficient [nondim] that determines the function + !! of resolution, used for lateral viscosity, as: + !! F = 1 / (1 + (Res_coef_visc*Ld/dx)^Res_fn_power) + real :: depth_scaled_khth_h0 !< The depth above which KHTH is linearly scaled away [Z ~> m] + real :: depth_scaled_khth_exp !< The exponent used in the depth dependent scaling function for KHTH [nondim] + real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [Z2 T-1 ~> m2 s-1] + integer :: Res_fn_power_khth !< The power of dx/Ld in the KhTh resolution function. Any + !! positive integer power may be used, but even powers + !! and especially 2 are coded to be more efficient. + integer :: Res_fn_power_visc !< The power of dx/Ld in the Kh resolution function. Any + !! positive integer power may be used, but even powers + !! and especially 2 are coded to be more efficient. + real :: Visbeck_S_max !< Upper bound on slope used in Eady growth rate [Z L-1 ~> nondim]. + + ! Leith parameters + logical :: use_QG_Leith_GM !< If true, uses the QG Leith viscosity as the GM coefficient + logical :: use_beta_in_QG_Leith !< If true, includes the beta term in the QG Leith GM coefficient + + ! Diagnostics + !>@{ + !! Diagnostic identifier + integer :: id_SN_u=-1, id_SN_v=-1, id_UH_grad=-1, id_VH_grad=-1, id_L2u=-1, id_L2v=-1, id_L2grad_u=-1, id_L2grad_v=-1, id_Res_fn = -1 + integer :: id_N2_u=-1, id_N2_v=-1, id_S2_u=-1, id_S2_v=-1 + integer :: id_dzu=-1, id_dzv=-1, id_dzSxN=-1, id_dzSyN=-1 + integer :: id_Rd_dx=-1, id_KH_u_QG = -1, id_KH_v_QG = -1 + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. + !>@} + + type(wave_speed_CS) :: wave_speed !< Wave speed control structure + type(group_pass_type) :: pass_cg1 !< For group halo pass + logical :: debug !< If true, write out checksums of data for debugging +end type VarMix_CS + +public VarMix_init, VarMix_end, calc_slope_functions, calc_resoln_function +public calc_QG_Leith_viscosity, calc_depth_function + +contains + +!> Calculates the non-dimensional depth functions. +subroutine calc_depth_function(G, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure + + ! Local variables + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j + real :: H0 ! The depth above which KHTH is linearly scaled away [Z ~> m] + real :: expo ! exponent used in the depth dependent scaling [nondim] + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (.not. CS%initialized) call MOM_error(FATAL, "calc_depth_function: "// & + "Module must be initialized before it is used.") + + if (.not. CS%calculate_depth_fns) return + if (.not. allocated(CS%Depth_fn_u)) call MOM_error(FATAL, & + "calc_depth_function: %Depth_fn_u is not associated with Depth_scaled_KhTh.") + if (.not. allocated(CS%Depth_fn_v)) call MOM_error(FATAL, & + "calc_depth_function: %Depth_fn_v is not associated with Depth_scaled_KhTh.") + + ! For efficiency, the reciprocal of H0 should be used instead. + H0 = CS%depth_scaled_khth_h0 + expo = CS%depth_scaled_khth_exp +!$OMP do + do j=js,je ; do I=is-1,Ieq + CS%Depth_fn_u(I,j) = (MIN(1.0, (0.5*(G%bathyT(i,j) + G%bathyT(i+1,j)) + G%Z_ref)/H0))**expo + enddo ; enddo +!$OMP do + do J=js-1,Jeq ; do i=is,ie + CS%Depth_fn_v(i,J) = (MIN(1.0, (0.5*(G%bathyT(i,j) + G%bathyT(i,j+1)) + G%Z_ref)/H0))**expo + enddo ; enddo + +end subroutine calc_depth_function + +!> Calculates and stores the non-dimensional resolution functions +subroutine calc_resoln_function(h, tv, G, GV, US, CS) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure + + ! Local variables + ! Depending on the power-function being used, dimensional rescaling may be limited, so some + ! of the following variables have units that depend on that power. + real :: cg1_q ! The gravity wave speed interpolated to q points [L T-1 ~> m s-1] or [m s-1]. + real :: cg1_u ! The gravity wave speed interpolated to u points [L T-1 ~> m s-1] or [m s-1]. + real :: cg1_v ! The gravity wave speed interpolated to v points [L T-1 ~> m s-1] or [m s-1]. + real :: dx_term ! A term in the denominator [L2 T-2 ~> m2 s-2] or [m2 s-2] + integer :: power_2 + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (.not. CS%initialized) call MOM_error(FATAL, "calc_resoln_function: "// & + "Module must be initialized before it is used.") + + if (CS%calculate_cg1) then + if (.not. allocated(CS%cg1)) call MOM_error(FATAL, & + "calc_resoln_function: %cg1 is not associated with Resoln_scaled_Kh.") + if (CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct) then + if (.not. allocated(CS%ebt_struct)) call MOM_error(FATAL, & + "calc_resoln_function: %ebt_struct is not associated with RESOLN_USE_EBT.") + if (CS%Resoln_use_ebt) then + ! Both resolution fn and vertical structure are using EBT + call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed, modal_structure=CS%ebt_struct) + else + ! Use EBT to get vertical structure first and then re-calculate cg1 using first baroclinic mode + call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed, modal_structure=CS%ebt_struct, & + use_ebt_mode=.true.) + call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed) + endif + call pass_var(CS%ebt_struct, G%Domain) + else + call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed) + endif + + call create_group_pass(CS%pass_cg1, CS%cg1, G%Domain) + call do_group_pass(CS%pass_cg1, G%Domain) + endif + + ! Calculate and store the ratio between deformation radius and grid-spacing + ! at h-points [nondim]. + if (CS%calculate_rd_dx) then + if (.not. allocated(CS%Rd_dx_h)) call MOM_error(FATAL, & + "calc_resoln_function: %Rd_dx_h is not associated with calculate_rd_dx.") + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%Rd_dx_h(i,j) = CS%cg1(i,j) / & + (sqrt(CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j))) + enddo ; enddo + if (query_averaging_enabled(CS%diag)) then + if (CS%id_Rd_dx > 0) call post_data(CS%id_Rd_dx, CS%Rd_dx_h, CS%diag) + endif + endif + + if (.not. CS%calculate_res_fns) return + + if (.not. allocated(CS%Res_fn_h)) call MOM_error(FATAL, & + "calc_resoln_function: %Res_fn_h is not associated with Resoln_scaled_Kh.") + if (.not. allocated(CS%Res_fn_q)) call MOM_error(FATAL, & + "calc_resoln_function: %Res_fn_q is not associated with Resoln_scaled_Kh.") + if (.not. allocated(CS%Res_fn_u)) call MOM_error(FATAL, & + "calc_resoln_function: %Res_fn_u is not associated with Resoln_scaled_Kh.") + if (.not. allocated(CS%Res_fn_v)) call MOM_error(FATAL, & + "calc_resoln_function: %Res_fn_v is not associated with Resoln_scaled_Kh.") + if (.not. allocated(CS%f2_dx2_h)) call MOM_error(FATAL, & + "calc_resoln_function: %f2_dx2_h is not associated with Resoln_scaled_Kh.") + if (.not. allocated(CS%f2_dx2_q)) call MOM_error(FATAL, & + "calc_resoln_function: %f2_dx2_q is not associated with Resoln_scaled_Kh.") + if (.not. allocated(CS%f2_dx2_u)) call MOM_error(FATAL, & + "calc_resoln_function: %f2_dx2_u is not associated with Resoln_scaled_Kh.") + if (.not. allocated(CS%f2_dx2_v)) call MOM_error(FATAL, & + "calc_resoln_function: %f2_dx2_v is not associated with Resoln_scaled_Kh.") + if (.not. allocated(CS%beta_dx2_h)) call MOM_error(FATAL, & + "calc_resoln_function: %beta_dx2_h is not associated with Resoln_scaled_Kh.") + if (.not. allocated(CS%beta_dx2_q)) call MOM_error(FATAL, & + "calc_resoln_function: %beta_dx2_q is not associated with Resoln_scaled_Kh.") + if (.not. allocated(CS%beta_dx2_u)) call MOM_error(FATAL, & + "calc_resoln_function: %beta_dx2_u is not associated with Resoln_scaled_Kh.") + if (.not. allocated(CS%beta_dx2_v)) call MOM_error(FATAL, & + "calc_resoln_function: %beta_dx2_v is not associated with Resoln_scaled_Kh.") + + ! Do this calculation on the extent used in MOM_hor_visc.F90, and + ! MOM_tracer.F90 so that no halo update is needed. + +!$OMP parallel default(none) shared(is,ie,js,je,Ieq,Jeq,CS,US) & +!$OMP private(dx_term,cg1_q,power_2,cg1_u,cg1_v) + if (CS%Res_fn_power_visc >= 100) then +!$OMP do + do j=js-1,je+1 ; do i=is-1,ie+1 + dx_term = CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j) + if ((CS%Res_coef_visc * CS%cg1(i,j))**2 > dx_term) then + CS%Res_fn_h(i,j) = 0.0 + else + CS%Res_fn_h(i,j) = 1.0 + endif + enddo ; enddo +!$OMP do + do J=js-1,Jeq ; do I=is-1,Ieq + cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) + dx_term = CS%f2_dx2_q(I,J) + cg1_q * CS%beta_dx2_q(I,J) + if ((CS%Res_coef_visc * cg1_q)**2 > dx_term) then + CS%Res_fn_q(I,J) = 0.0 + else + CS%Res_fn_q(I,J) = 1.0 + endif + enddo ; enddo + elseif (CS%Res_fn_power_visc == 2) then +!$OMP do + do j=js-1,je+1 ; do i=is-1,ie+1 + dx_term = CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j) + CS%Res_fn_h(i,j) = dx_term / (dx_term + (CS%Res_coef_visc * CS%cg1(i,j))**2) + enddo ; enddo +!$OMP do + do J=js-1,Jeq ; do I=is-1,Ieq + cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) + dx_term = CS%f2_dx2_q(I,J) + cg1_q * CS%beta_dx2_q(I,J) + CS%Res_fn_q(I,J) = dx_term / (dx_term + (CS%Res_coef_visc * cg1_q)**2) + enddo ; enddo + elseif (mod(CS%Res_fn_power_visc, 2) == 0) then + power_2 = CS%Res_fn_power_visc / 2 +!$OMP do + do j=js-1,je+1 ; do i=is-1,ie+1 + dx_term = (US%L_T_to_m_s**2*(CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j)))**power_2 + CS%Res_fn_h(i,j) = dx_term / & + (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*CS%cg1(i,j))**CS%Res_fn_power_visc) + enddo ; enddo +!$OMP do + do J=js-1,Jeq ; do I=is-1,Ieq + cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) + dx_term = (US%L_T_to_m_s**2*(CS%f2_dx2_q(I,J) + cg1_q * CS%beta_dx2_q(I,J)))**power_2 + CS%Res_fn_q(I,J) = dx_term / & + (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q)**CS%Res_fn_power_visc) + enddo ; enddo + else +!$OMP do + do j=js-1,je+1 ; do i=is-1,ie+1 + dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_h(i,j) + & + CS%cg1(i,j)*CS%beta_dx2_h(i,j)))**CS%Res_fn_power_visc + CS%Res_fn_h(i,j) = dx_term / & + (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*CS%cg1(i,j))**CS%Res_fn_power_visc) + enddo ; enddo +!$OMP do + do J=js-1,Jeq ; do I=is-1,Ieq + cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) + dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_q(I,J) + & + cg1_q * CS%beta_dx2_q(I,J)))**CS%Res_fn_power_visc + CS%Res_fn_q(I,J) = dx_term / & + (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q)**CS%Res_fn_power_visc) + enddo ; enddo + endif + + if (CS%interpolate_Res_fn) then + do j=js,je ; do I=is-1,Ieq + CS%Res_fn_u(I,j) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i+1,j)) + enddo ; enddo + do J=js-1,Jeq ; do i=is,ie + CS%Res_fn_v(i,J) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i,j+1)) + enddo ; enddo + else ! .not.CS%interpolate_Res_fn + if (CS%Res_fn_power_khth >= 100) then +!$OMP do + do j=js,je ; do I=is-1,Ieq + cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) + dx_term = CS%f2_dx2_u(I,j) + cg1_u * CS%beta_dx2_u(I,j) + if ((CS%Res_coef_khth * cg1_u)**2 > dx_term) then + CS%Res_fn_u(I,j) = 0.0 + else + CS%Res_fn_u(I,j) = 1.0 + endif + enddo ; enddo +!$OMP do + do J=js-1,Jeq ; do i=is,ie + cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) + dx_term = CS%f2_dx2_v(i,J) + cg1_v * CS%beta_dx2_v(i,J) + if ((CS%Res_coef_khth * cg1_v)**2 > dx_term) then + CS%Res_fn_v(i,J) = 0.0 + else + CS%Res_fn_v(i,J) = 1.0 + endif + enddo ; enddo + elseif (CS%Res_fn_power_khth == 2) then +!$OMP do + do j=js,je ; do I=is-1,Ieq + cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) + dx_term = CS%f2_dx2_u(I,j) + cg1_u * CS%beta_dx2_u(I,j) + CS%Res_fn_u(I,j) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_u)**2) + enddo ; enddo +!$OMP do + do J=js-1,Jeq ; do i=is,ie + cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) + dx_term = CS%f2_dx2_v(i,J) + cg1_v * CS%beta_dx2_v(i,J) + CS%Res_fn_v(i,J) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_v)**2) + enddo ; enddo + elseif (mod(CS%Res_fn_power_khth, 2) == 0) then + power_2 = CS%Res_fn_power_khth / 2 +!$OMP do + do j=js,je ; do I=is-1,Ieq + cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) + dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_u(I,j) + cg1_u * CS%beta_dx2_u(I,j)))**power_2 + CS%Res_fn_u(I,j) = dx_term / & + (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u)**CS%Res_fn_power_khth) + enddo ; enddo +!$OMP do + do J=js-1,Jeq ; do i=is,ie + cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) + dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_v(i,J) + cg1_v * CS%beta_dx2_v(i,J)))**power_2 + CS%Res_fn_v(i,J) = dx_term / & + (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v)**CS%Res_fn_power_khth) + enddo ; enddo + else +!$OMP do + do j=js,je ; do I=is-1,Ieq + cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) + dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_u(I,j) + & + cg1_u * CS%beta_dx2_u(I,j)))**CS%Res_fn_power_khth + CS%Res_fn_u(I,j) = dx_term / & + (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u)**CS%Res_fn_power_khth) + enddo ; enddo +!$OMP do + do J=js-1,Jeq ; do i=is,ie + cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) + dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_v(i,J) + & + cg1_v * CS%beta_dx2_v(i,J)))**CS%Res_fn_power_khth + CS%Res_fn_v(i,J) = dx_term / & + (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v)**CS%Res_fn_power_khth) + enddo ; enddo + endif + endif +!$OMP end parallel + + if (query_averaging_enabled(CS%diag)) then + if (CS%id_Res_fn > 0) call post_data(CS%id_Res_fn, CS%Res_fn_h, CS%diag) + endif + +end subroutine calc_resoln_function + +!> Calculates and stores functions of isopycnal slopes, e.g. Sx, Sy, S*N, mostly used in the Visbeck et al. +!! style scaling of diffusivity +subroutine calc_slope_functions(h, uh, vh, tv, dt, G, GV, US, CS, OBC) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)),intent(inout) :: uh !< Layer thickness times u [UH ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)),intent(inout) :: vh !< Layer thickness times v [VH ~> m2 s-1 or kg m-1 s-1] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, intent(in) :: dt !< Time increment [T ~> s] + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure + ! Local variables + real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & + e ! The interface heights relative to mean sea level [Z ~> m]. + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1] + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions: "//& + "Module must be initialized before it is used.") + + if (CS%calculate_Eady_growth_rate) then + call find_eta(h, tv, G, GV, US, e, halo_size=2) + if (CS%use_simpler_Eady_growth_rate) then + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & + CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, dzu=dzu, dzv=dzv, & + dzSxN=dzSxN, dzSyN=dzSyN, halo=1, OBC=OBC) + call calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, CS%SN_u, CS%SN_v) + elseif (CS%use_stored_slopes) then + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & + CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, halo=1, OBC=OBC) + call calc_Visbeck_coeffs_old(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) + else + !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, uh, vh, .true.) + endif + endif + + if (query_averaging_enabled(CS%diag)) then + if (CS%id_dzu > 0) call post_data(CS%id_dzu, dzu, CS%diag) + if (CS%id_dzv > 0) call post_data(CS%id_dzv, dzv, CS%diag) + if (CS%id_dzSxN > 0) call post_data(CS%id_dzSxN, dzSxN, CS%diag) + if (CS%id_dzSyN > 0) call post_data(CS%id_dzSyN, dzSyN, CS%diag) + if (CS%id_SN_u > 0) call post_data(CS%id_SN_u, CS%SN_u, CS%diag) + if (CS%id_SN_v > 0) call post_data(CS%id_SN_v, CS%SN_v, CS%diag) + if (CS%id_UH_grad > 0) call post_data(CS%id_UH_grad, CS%UH_grad, CS%diag) + if (CS%id_VH_grad > 0) call post_data(CS%id_VH_grad, CS%VH_grad, CS%diag) + if (CS%id_L2u > 0) call post_data(CS%id_L2u, CS%L2u, CS%diag) + if (CS%id_L2v > 0) call post_data(CS%id_L2v, CS%L2v, CS%diag) + if (CS%id_L2grad_u > 0) call post_data(CS%id_L2grad_u, CS%L2grad_u, CS%diag) + if (CS%id_L2grad_v > 0) call post_data(CS%id_L2grad_v, CS%L2grad_v, CS%diag) + if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) + if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) + endif + +end subroutine calc_slope_functions + +!> Calculates factors used when setting diffusivity coefficients similar to Visbeck et al., 1997. +!! This is on older implementation that is susceptible to large values of Eady growth rate +!! for incropping layers. +subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: slope_x !< Zonal isoneutral slope [Z L-1 ~> nondim] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: N2_u !< Buoyancy (Brunt-Vaisala) frequency + !! at u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: slope_y !< Meridional isoneutral slope + !! [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: N2_v !< Buoyancy (Brunt-Vaisala) frequency + !! at v-points [L2 Z-2 T-2 ~> s-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure + + ! Local variables + real :: S2 ! Interface slope squared [Z2 L-2 ~> nondim] + real :: N2 ! Positive buoyancy frequency or zero [L2 Z-2 T-2 ~> s-2] + real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] + real :: H_geom ! The geometric mean of Hup and Hdn [H ~> m or kg m-2]. + real :: S2max ! An upper bound on the squared slopes [Z2 L-2 ~> nondim] + real :: wNE, wSE, wSW, wNW ! Weights of adjacent points [nondim] + real :: H_u(SZIB_(G)), H_v(SZI_(G)) ! Layer thicknesses at u- and v-points [H ~> m or kg m-2] + + ! Note that at some points in the code S2_u and S2_v hold the running depth + ! integrals of the squared slope [H ~> m or kg m-2] before the average is taken. + real :: S2_u(SZIB_(G),SZJ_(G)) ! At first the thickness-weighted depth integral of the squared + ! slope [H Z2 L-2 ~> m or kg m-2] and then the average of the + ! squared slope [Z2 L-2 ~> nondim] at u points. + real :: S2_v(SZI_(G),SZJB_(G)) ! At first the thickness-weighted depth integral of the squared + ! slope [H Z2 L-2 ~> m or kg m-2] and then the average of the + ! squared slope [Z2 L-2 ~> nondim] at v points. + + integer :: i, j, k, is, ie, js, je, nz, l_seg + + if (.not. CS%initialized) call MOM_error(FATAL, "calc_Visbeck_coeffs_old: "// & + "Module must be initialized before it is used.") + + if (.not. CS%calculate_Eady_growth_rate) return + if (.not. allocated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function:"// & + "%SN_u is not associated with use_variable_mixing.") + if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:R"// & + "%SN_v is not associated with use_variable_mixing.") + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + S2max = CS%Visbeck_S_max**2 + + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%SN_u(i,j) = 0.0 + CS%SN_v(i,j) = 0.0 + enddo ; enddo + + ! To set the length scale based on the deformation radius, use wave_speed to + ! calculate the first-mode gravity wave speed and then blend the equatorial + ! and midlatitude deformation radii, using calc_resoln_function as a template. + + !$OMP parallel do default(shared) private(S2,H_u,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) + do j=js,je + do I=is-1,ie + CS%SN_u(I,j) = 0. ; H_u(I) = 0. ; S2_u(I,j) = 0. + enddo + do K=2,nz ; do I=is-1,ie + Hdn = sqrt( h(i,j,k) * h(i+1,j,k) ) + Hup = sqrt( h(i,j,k-1) * h(i+1,j,k-1) ) + H_geom = sqrt( Hdn * Hup ) + !H_geom = H_geom * sqrt(N2) ! WKB-ish + !H_geom = H_geom * N2 ! WKB-ish + wSE = G%mask2dCv(i+1,J-1) * ( (h(i+1,j,k)*h(i+1,j-1,k)) * (h(i+1,j,k-1)*h(i+1,j-1,k-1)) ) + wNW = G%mask2dCv(i ,J ) * ( (h(i ,j,k)*h(i ,j+1,k)) * (h(i ,j,k-1)*h(i ,j+1,k-1)) ) + wNE = G%mask2dCv(i+1,J ) * ( (h(i+1,j,k)*h(i+1,j+1,k)) * (h(i+1,j,k-1)*h(i+1,j+1,k-1)) ) + wSW = G%mask2dCv(i ,J-1) * ( (h(i ,j,k)*h(i ,j-1,k)) * (h(i ,j,k-1)*h(i ,j-1,k-1)) ) + S2 = slope_x(I,j,K)**2 + & + ((wNW*slope_y(i,J,K)**2 + wSE*slope_y(i+1,J-1,K)**2) + & + (wNE*slope_y(i+1,J,K)**2 + wSW*slope_y(i,J-1,K)**2) ) / & + ( ((wSE+wNW) + (wNE+wSW)) + GV%H_subroundoff**4 ) + if (S2max>0.) S2 = S2 * S2max / (S2 + S2max) ! Limit S2 + + N2 = max(0., N2_u(I,j,k)) + CS%SN_u(I,j) = CS%SN_u(I,j) + sqrt( S2*N2 )*H_geom + S2_u(I,j) = S2_u(I,j) + S2*H_geom + H_u(I) = H_u(I) + H_geom + enddo ; enddo + do I=is-1,ie + if (H_u(I)>0.) then + CS%SN_u(I,j) = G%OBCmaskCu(I,j) * CS%SN_u(I,j) / H_u(I) + S2_u(I,j) = G%OBCmaskCu(I,j) * S2_u(I,j) / H_u(I) + else + CS%SN_u(I,j) = 0. + endif + enddo + enddo + + !$OMP parallel do default(shared) private(S2,H_v,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) + do J=js-1,je + do i=is,ie + CS%SN_v(i,J) = 0.; H_v(i) = 0. ; S2_v(i,J) = 0. + enddo + do K=2,nz ; do i=is,ie + Hdn = sqrt( h(i,j,k) * h(i,j+1,k) ) + Hup = sqrt( h(i,j,k-1) * h(i,j+1,k-1) ) + H_geom = sqrt( Hdn * Hup ) + !H_geom = H_geom * sqrt(N2) ! WKB-ish + !H_geom = H_geom * N2 ! WKB-ish + wSE = G%mask2dCu(I,j) * ( (h(i,j ,k)*h(i+1,j ,k)) * (h(i,j ,k-1)*h(i+1,j ,k-1)) ) + wNW = G%mask2dCu(I-1,j+1) * ( (h(i,j+1,k)*h(i-1,j+1,k)) * (h(i,j+1,k-1)*h(i-1,j+1,k-1)) ) + wNE = G%mask2dCu(I,j+1) * ( (h(i,j+1,k)*h(i+1,j+1,k)) * (h(i,j+1,k-1)*h(i+1,j+1,k-1)) ) + wSW = G%mask2dCu(I-1,j) * ( (h(i,j ,k)*h(i-1,j ,k)) * (h(i,j ,k-1)*h(i-1,j ,k-1)) ) + S2 = slope_y(i,J,K)**2 + & + ((wSE*slope_x(I,j,K)**2 + wNW*slope_x(I-1,j+1,K)**2) + & + (wNE*slope_x(I,j+1,K)**2 + wSW*slope_x(I-1,j,K)**2) ) / & + ( ((wSE+wNW) + (wNE+wSW)) + GV%H_subroundoff**4 ) + if (S2max>0.) S2 = S2 * S2max / (S2 + S2max) ! Limit S2 + + N2 = max(0., N2_v(i,J,K)) + CS%SN_v(i,J) = CS%SN_v(i,J) + sqrt( S2*N2 )*H_geom + S2_v(i,J) = S2_v(i,J) + S2*H_geom + H_v(i) = H_v(i) + H_geom + enddo ; enddo + do i=is,ie + if (H_v(i)>0.) then + CS%SN_v(i,J) = G%OBCmaskCv(i,J) * CS%SN_v(i,J) / H_v(i) + S2_v(i,J) = G%OBCmaskCv(i,J) * S2_v(i,J) / H_v(i) + else + CS%SN_v(i,J) = 0. + endif + enddo + enddo + + ! Offer diagnostic fields for averaging. + if (query_averaging_enabled(CS%diag)) then + if (CS%id_S2_u > 0) call post_data(CS%id_S2_u, S2_u, CS%diag) + if (CS%id_S2_v > 0) call post_data(CS%id_S2_v, S2_v, CS%diag) + endif + + if (CS%debug) then + call uvchksum("calc_Visbeck_coeffs_old slope_[xy]", slope_x, slope_y, G%HI, & + scale=US%Z_to_L, haloshift=1) + call uvchksum("calc_Visbeck_coeffs_old N2_u, N2_v", N2_u, N2_v, G%HI, & + scale=US%L_to_Z**2*US%s_to_T**2, scalar_pair=.true.) + call uvchksum("calc_Visbeck_coeffs_old SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & + scale=US%s_to_T, scalar_pair=.true.) + endif + +end subroutine calc_Visbeck_coeffs_old + +!> Calculates the Eady growth rate (2D fields) for use in MEKE and the Visbeck schemes +subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, SN_u, SN_v) + type(VarMix_CS), intent(inout) :: CS !< Variable mixing coefficients + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Interface height [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface height [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: dzu !< dz at u-points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: dzv !< dz at v-points [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: dzSxN !< dz Sx N at u-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: dzSyN !< dz Sy N at v-points [Z T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: SN_u !< SN at u-points [T-1 ~> s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: SN_v !< SN at v-points [T-1 ~> s-1] + ! Local variables + real :: D_scale ! The depth over which to average SN [Z ~> m] + real :: dnew ! Depth of bottom of layer [Z ~> m] + real :: dz ! Limited thickness of this layer [Z ~> m] + real :: weight ! Fraction of this layer that contributes to integral [nondim] + real :: sum_dz(SZI_(G)) ! Cumulative sum of z-thicknesses [Z ~> m] + real :: vint_SN(SZIB_(G)) ! Cumulative integral of SN [Z T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G)) :: SN_cpy !< SN at u-points [T-1 ~> s-1] + real :: dz_neglect ! A negligibly small distance to avoid division by zero [Z ~> m] + real :: r_crp_dist ! The inverse of the distance over which to scale the cropping [Z-1 ~> m-1] + real :: dB, dT ! Elevation variables used when cropping [Z ~> m] + integer :: i, j, k, l_seg + logical :: crop + + dz_neglect = GV%H_subroundoff * GV%H_to_Z + D_scale = CS%Eady_GR_D_scale + if (D_scale<=0.) D_scale = 64.*GV%max_depth ! 0 means use full depth so choose something big + r_crp_dist = 1. / max( dz_neglect, CS%cropping_distance ) + crop = CS%cropping_distance>=0. ! Only filter out in-/out-cropped interface is parameter if non-negative + + if (CS%debug) then + call uvchksum("calc_Eady_growth_rate_2D dz[uv]", dzu, dzv, G%HI, scale=US%Z_to_m, scalar_pair=.true.) + call uvchksum("calc_Eady_growth_rate_2D dzS2N2[uv]", dzSxN, dzSyN, G%HI, & + scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) + endif + + !$OMP parallel do default(shared) + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%SN_u(i,j) = 0.0 + CS%SN_v(i,j) = 0.0 + enddo ; enddo + + !$OMP parallel do default(shared) private(dnew,dz,weight,l_seg,vint_SN,sum_dz) + do j=G%jsc-1,G%jec+1 + do I=G%isc-1,G%iec + vint_SN(I) = 0. + sum_dz(I) = dz_neglect + enddo + if (crop) then + do K=2,GV%ke ; do I=G%isc-1,G%iec + dnew = sum_dz(I) + dzu(I,j,K) ! This is where the bottom of the layer is + dnew = min(dnew, D_scale) ! This limits the depth to D_scale + dz = max(0., dnew - sum_dz(I)) ! This is the part of the layer to be included in the integral. + ! When D_scale>dnew, dz=dzu (+roundoff error). + ! When sum_dzdnew, dz=dzu (+roundoff error). + ! When sum_dzdnew, dz=dzu (+roundoff error). + ! When sum_dzdnew, dz=dzu (+roundoff error). + ! When sum_dz The original calc_slope_function() that calculated slopes using +!! interface positions only, not accounting for density variations. +!> Computes UH_grad and VH_grad for gradient model +subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, uh, vh, calculate_slopes) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uh !< Interface height times u [ZU ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vh !< Interface height times v [ZU ~> m2 s-1] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface position [Z ~> m] + logical, intent(in) :: calculate_slopes !< If true, calculate slopes + !! internally otherwise use slopes stored in CS +!> logical, intent(in) :: use_gradient_model !< If true, calculate gradient model + real :: Lgrid !< Grid lengthscale for the gradient model [H ~> m] + ! Local variables + real :: E_x(SZIB_(G),SZJ_(G)) ! X-slope of interface at u points [Z L-1 ~> nondim] (for diagnostics) + real :: E_y(SZI_(G),SZJB_(G)) ! Y-slope of interface at v points [Z L-1 ~> nondim] (for diagnostics) + real :: U_xH_x(SZIB_(G), SZJ_(G)) ! X-slope of U and H [T-1 ~> s-1] + real :: U_yH_y(SZI_(G), SZJB_(G)) ! Y-slope of U and H [T-1 ~> s-1] + real :: V_xH_x(SZIB_(G), SZJ_(G)) ! X-slope of V and H [T-1 ~> s-1] + real :: V_yH_y(SZI_(G), SZJB_(G)) ! Y-slope of V and H [T-1 ~> s-1] + real :: H_cutoff ! Local estimate of a minimum thickness for masking [H ~> m or kg m-2] + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: S2 ! Interface slope squared [Z2 L-2 ~> nondim] + real :: N2 ! Brunt-Vaisala frequency squared [L2 Z-2 T-2 ~> s-2] + real :: gradUH ! Gradient model frequency, zonal transport [T-1 ~> s-1] + real :: gradVH ! Gradient model frequency, merid transport [T-1 ~> s-1] + real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] + real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. + real :: S2N2_u_local(SZIB_(G),SZJ_(G),SZK_(GV)) ! The depth integral of the slope times + ! the buoyancy frequency squared at u-points [Z T-2 ~> m s-2] + real :: S2N2_v_local(SZI_(G),SZJB_(G),SZK_(GV)) ! The depth integral of the slope times + ! the buoyancy frequency squared at v-points [Z T-2 ~> m s-2] + real :: UH_grad_local(SZIB_(G), SZJ_(G),SZK_(GV)) ! The depth integral of grad slopes for UH at u-points + real :: VH_grad_local(SZI_(G), SZJB_(G),SZK_(GV)) ! The depth integral of grad slopes for VH at v-points + integer :: is, ie, js, je, nz + integer :: i, j, k + integer :: l_seg + + if (.not. CS%initialized) call MOM_error(FATAL, "calc_slope_functions_using_just_e: "// & + "Module must be initialized before it is used.") + + if (.not. CS%calculate_Eady_growth_rate) return + if (.not. allocated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function:"// & + "%SN_u is not associated with use_variable_mixing.") + if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:"// & + "%SN_v is not associated with use_variable_mixing.") + if (.not. allocated(CS%UH_grad)) call MOM_error(FATAL, "calc_slope_function:"// & + "%UH_grad is not associated with use_gradient_model.") + if (.not. allocated(CS%VH_grad)) call MOM_error(FATAL, "calc_slope_function:"// & + "%VH_grad is not associated with use_gradient_model.") + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + h_neglect = GV%H_subroundoff + H_cutoff = real(2*nz) * (GV%Angstrom_H + h_neglect) + + ! To set length scale for gradient model + ! To set the length scale based on the deformation radius, use wave_speed to + ! calculate the first-mode gravity wave speed and then blend the equatorial + ! and midlatitude deformation radii, using calc_resoln_function as a template. + + !$OMP parallel do default(shared) private(E_x,E_y,S2,Hdn,Hup,H_geom,N2) + ! Set the length scale at u-points. +!$OMP do + do j=js,je ; do I=is-1,ie +! CS%L2u(I,j) = CS%Visbeck_L_scale**2 + Lgrid = sqrt(G%dxCu(I,j)**2 + G%dyCu(I,j)**2) +! CS%L2grad_u(I,j) = CS%grad_L_scale * Lgrid**2 + CS%L2grad_u(I,j) = 1.0 * Lgrid**2 + enddo ; enddo + ! Set length scale at v-points +!$OMP do + do J=js-1,je ; do i=is,ie +! CS%L2v(i,J) = CS%Visbeck_L_scale**2 + Lgrid = sqrt(G%dxCv(i,J)**2 + G%dyCv(i,J)**2) +! CS%L2grad_v(i,J) = CS%grad_L_scale * Lgrid**2 + CS%L2grad_v(i,J) = 1.0 * Lgrid**2 + enddo ; enddo +!$OMP do + do k=nz,CS%VarMix_Ktop,-1 + + if (calculate_slopes) then + ! Calculate the interface slopes E_x and E_y and u- and v- points respectively + do j=js-1,je+1 ; do I=is-1,ie + E_x(I,j) = (e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) + ! Mask slopes where interface intersects topography + if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. + enddo ; enddo + do J=js-1,je ; do i=is-1,ie+1 + E_y(i,J) = (e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) + ! Mask slopes where interface intersects topography + if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) E_y(I,j) = 0. + enddo ; enddo + else ! This branch is not used. + do j=js-1,je+1 ; do I=is-1,ie + E_x(I,j) = CS%slope_x(I,j,k) + if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. + enddo ; enddo + do j=js-1,je ; do I=is-1,ie+1 + E_y(i,J) = CS%slope_y(i,J,k) + if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) E_y(I,j) = 0. + enddo ; enddo + endif + + if (calculate_slopes) then + ! Calculate the gradient slopes U_xH_x, V_xH_x, U_yH_y, V_yH_y on u- and v-points respectively + do j=js-1,je+1 ; do I=is-1,ie + U_xH_x(I,j) =1.0*(G%IdxCu(I+1,j)*G%IdyCu(I+1,j)*uh(I+1,j,K) - G%IdxCu(I,j)*G%IdyCu(I,j)*uh(I,j,k))*( & + G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dyCu(I,j) * (2.0*(h(I+1,j,K) - h(I,j,K))/( & + h(I+1,j,K) + h(I,j,K) + h_neglect)) + V_xH_x(I,j) =1.0*(G%IdxCv(I+1,j)*G%IdxCv(I+1,j)*vh(I+1,j,K) - G%IdxCv(I,j)*G%IdxCv(I,j)*vh(I,j,k))*( & + G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dyCu(I,j) * (2.0*(h(I+1,j,K) - h(I,j,K))/( & + h(I+1,j,K) + h(I,j,K) + h_neglect)) + ! Mask slopes where interface intersects topography + if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) U_xH_x(I,j) = 0. + if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) V_xH_x(I,j) = 0. + enddo ; enddo + do J=js-1,je ; do i=is-1,ie+1 + U_yH_y(i,J) =1.0*(G%IdyCu(i,J+1)**G%IdyCu(i,J+1)*uh(i,J+1,K) - G%IdyCu(i,J)*G%IdyCu(i,J)*uh(i,J,k))*( & + G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCu(i,J) * (2.0*(h(i,J+1,K) - h(i,J,K))/( & + h(i,J+1,K) + h(i,J,K) + h_neglect)) + V_yH_y(i,J) =1.0*(G%IdyCv(i,J+1)*G%IdxCv(i,J+1)*vh(i,J,K) - G%IdyCv(i,J)*G%IdxCv(i,J)*vh(i,J,k))*( & + G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCv(I,j) * (2.0*(h(i,J+1,K) - h(i,J,K))/( & + h(i,J+1,K) + h(i,J,K) + h_neglect)) + ! Mask slopes where interface intersects topography + if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) U_yH_y(I,j) = 0. + if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) V_yH_y(I,j) = 0. + enddo ; enddo + else ! This branch is not used. + do j=js-1,je+1 ; do I=is-1,ie + U_xH_x(I,j) =1.0*(G%IdxCu(I+1,j)*G%IdyCu(I+1,j)*uh(I+1,j,K) - G%IdxCu(I,j)*G%IdyCu(I,j)*uh(I,j,k))*( & + G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dyCu(I,j) * (2.0*(h(I+1,j,K) - h(I,j,K))/( & + h(I+1,j,K) + h(I,j,K) + h_neglect)) + V_xH_x(I,j) =1.0*(G%IdxCv(I+1,j)*G%IdxCv(I+1,j)*vh(I+1,j,K) - G%IdxCv(I,j)*G%IdxCv(I,j)*vh(I,j,k))*( & + G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dy_Cu(I,j) * (2.0*(h(I+1,j,K) - h(I,j,K))/( & + h(I+1,j,K) + h(I,j,K) + h_neglect)) + if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) U_xH_x(I,j) = 0. + if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) V_xH_x(I,j) = 0. + enddo ; enddo + do j=js-1,je ; do I=is-1,ie+1 + U_yH_y(i,J) =1.0*(G%IdyCu(i,J+1)*G%IdyCu(i,J+1)*uh(i,J+1,K) - G%IdyCu(i,J)*G%IdyCu(i,J)*uh(i,J,k))*( & + G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCu(i,J) * (2.0*(h(i,J+1,K) - h(i,J,K))/( & + h(i,J+1,K) + h(i,J,K) + h_neglect)) + V_yH_y(i,J) =1.0*(G%IdyCv(i,J+1)*G%IdxCv(i,J+1)*vh(i,J,K) - G%IdyCv(i,J)*G%IdxCv(i,J)*vh(i,J,k))*( & + G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCv(I,j) * (2.0*(h(i,J+1,K) - h(i,J,K))/( & + h(i,J+1,K) + h(i,J,K) + h_neglect)) + if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) U_yH_y(I,j) = 0. + if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) V_yH_y(I,j) = 0. + enddo ; enddo + endif + + ! Calculate N*S*h from this layer and add to the sum + do j=js,je ; do I=is-1,ie + S2 = ( E_x(I,j)**2 + 0.25*( & + (E_y(I,j)**2+E_y(I+1,j-1)**2) + (E_y(I+1,j)**2+E_y(I,j-1)**2) ) ) + Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) + Hup = 2.*h(i+1,j,k)*h(i+1,j,k-1) / (h(i+1,j,k) + h(i+1,j,k-1) + h_neglect) + H_geom = sqrt(Hdn*Hup) + N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) + gradUH = U_xH_x(I,j) + 0.25*(U_yH_y(I,j)+U_yH_y(I,j-1)+U_yH_y(I+1,j)+U_yH_y(I+1,j-1)) + if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) & + S2 = 0.0 + gradUH = 0.0 + S2N2_u_local(I,j,k) = (H_geom * GV%H_to_Z) * S2 * N2 + UH_grad_local(I,j,k) = gradUH + enddo ; enddo + do J=js-1,je ; do i=is,ie + S2 = ( E_y(i,J)**2 + 0.25*( & + (E_x(i,J)**2+E_x(i-1,J+1)**2) + (E_x(i,J+1)**2+E_x(i-1,J)**2) ) ) + Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) + Hup = 2.*h(i,j+1,k)*h(i,j+1,k-1) / (h(i,j+1,k) + h(i,j+1,k-1) + h_neglect) + H_geom = sqrt(Hdn*Hup) + N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) + gradVH = 0.25*(V_xH_x(i,J)+V_xH_x(i-1,J)+V_xH_x(i,J+1)+V_xH_x(i-1,J+1))+V_yH_y(i,J) + if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) & + S2 = 0.0 + gradVH = 0.0 + S2N2_v_local(i,J,k) = (H_geom * GV%H_to_Z) * S2 * N2 + VH_grad_local(i,J,k) = gradVH + enddo ; enddo + + enddo ! k + !$OMP parallel do default(shared) + do j=js,je + do I=is-1,ie ; CS%SN_u(I,j) = 0.0 ; enddo + do k=nz,CS%VarMix_Ktop,-1 ; do I=is-1,ie + CS%SN_u(I,j) = CS%SN_u(I,j) + S2N2_u_local(I,j,k) + CS%UH_grad(I,j,k) = UH_grad_local(I,j,k) + enddo ; enddo + ! SN above contains S^2*N^2*H, convert to vertical average of S*N + do I=is-1,ie + !### Replace G%bathT+G%Z_ref here with (e(i,j,1) - e(i,j,nz+1)). + !SN_u(I,j) = sqrt( SN_u(I,j) / ( max(G%bathyT(i,j), G%bathyT(i+1,j)) + (G%Z_ref + GV%Angstrom_Z) ) ) + !The code below behaves better than the line above. Not sure why? AJA + if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > H_cutoff*GV%H_to_Z ) then + CS%SN_u(I,j) = G%OBCmaskCu(I,j) * sqrt( CS%SN_u(I,j) / & + (max(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref) ) +!! CS%UH_grad(I,j) = G%OBCmaskCu(I,j) * ( CS%UH_grad(I,j) / (max(G%bathyT(I,j), G%bathyT(I+1,j)) + G%Z_ref) ) + else + CS%SN_u(I,j) = 0.0 +!! CS%UH_grad(I,j) = 0.0 + endif + enddo + enddo + !$OMP parallel do default(shared) + do J=js-1,je + do i=is,ie ; CS%SN_v(i,J) = 0.0 ; enddo + do k=nz,CS%VarMix_Ktop,-1 ; do i=is,ie + CS%SN_v(i,J) = CS%SN_v(i,J) + S2N2_v_local(i,J,k) + CS%VH_grad(i,J,k) = VH_grad_local(i,J,k) + enddo ; enddo + do i=is,ie + !### Replace G%bathT+G%Z_ref here with (e(i,j,1) - e(i,j,nz+1)). + !SN_v(i,J) = sqrt( SN_v(i,J) / ( max(G%bathyT(i,J), G%bathyT(i,J+1)) + (G%Z_ref + GV%Angstrom_Z) ) ) + !The code below behaves better than the line above. Not sure why? AJA + if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > H_cutoff*GV%H_to_Z ) then + CS%SN_v(i,J) = G%OBCmaskCv(i,J) * sqrt( CS%SN_v(i,J) / & + (max(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref) ) +! CS%VH_grad(i,J) = G%OBCmaskCv(i,J) * (CS%VH_grad(i,J) / (max(G%bathyT(i,J), G%bathyT(i,J+1)) + G%Z_ref) ) + else + CS%SN_v(i,J) = 0.0 +! CS%VH_grad(i,J) = 0.0 + endif + enddo + enddo + +end subroutine calc_slope_functions_using_just_e + +!> Calculates the Leith Laplacian and bi-harmonic viscosity coefficients +subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vort_xy_dx, vort_xy_dy) + type(VarMix_CS), intent(inout) :: CS !< Variable mixing coefficients + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + integer, intent(in) :: k !< Layer for which to calculate vorticity magnitude + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: div_xx_dx !< x-derivative of horizontal divergence + !! (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: div_xx_dy !< y-derivative of horizontal divergence + !! (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vort_xy_dx !< x-derivative of vertical vorticity + !! (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: vort_xy_dy !< y-derivative of vertical vorticity + !! (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] + ! Local variables + real, dimension(SZI_(G),SZJB_(G)) :: & + dslopey_dz, & ! z-derivative of y-slope at v-points [L-1 ~> m-1] + h_at_v, & ! Thickness at v-points [H ~> m or kg m-2] + beta_v, & ! Beta at v-points [T-1 L-1 ~> s-1 m-1] + grad_vort_mag_v, & ! Magnitude of vorticity gradient at v-points [T-1 L-1 ~> s-1 m-1] + grad_div_mag_v ! Magnitude of divergence gradient at v-points [T-1 L-1 ~> s-1 m-1] + + real, dimension(SZIB_(G),SZJ_(G)) :: & + dslopex_dz, & ! z-derivative of x-slope at u-points [L-1 ~> m-1] + h_at_u, & ! Thickness at u-points [H ~> m or kg m-2] + beta_u, & ! Beta at u-points [T-1 L-1 ~> s-1 m-1] + grad_vort_mag_u, & ! Magnitude of vorticity gradient at u-points [T-1 L-1 ~> s-1 m-1] + grad_div_mag_u ! Magnitude of divergence gradient at u-points [T-1 L-1 ~> s-1 m-1] + real :: h_at_slope_above ! The thickness above [H ~> m or kg m-2] + real :: h_at_slope_below ! The thickness below [H ~> m or kg m-2] + real :: Ih ! The inverse of a combination of thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: f ! A copy of the Coriolis parameter [T-1 ~> s-1] + real :: inv_PI3 ! The inverse of pi cubed [nondim] + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq,nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + nz = GV%ke + + inv_PI3 = 1.0 / ((4.0*atan(1.0))**3) + + if ((k > 1) .and. (k < nz)) then + + ! With USE_QG_LEITH_VISC=True, this might need to change to + ! do j=js-2,je+2 ; do I=is-2,ie+1 + ! but other arrays used here (e.g., h and CS%slope_x) would also need to have wider valid halos. + do j=js-1,je+1 ; do I=is-2,Ieq+1 + h_at_slope_above = 2. * ( h(i,j,k-1) * h(i+1,j,k-1) ) * ( h(i,j,k) * h(i+1,j,k) ) / & + ( ( h(i,j,k-1) * h(i+1,j,k-1) ) * ( h(i,j,k) + h(i+1,j,k) ) & + + ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k-1) + h(i+1,j,k-1) ) + GV%H_subroundoff**2 ) + h_at_slope_below = 2. * ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) * h(i+1,j,k+1) ) / & + ( ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) + h(i+1,j,k+1) ) & + + ( h(i,j,k+1) * h(i+1,j,k+1) ) * ( h(i,j,k) + h(i+1,j,k) ) + GV%H_subroundoff**2 ) + Ih = 1./ ( ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) * GV%H_to_Z ) + dslopex_dz(I,j) = 2. * ( CS%slope_x(i,j,k) - CS%slope_x(i,j,k+1) ) * Ih + h_at_u(I,j) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih + enddo ; enddo + + ! With USE_QG_LEITH_VISC=True, this might need to change to + ! do J=js-2,je+1 ; do i=is-2,ie+2 + do J=js-2,Jeq+1 ; do i=is-1,ie+1 + h_at_slope_above = 2. * ( h(i,j,k-1) * h(i,j+1,k-1) ) * ( h(i,j,k) * h(i,j+1,k) ) / & + ( ( h(i,j,k-1) * h(i,j+1,k-1) ) * ( h(i,j,k) + h(i,j+1,k) ) & + + ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k-1) + h(i,j+1,k-1) ) + GV%H_subroundoff**2 ) + h_at_slope_below = 2. * ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) * h(i,j+1,k+1) ) / & + ( ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) + h(i,j+1,k+1) ) & + + ( h(i,j,k+1) * h(i,j+1,k+1) ) * ( h(i,j,k) + h(i,j+1,k) ) + GV%H_subroundoff**2 ) + Ih = 1./ ( ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) * GV%H_to_Z ) + dslopey_dz(i,J) = 2. * ( CS%slope_y(i,j,k) - CS%slope_y(i,j,k+1) ) * Ih + h_at_v(i,J) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih + enddo ; enddo + + ! With USE_QG_LEITH_VISC=True, this might need to be + ! do J=js-2,je+1 ; do i=is-1,ie+1 + do J=js-1,je ; do i=is-1,Ieq+1 + f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J) ) + vort_xy_dx(i,J) = vort_xy_dx(i,J) - f * & + ( ( h_at_u(I,j) * dslopex_dz(I,j) + h_at_u(I-1,j+1) * dslopex_dz(I-1,j+1) ) & + + ( h_at_u(I-1,j) * dslopex_dz(I-1,j) + h_at_u(I,j+1) * dslopex_dz(I,j+1) ) ) / & + ( ( h_at_u(I,j) + h_at_u(I-1,j+1) ) + ( h_at_u(I-1,j) + h_at_u(I,j+1) ) + GV%H_subroundoff) + enddo ; enddo + + ! With USE_QG_LEITH_VISC=True, this might need to be + ! do j=js-1,je+1 ; do I=is-2,ie+1 + do j=js-1,Jeq+1 ; do I=is-1,ie + f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) + vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * & + ( ( h_at_v(i,J) * dslopey_dz(i,J) + h_at_v(i+1,J-1) * dslopey_dz(i+1,J-1) ) & + + ( h_at_v(i,J-1) * dslopey_dz(i,J-1) + h_at_v(i+1,J) * dslopey_dz(i+1,J) ) ) / & + ( ( h_at_v(i,J) + h_at_v(i+1,J-1) ) + ( h_at_v(i,J-1) + h_at_v(i+1,J) ) + GV%H_subroundoff) + enddo ; enddo + endif ! k > 1 + + if (CS%use_QG_Leith_GM) then + + do j=js,je ; do I=is-1,Ieq + grad_vort_mag_u(I,j) = SQRT(vort_xy_dy(I,j)**2 + (0.25*((vort_xy_dx(i,J) + vort_xy_dx(i+1,J-1)) & + + (vort_xy_dx(i+1,J) + vort_xy_dx(i,J-1))))**2) + grad_div_mag_u(I,j) = SQRT(div_xx_dx(I,j)**2 + (0.25*((div_xx_dy(i,J) + div_xx_dy(i+1,J-1)) & + + (div_xx_dy(i+1,J) + div_xx_dy(i,J-1))))**2) + if (CS%use_beta_in_QG_Leith) then + beta_u(I,j) = sqrt((0.5*(G%dF_dx(i,j)+G%dF_dx(i+1,j))**2) + & + (0.5*(G%dF_dy(i,j)+G%dF_dy(i+1,j))**2)) + CS%KH_u_QG(I,j,k) = MIN(grad_vort_mag_u(I,j) + grad_div_mag_u(I,j), 3.0*beta_u(I,j)) * & + CS%Laplac3_const_u(I,j) * inv_PI3 + else + CS%KH_u_QG(I,j,k) = (grad_vort_mag_u(I,j) + grad_div_mag_u(I,j)) * & + CS%Laplac3_const_u(I,j) * inv_PI3 + endif + enddo ; enddo + + do J=js-1,Jeq ; do i=is,ie + grad_vort_mag_v(i,J) = SQRT(vort_xy_dx(i,J)**2 + (0.25*((vort_xy_dy(I,j) + vort_xy_dy(I-1,j+1)) & + + (vort_xy_dy(I,j+1) + vort_xy_dy(I-1,j))))**2) + grad_div_mag_v(i,J) = SQRT(div_xx_dy(i,J)**2 + (0.25*((div_xx_dx(I,j) + div_xx_dx(I-1,j+1)) & + + (div_xx_dx(I,j+1) + div_xx_dx(I-1,j))))**2) + if (CS%use_beta_in_QG_Leith) then + beta_v(i,J) = sqrt((0.5*(G%dF_dx(i,j)+G%dF_dx(i,j+1))**2) + & + (0.5*(G%dF_dy(i,j)+G%dF_dy(i,j+1))**2)) + CS%KH_v_QG(i,J,k) = MIN(grad_vort_mag_v(i,J) + grad_div_mag_v(i,J), 3.0*beta_v(i,J)) * & + CS%Laplac3_const_v(i,J) * inv_PI3 + else + CS%KH_v_QG(i,J,k) = (grad_vort_mag_v(i,J) + grad_div_mag_v(i,J)) * & + CS%Laplac3_const_v(i,J) * inv_PI3 + endif + enddo ; enddo + ! post diagnostics + + if (k==nz) then + if (CS%id_KH_v_QG > 0) call post_data(CS%id_KH_v_QG, CS%KH_v_QG, CS%diag) + if (CS%id_KH_u_QG > 0) call post_data(CS%id_KH_u_QG, CS%KH_u_QG, CS%diag) + endif + endif + +end subroutine calc_QG_Leith_viscosity + +!> Initializes the variables mixing coefficients container +subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handles + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(VarMix_CS), intent(inout) :: CS !< Variable mixing coefficients + + ! Local variables + real :: KhTr_Slope_Cff ! The nondimensional coefficient in the Visbeck formula + ! for the epipycnal tracer diffusivity [nondim] + real :: KhTh_Slope_Cff ! The nondimensional coefficient in the Visbeck formula + ! for the interface depth diffusivity [nondim] + real :: Grad_L_Scale ! The nondimensional coefficient in the gradient formula + ! for the depth diffusivity [nondim] + real :: oneOrTwo ! A variable that may be 1 or 2, depending on which form + ! of the equatorial deformation radius us used [nondim] + real :: N2_filter_depth ! A depth below which stratification is treated as monotonic when + ! calculating the first-mode wave speed [Z ~> m] + real :: KhTr_passivity_coeff ! Coefficient setting the ratio between along-isopycnal tracer + ! mixing and interface height mixing [nondim] + real :: absurdly_small_freq ! A miniscule frequency that is used to avoid division by 0 [T-1 ~> s-1]. The + ! default value is roughly (pi / (the age of the universe)). + logical :: Gill_equatorial_Ld, use_FGNV_streamfn, use_MEKE, in_use + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. + logical :: remap_answers_2018 + integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use + ! for remapping. Values below 20190101 recover the remapping + ! answers from 2018, while higher values use more robust + ! forms of the same remapping expressions. + real :: MLE_front_length ! The frontal-length scale used to calculate the upscaling of + ! buoyancy gradients in boundary layer parameterizations [L ~> m] + real :: Leith_Lap_const ! The non-dimensional coefficient in the Leith viscosity [nondim] + real :: grid_sp_u2, grid_sp_v2 ! Intermediate quantities for Leith metrics [L2 ~> m2] + real :: grid_sp_u3, grid_sp_v3 ! Intermediate quantities for Leith metrics [L3 ~> m3] + real :: wave_speed_min ! A floor in the first mode speed below which 0 is returned [L T-1 ~> m s-1] + real :: wave_speed_tol ! The fractional tolerance for finding the wave speeds [nondim] + logical :: Resoln_scaled_MEKE_visc ! If true, the viscosity contribution from MEKE is + ! scaled by the resolution function. + logical :: better_speed_est ! If true, use a more robust estimate of the first + ! mode wave speed as the starting point for iterations. + real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale + ! temperature variance [nondim] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_lateral_mixing_coeffs" ! This module's name. + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + CS%initialized = .true. + in_use = .false. ! Set to true to avoid deallocating + CS%diag => diag ! Diagnostics pointer + CS%calculate_cg1 = .false. + CS%calculate_Rd_dx = .false. + CS%calculate_res_fns = .false. + CS%use_simpler_Eady_growth_rate = .false. + CS%calculate_depth_fns = .false. + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "USE_VARIABLE_MIXING", CS%use_variable_mixing,& + "If true, the variable mixing code will be called. This "//& + "allows diagnostics to be created even if the scheme is "//& + "not used. If KHTR_SLOPE_CFF>0 or KhTh_Slope_Cff>0, "//& + "this is set to true regardless of what is in the "//& + "parameter file.", default=.false.) + ! call get_param(param_file, mdl, "USE_GRADIENT_MODEL", CS%use_gradient_model,& + ! "If true, use the gradient model formula for eddy diffusivity. This "//& + ! "allows diagnostics to be created even if the scheme is "//& + ! "not used. If Grad_L_Scale>0, this is set to true regardless of what "//& + ! "is in the parameter file.", default=.false.) + call get_param(param_file, mdl, "USE_VISBECK", CS%use_Visbeck,& + "If true, use the Visbeck et al. (1997) formulation for \n"//& + "thickness diffusivity.", default=.false.) + call get_param(param_file, mdl, "RESOLN_SCALED_KH", CS%Resoln_scaled_Kh, & + "If true, the Laplacian lateral viscosity is scaled away "//& + "when the first baroclinic deformation radius is well "//& + "resolved.", default=.false.) + call get_param(param_file, mdl, "DEPTH_SCALED_KHTH", CS%Depth_scaled_KhTh, & + "If true, KHTH is scaled away when the depth is shallower"//& + "than a reference depth: KHTH = MIN(1,H/H0)**N * KHTH, "//& + "where H0 is a reference depth, controlled via DEPTH_SCALED_KHTH_H0, "//& + "and the exponent (N) is controlled via DEPTH_SCALED_KHTH_EXP.",& + default=.false.) + call get_param(param_file, mdl, "RESOLN_SCALED_KHTH", CS%Resoln_scaled_KhTh, & + "If true, the interface depth diffusivity is scaled away "//& + "when the first baroclinic deformation radius is well "//& + "resolved.", default=.false.) + call get_param(param_file, mdl, "RESOLN_SCALED_KHTR", CS%Resoln_scaled_KhTr, & + "If true, the epipycnal tracer diffusivity is scaled "//& + "away when the first baroclinic deformation radius is "//& + "well resolved.", default=.false.) + call get_param(param_file, mdl, "USE_MEKE", use_MEKE, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "RES_SCALE_MEKE_VISC", Resoln_scaled_MEKE_visc, & + "If true, the viscosity contribution from MEKE is scaled by "//& + "the resolution function.", default=.false., do_not_log=.true.) ! Logged elsewhere. + if (.not.use_MEKE) Resoln_scaled_MEKE_visc = .false. + call get_param(param_file, mdl, "RESOLN_USE_EBT", CS%Resoln_use_ebt, & + "If true, uses the equivalent barotropic wave speed instead "//& + "of first baroclinic wave for calculating the resolution fn.",& + default=.false.) + call get_param(param_file, mdl, "KHTH_USE_EBT_STRUCT", CS%khth_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of thickness diffusivity.",& + default=.false.) + call get_param(param_file, mdl, "KD_GL90_USE_EBT_STRUCT", CS%kdgl90_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of diffusivity in the GL90 scheme.",& + default=.false.) + call get_param(param_file, mdl, "KHTH_SLOPE_CFF", KhTh_Slope_Cff, & + "The nondimensional coefficient in the Visbeck formula "//& + "for the interface depth diffusivity", units="nondim", default=0.0) + call get_param(param_file, mdl, "KHTR_SLOPE_CFF", KhTr_Slope_Cff, & + "The nondimensional coefficient in the Visbeck formula "//& + "for the epipycnal tracer diffusivity", units="nondim", default=0.0) + call get_param(param_file, mdl, "USE_STORED_SLOPES", CS%use_stored_slopes,& + "If true, the isopycnal slopes are calculated once and "//& + "stored for re-use. This uses more memory but avoids calling "//& + "the equation of state more times than should be necessary.", & + default=.false.) + call get_param(param_file, mdl, "VERY_SMALL_FREQUENCY", absurdly_small_freq, & + "A miniscule frequency that is used to avoid division by 0. The default "//& + "value is roughly (pi / (the age of the universe)).", & + default=1.0e-17, units="s-1", scale=US%T_to_s) + call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", use_FGNV_streamfn, & + default=.false., do_not_log=.true.) + CS%calculate_cg1 = CS%calculate_cg1 .or. use_FGNV_streamfn .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct + CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. use_MEKE + ! Indicate whether to calculate the Eady growth rate + CS%calculate_Eady_growth_rate = use_MEKE .or. (KhTr_Slope_Cff>0.) .or. (KhTh_Slope_Cff>0.) + call get_param(param_file, mdl, "KHTR_PASSIVITY_COEFF", KhTr_passivity_coeff, & + units="nondim", default=0., do_not_log=.true.) + CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. (KhTr_passivity_coeff>0.) + call get_param(param_file, mdl, "MLE_FRONT_LENGTH", MLE_front_length, & + units="m", default=0.0, scale=US%m_to_L, do_not_log=.true.) + CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. (MLE_front_length>0.) + + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) + + call get_param(param_file, mdl, "USE_STANLEY_ISO", CS%use_stanley_iso, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in isopycnal slope code.", default=.false.) + if (CS%use_stanley_iso) then + call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & + "Coefficient correlating the temperature gradient and SGS T variance.", & + units="nondim", default=-1.0, do_not_log=.true.) + if (Stanley_coeff < 0.0) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ISO is true.") + endif + + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct) then + in_use = .true. + call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & + "The depth below which N2 is monotonized to avoid stratification "//& + "artifacts from altering the equivalent barotropic mode structure.",& + units="m", default=2000., scale=US%m_to_Z) + allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke), source=0.0) + endif + + if (CS%use_stored_slopes) then + if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then + call get_param(param_file, mdl, "VISBECK_MAX_SLOPE", CS%Visbeck_S_max, & + "If non-zero, is an upper bound on slopes used in the "//& + "Visbeck formula for diffusivity. This does not affect the "//& + "isopycnal slope calculation used within thickness diffusion.", & + units="nondim", default=0.0, scale=US%L_to_Z) + else + CS%Visbeck_S_max = 0. + endif + endif + + if (CS%use_stored_slopes) then + ! CS%calculate_Eady_growth_rate=.true. + in_use = .true. + allocate(CS%slope_x(IsdB:IedB,jsd:jed,GV%ke+1), source=0.0) + allocate(CS%slope_y(isd:ied,JsdB:JedB,GV%ke+1), source=0.0) + call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & + "A diapycnal diffusivity that is used to interpolate "//& + "more sensible values of T & S into thin layers.", & + units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + endif + + if (CS%calculate_Eady_growth_rate) then + in_use = .true. + allocate(CS%SN_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%SN_v(isd:ied,JsdB:JedB), source=0.0) + CS%id_SN_u = register_diag_field('ocean_model', 'SN_u', diag%axesCu1, Time, & + 'Inverse eddy time-scale, S*N, at u-points', 's-1', conversion=US%s_to_T) + CS%id_SN_v = register_diag_field('ocean_model', 'SN_v', diag%axesCv1, Time, & + 'Inverse eddy time-scale, S*N, at v-points', 's-1', conversion=US%s_to_T) + call get_param(param_file, mdl, "USE_SIMPLER_EADY_GROWTH_RATE", CS%use_simpler_Eady_growth_rate, & + "If true, use a simpler method to calculate the Eady growth rate "//& + "that avoids division by layer thickness. Recommended.", default=.false.) + if (CS%use_simpler_Eady_growth_rate) then + if (.not. CS%use_stored_slopes) call MOM_error(FATAL, & + "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& + "When USE_SIMPLER_EADY_GROWTH_RATE=True, USE_STORED_SLOPES must also be True.") + call get_param(param_file, mdl, "EADY_GROWTH_RATE_D_SCALE", CS%Eady_GR_D_scale, & + "The depth from surface over which to average SN when calculating "//& + "a 2D Eady growth rate. Zero mean use full depth.", & + units="m", default=0., scale=US%m_to_Z) + call get_param(param_file, mdl, "EADY_GROWTH_RATE_CROPPING_DISTANCE", CS%cropping_distance, & + "Distance from surface or bottom to filter out outcropped or "//& + "incropped interfaces for the Eady growth rate calc. "//& + "Negative values disables cropping.", units="m", default=0., scale=US%m_to_Z) + else + call get_param(param_file, mdl, "VARMIX_KTOP", CS%VarMix_Ktop, & + "The layer number at which to start vertical integration "//& + "of S*N for purposes of finding the Eady growth rate.", & + units="nondim", default=2) + call get_param(param_file, mdl, "MIN_DZ_FOR_SLOPE_N2", CS%h_min_N2, & + "The minimum vertical distance to use in the denominator of the "//& + "bouyancy frequency used in the slope calculation.", & + units="m", default=1.0, scale=GV%m_to_H, do_not_log=CS%use_stored_slopes) + endif + endif + + if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then + in_use = .true. + call get_param(param_file, mdl, "VISBECK_L_SCALE", CS%Visbeck_L_scale, & + "The fixed length scale in the Visbeck formula, or if negative a nondimensional "//& + "scaling factor relating this length scale squared to the cell areas.", & + units="m or nondim", default=0.0, scale=US%m_to_L) + allocate(CS%L2u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%L2v(isd:ied,JsdB:JedB), source=0.0) + if (CS%Visbeck_L_scale<0) then + ! Undo the rescaling of CS%Visbeck_L_scale. + do j=js,je ; do I=is-1,Ieq + CS%L2u(I,j) = (US%L_to_m*CS%Visbeck_L_scale)**2 * G%areaCu(I,j) + enddo ; enddo + do J=js-1,Jeq ; do i=is,ie + CS%L2v(i,J) = (US%L_to_m*CS%Visbeck_L_scale)**2 * G%areaCv(i,J) + enddo ; enddo + else + CS%L2u(:,:) = CS%Visbeck_L_scale**2 + CS%L2v(:,:) = CS%Visbeck_L_scale**2 + endif + + CS%id_L2u = register_diag_field('ocean_model', 'L2u', diag%axesCu1, Time, & + 'Length scale squared for mixing coefficient, at u-points', & + 'm2', conversion=US%L_to_m**2) + CS%id_L2v = register_diag_field('ocean_model', 'L2v', diag%axesCv1, Time, & + 'Length scale squared for mixing coefficient, at v-points', & + 'm2', conversion=US%L_to_m**2) + endif + + if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then + in_use = .true. + call get_param(param_file, mdl, "GRAD_L_SCALE", CS%grad_L_scale, & + "The fixed length scale in the gradient formula.", units="m", & + default=1.0) + allocate(CS%UH_grad(IsdB:IedB,jsd:jed,GV%ke), source=0.0) + allocate(CS%VH_grad(isd:ied,JsdB:JedB,GV%ke), source=0.0) + allocate(CS%L2grad_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%L2grad_v(isd:ied,JsdB:JedB), source=0.0) + endif + + CS%id_UH_grad = register_diag_field('ocean_model', 'UH_grad', diag%axesCu1, Time, & + 'Inverse gradient eddy time-scale, U_xH_x+U_yH_y, at u-points', 's^-1') + CS%id_VH_grad = register_diag_field('ocean_model', 'VH_grad', diag%axesCv1, Time, & + 'Inverse gradient eddy time-scale, V_xH_x+V_yH_y, at v-points', 's^-1') + CS%id_L2grad_u = register_diag_field('ocean_model', 'L2grad_u', diag%axesCu1, Time, & + 'Length scale squared for gradient coefficient, at u-points', 'm^2') + CS%id_L2grad_v = register_diag_field('ocean_model', 'L2grad_v', diag%axesCv1, Time, & + 'Length scale squared for gradient coefficient, at v-points', 'm^2') + + + if (CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) then + CS%id_N2_u = register_diag_field('ocean_model', 'N2_u', diag%axesCui, Time, & + 'Square of Brunt-Vaisala frequency, N^2, at u-points, as used in Visbeck et al.', & + 's-2', conversion=(US%L_to_Z*US%s_to_T)**2) + CS%id_N2_v = register_diag_field('ocean_model', 'N2_v', diag%axesCvi, Time, & + 'Square of Brunt-Vaisala frequency, N^2, at v-points, as used in Visbeck et al.', & + 's-2', conversion=(US%L_to_Z*US%s_to_T)**2) + endif + if (CS%use_simpler_Eady_growth_rate) then + CS%id_dzu = register_diag_field('ocean_model', 'dzu_Visbeck', diag%axesCui, Time, & + 'dz at u-points, used in calculating Eady growth rate in Visbeck et al..', & + 'm', conversion=US%Z_to_m) + CS%id_dzv = register_diag_field('ocean_model', 'dzv_Visbeck', diag%axesCvi, Time, & + 'dz at v-points, used in calculating Eady growth rate in Visbeck et al..', & + 'm', conversion=US%Z_to_m) + CS%id_dzSxN = register_diag_field('ocean_model', 'dzSxN', diag%axesCui, Time, & + 'dz * |slope_x| * N, used in calculating Eady growth rate in '//& + 'Visbeck et al..', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + CS%id_dzSyN = register_diag_field('ocean_model', 'dzSyN', diag%axesCvi, Time, & + 'dz * |slope_y| * N, used in calculating Eady growth rate in '//& + 'Visbeck et al..', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + endif + if (CS%use_stored_slopes) then + CS%id_S2_u = register_diag_field('ocean_model', 'S2_u', diag%axesCu1, Time, & + 'Depth average square of slope magnitude, S^2, at u-points, as used in Visbeck et al.', & + 'nondim', conversion=US%Z_to_L**2) + CS%id_S2_v = register_diag_field('ocean_model', 'S2_v', diag%axesCv1, Time, & + 'Depth average square of slope magnitude, S^2, at v-points, as used in Visbeck et al.', & + 'nondim', conversion=US%Z_to_L**2) + endif + + oneOrTwo = 1.0 + CS%Resoln_scaling_used = CS%Resoln_scaled_Kh .or. CS%Resoln_scaled_KhTh .or. & + CS%Resoln_scaled_KhTr .or. Resoln_scaled_MEKE_visc + if (CS%Resoln_scaling_used) then + CS%calculate_Rd_dx = .true. + CS%calculate_res_fns = .true. + allocate(CS%Res_fn_h(isd:ied,jsd:jed), source=0.0) + allocate(CS%Res_fn_q(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%Res_fn_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%Res_fn_v(isd:ied,JsdB:JedB), source=0.0) + allocate(CS%beta_dx2_q(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%beta_dx2_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%beta_dx2_v(isd:ied,JsdB:JedB), source=0.0) + allocate(CS%f2_dx2_q(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%f2_dx2_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%f2_dx2_v(isd:ied,JsdB:JedB), source=0.0) + + CS%id_Res_fn = register_diag_field('ocean_model', 'Res_fn', diag%axesT1, Time, & + 'Resolution function for scaling diffusivities', 'nondim') + + call get_param(param_file, mdl, "KH_RES_SCALE_COEF", CS%Res_coef_khth, & + "A coefficient that determines how KhTh is scaled away if "//& + "RESOLN_SCALED_... is true, as "//& + "F = 1 / (1 + (KH_RES_SCALE_COEF*Rd/dx)^KH_RES_FN_POWER).", & + units="nondim", default=1.0) + call get_param(param_file, mdl, "KH_RES_FN_POWER", CS%Res_fn_power_khth, & + "The power of dx/Ld in the Kh resolution function. Any "//& + "positive integer may be used, although even integers "//& + "are more efficient to calculate. Setting this greater "//& + "than 100 results in a step-function being used.", & + default=2) + call get_param(param_file, mdl, "VISC_RES_SCALE_COEF", CS%Res_coef_visc, & + "A coefficient that determines how Kh is scaled away if "//& + "RESOLN_SCALED_... is true, as "//& + "F = 1 / (1 + (KH_RES_SCALE_COEF*Rd/dx)^KH_RES_FN_POWER). "//& + "This function affects lateral viscosity, Kh, and not KhTh.", & + units="nondim", default=CS%Res_coef_khth) + call get_param(param_file, mdl, "VISC_RES_FN_POWER", CS%Res_fn_power_visc, & + "The power of dx/Ld in the Kh resolution function. Any "//& + "positive integer may be used, although even integers "//& + "are more efficient to calculate. Setting this greater "//& + "than 100 results in a step-function being used. "//& + "This function affects lateral viscosity, Kh, and not KhTh.", & + default=CS%Res_fn_power_khth) + call get_param(param_file, mdl, "INTERPOLATE_RES_FN", CS%interpolate_Res_fn, & + "If true, interpolate the resolution function to the "//& + "velocity points from the thickness points; otherwise "//& + "interpolate the wave speed and calculate the resolution "//& + "function independently at each point.", default=.false.) + if (CS%interpolate_Res_fn) then + if (CS%Res_coef_visc /= CS%Res_coef_khth) call MOM_error(FATAL, & + "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& + "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_SCALE_COEF.") + if (CS%Res_fn_power_visc /= CS%Res_fn_power_khth) call MOM_error(FATAL, & + "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& + "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_FN_POWER.") + endif + call get_param(param_file, mdl, "GILL_EQUATORIAL_LD", Gill_equatorial_Ld, & + "If true, uses Gill's definition of the baroclinic "//& + "equatorial deformation radius, otherwise, if false, use "//& + "Pedlosky's definition. These definitions differ by a factor "//& + "of 2 in front of the beta term in the denominator. Gill's "//& + "is the more appropriate definition.", default=.true.) + if (Gill_equatorial_Ld) then + oneOrTwo = 2.0 + endif + + do J=js-1,Jeq ; do I=is-1,Ieq + CS%f2_dx2_q(I,J) = (G%dxBu(I,J)**2 + G%dyBu(I,J)**2) * & + max(G%CoriolisBu(I,J)**2, absurdly_small_freq**2) + CS%beta_dx2_q(I,J) = oneOrTwo * ((G%dxBu(I,J))**2 + (G%dyBu(I,J))**2) * (sqrt(0.5 * & + ( (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & + ((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2) + & + (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & + ((G%CoriolisBu(I,J+1)-G%CoriolisBu(I,J)) * G%IdyCu(I,j+1))**2) ) )) + enddo ; enddo + + do j=js,je ; do I=is-1,Ieq + CS%f2_dx2_u(I,j) = (G%dxCu(I,j)**2 + G%dyCu(I,j)**2) * & + max(0.5* (G%CoriolisBu(I,J)**2+G%CoriolisBu(I,J-1)**2), absurdly_small_freq**2) + CS%beta_dx2_u(I,j) = oneOrTwo * ((G%dxCu(I,j))**2 + (G%dyCu(I,j))**2) * (sqrt( & + 0.25*( (((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2 + & + ((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2) + & + (((G%CoriolisBu(I+1,J-1)-G%CoriolisBu(I,J-1)) * G%IdxCv(i+1,J-1))**2 + & + ((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2) ) + & + ((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 )) + enddo ; enddo + + do J=js-1,Jeq ; do i=is,ie + CS%f2_dx2_v(i,J) = ((G%dxCv(i,J))**2 + (G%dyCv(i,J))**2) * & + max(0.5*(G%CoriolisBu(I,J)**2+G%CoriolisBu(I-1,J)**2), absurdly_small_freq**2) + CS%beta_dx2_v(i,J) = oneOrTwo * ((G%dxCv(i,J))**2 + (G%dyCv(i,J))**2) * (sqrt( & + ((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & + 0.25*( (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & + ((G%CoriolisBu(I-1,J+1)-G%CoriolisBu(I-1,J)) * G%IdyCu(I-1,j+1))**2) + & + (((G%CoriolisBu(I,J+1)-G%CoriolisBu(I,J)) * G%IdyCu(I,j+1))**2 + & + ((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2) ) )) + enddo ; enddo + + endif + + if (CS%Depth_scaled_KhTh) then + CS%calculate_depth_fns = .true. + allocate(CS%Depth_fn_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%Depth_fn_v(isd:ied,JsdB:JedB), source=0.0) + call get_param(param_file, mdl, "DEPTH_SCALED_KHTH_H0", CS%depth_scaled_khth_h0, & + "The depth above which KHTH is scaled away.", & + units="m", scale=US%m_to_Z, default=1000.) + call get_param(param_file, mdl, "DEPTH_SCALED_KHTH_EXP", CS%depth_scaled_khth_exp, & + "The exponent used in the depth dependent scaling function for KHTH.", & + units="nondim", default=3.0) + endif + + ! Resolution %Rd_dx_h + CS%id_Rd_dx = register_diag_field('ocean_model', 'Rd_dx', diag%axesT1, Time, & + 'Ratio between deformation radius and grid spacing', 'm m-1') + CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. (CS%id_Rd_dx>0) + + if (CS%calculate_Rd_dx) then + CS%calculate_cg1 = .true. ! We will need %cg1 + allocate(CS%Rd_dx_h(isd:ied,jsd:jed), source=0.0) + allocate(CS%beta_dx2_h(isd:ied,jsd:jed), source=0.0) + allocate(CS%f2_dx2_h(isd:ied,jsd:jed), source=0.0) + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%f2_dx2_h(i,j) = (G%dxT(i,j)**2 + G%dyT(i,j)**2) * & + max(0.25 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)), & + absurdly_small_freq**2) + CS%beta_dx2_h(i,j) = oneOrTwo * ((G%dxT(i,j))**2 + (G%dyT(i,j))**2) * (sqrt(0.5 * & + ( (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & + ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & + (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & + ((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2) ) )) + enddo ; enddo + endif + + if (CS%calculate_cg1) then + in_use = .true. + allocate(CS%cg1(isd:ied,jsd:jed), source=0.0) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=(default_answer_date<20190101)) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) + ! Revise inconsistent default answer dates for remapping. + if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions. "//& + "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& + "latter takes precedence.", default=default_answer_date) + + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & + "The fractional tolerance for finding the wave speeds.", & + units="nondim", default=0.001) + !### Set defaults so that wave_speed_min*wave_speed_tol >= 1e-9 m s-1 + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_MIN", wave_speed_min, & + "A floor in the first mode speed below which 0 used instead.", & + units="m s-1", default=0.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_BETTER_EST", better_speed_est, & + "If true, use a more robust estimate of the first mode wave speed as the "//& + "starting point for iterations.", default=.true.) + call wave_speed_init(CS%wave_speed, use_ebt_mode=CS%Resoln_use_ebt, & + mono_N2_depth=N2_filter_depth, remap_answer_date=remap_answer_date, & + better_speed_est=better_speed_est, min_speed=wave_speed_min, & + wave_speed_tol=wave_speed_tol) + endif + + ! Leith parameters + call get_param(param_file, mdl, "USE_QG_LEITH_GM", CS%use_QG_Leith_GM, & + "If true, use the QG Leith viscosity as the GM coefficient.", & + default=.false.) + + if (CS%Use_QG_Leith_GM) then + call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, & + "The nondimensional Laplacian Leith constant, \n"//& + "often set to 1.0", units="nondim", default=0.0) + + call get_param(param_file, mdl, "USE_BETA_IN_LEITH", CS%use_beta_in_QG_Leith, & + "If true, include the beta term in the Leith nonlinear eddy viscosity.", & + default=.true.) + + ALLOC_(CS%Laplac3_const_u(IsdB:IedB,jsd:jed)) ; CS%Laplac3_const_u(:,:) = 0.0 + ALLOC_(CS%Laplac3_const_v(isd:ied,JsdB:JedB)) ; CS%Laplac3_const_v(:,:) = 0.0 + ALLOC_(CS%KH_u_QG(IsdB:IedB,jsd:jed,GV%ke)) ; CS%KH_u_QG(:,:,:) = 0.0 + ALLOC_(CS%KH_v_QG(isd:ied,JsdB:JedB,GV%ke)) ; CS%KH_v_QG(:,:,:) = 0.0 + ! register diagnostics + + CS%id_KH_u_QG = register_diag_field('ocean_model', 'KH_u_QG', diag%axesCuL, Time, & + 'Horizontal viscosity from Leith QG, at u-points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_KH_v_QG = register_diag_field('ocean_model', 'KH_v_QG', diag%axesCvL, Time, & + 'Horizontal viscosity from Leith QG, at v-points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + + do j=Jsq,Jeq+1 ; do I=is-1,Ieq + ! Static factors in the Leith schemes + grid_sp_u2 = G%dyCu(I,j)*G%dxCu(I,j) + grid_sp_u3 = grid_sp_u2*sqrt(grid_sp_u2) + CS%Laplac3_const_u(I,j) = Leith_Lap_const * grid_sp_u3 + enddo ; enddo + do j=js-1,Jeq ; do I=Isq,Ieq+1 + ! Static factors in the Leith schemes + grid_sp_v2 = G%dyCv(i,J)*G%dxCv(i,J) + grid_sp_v3 = grid_sp_v2*sqrt(grid_sp_v2) + CS%Laplac3_const_v(i,J) = Leith_Lap_const * grid_sp_v3 + enddo ; enddo + + if (.not. CS%use_stored_slopes) call MOM_error(FATAL, & + "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& + "USE_STORED_SLOPES must be True when using QG Leith.") + endif + + ! Re-enable variable mixing if one of the schemes was enabled + CS%use_variable_mixing = in_use .or. CS%use_variable_mixing +end subroutine VarMix_init + +!> Destructor for VarMix control structure +subroutine VarMix_end(CS) + type(VarMix_CS), intent(inout) :: CS + + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct) & + deallocate(CS%ebt_struct) + + if (CS%use_stored_slopes) then + deallocate(CS%slope_x) + deallocate(CS%slope_y) + endif + + if (CS%calculate_Eady_growth_rate) then + deallocate(CS%SN_u) + deallocate(CS%SN_v) + endif + + if (allocated(CS%L2u)) deallocate(CS%L2u) + if (allocated(CS%L2v)) deallocate(CS%L2v) + + if (CS%Resoln_scaling_used) then + deallocate(CS%Res_fn_h) + deallocate(CS%Res_fn_q) + deallocate(CS%Res_fn_u) + deallocate(CS%Res_fn_v) + deallocate(CS%beta_dx2_q) + deallocate(CS%beta_dx2_u) + deallocate(CS%beta_dx2_v) + deallocate(CS%f2_dx2_q) + deallocate(CS%f2_dx2_u) + deallocate(CS%f2_dx2_v) + endif + + if (CS%Depth_scaled_KhTh) then + deallocate(CS%Depth_fn_u) + deallocate(CS%Depth_fn_v) + endif + + if (CS%calculate_Rd_dx) then + deallocate(CS%Rd_dx_h) + deallocate(CS%beta_dx2_h) + deallocate(CS%f2_dx2_h) + endif + + if (CS%calculate_cg1) then + deallocate(CS%cg1) + endif + + if (CS%Use_QG_Leith_GM) then + DEALLOC_(CS%Laplac3_const_u) + DEALLOC_(CS%Laplac3_const_v) + DEALLOC_(CS%KH_u_QG) + DEALLOC_(CS%KH_v_QG) + endif +end subroutine VarMix_end + +!> \namespace mom_lateral_mixing_coeffs +!! +!! This module provides a container for various factors used in prescribing diffusivities, that are +!! a function of the state (in particular the stratification and isoneutral slopes). +!! +!! \section section_Resolution_Function The resolution function +!! +!! The resolution function is expressed in terms of the ratio of grid-spacing to deformation radius. +!! The square of the resolution parameter is +!! +!! \f[ +!! R^2 = \frac{L_d^2}{\Delta^2} = \frac{ c_g^2 }{ f^2 \Delta^2 + c_g \beta \Delta^2 } +!! \f] +!! +!! where the grid spacing is calculated as +!! +!! \f[ +!! \Delta^2 = \Delta x^2 + \Delta y^2 . +!! \f] +!! +!! \todo Check this reference to Bob on/off paper. +!! The resolution function used in scaling diffusivities (Hallberg, 2010) is +!! +!! \f[ +!! r(\Delta,L_d) = \frac{1}{1+(\alpha R)^p} +!! \f] +!! +!! The resolution function can be applied independently to thickness diffusion (module mom_thickness_diffuse), +!! tracer diffusion (mom_tracer_hordiff) lateral viscosity (mom_hor_visc). +!! +!! Robert Hallberg, 2013: Using a resolution function to regulate parameterizations of oceanic mesoscale eddy effects. +!! Ocean Modelling, 71, pp 92-103. http://dx.doi.org/10.1016/j.ocemod.2013.08.007 +!! +!! | Symbol | Module parameter | +!! | ------ | --------------- | +!! | - | USE_VARIABLE_MIXING | +!! | - | RESOLN_SCALED_KH | +!! | - | RESOLN_SCALED_KHTH | +!! | - | RESOLN_SCALED_KHTR | +!! | \f$ \alpha \f$ | KH_RES_SCALE_COEF (for thickness and tracer diffusivity) | +!! | \f$ p \f$ | KH_RES_FN_POWER (for thickness and tracer diffusivity) | +!! | \f$ \alpha \f$ | VISC_RES_SCALE_COEF (for lateral viscosity) | +!! | \f$ p \f$ | VISC_RES_FN_POWER (for lateral viscosity) | +!! | - | GILL_EQUATORIAL_LD | +!! +!! +!! +!! \section section_Vicbeck Visbeck diffusivity +!! +!! This module also calculates factors used in setting the thickness diffusivity similar to a Visbeck et al., 1997, +!! scheme. The factors are combined in mom_thickness_diffuse::thickness_diffuse() but calculated in this module. +!! +!! \f[ +!! \kappa_h = \alpha_s L_s^2 S N +!! \f] +!! +!! where \f$S\f$ is the magnitude of the isoneutral slope and \f$N\f$ is the Brunt-Vaisala frequency. +!! +!! Visbeck, Marshall, Haine and Spall, 1997: Specification of Eddy Transfer Coefficients in Coarse-Resolution +!! Ocean Circulation Models. J. Phys. Oceanogr. http://dx.doi.org/10.1175/1520-0485(1997)027%3C0381:SOETCI%3E2.0.CO;2 +!! +!! | Symbol | Module parameter | +!! | ------ | --------------- | +!! | - | USE_VARIABLE_MIXING | +!! | \f$ \alpha_s \f$ | KHTH_SLOPE_CFF (for mom_thickness_diffuse module)| +!! | \f$ \alpha_s \f$ | KHTR_SLOPE_CFF (for mom_tracer_hordiff module)| +!! | \f$ L_{s} \f$ | VISBECK_L_SCALE | +!! | \f$ S_{max} \f$ | VISBECK_MAX_SLOPE | +!! +!! +!! \section section_vertical_structure_khth Vertical structure function for KhTh +!! +!! The thickness diffusivity can be prescribed a vertical distribution with the shape of the equivalent barotropic +!! velocity mode. The structure function is stored in the control structure for thie module (varmix_cs) but is +!! calculated using subroutines in mom_wave_speed. +!! +!! | Symbol | Module parameter | +!! | ------ | --------------- | +!! | - | KHTH_USE_EBT_STRUCT | + +end module MOM_lateral_mixing_coeffs diff --git a/parameterizations/lateral/MOM_load_love_numbers.F90 b/parameterizations/lateral/MOM_load_love_numbers.F90 new file mode 100644 index 0000000000..3d573d894d --- /dev/null +++ b/parameterizations/lateral/MOM_load_love_numbers.F90 @@ -0,0 +1,1486 @@ +!> Load Love Numbers for degree range [0, 1440] +module MOM_load_love_numbers + +implicit none ; private + +public Love_Data + +integer, parameter :: lmax = 1440 !< Maximum degree of the stored Love numbers +real, dimension(4, lmax+1), parameter :: & + Love_Data = & + reshape((/ 0.0, 0.0000000000, 0.0000000000 , -1.0000000000 , & + 1.0, -1.2858777580,-8.9608179370e-1, -1.0000000000 , & + 2.0, -0.9907994900, 2.3286695000e-2, -3.0516104000e-1, & + 3.0, -1.0499631000, 6.9892136000e-2, -1.9585733000e-1, & + 4.0, -1.0526477000, 5.8670467000e-2, -1.3352284000e-1, & + 5.0, -1.0855918000, 4.6165153000e-2, -1.0456531000e-1, & + 6.0, -1.1431163000, 3.8586926000e-2, -9.0184841000e-2, & + 7.0, -1.2116273000, 3.4198827000e-2, -8.1906787000e-2, & + 8.0, -1.2831157000, 3.1474998000e-2, -7.6379141000e-2, & + 9.0, -1.3538554000, 2.9624407000e-2, -7.2250183000e-2, & + 10.0, -1.4223516000, 2.8273961000e-2, -6.8934145000e-2, & + 11.0, -1.4881117000, 2.7242278000e-2, -6.6147992000e-2, & + 12.0, -1.5510428000, 2.6431124000e-2, -6.3736253000e-2, & + 13.0, -1.6111895000, 2.5779507000e-2, -6.1602870000e-2, & + 14.0, -1.6686329000, 2.5245139000e-2, -5.9683159000e-2, & + 15.0, -1.7234569000, 2.4796803000e-2, -5.7931180000e-2, & + 16.0, -1.7757418000, 2.4410861000e-2, -5.6313294000e-2, & + 17.0, -1.8255646000, 2.4069336000e-2, -5.4804452000e-2, & + 18.0, -1.8730019000, 2.3758645000e-2, -5.3385807000e-2, & + 19.0, -1.9181321000, 2.3468646000e-2, -5.2043088000e-2, & + 20.0, -1.9610366000, 2.3191893000e-2, -5.0765423000e-2, & + 21.0, -2.0018000000, 2.2923032000e-2, -4.9544487000e-2, & + 22.0, -2.0405101000, 2.2658321000e-2, -4.8373866000e-2, & + 23.0, -2.0772571000, 2.2395242000e-2, -4.7248575000e-2, & + 24.0, -2.1121328000, 2.2132200000e-2, -4.6164708000e-2, & + 25.0, -2.1452296000, 2.1868280000e-2, -4.5119160000e-2, & + 26.0, -2.1766398000, 2.1603063000e-2, -4.4109431000e-2, & + 27.0, -2.2064546000, 2.1336479000e-2, -4.3133464000e-2, & + 28.0, -2.2347634000, 2.1068700000e-2, -4.2189540000e-2, & + 29.0, -2.2616531000, 2.0800053000e-2, -4.1276184000e-2, & + 30.0, -2.2872080000, 2.0530962000e-2, -4.0392105000e-2, & + 31.0, -2.3115088000, 2.0261897000e-2, -3.9536148000e-2, & + 32.0, -2.3346328000, 1.9993346000e-2, -3.8707260000e-2, & + 33.0, -2.3566536000, 1.9725790000e-2, -3.7904463000e-2, & + 34.0, -2.3776409000, 1.9459686000e-2, -3.7126837000e-2, & + 35.0, -2.3976605000, 1.9195459000e-2, -3.6373510000e-2, & + 36.0, -2.4167746000, 1.8933494000e-2, -3.5643644000e-2, & + 37.0, -2.4350414000, 1.8674136000e-2, -3.4936432000e-2, & + 38.0, -2.4525156000, 1.8417687000e-2, -3.4251094000e-2, & + 39.0, -2.4692484000, 1.8164407000e-2, -3.3586873000e-2, & + 40.0, -2.4852876000, 1.7914518000e-2, -3.2943035000e-2, & + 41.0, -2.5006779000, 1.7668203000e-2, -3.2318866000e-2, & + 42.0, -2.5154609000, 1.7425613000e-2, -3.1713675000e-2, & + 43.0, -2.5296755000, 1.7186866000e-2, -3.1126789000e-2, & + 44.0, -2.5433577000, 1.6952053000e-2, -3.0557557000e-2, & + 45.0, -2.5565412000, 1.6721240000e-2, -3.0005347000e-2, & + 46.0, -2.5692574000, 1.6494470000e-2, -2.9469547000e-2, & + 47.0, -2.5815353000, 1.6271769000e-2, -2.8949568000e-2, & + 48.0, -2.5934022000, 1.6053144000e-2, -2.8444838000e-2, & + 49.0, -2.6048833000, 1.5838586000e-2, -2.7954806000e-2, & + 50.0, -2.6160021000, 1.5628077000e-2, -2.7478940000e-2, & + 51.0, -2.6267805000, 1.5421585000e-2, -2.7016729000e-2, & + 52.0, -2.6372389000, 1.5219071000e-2, -2.6567679000e-2, & + 53.0, -2.6473964000, 1.5020486000e-2, -2.6131317000e-2, & + 54.0, -2.6572706000, 1.4825779000e-2, -2.5707185000e-2, & + 55.0, -2.6668781000, 1.4634888000e-2, -2.5294846000e-2, & + 56.0, -2.6762345000, 1.4447752000e-2, -2.4893877000e-2, & + 57.0, -2.6853540000, 1.4264303000e-2, -2.4503874000e-2, & + 58.0, -2.6942503000, 1.4084474000e-2, -2.4124449000e-2, & + 59.0, -2.7029358000, 1.3908192000e-2, -2.3755228000e-2, & + 60.0, -2.7114225000, 1.3735386000e-2, -2.3395852000e-2, & + 61.0, -2.7197214000, 1.3565983000e-2, -2.3045980000e-2, & + 62.0, -2.7278428000, 1.3399909000e-2, -2.2705280000e-2, & + 63.0, -2.7357965000, 1.3237092000e-2, -2.2373437000e-2, & + 64.0, -2.7435916000, 1.3077458000e-2, -2.2050147000e-2, & + 65.0, -2.7512366000, 1.2920935000e-2, -2.1735119000e-2, & + 66.0, -2.7587397000, 1.2767451000e-2, -2.1428073000e-2, & + 67.0, -2.7661083000, 1.2616936000e-2, -2.1128742000e-2, & + 68.0, -2.7733496000, 1.2469319000e-2, -2.0836869000e-2, & + 69.0, -2.7804703000, 1.2324532000e-2, -2.0552206000e-2, & + 70.0, -2.7874767000, 1.2182508000e-2, -2.0274516000e-2, & + 71.0, -2.7943748000, 1.2043181000e-2, -2.0003572000e-2, & + 72.0, -2.8011702000, 1.1906487000e-2, -1.9739156000e-2, & + 73.0, -2.8078682000, 1.1772362000e-2, -1.9481058000e-2, & + 74.0, -2.8144738000, 1.1640746000e-2, -1.9229076000e-2, & + 75.0, -2.8209918000, 1.1511578000e-2, -1.8983017000e-2, & + 76.0, -2.8274266000, 1.1384799000e-2, -1.8742695000e-2, & + 77.0, -2.8337824000, 1.1260352000e-2, -1.8507931000e-2, & + 78.0, -2.8400633000, 1.1138183000e-2, -1.8278553000e-2, & + 79.0, -2.8462730000, 1.1018236000e-2, -1.8054395000e-2, & + 80.0, -2.8524152000, 1.0900460000e-2, -1.7835300000e-2, & + 81.0, -2.8584932000, 1.0784802000e-2, -1.7621113000e-2, & + 82.0, -2.8645103000, 1.0671213000e-2, -1.7411688000e-2, & + 83.0, -2.8704696000, 1.0559645000e-2, -1.7206882000e-2, & + 84.0, -2.8763739000, 1.0450051000e-2, -1.7006560000e-2, & + 85.0, -2.8822260000, 1.0342384000e-2, -1.6810590000e-2, & + 86.0, -2.8880285000, 1.0236599000e-2, -1.6618845000e-2, & + 87.0, -2.8937839000, 1.0132655000e-2, -1.6431203000e-2, & + 88.0, -2.8994945000, 1.0030508000e-2, -1.6247547000e-2, & + 89.0, -2.9051627000, 9.9301169000e-3, -1.6067762000e-2, & + 90.0, -2.9107905000, 9.8314429000e-3, -1.5891741000e-2, & + 91.0, -2.9163799000, 9.7344467000e-3, -1.5719376000e-2, & + 92.0, -2.9219330000, 9.6390907000e-3, -1.5550567000e-2, & + 93.0, -2.9274514000, 9.5453383000e-3, -1.5385215000e-2, & + 94.0, -2.9329370000, 9.4531538000e-3, -1.5223225000e-2, & + 95.0, -2.9383913000, 9.3625026000e-3, -1.5064506000e-2, & + 96.0, -2.9438161000, 9.2733509000e-3, -1.4908968000e-2, & + 97.0, -2.9492127000, 9.1856660000e-3, -1.4756526000e-2, & + 98.0, -2.9545826000, 9.0994159000e-3, -1.4607099000e-2, & + 99.0, -2.9599272000, 9.0145695000e-3, -1.4460604000e-2, & + 100.0, -2.9652476000, 8.9310967000e-3, -1.4316967000e-2, & + 101.0, -2.9705453000, 8.8489681000e-3, -1.4176111000e-2, & + 102.0, -2.9758213000, 8.7681548000e-3, -1.4037965000e-2, & + 103.0, -2.9810767000, 8.6886292000e-3, -1.3902458000e-2, & + 104.0, -2.9863125000, 8.6103640000e-3, -1.3769523000e-2, & + 105.0, -2.9915299000, 8.5333328000e-3, -1.3639094000e-2, & + 106.0, -2.9967298000, 8.4575097000e-3, -1.3511108000e-2, & + 107.0, -3.0019129000, 8.3828699000e-3, -1.3385503000e-2, & + 108.0, -3.0070803000, 8.3093886000e-3, -1.3262220000e-2, & + 109.0, -3.0122328000, 8.2370423000e-3, -1.3141201000e-2, & + 110.0, -3.0173710000, 8.1658076000e-3, -1.3022390000e-2, & + 111.0, -3.0224958000, 8.0956619000e-3, -1.2905734000e-2, & + 112.0, -3.0276079000, 8.0265832000e-3, -1.2791179000e-2, & + 113.0, -3.0327080000, 7.9585500000e-3, -1.2678675000e-2, & + 114.0, -3.0377966000, 7.8915413000e-3, -1.2568172000e-2, & + 115.0, -3.0428744000, 7.8255367000e-3, -1.2459622000e-2, & + 116.0, -3.0479420000, 7.7605163000e-3, -1.2352979000e-2, & + 117.0, -3.0529999000, 7.6964606000e-3, -1.2248198000e-2, & + 118.0, -3.0580486000, 7.6333507000e-3, -1.2145235000e-2, & + 119.0, -3.0630887000, 7.5711680000e-3, -1.2044048000e-2, & + 120.0, -3.0681205000, 7.5098946000e-3, -1.1944594000e-2, & + 121.0, -3.0731446000, 7.4495128000e-3, -1.1846835000e-2, & + 122.0, -3.0781614000, 7.3900054000e-3, -1.1750732000e-2, & + 123.0, -3.0831713000, 7.3313557000e-3, -1.1656245000e-2, & + 124.0, -3.0881747000, 7.2735474000e-3, -1.1563340000e-2, & + 125.0, -3.0931718000, 7.2165644000e-3, -1.1471980000e-2, & + 126.0, -3.0981632000, 7.1603911000e-3, -1.1382130000e-2, & + 127.0, -3.1031490000, 7.1050124000e-3, -1.1293757000e-2, & + 128.0, -3.1081296000, 7.0504134000e-3, -1.1206828000e-2, & + 129.0, -3.1131054000, 6.9965795000e-3, -1.1121311000e-2, & + 130.0, -3.1180765000, 6.9434967000e-3, -1.1037175000e-2, & + 131.0, -3.1230433000, 6.8911509000e-3, -1.0954391000e-2, & + 132.0, -3.1280059000, 6.8395288000e-3, -1.0872928000e-2, & + 133.0, -3.1329647000, 6.7886171000e-3, -1.0792758000e-2, & + 134.0, -3.1379199000, 6.7384029000e-3, -1.0713853000e-2, & + 135.0, -3.1428716000, 6.6888735000e-3, -1.0636187000e-2, & + 136.0, -3.1478201000, 6.6400168000e-3, -1.0559733000e-2, & + 137.0, -3.1527656000, 6.5918206000e-3, -1.0484466000e-2, & + 138.0, -3.1577082000, 6.5442732000e-3, -1.0410360000e-2, & + 139.0, -3.1626481000, 6.4973631000e-3, -1.0337392000e-2, & + 140.0, -3.1675855000, 6.4510790000e-3, -1.0265537000e-2, & + 141.0, -3.1725205000, 6.4054099000e-3, -1.0194773000e-2, & + 142.0, -3.1774533000, 6.3603452000e-3, -1.0125078000e-2, & + 143.0, -3.1823840000, 6.3158742000e-3, -1.0056429000e-2, & + 144.0, -3.1873127000, 6.2719868000e-3, -9.9888045000e-3, & + 145.0, -3.1922396000, 6.2286729000e-3, -9.9221850000e-3, & + 146.0, -3.1971648000, 6.1859227000e-3, -9.8565496000e-3, & + 147.0, -3.2020883000, 6.1437265000e-3, -9.7918788000e-3, & + 148.0, -3.2070102000, 6.1020749000e-3, -9.7281532000e-3, & + 149.0, -3.2119308000, 6.0609589000e-3, -9.6653542000e-3, & + 150.0, -3.2168500000, 6.0203693000e-3, -9.6034635000e-3, & + 151.0, -3.2217679000, 5.9802974000e-3, -9.5424633000e-3, & + 152.0, -3.2266847000, 5.9407346000e-3, -9.4823362000e-3, & + 153.0, -3.2316003000, 5.9016724000e-3, -9.4230652000e-3, & + 154.0, -3.2365149000, 5.8631026000e-3, -9.3646338000e-3, & + 155.0, -3.2414284000, 5.8250172000e-3, -9.3070259000e-3, & + 156.0, -3.2463411000, 5.7874081000e-3, -9.2502257000e-3, & + 157.0, -3.2512529000, 5.7502678000e-3, -9.1942178000e-3, & + 158.0, -3.2561639000, 5.7135886000e-3, -9.1389873000e-3, & + 159.0, -3.2610741000, 5.6773630000e-3, -9.0845194000e-3, & + 160.0, -3.2659835000, 5.6415839000e-3, -9.0308000000e-3, & + 161.0, -3.2708923000, 5.6062442000e-3, -8.9778149000e-3, & + 162.0, -3.2758004000, 5.5713368000e-3, -8.9255506000e-3, & + 163.0, -3.2807079000, 5.5368550000e-3, -8.8739938000e-3, & + 164.0, -3.2856148000, 5.5027920000e-3, -8.8231314000e-3, & + 165.0, -3.2905211000, 5.4691413000e-3, -8.7729507000e-3, & + 166.0, -3.2954269000, 5.4358966000e-3, -8.7234394000e-3, & + 167.0, -3.3003322000, 5.4030515000e-3, -8.6745852000e-3, & + 168.0, -3.3052370000, 5.3705998000e-3, -8.6263763000e-3, & + 169.0, -3.3101414000, 5.3385356000e-3, -8.5788012000e-3, & + 170.0, -3.3150452000, 5.3068529000e-3, -8.5318484000e-3, & + 171.0, -3.3199486000, 5.2755459000e-3, -8.4855070000e-3, & + 172.0, -3.3248516000, 5.2446089000e-3, -8.4397661000e-3, & + 173.0, -3.3297541000, 5.2140364000e-3, -8.3946150000e-3, & + 174.0, -3.3346563000, 5.1838229000e-3, -8.3500435000e-3, & + 175.0, -3.3395580000, 5.1539630000e-3, -8.3060415000e-3, & + 176.0, -3.3444593000, 5.1244515000e-3, -8.2625990000e-3, & + 177.0, -3.3493602000, 5.0952833000e-3, -8.2197063000e-3, & + 178.0, -3.3542607000, 5.0664532000e-3, -8.1773539000e-3, & + 179.0, -3.3591609000, 5.0379563000e-3, -8.1355327000e-3, & + 180.0, -3.3640606000, 5.0097879000e-3, -8.0942335000e-3, & + 181.0, -3.3689599000, 4.9819430000e-3, -8.0534474000e-3, & + 182.0, -3.3738588000, 4.9544170000e-3, -8.0131658000e-3, & + 183.0, -3.3787572000, 4.9272053000e-3, -7.9733801000e-3, & + 184.0, -3.3836553000, 4.9003034000e-3, -7.9340821000e-3, & + 185.0, -3.3885529000, 4.8737069000e-3, -7.8952635000e-3, & + 186.0, -3.3934501000, 4.8474114000e-3, -7.8569164000e-3, & + 187.0, -3.3983469000, 4.8214127000e-3, -7.8190330000e-3, & + 188.0, -3.4032432000, 4.7957066000e-3, -7.7816057000e-3, & + 189.0, -3.4081390000, 4.7702889000e-3, -7.7446269000e-3, & + 190.0, -3.4130344000, 4.7451557000e-3, -7.7080893000e-3, & + 191.0, -3.4179292000, 4.7203030000e-3, -7.6719857000e-3, & + 192.0, -3.4228236000, 4.6957268000e-3, -7.6363091000e-3, & + 193.0, -3.4277174000, 4.6714235000e-3, -7.6010526000e-3, & + 194.0, -3.4326107000, 4.6473891000e-3, -7.5662095000e-3, & + 195.0, -3.4375035000, 4.6236200000e-3, -7.5317730000e-3, & + 196.0, -3.4423957000, 4.6001126000e-3, -7.4977367000e-3, & + 197.0, -3.4472873000, 4.5768634000e-3, -7.4640943000e-3, & + 198.0, -3.4521783000, 4.5538688000e-3, -7.4308395000e-3, & + 199.0, -3.4570687000, 4.5311254000e-3, -7.3979662000e-3, & + 200.0, -3.4619585000, 4.5086298000e-3, -7.3654685000e-3, & + 201.0, -3.4668476000, 4.4863788000e-3, -7.3333403000e-3, & + 202.0, -3.4717360000, 4.4643689000e-3, -7.3015761000e-3, & + 203.0, -3.4766237000, 4.4425971000e-3, -7.2701701000e-3, & + 204.0, -3.4815107000, 4.4210601000e-3, -7.2391168000e-3, & + 205.0, -3.4863970000, 4.3997550000e-3, -7.2084108000e-3, & + 206.0, -3.4912825000, 4.3786785000e-3, -7.1780467000e-3, & + 207.0, -3.4961672000, 4.3578278000e-3, -7.1480193000e-3, & + 208.0, -3.5010512000, 4.3371999000e-3, -7.1183236000e-3, & + 209.0, -3.5059343000, 4.3167918000e-3, -7.0889544000e-3, & + 210.0, -3.5108165000, 4.2966008000e-3, -7.0599068000e-3, & + 211.0, -3.5156979000, 4.2766239000e-3, -7.0311760000e-3, & + 212.0, -3.5205784000, 4.2568586000e-3, -7.0027573000e-3, & + 213.0, -3.5254580000, 4.2373019000e-3, -6.9746460000e-3, & + 214.0, -3.5303366000, 4.2179514000e-3, -6.9468375000e-3, & + 215.0, -3.5352143000, 4.1988043000e-3, -6.9193272000e-3, & + 216.0, -3.5400909000, 4.1798580000e-3, -6.8921109000e-3, & + 217.0, -3.5449666000, 4.1611101000e-3, -6.8651842000e-3, & + 218.0, -3.5498412000, 4.1425580000e-3, -6.8385428000e-3, & + 219.0, -3.5547147000, 4.1241992000e-3, -6.8121826000e-3, & + 220.0, -3.5595871000, 4.1060313000e-3, -6.7860995000e-3, & + 221.0, -3.5644584000, 4.0880520000e-3, -6.7602894000e-3, & + 222.0, -3.5693286000, 4.0702588000e-3, -6.7347484000e-3, & + 223.0, -3.5741976000, 4.0526495000e-3, -6.7094726000e-3, & + 224.0, -3.5790654000, 4.0352217000e-3, -6.6844583000e-3, & + 225.0, -3.5839320000, 4.0179733000e-3, -6.6597016000e-3, & + 226.0, -3.5887973000, 4.0009020000e-3, -6.6351989000e-3, & + 227.0, -3.5936613000, 3.9840057000e-3, -6.6109466000e-3, & + 228.0, -3.5985240000, 3.9672821000e-3, -6.5869411000e-3, & + 229.0, -3.6033854000, 3.9507293000e-3, -6.5631791000e-3, & + 230.0, -3.6082455000, 3.9343450000e-3, -6.5396569000e-3, & + 231.0, -3.6131041000, 3.9181273000e-3, -6.5163713000e-3, & + 232.0, -3.6179613000, 3.9020742000e-3, -6.4933190000e-3, & + 233.0, -3.6228171000, 3.8861836000e-3, -6.4704966000e-3, & + 234.0, -3.6276714000, 3.8704536000e-3, -6.4479012000e-3, & + 235.0, -3.6325242000, 3.8548822000e-3, -6.4255293000e-3, & + 236.0, -3.6373754000, 3.8394677000e-3, -6.4033781000e-3, & + 237.0, -3.6422252000, 3.8242080000e-3, -6.3814445000e-3, & + 238.0, -3.6470733000, 3.8091013000e-3, -6.3597254000e-3, & + 239.0, -3.6519198000, 3.7941458000e-3, -6.3382179000e-3, & + 240.0, -3.6567647000, 3.7793398000e-3, -6.3169193000e-3, & + 241.0, -3.6616079000, 3.7646814000e-3, -6.2958265000e-3, & + 242.0, -3.6664494000, 3.7501690000e-3, -6.2749370000e-3, & + 243.0, -3.6712891000, 3.7358007000e-3, -6.2542478000e-3, & + 244.0, -3.6761271000, 3.7215749000e-3, -6.2337563000e-3, & + 245.0, -3.6809634000, 3.7074899000e-3, -6.2134599000e-3, & + 246.0, -3.6857978000, 3.6935441000e-3, -6.1933559000e-3, & + 247.0, -3.6906303000, 3.6797359000e-3, -6.1734419000e-3, & + 248.0, -3.6954610000, 3.6660636000e-3, -6.1537152000e-3, & + 249.0, -3.7002898000, 3.6525257000e-3, -6.1341734000e-3, & + 250.0, -3.7051167000, 3.6391206000e-3, -6.1148140000e-3, & + 251.0, -3.7099416000, 3.6258468000e-3, -6.0956346000e-3, & + 252.0, -3.7147645000, 3.6127027000e-3, -6.0766330000e-3, & + 253.0, -3.7195854000, 3.5996869000e-3, -6.0578067000e-3, & + 254.0, -3.7244043000, 3.5867979000e-3, -6.0391534000e-3, & + 255.0, -3.7292211000, 3.5740342000e-3, -6.0206710000e-3, & + 256.0, -3.7340357000, 3.5613944000e-3, -6.0023572000e-3, & + 257.0, -3.7388483000, 3.5488772000e-3, -5.9842098000e-3, & + 258.0, -3.7436587000, 3.5364810000e-3, -5.9662266000e-3, & + 259.0, -3.7484669000, 3.5242045000e-3, -5.9484056000e-3, & + 260.0, -3.7532729000, 3.5120464000e-3, -5.9307447000e-3, & + 261.0, -3.7580766000, 3.5000053000e-3, -5.9132419000e-3, & + 262.0, -3.7628780000, 3.4880799000e-3, -5.8958950000e-3, & + 263.0, -3.7676772000, 3.4762689000e-3, -5.8787022000e-3, & + 264.0, -3.7724740000, 3.4645710000e-3, -5.8616614000e-3, & + 265.0, -3.7772685000, 3.4529849000e-3, -5.8447709000e-3, & + 266.0, -3.7820605000, 3.4415093000e-3, -5.8280285000e-3, & + 267.0, -3.7868501000, 3.4301431000e-3, -5.8114326000e-3, & + 268.0, -3.7916373000, 3.4188851000e-3, -5.7949812000e-3, & + 269.0, -3.7964220000, 3.4077339000e-3, -5.7786726000e-3, & + 270.0, -3.8012042000, 3.3966884000e-3, -5.7625050000e-3, & + 271.0, -3.8059839000, 3.3857475000e-3, -5.7464766000e-3, & + 272.0, -3.8107610000, 3.3749099000e-3, -5.7305857000e-3, & + 273.0, -3.8155355000, 3.3641746000e-3, -5.7148305000e-3, & + 274.0, -3.8203074000, 3.3535404000e-3, -5.6992095000e-3, & + 275.0, -3.8250766000, 3.3430061000e-3, -5.6837210000e-3, & + 276.0, -3.8298432000, 3.3325707000e-3, -5.6683633000e-3, & + 277.0, -3.8346070000, 3.3222331000e-3, -5.6531348000e-3, & + 278.0, -3.8393682000, 3.3119922000e-3, -5.6380340000e-3, & + 279.0, -3.8441265000, 3.3018470000e-3, -5.6230593000e-3, & + 280.0, -3.8488821000, 3.2917964000e-3, -5.6082092000e-3, & + 281.0, -3.8536348000, 3.2818393000e-3, -5.5934822000e-3, & + 282.0, -3.8583847000, 3.2719748000e-3, -5.5788767000e-3, & + 283.0, -3.8631317000, 3.2622018000e-3, -5.5643913000e-3, & + 284.0, -3.8678759000, 3.2525193000e-3, -5.5500246000e-3, & + 285.0, -3.8726170000, 3.2429264000e-3, -5.5357752000e-3, & + 286.0, -3.8773553000, 3.2334221000e-3, -5.5216416000e-3, & + 287.0, -3.8820905000, 3.2240054000e-3, -5.5076224000e-3, & + 288.0, -3.8868227000, 3.2146753000e-3, -5.4937164000e-3, & + 289.0, -3.8915519000, 3.2054310000e-3, -5.4799221000e-3, & + 290.0, -3.8962780000, 3.1962715000e-3, -5.4662383000e-3, & + 291.0, -3.9010010000, 3.1871958000e-3, -5.4526635000e-3, & + 292.0, -3.9057209000, 3.1782032000e-3, -5.4391967000e-3, & + 293.0, -3.9104377000, 3.1692926000e-3, -5.4258363000e-3, & + 294.0, -3.9151512000, 3.1604632000e-3, -5.4125813000e-3, & + 295.0, -3.9198616000, 3.1517142000e-3, -5.3994305000e-3, & + 296.0, -3.9245687000, 3.1430446000e-3, -5.3863824000e-3, & + 297.0, -3.9292725000, 3.1344537000e-3, -5.3734361000e-3, & + 298.0, -3.9339731000, 3.1259405000e-3, -5.3605902000e-3, & + 299.0, -3.9386704000, 3.1175043000e-3, -5.3478437000e-3, & + 300.0, -3.9433643000, 3.1091442000e-3, -5.3351954000e-3, & + 301.0, -3.9480548000, 3.1008594000e-3, -5.3226441000e-3, & + 302.0, -3.9527420000, 3.0926491000e-3, -5.3101888000e-3, & + 303.0, -3.9574257000, 3.0845126000e-3, -5.2978283000e-3, & + 304.0, -3.9621060000, 3.0764490000e-3, -5.2855615000e-3, & + 305.0, -3.9667828000, 3.0684575000e-3, -5.2733874000e-3, & + 306.0, -3.9714561000, 3.0605375000e-3, -5.2613050000e-3, & + 307.0, -3.9761259000, 3.0526881000e-3, -5.2493131000e-3, & + 308.0, -3.9807921000, 3.0449085000e-3, -5.2374107000e-3, & + 309.0, -3.9854548000, 3.0371982000e-3, -5.2255969000e-3, & + 310.0, -3.9901138000, 3.0295562000e-3, -5.2138707000e-3, & + 311.0, -3.9947693000, 3.0219820000e-3, -5.2022310000e-3, & + 312.0, -3.9994210000, 3.0144747000e-3, -5.1906768000e-3, & + 313.0, -4.0040691000, 3.0070337000e-3, -5.1792073000e-3, & + 314.0, -4.0087135000, 2.9996584000e-3, -5.1678215000e-3, & + 315.0, -4.0133542000, 2.9923479000e-3, -5.1565183000e-3, & + 316.0, -4.0179911000, 2.9851016000e-3, -5.1452970000e-3, & + 317.0, -4.0226242000, 2.9779189000e-3, -5.1341566000e-3, & + 318.0, -4.0272535000, 2.9707990000e-3, -5.1230962000e-3, & + 319.0, -4.0318790000, 2.9637414000e-3, -5.1121150000e-3, & + 320.0, -4.0365006000, 2.9567453000e-3, -5.1012119000e-3, & + 321.0, -4.0411184000, 2.9498101000e-3, -5.0903863000e-3, & + 322.0, -4.0457322000, 2.9429353000e-3, -5.0796372000e-3, & + 323.0, -4.0503421000, 2.9361201000e-3, -5.0689638000e-3, & + 324.0, -4.0549481000, 2.9293639000e-3, -5.0583652000e-3, & + 325.0, -4.0595501000, 2.9226662000e-3, -5.0478407000e-3, & + 326.0, -4.0641480000, 2.9160263000e-3, -5.0373894000e-3, & + 327.0, -4.0687420000, 2.9094435000e-3, -5.0270106000e-3, & + 328.0, -4.0733319000, 2.9029174000e-3, -5.0167034000e-3, & + 329.0, -4.0779177000, 2.8964474000e-3, -5.0064671000e-3, & + 330.0, -4.0824995000, 2.8900327000e-3, -4.9963009000e-3, & + 331.0, -4.0870771000, 2.8836730000e-3, -4.9862041000e-3, & + 332.0, -4.0916505000, 2.8773676000e-3, -4.9761758000e-3, & + 333.0, -4.0962198000, 2.8711159000e-3, -4.9662155000e-3, & + 334.0, -4.1007850000, 2.8649173000e-3, -4.9563223000e-3, & + 335.0, -4.1053459000, 2.8587715000e-3, -4.9464955000e-3, & + 336.0, -4.1099025000, 2.8526777000e-3, -4.9367344000e-3, & + 337.0, -4.1144549000, 2.8466354000e-3, -4.9270384000e-3, & + 338.0, -4.1190030000, 2.8406442000e-3, -4.9174066000e-3, & + 339.0, -4.1235469000, 2.8347035000e-3, -4.9078386000e-3, & + 340.0, -4.1280863000, 2.8288128000e-3, -4.8983335000e-3, & + 341.0, -4.1326215000, 2.8229715000e-3, -4.8888907000e-3, & + 342.0, -4.1371523000, 2.8171792000e-3, -4.8795095000e-3, & + 343.0, -4.1416786000, 2.8114353000e-3, -4.8701893000e-3, & + 344.0, -4.1462006000, 2.8057394000e-3, -4.8609295000e-3, & + 345.0, -4.1507181000, 2.8000909000e-3, -4.8517295000e-3, & + 346.0, -4.1552312000, 2.7944894000e-3, -4.8425885000e-3, & + 347.0, -4.1597397000, 2.7889344000e-3, -4.8335060000e-3, & + 348.0, -4.1642438000, 2.7834254000e-3, -4.8244814000e-3, & + 349.0, -4.1687434000, 2.7779620000e-3, -4.8155141000e-3, & + 350.0, -4.1732384000, 2.7725436000e-3, -4.8066034000e-3, & + 351.0, -4.1777288000, 2.7671698000e-3, -4.7977488000e-3, & + 352.0, -4.1822147000, 2.7618402000e-3, -4.7889498000e-3, & + 353.0, -4.1866959000, 2.7565543000e-3, -4.7802057000e-3, & + 354.0, -4.1911725000, 2.7513117000e-3, -4.7715160000e-3, & + 355.0, -4.1956445000, 2.7461118000e-3, -4.7628800000e-3, & + 356.0, -4.2001118000, 2.7409544000e-3, -4.7542974000e-3, & + 357.0, -4.2045744000, 2.7358388000e-3, -4.7457675000e-3, & + 358.0, -4.2090323000, 2.7307648000e-3, -4.7372897000e-3, & + 359.0, -4.2134854000, 2.7257319000e-3, -4.7288636000e-3, & + 360.0, -4.2179338000, 2.7207397000e-3, -4.7204886000e-3, & + 361.0, -4.2223775000, 2.7157877000e-3, -4.7121643000e-3, & + 362.0, -4.2268163000, 2.7108756000e-3, -4.7038900000e-3, & + 363.0, -4.2312503000, 2.7060029000e-3, -4.6956653000e-3, & + 364.0, -4.2356795000, 2.7011692000e-3, -4.6874897000e-3, & + 365.0, -4.2401039000, 2.6963742000e-3, -4.6793627000e-3, & + 366.0, -4.2445234000, 2.6916175000e-3, -4.6712838000e-3, & + 367.0, -4.2489380000, 2.6868986000e-3, -4.6632526000e-3, & + 368.0, -4.2533476000, 2.6822172000e-3, -4.6552684000e-3, & + 369.0, -4.2577524000, 2.6775728000e-3, -4.6473310000e-3, & + 370.0, -4.2621522000, 2.6729652000e-3, -4.6394397000e-3, & + 371.0, -4.2665470000, 2.6683940000e-3, -4.6315942000e-3, & + 372.0, -4.2709369000, 2.6638587000e-3, -4.6237940000e-3, & + 373.0, -4.2753218000, 2.6593590000e-3, -4.6160387000e-3, & + 374.0, -4.2797016000, 2.6548946000e-3, -4.6083277000e-3, & + 375.0, -4.2840764000, 2.6504651000e-3, -4.6006607000e-3, & + 376.0, -4.2884462000, 2.6460701000e-3, -4.5930373000e-3, & + 377.0, -4.2928108000, 2.6417093000e-3, -4.5854569000e-3, & + 378.0, -4.2971704000, 2.6373823000e-3, -4.5779192000e-3, & + 379.0, -4.3015249000, 2.6330888000e-3, -4.5704238000e-3, & + 380.0, -4.3058742000, 2.6288285000e-3, -4.5629702000e-3, & + 381.0, -4.3102184000, 2.6246011000e-3, -4.5555581000e-3, & + 382.0, -4.3145575000, 2.6204061000e-3, -4.5481870000e-3, & + 383.0, -4.3188914000, 2.6162432000e-3, -4.5408565000e-3, & + 384.0, -4.3232200000, 2.6121122000e-3, -4.5335663000e-3, & + 385.0, -4.3275435000, 2.6080128000e-3, -4.5263159000e-3, & + 386.0, -4.3318617000, 2.6039445000e-3, -4.5191050000e-3, & + 387.0, -4.3361747000, 2.5999071000e-3, -4.5119331000e-3, & + 388.0, -4.3404824000, 2.5959002000e-3, -4.5048000000e-3, & + 389.0, -4.3447848000, 2.5919236000e-3, -4.4977052000e-3, & + 390.0, -4.3490820000, 2.5879770000e-3, -4.4906484000e-3, & + 391.0, -4.3533738000, 2.5840600000e-3, -4.4836292000e-3, & + 392.0, -4.3576603000, 2.5801724000e-3, -4.4766472000e-3, & + 393.0, -4.3619414000, 2.5763138000e-3, -4.4697021000e-3, & + 394.0, -4.3662172000, 2.5724840000e-3, -4.4627935000e-3, & + 395.0, -4.3704876000, 2.5686827000e-3, -4.4559212000e-3, & + 396.0, -4.3747527000, 2.5649095000e-3, -4.4490846000e-3, & + 397.0, -4.3790123000, 2.5611642000e-3, -4.4422836000e-3, & + 398.0, -4.3832665000, 2.5574466000e-3, -4.4355178000e-3, & + 399.0, -4.3875152000, 2.5537563000e-3, -4.4287868000e-3, & + 400.0, -4.3917586000, 2.5500930000e-3, -4.4220903000e-3, & + 401.0, -4.3959964000, 2.5464565000e-3, -4.4154280000e-3, & + 402.0, -4.4002288000, 2.5428466000e-3, -4.4087995000e-3, & + 403.0, -4.4044556000, 2.5392629000e-3, -4.4022046000e-3, & + 404.0, -4.4086770000, 2.5357051000e-3, -4.3956430000e-3, & + 405.0, -4.4128928000, 2.5321731000e-3, -4.3891142000e-3, & + 406.0, -4.4171031000, 2.5286666000e-3, -4.3826181000e-3, & + 407.0, -4.4213078000, 2.5251852000e-3, -4.3761543000e-3, & + 408.0, -4.4255070000, 2.5217289000e-3, -4.3697225000e-3, & + 409.0, -4.4297006000, 2.5182972000e-3, -4.3633224000e-3, & + 410.0, -4.4338886000, 2.5148899000e-3, -4.3569537000e-3, & + 411.0, -4.4380709000, 2.5115069000e-3, -4.3506162000e-3, & + 412.0, -4.4422477000, 2.5081478000e-3, -4.3443095000e-3, & + 413.0, -4.4464188000, 2.5048125000e-3, -4.3380334000e-3, & + 414.0, -4.4505843000, 2.5015006000e-3, -4.3317876000e-3, & + 415.0, -4.4547441000, 2.4982119000e-3, -4.3255718000e-3, & + 416.0, -4.4588982000, 2.4949463000e-3, -4.3193857000e-3, & + 417.0, -4.4630466000, 2.4917034000e-3, -4.3132290000e-3, & + 418.0, -4.4671894000, 2.4884831000e-3, -4.3071016000e-3, & + 419.0, -4.4713264000, 2.4852851000e-3, -4.3010031000e-3, & + 420.0, -4.4754577000, 2.4821092000e-3, -4.2949332000e-3, & + 421.0, -4.4795832000, 2.4789551000e-3, -4.2888918000e-3, & + 422.0, -4.4837030000, 2.4758227000e-3, -4.2828785000e-3, & + 423.0, -4.4878171000, 2.4727118000e-3, -4.2768931000e-3, & + 424.0, -4.4919253000, 2.4696220000e-3, -4.2709353000e-3, & + 425.0, -4.4960278000, 2.4665532000e-3, -4.2650050000e-3, & + 426.0, -4.5001245000, 2.4635053000e-3, -4.2591017000e-3, & + 427.0, -4.5042153000, 2.4604778000e-3, -4.2532254000e-3, & + 428.0, -4.5083003000, 2.4574708000e-3, -4.2473758000e-3, & + 429.0, -4.5123795000, 2.4544839000e-3, -4.2415526000e-3, & + 430.0, -4.5164529000, 2.4515170000e-3, -4.2357555000e-3, & + 431.0, -4.5205204000, 2.4485699000e-3, -4.2299844000e-3, & + 432.0, -4.5245820000, 2.4456423000e-3, -4.2242391000e-3, & + 433.0, -4.5286377000, 2.4427340000e-3, -4.2185193000e-3, & + 434.0, -4.5326876000, 2.4398450000e-3, -4.2128247000e-3, & + 435.0, -4.5367315000, 2.4369749000e-3, -4.2071552000e-3, & + 436.0, -4.5407695000, 2.4341235000e-3, -4.2015105000e-3, & + 437.0, -4.5448016000, 2.4312908000e-3, -4.1958904000e-3, & + 438.0, -4.5488278000, 2.4284765000e-3, -4.1902947000e-3, & + 439.0, -4.5528480000, 2.4256804000e-3, -4.1847233000e-3, & + 440.0, -4.5568623000, 2.4229023000e-3, -4.1791757000e-3, & + 441.0, -4.5608706000, 2.4201420000e-3, -4.1736520000e-3, & + 442.0, -4.5648729000, 2.4173995000e-3, -4.1681518000e-3, & + 443.0, -4.5688693000, 2.4146744000e-3, -4.1626750000e-3, & + 444.0, -4.5728596000, 2.4119666000e-3, -4.1572213000e-3, & + 445.0, -4.5768440000, 2.4092760000e-3, -4.1517905000e-3, & + 446.0, -4.5808223000, 2.4066023000e-3, -4.1463825000e-3, & + 447.0, -4.5847946000, 2.4039454000e-3, -4.1409971000e-3, & + 448.0, -4.5887608000, 2.4013051000e-3, -4.1356340000e-3, & + 449.0, -4.5927211000, 2.3986813000e-3, -4.1302931000e-3, & + 450.0, -4.5966752000, 2.3960738000e-3, -4.1249742000e-3, & + 451.0, -4.6006234000, 2.3934824000e-3, -4.1196771000e-3, & + 452.0, -4.6045654000, 2.3909070000e-3, -4.1144015000e-3, & + 453.0, -4.6085014000, 2.3883473000e-3, -4.1091474000e-3, & + 454.0, -4.6124313000, 2.3858033000e-3, -4.1039146000e-3, & + 455.0, -4.6163550000, 2.3832748000e-3, -4.0987028000e-3, & + 456.0, -4.6202727000, 2.3807615000e-3, -4.0935118000e-3, & + 457.0, -4.6241843000, 2.3782635000e-3, -4.0883416000e-3, & + 458.0, -4.6280897000, 2.3757804000e-3, -4.0831919000e-3, & + 459.0, -4.6319890000, 2.3733122000e-3, -4.0780626000e-3, & + 460.0, -4.6358822000, 2.3708588000e-3, -4.0729534000e-3, & + 461.0, -4.6397692000, 2.3684198000e-3, -4.0678643000e-3, & + 462.0, -4.6436501000, 2.3659953000e-3, -4.0627950000e-3, & + 463.0, -4.6475249000, 2.3635851000e-3, -4.0577454000e-3, & + 464.0, -4.6513934000, 2.3611889000e-3, -4.0527153000e-3, & + 465.0, -4.6552558000, 2.3588068000e-3, -4.0477046000e-3, & + 466.0, -4.6591120000, 2.3564384000e-3, -4.0427131000e-3, & + 467.0, -4.6629620000, 2.3540838000e-3, -4.0377406000e-3, & + 468.0, -4.6668058000, 2.3517427000e-3, -4.0327870000e-3, & + 469.0, -4.6706434000, 2.3494150000e-3, -4.0278521000e-3, & + 470.0, -4.6744748000, 2.3471006000e-3, -4.0229358000e-3, & + 471.0, -4.6783000000, 2.3447994000e-3, -4.0180379000e-3, & + 472.0, -4.6821189000, 2.3425111000e-3, -4.0131582000e-3, & + 473.0, -4.6859316000, 2.3402357000e-3, -4.0082967000e-3, & + 474.0, -4.6897381000, 2.3379731000e-3, -4.0034532000e-3, & + 475.0, -4.6935383000, 2.3357231000e-3, -3.9986274000e-3, & + 476.0, -4.6973323000, 2.3334855000e-3, -3.9938194000e-3, & + 477.0, -4.7011201000, 2.3312604000e-3, -3.9890289000e-3, & + 478.0, -4.7049015000, 2.3290474000e-3, -3.9842557000e-3, & + 479.0, -4.7086767000, 2.3268466000e-3, -3.9794999000e-3, & + 480.0, -4.7124456000, 2.3246577000e-3, -3.9747611000e-3, & + 481.0, -4.7162083000, 2.3224807000e-3, -3.9700393000e-3, & + 482.0, -4.7199646000, 2.3203154000e-3, -3.9653344000e-3, & + 483.0, -4.7237147000, 2.3181618000e-3, -3.9606461000e-3, & + 484.0, -4.7274585000, 2.3160196000e-3, -3.9559744000e-3, & + 485.0, -4.7311959000, 2.3138889000e-3, -3.9513192000e-3, & + 486.0, -4.7349271000, 2.3117694000e-3, -3.9466802000e-3, & + 487.0, -4.7386519000, 2.3096610000e-3, -3.9420575000e-3, & + 488.0, -4.7423704000, 2.3075637000e-3, -3.9374508000e-3, & + 489.0, -4.7460826000, 2.3054773000e-3, -3.9328600000e-3, & + 490.0, -4.7497885000, 2.3034017000e-3, -3.9282850000e-3, & + 491.0, -4.7534880000, 2.3013368000e-3, -3.9237256000e-3, & + 492.0, -4.7571812000, 2.2992825000e-3, -3.9191818000e-3, & + 493.0, -4.7608681000, 2.2972386000e-3, -3.9146535000e-3, & + 494.0, -4.7645486000, 2.2952052000e-3, -3.9101404000e-3, & + 495.0, -4.7682227000, 2.2931820000e-3, -3.9056425000e-3, & + 496.0, -4.7718905000, 2.2911690000e-3, -3.9011597000e-3, & + 497.0, -4.7755520000, 2.2891660000e-3, -3.8966919000e-3, & + 498.0, -4.7792071000, 2.2871729000e-3, -3.8922389000e-3, & + 499.0, -4.7828558000, 2.2851898000e-3, -3.8878005000e-3, & + 500.0, -4.7864981000, 2.2832163000e-3, -3.8833768000e-3, & + 501.0, -4.7901341000, 2.2812525000e-3, -3.8789676000e-3, & + 502.0, -4.7937636000, 2.2792983000e-3, -3.8745728000e-3, & + 503.0, -4.7973868000, 2.2773535000e-3, -3.8701922000e-3, & + 504.0, -4.8010036000, 2.2754180000e-3, -3.8658258000e-3, & + 505.0, -4.8046141000, 2.2734918000e-3, -3.8614735000e-3, & + 506.0, -4.8082181000, 2.2715748000e-3, -3.8571351000e-3, & + 507.0, -4.8118157000, 2.2696668000e-3, -3.8528105000e-3, & + 508.0, -4.8154069000, 2.2677678000e-3, -3.8484997000e-3, & + 509.0, -4.8189918000, 2.2658777000e-3, -3.8442025000e-3, & + 510.0, -4.8225702000, 2.2639964000e-3, -3.8399188000e-3, & + 511.0, -4.8261422000, 2.2621237000e-3, -3.8356485000e-3, & + 512.0, -4.8297078000, 2.2602597000e-3, -3.8313916000e-3, & + 513.0, -4.8332670000, 2.2584041000e-3, -3.8271479000e-3, & + 514.0, -4.8368197000, 2.2565570000e-3, -3.8229173000e-3, & + 515.0, -4.8403661000, 2.2547183000e-3, -3.8186997000e-3, & + 516.0, -4.8439060000, 2.2528877000e-3, -3.8144951000e-3, & + 517.0, -4.8474395000, 2.2510654000e-3, -3.8103033000e-3, & + 518.0, -4.8509666000, 2.2492511000e-3, -3.8061243000e-3, & + 519.0, -4.8544872000, 2.2474448000e-3, -3.8019578000e-3, & + 520.0, -4.8580014000, 2.2456465000e-3, -3.7978040000e-3, & + 521.0, -4.8615092000, 2.2438560000e-3, -3.7936626000e-3, & + 522.0, -4.8650105000, 2.2420732000e-3, -3.7895335000e-3, & + 523.0, -4.8685054000, 2.2402981000e-3, -3.7854168000e-3, & + 524.0, -4.8719939000, 2.2385305000e-3, -3.7813122000e-3, & + 525.0, -4.8754759000, 2.2367705000e-3, -3.7772197000e-3, & + 526.0, -4.8789515000, 2.2350179000e-3, -3.7731392000e-3, & + 527.0, -4.8824206000, 2.2332727000e-3, -3.7690706000e-3, & + 528.0, -4.8858833000, 2.2315347000e-3, -3.7650139000e-3, & + 529.0, -4.8893395000, 2.2298040000e-3, -3.7609689000e-3, & + 530.0, -4.8927893000, 2.2280804000e-3, -3.7569356000e-3, & + 531.0, -4.8962327000, 2.2263638000e-3, -3.7529139000e-3, & + 532.0, -4.8996696000, 2.2246542000e-3, -3.7489037000e-3, & + 533.0, -4.9031000000, 2.2229515000e-3, -3.7449049000e-3, & + 534.0, -4.9065240000, 2.2212556000e-3, -3.7409174000e-3, & + 535.0, -4.9099415000, 2.2195665000e-3, -3.7369411000e-3, & + 536.0, -4.9133526000, 2.2178841000e-3, -3.7329761000e-3, & + 537.0, -4.9167573000, 2.2162082000e-3, -3.7290221000e-3, & + 538.0, -4.9201554000, 2.2145390000e-3, -3.7250792000e-3, & + 539.0, -4.9235472000, 2.2128762000e-3, -3.7211471000e-3, & + 540.0, -4.9269324000, 2.2112198000e-3, -3.7172260000e-3, & + 541.0, -4.9303112000, 2.2095698000e-3, -3.7133156000e-3, & + 542.0, -4.9336836000, 2.2079261000e-3, -3.7094160000e-3, & + 543.0, -4.9370495000, 2.2062885000e-3, -3.7055269000e-3, & + 544.0, -4.9404089000, 2.2046571000e-3, -3.7016485000e-3, & + 545.0, -4.9437619000, 2.2030318000e-3, -3.6977805000e-3, & + 546.0, -4.9471084000, 2.2014125000e-3, -3.6939229000e-3, & + 547.0, -4.9504485000, 2.1997991000e-3, -3.6900757000e-3, & + 548.0, -4.9537821000, 2.1981917000e-3, -3.6862387000e-3, & + 549.0, -4.9571092000, 2.1965901000e-3, -3.6824120000e-3, & + 550.0, -4.9604299000, 2.1949942000e-3, -3.6785954000e-3, & + 551.0, -4.9637442000, 2.1934040000e-3, -3.6747888000e-3, & + 552.0, -4.9670519000, 2.1918195000e-3, -3.6709922000e-3, & + 553.0, -4.9703533000, 2.1902406000e-3, -3.6672056000e-3, & + 554.0, -4.9736481000, 2.1886671000e-3, -3.6634288000e-3, & + 555.0, -4.9769366000, 2.1870992000e-3, -3.6596618000e-3, & + 556.0, -4.9802185000, 2.1855366000e-3, -3.6559045000e-3, & + 557.0, -4.9834940000, 2.1839795000e-3, -3.6521569000e-3, & + 558.0, -4.9867631000, 2.1824276000e-3, -3.6484189000e-3, & + 559.0, -4.9900257000, 2.1808809000e-3, -3.6446904000e-3, & + 560.0, -4.9932819000, 2.1793394000e-3, -3.6409714000e-3, & + 561.0, -4.9965316000, 2.1778031000e-3, -3.6372617000e-3, & + 562.0, -4.9997749000, 2.1762718000e-3, -3.6335615000e-3, & + 563.0, -5.0030117000, 2.1747455000e-3, -3.6298704000e-3, & + 564.0, -5.0062421000, 2.1732242000e-3, -3.6261887000e-3, & + 565.0, -5.0094660000, 2.1717078000e-3, -3.6225160000e-3, & + 566.0, -5.0126835000, 2.1701963000e-3, -3.6188525000e-3, & + 567.0, -5.0158946000, 2.1686895000e-3, -3.6151980000e-3, & + 568.0, -5.0190992000, 2.1671876000e-3, -3.6115525000e-3, & + 569.0, -5.0222974000, 2.1656903000e-3, -3.6079159000e-3, & + 570.0, -5.0254891000, 2.1641977000e-3, -3.6042882000e-3, & + 571.0, -5.0286744000, 2.1627096000e-3, -3.6006692000e-3, & + 572.0, -5.0318533000, 2.1612262000e-3, -3.5970590000e-3, & + 573.0, -5.0350258000, 2.1597472000e-3, -3.5934575000e-3, & + 574.0, -5.0381918000, 2.1582727000e-3, -3.5898647000e-3, & + 575.0, -5.0413514000, 2.1568026000e-3, -3.5862804000e-3, & + 576.0, -5.0445046000, 2.1553369000e-3, -3.5827047000e-3, & + 577.0, -5.0476514000, 2.1538755000e-3, -3.5791374000e-3, & + 578.0, -5.0507917000, 2.1524183000e-3, -3.5755785000e-3, & + 579.0, -5.0539256000, 2.1509654000e-3, -3.5720280000e-3, & + 580.0, -5.0570532000, 2.1495166000e-3, -3.5684858000e-3, & + 581.0, -5.0601743000, 2.1480720000e-3, -3.5649519000e-3, & + 582.0, -5.0632890000, 2.1466315000e-3, -3.5614262000e-3, & + 583.0, -5.0663973000, 2.1451950000e-3, -3.5579086000e-3, & + 584.0, -5.0694991000, 2.1437625000e-3, -3.5543992000e-3, & + 585.0, -5.0725946000, 2.1423339000e-3, -3.5508978000e-3, & + 586.0, -5.0756837000, 2.1409093000e-3, -3.5474044000e-3, & + 587.0, -5.0787664000, 2.1394885000e-3, -3.5439189000e-3, & + 588.0, -5.0818427000, 2.1380716000e-3, -3.5404414000e-3, & + 589.0, -5.0849126000, 2.1366585000e-3, -3.5369717000e-3, & + 590.0, -5.0879762000, 2.1352491000e-3, -3.5335099000e-3, & + 591.0, -5.0910333000, 2.1338434000e-3, -3.5300557000e-3, & + 592.0, -5.0940841000, 2.1324413000e-3, -3.5266094000e-3, & + 593.0, -5.0971285000, 2.1310429000e-3, -3.5231706000e-3, & + 594.0, -5.1001665000, 2.1296481000e-3, -3.5197395000e-3, & + 595.0, -5.1031982000, 2.1282569000e-3, -3.5163160000e-3, & + 596.0, -5.1062234000, 2.1268691000e-3, -3.5129000000e-3, & + 597.0, -5.1092424000, 2.1254848000e-3, -3.5094915000e-3, & + 598.0, -5.1122549000, 2.1241039000e-3, -3.5060904000e-3, & + 599.0, -5.1152611000, 2.1227265000e-3, -3.5026968000e-3, & + 600.0, -5.1182610000, 2.1213524000e-3, -3.4993105000e-3, & + 601.0, -5.1212545000, 2.1199816000e-3, -3.4959315000e-3, & + 602.0, -5.1242417000, 2.1186141000e-3, -3.4925597000e-3, & + 603.0, -5.1272225000, 2.1172498000e-3, -3.4891952000e-3, & + 604.0, -5.1301970000, 2.1158888000e-3, -3.4858379000e-3, & + 605.0, -5.1331651000, 2.1145309000e-3, -3.4824877000e-3, & + 606.0, -5.1361270000, 2.1131762000e-3, -3.4791445000e-3, & + 607.0, -5.1390825000, 2.1118246000e-3, -3.4758085000e-3, & + 608.0, -5.1420316000, 2.1104761000e-3, -3.4724795000e-3, & + 609.0, -5.1449745000, 2.1091306000e-3, -3.4691574000e-3, & + 610.0, -5.1479111000, 2.1077881000e-3, -3.4658423000e-3, & + 611.0, -5.1508413000, 2.1064486000e-3, -3.4625341000e-3, & + 612.0, -5.1537652000, 2.1051120000e-3, -3.4592327000e-3, & + 613.0, -5.1566829000, 2.1037784000e-3, -3.4559381000e-3, & + 614.0, -5.1595942000, 2.1024476000e-3, -3.4526504000e-3, & + 615.0, -5.1624993000, 2.1011196000e-3, -3.4493693000e-3, & + 616.0, -5.1653981000, 2.0997945000e-3, -3.4460950000e-3, & + 617.0, -5.1682905000, 2.0984722000e-3, -3.4428273000e-3, & + 618.0, -5.1711768000, 2.0971526000e-3, -3.4395663000e-3, & + 619.0, -5.1740567000, 2.0958358000e-3, -3.4363118000e-3, & + 620.0, -5.1769304000, 2.0945216000e-3, -3.4330639000e-3, & + 621.0, -5.1797978000, 2.0932101000e-3, -3.4298226000e-3, & + 622.0, -5.1826589000, 2.0919012000e-3, -3.4265877000e-3, & + 623.0, -5.1855138000, 2.0905950000e-3, -3.4233592000e-3, & + 624.0, -5.1883625000, 2.0892913000e-3, -3.4201372000e-3, & + 625.0, -5.1912049000, 2.0879902000e-3, -3.4169215000e-3, & + 626.0, -5.1940410000, 2.0866915000e-3, -3.4137122000e-3, & + 627.0, -5.1968710000, 2.0853954000e-3, -3.4105092000e-3, & + 628.0, -5.1996947000, 2.0841018000e-3, -3.4073124000e-3, & + 629.0, -5.2025121000, 2.0828105000e-3, -3.4041219000e-3, & + 630.0, -5.2053234000, 2.0815217000e-3, -3.4009376000e-3, & + 631.0, -5.2081285000, 2.0802353000e-3, -3.3977595000e-3, & + 632.0, -5.2109273000, 2.0789512000e-3, -3.3945875000e-3, & + 633.0, -5.2137199000, 2.0776695000e-3, -3.3914216000e-3, & + 634.0, -5.2165064000, 2.0763900000e-3, -3.3882618000e-3, & + 635.0, -5.2192866000, 2.0751129000e-3, -3.3851080000e-3, & + 636.0, -5.2220607000, 2.0738380000e-3, -3.3819602000e-3, & + 637.0, -5.2248286000, 2.0725653000e-3, -3.3788184000e-3, & + 638.0, -5.2275903000, 2.0712949000e-3, -3.3756826000e-3, & + 639.0, -5.2303458000, 2.0700266000e-3, -3.3725527000e-3, & + 640.0, -5.2330952000, 2.0687604000e-3, -3.3694286000e-3, & + 641.0, -5.2358384000, 2.0674964000e-3, -3.3663104000e-3, & + 642.0, -5.2385755000, 2.0662346000e-3, -3.3631981000e-3, & + 643.0, -5.2413064000, 2.0649747000e-3, -3.3600915000e-3, & + 644.0, -5.2440312000, 2.0637170000e-3, -3.3569907000e-3, & + 645.0, -5.2467498000, 2.0624613000e-3, -3.3538957000e-3, & + 646.0, -5.2494624000, 2.0612076000e-3, -3.3508063000e-3, & + 647.0, -5.2521688000, 2.0599559000e-3, -3.3477227000e-3, & + 648.0, -5.2548690000, 2.0587062000e-3, -3.3446446000e-3, & + 649.0, -5.2575632000, 2.0574585000e-3, -3.3415722000e-3, & + 650.0, -5.2602513000, 2.0562126000e-3, -3.3385054000e-3, & + 651.0, -5.2629332000, 2.0549687000e-3, -3.3354442000e-3, & + 652.0, -5.2656091000, 2.0537266000e-3, -3.3323885000e-3, & + 653.0, -5.2682789000, 2.0524865000e-3, -3.3293383000e-3, & + 654.0, -5.2709426000, 2.0512481000e-3, -3.3262936000e-3, & + 655.0, -5.2736002000, 2.0500116000e-3, -3.3232543000e-3, & + 656.0, -5.2762518000, 2.0487769000e-3, -3.3202205000e-3, & + 657.0, -5.2788973000, 2.0475440000e-3, -3.3171921000e-3, & + 658.0, -5.2815367000, 2.0463128000e-3, -3.3141691000e-3, & + 659.0, -5.2841701000, 2.0450834000e-3, -3.3111514000e-3, & + 660.0, -5.2867975000, 2.0438557000e-3, -3.3081390000e-3, & + 661.0, -5.2894188000, 2.0426297000e-3, -3.3051319000e-3, & + 662.0, -5.2920341000, 2.0414054000e-3, -3.3021302000e-3, & + 663.0, -5.2946433000, 2.0401828000e-3, -3.2991336000e-3, & + 664.0, -5.2972466000, 2.0389618000e-3, -3.2961423000e-3, & + 665.0, -5.2998438000, 2.0377425000e-3, -3.2931562000e-3, & + 666.0, -5.3024350000, 2.0365247000e-3, -3.2901753000e-3, & + 667.0, -5.3050203000, 2.0353086000e-3, -3.2871995000e-3, & + 668.0, -5.3075995000, 2.0340940000e-3, -3.2842288000e-3, & + 669.0, -5.3101728000, 2.0328810000e-3, -3.2812633000e-3, & + 670.0, -5.3127401000, 2.0316695000e-3, -3.2783028000e-3, & + 671.0, -5.3153014000, 2.0304596000e-3, -3.2753474000e-3, & + 672.0, -5.3178568000, 2.0292512000e-3, -3.2723970000e-3, & + 673.0, -5.3204062000, 2.0280443000e-3, -3.2694517000e-3, & + 674.0, -5.3229496000, 2.0268388000e-3, -3.2665113000e-3, & + 675.0, -5.3254871000, 2.0256348000e-3, -3.2635759000e-3, & + 676.0, -5.3280187000, 2.0244322000e-3, -3.2606454000e-3, & + 677.0, -5.3305444000, 2.0232311000e-3, -3.2577199000e-3, & + 678.0, -5.3330641000, 2.0220314000e-3, -3.2547992000e-3, & + 679.0, -5.3355779000, 2.0208331000e-3, -3.2518834000e-3, & + 680.0, -5.3380858000, 2.0196361000e-3, -3.2489725000e-3, & + 681.0, -5.3405878000, 2.0184406000e-3, -3.2460664000e-3, & + 682.0, -5.3430840000, 2.0172463000e-3, -3.2431652000e-3, & + 683.0, -5.3455742000, 2.0160534000e-3, -3.2402687000e-3, & + 684.0, -5.3480585000, 2.0148619000e-3, -3.2373770000e-3, & + 685.0, -5.3505370000, 2.0136716000e-3, -3.2344900000e-3, & + 686.0, -5.3530097000, 2.0124826000e-3, -3.2316078000e-3, & + 687.0, -5.3554764000, 2.0112949000e-3, -3.2287303000e-3, & + 688.0, -5.3579373000, 2.0101085000e-3, -3.2258574000e-3, & + 689.0, -5.3603924000, 2.0089233000e-3, -3.2229893000e-3, & + 690.0, -5.3628417000, 2.0077394000e-3, -3.2201258000e-3, & + 691.0, -5.3652851000, 2.0065567000e-3, -3.2172669000e-3, & + 692.0, -5.3677227000, 2.0053752000e-3, -3.2144126000e-3, & + 693.0, -5.3701545000, 2.0041948000e-3, -3.2115629000e-3, & + 694.0, -5.3725805000, 2.0030157000e-3, -3.2087178000e-3, & + 695.0, -5.3750006000, 2.0018377000e-3, -3.2058772000e-3, & + 696.0, -5.3774150000, 2.0006609000e-3, -3.2030412000e-3, & + 697.0, -5.3798237000, 1.9994853000e-3, -3.2002097000e-3, & + 698.0, -5.3822265000, 1.9983108000e-3, -3.1973826000e-3, & + 699.0, -5.3846236000, 1.9971373000e-3, -3.1945601000e-3, & + 700.0, -5.3870149000, 1.9959650000e-3, -3.1917420000e-3, & + 701.0, -5.3894005000, 1.9947938000e-3, -3.1889283000e-3, & + 702.0, -5.3917803000, 1.9936237000e-3, -3.1861191000e-3, & + 703.0, -5.3941544000, 1.9924547000e-3, -3.1833143000e-3, & + 704.0, -5.3965228000, 1.9912867000e-3, -3.1805139000e-3, & + 705.0, -5.3988854000, 1.9901198000e-3, -3.1777178000e-3, & + 706.0, -5.4012423000, 1.9889539000e-3, -3.1749261000e-3, & + 707.0, -5.4035936000, 1.9877890000e-3, -3.1721387000e-3, & + 708.0, -5.4059391000, 1.9866252000e-3, -3.1693556000e-3, & + 709.0, -5.4082790000, 1.9854623000e-3, -3.1665769000e-3, & + 710.0, -5.4106131000, 1.9843005000e-3, -3.1638024000e-3, & + 711.0, -5.4129416000, 1.9831396000e-3, -3.1610322000e-3, & + 712.0, -5.4152645000, 1.9819797000e-3, -3.1582662000e-3, & + 713.0, -5.4175816000, 1.9808208000e-3, -3.1555045000e-3, & + 714.0, -5.4198932000, 1.9796628000e-3, -3.1527469000e-3, & + 715.0, -5.4221991000, 1.9785058000e-3, -3.1499936000e-3, & + 716.0, -5.4244993000, 1.9773497000e-3, -3.1472445000e-3, & + 717.0, -5.4267939000, 1.9761945000e-3, -3.1444995000e-3, & + 718.0, -5.4290830000, 1.9750402000e-3, -3.1417587000e-3, & + 719.0, -5.4313664000, 1.9738869000e-3, -3.1390221000e-3, & + 720.0, -5.4336442000, 1.9727344000e-3, -3.1362895000e-3, & + 721.0, -5.4359164000, 1.9715828000e-3, -3.1335611000e-3, & + 722.0, -5.4381830000, 1.9704321000e-3, -3.1308367000e-3, & + 723.0, -5.4404441000, 1.9692823000e-3, -3.1281164000e-3, & + 724.0, -5.4426996000, 1.9681333000e-3, -3.1254002000e-3, & + 725.0, -5.4449495000, 1.9669852000e-3, -3.1226881000e-3, & + 726.0, -5.4471939000, 1.9658379000e-3, -3.1199799000e-3, & + 727.0, -5.4494328000, 1.9646915000e-3, -3.1172758000e-3, & + 728.0, -5.4516661000, 1.9635458000e-3, -3.1145757000e-3, & + 729.0, -5.4538938000, 1.9624010000e-3, -3.1118796000e-3, & + 730.0, -5.4561161000, 1.9612570000e-3, -3.1091874000e-3, & + 731.0, -5.4583329000, 1.9601138000e-3, -3.1064992000e-3, & + 732.0, -5.4605441000, 1.9589714000e-3, -3.1038149000e-3, & + 733.0, -5.4627499000, 1.9578298000e-3, -3.1011346000e-3, & + 734.0, -5.4649502000, 1.9566889000e-3, -3.0984582000e-3, & + 735.0, -5.4671450000, 1.9555488000e-3, -3.0957857000e-3, & + 736.0, -5.4693343000, 1.9544095000e-3, -3.0931171000e-3, & + 737.0, -5.4715182000, 1.9532709000e-3, -3.0904524000e-3, & + 738.0, -5.4736966000, 1.9521331000e-3, -3.0877915000e-3, & + 739.0, -5.4758696000, 1.9509960000e-3, -3.0851345000e-3, & + 740.0, -5.4780372000, 1.9498596000e-3, -3.0824813000e-3, & + 741.0, -5.4801993000, 1.9487240000e-3, -3.0798319000e-3, & + 742.0, -5.4823560000, 1.9475891000e-3, -3.0771864000e-3, & + 743.0, -5.4845073000, 1.9464549000e-3, -3.0745446000e-3, & + 744.0, -5.4866533000, 1.9453214000e-3, -3.0719066000e-3, & + 745.0, -5.4887938000, 1.9441885000e-3, -3.0692724000e-3, & + 746.0, -5.4909289000, 1.9430564000e-3, -3.0666420000e-3, & + 747.0, -5.4930587000, 1.9419250000e-3, -3.0640153000e-3, & + 748.0, -5.4951831000, 1.9407942000e-3, -3.0613923000e-3, & + 749.0, -5.4973021000, 1.9396641000e-3, -3.0587731000e-3, & + 750.0, -5.4994158000, 1.9385347000e-3, -3.0561575000e-3, & + 751.0, -5.5015242000, 1.9374059000e-3, -3.0535457000e-3, & + 752.0, -5.5036272000, 1.9362778000e-3, -3.0509375000e-3, & + 753.0, -5.5057250000, 1.9351503000e-3, -3.0483331000e-3, & + 754.0, -5.5078174000, 1.9340235000e-3, -3.0457322000e-3, & + 755.0, -5.5099044000, 1.9328973000e-3, -3.0431351000e-3, & + 756.0, -5.5119863000, 1.9317717000e-3, -3.0405415000e-3, & + 757.0, -5.5140628000, 1.9306468000e-3, -3.0379516000e-3, & + 758.0, -5.5161340000, 1.9295224000e-3, -3.0353653000e-3, & + 759.0, -5.5182000000, 1.9283987000e-3, -3.0327826000e-3, & + 760.0, -5.5202607000, 1.9272756000e-3, -3.0302035000e-3, & + 761.0, -5.5223161000, 1.9261531000e-3, -3.0276280000e-3, & + 762.0, -5.5243664000, 1.9250311000e-3, -3.0250561000e-3, & + 763.0, -5.5264113000, 1.9239098000e-3, -3.0224877000e-3, & + 764.0, -5.5284511000, 1.9227890000e-3, -3.0199228000e-3, & + 765.0, -5.5304856000, 1.9216689000e-3, -3.0173615000e-3, & + 766.0, -5.5325150000, 1.9205493000e-3, -3.0148038000e-3, & + 767.0, -5.5345391000, 1.9194303000e-3, -3.0122495000e-3, & + 768.0, -5.5365581000, 1.9183118000e-3, -3.0096987000e-3, & + 769.0, -5.5385718000, 1.9171939000e-3, -3.0071515000e-3, & + 770.0, -5.5405804000, 1.9160766000e-3, -3.0046077000e-3, & + 771.0, -5.5425839000, 1.9149598000e-3, -3.0020674000e-3, & + 772.0, -5.5445822000, 1.9138435000e-3, -2.9995305000e-3, & + 773.0, -5.5465753000, 1.9127278000e-3, -2.9969971000e-3, & + 774.0, -5.5485633000, 1.9116127000e-3, -2.9944671000e-3, & + 775.0, -5.5505462000, 1.9104981000e-3, -2.9919406000e-3, & + 776.0, -5.5525239000, 1.9093840000e-3, -2.9894175000e-3, & + 777.0, -5.5544966000, 1.9082704000e-3, -2.9868978000e-3, & + 778.0, -5.5564641000, 1.9071573000e-3, -2.9843815000e-3, & + 779.0, -5.5584266000, 1.9060448000e-3, -2.9818686000e-3, & + 780.0, -5.5603840000, 1.9049328000e-3, -2.9793591000e-3, & + 781.0, -5.5623363000, 1.9038213000e-3, -2.9768530000e-3, & + 782.0, -5.5642835000, 1.9027103000e-3, -2.9743502000e-3, & + 783.0, -5.5662257000, 1.9015998000e-3, -2.9718507000e-3, & + 784.0, -5.5681628000, 1.9004898000e-3, -2.9693547000e-3, & + 785.0, -5.5700949000, 1.8993803000e-3, -2.9668619000e-3, & + 786.0, -5.5720220000, 1.8982713000e-3, -2.9643725000e-3, & + 787.0, -5.5739440000, 1.8971627000e-3, -2.9618864000e-3, & + 788.0, -5.5758611000, 1.8960547000e-3, -2.9594036000e-3, & + 789.0, -5.5777731000, 1.8949471000e-3, -2.9569240000e-3, & + 790.0, -5.5796802000, 1.8938401000e-3, -2.9544478000e-3, & + 791.0, -5.5815822000, 1.8927334000e-3, -2.9519749000e-3, & + 792.0, -5.5834793000, 1.8916273000e-3, -2.9495052000e-3, & + 793.0, -5.5853715000, 1.8905216000e-3, -2.9470388000e-3, & + 794.0, -5.5872586000, 1.8894164000e-3, -2.9445756000e-3, & + 795.0, -5.5891409000, 1.8883117000e-3, -2.9421157000e-3, & + 796.0, -5.5910182000, 1.8872074000e-3, -2.9396591000e-3, & + 797.0, -5.5928905000, 1.8861036000e-3, -2.9372056000e-3, & + 798.0, -5.5947580000, 1.8850002000e-3, -2.9347554000e-3, & + 799.0, -5.5966205000, 1.8838973000e-3, -2.9323083000e-3, & + 800.0, -5.5984781000, 1.8827948000e-3, -2.9298645000e-3, & + 801.0, -5.6003309000, 1.8816928000e-3, -2.9274239000e-3, & + 802.0, -5.6021787000, 1.8805912000e-3, -2.9249864000e-3, & + 803.0, -5.6040217000, 1.8794901000e-3, -2.9225522000e-3, & + 804.0, -5.6058598000, 1.8783894000e-3, -2.9201211000e-3, & + 805.0, -5.6076931000, 1.8772891000e-3, -2.9176931000e-3, & + 806.0, -5.6095215000, 1.8761892000e-3, -2.9152683000e-3, & + 807.0, -5.6113451000, 1.8750898000e-3, -2.9128467000e-3, & + 808.0, -5.6131638000, 1.8739909000e-3, -2.9104282000e-3, & + 809.0, -5.6149777000, 1.8728923000e-3, -2.9080128000e-3, & + 810.0, -5.6167869000, 1.8717942000e-3, -2.9056005000e-3, & + 811.0, -5.6185912000, 1.8706965000e-3, -2.9031914000e-3, & + 812.0, -5.6203907000, 1.8695992000e-3, -2.9007853000e-3, & + 813.0, -5.6221855000, 1.8685023000e-3, -2.8983824000e-3, & + 814.0, -5.6239754000, 1.8674058000e-3, -2.8959825000e-3, & + 815.0, -5.6257606000, 1.8663098000e-3, -2.8935857000e-3, & + 816.0, -5.6275411000, 1.8652141000e-3, -2.8911920000e-3, & + 817.0, -5.6293168000, 1.8641189000e-3, -2.8888014000e-3, & + 818.0, -5.6310878000, 1.8630241000e-3, -2.8864138000e-3, & + 819.0, -5.6328540000, 1.8619297000e-3, -2.8840292000e-3, & + 820.0, -5.6346155000, 1.8608357000e-3, -2.8816477000e-3, & + 821.0, -5.6363723000, 1.8597420000e-3, -2.8792693000e-3, & + 822.0, -5.6381245000, 1.8586488000e-3, -2.8768939000e-3, & + 823.0, -5.6398719000, 1.8575560000e-3, -2.8745215000e-3, & + 824.0, -5.6416146000, 1.8564636000e-3, -2.8721521000e-3, & + 825.0, -5.6433527000, 1.8553716000e-3, -2.8697857000e-3, & + 826.0, -5.6450861000, 1.8542799000e-3, -2.8674223000e-3, & + 827.0, -5.6468149000, 1.8531887000e-3, -2.8650619000e-3, & + 828.0, -5.6485390000, 1.8520979000e-3, -2.8627045000e-3, & + 829.0, -5.6502584000, 1.8510074000e-3, -2.8603501000e-3, & + 830.0, -5.6519733000, 1.8499173000e-3, -2.8579986000e-3, & + 831.0, -5.6536835000, 1.8488276000e-3, -2.8556502000e-3, & + 832.0, -5.6553891000, 1.8477384000e-3, -2.8533046000e-3, & + 833.0, -5.6570901000, 1.8466494000e-3, -2.8509621000e-3, & + 834.0, -5.6587866000, 1.8455609000e-3, -2.8486224000e-3, & + 835.0, -5.6604784000, 1.8444728000e-3, -2.8462858000e-3, & + 836.0, -5.6621657000, 1.8433850000e-3, -2.8439520000e-3, & + 837.0, -5.6638484000, 1.8422976000e-3, -2.8416212000e-3, & + 838.0, -5.6655266000, 1.8412106000e-3, -2.8392933000e-3, & + 839.0, -5.6672002000, 1.8401239000e-3, -2.8369683000e-3, & + 840.0, -5.6688693000, 1.8390377000e-3, -2.8346462000e-3, & + 841.0, -5.6705338000, 1.8379518000e-3, -2.8323270000e-3, & + 842.0, -5.6721939000, 1.8368663000e-3, -2.8300107000e-3, & + 843.0, -5.6738494000, 1.8357811000e-3, -2.8276973000e-3, & + 844.0, -5.6755004000, 1.8346964000e-3, -2.8253867000e-3, & + 845.0, -5.6771470000, 1.8336120000e-3, -2.8230791000e-3, & + 846.0, -5.6787890000, 1.8325279000e-3, -2.8207743000e-3, & + 847.0, -5.6804266000, 1.8314443000e-3, -2.8184724000e-3, & + 848.0, -5.6820597000, 1.8303610000e-3, -2.8161733000e-3, & + 849.0, -5.6836884000, 1.8292781000e-3, -2.8138771000e-3, & + 850.0, -5.6853127000, 1.8281955000e-3, -2.8115837000e-3, & + 851.0, -5.6869325000, 1.8271133000e-3, -2.8092932000e-3, & + 852.0, -5.6885478000, 1.8260315000e-3, -2.8070055000e-3, & + 853.0, -5.6901588000, 1.8249501000e-3, -2.8047206000e-3, & + 854.0, -5.6917653000, 1.8238690000e-3, -2.8024385000e-3, & + 855.0, -5.6933675000, 1.8227882000e-3, -2.8001593000e-3, & + 856.0, -5.6949653000, 1.8217079000e-3, -2.7978829000e-3, & + 857.0, -5.6965586000, 1.8206279000e-3, -2.7956092000e-3, & + 858.0, -5.6981477000, 1.8195482000e-3, -2.7933384000e-3, & + 859.0, -5.6997323000, 1.8184690000e-3, -2.7910703000e-3, & + 860.0, -5.7013126000, 1.8173900000e-3, -2.7888051000e-3, & + 861.0, -5.7028886000, 1.8163115000e-3, -2.7865426000e-3, & + 862.0, -5.7044602000, 1.8152333000e-3, -2.7842829000e-3, & + 863.0, -5.7060275000, 1.8141555000e-3, -2.7820260000e-3, & + 864.0, -5.7075905000, 1.8130780000e-3, -2.7797718000e-3, & + 865.0, -5.7091492000, 1.8120009000e-3, -2.7775204000e-3, & + 866.0, -5.7107035000, 1.8109241000e-3, -2.7752717000e-3, & + 867.0, -5.7122536000, 1.8098477000e-3, -2.7730258000e-3, & + 868.0, -5.7137995000, 1.8087717000e-3, -2.7707826000e-3, & + 869.0, -5.7153410000, 1.8076960000e-3, -2.7685421000e-3, & + 870.0, -5.7168783000, 1.8066207000e-3, -2.7663044000e-3, & + 871.0, -5.7184113000, 1.8055458000e-3, -2.7640694000e-3, & + 872.0, -5.7199401000, 1.8044712000e-3, -2.7618372000e-3, & + 873.0, -5.7214646000, 1.8033969000e-3, -2.7596076000e-3, & + 874.0, -5.7229850000, 1.8023230000e-3, -2.7573808000e-3, & + 875.0, -5.7245011000, 1.8012495000e-3, -2.7551566000e-3, & + 876.0, -5.7260130000, 1.8001763000e-3, -2.7529352000e-3, & + 877.0, -5.7275207000, 1.7991035000e-3, -2.7507164000e-3, & + 878.0, -5.7290242000, 1.7980311000e-3, -2.7485003000e-3, & + 879.0, -5.7305236000, 1.7969590000e-3, -2.7462870000e-3, & + 880.0, -5.7320187000, 1.7958873000e-3, -2.7440763000e-3, & + 881.0, -5.7335097000, 1.7948159000e-3, -2.7418682000e-3, & + 882.0, -5.7349966000, 1.7937449000e-3, -2.7396629000e-3, & + 883.0, -5.7364793000, 1.7926742000e-3, -2.7374601000e-3, & + 884.0, -5.7379579000, 1.7916039000e-3, -2.7352601000e-3, & + 885.0, -5.7394323000, 1.7905340000e-3, -2.7330627000e-3, & + 886.0, -5.7409027000, 1.7894644000e-3, -2.7308680000e-3, & + 887.0, -5.7423689000, 1.7883951000e-3, -2.7286759000e-3, & + 888.0, -5.7438310000, 1.7873263000e-3, -2.7264864000e-3, & + 889.0, -5.7452891000, 1.7862578000e-3, -2.7242996000e-3, & + 890.0, -5.7467430000, 1.7851896000e-3, -2.7221154000e-3, & + 891.0, -5.7481929000, 1.7841218000e-3, -2.7199338000e-3, & + 892.0, -5.7496387000, 1.7830544000e-3, -2.7177548000e-3, & + 893.0, -5.7510805000, 1.7819873000e-3, -2.7155785000e-3, & + 894.0, -5.7525182000, 1.7809206000e-3, -2.7134047000e-3, & + 895.0, -5.7539519000, 1.7798543000e-3, -2.7112336000e-3, & + 896.0, -5.7553816000, 1.7787883000e-3, -2.7090651000e-3, & + 897.0, -5.7568072000, 1.7777227000e-3, -2.7068991000e-3, & + 898.0, -5.7582289000, 1.7766574000e-3, -2.7047358000e-3, & + 899.0, -5.7596465000, 1.7755925000e-3, -2.7025750000e-3, & + 900.0, -5.7610602000, 1.7745280000e-3, -2.7004169000e-3, & + 901.0, -5.7624698000, 1.7734638000e-3, -2.6982613000e-3, & + 902.0, -5.7638755000, 1.7724000000e-3, -2.6961082000e-3, & + 903.0, -5.7652772000, 1.7713365000e-3, -2.6939578000e-3, & + 904.0, -5.7666750000, 1.7702734000e-3, -2.6918099000e-3, & + 905.0, -5.7680688000, 1.7692107000e-3, -2.6896645000e-3, & + 906.0, -5.7694587000, 1.7681484000e-3, -2.6875218000e-3, & + 907.0, -5.7708447000, 1.7670864000e-3, -2.6853815000e-3, & + 908.0, -5.7722267000, 1.7660247000e-3, -2.6832438000e-3, & + 909.0, -5.7736048000, 1.7649635000e-3, -2.6811087000e-3, & + 910.0, -5.7749791000, 1.7639026000e-3, -2.6789761000e-3, & + 911.0, -5.7763494000, 1.7628421000e-3, -2.6768460000e-3, & + 912.0, -5.7777158000, 1.7617819000e-3, -2.6747185000e-3, & + 913.0, -5.7790784000, 1.7607221000e-3, -2.6725934000e-3, & + 914.0, -5.7804371000, 1.7596627000e-3, -2.6704709000e-3, & + 915.0, -5.7817919000, 1.7586037000e-3, -2.6683510000e-3, & + 916.0, -5.7831429000, 1.7575450000e-3, -2.6662335000e-3, & + 917.0, -5.7844901000, 1.7564867000e-3, -2.6641185000e-3, & + 918.0, -5.7858334000, 1.7554288000e-3, -2.6620060000e-3, & + 919.0, -5.7871729000, 1.7543712000e-3, -2.6598961000e-3, & + 920.0, -5.7885086000, 1.7533140000e-3, -2.6577886000e-3, & + 921.0, -5.7898405000, 1.7522572000e-3, -2.6556836000e-3, & + 922.0, -5.7911686000, 1.7512008000e-3, -2.6535811000e-3, & + 923.0, -5.7924928000, 1.7501447000e-3, -2.6514811000e-3, & + 924.0, -5.7938134000, 1.7490890000e-3, -2.6493836000e-3, & + 925.0, -5.7951301000, 1.7480337000e-3, -2.6472885000e-3, & + 926.0, -5.7964431000, 1.7469788000e-3, -2.6451960000e-3, & + 927.0, -5.7977523000, 1.7459242000e-3, -2.6431058000e-3, & + 928.0, -5.7990578000, 1.7448700000e-3, -2.6410182000e-3, & + 929.0, -5.8003595000, 1.7438162000e-3, -2.6389330000e-3, & + 930.0, -5.8016575000, 1.7427628000e-3, -2.6368502000e-3, & + 931.0, -5.8029518000, 1.7417098000e-3, -2.6347699000e-3, & + 932.0, -5.8042424000, 1.7406571000e-3, -2.6326921000e-3, & + 933.0, -5.8055293000, 1.7396049000e-3, -2.6306167000e-3, & + 934.0, -5.8068125000, 1.7385530000e-3, -2.6285437000e-3, & + 935.0, -5.8080920000, 1.7375015000e-3, -2.6264732000e-3, & + 936.0, -5.8093679000, 1.7364504000e-3, -2.6244051000e-3, & + 937.0, -5.8106400000, 1.7353996000e-3, -2.6223394000e-3, & + 938.0, -5.8119085000, 1.7343493000e-3, -2.6202762000e-3, & + 939.0, -5.8131734000, 1.7332993000e-3, -2.6182153000e-3, & + 940.0, -5.8144346000, 1.7322497000e-3, -2.6161569000e-3, & + 941.0, -5.8156922000, 1.7312006000e-3, -2.6141009000e-3, & + 942.0, -5.8169461000, 1.7301518000e-3, -2.6120473000e-3, & + 943.0, -5.8181965000, 1.7291034000e-3, -2.6099961000e-3, & + 944.0, -5.8194432000, 1.7280553000e-3, -2.6079473000e-3, & + 945.0, -5.8206864000, 1.7270077000e-3, -2.6059010000e-3, & + 946.0, -5.8219259000, 1.7259605000e-3, -2.6038570000e-3, & + 947.0, -5.8231619000, 1.7249137000e-3, -2.6018154000e-3, & + 948.0, -5.8243943000, 1.7238672000e-3, -2.5997761000e-3, & + 949.0, -5.8256231000, 1.7228212000e-3, -2.5977393000e-3, & + 950.0, -5.8268484000, 1.7217755000e-3, -2.5957048000e-3, & + 951.0, -5.8280701000, 1.7207303000e-3, -2.5936728000e-3, & + 952.0, -5.8292883000, 1.7196854000e-3, -2.5916430000e-3, & + 953.0, -5.8305029000, 1.7186410000e-3, -2.5896157000e-3, & + 954.0, -5.8317141000, 1.7175970000e-3, -2.5875907000e-3, & + 955.0, -5.8329217000, 1.7165533000e-3, -2.5855681000e-3, & + 956.0, -5.8341258000, 1.7155101000e-3, -2.5835478000e-3, & + 957.0, -5.8353264000, 1.7144672000e-3, -2.5815299000e-3, & + 958.0, -5.8365235000, 1.7134248000e-3, -2.5795144000e-3, & + 959.0, -5.8377172000, 1.7123828000e-3, -2.5775012000e-3, & + 960.0, -5.8389074000, 1.7113411000e-3, -2.5754903000e-3, & + 961.0, -5.8400941000, 1.7102999000e-3, -2.5734818000e-3, & + 962.0, -5.8412773000, 1.7092591000e-3, -2.5714756000e-3, & + 963.0, -5.8424571000, 1.7082187000e-3, -2.5694717000e-3, & + 964.0, -5.8436335000, 1.7071787000e-3, -2.5674702000e-3, & + 965.0, -5.8448065000, 1.7061391000e-3, -2.5654710000e-3, & + 966.0, -5.8459760000, 1.7051000000e-3, -2.5634741000e-3, & + 967.0, -5.8471421000, 1.7040612000e-3, -2.5614796000e-3, & + 968.0, -5.8483048000, 1.7030229000e-3, -2.5594873000e-3, & + 969.0, -5.8494641000, 1.7019850000e-3, -2.5574974000e-3, & + 970.0, -5.8506200000, 1.7009475000e-3, -2.5555098000e-3, & + 971.0, -5.8517725000, 1.6999104000e-3, -2.5535245000e-3, & + 972.0, -5.8529217000, 1.6988737000e-3, -2.5515415000e-3, & + 973.0, -5.8540675000, 1.6978374000e-3, -2.5495608000e-3, & + 974.0, -5.8552099000, 1.6968016000e-3, -2.5475824000e-3, & + 975.0, -5.8563490000, 1.6957662000e-3, -2.5456062000e-3, & + 976.0, -5.8574847000, 1.6947312000e-3, -2.5436324000e-3, & + 977.0, -5.8586172000, 1.6936966000e-3, -2.5416609000e-3, & + 978.0, -5.8597463000, 1.6926625000e-3, -2.5396916000e-3, & + 979.0, -5.8608720000, 1.6916288000e-3, -2.5377246000e-3, & + 980.0, -5.8619945000, 1.6905955000e-3, -2.5357599000e-3, & + 981.0, -5.8631137000, 1.6895626000e-3, -2.5337975000e-3, & + 982.0, -5.8642296000, 1.6885302000e-3, -2.5318373000e-3, & + 983.0, -5.8653422000, 1.6874982000e-3, -2.5298794000e-3, & + 984.0, -5.8664515000, 1.6864666000e-3, -2.5279238000e-3, & + 985.0, -5.8675576000, 1.6854355000e-3, -2.5259704000e-3, & + 986.0, -5.8686604000, 1.6844048000e-3, -2.5240193000e-3, & + 987.0, -5.8697599000, 1.6833745000e-3, -2.5220704000e-3, & + 988.0, -5.8708562000, 1.6823447000e-3, -2.5201238000e-3, & + 989.0, -5.8719493000, 1.6813153000e-3, -2.5181795000e-3, & + 990.0, -5.8730391000, 1.6802863000e-3, -2.5162374000e-3, & + 991.0, -5.8741258000, 1.6792578000e-3, -2.5142975000e-3, & + 992.0, -5.8752092000, 1.6782297000e-3, -2.5123598000e-3, & + 993.0, -5.8762894000, 1.6772020000e-3, -2.5104244000e-3, & + 994.0, -5.8773664000, 1.6761748000e-3, -2.5084913000e-3, & + 995.0, -5.8784403000, 1.6751480000e-3, -2.5065603000e-3, & + 996.0, -5.8795109000, 1.6741217000e-3, -2.5046316000e-3, & + 997.0, -5.8805784000, 1.6730958000e-3, -2.5027051000e-3, & + 998.0, -5.8816427000, 1.6720704000e-3, -2.5007809000e-3, & + 999.0, -5.8827039000, 1.6710454000e-3, -2.4988588000e-3, & + 1000.0, -5.8837619000, 1.6700209000e-3, -2.4969390000e-3, & + 1001.0, -5.8848168000, 1.6689968000e-3, -2.4950213000e-3, & + 1002.0, -5.8858686000, 1.6679732000e-3, -2.4931059000e-3, & + 1003.0, -5.8869172000, 1.6669500000e-3, -2.4911927000e-3, & + 1004.0, -5.8879627000, 1.6659272000e-3, -2.4892817000e-3, & + 1005.0, -5.8890051000, 1.6649049000e-3, -2.4873729000e-3, & + 1006.0, -5.8900444000, 1.6638831000e-3, -2.4854663000e-3, & + 1007.0, -5.8910807000, 1.6628617000e-3, -2.4835619000e-3, & + 1008.0, -5.8921138000, 1.6618408000e-3, -2.4816596000e-3, & + 1009.0, -5.8931439000, 1.6608204000e-3, -2.4797596000e-3, & + 1010.0, -5.8941708000, 1.6598004000e-3, -2.4778617000e-3, & + 1011.0, -5.8951948000, 1.6587808000e-3, -2.4759660000e-3, & + 1012.0, -5.8962156000, 1.6577617000e-3, -2.4740725000e-3, & + 1013.0, -5.8972335000, 1.6567431000e-3, -2.4721812000e-3, & + 1014.0, -5.8982483000, 1.6557250000e-3, -2.4702920000e-3, & + 1015.0, -5.8992600000, 1.6547073000e-3, -2.4684051000e-3, & + 1016.0, -5.9002688000, 1.6536901000e-3, -2.4665202000e-3, & + 1017.0, -5.9012745000, 1.6526733000e-3, -2.4646376000e-3, & + 1018.0, -5.9022772000, 1.6516570000e-3, -2.4627571000e-3, & + 1019.0, -5.9032769000, 1.6506412000e-3, -2.4608788000e-3, & + 1020.0, -5.9042737000, 1.6496258000e-3, -2.4590026000e-3, & + 1021.0, -5.9052674000, 1.6486109000e-3, -2.4571286000e-3, & + 1022.0, -5.9062582000, 1.6475965000e-3, -2.4552567000e-3, & + 1023.0, -5.9072460000, 1.6465826000e-3, -2.4533870000e-3, & + 1024.0, -5.9082308000, 1.6455691000e-3, -2.4515194000e-3, & + 1025.0, -5.9092127000, 1.6445561000e-3, -2.4496539000e-3, & + 1026.0, -5.9101917000, 1.6435436000e-3, -2.4477906000e-3, & + 1027.0, -5.9111677000, 1.6425316000e-3, -2.4459295000e-3, & + 1028.0, -5.9121408000, 1.6415200000e-3, -2.4440704000e-3, & + 1029.0, -5.9131109000, 1.6405089000e-3, -2.4422135000e-3, & + 1030.0, -5.9140782000, 1.6394983000e-3, -2.4403587000e-3, & + 1031.0, -5.9150425000, 1.6384882000e-3, -2.4385061000e-3, & + 1032.0, -5.9160039000, 1.6374786000e-3, -2.4366555000e-3, & + 1033.0, -5.9169625000, 1.6364694000e-3, -2.4348071000e-3, & + 1034.0, -5.9179181000, 1.6354607000e-3, -2.4329608000e-3, & + 1035.0, -5.9188709000, 1.6344526000e-3, -2.4311166000e-3, & + 1036.0, -5.9198208000, 1.6334449000e-3, -2.4292746000e-3, & + 1037.0, -5.9207678000, 1.6324377000e-3, -2.4274346000e-3, & + 1038.0, -5.9217120000, 1.6314309000e-3, -2.4255967000e-3, & + 1039.0, -5.9226533000, 1.6304247000e-3, -2.4237610000e-3, & + 1040.0, -5.9235918000, 1.6294190000e-3, -2.4219273000e-3, & + 1041.0, -5.9245275000, 1.6284137000e-3, -2.4200958000e-3, & + 1042.0, -5.9254603000, 1.6274090000e-3, -2.4182663000e-3, & + 1043.0, -5.9263904000, 1.6264047000e-3, -2.4164389000e-3, & + 1044.0, -5.9273176000, 1.6254009000e-3, -2.4146136000e-3, & + 1045.0, -5.9282420000, 1.6243977000e-3, -2.4127904000e-3, & + 1046.0, -5.9291636000, 1.6233949000e-3, -2.4109693000e-3, & + 1047.0, -5.9300824000, 1.6223926000e-3, -2.4091503000e-3, & + 1048.0, -5.9309984000, 1.6213909000e-3, -2.4073333000e-3, & + 1049.0, -5.9319117000, 1.6203896000e-3, -2.4055185000e-3, & + 1050.0, -5.9328222000, 1.6193888000e-3, -2.4037057000e-3, & + 1051.0, -5.9337299000, 1.6183886000e-3, -2.4018949000e-3, & + 1052.0, -5.9346349000, 1.6173888000e-3, -2.4000862000e-3, & + 1053.0, -5.9355371000, 1.6163895000e-3, -2.3982796000e-3, & + 1054.0, -5.9364366000, 1.6153908000e-3, -2.3964751000e-3, & + 1055.0, -5.9373334000, 1.6143925000e-3, -2.3946726000e-3, & + 1056.0, -5.9382274000, 1.6133948000e-3, -2.3928722000e-3, & + 1057.0, -5.9391187000, 1.6123976000e-3, -2.3910738000e-3, & + 1058.0, -5.9400074000, 1.6114009000e-3, -2.3892775000e-3, & + 1059.0, -5.9408933000, 1.6104046000e-3, -2.3874833000e-3, & + 1060.0, -5.9417765000, 1.6094089000e-3, -2.3856910000e-3, & + 1061.0, -5.9426570000, 1.6084138000e-3, -2.3839009000e-3, & + 1062.0, -5.9435349000, 1.6074191000e-3, -2.3821127000e-3, & + 1063.0, -5.9444100000, 1.6064249000e-3, -2.3803266000e-3, & + 1064.0, -5.9452825000, 1.6054313000e-3, -2.3785426000e-3, & + 1065.0, -5.9461524000, 1.6044382000e-3, -2.3767606000e-3, & + 1066.0, -5.9470196000, 1.6034456000e-3, -2.3749806000e-3, & + 1067.0, -5.9478841000, 1.6024535000e-3, -2.3732026000e-3, & + 1068.0, -5.9487460000, 1.6014619000e-3, -2.3714267000e-3, & + 1069.0, -5.9496053000, 1.6004709000e-3, -2.3696528000e-3, & + 1070.0, -5.9504619000, 1.5994804000e-3, -2.3678809000e-3, & + 1071.0, -5.9513160000, 1.5984904000e-3, -2.3661110000e-3, & + 1072.0, -5.9521674000, 1.5975009000e-3, -2.3643432000e-3, & + 1073.0, -5.9530162000, 1.5965120000e-3, -2.3625773000e-3, & + 1074.0, -5.9538624000, 1.5955236000e-3, -2.3608135000e-3, & + 1075.0, -5.9547061000, 1.5945357000e-3, -2.3590517000e-3, & + 1076.0, -5.9555471000, 1.5935483000e-3, -2.3572919000e-3, & + 1077.0, -5.9563856000, 1.5925615000e-3, -2.3555341000e-3, & + 1078.0, -5.9572215000, 1.5915752000e-3, -2.3537782000e-3, & + 1079.0, -5.9580548000, 1.5905894000e-3, -2.3520244000e-3, & + 1080.0, -5.9588856000, 1.5896041000e-3, -2.3502726000e-3, & + 1081.0, -5.9597138000, 1.5886194000e-3, -2.3485228000e-3, & + 1082.0, -5.9605395000, 1.5876353000e-3, -2.3467750000e-3, & + 1083.0, -5.9613627000, 1.5866516000e-3, -2.3450292000e-3, & + 1084.0, -5.9621833000, 1.5856685000e-3, -2.3432853000e-3, & + 1085.0, -5.9630014000, 1.5846860000e-3, -2.3415434000e-3, & + 1086.0, -5.9638170000, 1.5837039000e-3, -2.3398036000e-3, & + 1087.0, -5.9646301000, 1.5827224000e-3, -2.3380657000e-3, & + 1088.0, -5.9654407000, 1.5817415000e-3, -2.3363297000e-3, & + 1089.0, -5.9662488000, 1.5807611000e-3, -2.3345958000e-3, & + 1090.0, -5.9670544000, 1.5797812000e-3, -2.3328638000e-3, & + 1091.0, -5.9678575000, 1.5788019000e-3, -2.3311338000e-3, & + 1092.0, -5.9686582000, 1.5778231000e-3, -2.3294057000e-3, & + 1093.0, -5.9694563000, 1.5768449000e-3, -2.3276797000e-3, & + 1094.0, -5.9702521000, 1.5758672000e-3, -2.3259555000e-3, & + 1095.0, -5.9710453000, 1.5748901000e-3, -2.3242334000e-3, & + 1096.0, -5.9718361000, 1.5739135000e-3, -2.3225132000e-3, & + 1097.0, -5.9726245000, 1.5729374000e-3, -2.3207950000e-3, & + 1098.0, -5.9734105000, 1.5719619000e-3, -2.3190787000e-3, & + 1099.0, -5.9741940000, 1.5709870000e-3, -2.3173643000e-3, & + 1100.0, -5.9749751000, 1.5700126000e-3, -2.3156519000e-3, & + 1101.0, -5.9757538000, 1.5690387000e-3, -2.3139415000e-3, & + 1102.0, -5.9765300000, 1.5680654000e-3, -2.3122330000e-3, & + 1103.0, -5.9773039000, 1.5670927000e-3, -2.3105264000e-3, & + 1104.0, -5.9780754000, 1.5661205000e-3, -2.3088218000e-3, & + 1105.0, -5.9788445000, 1.5651489000e-3, -2.3071191000e-3, & + 1106.0, -5.9796112000, 1.5641778000e-3, -2.3054184000e-3, & + 1107.0, -5.9803755000, 1.5632073000e-3, -2.3037195000e-3, & + 1108.0, -5.9811375000, 1.5622374000e-3, -2.3020226000e-3, & + 1109.0, -5.9818971000, 1.5612680000e-3, -2.3003277000e-3, & + 1110.0, -5.9826543000, 1.5602991000e-3, -2.2986346000e-3, & + 1111.0, -5.9834092000, 1.5593309000e-3, -2.2969435000e-3, & + 1112.0, -5.9841618000, 1.5583632000e-3, -2.2952543000e-3, & + 1113.0, -5.9849120000, 1.5573960000e-3, -2.2935670000e-3, & + 1114.0, -5.9856599000, 1.5564294000e-3, -2.2918817000e-3, & + 1115.0, -5.9864054000, 1.5554634000e-3, -2.2901982000e-3, & + 1116.0, -5.9871487000, 1.5544979000e-3, -2.2885167000e-3, & + 1117.0, -5.9878896000, 1.5535331000e-3, -2.2868370000e-3, & + 1118.0, -5.9886282000, 1.5525687000e-3, -2.2851593000e-3, & + 1119.0, -5.9893646000, 1.5516050000e-3, -2.2834835000e-3, & + 1120.0, -5.9900986000, 1.5506418000e-3, -2.2818095000e-3, & + 1121.0, -5.9908304000, 1.5496792000e-3, -2.2801375000e-3, & + 1122.0, -5.9915599000, 1.5487171000e-3, -2.2784674000e-3, & + 1123.0, -5.9922871000, 1.5477557000e-3, -2.2767991000e-3, & + 1124.0, -5.9930120000, 1.5467948000e-3, -2.2751328000e-3, & + 1125.0, -5.9937347000, 1.5458344000e-3, -2.2734683000e-3, & + 1126.0, -5.9944551000, 1.5448747000e-3, -2.2718058000e-3, & + 1127.0, -5.9951733000, 1.5439155000e-3, -2.2701451000e-3, & + 1128.0, -5.9958892000, 1.5429569000e-3, -2.2684863000e-3, & + 1129.0, -5.9966029000, 1.5419989000e-3, -2.2668294000e-3, & + 1130.0, -5.9973144000, 1.5410414000e-3, -2.2651743000e-3, & + 1131.0, -5.9980236000, 1.5400845000e-3, -2.2635212000e-3, & + 1132.0, -5.9987307000, 1.5391282000e-3, -2.2618699000e-3, & + 1133.0, -5.9994355000, 1.5381725000e-3, -2.2602205000e-3, & + 1134.0, -6.0001381000, 1.5372174000e-3, -2.2585729000e-3, & + 1135.0, -6.0008385000, 1.5362628000e-3, -2.2569272000e-3, & + 1136.0, -6.0015367000, 1.5353089000e-3, -2.2552834000e-3, & + 1137.0, -6.0022328000, 1.5343555000e-3, -2.2536414000e-3, & + 1138.0, -6.0029266000, 1.5334027000e-3, -2.2520013000e-3, & + 1139.0, -6.0036183000, 1.5324504000e-3, -2.2503631000e-3, & + 1140.0, -6.0043078000, 1.5314988000e-3, -2.2487267000e-3, & + 1141.0, -6.0049952000, 1.5305477000e-3, -2.2470922000e-3, & + 1142.0, -6.0056804000, 1.5295973000e-3, -2.2454595000e-3, & + 1143.0, -6.0063635000, 1.5286474000e-3, -2.2438287000e-3, & + 1144.0, -6.0070444000, 1.5276981000e-3, -2.2421997000e-3, & + 1145.0, -6.0077231000, 1.5267494000e-3, -2.2405726000e-3, & + 1146.0, -6.0083998000, 1.5258013000e-3, -2.2389473000e-3, & + 1147.0, -6.0090743000, 1.5248538000e-3, -2.2373238000e-3, & + 1148.0, -6.0097467000, 1.5239068000e-3, -2.2357022000e-3, & + 1149.0, -6.0104170000, 1.5229605000e-3, -2.2340824000e-3, & + 1150.0, -6.0110851000, 1.5220147000e-3, -2.2324645000e-3, & + 1151.0, -6.0117512000, 1.5210696000e-3, -2.2308484000e-3, & + 1152.0, -6.0124152000, 1.5201250000e-3, -2.2292341000e-3, & + 1153.0, -6.0130771000, 1.5191811000e-3, -2.2276216000e-3, & + 1154.0, -6.0137369000, 1.5182377000e-3, -2.2260110000e-3, & + 1155.0, -6.0143946000, 1.5172949000e-3, -2.2244022000e-3, & + 1156.0, -6.0150502000, 1.5163527000e-3, -2.2227952000e-3, & + 1157.0, -6.0157038000, 1.5154112000e-3, -2.2211900000e-3, & + 1158.0, -6.0163553000, 1.5144702000e-3, -2.2195866000e-3, & + 1159.0, -6.0170048000, 1.5135298000e-3, -2.2179851000e-3, & + 1160.0, -6.0176522000, 1.5125900000e-3, -2.2163853000e-3, & + 1161.0, -6.0182976000, 1.5116508000e-3, -2.2147874000e-3, & + 1162.0, -6.0189409000, 1.5107122000e-3, -2.2131913000e-3, & + 1163.0, -6.0195822000, 1.5097742000e-3, -2.2115970000e-3, & + 1164.0, -6.0202215000, 1.5088369000e-3, -2.2100045000e-3, & + 1165.0, -6.0208588000, 1.5079001000e-3, -2.2084138000e-3, & + 1166.0, -6.0214940000, 1.5069639000e-3, -2.2068249000e-3, & + 1167.0, -6.0221273000, 1.5060283000e-3, -2.2052377000e-3, & + 1168.0, -6.0227585000, 1.5050934000e-3, -2.2036524000e-3, & + 1169.0, -6.0233877000, 1.5041590000e-3, -2.2020689000e-3, & + 1170.0, -6.0240150000, 1.5032253000e-3, -2.2004872000e-3, & + 1171.0, -6.0246402000, 1.5022921000e-3, -2.1989072000e-3, & + 1172.0, -6.0252635000, 1.5013596000e-3, -2.1973290000e-3, & + 1173.0, -6.0258848000, 1.5004276000e-3, -2.1957527000e-3, & + 1174.0, -6.0265042000, 1.4994963000e-3, -2.1941781000e-3, & + 1175.0, -6.0271215000, 1.4985656000e-3, -2.1926052000e-3, & + 1176.0, -6.0277369000, 1.4976355000e-3, -2.1910342000e-3, & + 1177.0, -6.0283504000, 1.4967060000e-3, -2.1894649000e-3, & + 1178.0, -6.0289619000, 1.4957771000e-3, -2.1878974000e-3, & + 1179.0, -6.0295715000, 1.4948489000e-3, -2.1863317000e-3, & + 1180.0, -6.0301791000, 1.4939212000e-3, -2.1847678000e-3, & + 1181.0, -6.0307848000, 1.4929942000e-3, -2.1832056000e-3, & + 1182.0, -6.0313886000, 1.4920677000e-3, -2.1816451000e-3, & + 1183.0, -6.0319905000, 1.4911419000e-3, -2.1800865000e-3, & + 1184.0, -6.0325904000, 1.4902167000e-3, -2.1785296000e-3, & + 1185.0, -6.0331885000, 1.4892921000e-3, -2.1769744000e-3, & + 1186.0, -6.0337846000, 1.4883682000e-3, -2.1754210000e-3, & + 1187.0, -6.0343789000, 1.4874448000e-3, -2.1738694000e-3, & + 1188.0, -6.0349712000, 1.4865221000e-3, -2.1723195000e-3, & + 1189.0, -6.0355617000, 1.4856000000e-3, -2.1707714000e-3, & + 1190.0, -6.0361503000, 1.4846785000e-3, -2.1692250000e-3, & + 1191.0, -6.0367370000, 1.4837576000e-3, -2.1676804000e-3, & + 1192.0, -6.0373218000, 1.4828373000e-3, -2.1661375000e-3, & + 1193.0, -6.0379048000, 1.4819177000e-3, -2.1645963000e-3, & + 1194.0, -6.0384859000, 1.4809986000e-3, -2.1630569000e-3, & + 1195.0, -6.0390651000, 1.4800802000e-3, -2.1615192000e-3, & + 1196.0, -6.0396426000, 1.4791625000e-3, -2.1599833000e-3, & + 1197.0, -6.0402181000, 1.4782453000e-3, -2.1584490000e-3, & + 1198.0, -6.0407919000, 1.4773288000e-3, -2.1569166000e-3, & + 1199.0, -6.0413638000, 1.4764129000e-3, -2.1553858000e-3, & + 1200.0, -6.0419338000, 1.4754976000e-3, -2.1538568000e-3, & + 1201.0, -6.0425021000, 1.4745829000e-3, -2.1523295000e-3, & + 1202.0, -6.0430685000, 1.4736689000e-3, -2.1508039000e-3, & + 1203.0, -6.0436331000, 1.4727555000e-3, -2.1492800000e-3, & + 1204.0, -6.0441959000, 1.4718427000e-3, -2.1477579000e-3, & + 1205.0, -6.0447570000, 1.4709305000e-3, -2.1462375000e-3, & + 1206.0, -6.0453162000, 1.4700190000e-3, -2.1447188000e-3, & + 1207.0, -6.0458736000, 1.4691081000e-3, -2.1432018000e-3, & + 1208.0, -6.0464292000, 1.4681978000e-3, -2.1416865000e-3, & + 1209.0, -6.0469831000, 1.4672882000e-3, -2.1401729000e-3, & + 1210.0, -6.0475352000, 1.4663791000e-3, -2.1386610000e-3, & + 1211.0, -6.0480855000, 1.4654707000e-3, -2.1371509000e-3, & + 1212.0, -6.0486341000, 1.4645630000e-3, -2.1356424000e-3, & + 1213.0, -6.0491809000, 1.4636558000e-3, -2.1341356000e-3, & + 1214.0, -6.0497259000, 1.4627493000e-3, -2.1326306000e-3, & + 1215.0, -6.0502692000, 1.4618435000e-3, -2.1311272000e-3, & + 1216.0, -6.0508107000, 1.4609382000e-3, -2.1296255000e-3, & + 1217.0, -6.0513505000, 1.4600336000e-3, -2.1281255000e-3, & + 1218.0, -6.0518886000, 1.4591297000e-3, -2.1266272000e-3, & + 1219.0, -6.0524250000, 1.4582263000e-3, -2.1251306000e-3, & + 1220.0, -6.0529596000, 1.4573236000e-3, -2.1236357000e-3, & + 1221.0, -6.0534925000, 1.4564215000e-3, -2.1221424000e-3, & + 1222.0, -6.0540237000, 1.4555201000e-3, -2.1206509000e-3, & + 1223.0, -6.0545531000, 1.4546193000e-3, -2.1191610000e-3, & + 1224.0, -6.0550809000, 1.4537191000e-3, -2.1176728000e-3, & + 1225.0, -6.0556070000, 1.4528196000e-3, -2.1161863000e-3, & + 1226.0, -6.0561314000, 1.4519207000e-3, -2.1147014000e-3, & + 1227.0, -6.0566541000, 1.4510224000e-3, -2.1132182000e-3, & + 1228.0, -6.0571751000, 1.4501248000e-3, -2.1117367000e-3, & + 1229.0, -6.0576944000, 1.4492278000e-3, -2.1102569000e-3, & + 1230.0, -6.0582120000, 1.4483315000e-3, -2.1087787000e-3, & + 1231.0, -6.0587280000, 1.4474358000e-3, -2.1073022000e-3, & + 1232.0, -6.0592424000, 1.4465407000e-3, -2.1058273000e-3, & + 1233.0, -6.0597550000, 1.4456463000e-3, -2.1043541000e-3, & + 1234.0, -6.0602660000, 1.4447525000e-3, -2.1028826000e-3, & + 1235.0, -6.0607754000, 1.4438593000e-3, -2.1014127000e-3, & + 1236.0, -6.0612831000, 1.4429668000e-3, -2.0999445000e-3, & + 1237.0, -6.0617892000, 1.4420750000e-3, -2.0984779000e-3, & + 1238.0, -6.0622936000, 1.4411837000e-3, -2.0970130000e-3, & + 1239.0, -6.0627964000, 1.4402931000e-3, -2.0955497000e-3, & + 1240.0, -6.0632976000, 1.4394032000e-3, -2.0940880000e-3, & + 1241.0, -6.0637972000, 1.4385139000e-3, -2.0926281000e-3, & + 1242.0, -6.0642951000, 1.4376252000e-3, -2.0911697000e-3, & + 1243.0, -6.0647914000, 1.4367372000e-3, -2.0897130000e-3, & + 1244.0, -6.0652862000, 1.4358498000e-3, -2.0882579000e-3, & + 1245.0, -6.0657793000, 1.4349631000e-3, -2.0868045000e-3, & + 1246.0, -6.0662708000, 1.4340770000e-3, -2.0853527000e-3, & + 1247.0, -6.0667608000, 1.4331916000e-3, -2.0839025000e-3, & + 1248.0, -6.0672491000, 1.4323068000e-3, -2.0824540000e-3, & + 1249.0, -6.0677359000, 1.4314226000e-3, -2.0810070000e-3, & + 1250.0, -6.0682211000, 1.4305391000e-3, -2.0795618000e-3, & + 1251.0, -6.0687047000, 1.4296562000e-3, -2.0781181000e-3, & + 1252.0, -6.0691867000, 1.4287740000e-3, -2.0766760000e-3, & + 1253.0, -6.0696672000, 1.4278925000e-3, -2.0752356000e-3, & + 1254.0, -6.0701462000, 1.4270115000e-3, -2.0737968000e-3, & + 1255.0, -6.0706235000, 1.4261312000e-3, -2.0723596000e-3, & + 1256.0, -6.0710993000, 1.4252516000e-3, -2.0709241000e-3, & + 1257.0, -6.0715736000, 1.4243726000e-3, -2.0694901000e-3, & + 1258.0, -6.0720464000, 1.4234943000e-3, -2.0680577000e-3, & + 1259.0, -6.0725175000, 1.4226166000e-3, -2.0666270000e-3, & + 1260.0, -6.0729872000, 1.4217396000e-3, -2.0651979000e-3, & + 1261.0, -6.0734554000, 1.4208632000e-3, -2.0637703000e-3, & + 1262.0, -6.0739220000, 1.4199874000e-3, -2.0623444000e-3, & + 1263.0, -6.0743871000, 1.4191123000e-3, -2.0609201000e-3, & + 1264.0, -6.0748507000, 1.4182379000e-3, -2.0594973000e-3, & + 1265.0, -6.0753127000, 1.4173641000e-3, -2.0580762000e-3, & + 1266.0, -6.0757733000, 1.4164910000e-3, -2.0566566000e-3, & + 1267.0, -6.0762324000, 1.4156185000e-3, -2.0552387000e-3, & + 1268.0, -6.0766899000, 1.4147466000e-3, -2.0538223000e-3, & + 1269.0, -6.0771460000, 1.4138754000e-3, -2.0524076000e-3, & + 1270.0, -6.0776006000, 1.4130049000e-3, -2.0509944000e-3, & + 1271.0, -6.0780537000, 1.4121350000e-3, -2.0495828000e-3, & + 1272.0, -6.0785054000, 1.4112658000e-3, -2.0481728000e-3, & + 1273.0, -6.0789555000, 1.4103972000e-3, -2.0467643000e-3, & + 1274.0, -6.0794042000, 1.4095293000e-3, -2.0453575000e-3, & + 1275.0, -6.0798515000, 1.4086620000e-3, -2.0439522000e-3, & + 1276.0, -6.0802972000, 1.4077954000e-3, -2.0425485000e-3, & + 1277.0, -6.0807415000, 1.4069294000e-3, -2.0411464000e-3, & + 1278.0, -6.0811844000, 1.4060641000e-3, -2.0397458000e-3, & + 1279.0, -6.0816258000, 1.4051994000e-3, -2.0383468000e-3, & + 1280.0, -6.0820658000, 1.4043354000e-3, -2.0369494000e-3, & + 1281.0, -6.0825043000, 1.4034720000e-3, -2.0355536000e-3, & + 1282.0, -6.0829414000, 1.4026093000e-3, -2.0341593000e-3, & + 1283.0, -6.0833771000, 1.4017473000e-3, -2.0327665000e-3, & + 1284.0, -6.0838114000, 1.4008859000e-3, -2.0313754000e-3, & + 1285.0, -6.0842442000, 1.4000251000e-3, -2.0299858000e-3, & + 1286.0, -6.0846756000, 1.3991650000e-3, -2.0285977000e-3, & + 1287.0, -6.0851056000, 1.3983056000e-3, -2.0272112000e-3, & + 1288.0, -6.0855342000, 1.3974468000e-3, -2.0258263000e-3, & + 1289.0, -6.0859614000, 1.3965887000e-3, -2.0244429000e-3, & + 1290.0, -6.0863871000, 1.3957312000e-3, -2.0230610000e-3, & + 1291.0, -6.0868115000, 1.3948744000e-3, -2.0216807000e-3, & + 1292.0, -6.0872345000, 1.3940183000e-3, -2.0203020000e-3, & + 1293.0, -6.0876561000, 1.3931628000e-3, -2.0189247000e-3, & + 1294.0, -6.0880764000, 1.3923079000e-3, -2.0175491000e-3, & + 1295.0, -6.0884952000, 1.3914537000e-3, -2.0161749000e-3, & + 1296.0, -6.0889127000, 1.3906002000e-3, -2.0148024000e-3, & + 1297.0, -6.0893288000, 1.3897473000e-3, -2.0134313000e-3, & + 1298.0, -6.0897435000, 1.3888951000e-3, -2.0120618000e-3, & + 1299.0, -6.0901569000, 1.3880436000e-3, -2.0106938000e-3, & + 1300.0, -6.0905689000, 1.3871927000e-3, -2.0093273000e-3, & + 1301.0, -6.0909796000, 1.3863424000e-3, -2.0079624000e-3, & + 1302.0, -6.0913889000, 1.3854928000e-3, -2.0065990000e-3, & + 1303.0, -6.0917969000, 1.3846439000e-3, -2.0052371000e-3, & + 1304.0, -6.0922035000, 1.3837956000e-3, -2.0038767000e-3, & + 1305.0, -6.0926088000, 1.3829480000e-3, -2.0025179000e-3, & + 1306.0, -6.0930127000, 1.3821011000e-3, -2.0011606000e-3, & + 1307.0, -6.0934154000, 1.3812548000e-3, -1.9998048000e-3, & + 1308.0, -6.0938167000, 1.3804091000e-3, -1.9984505000e-3, & + 1309.0, -6.0942166000, 1.3795642000e-3, -1.9970977000e-3, & + 1310.0, -6.0946153000, 1.3787199000e-3, -1.9957464000e-3, & + 1311.0, -6.0950127000, 1.3778762000e-3, -1.9943967000e-3, & + 1312.0, -6.0954087000, 1.3770332000e-3, -1.9930484000e-3, & + 1313.0, -6.0958034000, 1.3761909000e-3, -1.9917017000e-3, & + 1314.0, -6.0961969000, 1.3753492000e-3, -1.9903564000e-3, & + 1315.0, -6.0965890000, 1.3745082000e-3, -1.9890127000e-3, & + 1316.0, -6.0969798000, 1.3736678000e-3, -1.9876705000e-3, & + 1317.0, -6.0973694000, 1.3728281000e-3, -1.9863297000e-3, & + 1318.0, -6.0977577000, 1.3719890000e-3, -1.9849905000e-3, & + 1319.0, -6.0981446000, 1.3711507000e-3, -1.9836527000e-3, & + 1320.0, -6.0985303000, 1.3703129000e-3, -1.9823165000e-3, & + 1321.0, -6.0989148000, 1.3694759000e-3, -1.9809817000e-3, & + 1322.0, -6.0992979000, 1.3686395000e-3, -1.9796485000e-3, & + 1323.0, -6.0996798000, 1.3678037000e-3, -1.9783167000e-3, & + 1324.0, -6.1000605000, 1.3669686000e-3, -1.9769864000e-3, & + 1325.0, -6.1004399000, 1.3661342000e-3, -1.9756576000e-3, & + 1326.0, -6.1008180000, 1.3653005000e-3, -1.9743302000e-3, & + 1327.0, -6.1011948000, 1.3644674000e-3, -1.9730044000e-3, & + 1328.0, -6.1015705000, 1.3636349000e-3, -1.9716800000e-3, & + 1329.0, -6.1019449000, 1.3628031000e-3, -1.9703571000e-3, & + 1330.0, -6.1023180000, 1.3619720000e-3, -1.9690357000e-3, & + 1331.0, -6.1026899000, 1.3611416000e-3, -1.9677157000e-3, & + 1332.0, -6.1030606000, 1.3603118000e-3, -1.9663972000e-3, & + 1333.0, -6.1034300000, 1.3594826000e-3, -1.9650802000e-3, & + 1334.0, -6.1037983000, 1.3586541000e-3, -1.9637647000e-3, & + 1335.0, -6.1041653000, 1.3578263000e-3, -1.9624506000e-3, & + 1336.0, -6.1045311000, 1.3569992000e-3, -1.9611380000e-3, & + 1337.0, -6.1048956000, 1.3561727000e-3, -1.9598268000e-3, & + 1338.0, -6.1052590000, 1.3553468000e-3, -1.9585171000e-3, & + 1339.0, -6.1056212000, 1.3545217000e-3, -1.9572089000e-3, & + 1340.0, -6.1059821000, 1.3536972000e-3, -1.9559021000e-3, & + 1341.0, -6.1063419000, 1.3528733000e-3, -1.9545968000e-3, & + 1342.0, -6.1067005000, 1.3520501000e-3, -1.9532929000e-3, & + 1343.0, -6.1070578000, 1.3512276000e-3, -1.9519905000e-3, & + 1344.0, -6.1074140000, 1.3504057000e-3, -1.9506896000e-3, & + 1345.0, -6.1077690000, 1.3495845000e-3, -1.9493900000e-3, & + 1346.0, -6.1081229000, 1.3487640000e-3, -1.9480920000e-3, & + 1347.0, -6.1084755000, 1.3479441000e-3, -1.9467953000e-3, & + 1348.0, -6.1088270000, 1.3471249000e-3, -1.9455001000e-3, & + 1349.0, -6.1091773000, 1.3463063000e-3, -1.9442064000e-3, & + 1350.0, -6.1095265000, 1.3454884000e-3, -1.9429141000e-3, & + 1351.0, -6.1098744000, 1.3446712000e-3, -1.9416232000e-3, & + 1352.0, -6.1102213000, 1.3438546000e-3, -1.9403338000e-3, & + 1353.0, -6.1105669000, 1.3430387000e-3, -1.9390458000e-3, & + 1354.0, -6.1109115000, 1.3422234000e-3, -1.9377592000e-3, & + 1355.0, -6.1112548000, 1.3414088000e-3, -1.9364741000e-3, & + 1356.0, -6.1115971000, 1.3405949000e-3, -1.9351903000e-3, & + 1357.0, -6.1119382000, 1.3397816000e-3, -1.9339081000e-3, & + 1358.0, -6.1122781000, 1.3389690000e-3, -1.9326272000e-3, & + 1359.0, -6.1126170000, 1.3381571000e-3, -1.9313478000e-3, & + 1360.0, -6.1129546000, 1.3373458000e-3, -1.9300697000e-3, & + 1361.0, -6.1132912000, 1.3365352000e-3, -1.9287931000e-3, & + 1362.0, -6.1136267000, 1.3357252000e-3, -1.9275180000e-3, & + 1363.0, -6.1139610000, 1.3349159000e-3, -1.9262442000e-3, & + 1364.0, -6.1142942000, 1.3341073000e-3, -1.9249718000e-3, & + 1365.0, -6.1146263000, 1.3332993000e-3, -1.9237009000e-3, & + 1366.0, -6.1149573000, 1.3324920000e-3, -1.9224314000e-3, & + 1367.0, -6.1152872000, 1.3316853000e-3, -1.9211632000e-3, & + 1368.0, -6.1156160000, 1.3308793000e-3, -1.9198965000e-3, & + 1369.0, -6.1159437000, 1.3300740000e-3, -1.9186312000e-3, & + 1370.0, -6.1162702000, 1.3292693000e-3, -1.9173673000e-3, & + 1371.0, -6.1165957000, 1.3284653000e-3, -1.9161048000e-3, & + 1372.0, -6.1169202000, 1.3276619000e-3, -1.9148437000e-3, & + 1373.0, -6.1172435000, 1.3268592000e-3, -1.9135840000e-3, & + 1374.0, -6.1175657000, 1.3260572000e-3, -1.9123257000e-3, & + 1375.0, -6.1178869000, 1.3252558000e-3, -1.9110688000e-3, & + 1376.0, -6.1182070000, 1.3244551000e-3, -1.9098133000e-3, & + 1377.0, -6.1185260000, 1.3236551000e-3, -1.9085591000e-3, & + 1378.0, -6.1188440000, 1.3228557000e-3, -1.9073064000e-3, & + 1379.0, -6.1191609000, 1.3220569000e-3, -1.9060550000e-3, & + 1380.0, -6.1194767000, 1.3212589000e-3, -1.9048051000e-3, & + 1381.0, -6.1197915000, 1.3204614000e-3, -1.9035565000e-3, & + 1382.0, -6.1201052000, 1.3196647000e-3, -1.9023093000e-3, & + 1383.0, -6.1204179000, 1.3188686000e-3, -1.9010635000e-3, & + 1384.0, -6.1207295000, 1.3180732000e-3, -1.8998190000e-3, & + 1385.0, -6.1210401000, 1.3172784000e-3, -1.8985760000e-3, & + 1386.0, -6.1213496000, 1.3164843000e-3, -1.8973343000e-3, & + 1387.0, -6.1216581000, 1.3156908000e-3, -1.8960940000e-3, & + 1388.0, -6.1219656000, 1.3148980000e-3, -1.8948550000e-3, & + 1389.0, -6.1222720000, 1.3141059000e-3, -1.8936175000e-3, & + 1390.0, -6.1225774000, 1.3133144000e-3, -1.8923813000e-3, & + 1391.0, -6.1228818000, 1.3125236000e-3, -1.8911464000e-3, & + 1392.0, -6.1231851000, 1.3117334000e-3, -1.8899130000e-3, & + 1393.0, -6.1234875000, 1.3109439000e-3, -1.8886809000e-3, & + 1394.0, -6.1237888000, 1.3101551000e-3, -1.8874501000e-3, & + 1395.0, -6.1240891000, 1.3093669000e-3, -1.8862207000e-3, & + 1396.0, -6.1243884000, 1.3085794000e-3, -1.8849927000e-3, & + 1397.0, -6.1246867000, 1.3077925000e-3, -1.8837660000e-3, & + 1398.0, -6.1249840000, 1.3070063000e-3, -1.8825407000e-3, & + 1399.0, -6.1252803000, 1.3062208000e-3, -1.8813168000e-3, & + 1400.0, -6.1255756000, 1.3054359000e-3, -1.8800942000e-3, & + 1401.0, -6.1258699000, 1.3046517000e-3, -1.8788729000e-3, & + 1402.0, -6.1261632000, 1.3038681000e-3, -1.8776530000e-3, & + 1403.0, -6.1264555000, 1.3030852000e-3, -1.8764345000e-3, & + 1404.0, -6.1267469000, 1.3023029000e-3, -1.8752172000e-3, & + 1405.0, -6.1270372000, 1.3015213000e-3, -1.8740014000e-3, & + 1406.0, -6.1273266000, 1.3007404000e-3, -1.8727868000e-3, & + 1407.0, -6.1276150000, 1.2999601000e-3, -1.8715736000e-3, & + 1408.0, -6.1279024000, 1.2991804000e-3, -1.8703618000e-3, & + 1409.0, -6.1281889000, 1.2984015000e-3, -1.8691513000e-3, & + 1410.0, -6.1284744000, 1.2976231000e-3, -1.8679421000e-3, & + 1411.0, -6.1287590000, 1.2968455000e-3, -1.8667343000e-3, & + 1412.0, -6.1290425000, 1.2960685000e-3, -1.8655277000e-3, & + 1413.0, -6.1293252000, 1.2952921000e-3, -1.8643226000e-3, & + 1414.0, -6.1296068000, 1.2945164000e-3, -1.8631187000e-3, & + 1415.0, -6.1298876000, 1.2937414000e-3, -1.8619162000e-3, & + 1416.0, -6.1301673000, 1.2929670000e-3, -1.8607150000e-3, & + 1417.0, -6.1304462000, 1.2921933000e-3, -1.8595151000e-3, & + 1418.0, -6.1307241000, 1.2914202000e-3, -1.8583165000e-3, & + 1419.0, -6.1310010000, 1.2906478000e-3, -1.8571193000e-3, & + 1420.0, -6.1312770000, 1.2898761000e-3, -1.8559234000e-3, & + 1421.0, -6.1315521000, 1.2891050000e-3, -1.8547288000e-3, & + 1422.0, -6.1318263000, 1.2883345000e-3, -1.8535355000e-3, & + 1423.0, -6.1320995000, 1.2875647000e-3, -1.8523435000e-3, & + 1424.0, -6.1323718000, 1.2867956000e-3, -1.8511528000e-3, & + 1425.0, -6.1326432000, 1.2860271000e-3, -1.8499635000e-3, & + 1426.0, -6.1329136000, 1.2852592000e-3, -1.8487754000e-3, & + 1427.0, -6.1331832000, 1.2844921000e-3, -1.8475887000e-3, & + 1428.0, -6.1334518000, 1.2837255000e-3, -1.8464033000e-3, & + 1429.0, -6.1337196000, 1.2829597000e-3, -1.8452191000e-3, & + 1430.0, -6.1339864000, 1.2821945000e-3, -1.8440363000e-3, & + 1431.0, -6.1342523000, 1.2814299000e-3, -1.8428548000e-3, & + 1432.0, -6.1345173000, 1.2806660000e-3, -1.8416745000e-3, & + 1433.0, -6.1347815000, 1.2799027000e-3, -1.8404956000e-3, & + 1434.0, -6.1350447000, 1.2791401000e-3, -1.8393180000e-3, & + 1435.0, -6.1353070000, 1.2783782000e-3, -1.8381416000e-3, & + 1436.0, -6.1355685000, 1.2776168000e-3, -1.8369666000e-3, & + 1437.0, -6.1358290000, 1.2768562000e-3, -1.8357928000e-3, & + 1438.0, -6.1360887000, 1.2760962000e-3, -1.8346203000e-3, & + 1439.0, -6.1363475000, 1.2753368000e-3, -1.8334492000e-3, & + 1440.0, -6.1366054000, 1.2745781000e-3, -1.8322792000e-3 & + /), (/4, lmax+1/)) !< Load Love numbers + +!> \namespace mom_load_love_numbers +!! This module serves the sole purpose of storing load Love number. The Love numbers are used for the spherical harmonic +!! self-attraction and loading (SAL) calculation in MOM_self_attr_load module. This separate module ensures readability +!! of the SAL module. +!! +!! Variable Love_Data stores the Love numbers up to degree 1440. From left to right: degree, h, l, and k. Data in this +!! module is imported from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los Alamos +!! National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2022)]. The load Love numbers +!! are from Wang et al. (2012), which are in the center of mass of total Earth system reference frame (CM). When used, +!! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) [Blewitt (2003)], +!! as in subroutine calc_love_scaling in MOM_tidal_forcing module. +!! +!! References: +!! +!! Barton, K.N., Pal, N., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J.J., +!! Wirasaet, D. and Schindelegger, M., 2022. Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in +!! MPAS‐Ocean. Journal of Advances in Modeling Earth Systems, 14(11), p.e2022MS003207. +!! https://doi.org/10.1029/2022MS003207 +!! +!! Blewitt, G., 2003. Self‐consistency in reference frames, geocenter definition, and surface loading of the solid +!! Earth. Journal of geophysical research: solid earth, 108(B2). +!! https://doi.org/10.1029/2002JB002082 +!! +!! Brus, S.R., Barton, K.N., Pal, N., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., +!! Westerink, J.J. and Schindelegger, M., 2023. Scalable self attraction and loading calculations for unstructured ocean +!! tide models. Ocean Modelling, p.102160. +!! https://doi.org/10.1016/j.ocemod.2023.102160 +!! +!! Wang, H., Xiang, L., Jia, L., Jiang, L., Wang, Z., Hu, B. and Gao, P., 2012. Load Love numbers and Green's functions +!! for elastic Earth models PREM, iasp91, ak135, and modified models with refined crustal structure from Crust 2.0. +!! Computers & Geosciences, 49, pp.190-199. +!! https://doi.org/10.1016/j.cageo.2012.06.022 +end module MOM_load_love_numbers \ No newline at end of file diff --git a/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/parameterizations/lateral/MOM_mixed_layer_restrat.F90 new file mode 100644 index 0000000000..057943a788 --- /dev/null +++ b/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -0,0 +1,2128 @@ +!> \brief Parameterization of mixed layer restratification by unresolved mixed-layer eddies. +module MOM_mixed_layer_restrat + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : hchksum +use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type +use MOM_diag_mediator, only : diag_update_remap_grids +use MOM_domains, only : pass_var, To_West, To_South, Omit_Corners +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_forcing_type, only : mech_forcing, find_ustar +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_intrinsic_functions, only : cuberoot +use MOM_lateral_mixing_coeffs, only : VarMix_CS +use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units +use MOM_EOS, only : calculate_density, calculate_spec_vol, EOS_domain + +implicit none ; private + +#include + +public mixedlayer_restrat +public mixedlayer_restrat_init +public mixedlayer_restrat_register_restarts +public mixedlayer_restrat_unit_tests + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure for mom_mixed_layer_restrat +type, public :: mixedlayer_restrat_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + real :: ml_restrat_coef !< A non-dimensional factor by which the instability is enhanced + !! over what would be predicted based on the resolved gradients + !! [nondim]. This increases with grid spacing^2, up to something + !! of order 500. + real :: ml_restrat_coef2 !< As for ml_restrat_coef but using the slow filtered MLD [nondim]. + real :: front_length !< If non-zero, is the frontal-length scale [L ~> m] used to calculate the + !! upscaling of buoyancy gradients that is otherwise represented + !! by the parameter FOX_KEMPER_ML_RESTRAT_COEF. If MLE_FRONT_LENGTH is + !! non-zero, it is recommended to set FOX_KEMPER_ML_RESTRAT_COEF=1.0. + logical :: MLE_use_PBL_MLD !< If true, use the MLD provided by the PBL parameterization. + !! if false, MLE will calculate a MLD based on a density difference + !! based on the parameter MLE_DENSITY_DIFF. + real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] + real :: MLE_MLD_decay_time !< Time-scale to use in a running-mean when MLD is retreating [T ~> s]. + real :: MLE_MLD_decay_time2 !< Time-scale to use in a running-mean when filtered MLD is retreating [T ~> s]. + real :: MLE_density_diff !< Density difference used in detecting mixed-layer depth [R ~> kg m-3]. + real :: MLE_tail_dh !< Fraction by which to extend the mixed-layer restratification + !! depth used for a smoother stream function at the base of + !! the mixed-layer [nondim]. + real :: MLE_MLD_stretch !< A scaling coefficient for stretching/shrinking the MLD used in + !! the MLE scheme [nondim]. This simply multiplies MLD wherever used. + + ! The following parameters are used in the Bodner et al., 2023, parameterization + logical :: use_Bodner = .false. !< If true, use the Bodner et al., 2023, parameterization. + real :: Cr !< Efficiency coefficient from Bodner et al., 2023 [nondim] + real :: mstar !< The m* value used to estimate the turbulent vertical momentum flux [nondim] + real :: nstar !< The n* value used to estimate the turbulent vertical momentum flux [nondim] + real :: min_wstar2 !< The minimum lower bound to apply to the vertical momentum flux, + !! w'u', in the Bodner et al., restratification parameterization + !! [Z2 T-2 ~> m2 s-2]. This avoids a division-by-zero in the limit when u* + !! and the buoyancy flux are zero. + real :: BLD_growing_Tfilt !< The time-scale for a running-mean filter applied to the boundary layer + !! depth (BLD) when the BLD is deeper than the running mean [T ~> s]. + !! A value of 0 instantaneously sets the running mean to the current value of BLD. + real :: BLD_decaying_Tfilt !< The time-scale for a running-mean filter applied to the boundary layer + !! depth (BLD) when the BLD is shallower than the running mean [T ~> s]. + !! A value of 0 instantaneously sets the running mean to the current value of BLD. + real :: MLD_decaying_Tfilt !< The time-scale for a running-mean filter applied to the time-filtered + !! MLD, when the latter is shallower than the running mean [T ~> s]. + !! A value of 0 instantaneously sets the running mean to the current value of MLD. + real :: MLD_growing_Tfilt !< The time-scale for a running-mean filter applied to the time-filtered + !! MLD, when the latter is deeper than the running mean [T ~> s]. + !! A value of 0 instantaneously sets the running mean to the current value of MLD. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the + !! mixed layer restrat calculations. Values below 20240201 recover + !! the answers from the end of 2023, while higher values use the new + !! cuberoot function in the Bodner code to avoid needing to undo + !! dimensional rescaling. + + logical :: debug = .false. !< If true, calculate checksums of fields for debugging. + + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. + logical :: use_Stanley_ML !< If true, use the Stanley parameterization of SGS T variance + real :: ustar_min !< A minimum value of ustar in thickness units to avoid numerical + !! problems [H T-1 ~> m s-1 or kg m-2 s-1] + real :: Kv_restrat !< A viscosity that sets a floor on the momentum mixing rate + !! during restratification, rescaled into thickness-based + !! units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] + + real, dimension(:,:), allocatable :: & + MLD_filtered, & !< Time-filtered MLD [H ~> m or kg m-2] + MLD_filtered_slow, & !< Slower time-filtered MLD [H ~> m or kg m-2] + wpup_filtered !< Time-filtered vertical momentum flux [H L T-2 ~> m2 s-2 or kg m-1 s-2] + + !>@{ + !! Diagnostic identifier + integer :: id_urestrat_time = -1 + integer :: id_vrestrat_time = -1 + integer :: id_uhml = -1 + integer :: id_vhml = -1 + integer :: id_MLD = -1 + integer :: id_BLD = -1 + integer :: id_Rml = -1 + integer :: id_uDml = -1 + integer :: id_vDml = -1 + integer :: id_uml = -1 + integer :: id_vml = -1 + integer :: id_wpup = -1 + integer :: id_ustar = -1 + integer :: id_bflux = -1 + integer :: id_lfbod = -1 + !>@} + +end type mixedlayer_restrat_CS + +character(len=40) :: mdl = "MOM_mixed_layer_restrat" !< This module's name. + +contains + +!> Driver for the mixed-layer restratification parameterization. +!! The code branches between two different implementations depending +!! on whether the bulk-mixed layer or a general coordinate are in use. +subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, bflux, VarMix, G, GV, US, CS) + type(ocean_grid_type), intent(inout) :: 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(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [H L2 ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + real, dimension(:,:), pointer :: MLD !< Mixed layer depth provided by the + !! planetary boundary layer scheme [Z ~> m] + real, dimension(:,:), pointer :: bflux !< Surface buoyancy flux provided by the + !! PBL scheme [Z2 T-3 ~> m2 s-3] + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control structure + type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + + if (.not. CS%initialized) call MOM_error(FATAL, "mixedlayer_restrat: "// & + "Module must be initialized before it is used.") + + if (GV%nkml>0) then + ! Original form, written for the isopycnal model with a bulk mixed layer + call mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) + elseif (CS%use_Bodner) then + ! Implementation of Bodner et al., 2023 + call mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, MLD, bflux) + else + ! Implementation of Fox-Kemper et al., 2008, to work in general coordinates + call mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, US, CS) + endif + +end subroutine mixedlayer_restrat + +!> Calculates a restratifying flow in the mixed layer, following the formulation used in OM4 +subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, G, GV, US, CS) + ! Arguments + type(ocean_grid_type), intent(inout) :: 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(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [H L2 ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by the + !! PBL scheme [Z ~> m] + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control structure + type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + + ! Local variables + real :: uhml(SZIB_(G),SZJ_(G),SZK_(GV)) ! Restratifying zonal thickness transports [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vhml(SZI_(G),SZJB_(G),SZK_(GV)) ! Restratifying meridional thickness transports [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + h_avail ! The volume available for diffusion out of each face of each + ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: & + U_star_2d, & ! The wind friction velocity in thickness-based units, calculated using + ! the Boussinesq reference density or the time-evolving surface density + ! in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] + MLD_fast, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] + htot_fast, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] + Rml_av_fast, & ! Negative g_Rho0 times the average mixed layer density or G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + MLD_slow, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] + htot_slow, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] + Rml_av_slow ! Negative g_Rho0 times the average mixed layer density or G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor + ! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2] + real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + real :: rml_int_fast(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-3] + real :: rml_int_slow(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-3] + real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] + real :: SpV_int_fast(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] + real :: SpV_int_slow(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] + real :: H_mld(SZI_(G)) ! The thickness of water within the topmost MLD_in of height [H ~> m or kg m-2] + real :: MLD_rem(SZI_(G)) ! The vertical extent of the MLD_in that has not yet been accounted for [Z ~> m] + real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] + + real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] + real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] + real :: u_star ! surface friction velocity, interpolated to velocity points and recast into + ! thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] + real :: timescale ! mixing growth timescale [T ~> s] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. + real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] + real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] + real :: Ihtot,Ihtot_slow! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux + ! magnitudes (uDml & vDml) to the realized flux in a + ! layer [nondim]. The vertical sum of a() through the pieces of + ! the mixed layer must be 0. + real :: b(SZK_(GV)) ! As for a(k) but for the slow-filtered MLD [nondim] + real :: uDml(SZIB_(G)) ! Zonal volume fluxes in the upper half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml(SZI_(G)) ! Meridional volume fluxes in the upper half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: uDml_slow(SZIB_(G)) ! Zonal volume fluxes in the upper half of the boundary layer to + ! restratify the time-filtered boundary layer depth [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_slow(SZI_(G)) ! Meridional volume fluxes in the upper half of the boundary layer to + ! restratify the time-filtered boundary layer depth [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! Zonal restratification timescale [T ~> s], stored for diagnostics. + real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! Meridional restratification timescale [T ~> s], stored for diagnostics. + real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK ! Densities and density differences [R ~> kg m-3] + real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. + real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer + ! densities [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G)) :: covTS, & ! SGS TS covariance in Stanley param; currently 0 [C S ~> degC ppt] + varS ! SGS S variance in Stanley param; currently 0 [S2 ~> ppt2] + real :: aFac, bFac ! Nondimensional ratios [nondim] + real :: ddRho ! A density difference [R ~> kg m-3] + real :: hAtVel ! Thickness at the velocity points [H ~> m or kg m-2] + real :: zpa ! Fractional position within the mixed layer of the interface above a layer [nondim] + real :: zpb ! Fractional position within the mixed layer of the interface below a layer [nondim] + real :: dh ! Portion of the layer thickness that is in the mixed layer [H ~> m or kg m-2] + real :: res_scaling_fac ! The resolution-dependent scaling factor [nondim] + real :: I_LFront ! The inverse of the frontal length scale [L-1 ~> m-1] + real :: vonKar_x_pi2 ! A scaling constant that is approximately the von Karman constant times + ! pi squared [nondim] + logical :: line_is_empty, keep_going, res_upscale + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + h_min = 0.5*GV%Angstrom_H ! This should be GV%Angstrom_H, but that value would change answers. + covTS(:) = 0.0 !!Functionality not implemented yet; in future, should be passed in tv + varS(:) = 0.0 + + vonKar_x_pi2 = CS%vonKar * 9.8696 + + if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & + "An equation of state must be used with this module.") + if (.not. allocated(VarMix%Rd_dx_h) .and. CS%front_length > 0.) & + call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & + "The resolution argument, Rd/dx, was not associated.") + if (CS%use_Stanley_ML .and. .not.GV%Boussinesq) call MOM_error(FATAL, & + "MOM_mixedlayer_restrat: The Stanley parameterization is not"//& + "available without the Boussinesq approximation.") + + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1, H_T_units=.true.) + + if (CS%MLE_density_diff > 0.) then ! We need to calculate a mixed layer depth, MLD. + !! TODO: use derivatives and mid-MLD pressure. Currently this is sigma-0. -AJA + pRef_MLD(:) = 0. + EOSdom(:) = EOS_domain(G%HI, halo=1) + do j=js-1,je+1 + dK(:) = 0.5 * h(:,j,1) ! Depth of center of surface layer + if (CS%use_Stanley_ML) then + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, tv%varT(:,j,1), covTS, varS, & + rhoSurf, tv%eqn_of_state, EOSdom) + else + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) + endif + deltaRhoAtK(:) = 0. + MLD_fast(:,j) = 0. + do k=2,nz + dKm1(:) = dK(:) ! Depth of center of layer K-1 + dK(:) = dK(:) + 0.5 * ( h(:,j,k) + h(:,j,k-1) ) ! Depth of center of layer K + ! Mixed-layer depth, using sigma-0 (surface reference pressure) + deltaRhoAtKm1(:) = deltaRhoAtK(:) ! Store value from previous iteration of K + if (CS%use_Stanley_ML) then + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, tv%varT(:,j,k), covTS, varS, & + deltaRhoAtK, tv%eqn_of_state, EOSdom) + else + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) + endif + do i=is-1,ie+1 + deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface + enddo + do i=is-1,ie+1 + ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) + if ((MLD_fast(i,j)==0.) .and. (ddRho>0.) .and. & + (deltaRhoAtKm1(i)=CS%MLE_density_diff)) then + aFac = ( CS%MLE_density_diff - deltaRhoAtKm1(i) ) / ddRho + MLD_fast(i,j) = dK(i) * aFac + dKm1(i) * (1. - aFac) + endif + enddo ! i-loop + enddo ! k-loop + do i=is-1,ie+1 + MLD_fast(i,j) = CS%MLE_MLD_stretch * MLD_fast(i,j) + if ((MLD_fast(i,j)==0.) .and. (deltaRhoAtK(i) 0.0) then + if (MLD_rem(i) > GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)) then + H_mld(i) = H_mld(i) + h(i,j,k) + MLD_rem(i) = MLD_rem(i) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + keep_going = .true. + else + H_mld(i) = H_mld(i) + GV%RZ_to_H * MLD_rem(i) / tv%SpV_avg(i,j,k) + MLD_rem(i) = 0.0 + endif + endif ; enddo + if (.not.keep_going) exit + enddo + do i=is-1,ie+1 ; MLD_fast(i,j) = CS%MLE_MLD_stretch * H_mld(i) ; enddo + enddo + endif + else + call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & + "No MLD to use for MLE parameterization.") + endif + + ! Apply time filter (to remove diurnal cycle) + if (CS%MLE_MLD_decay_time>0.) then + if (CS%debug) then + call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(MLD_in, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, scale=US%Z_to_m) + endif + aFac = CS%MLE_MLD_decay_time / ( dt + CS%MLE_MLD_decay_time ) + bFac = dt / ( dt + CS%MLE_MLD_decay_time ) + do j=js-1,je+1 ; do i=is-1,ie+1 + ! Expression bFac*MLD_fast(i,j) + aFac*CS%MLD_filtered(i,j) is the time-filtered + ! (running mean) of MLD. The max() allows the "running mean" to be reset + ! instantly to a deeper MLD. + CS%MLD_filtered(i,j) = max( MLD_fast(i,j), bFac*MLD_fast(i,j) + aFac*CS%MLD_filtered(i,j) ) + MLD_fast(i,j) = CS%MLD_filtered(i,j) + enddo ; enddo + endif + + ! Apply slower time filter (to remove seasonal cycle) on already filtered MLD_fast + if (CS%MLE_MLD_decay_time2>0.) then + if (CS%debug) then + call hchksum(CS%MLD_filtered_slow, 'mixed_layer_restrat: MLD_filtered_slow', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(MLD_fast, 'mixed_layer_restrat: MLD fast', G%HI, haloshift=1, scale=GV%H_to_mks) + endif + aFac = CS%MLE_MLD_decay_time2 / ( dt + CS%MLE_MLD_decay_time2 ) + bFac = dt / ( dt + CS%MLE_MLD_decay_time2 ) + do j=js-1,je+1 ; do i=is-1,ie+1 + ! Expression bFac*MLD_fast(i,j) + aFac*CS%MLD_filtered(i,j) is the time-filtered + ! (running mean) of MLD. The max() allows the "running mean" to be reset + ! instantly to a deeper MLD. + CS%MLD_filtered_slow(i,j) = max( MLD_fast(i,j), bFac*MLD_fast(i,j) + aFac*CS%MLD_filtered_slow(i,j) ) + MLD_slow(i,j) = CS%MLD_filtered_slow(i,j) + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + MLD_slow(i,j) = MLD_fast(i,j) + enddo ; enddo + endif + + uDml(:) = 0.0 ; vDml(:) = 0.0 + uDml_slow(:) = 0.0 ; vDml_slow(:) = 0.0 + I4dt = 0.25 / dt + g_Rho0 = GV%H_to_Z * GV%g_Earth / GV%Rho0 + h_neglect = GV%H_subroundoff + if (CS%front_length>0.) then + res_upscale = .true. + I_LFront = 1. / CS%front_length + else + res_upscale = .false. + endif + + p0(:) = 0.0 + EOSdom(:) = EOS_domain(G%HI, halo=1) + !$OMP parallel default(shared) private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & + !$OMP SpV_ml,SpV_int_fast,SpV_int_slow,Rml_int_fast,Rml_int_slow, & + !$OMP line_is_empty,keep_going,res_scaling_fac, & + !$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & + !$OMP firstprivate(uDml,vDml,uDml_slow,vDml_slow) + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot_fast(i,j) = 0.0 ; Rml_int_fast(i) = 0.0 + htot_slow(i,j) = 0.0 ; Rml_int_slow(i) = 0.0 + enddo + keep_going = .true. + do k=1,nz + do i=is-1,ie+1 + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + if (keep_going) then + if (CS%use_Stanley_ML) then + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & + rho_ml(:), tv%eqn_of_state, EOSdom) + else + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), tv%eqn_of_state, EOSdom) + endif + line_is_empty = .true. + do i=is-1,ie+1 + if (htot_fast(i,j) < MLD_fast(i,j)) then + dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) + Rml_int_fast(i) = Rml_int_fast(i) + dh*rho_ml(i) + htot_fast(i,j) = htot_fast(i,j) + dh + line_is_empty = .false. + endif + if (htot_slow(i,j) < MLD_slow(i,j)) then + dh = min( h(i,j,k), MLD_slow(i,j)-htot_slow(i,j) ) + Rml_int_slow(i) = Rml_int_slow(i) + dh*rho_ml(i) + htot_slow(i,j) = htot_slow(i,j) + dh + line_is_empty = .false. + endif + enddo + if (line_is_empty) keep_going=.false. + endif + enddo + + do i=is-1,ie+1 + Rml_av_fast(i,j) = -(g_Rho0*Rml_int_fast(i)) / (htot_fast(i,j) + h_neglect) + Rml_av_slow(i,j) = -(g_Rho0*Rml_int_slow(i)) / (htot_slow(i,j) + h_neglect) + enddo + enddo + else ! This is only used in non-Boussinesq mode. + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot_fast(i,j) = 0.0 ; SpV_int_fast(i) = 0.0 + htot_slow(i,j) = 0.0 ; SpV_int_slow(i) = 0.0 + enddo + keep_going = .true. + do k=1,nz + do i=is-1,ie+1 + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + if (keep_going) then + ! if (CS%use_Stanley_ML) then ! This is not implemented yet in the EoS code. + ! call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & + ! rho_ml(:), tv%eqn_of_state, EOSdom) + ! else + call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, SpV_ml, tv%eqn_of_state, EOSdom) + ! endif + line_is_empty = .true. + do i=is-1,ie+1 + if (htot_fast(i,j) < MLD_fast(i,j)) then + dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) + SpV_int_fast(i) = SpV_int_fast(i) + dh*SpV_ml(i) + htot_fast(i,j) = htot_fast(i,j) + dh + line_is_empty = .false. + endif + if (htot_slow(i,j) < MLD_slow(i,j)) then + dh = min( h(i,j,k), MLD_slow(i,j)-htot_slow(i,j) ) + SpV_int_slow(i) = SpV_int_slow(i) + dh*SpV_ml(i) + htot_slow(i,j) = htot_slow(i,j) + dh + line_is_empty = .false. + endif + enddo + if (line_is_empty) keep_going=.false. + endif + enddo + + ! Convert the vertically integrated specific volume into a positive variable with units of density. + do i=is-1,ie+1 + Rml_av_fast(i,j) = (GV%H_to_RZ*GV%g_Earth * SpV_int_fast(i)) / (htot_fast(i,j) + h_neglect) + Rml_av_slow(i,j) = (GV%H_to_RZ*GV%g_Earth * SpV_int_slow(i)) / (htot_slow(i,j) + h_neglect) + enddo + enddo + endif + + if (CS%debug) then + call hchksum(h, 'mixed_layer_restrat: h', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(U_star_2d, 'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=GV%H_to_m*US%s_to_T) + call hchksum(MLD_fast, 'mixed_layer_restrat: MLD', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(Rml_av_fast, 'mixed_layer_restrat: rml', G%HI, haloshift=1, & + scale=GV%m_to_H*US%L_T_to_m_s**2) + endif + +! TO DO: +! 1. Mixing extends below the mixing layer to the mixed layer. Find it! +! 2. Add exponential tail to stream-function? + +! U - Component + !$OMP do + do j=js,je ; do I=is-1,ie + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) + + absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + ! If needed, res_scaling_fac = min( ds, L_d ) / l_f + if (res_upscale) res_scaling_fac = & + ( sqrt( 0.5 * ( G%dxCu(I,j)**2 + G%dyCu(I,j)**2 ) ) * I_LFront ) & + * min( 1., 0.5*( VarMix%Rd_dx_h(i,j) + VarMix%Rd_dx_h(i+1,j) ) ) + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 + h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + timescale = timescale * CS%ml_restrat_coef + + if (res_upscale) timescale = timescale * res_scaling_fac + uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & + (Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2) + + ! As above but using the slow filtered MLD + h_vel = 0.5*((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + timescale = timescale * CS%ml_restrat_coef2 + + if (res_upscale) timescale = timescale * res_scaling_fac + uDml_slow(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & + (Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2) + + if (uDml(I) + uDml_slow(I) == 0.) then + do k=1,nz ; uhml(I,j,k) = 0.0 ; enddo + else + IhTot = 2.0 / ((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) + IhTot_slow = 2.0 / ((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) + zpa = 0.0 ; zpb = 0.0 + ! a(k) relates the sublayer transport to uDml with a linear profile. + ! The sum of a(k) through the mixed layers must be 0. + do k=1,nz + hAtVel = 0.5*(h(i,j,k) + h(i+1,j,k)) + a(k) = mu(zpa, CS%MLE_tail_dh) ! mu(z/MLD) for upper interface + zpa = zpa - (hAtVel * IhTot) ! z/H for lower interface + a(k) = a(k) - mu(zpa, CS%MLE_tail_dh) ! Transport profile + ! Limit magnitude (uDml) if it would violate CFL + if (a(k)*uDml(I) > 0.0) then + if (a(k)*uDml(I) > h_avail(i,j,k)) uDml(I) = h_avail(i,j,k) / a(k) + elseif (a(k)*uDml(I) < 0.0) then + if (-a(k)*uDml(I) > h_avail(i+1,j,k)) uDml(I) = -h_avail(i+1,j,k) / a(k) + endif + enddo + do k=1,nz + ! Transport for slow-filtered MLD + hAtVel = 0.5*(h(i,j,k) + h(i+1,j,k)) + b(k) = mu(zpb, CS%MLE_tail_dh) ! mu(z/MLD) for upper interface + zpb = zpb - (hAtVel * IhTot_slow) ! z/H for lower interface + b(k) = b(k) - mu(zpb, CS%MLE_tail_dh) ! Transport profile + ! Limit magnitude (uDml_slow) if it would violate CFL when added to uDml + if (b(k)*uDml_slow(I) > 0.0) then + if (b(k)*uDml_slow(I) > h_avail(i,j,k) - a(k)*uDml(I)) & + uDml_slow(I) = max( 0., h_avail(i,j,k) - a(k)*uDml(I) ) / b(k) + elseif (b(k)*uDml_slow(I) < 0.0) then + if (-b(k)*uDml_slow(I) > h_avail(i+1,j,k) + a(k)*uDml(I)) & + uDml_slow(I) = -max( 0., h_avail(i+1,j,k) + a(k)*uDml(I) ) / b(k) + endif + enddo + do k=1,nz + uhml(I,j,k) = a(k)*uDml(I) + b(k)*uDml_slow(I) + uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k)*dt + enddo + endif + + utimescale_diag(I,j) = timescale + uDml_diag(I,j) = uDml(I) + enddo ; enddo + +! V- component + !$OMP do + do J=js-1,je ; do i=is,ie + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) + + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + ! If needed, res_scaling_fac = min( ds, L_d ) / l_f + if (res_upscale) res_scaling_fac = & + ( sqrt( 0.5 * ( (G%dxCv(i,J))**2 + (G%dyCv(i,J))**2 ) ) * I_LFront ) & + * min( 1., 0.5*( VarMix%Rd_dx_h(i,j) + VarMix%Rd_dx_h(i,j+1) ) ) + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 + h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + timescale = timescale * CS%ml_restrat_coef + + if (res_upscale) timescale = timescale * res_scaling_fac + vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & + (Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2) + + ! As above but using the slow filtered MLD + h_vel = 0.5*((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + timescale = timescale * CS%ml_restrat_coef2 + + if (res_upscale) timescale = timescale * res_scaling_fac + vDml_slow(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & + (Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2) + + if (vDml(i) + vDml_slow(i) == 0.) then + do k=1,nz ; vhml(i,J,k) = 0.0 ; enddo + else + IhTot = 2.0 / ((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) + IhTot_slow = 2.0 / ((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) + zpa = 0.0 ; zpb = 0.0 + ! a(k) relates the sublayer transport to vDml with a linear profile. + ! The sum of a(k) through the mixed layers must be 0. + do k=1,nz + hAtVel = 0.5*(h(i,j,k) + h(i,j+1,k)) + a(k) = mu(zpa, CS%MLE_tail_dh) ! mu(z/MLD) for upper interface + zpa = zpa - (hAtVel * IhTot) ! z/H for lower interface + a(k) = a(k) - mu(zpa, CS%MLE_tail_dh) ! Transport profile + ! Limit magnitude (vDml) if it would violate CFL + if (a(k)*vDml(i) > 0.0) then + if (a(k)*vDml(i) > h_avail(i,j,k)) vDml(i) = h_avail(i,j,k) / a(k) + elseif (a(k)*vDml(i) < 0.0) then + if (-a(k)*vDml(i) > h_avail(i,j+1,k)) vDml(i) = -h_avail(i,j+1,k) / a(k) + endif + enddo + do k=1,nz + ! Transport for slow-filtered MLD + hAtVel = 0.5*(h(i,j,k) + h(i,j+1,k)) + b(k) = mu(zpb, CS%MLE_tail_dh) ! mu(z/MLD) for upper interface + zpb = zpb - (hAtVel * IhTot_slow) ! z/H for lower interface + b(k) = b(k) - mu(zpb, CS%MLE_tail_dh) ! Transport profile + ! Limit magnitude (vDml_slow) if it would violate CFL when added to vDml + if (b(k)*vDml_slow(i) > 0.0) then + if (b(k)*vDml_slow(i) > h_avail(i,j,k) - a(k)*vDml(i)) & + vDml_slow(i) = max( 0., h_avail(i,j,k) - a(k)*vDml(i) ) / b(k) + elseif (b(k)*vDml_slow(i) < 0.0) then + if (-b(k)*vDml_slow(i) > h_avail(i,j+1,k) + a(k)*vDml(i)) & + vDml_slow(i) = -max( 0., h_avail(i,j+1,k) + a(k)*vDml(i) ) / b(k) + endif + enddo + do k=1,nz + vhml(i,J,k) = a(k)*vDml(i) + b(k)*vDml_slow(i) + vhtr(i,J,k) = vhtr(i,J,k) + vhml(i,J,k)*dt + enddo + endif + + vtimescale_diag(i,J) = timescale + vDml_diag(i,J) = vDml(i) + enddo ; enddo + + !$OMP do + do j=js,je ; do k=1,nz ; do i=is,ie + h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & + ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) + if (h(i,j,k) < h_min) h(i,j,k) = h_min + enddo ; enddo ; enddo + !$OMP end parallel + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + if (CS%id_uhml > 0 .or. CS%id_vhml > 0) & + ! Remapped uhml and vhml require east/north halo updates of h + call pass_var(h, G%domain, To_West+To_South+Omit_Corners, halo=1) + call diag_update_remap_grids(CS%diag) + + ! Offer diagnostic fields for averaging. + if (query_averaging_enabled(CS%diag)) then + if (CS%id_urestrat_time > 0) call post_data(CS%id_urestrat_time, utimescale_diag, CS%diag) + if (CS%id_vrestrat_time > 0) call post_data(CS%id_vrestrat_time, vtimescale_diag, CS%diag) + if (CS%id_uhml > 0) call post_data(CS%id_uhml, uhml, CS%diag) + if (CS%id_vhml > 0) call post_data(CS%id_vhml, vhml, CS%diag) + if (CS%id_BLD > 0) call post_data(CS%id_BLD, MLD_fast, CS%diag) + if (CS%id_MLD > 0) call post_data(CS%id_MLD, MLD_slow, CS%diag) + if (CS%id_Rml > 0) call post_data(CS%id_Rml, Rml_av_fast, CS%diag) + if (CS%id_uDml > 0) call post_data(CS%id_uDml, uDml_diag, CS%diag) + if (CS%id_vDml > 0) call post_data(CS%id_vDml, vDml_diag, CS%diag) + + if (CS%id_uml > 0) then + do J=js,je ; do i=is-1,ie + h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) + uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (mu(0.,0.)-mu(-.01,0.)) + enddo ; enddo + call post_data(CS%id_uml, uDml_diag, CS%diag) + endif + if (CS%id_vml > 0) then + do J=js-1,je ; do i=is,ie + h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) + vDml_diag(i,J) = vDml_diag(i,J) / (0.01*h_vel) * G%IdxCv(i,J) * (mu(0.,0.)-mu(-.01,0.)) + enddo ; enddo + call post_data(CS%id_vml, vDml_diag, CS%diag) + endif + endif + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + ! This needs to happen after the H update and before the next post_data. + call diag_update_remap_grids(CS%diag) + +end subroutine mixedlayer_restrat_OM4 + +!> Stream function shape as a function of non-dimensional position within mixed-layer [nondim] +real function mu(sigma, dh) + real, intent(in) :: sigma !< Fractional position within mixed layer [nondim] + !! z=0 is surface, z=-1 is the bottom of the mixed layer + real, intent(in) :: dh !< Non-dimensional distance over which to extend stream + !! function to smooth transport at base [nondim] + ! Local variables + real :: xp !< A linear function from mid-point of the mixed-layer + !! to the extended mixed-layer bottom [nondim] + real :: bottop !< A mask, 0 in upper half of mixed layer, 1 otherwise [nondim] + real :: dd !< A cubic(-ish) profile in lower half of extended mixed + !! layer to smooth out the parameterized transport [nondim] + + ! Lower order shape (not used), see eq 10 from FK08b. + ! Apparently used in CM2G, see eq 14 of FK11. + !mu = max(0., (1. - (2.*sigma + 1.)**2)) + + ! Second order, in Rossby number, shape. See eq 21 from FK08a, eq 9 from FK08b, eq 5 FK11 + mu = max(0., (1. - (2.*sigma + 1.)**2) * (1. + (5./21.)*(2.*sigma + 1.)**2)) + + ! -0.5 < sigma : xp(sigma)=0 (upper half of mixed layer) + ! -1.0+dh < sigma < -0.5 : xp(sigma)=linear (lower half +dh of mixed layer) + ! sigma < -1.0+dh : xp(sigma)=1 (below mixed layer + dh) + xp = max(0., min(1., (-sigma - 0.5)*2. / (1. + 2.*dh))) + + ! -0.5 < sigma : dd(sigma)=1 (upper half of mixed layer) + ! -1.0+dh < sigma < -0.5 : dd(sigma)=cubic (lower half +dh of mixed layer) + ! sigma < -1.0+dh : dd(sigma)=0 (below mixed layer + dh) + dd = (max(1. - xp**2 * (3. - 2.*xp), 0.))**(1. + 2.*dh) + + ! -0.5 < sigma : bottop(sigma)=0 (upper half of mixed layer) + ! sigma < -0.5 : bottop(sigma)=1 (below upper half) + bottop = 0.5*(1. - sign(1., sigma + 0.5)) ! =0 for sigma>-0.5, =1 for sigma<-0.5 + + mu = max(mu, dd*bottop) ! Combines original psi1 with tail +end function mu + +!> Calculates a restratifying flow in the mixed layer, following the formulation +!! used in Bodner et al., 2023 (B22) +subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, BLD, bflux) + ! Arguments + type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + type(ocean_grid_type), intent(inout) :: 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(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [H L2 ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + real, dimension(:,:), pointer :: BLD !< Active boundary layer depth provided by the + !! PBL scheme [Z ~> m] (not H) + real, dimension(:,:), pointer :: bflux !< Surface buoyancy flux provided by the + !! PBL scheme [Z2 T-3 ~> m2 s-3] + ! Local variables + real :: uhml(SZIB_(G),SZJ_(G),SZK_(GV)) ! zonal mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vhml(SZI_(G),SZJB_(G),SZK_(GV)) ! merid mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vol_dt_avail(SZI_(G),SZJ_(G),SZK_(GV)) ! The volume available for exchange out of each face of + ! each layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJ_(G)) :: & + little_h, & ! "Little h" representing active mixing layer depth [H ~> m or kg m-2] + big_H, & ! "Big H" representing the mixed layer depth [H ~> m or kg m-2] + htot, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] + buoy_av, & ! g_Rho0 times the average mixed layer density or G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + wpup ! Turbulent vertical momentum [L H T-2 ~> m2 s-2 or kg m-1 s-2] + real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: lf_bodner_diag(SZI_(G),SZJ_(G)) ! Front width as in Bodner et al., 2023 (B22), eq 24 [L ~> m] + real :: U_star_2d(SZI_(G),SZJ_(G)) ! The wind friction velocity, calculated using the Boussinesq + ! reference density or the time-evolving surface density in non-Boussinesq + ! mode [Z T-1 ~> m s-1] + real :: BLD_in_H(SZI_(G)) ! The thickness of the active boundary layer with the topmost BLD of + ! height [H ~> m or kg m-2] + real :: covTS(SZI_(G)) ! SGS TS covariance in Stanley param; currently 0 [C S ~> degC ppt] + real :: varS(SZI_(G)) ! SGS S variance in Stanley param; currently 0 [S2 ~> ppt2] + real :: dmu(SZK_(GV)) ! Change in mu(z) across layer k [nondim] + real :: Rml_int(SZI_(G)) ! Potential density integrated through the mixed layer [R H ~> kg m-2 or kg2 m-5] + real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] + real :: SpV_int(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] + real :: H_mld(SZI_(G)) ! The thickness of water within the topmost BLD of height [H ~> m or kg m-2] + real :: MLD_rem(SZI_(G)) ! The vertical extent of the BLD that has not yet been accounted for [Z ~> m] + real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] + real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor + ! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2] + real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] + real :: w_star3 ! Cube of turbulent convective velocity [Z3 T-3 ~> m3 s-3] + real :: u_star3 ! Cube of surface friction velocity [Z3 T-3 ~> m3 s-3] + real :: r_wpup ! reciprocal of vertical momentum flux [T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1] + real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] + real :: f_h ! Coriolis parameter at h-points [T-1 ~> s-1] + real :: f2_h ! Coriolis parameter at h-points squared [T-2 ~> s-2] + real :: absurdly_small_freq2 ! Frequency squared used to avoid division by 0 [T-2 ~> s-2] + real :: grid_dsd ! combination of grid scales [L2 ~> m2] + real :: h_sml ! "Little h", the active mixing depth with diurnal cycle removed [H ~> m or kg m-2] + real :: h_big ! "Big H", the mixed layer depth based on a time filtered "little h" [H ~> m or kg m-2] + real :: grd_b ! The vertically average gradient of buoyancy [L H-1 T-2 ~> s-2 or m-3 kg-1 s-2] + real :: psi_mag ! Magnitude of stream function [L2 H T-1 ~> m3 s-1 or kg s-1] + real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] + real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] + real :: Ihtot,Ihtot_slow! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: hAtVel ! Thickness at the velocity points [H ~> m or kg m-2] + real :: sigint ! Fractional position within the mixed layer of the interface above a layer [nondim] + real :: muzb ! mu(z) at bottom of the layer [nondim] + real :: muza ! mu(z) at top of the layer [nondim] + real :: dh ! Portion of the layer thickness that is in the mixed layer [H ~> m or kg m-2] + real :: res_scaling_fac ! The resolution-dependent scaling factor [nondim] + real :: Z3_T3_to_m3_s3 ! Conversion factors to undo scaling and permit terms to be raised to a + ! fractional power [T3 m3 Z-3 s-3 ~> 1] + real :: m2_s2_to_Z2_T2 ! Conversion factors to restore scaling after a term is raised to a + ! fractional power [Z2 s2 T-2 m-2 ~> 1] + real, parameter :: two_thirds = 2./3. ! [nondim] + logical :: line_is_empty, keep_going + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + + 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 + + I4dt = 0.25 / dt + g_Rho0 = GV%H_to_Z * GV%g_Earth / GV%Rho0 + h_neglect = GV%H_subroundoff + + covTS(:) = 0.0 ! Might be in tv% in the future. Not implemented for the time being. + varS(:) = 0.0 ! Ditto. + + ! This value is roughly (pi / (the age of the universe) )^2. + absurdly_small_freq2 = 1e-34*US%T_to_s**2 + + if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & + "An equation of state must be used with this module.") + if (.not.CS%MLE_use_PBL_MLD) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & + "To use the Bodner et al., 2023, MLE parameterization, MLE_USE_PBL_MLD must be True.") + if (CS%MLE_density_diff > 0.) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & + "MLE_density_diff is +ve and should not be in mixedlayer_restrat_Bodner.") + if (.not.associated(bflux)) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & + "Surface buoyancy flux was not associated.") + + call pass_var(bflux, G%domain, halo=1) + + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) + + if (CS%debug) then + call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(BLD, 'mle_Bodner: BLD in', G%HI, haloshift=1, scale=US%Z_to_m) + if (associated(bflux)) & + call hchksum(bflux, 'mle_Bodner: bflux', G%HI, haloshift=1, scale=US%Z_to_m**2*US%s_to_T**3) + call hchksum(U_star_2d, 'mle_Bodner: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) + call hchksum(CS%MLD_filtered, 'mle_Bodner: MLD_filtered 1', & + G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 1', & + G%HI, haloshift=1, scale=GV%H_to_mks) + endif + + ! Apply time filter to BLD (to remove diurnal cycle) to obtain "little h". + ! "little h" is representative of the active mixing layer depth, used in B22 formula (eq 27). + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + do j=js-1,je+1 ; do i=is-1,ie+1 + little_h(i,j) = rmean2ts(GV%Z_to_H*BLD(i,j), CS%MLD_filtered(i,j), & + CS%BLD_growing_Tfilt, CS%BLD_decaying_Tfilt, dt) + CS%MLD_filtered(i,j) = little_h(i,j) + enddo ; enddo + else ! The fully non-Boussinesq conversion between height in BLD and thickness. + do j=js-1,je+1 + do i=is-1,ie+1 ; MLD_rem(i) = BLD(i,j) ; H_mld(i) = 0.0 ; enddo + do k=1,nz + keep_going = .false. + do i=is-1,ie+1 ; if (MLD_rem(i) > 0.0) then + if (MLD_rem(i) > GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)) then + H_mld(i) = H_mld(i) + h(i,j,k) + MLD_rem(i) = MLD_rem(i) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + keep_going = .true. + else + H_mld(i) = H_mld(i) + GV%RZ_to_H * MLD_rem(i) / tv%SpV_avg(i,j,k) + MLD_rem(i) = 0.0 + endif + endif ; enddo + if (.not.keep_going) exit + enddo + do i=is-1,ie+1 + little_h(i,j) = rmean2ts(H_mld(i), CS%MLD_filtered(i,j), & + CS%BLD_growing_Tfilt, CS%BLD_decaying_Tfilt, dt) + CS%MLD_filtered(i,j) = little_h(i,j) + enddo + enddo + endif + + ! Calculate "big H", representative of the mixed layer depth, used in B22 formula (eq 27). + do j=js-1,je+1 ; do i=is-1,ie+1 + big_H(i,j) = rmean2ts(little_h(i,j), CS%MLD_filtered_slow(i,j), & + CS%MLD_growing_Tfilt, CS%MLD_decaying_Tfilt, dt) + CS%MLD_filtered_slow(i,j) = big_H(i,j) + enddo ; enddo + + ! Estimate w'u' at h-points, with a floor to avoid division by zero later. + if (allocated(tv%SpV_avg) .and. .not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then + do j=js-1,je+1 ; do i=is-1,ie+1 + ! This expression differs by a factor of 1. / (Rho_0 * SpV_avg) compared with the other + ! expressions below, and it is invariant to the value of Rho_0 in non-Boussinesq mode. + wpup(i,j) = max((cuberoot( CS%mstar * U_star_2d(i,j)**3 + & + CS%nstar * max(0., -bflux(i,j)) * BLD(i,j) ))**2, CS%min_wstar2) & + * (US%Z_to_L * GV%RZ_to_H / tv%SpV_avg(i,j,1)) + ! The final line above converts from [Z2 T-2 ~> m2 s-2] to [L H T-2 ~> m2 s-2 or Pa]. + ! Some rescaling factors and the division by specific volume compensating for other + ! factors that are in find_ustar_mech, and others effectively converting the wind + ! stresses from [R L Z T-2 ~> Pa] to [L H T-2 ~> m2 s-2 or Pa]. The rescaling factors + ! and density being applied to the buoyancy flux are not so neatly explained because + ! fractional powers cancel out or combine with terms in the definitions of BLD and + ! bflux (such as SpV_avg**-2/3 combining with other terms in bflux to give the thermal + ! expansion coefficient) and because the specific volume does vary within the mixed layer. + enddo ; enddo + elseif (CS%answer_date < 20240201) then + Z3_T3_to_m3_s3 = (US%Z_to_m * US%s_to_T)**3 + m2_s2_to_Z2_T2 = (US%m_to_Z * US%T_to_s)**2 + do j=js-1,je+1 ; do i=is-1,ie+1 + w_star3 = max(0., -bflux(i,j)) * BLD(i,j) ! In [Z3 T-3 ~> m3 s-3] + u_star3 = U_star_2d(i,j)**3 ! In [Z3 T-3 ~> m3 s-3] + wpup(i,j) = max(m2_s2_to_Z2_T2 * (Z3_T3_to_m3_s3 * ( CS%mstar * u_star3 + CS%nstar * w_star3 ) )**two_thirds, & + CS%min_wstar2) * US%Z_to_L * GV%Z_to_H ! In [L H T-2 ~> m2 s-2 or kg m-1 s-2] + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + w_star3 = max(0., -bflux(i,j)) * BLD(i,j) ! In [Z3 T-3 ~> m3 s-3] + wpup(i,j) = max( (cuberoot(CS%mstar * U_star_2d(i,j)**3 + CS%nstar * w_star3))**2, CS%min_wstar2 ) & + * US%Z_to_L * GV%Z_to_H ! In [L H T-2 ~> m2 s-2 or kg m-1 s-2] + enddo ; enddo + endif + + ! We filter w'u' with the same time scales used for "little h" + do j=js-1,je+1 ; do i=is-1,ie+1 + wpup(i,j) = rmean2ts(wpup(i,j), CS%wpup_filtered(i,j), & + CS%BLD_growing_Tfilt, CS%BLD_decaying_Tfilt, dt) + CS%wpup_filtered(i,j) = wpup(i,j) + enddo ; enddo + + if (CS%id_lfbod > 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + ! Calculate front length used in B22 formula (eq 24). + w_star3 = max(0., -bflux(i,j)) * BLD(i,j) + u_star3 = U_star_2d(i,j)**3 + + ! Include an absurdly_small_freq2 to prevent division by zero. + f_h = 0.25 * ((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) & + + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))) + f2_h = max(f_h**2, absurdly_small_freq2) + + lf_bodner_diag(i,j) = & + 0.25 * cuberoot(CS%mstar * u_star3 + CS%nstar * w_star3)**2 & + / (f2_h * max(little_h(i,j), GV%Angstrom_H)) + enddo ; enddo + + ! Rescale from [Z2 H-1 to L] + if (allocated(tv%SpV_avg) .and. .not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then + do j=js-1,je+1 ; do i=is-1,ie+1 + lf_bodner_diag(i,j) = lf_bodner_diag(i,j) & + * (US%Z_to_L * GV%RZ_to_H / tv%SpV_avg(i,j,1)) + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + lf_bodner_diag(i,j) = lf_bodner_diag(i,j) * US%Z_to_L * GV%Z_to_H + enddo ; enddo + endif + endif + + if (CS%debug) then + call hchksum(little_h,'mle_Bodner: little_h', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(big_H,'mle_Bodner: big_H', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(CS%MLD_filtered,'mle_Bodner: MLD_filtered 2', & + G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 2', & + G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(wpup,'mle_Bodner: wpup', G%HI, haloshift=1, scale=US%L_to_m*GV%H_to_mks*US%s_to_T**2) + endif + + ! Calculate the average density in the "mixed layer". + ! Notice we use p=0 (sigma_0) since horizontal differences of vertical averages of + ! in-situ density would contain the MLD gradient (through the pressure dependence). + p0(:) = 0.0 + EOSdom(:) = EOS_domain(G%HI, halo=1) + !$OMP parallel & + !$OMP default(shared) & + !$OMP private(i, j, k, keep_going, line_is_empty, dh, & + !$OMP grid_dsd, absf, h_sml, h_big, grd_b, r_wpup, psi_mag, IhTot, & + !$OMP sigint, muzb, muza, hAtVel, Rml_int, SpV_int) + + !$OMP do + do j=js-1,je+1 + rho_ml(:) = 0.0 ; SpV_ml(:) = 0.0 + do i=is-1,ie+1 + htot(i,j) = 0.0 ; Rml_int(i) = 0.0 ; SpV_int(i) = 0.0 + enddo + keep_going = .true. + do k=1,nz + do i=is-1,ie+1 + vol_dt_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + if (keep_going) then + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + if (CS%use_Stanley_ML) then + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & + rho_ml, tv%eqn_of_state, EOSdom) + else + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml, tv%eqn_of_state, EOSdom) + endif + else + call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, SpV_ml, tv%eqn_of_state, EOSdom) + endif + line_is_empty = .true. + do i=is-1,ie+1 + if (htot(i,j) < big_H(i,j)) then + dh = min( h(i,j,k), big_H(i,j) - htot(i,j) ) + Rml_int(i) = Rml_int(i) + dh*rho_ml(i) ! Rml_int has units of [R H ~> kg m-2] + SpV_int(i) = SpV_int(i) + dh*SpV_ml(i) ! SpV_int has units of [H R-1 ~> m4 kg-1 or m] + htot(i,j) = htot(i,j) + dh + line_is_empty = .false. + endif + enddo + if (line_is_empty) keep_going=.false. + endif + enddo + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is-1,ie+1 + ! Buoy_av has units (L2 H-1 T-2 R-1) * (R H) * H-1 = L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2 + buoy_av(i,j) = -( g_Rho0 * Rml_int(i) ) / (htot(i,j) + h_neglect) + enddo + else + do i=is-1,ie+1 + ! Buoy_av has units (R L2 H-1 T-2) * (R-1 H) * H-1 = L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2 + buoy_av(i,j) = (GV%H_to_RZ*GV%g_Earth * SpV_int(i)) / (htot(i,j) + h_neglect) + enddo + endif + enddo + + if (CS%debug) then + call hchksum(htot,'mle_Bodner: htot', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(vol_dt_avail,'mle_Bodner: vol_dt_avail', G%HI, haloshift=1, & + scale=US%L_to_m**2*GV%H_to_mks*US%s_to_T) + call hchksum(buoy_av,'mle_Bodner: buoy_av', G%HI, haloshift=1, scale=GV%m_to_H*US%L_T_to_m_s**2) + endif + + ! U - Component + !$OMP do + do j=js,je ; do I=is-1,ie + if (G%OBCmaskCu(I,j) > 0.) then + grid_dsd = sqrt(0.5*( G%dxCu(I,j)**2 + G%dyCu(I,j)**2 )) * G%dyCu(I,j) ! L2 ~> m2 + absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! T-1 ~> s-1 + h_sml = 0.5*( little_h(i,j) + little_h(i+1,j) ) ! H ~> m or kg m-3 + h_big = 0.5*( big_H(i,j) + big_H(i+1,j) ) ! H ~> m or kg m-3 + grd_b = ( buoy_av(i+1,j) - buoy_av(i,j) ) * G%IdxCu(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 + r_wpup = 2. / ( wpup(i,j) + wpup(i+1,j) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 + psi_mag = ( ( ( CS%Cr * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 + * ( ( h_big**2 ) * grd_b ) ) * r_wpup + else ! There is no flux on land and no gradient at open boundary points. + psi_mag = 0.0 + endif + + IhTot = 2.0 / ((htot(i,j) + htot(i+1,j)) + h_neglect) ! [H-1] + sigint = 0.0 + muzb = 0.0 ! This will be the first value of muza = mu(z=0) + do k=1,nz + muza = muzb ! mu(z/MLD) for upper interface [nondim] + hAtVel = 0.5*(h(i,j,k) + h(i+1,j,k)) ! Thickness at velocity point [H] + sigint = sigint - (hAtVel * IhTot) ! z/H for lower interface [nondim] + muzb = mu(sigint, CS%MLE_tail_dh) ! mu(z/MLD) for lower interface [nondim] + dmu(k) = muza - muzb ! Change in mu(z) across layer [nondim] + ! dmu(k)*psi_mag is the transport in this layer [L2 H T-1 ~> m3 s-1] + ! Limit magnitude (psi_mag) if it would violate CFL + if (dmu(k)*psi_mag > 0.0) then + if (dmu(k)*psi_mag > vol_dt_avail(i,j,k)) psi_mag = vol_dt_avail(i,j,k) / dmu(k) + elseif (dmu(k)*psi_mag < 0.0) then + if (-dmu(k)*psi_mag > vol_dt_avail(i+1,j,k)) psi_mag = -vol_dt_avail(i+1,j,k) / dmu(k) + endif + enddo ! These loops cannot be fused because psi_mag applies to the whole column + do k=1,nz + uhml(I,j,k) = dmu(k) * psi_mag ! [ L2 H T-1 ] + uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k) * dt ! [ L2 H ] + enddo + + uDml_diag(I,j) = psi_mag + enddo ; enddo + + ! V- component + !$OMP do + do J=js-1,je ; do i=is,ie + if (G%OBCmaskCv(i,J) > 0.) then + grid_dsd = sqrt(0.5*( G%dxCv(i,J)**2 + G%dyCv(i,J)**2 )) * G%dxCv(i,J) ! L2 ~> m2 + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! T-1 ~> s-1 + h_sml = 0.5*( little_h(i,j) + little_h(i,j+1) ) ! H ~> m or kg m-3 + h_big = 0.5*( big_H(i,j) + big_H(i,j+1) ) ! H ~> m or kg m-3 + grd_b = ( buoy_av(i,j+1) - buoy_av(i,j) ) * G%IdyCv(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 + r_wpup = 2. / ( wpup(i,j) + wpup(i,j+1) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 + psi_mag = ( ( ( CS%Cr * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 + * ( ( h_big**2 ) * grd_b ) ) * r_wpup + else ! There is no flux on land and no gradient at open boundary points. + psi_mag = 0.0 + endif + + IhTot = 2.0 / ((htot(i,j) + htot(i,j+1)) + h_neglect) ! [H-1] + sigint = 0.0 + muzb = 0.0 ! This will be the first value of muza = mu(z=0) + do k=1,nz + muza = muzb ! mu(z/MLD) for upper interface [nondim] + hAtVel = 0.5*(h(i,j,k) + h(i,j+1,k)) ! Thickness at velocity point [H] + sigint = sigint - (hAtVel * IhTot) ! z/H for lower interface [nondim] + muzb = mu(sigint, CS%MLE_tail_dh) ! mu(z/MLD) for lower interface [nondim] + dmu(k) = muza - muzb ! Change in mu(z) across layer [nondim] + ! dmu(k)*psi_mag is the transport in this layer [L2 H T-1 ~> m3 s-1] + ! Limit magnitude (psi_mag) if it would violate CFL + if (dmu(k)*psi_mag > 0.0) then + if (dmu(k)*psi_mag > vol_dt_avail(i,j,k)) psi_mag = vol_dt_avail(i,j,k) / dmu(k) + elseif (dmu(k)*psi_mag < 0.0) then + if (-dmu(k)*psi_mag > vol_dt_avail(i,j+1,k)) psi_mag = -vol_dt_avail(i,j+1,k) / dmu(k) + endif + enddo ! These loops cannot be fused because psi_mag applies to the whole column + do k=1,nz + vhml(i,J,k) = dmu(k) * psi_mag ! [ L2 H T-1 ] + vhtr(i,J,k) = vhtr(i,J,k) + vhml(i,J,k) * dt ! [ L2 H ] + enddo + + vDml_diag(i,J) = psi_mag + enddo ; enddo + + !$OMP do + do j=js,je ; do k=1,nz ; do i=is,ie + h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & + ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) + enddo ; enddo ; enddo + !$OMP end parallel + + if (CS%id_uhml > 0 .or. CS%id_vhml > 0) & + ! Remapped uhml and vhml require east/north halo updates of h + call pass_var(h, G%domain, To_West+To_South+Omit_Corners, halo=1) + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! Offer diagnostic fields for averaging. + if (query_averaging_enabled(CS%diag)) then + if (CS%id_ustar > 0) call post_data(CS%id_ustar, U_star_2d, CS%diag) + if (CS%id_bflux > 0) call post_data(CS%id_bflux, bflux, CS%diag) + if (CS%id_wpup > 0) call post_data(CS%id_wpup, wpup, CS%diag) + if (CS%id_Rml > 0) call post_data(CS%id_Rml, buoy_av, CS%diag) + if (CS%id_BLD > 0) call post_data(CS%id_BLD, little_h, CS%diag) + if (CS%id_MLD > 0) call post_data(CS%id_MLD, big_H, CS%diag) + if (CS%id_uhml > 0) call post_data(CS%id_uhml, uhml, CS%diag) + if (CS%id_vhml > 0) call post_data(CS%id_vhml, vhml, CS%diag) + if (CS%id_uDml > 0) call post_data(CS%id_uDml, uDml_diag, CS%diag) + if (CS%id_vDml > 0) call post_data(CS%id_vDml, vDml_diag, CS%diag) + if (CS%id_lfbod > 0) call post_data(CS%id_lfbod, lf_bodner_diag, CS%diag) + + if (CS%id_uml > 0) then + do J=js,je ; do i=is-1,ie + h_vel = 0.5*((htot(i,j) + htot(i+1,j)) + h_neglect) + uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (mu(0.,0.)-mu(-.01,0.)) + enddo ; enddo + call post_data(CS%id_uml, uDml_diag, CS%diag) + endif + if (CS%id_vml > 0) then + do J=js-1,je ; do i=is,ie + h_vel = 0.5*((htot(i,j) + htot(i,j+1)) + h_neglect) + vDml_diag(i,J) = vDml_diag(i,J) / (0.01*h_vel) * G%IdxCv(i,J) * (mu(0.,0.)-mu(-.01,0.)) + enddo ; enddo + call post_data(CS%id_vml, vDml_diag, CS%diag) + endif + endif + +end subroutine mixedlayer_restrat_Bodner + +!> Two time-scale running mean [units of "signal" and "filtered"] +!! +!! If signal > filtered, returns running-mean with time scale "tau_growing". +!! If signal <= filtered, returns running-mean with time scale "tau_decaying". +!! +!! The running mean of \f$ s \f$ with time scale "of \f$ \tau \f$ is: +!! \f[ +!! \bar{s} <- ( \Delta t * s + \tau * \bar{s} ) / ( \Delta t + \tau ) +!! \f] +!! +!! Note that if \f$ tau=0 \f$, then the running mean equals the signal. Thus, +!! rmean2ts with tau_growing=0 recovers the "resetting running mean" used in OM4. +real elemental function rmean2ts(signal, filtered, tau_growing, tau_decaying, dt) + ! Arguments + real, intent(in) :: signal ! Unfiltered signal [arbitrary units] + real, intent(in) :: filtered ! Current value of running mean [arbitrary units] + real, intent(in) :: tau_growing ! Time scale for growing signal [T ~> s] + real, intent(in) :: tau_decaying ! Time scale for decaying signal [T ~> s] + real, intent(in) :: dt ! Time step [T ~> s] + ! Local variables + real :: afac, bfac ! Non-dimensional fractional weights [nondim] + real :: rt ! Reciprocal time scale [T-1 ~> s-1] + + if (signal>=filtered) then + rt = 1.0 / ( dt + tau_growing ) + aFac = tau_growing * rt + bFac = 1. - aFac + else + rt = 1.0 / ( dt + tau_decaying ) + aFac = tau_decaying * rt + bFac = 1. - aFac + endif + + rmean2ts = aFac * filtered + bFac * signal + +end function rmean2ts + +!> Calculates a restratifying flow assuming a 2-layer bulk mixed layer. +subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) + 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(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [H L2 ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + + ! Local variables + real :: uhml(SZIB_(G),SZJ_(G),SZK_(GV)) ! Restratifying zonal thickness transports [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vhml(SZI_(G),SZJB_(G),SZK_(GV)) ! Restratifying meridional thickness transports [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + h_avail ! The volume available for diffusion out of each face of each + ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: & + U_star_2d, & ! The wind friction velocity in thickness-based units, calculated using + ! the Boussinesq reference density or the time-evolving surface density + ! in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] + htot, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] + Rml_av ! g_Rho0 times the average mixed layer density or negative G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor + ! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2] + real :: Rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + real :: rho_int(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-3] + real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] + real :: SpV_int(SZI_(G)) ! Specific volume integrated through the surface layer [H R-1 ~> m4 kg-1 or m] + real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] + + real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] + real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] + real :: u_star ! surface friction velocity, interpolated to velocity points and recast into + ! thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: vonKar_x_pi2 ! A scaling constant that is approximately the von Karman constant times + ! pi squared [nondim] + real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] + real :: timescale ! mixing growth timescale [T ~> s] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. + real :: h_neglect ! tiny thickness usually lost in roundoff and can be neglected [H ~> m or kg m-2] + real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] + real :: I2htot ! Twice the total mixed layer thickness at velocity points [H ~> m or kg m-2] + real :: z_topx2 ! depth of the top of a layer at velocity points [H ~> m or kg m-2] + real :: hx2 ! layer thickness at velocity points [H ~> m or kg m-2] + real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux magnitudes (uDml & vDml) + ! to the realized flux in a layer [nondim]. The vertical sum of a() + ! through the pieces of the mixed layer must be 0. + real :: uDml(SZIB_(G)) ! Zonal volume fluxes in the upper half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml(SZI_(G)) ! Meridional volume fluxes in the upper half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! Zonal restratification timescale [T ~> s], stored for diagnostics. + real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! Meridional restratification timescale [T ~> s], stored for diagnostics. + real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkml + 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 ; nkml = GV%nkml + + if (.not. CS%initialized) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & + "Module must be initialized before it is used.") + + if ((nkml<2) .or. (CS%ml_restrat_coef<=0.0)) return + + + h_min = 0.5*GV%Angstrom_H ! This should be GV%Angstrom_H, but that value would change answers. + uDml(:) = 0.0 ; vDml(:) = 0.0 + I4dt = 0.25 / dt + g_Rho0 = GV%H_to_Z * GV%g_Earth / GV%Rho0 + vonKar_x_pi2 = CS%vonKar * 9.8696 + use_EOS = associated(tv%eqn_of_state) + h_neglect = GV%H_subroundoff + + if (.not.use_EOS) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & + "An equation of state must be used with this module.") + + if (CS%use_Stanley_ML) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & + "The Stanley parameterization is not available with the BML.") + + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1, H_T_units=.true.) + + ! Fix this later for nkml >= 3. + + p0(:) = 0.0 + EOSdom(:) = EOS_domain(G%HI, halo=1) + !$OMP parallel default(shared) private(Rho_ml,rho_int,h_vel,u_star,absf,mom_mixrate,timescale, & + !$OMP SpV_ml,SpV_int,I2htot,z_topx2,hx2,a) & + !$OMP firstprivate(uDml,vDml) + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot(i,j) = 0.0 ; rho_int(i) = 0.0 + enddo + do k=1,nkml + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho_ml(:), tv%eqn_of_state, EOSdom) + do i=is-1,ie+1 + rho_int(i) = rho_int(i) + h(i,j,k)*Rho_ml(i) + htot(i,j) = htot(i,j) + h(i,j,k) + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + enddo + + do i=is-1,ie+1 + Rml_av(i,j) = (g_Rho0*rho_int(i)) / (htot(i,j) + h_neglect) + enddo + enddo + else ! This is only used in non-Boussinesq mode. + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot(i,j) = 0.0 ; SpV_int(i) = 0.0 + enddo + do k=1,nkml + call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, SpV_ml, tv%eqn_of_state, EOSdom) + do i=is-1,ie+1 + SpV_int(i) = SpV_int(i) + h(i,j,k)*SpV_ml(i) ! [H R-1 ~> m4 kg-1 or m] + htot(i,j) = htot(i,j) + h(i,j,k) + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + enddo + + ! Convert the vertically integrated specific volume into a negative variable with units of density. + do i=is-1,ie+1 + Rml_av(i,j) = (-GV%H_to_RZ*GV%g_Earth * SpV_int(i)) / (htot(i,j) + h_neglect) + enddo + enddo + endif + +! TO DO: +! 1. Mixing extends below the mixing layer to the mixed layer. Find it! +! 2. Add exponential tail to stream-function? + +! U - Component + !$OMP do + do j=js,je ; do I=is-1,ie + h_vel = 0.5*(htot(i,j) + htot(i+1,j)) + + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) + + absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + + timescale = timescale * CS%ml_restrat_coef +! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) + + uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & + (Rml_av(i+1,j)-Rml_av(i,j)) * (h_vel**2) + + if (uDml(I) == 0) then + do k=1,nkml ; uhml(I,j,k) = 0.0 ; enddo + else + I2htot = 1.0 / (htot(i,j) + htot(i+1,j) + h_neglect) + z_topx2 = 0.0 + ! a(k) relates the sublayer transport to uDml with a linear profile. + ! The sum of a(k) through the mixed layers must be 0. + do k=1,nkml + hx2 = (h(i,j,k) + h(i+1,j,k) + h_neglect) + a(k) = (hx2 * I2htot) * (2.0 - 4.0*(z_topx2+0.5*hx2)*I2htot) + z_topx2 = z_topx2 + hx2 + if (a(k)*uDml(I) > 0.0) then + if (a(k)*uDml(I) > h_avail(i,j,k)) uDml(I) = h_avail(i,j,k) / a(k) + else + if (-a(k)*uDml(I) > h_avail(i+1,j,k)) uDml(I) = -h_avail(i+1,j,k)/a(k) + endif + enddo + do k=1,nkml + uhml(I,j,k) = a(k)*uDml(I) + uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k)*dt + enddo + endif + + uDml_diag(I,j) = uDml(I) + utimescale_diag(I,j) = timescale + enddo ; enddo + +! V- component + !$OMP do + do J=js-1,je ; do i=is,ie + h_vel = 0.5*(htot(i,j) + htot(i,j+1)) + + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) + + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + + timescale = timescale * CS%ml_restrat_coef +! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) + + vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & + (Rml_av(i,j+1)-Rml_av(i,j)) * (h_vel**2) + if (vDml(i) == 0) then + do k=1,nkml ; vhml(i,J,k) = 0.0 ; enddo + else + I2htot = 1.0 / (htot(i,j) + htot(i,j+1) + h_neglect) + z_topx2 = 0.0 + ! a(k) relates the sublayer transport to vDml with a linear profile. + ! The sum of a(k) through the mixed layers must be 0. + do k=1,nkml + hx2 = (h(i,j,k) + h(i,j+1,k) + h_neglect) + a(k) = (hx2 * I2htot) * (2.0 - 4.0*(z_topx2+0.5*hx2)*I2htot) + z_topx2 = z_topx2 + hx2 + if (a(k)*vDml(i) > 0.0) then + if (a(k)*vDml(i) > h_avail(i,j,k)) vDml(i) = h_avail(i,j,k) / a(k) + else + if (-a(k)*vDml(i) > h_avail(i,j+1,k)) vDml(i) = -h_avail(i,j+1,k)/a(k) + endif + enddo + do k=1,nkml + vhml(i,J,k) = a(k)*vDml(i) + vhtr(i,J,k) = vhtr(i,J,k) + vhml(i,J,k)*dt + enddo + endif + + vtimescale_diag(i,J) = timescale + vDml_diag(i,J) = vDml(i) + enddo ; enddo + + !$OMP do + do j=js,je ; do k=1,nkml ; do i=is,ie + h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & + ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) + if (h(i,j,k) < h_min) h(i,j,k) = h_min + enddo ; enddo ; enddo + !$OMP end parallel + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + if (CS%id_uhml > 0 .or. CS%id_vhml > 0) & + ! Remapped uhml and vhml require east/north halo updates of h + call pass_var(h, G%domain, To_West+To_South+Omit_Corners, halo=1) + call diag_update_remap_grids(CS%diag) + + ! Offer diagnostic fields for averaging. + if (query_averaging_enabled(CS%diag) .and. & + ((CS%id_urestrat_time > 0) .or. (CS%id_vrestrat_time > 0))) then + call post_data(CS%id_urestrat_time, utimescale_diag, CS%diag) + call post_data(CS%id_vrestrat_time, vtimescale_diag, CS%diag) + endif + if (query_averaging_enabled(CS%diag) .and. & + ((CS%id_uhml>0) .or. (CS%id_vhml>0))) then + do k=nkml+1,nz + do j=js,je ; do I=Isq,Ieq ; uhml(I,j,k) = 0.0 ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; vhml(i,J,k) = 0.0 ; enddo ; enddo + enddo + if (CS%id_uhml > 0) call post_data(CS%id_uhml, uhml, CS%diag) + if (CS%id_vhml > 0) call post_data(CS%id_vhml, vhml, CS%diag) + if (CS%id_MLD > 0) call post_data(CS%id_MLD, htot, CS%diag) + if (CS%id_Rml > 0) call post_data(CS%id_Rml, Rml_av, CS%diag) + if (CS%id_uDml > 0) call post_data(CS%id_uDml, uDml_diag, CS%diag) + if (CS%id_vDml > 0) call post_data(CS%id_vDml, vDml_diag, CS%diag) + endif + +end subroutine mixedlayer_restrat_BML + +! NOTE: This function appears to change answers on some platforms, so it is +! currently unused in the model, but we intend to introduce it in the future. + +!> Return the growth timescale for the submesoscale mixed layer eddies in [T ~> s] +real function growth_time(u_star, hBL, absf, h_neg, vonKar, Kv_rest, restrat_coef) + real, intent(in) :: u_star !< Surface friction velocity in thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1] + real, intent(in) :: hBL !< Boundary layer thickness including at least a negligible + !! value to keep it positive definite [H ~> m or kg m-2] + real, intent(in) :: absf !< Absolute value of the Coriolis parameter [T-1 ~> s-1] + real, intent(in) :: h_neg !< A tiny thickness that is usually lost in roundoff so can be + !! neglected [H ~> m or kg m-2] + real, intent(in) :: Kv_rest !< The background laminar vertical viscosity used for restratification, + !! rescaled into thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] + real, intent(in) :: vonKar !< The von Karman constant, used to scale the turbulent limits + !! on the restratification timescales [nondim] + real, intent(in) :: restrat_coef !< An overall scaling factor for the restratification timescale [nondim] + + ! Local variables + real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] + real :: Kv_eff ! An effective overall viscosity in thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] + real :: pi2 ! A scaling constant that is approximately pi^2 [nondim] + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + Kv_water + ! momentum mixing rate: pi^2*visc/h_ml^2 + pi2 = 9.8696 ! Approximately pi^2. This is more accurate than the overall uncertainty of the + ! scheme, with a value that is chosen to reproduce previous answers. + if (Kv_rest <= 0.0) then + ! This case reproduces the previous answers, but the extra h_neg is otherwise unnecessary. + mom_mixrate = (pi2*vonKar)*u_star**2 / (absf*hBL**2 + 4.0*(hBL + h_neg)*u_star) + growth_time = restrat_coef * (0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2)) + else + ! Set the mixing rate to the sum of a turbulent mixing rate and a laminar viscous rate. + ! mom_mixrate = pi2*vonKar*u_star**2 / (absf*hBL**2 + 4.0*hBL*u_star) + pi2*Kv_rest / hBL**2 + if (absf*hBL <= 4.0e-16*u_star) then + Kv_eff = pi2 * (Kv_rest + 0.25*vonKar*hBL*u_star) + else + Kv_eff = pi2 * (Kv_rest + vonKar*u_star**2*hBL / (absf*hBL + 4.0*u_star)) + endif + growth_time = (restrat_coef*0.0625) * ((hBL**2*(hBL**2*absf + 2.0*Kv_eff)) / ((hBL**2*absf)**2 + Kv_eff**2)) + endif + +end function growth_time + +!> Initialize the mixed layer restratification module +logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, restart_CS) + type(time_type), intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(inout) :: 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(param_file_type), intent(in) :: param_file !< Parameter file to parse + type(diag_ctrl), target, intent(inout) :: diag !< Regulate diagnostics + type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure + + ! Local variables + real :: flux_to_kg_per_s ! A unit conversion factor for fluxes. [kg T s-1 H-1 L-2 ~> kg m-3 or 1] + real :: omega ! The Earth's rotation rate [T-1 ~> s-1]. + real :: ustar_min_dflt ! The default value for RESTRAT_USTAR_MIN [Z T-1 ~> m s-1] + real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale + ! temperature variance [nondim] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags + ! This include declares and sets the variable "version". +# include "version_variable.h" + integer :: i, j + + ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & + default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, "", all_default=.not.mixedlayer_restrat_init) + call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & + "If true, a density-gradient dependent re-stratifying "//& + "flow is imposed in the mixed layer. Can be used in ALE mode "//& + "without restriction but in layer mode can only be used if "//& + "BULKMIXEDLAYER is true.", default=.false.) + if (.not. mixedlayer_restrat_init) return + + CS%initialized = .true. + + ! Nonsense values to cause problems when these parameters are not used + CS%MLE_MLD_decay_time = -9.e9*US%s_to_T + CS%MLE_density_diff = -9.e9*US%kg_m3_to_R + CS%MLE_tail_dh = -9.e9 + CS%MLE_use_PBL_MLD = .false. + CS%MLE_MLD_stretch = -9.e9 + CS%use_Stanley_ML = .false. + CS%use_Bodner = .false. + + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=.true.) + call openParameterBlock(param_file,'MLE') ! Prepend MLE% to all parameters + if (GV%nkml==0) then + call get_param(param_file, mdl, "USE_BODNER23", CS%use_Bodner, & + "If true, use the Bodner et al., 2023, formulation of the re-stratifying "//& + "mixed-layer restratification parameterization. This only works in ALE mode.", & + default=.false.) + endif + if (CS%use_Bodner) then + call get_param(param_file, mdl, "CR", CS%CR, & + "The efficiency coefficient in eq 27 of Bodner et al., 2023.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "BODNER_NSTAR", CS%Nstar, & + "The n* value used to estimate the turbulent vertical momentum flux "//& + "in Bodner et al., 2023, eq. 18. This is independent of the value used in "//& + "the PBL scheme but should be set to be the same for consistency.", & + units="nondim", default=0.066) + call get_param(param_file, mdl, "BODNER_MSTAR", CS%Mstar, & + "The m* value used to estimate the turbulent vertical momentum flux "//& + "in Bodner et al., 2023, eq. 18. This is independent of the value used in "//& + "the PBL scheme but should be set to be the same for consistency.", & + units="nondim", default=0.5) + call get_param(param_file, mdl, "BLD_GROWING_TFILTER", CS%BLD_growing_Tfilt, & + "The time-scale for a running-mean filter applied to the boundary layer "//& + "depth (BLD) when the BLD is deeper than the running mean. A value of 0 "//& + "instantaneously sets the running mean to the current value of BLD.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "BLD_DECAYING_TFILTER", CS%BLD_decaying_Tfilt, & + "The time-scale for a running-mean filter applied to the boundary layer "//& + "depth (BLD) when the BLD is shallower than the running mean. A value of 0 "//& + "instantaneously sets the running mean to the current value of BLD.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "MLD_GROWING_TFILTER", CS%MLD_growing_Tfilt, & + "The time-scale for a running-mean filter applied to the time-filtered "//& + "BLD, when the latter is deeper than the running mean. A value of 0 "//& + "instantaneously sets the running mean to the current value filtered BLD.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "MLD_DECAYING_TFILTER", CS%MLD_decaying_Tfilt, & + "The time-scale for a running-mean filter applied to the time-filtered "//& + "BLD, when the latter is shallower than the running mean. A value of 0 "//& + "instantaneously sets the running mean to the current value filtered BLD.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "ML_RESTRAT_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the mixed layer "//& + "restrat calculations. Values below 20240201 recover the answers from the end "//& + "of 2023, while higher values use the new cuberoot function in the Bodner code "//& + "to avoid needing to undo dimensional rescaling.", & + default=default_answer_date, & + do_not_log=.not.(CS%use_Bodner.and.(GV%Boussinesq.or.GV%semi_Boussinesq))) + call get_param(param_file, mdl, "MIN_WSTAR2", CS%min_wstar2, & + "The minimum lower bound to apply to the vertical momentum flux, w'u', "//& + "in the Bodner et al., restratification parameterization. This avoids "//& + "a division-by-zero in the limit when u* and the buoyancy flux are zero. "//& + "The default is less than the molecular viscosity of water times the Coriolis "//& + "parameter a micron away from the equator.", & + units="m2 s-2", default=1.0e-24, scale=US%m_to_Z**2*US%T_to_s**2) + call get_param(param_file, mdl, "TAIL_DH", CS%MLE_tail_dh, & + "Fraction by which to extend the mixed-layer restratification "//& + "depth used for a smoother stream function at the base of "//& + "the mixed-layer.", units="nondim", default=0.0) + call get_param(param_file, mdl, "USE_STANLEY_TVAR", CS%use_Stanley_ML, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in ML restrat code.", default=.false.) + call closeParameterBlock(param_file) ! The remaining parameters do not have MLE% prepended + call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & + "If true, the MLE parameterization will use the mixed-layer "//& + "depth provided by the active PBL parameterization. If false, "//& + "MLE will estimate a MLD based on a density difference with the "//& + "surface using the parameter MLE_DENSITY_DIFF.", default=.false.) + if (.not.CS%MLE_use_PBL_MLD) call MOM_error(FATAL, "mixedlayer_restrat_init: "// & + "To use MLE%USE_BODNER23=True then MLE_USE_PBL_MLD must be True.") + else + call closeParameterBlock(param_file) ! The remaining parameters do not have MLE% prepended + endif + + if (.not.CS%use_Bodner) then + ! This coefficient is used in both layered and ALE versions of Fox-Kemper but not Bodner + call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF", CS%ml_restrat_coef, & + "A nondimensional coefficient that is proportional to "//& + "the ratio of the deformation radius to the dominant "//& + "lengthscale of the submesoscale mixed layer "//& + "instabilities, times the minimum of the ratio of the "//& + "mesoscale eddy kinetic energy to the large-scale "//& + "geostrophic kinetic energy or 1 plus the square of the "//& + "grid spacing over the deformation radius, as detailed "//& + "by Fox-Kemper et al. (2010)", units="nondim", default=0.0) + ! These parameters are only used in the OM4-era version of Fox-Kemper + call get_param(param_file, mdl, "USE_STANLEY_ML", CS%use_Stanley_ML, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in ML restrat code.", default=.false.) + if (CS%use_Stanley_ML) then + call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & + "Coefficient correlating the temperature gradient and SGS T variance.", & + units="nondim", default=-1.0, do_not_log=.true.) + if (Stanley_coeff < 0.0) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ML is true.") + endif + call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) + ! We use GV%nkml to distinguish between the old and new implementation of MLE. + ! The old implementation only works for the layer model with nkml>0. + if (GV%nkml==0) then + call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF2", CS%ml_restrat_coef2, & + "As for FOX_KEMPER_ML_RESTRAT_COEF but used in a second application "//& + "of the MLE restratification parameterization.", units="nondim", default=0.0) + call get_param(param_file, mdl, "MLE_FRONT_LENGTH", CS%front_length, & + "If non-zero, is the frontal-length scale used to calculate the "//& + "upscaling of buoyancy gradients that is otherwise represented "//& + "by the parameter FOX_KEMPER_ML_RESTRAT_COEF. If MLE_FRONT_LENGTH is "//& + "non-zero, it is recommended to set FOX_KEMPER_ML_RESTRAT_COEF=1.0.",& + units="m", default=0.0, scale=US%m_to_L) + call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & + "If true, the MLE parameterization will use the mixed-layer "//& + "depth provided by the active PBL parameterization. If false, "//& + "MLE will estimate a MLD based on a density difference with the "//& + "surface using the parameter MLE_DENSITY_DIFF.", default=.false.) + call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME", CS%MLE_MLD_decay_time, & + "The time-scale for a running-mean filter applied to the mixed-layer "//& + "depth used in the MLE restratification parameterization. When "//& + "the MLD deepens below the current running-mean the running-mean "//& + "is instantaneously set to the current MLD.", units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME2", CS%MLE_MLD_decay_time2, & + "The time-scale for a running-mean filter applied to the filtered "//& + "mixed-layer depth used in a second MLE restratification parameterization. "//& + "When the MLD deepens below the current running-mean the running-mean "//& + "is instantaneously set to the current MLD.", units="s", default=0., scale=US%s_to_T) + if (.not. CS%MLE_use_PBL_MLD) then + call get_param(param_file, mdl, "MLE_DENSITY_DIFF", CS%MLE_density_diff, & + "Density difference used to detect the mixed-layer "//& + "depth used for the mixed-layer eddy parameterization "//& + "by Fox-Kemper et al. (2010)", units="kg/m3", default=0.03, scale=US%kg_m3_to_R) + endif + call get_param(param_file, mdl, "MLE_TAIL_DH", CS%MLE_tail_dh, & + "Fraction by which to extend the mixed-layer restratification "//& + "depth used for a smoother stream function at the base of "//& + "the mixed-layer.", units="nondim", default=0.0) + call get_param(param_file, mdl, "MLE_MLD_STRETCH", CS%MLE_MLD_stretch, & + "A scaling coefficient for stretching/shrinking the MLD "//& + "used in the MLE scheme. This simply multiplies MLD wherever used.",& + units="nondim", default=1.0) + endif + call get_param(param_file, mdl, "KV_RESTRAT", CS%Kv_restrat, & + "A small viscosity that sets a floor on the momentum mixing rate during "//& + "restratification. If this is positive, it will prevent some possible "//& + "divisions by zero even if ustar, RESTRAT_USTAR_MIN, and f are all 0.", & + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T*(US%Z_to_m*GV%m_to_H)) + call get_param(param_file, mdl, "OMEGA", omega, & + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) + ustar_min_dflt = 2.0e-4 * omega * (GV%Angstrom_Z + GV%dZ_subroundoff) + call get_param(param_file, mdl, "RESTRAT_USTAR_MIN", CS%ustar_min, & + "The minimum value of ustar that will be used by the mixed layer "//& + "restratification module. This can be tiny, but if this is greater than 0, "//& + "it will prevent divisions by zero when f and KV_RESTRAT are zero.", & + units="m s-1", default=US%Z_to_m*US%s_to_T*ustar_min_dflt, scale=GV%m_to_H*US%T_to_s) + endif + + CS%diag => diag + + flux_to_kg_per_s = GV%H_to_kg_m2 * US%L_to_m**2 * US%s_to_T + + CS%id_uhml = register_diag_field('ocean_model', 'uhml', diag%axesCuL, Time, & + 'Zonal Thickness Flux to Restratify Mixed Layer', & + 'kg s-1', conversion=flux_to_kg_per_s, y_cell_method='sum', v_extensive=.true.) + CS%id_vhml = register_diag_field('ocean_model', 'vhml', diag%axesCvL, Time, & + 'Meridional Thickness Flux to Restratify Mixed Layer', & + 'kg s-1', conversion=flux_to_kg_per_s, x_cell_method='sum', v_extensive=.true.) + CS%id_urestrat_time = register_diag_field('ocean_model', 'MLu_restrat_time', diag%axesCu1, Time, & + 'Mixed Layer Zonal Restratification Timescale', 's', conversion=US%T_to_s) + CS%id_vrestrat_time = register_diag_field('ocean_model', 'MLv_restrat_time', diag%axesCv1, Time, & + 'Mixed Layer Meridional Restratification Timescale', 's', conversion=US%T_to_s) + CS%id_MLD = register_diag_field('ocean_model', 'MLD_restrat', diag%axesT1, Time, & + 'Mixed Layer Depth as used in the mixed-layer restratification parameterization', & + 'm', conversion=GV%H_to_m) + CS%id_BLD = register_diag_field('ocean_model', 'BLD_restrat', diag%axesT1, Time, & + 'Boundary Layer Depth as used in the mixed-layer restratification parameterization', & + 'm', conversion=GV%H_to_m) + CS%id_Rml = register_diag_field('ocean_model', 'ML_buoy_restrat', diag%axesT1, Time, & + 'Mixed Layer Buoyancy as used in the mixed-layer restratification parameterization', & + 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) + CS%id_uDml = register_diag_field('ocean_model', 'udml_restrat', diag%axesCu1, Time, & + 'Transport stream function amplitude for zonal restratification of mixed layer', & + 'm3 s-1', conversion=GV%H_to_m*(US%L_to_m**2)*US%s_to_T) + CS%id_vDml = register_diag_field('ocean_model', 'vdml_restrat', diag%axesCv1, Time, & + 'Transport stream function amplitude for meridional restratification of mixed layer', & + 'm3 s-1', conversion=GV%H_to_m*(US%L_to_m**2)*US%s_to_T) + CS%id_uml = register_diag_field('ocean_model', 'uml_restrat', diag%axesCu1, Time, & + 'Surface zonal velocity component of mixed layer restratification', & + 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vml = register_diag_field('ocean_model', 'vml_restrat', diag%axesCv1, Time, & + 'Surface meridional velocity component of mixed layer restratification', & + 'm s-1', conversion=US%L_T_to_m_s) + if (CS%use_Bodner) then + CS%id_wpup = register_diag_field('ocean_model', 'MLE_wpup', diag%axesT1, Time, & + 'Vertical turbulent momentum flux in Bodner mixed layer restratification parameterization', & + 'm2 s-2', conversion=US%L_to_m*GV%H_to_m*US%s_to_T**2) + CS%id_ustar = register_diag_field('ocean_model', 'MLE_ustar', diag%axesT1, Time, & + 'Surface turbulent friction velocity, u*, in Bodner mixed layer restratification parameterization', & + 'm s-1', conversion=(US%Z_to_m*US%s_to_T)) + CS%id_bflux = register_diag_field('ocean_model', 'MLE_bflux', diag%axesT1, Time, & + 'Surface buoyancy flux, B0, in Bodner mixed layer restratification parameterization', & + 'm2 s-3', conversion=(US%Z_to_m**2*US%s_to_T**3)) + CS%id_lfbod = register_diag_field('ocean_model', 'lf_bodner', diag%axesT1, Time, & + 'Front length in Bodner mixed layer restratificiation parameterization', & + 'm', conversion=US%L_to_m) + endif + + ! If MLD_filtered is being used, we need to update halo regions after a restart + if (allocated(CS%MLD_filtered)) call pass_var(CS%MLD_filtered, G%domain) + if (allocated(CS%MLD_filtered_slow)) call pass_var(CS%MLD_filtered_slow, G%domain) + if (allocated(CS%wpup_filtered)) call pass_var(CS%wpup_filtered, G%domain) + +end function mixedlayer_restrat_init + +!> Allocate and register fields in the mixed layer restratification structure for restarts +subroutine mixedlayer_restrat_register_restarts(HI, GV, US, param_file, CS, restart_CS) + ! Arguments + type(hor_index_type), intent(in) :: HI !< Horizontal index 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 to parse + type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + + ! Local variables + character(len=64) :: mom_flux_units + logical :: mixedlayer_restrat_init, use_Bodner + + ! Check to see if this module will be used + call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & + default=.false., do_not_log=.true.) + if (.not. mixedlayer_restrat_init) return + + call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME", CS%MLE_MLD_decay_time, & + units="s", default=0., scale=US%s_to_T, do_not_log=.true.) + call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME2", CS%MLE_MLD_decay_time2, & + units="s", default=0., scale=US%s_to_T, do_not_log=.true.) + call openParameterBlock(param_file, 'MLE', do_not_log=.true.) + call get_param(param_file, mdl, "USE_BODNER23", use_Bodner, & + default=.false., do_not_log=.true.) + call closeParameterBlock(param_file) + if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0. .or. use_Bodner) then + ! CS%MLD_filtered is used to keep a running mean of the PBL's actively mixed MLD. + allocate(CS%MLD_filtered(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) + call register_restart_field(CS%MLD_filtered, "MLD_MLE_filtered", .false., restart_CS, & + longname="Time-filtered MLD for use in MLE", & + units=get_thickness_units(GV), conversion=GV%H_to_MKS) + endif + if (CS%MLE_MLD_decay_time2>0. .or. use_Bodner) then + ! CS%MLD_filtered_slow is used to keep a running mean of the PBL's seasonal or winter MLD. + allocate(CS%MLD_filtered_slow(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) + call register_restart_field(CS%MLD_filtered_slow, "MLD_MLE_filtered_slow", .false., restart_CS, & + longname="Slower time-filtered MLD for use in MLE", & + units=get_thickness_units(GV), conversion=GV%H_to_MKS) + endif + if (use_Bodner) then + ! CS%MLD_filtered_slow is used to keep a running mean of the PBL's seasonal or winter MLD. + mom_flux_units = "m2 s-2" ; if (.not.GV%Boussinesq) mom_flux_units = "kg m-1 s-2" + allocate(CS%wpup_filtered(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) + call register_restart_field(CS%wpup_filtered, "MLE_Bflux", .false., restart_CS, & + longname="Time-filtered vertical turbulent momentum flux for use in MLE", & + units=mom_flux_units, conversion=US%L_to_m*GV%H_to_mks*US%s_to_T**2 ) + endif + +end subroutine mixedlayer_restrat_register_restarts + +!> Returns true if a unit test of functions in MOM_mixedlayer_restrat fail. +!! Returns false otherwise. +logical function mixedlayer_restrat_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + type(mixedlayer_restrat_CS) :: CS ! Control structure + logical :: this_test + + print *,'===== mixedlayer_restrat: mixedlayer_restrat_unit_tests ==================' + + ! Tests of the shape function mu(z) + this_test = & + test_answer(verbose, mu(3.,0.), 0., 'mu(3)=0') + this_test = this_test .or. & + test_answer(verbose, mu(0.,0.), 0., 'mu(0)=0') + this_test = this_test .or. & + test_answer(verbose, mu(-0.25,0.), 0.7946428571428572, 'mu(-0.25)=0.7946...', tol=epsilon(1.)) + this_test = this_test .or. & + test_answer(verbose, mu(-0.5,0.), 1., 'mu(-0.5)=1') + this_test = this_test .or. & + test_answer(verbose, mu(-0.75,0.), 0.7946428571428572, 'mu(-0.75)=0.7946...', tol=epsilon(1.)) + this_test = this_test .or. & + test_answer(verbose, mu(-1.,0.), 0., 'mu(-1)=0') + this_test = this_test .or. & + test_answer(verbose, mu(-3.,0.), 0., 'mu(-3)=0') + this_test = this_test .or. & + test_answer(verbose, mu(-0.5,0.5), 1., 'mu(-0.5,0.5)=1') + this_test = this_test .or. & + test_answer(verbose, mu(-1.,0.5), 0.25, 'mu(-1,0.5)=0.25') + this_test = this_test .or. & + test_answer(verbose, mu(-1.5,0.5), 0., 'mu(-1.5,0.5)=0') + if (.not. this_test) print '(a)',' Passed tests of mu(z)' + mixedlayer_restrat_unit_tests = this_test + + ! Tests of the two time-scale running mean function + this_test = & + test_answer(verbose, rmean2ts(3.,2.,0.,0.,3.), 3., 'rmean2ts(3,2,0,0,3)=3') + this_test = this_test .or. & + test_answer(verbose, rmean2ts(1.,2.,0.,0.,3.), 1., 'rmean2ts(1,2,0,0,3)=1') + this_test = this_test .or. & + test_answer(verbose, rmean2ts(4.,0.,3.,0.,1.), 1., 'rmean2ts(4,0,3,0,1)=1') + this_test = this_test .or. & + test_answer(verbose, rmean2ts(0.,4.,0.,3.,1.), 3., 'rmean2ts(0,4,0,3,1)=3') + if (.not. this_test) print '(a)',' Passed tests of rmean2ts(s,f,g,d,dt)' + mixedlayer_restrat_unit_tests = mixedlayer_restrat_unit_tests .or. this_test + +end function mixedlayer_restrat_unit_tests + +!> Returns true if any cell of u and u_true are not identical. Returns false otherwise. +logical function test_answer(verbose, u, u_true, label, tol) + logical, intent(in) :: verbose !< If true, write results to stdout + real, intent(in) :: u !< Values to test + real, intent(in) :: u_true !< Values to test against (correct answer) + character(len=*), intent(in) :: label !< Message + real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true + ! Local variables + real :: tolerance ! The tolerance for differences between u and u_true + integer :: k + + tolerance = 0.0 ; if (present(tol)) tolerance = tol + test_answer = .false. + + if (abs(u - u_true) > tolerance) test_answer = .true. + if (test_answer .or. verbose) then + if (test_answer) then + print '(3(a,1pe24.16),x,a,x,a)','computed =',u,' correct =',u_true, & + ' err=',u-u_true,' < wrong',label + else + print '(2(a,1pe24.16),x,a)','computed =',u,' correct =',u_true,label + endif + endif + +end function test_answer + +!> \namespace mom_mixed_layer_restrat +!! +!! \section section_mle Mixed-layer eddy parameterization module +!! +!! The subroutines in this module implement a parameterization of unresolved viscous +!! mixed layer restratification of the mixed layer as described in Fox-Kemper et +!! al., 2008, and whose impacts are described in Fox-Kemper et al., 2011. +!! This is derived in part from the older parameterization that is described in +!! Hallberg (Aha Hulikoa, 2003), which this new parameterization surpasses, which +!! in turn is based on the sub-inertial mixed layer theory of Young (JPO, 1994). +!! There is no net horizontal volume transport due to this parameterization, and +!! no direct effect below the mixed layer. A revised of the parameterization by +!! Bodner et al., 2023, is also available as an option. +!! +!! This parameterization sets the restratification timescale to agree with +!! high-resolution studies of mixed layer restratification. +!! +!! The run-time parameter FOX_KEMPER_ML_RESTRAT_COEF is a non-dimensional number of +!! order a few tens, proportional to the ratio of the deformation radius or the +!! grid scale (whichever is smaller to the dominant horizontal length-scale of the +!! sub-meso-scale mixed layer instabilities. +!! +!! \subsection section_mle_nutshell "Sub-meso" in a nutshell +!! +!! The parameterization is colloquially referred to as "sub-meso". +!! +!! The original Fox-Kemper et al., (2008b) paper proposed a quasi-Stokes +!! advection described by the stream function (eq. 5 of Fox-Kemper et al., 2011): +!! \f[ +!! {\bf \Psi}_o = C_e \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} }{ |f| } \mu(z) +!! \f] +!! +!! where the vertical profile function is +!! \f[ +!! \mu(z) = \max \left\{ 0, \left[ 1 - \left(\frac{2z}{H}+1\right)^2 \right] +!! \left[ 1 + \frac{5}{21} \left(\frac{2z}{H}+1\right)^2 \right] \right\} +!! \f] +!! and \f$ H \f$ is the mixed-layer depth, \f$ f \f$ is the local Coriolis parameter, \f$ C_e \sim 0.06-0.08 \f$ and +!! \f$ \nabla \bar{b} \f$ is a depth mean buoyancy gradient averaged over the mixed layer. +!! +!! For use in coarse-resolution models, an upscaling of the buoyancy gradients and adaption for the equator +!! leads to the following parameterization (eq. 6 of Fox-Kemper et al., 2011): +!! \f[ +!! {\bf \Psi} = C_e \Gamma_\Delta \frac{\Delta s}{l_f} \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} } +!! { \sqrt{ f^2 + \tau^{-2}} } \mu(z) +!! \f] +!! where \f$ \Delta s \f$ is the minimum of grid-scale and deformation radius, +!! \f$ l_f \f$ is the width of the mixed-layer fronts, and \f$ \Gamma_\Delta=1 \f$. +!! \f$ \tau \f$ is a time-scale for mixing momentum across the mixed layer. +!! \f$ l_f \f$ is thought to be of order hundreds of meters. +!! +!! The upscaling factor \f$ \frac{\Delta s}{l_f} \f$ can be a global constant, model parameter FOX_KEMPER_ML_RESTRAT, +!! so that in practice the parameterization is: +!! \f[ +!! {\bf \Psi} = C_e \Gamma_\Delta \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} }{ \sqrt{ f^2 + \tau^{-2}} } \mu(z) +!! \f] +!! with non-unity \f$ \Gamma_\Delta \f$. +!! +!! \f$ C_e \f$ is hard-coded as 0.0625. \f$ \tau \f$ is calculated from the surface friction velocity \f$ u^* \f$. +!! \todo Explain expression for momentum mixing time-scale. +!! +!! | Symbol | Module parameter | +!! | ---------------------------- | --------------------- | +!! | \f$ \Gamma_\Delta \f$ | FOX_KEMPER_ML_RESTRAT | +!! | \f$ l_f \f$ | MLE_FRONT_LENGTH | +!! | \f$ \Delta \rho \f$ | MLE_DENSITY_DIFF | +!! +!! \subsection section_mle_filtering Time-filtering of mixed-layer depth +!! +!! Using the instantaneous mixed-layer depth is inconsistent with the finite life-time of +!! mixed-layer instabilities. We provide a one-sided running-mean filter of mixed-layer depth, \f$ H \f$, of the form: +!! \f[ +!! \bar{H} \leftarrow \max \left( H, \frac{ \Delta t H + \tau_h \bar{H} }{ \Delta t + \tau_h } \right) +!! \f] +!! which allows the effective mixed-layer depth seen by the parameterization, \f$\bar{H}\f$, to instantaneously deepen +!! but to decay with time-scale \f$ \tau_h \f$. +!! \f$ \bar{H} \f$ is substituted for \f$ H \f$ in the above equations. +!! +!! | Symbol | Module parameter | +!! | ---------------------------- | --------------------- | +!! | \f$ \tau_h \f$ | MLE_MLD_DECAY_TIME | +!! +!! \subsection section_mle_mld Defining the mixed-layer-depth +!! +!! If the parameter MLE_USE_PBL_MLD=True then the mixed-layer depth is defined/diagnosed by the +!! boundary-layer parameterization (e.g. ePBL, KPP, etc.). +!! +!! If the parameter MLE_USE_PBL_MLD=False then the mixed-layer depth is diagnosed in this module +!! as the depth of a given density difference, \f$ \Delta \rho \f$, with the surface where the +!! density difference is the parameter MLE_DENSITY_DIFF. +!! +!! \subsection The Bodner (2023) modification +!! +!! To use this variant of the parameterization, set MLE\%USE_BODNER23=True which then changes the +!! available parameters. +!! MLE_USE_PBL_MLD must be True to use the B23 modification. +!! +!! Bodner et al., 2023, (B23) use an expression for the frontal width which changes the scaling from \f$ H^2 \f$ +!! to \f$ h H^2 \f$: +!! \f[ +!! {\bf \Psi} = C_r \frac{\Delta s |f| \bar{h} \bar{H}^2 \nabla \bar{b} \times \hat{\bf z} } +!! { \left( m_*u_*^3 + n_* w_*^3 \right)^{2/3} } \mu(z) +!! \f] +!! (see eq. 27 of B23). +!! Here, the \f$h\f$ is the activate boundary layer depth, and \f$H\f$ is the mixed layer depth. +!! The denominator is an approximation of the vertical turbulent momentum flux \f$\overline{w'u'}\f$ (see +!! eq. 18 of B23) calculated from the surface friction velocity \f$u_*\f$, and from the surface buoyancy flux, +!! \f$B\f$, using the relation \f$ w_*^3 \sim -B h \f$. +!! An advantage of this form of "sub-meso" is the denominator is well behaved at the equator but we apply a +!! lower bound of \f$w_{min}^2\f$ to avoid division by zero under zero forcing. +!! As for the original Fox-Kemper parameterization, \f$\nabla \bar{b}\f$ is the buoyancy gradient averaged +!! over the mixed-layer. +!! +!! The instantaneous boundary layer depth, \f$h\f$, is time filtered primarily to remove the diurnal cycle: +!! \f[ +!! \bar{h} \leftarrow \max \left( +!! \min \left( h, \frac{ \Delta t h + \tau_{h+} \bar{h} }{ \Delta t + \tau_{h+} } \right), +!! \frac{ \Delta t h + \tau_{h-} \bar{h} }{ \Delta t + \tau_{h-} } \right) +!! \f] +!! Setting \f$ \tau_{h+}=0 \f$ means that when \f$ h>\bar{h} \f$ then \f$\bar{h}\leftarrow h\f$, i.e. the +!! effective (filtered) depth, \f$\bar{h}\f$, is instantly deepened. When \f$h<\bar{h}\f$ then the effective +!! depth shoals with time-scale \f$\tau_{h-}\f$. +!! +!! A second filter is applied to \f$\bar{h}\f$ to yield and effective "mixed layer depth", \f$\bar{H}\f$, +!! defined as the deepest the boundary layer over some time-scale \f$\tau_{H-}\f$: +!! \f[ +!! \bar{H} \leftarrow \max \left( +!! \min \left( \bar{h}, \frac{ \Delta t \bar{h} + \tau_{H+} \bar{H} }{ \Delta t + \tau_{H+} } \right), +!! \frac{ \Delta t \bar{h} + \tau_{h-} \bar{H} }{ \Delta t + \tau_{H-} } \right) +!! \f] +!! Again, setting \f$ \tau_{H+}=0 \f$ allows the effective mixed layer to instantly deepend to \f$ \bar{h} \f$. +!! +!! | Symbol | Module parameter | +!! | ---------------------------- | ------------------------- | +!! | \f$ C_r \f$ | MLE\%CR | +!! | \f$ n_* \f$ | MLE\%BODNER_NSTAR | +!! | \f$ m_* \f$ | MLE\%BODNER_MSTAR | +!! | \f$ w_* \f$ | MLE\%BODNER_MSTAR | +!! | \f$ w_{min}^2 \f$ | MLE\%MIN_WSTAR2 | +!! | \f$ \tau_{h+} \f$ | MLE\%BLD_GROWING_TFILTER | +!! | \f$ \tau_{h-} \f$ | MLE\%BLD_DECAYING_TFILTER | +!! | \f$ \tau_{H+} \f$ | MLE\%MLD_GROWING_TFILTER | +!! | \f$ \tau_{H-} \f$ | MLE\%BLD_DECAYING_TFILTER | +!! +!! \subsection section_mle_ref References +!! +!! Fox-Kemper, B., Ferrari, R. and Hallberg, R., 2008: +!! Parameterization of Mixed Layer Eddies. Part I: Theory and Diagnosis +!! J. Phys. Oceangraphy, 38 (6), p1145-1165. +!! https://doi.org/10.1175/2007JPO3792.1 +!! +!! Fox-Kemper, B. and Ferrari, R. 2008: +!! Parameterization of Mixed Layer Eddies. Part II: Prognosis and Impact +!! J. Phys. Oceangraphy, 38 (6), p1166-1179. +!! https://doi.org/10.1175/2007JPO3788.1 +!! +!! B. Fox-Kemper, G. Danabasoglu, R. Ferrari, S.M. Griffies, R.W. Hallberg, M.M. Holland, M.E. Maltrud, +!! S. Peacock, and B.L. Samuels, 2011: Parameterization of mixed layer eddies. III: Implementation and impact +!! in global ocean climate simulations. Ocean Modell., 39(1), p61-78. +!! https://doi.org/10.1016/j.ocemod.2010.09.002 +!! +!! A.S. Bodner, B. Fox-Kemper, L. Johnson, L. P. Van Roekel, J. C. McWilliams, P. P. Sullivan, P. S. Hall, +!! and J. Dong, 2023: Modifying the Mixed Layer Eddy Parameterization to Include Frontogenesis Arrest by +!! Boundary Layer Turbulence. J. Phys. Oceanogr., 53(1), p323-339. +!! https://doi.org/10.1175/JPO-D-21-0297.1 + +end module MOM_mixed_layer_restrat diff --git a/parameterizations/lateral/MOM_self_attr_load.F90 b/parameterizations/lateral/MOM_self_attr_load.F90 new file mode 100644 index 0000000000..7f7215c9d8 --- /dev/null +++ b/parameterizations/lateral/MOM_self_attr_load.F90 @@ -0,0 +1,277 @@ +module MOM_self_attr_load + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE +use MOM_domains, only : pass_var +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : read_param, get_param, log_version, param_file_type +use MOM_obsolete_params, only : obsolete_logical, obsolete_int +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_spherical_harmonics, only : spherical_harmonics_init, spherical_harmonics_end +use MOM_spherical_harmonics, only : spherical_harmonics_forward, spherical_harmonics_inverse +use MOM_spherical_harmonics, only : sht_CS, order2index, calc_lmax +use MOM_load_love_numbers, only : Love_Data + +implicit none ; private + +public calc_SAL, scalar_SAL_sensitivity, SAL_init, SAL_end + +#include + +!> The control structure for the MOM_self_attr_load module +type, public :: SAL_CS ; private + logical :: use_sal_scalar !< If true, use the scalar approximation to calculate SAL. + logical :: use_sal_sht !< If true, use online spherical harmonics to calculate SAL + logical :: use_tidal_sal_prev !< If true, read the tidal SAL from the previous iteration of + !! the tides to facilitate convergence. + real :: sal_scalar_value !< The constant of proportionality between sea surface height + !! (really it should be bottom pressure) anomalies and bottom + !! geopotential anomalies [nondim]. + type(sht_CS) :: sht !< Spherical harmonic transforms (SHT) control structure + integer :: sal_sht_Nd !< Maximum degree for SHT [nodim] + real, allocatable :: Love_Scaling(:) !< Love number for each SHT mode [nodim] + real, allocatable :: Snm_Re(:), & !< Real SHT coefficient for SHT SAL [Z ~> m] + Snm_Im(:) !< Imaginary SHT coefficient for SHT SAL [Z ~> m] +end type SAL_CS + +integer :: id_clock_SAL !< CPU clock for self-attraction and loading + +contains + +!> This subroutine calculates seawater self-attraction and loading based on sea surface height. This should +!! be changed into bottom pressure anomaly in the future. Note that the SAL calculation applies to all motions +!! across the spectrum. Tidal-specific methods that assume periodicity, i.e. iterative and read-in SAL, are +!! stored in MOM_tidal_forcing module. +subroutine calc_SAL(eta, eta_sal, G, CS, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from + !! a time-mean geoid [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_sal !< The sea surface height anomaly from + !! self-attraction and loading [Z ~> m]. + type(SAL_CS), intent(inout) :: CS !< The control structure returned by a previous call to SAL_init. + real, optional, intent(in) :: tmp_scale !< A rescaling factor to temporarily convert eta + !! to MKS units in reproducing sumes [m Z-1 ~> 1] + + ! Local variables + integer :: n, m, l + integer :: Isq, Ieq, Jsq, Jeq + integer :: i, j + real :: eta_prop ! The scalar constant of proportionality between eta and eta_sal [nondim] + + call cpu_clock_begin(id_clock_SAL) + + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + ! use the scalar approximation and/or iterative tidal SAL + if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then + call scalar_SAL_sensitivity(CS, eta_prop) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_sal(i,j) = eta_prop*eta(i,j) + enddo ; enddo + + ! use the spherical harmonics method + elseif (CS%use_sal_sht) then + call spherical_harmonics_forward(G, CS%sht, eta, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd, tmp_scale=tmp_scale) + + ! Multiply scaling factors to each mode + do m = 0,CS%sal_sht_Nd + l = order2index(m, CS%sal_sht_Nd) + do n = m,CS%sal_sht_Nd + CS%Snm_Re(l+n-m) = CS%Snm_Re(l+n-m) * CS%Love_Scaling(l+n-m) + CS%Snm_Im(l+n-m) = CS%Snm_Im(l+n-m) * CS%Love_Scaling(l+n-m) + enddo + enddo + + call spherical_harmonics_inverse(G, CS%sht, CS%Snm_Re, CS%Snm_Im, eta_sal, CS%sal_sht_Nd) + ! Halo was not calculated in spherical harmonic transforms. + call pass_var(eta_sal, G%domain) + + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_sal(i,j) = 0.0 + enddo ; enddo + endif + + call cpu_clock_end(id_clock_SAL) +end subroutine calc_SAL + +!> This subroutine calculates the partial derivative of the local geopotential height with the input +!! sea surface height due to the scalar approximation of self-attraction and loading. +subroutine scalar_SAL_sensitivity(CS, deta_sal_deta) + type(SAL_CS), intent(in) :: CS !< The control structure returned by a previous call to SAL_init. + real, intent(out) :: deta_sal_deta !< The partial derivative of eta_sal with + !! the local value of eta [nondim]. + + if (CS%use_sal_scalar .and. CS%use_tidal_sal_prev) then + deta_sal_deta = 2.0*CS%sal_scalar_value + elseif (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then + deta_sal_deta = CS%sal_scalar_value + else + deta_sal_deta = 0.0 + endif +end subroutine scalar_SAL_sensitivity + +!> This subroutine calculates coefficients of the spherical harmonic modes for self-attraction and loading. +!! The algorithm is based on the SAL implementation in MPAS-ocean, which was modified by Kristin Barton from +!! routine written by K. Quinn (March 2010) and modified by M. Schindelegger (May 2017). +subroutine calc_love_scaling(nlm, rhoW, rhoE, Love_Scaling) + integer, intent(in) :: nlm !< Maximum spherical harmonics degree [nondim] + real, intent(in) :: rhoW !< The average density of sea water [R ~> kg m-3] + real, intent(in) :: rhoE !< The average density of Earth [R ~> kg m-3] + real, dimension(:), intent(out) :: Love_Scaling !< Scaling factors for inverse SHT [nondim] + + ! Local variables + real, dimension(:), allocatable :: HDat, LDat, KDat ! Love numbers converted in CF reference frames [nondim] + real :: H1, L1, K1 ! Temporary variables to store degree 1 Love numbers [nondim] + integer :: n_tot ! Size of the stored Love numbers + integer :: n, m, l + + n_tot = size(Love_Data, dim=2) + + if (nlm+1 > n_tot) call MOM_error(FATAL, "MOM_tidal_forcing " // & + "calc_love_scaling: maximum spherical harmonics degree is larger than " // & + "the size of the stored Love numbers in MOM_load_love_number.") + + allocate(HDat(nlm+1), LDat(nlm+1), KDat(nlm+1)) + HDat(:) = Love_Data(2,1:nlm+1) ; LDat(:) = Love_Data(3,1:nlm+1) ; KDat(:) = Love_Data(4,1:nlm+1) + + ! Convert reference frames from CM to CF + if (nlm > 0) then + H1 = HDat(2) ; L1 = LDat(2) ; K1 = KDat(2) + HDat(2) = ( 2.0 / 3.0) * (H1 - L1) + LDat(2) = (-1.0 / 3.0) * (H1 - L1) + KDat(2) = (-1.0 / 3.0) * H1 - (2.0 / 3.0) * L1 - 1.0 + endif + + do m=0,nlm ; do n=m,nlm + l = order2index(m,nlm) + Love_Scaling(l+n-m) = (3.0 / real(2*n+1)) * (rhoW / rhoE) * (1.0 + KDat(n+1) - HDat(n+1)) + enddo ; enddo +end subroutine calc_love_scaling + +!> This subroutine initializes the self-attraction and loading control structure. +subroutine SAL_init(G, US, param_file, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. + type(SAL_CS), intent(inout) :: CS !< Self-attraction and loading control structure + + ! Local variables +# include "version_variable.h" + character(len=40) :: mdl = "MOM_self_attr_load" ! This module's name. + integer :: lmax ! Total modes of the real spherical harmonics [nondim] + real :: rhoW ! The average density of sea water [R ~> kg m-3]. + real :: rhoE ! The average density of Earth [R ~> kg m-3]. + + logical :: calculate_sal + logical :: tides, use_tidal_sal_file + real :: tide_sal_scalar_value ! Scaling SAL factor [nondim] + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, '', "TIDES", tides, default=.false., do_not_log=.True.) + call get_param(param_file, mdl, "CALCULATE_SAL", calculate_sal, "If true, calculate "//& + " self-attraction and loading.", default=tides, do_not_log=.True.) + if (.not. calculate_sal) return + + if (tides) then + call get_param(param_file, '', "USE_PREVIOUS_TIDES", CS%use_tidal_sal_prev, & + default=.false., do_not_log=.True.) + call get_param(param_file, '', "TIDAL_SAL_FROM_FILE", use_tidal_sal_file, & + default=.false., do_not_log=.True.) + endif + + call get_param(param_file, mdl, "SAL_SCALAR_APPROX", CS%use_sal_scalar, & + "If true, use the scalar approximation to calculate self-attraction and "//& + "loading.", default=tides .and. (.not. use_tidal_sal_file)) + call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", tide_sal_scalar_value, & + units="m m-1", default=0.0, do_not_log=.True.) + if (tide_sal_scalar_value/=0.0) & + call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& + "Use SAL_SCALAR_VALUE instead." ) + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & + "The constant of proportionality between sea surface "//& + "height (really it should be bottom pressure) anomalies "//& + "and bottom geopotential anomalies. This is only used if "//& + "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & + default=tide_sal_scalar_value, units="m m-1", & + do_not_log=(.not. CS%use_sal_scalar) .and. (.not. CS%use_tidal_sal_prev)) + call get_param(param_file, mdl, "SAL_HARMONICS", CS%use_sal_sht, & + "If true, use the online spherical harmonics method to calculate "//& + "self-attraction and loading.", default=.false.) + call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", CS%sal_sht_Nd, & + "The maximum degree of the spherical harmonics transformation used for "// & + "calculating the self-attraction and loading term.", & + default=0, do_not_log=(.not. CS%use_sal_sht)) + call get_param(param_file, '', "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, & + units="kg m-3", do_not_log=.True.) + call get_param(param_file, mdl, "RHO_SOLID_EARTH", rhoE, & + "The mean solid earth density. This is used for calculating the "// & + "self-attraction and loading term.", units="kg m-3", & + default=5517.0, scale=US%kg_m3_to_R, do_not_log=(.not. CS%use_sal_sht)) + + if (CS%use_sal_sht) then + lmax = calc_lmax(CS%sal_sht_Nd) + allocate(CS%Snm_Re(lmax)); CS%Snm_Re(:) = 0.0 + allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 + + allocate(CS%Love_Scaling(lmax)); CS%Love_Scaling(:) = 0.0 + call calc_love_scaling(CS%sal_sht_Nd, rhoW, rhoE, CS%Love_Scaling) + call spherical_harmonics_init(G, param_file, CS%sht) + endif + + id_clock_SAL = cpu_clock_id('(Ocean SAL)', grain=CLOCK_MODULE) + +end subroutine SAL_init + +!> This subroutine deallocates memory associated with the SAL module. +subroutine SAL_end(CS) + type(SAL_CS), intent(inout) :: CS !< The control structure returned by a previous call + !! to SAL_init; it is deallocated here. + if (CS%use_sal_sht) then + if (allocated(CS%Love_Scaling)) deallocate(CS%Love_Scaling) + if (allocated(CS%Snm_Re)) deallocate(CS%Snm_Re) + if (allocated(CS%Snm_Im)) deallocate(CS%Snm_Im) + call spherical_harmonics_end(CS%sht) + endif +end subroutine SAL_end + +!> \namespace self_attr_load +!! +!! This module contains methods to calculate self-attraction and loading (SAL) as a function of sea surface height (SSH) +!! (rather, it should be bottom pressure anomaly). SAL is primarily used for fast evolving processes like tides or +!! storm surges, but the effect applies to all motions. +!! +!! If SAL_SCALAR_APPROX is true, a scalar approximation is applied (Accad and Pekeris 1978) and the SAL is simply +!! a fraction (set by SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH . For tides, the scalar +!! approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, +!! Arbic et al. (2004)]. +!! +!! If SAL_HARMONICS is true, a more accurate online spherical harmonic transforms are used to calculate SAL. +!! Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is set by +!! SAL_HARMONICS_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean +!! developed by Los Alamos National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2023)]. +!! +!! References: +!! +!! Accad, Y. and Pekeris, C.L., 1978. Solution of the tidal equations for the M2 and S2 tides in the world oceans from a +!! knowledge of the tidal potential alone. Philosophical Transactions of the Royal Society of London. Series A, +!! Mathematical and Physical Sciences, 290(1368), pp.235-266. +!! https://doi.org/10.1098/rsta.1978.0083 +!! +!! Arbic, B.K., Garner, S.T., Hallberg, R.W. and Simmons, H.L., 2004. The accuracy of surface elevations in forward +!! global barotropic and baroclinic tide models. Deep Sea Research Part II: Topical Studies in Oceanography, 51(25-26), +!! pp.3069-3101. +!! https://doi.org/10.1016/j.dsr2.2004.09.014 +!! +!! Barton, K.N., Pal, N., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J.J., +!! Wirasaet, D. and Schindelegger, M., 2022. Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in +!! MPAS‐Ocean. Journal of Advances in Modeling Earth Systems, 14(11), p.e2022MS003207. +!! https://doi.org/10.1029/2022MS003207 +!! +!! Brus, S.R., Barton, K.N., Pal, N., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., +!! Westerink, J.J. and Schindelegger, M., 2023. Scalable self attraction and loading calculations for unstructured ocean +!! tide models. Ocean Modelling, p.102160. +!! https://doi.org/10.1016/j.ocemod.2023.102160 +end module MOM_self_attr_load diff --git a/parameterizations/lateral/MOM_spherical_harmonics.F90 b/parameterizations/lateral/MOM_spherical_harmonics.F90 new file mode 100644 index 0000000000..26258e6b8e --- /dev/null +++ b/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -0,0 +1,395 @@ +!> Laplace's spherical harmonic transforms (SHT) +module MOM_spherical_harmonics +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, & + CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP +use MOM_error_handler, only : MOM_error, FATAL +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_coms_infra, only : sum_across_PEs +use MOM_coms, only : reproducing_sum + +implicit none ; private + +public spherical_harmonics_init, spherical_harmonics_end, order2index, calc_lmax +public spherical_harmonics_forward, spherical_harmonics_inverse + +#include + +!> Control structure for spherical harmonic transforms +type, public :: sht_CS ; private + logical :: initialized = .False. !< True if this control structure has been initialized. + integer :: ndegree !< Maximum degree of the spherical harmonics [nondim]. + integer :: lmax !< Number of associated Legendre polynomials of nonnegative m + !! [lmax=(ndegree+1)*(ndegree+2)/2] [nondim]. + real, allocatable :: cos_clatT(:,:) !< Precomputed cosine of colatitude at the t-cells [nondim]. + real, allocatable :: Pmm(:,:,:) !< Precomputed associated Legendre polynomials (m=n) at the t-cells [nondim]. + real, allocatable :: cos_lonT(:,:,:), & !< Precomputed cosine factors at the t-cells [nondim]. + sin_lonT(:,:,:) !< Precomputed sine factors at the t-cells [nondim]. + real, allocatable :: cos_lonT_wtd(:,:,:), & !< Precomputed area-weighted cosine factors at the t-cells [nondim] + sin_lonT_wtd(:,:,:) !< Precomputed area-weighted sine factors at the t-cells [nondim] + real, allocatable :: a_recur(:,:), & !< Precomputed recurrence coefficients a [nondim]. + b_recur(:,:) !< Precomputed recurrence coefficients b [nondim]. + real, allocatable :: Snm_Re_raw(:,:,:), & !< Array to store un-summed SHT coefficients + Snm_Im_raw(:,:,:) !< at the t-cells for reproducing sums [same as input variable] + logical :: reprod_sum !< True if use reproducible global sums +end type sht_CS + +integer :: id_clock_sht=-1 !< CPU clock for SHT [MODULE] +integer :: id_clock_sht_forward=-1 !< CPU clock for forward transforms [ROUTINE] +integer :: id_clock_sht_inverse=-1 !< CPU clock for inverse transforms [ROUTINE] +integer :: id_clock_sht_global_sum=-1 !< CPU clock for global summation in forward transforms [LOOP] + +contains + +!> Calculates forward spherical harmonics transforms +subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(sht_CS), intent(inout) :: CS !< Control structure for SHT + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: var !< Input 2-D variable [A] + real, intent(out) :: Snm_Re(:) !< SHT coefficients for the real modes (cosine) [A] + real, intent(out) :: Snm_Im(:) !< SHT coefficients for the imaginary modes (sine) [A] + integer, optional, intent(in) :: Nd !< Maximum degree of the spherical harmonics + !! overriding ndegree in the CS [nondim] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor to convert + !! var to MKS units during the reproducing + !! sums [a A-1 ~> 1] + ! local variables + integer :: Nmax ! Local copy of the maximum degree of the spherical harmonics + integer :: Ltot ! Local copy of the number of spherical harmonics + real, dimension(SZI_(G),SZJ_(G)) :: & + pmn, & ! Current associated Legendre polynomials of degree n and order m [nondim] + pmnm1, & ! Associated Legendre polynomials of degree n-1 and order m [nondim] + pmnm2 ! Associated Legendre polynomials of degree n-2 and order m [nondim] + real :: scale ! A rescaling factor to temporarily convert var to MKS units during the + ! reproducing sums [a A-1 ~> 1] + real :: I_scale ! The inverse of scale [A a-1 ~> 1] + real :: sum_tot ! The total of all components output by the reproducing sum in arbitrary units [a] + integer :: i, j, k + integer :: is, ie, js, je, isd, ied, jsd, jed + integer :: m, n, l + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_spherical_harmonics " // & + "spherical_harmonics_forward: Module must be initialized before it is used.") + + if (id_clock_sht>0) call cpu_clock_begin(id_clock_sht) + if (id_clock_sht_forward>0) call cpu_clock_begin(id_clock_sht_forward) + + Nmax = CS%ndegree; if (present(Nd)) Nmax = Nd + Ltot = calc_lmax(Nmax) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + do j=jsd,jed ; do i=isd,ied + pmn(i,j) = 0.0; pmnm1(i,j) = 0.0; pmnm2(i,j) = 0.0 + enddo ; enddo + + do l=1,Ltot ; Snm_Re(l) = 0.0; Snm_Im(l) = 0.0 ; enddo + + if (CS%reprod_sum) then + scale = 1.0 ; if (present(tmp_scale)) scale = tmp_scale + do m=0,Nmax + l = order2index(m, Nmax) + + do j=js,je ; do i=is,ie + CS%Snm_Re_raw(i,j,l) = (scale*var(i,j)) * CS%Pmm(i,j,m+1) * CS%cos_lonT_wtd(i,j,m+1) + CS%Snm_Im_raw(i,j,l) = (scale*var(i,j)) * CS%Pmm(i,j,m+1) * CS%sin_lonT_wtd(i,j,m+1) + pmnm2(i,j) = 0.0 + pmnm1(i,j) = CS%Pmm(i,j,m+1) + enddo ; enddo + + do n = m+1, Nmax ; do j=js,je ; do i=is,ie + pmn(i,j) = & + CS%a_recur(n+1,m+1) * CS%cos_clatT(i,j) * pmnm1(i,j) - CS%b_recur(n+1,m+1) * pmnm2(i,j) + CS%Snm_Re_raw(i,j,l+n-m) = (scale*var(i,j)) * pmn(i,j) * CS%cos_lonT_wtd(i,j,m+1) + CS%Snm_Im_raw(i,j,l+n-m) = (scale*var(i,j)) * pmn(i,j) * CS%sin_lonT_wtd(i,j,m+1) + pmnm2(i,j) = pmnm1(i,j) + pmnm1(i,j) = pmn(i,j) + enddo ; enddo ; enddo + enddo + else + do m=0,Nmax + l = order2index(m, Nmax) + + do j=js,je ; do i=is,ie + Snm_Re(l) = Snm_Re(l) + var(i,j) * CS%Pmm(i,j,m+1) * CS%cos_lonT_wtd(i,j,m+1) + Snm_Im(l) = Snm_Im(l) + var(i,j) * CS%Pmm(i,j,m+1) * CS%sin_lonT_wtd(i,j,m+1) + pmnm2(i,j) = 0.0 + pmnm1(i,j) = CS%Pmm(i,j,m+1) + enddo ; enddo + + do n=m+1, Nmax ; do j=js,je ; do i=is,ie + pmn(i,j) = & + CS%a_recur(n+1,m+1) * CS%cos_clatT(i,j) * pmnm1(i,j) - CS%b_recur(n+1,m+1) * pmnm2(i,j) + Snm_Re(l+n-m) = Snm_Re(l+n-m) + var(i,j) * pmn(i,j) * CS%cos_lonT_wtd(i,j,m+1) + Snm_Im(l+n-m) = Snm_Im(l+n-m) + var(i,j) * pmn(i,j) * CS%sin_lonT_wtd(i,j,m+1) + pmnm2(i,j) = pmnm1(i,j) + pmnm1(i,j) = pmn(i,j) + enddo ; enddo ; enddo + enddo + endif + + if (id_clock_sht_global_sum>0) call cpu_clock_begin(id_clock_sht_global_sum) + + if (CS%reprod_sum) then + sum_tot = reproducing_sum(CS%Snm_Re_raw(:,:,1:Ltot), sums=Snm_Re(1:Ltot)) + sum_tot = reproducing_sum(CS%Snm_Im_raw(:,:,1:Ltot), sums=Snm_Im(1:Ltot)) + if (scale /= 1.0) then + I_scale = 1.0 / scale + do l=1,Ltot + Snm_Re(l) = I_scale * Snm_Re(l) + Snm_Im(l) = I_scale * Snm_Im(l) + enddo + endif + else + call sum_across_PEs(Snm_Re, Ltot) + call sum_across_PEs(Snm_Im, Ltot) + endif + + if (id_clock_sht_global_sum>0) call cpu_clock_end(id_clock_sht_global_sum) + if (id_clock_sht_forward>0) call cpu_clock_end(id_clock_sht_forward) + if (id_clock_sht>0) call cpu_clock_end(id_clock_sht) +end subroutine spherical_harmonics_forward + +!> Calculates inverse spherical harmonics transforms +subroutine spherical_harmonics_inverse(G, CS, Snm_Re, Snm_Im, var, Nd) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(sht_CS), intent(in) :: CS !< Control structure for SHT + real, intent(in) :: Snm_Re(:) !< SHT coefficients for the real modes (cosine) [A] + real, intent(in) :: Snm_Im(:) !< SHT coefficients for the imaginary modes (sine) [A] + real, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: var !< Output 2-D variable [A] + integer, optional, intent(in) :: Nd !< Maximum degree of the spherical harmonics + !! overriding ndegree in the CS [nondim] + ! local variables + integer :: Nmax ! Local copy of the maximum degree of the spherical harmonics [nondim] + real :: mFac ! A constant multiplier. mFac = 1 (if m==0) or 2 (if m>0) [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: & + pmn, & ! Current associated Legendre polynomials of degree n and order m [nondim] + pmnm1, & ! Associated Legendre polynomials of degree n-1 and order m [nondim] + pmnm2 ! Associated Legendre polynomials of degree n-2 and order m [nondim] + integer :: i, j, k + integer :: is, ie, js, je, isd, ied, jsd, jed + integer :: m, n, l + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_spherical_harmonics " // & + "spherical_harmonics_inverse: Module must be initialized before it is used.") + + if (id_clock_sht>0) call cpu_clock_begin(id_clock_sht) + if (id_clock_sht_inverse>0) call cpu_clock_begin(id_clock_sht_inverse) + + Nmax = CS%ndegree; if (present(Nd)) Nmax = Nd + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + do j=jsd,jed ; do i=isd,ied + pmn(i,j) = 0.0; pmnm1(i,j) = 0.0; pmnm2(i,j) = 0.0 + var(i,j) = 0.0 + enddo ; enddo + + do m=0,Nmax + mFac = sign(1.0, m-0.5)*0.5 + 1.5 + l = order2index(m, Nmax) + + do j=js,je ; do i=is,ie + var(i,j) = var(i,j) & + + mFac * CS%Pmm(i,j,m+1) * ( Snm_Re(l) * CS%cos_lonT(i,j,m+1) & + + Snm_Im(l) * CS%sin_lonT(i,j,m+1)) + pmnm2(i,j) = 0.0 + pmnm1(i,j) = CS%Pmm(i,j,m+1) + enddo ; enddo + + do n=m+1,Nmax ; do j=js,je ; do i=is,ie + pmn(i,j) = & + CS%a_recur(n+1,m+1) * CS%cos_clatT(i,j) * pmnm1(i,j) - CS%b_recur(n+1,m+1) * pmnm2(i,j) + var(i,j) = var(i,j) & + + mFac * pmn(i,j) * ( Snm_Re(l+n-m) * CS%cos_lonT(i,j,m+1) & + + Snm_Im(l+n-m) * CS%sin_lonT(i,j,m+1)) + pmnm2(i,j) = pmnm1(i,j) + pmnm1(i,j) = pmn(i,j) + enddo ; enddo ; enddo + enddo + + if (id_clock_sht_inverse>0) call cpu_clock_end(id_clock_sht_inverse) + if (id_clock_sht>0) call cpu_clock_end(id_clock_sht) +end subroutine spherical_harmonics_inverse + +!> Calculate precomputed coefficients +subroutine spherical_harmonics_init(G, param_file, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating + type(sht_CS), intent(inout) :: CS !< Control structure for spherical harmonic transforms + + ! local variables + real, parameter :: PI = 4.0*atan(1.0) ! 3.1415926... calculated as 4*atan(1) [nondim] + real, parameter :: RADIAN = PI / 180.0 ! Degree to Radian constant [rad/degree] + real, dimension(SZI_(G),SZJ_(G)) :: sin_clatT ! sine of colatitude at the t-cells [nondim]. + real :: Pmm_coef ! = sqrt{ 1.0/(4.0*PI) * prod[(2k+1)/2k)] } [nondim]. + integer :: is, ie, js, je + integer :: i, j, k + integer :: m, n + integer :: Nd_SAL ! Maximum degree for SAL + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_spherical_harmonics" ! This module's name. + + if (CS%initialized) return + CS%initialized = .True. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", Nd_SAL, "", default=0, do_not_log=.true.) + CS%ndegree = Nd_SAL + CS%lmax = calc_lmax(CS%ndegree) + call get_param(param_file, mdl, "SHT_REPRODUCING_SUM", CS%reprod_sum, & + "If true, use reproducing sums (invariant to PE layout) in inverse transform "// & + "of spherical harmonics. Otherwise use a simple sum of floating point numbers. ", & + default=.False.) + + ! Calculate recurrence relationship coefficients + allocate(CS%a_recur(CS%ndegree+1, CS%ndegree+1)); CS%a_recur(:,:) = 0.0 + allocate(CS%b_recur(CS%ndegree+1, CS%ndegree+1)); CS%b_recur(:,:) = 0.0 + do m=0,CS%ndegree ; do n=m+1,CS%ndegree + ! These expressione will give NaNs with 32-bit integers for n > 23170, but this is trapped elsewhere. + CS%a_recur(n+1,m+1) = sqrt(real((2*n-1) * (2*n+1)) / real((n-m) * (n+m))) + CS%b_recur(n+1,m+1) = sqrt((real(2*n+1) * real((n+m-1) * (n-m-1))) / (real((n-m) * (n+m)) * real(2*n-3))) + enddo ; enddo + + ! Calculate complex exponential factors + allocate(CS%cos_lonT_wtd(is:ie, js:je, CS%ndegree+1)); CS%cos_lonT_wtd(:,:,:) = 0.0 + allocate(CS%sin_lonT_wtd(is:ie, js:je, CS%ndegree+1)); CS%sin_lonT_wtd(:,:,:) = 0.0 + allocate(CS%cos_lonT(is:ie, js:je, CS%ndegree+1)); CS%cos_lonT(:,:,:) = 0.0 + allocate(CS%sin_lonT(is:ie, js:je, CS%ndegree+1)); CS%sin_lonT(:,:,:) = 0.0 + do m=0,CS%ndegree + do j=js,je ; do i=is,ie + CS%cos_lonT(i,j,m+1) = cos(real(m) * (G%geolonT(i,j)*RADIAN)) + CS%sin_lonT(i,j,m+1) = sin(real(m) * (G%geolonT(i,j)*RADIAN)) + CS%cos_lonT_wtd(i,j,m+1) = CS%cos_lonT(i,j,m+1) * G%areaT(i,j) / G%Rad_Earth_L**2 + CS%sin_lonT_wtd(i,j,m+1) = CS%sin_lonT(i,j,m+1) * G%areaT(i,j) / G%Rad_Earth_L**2 + enddo ; enddo + enddo + + ! Calculate sine and cosine of colatitude + allocate(CS%cos_clatT(is:ie, js:je)); CS%cos_clatT(:,:) = 0.0 + do j=js,je ; do i=is,ie + CS%cos_clatT(i,j) = cos(0.5*PI - G%geolatT(i,j)*RADIAN) + sin_clatT(i,j) = sin(0.5*PI - G%geolatT(i,j)*RADIAN) + enddo ; enddo + + ! Calculate the diagonal elements of the associated Legendre polynomials (n=m) + allocate(CS%Pmm(is:ie,js:je,m+1)); CS%Pmm(:,:,:) = 0.0 + do m=0,CS%ndegree + Pmm_coef = 1.0/(4.0*PI) + do k=1,m ; Pmm_coef = Pmm_coef * (real(2*k+1) / real(2*k)); enddo + Pmm_coef = sqrt(Pmm_coef) + do j=js,je ; do i=is,ie + CS%Pmm(i,j,m+1) = Pmm_coef * (sin_clatT(i,j)**m) + enddo ; enddo + enddo + + if (CS%reprod_sum) then + allocate(CS%Snm_Re_raw(is:ie, js:je, CS%lmax)); CS%Snm_Re_raw = 0.0 + allocate(CS%Snm_Im_raw(is:ie, js:je, CS%lmax)); CS%Snm_Im_raw = 0.0 + endif + + id_clock_sht = cpu_clock_id('(Ocean spherical harmonics)', grain=CLOCK_MODULE) + id_clock_sht_forward = cpu_clock_id('(Ocean SHT forward)', grain=CLOCK_ROUTINE) + id_clock_sht_inverse = cpu_clock_id('(Ocean SHT inverse)', grain=CLOCK_ROUTINE) + id_clock_sht_global_sum = cpu_clock_id('(Ocean SHT global sum)', grain=CLOCK_LOOP) + +end subroutine spherical_harmonics_init + +!> Deallocate any variables allocated in spherical_harmonics_init +subroutine spherical_harmonics_end(CS) + type(sht_CS), intent(inout) :: CS !< Control structure for spherical harmonic transforms + + deallocate(CS%cos_clatT) + deallocate(CS%Pmm) + deallocate(CS%cos_lonT_wtd, CS%sin_lonT_wtd, CS%cos_lonT, CS%sin_lonT) + deallocate(CS%a_recur, CS%b_recur) + if (CS%reprod_sum) & + deallocate(CS%Snm_Re_raw, CS%Snm_Im_raw) +end subroutine spherical_harmonics_end + +!> Calculates the number of real elements (cosine) of spherical harmonics given maximum degree Nd. +function calc_lmax(Nd) result(lmax) + integer :: lmax !< Number of real spherical harmonic modes [nondim] + integer, intent(in) :: Nd !< Maximum degree [nondim] + + lmax = (Nd+2) * (Nd+1) / 2 +end function calc_lmax + +!> Calculates the one-dimensional index number at (n=0, m=m), given order m and maximum degree Nd. +!! It is sequenced with degree (n) changing first and order (m) changing second. +function order2index(m, Nd) result(l) + integer :: l !< One-dimensional index number [nondim] + integer, intent(in) :: m !< Current order number [nondim] + integer, intent(in) :: Nd !< Maximum degree [nondim] + + l = ((Nd+1) + (Nd+1-(m-1)))*m/2 + 1 +end function order2index + +!> \namespace mom_spherical_harmonics +!! +!! This module contains the subroutines to calculate spherical harmonic transforms (SHT), namely, forward transform +!! of a two-dimensional field into a given number of spherical harmonic modes and its inverse transform. This module +!! is primarily used to but not limited to calculate self-attraction and loading (SAL) term, which is mostly relevant to +!! high frequency motions such as tides. Should other needs arise in the future, this API can be easily modified. +!! Currently, the transforms are for t-cell fields only. +!! +!! This module is stemmed from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los +!! Alamos National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2023)]. The algorithm +!! for forward and inverse transforms loosely follows Schaeffer (2013). +!! +!! In forward transform, a two-dimensional physical field can be projected into a series of spherical harmonics. The +!! spherical harmonic coefficient of degree n and order m for a field \f$f(\theta, \phi)\f$ is calculated as follows: +!! \f[ +!! f^m_n = \int^{2\pi}_{0}\int^{\pi}_{0}f(\theta,\phi)Y^m_n(\theta,\phi)\sin\theta d\theta d\phi +!! \f] +!! and +!! \f[ +!! Y^m_n(\theta,\phi) = P^m_n(\cos\theta)\exp(im\phi) +!! \f] +!! where \f$P^m_n(\cos \theta)\f$ is the normalized associated Legendre polynomial of degree n and order m. \f$\phi\f$ +!! is the longitude and \f$\theta\f$ is the colatitude. +!! Or, written in the discretized form: +!! \f[ +!! f^m_n = \sum^{Nj}_{0}\sum^{Ni}_{0}f(i,j)Y^m_n(i,j)A(i,j)/r_e^2 +!! \f] +!! where $A$ is the area of the cell and $r_e$ is the radius of the Earth. +!! +!! In inverse transform, the first N degree spherical harmonic coefficients are used to reconstruct a two-dimensional +!! physical field: +!! \f[ +!! f(\theta,\phi) = \sum^N_{n=0}\sum^{n}_{m=-n}f^m_nY^m_n(\theta,\phi) +!! \f] +!! +!! The exponential coefficients are pre-computed and stored in the memory. The associated Legendre polynomials are +!! computed "on-the-fly", using the recurrence relationships to avoid large memory usage and take the advantage of +!! array vectorization. +!! +!! The maximum degree of the spherical harmonics is a runtime parameter and the maximum used by all SHT applications. +!! At the moment, it is only decided by SAL_HARMONICS_DEGREE. +!! +!! The forward transforms involve a global summation. Runtime flag SHT_REPRODUCING_SUM controls whether this is done +!! in a bit-wise reproducing way or not. +!! +!! References: +!! +!! Barton, K.N., Pal, N., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J.J., +!! Wirasaet, D. and Schindelegger, M., 2022. Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in +!! MPAS‐Ocean. Journal of Advances in Modeling Earth Systems, 14(11), p.e2022MS003207. +!! https://doi.org/10.1029/2022MS003207 +!! +!! Brus, S.R., Barton, K.N., Pal, N., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., +!! Westerink, J.J. and Schindelegger, M., 2023. Scalable self attraction and loading calculations for unstructured ocean +!! tide models. Ocean Modelling, p.102160. +!! https://doi.org/10.1016/j.ocemod.2023.102160 +!! +!! Schaeffer, N., 2013. Efficient spherical harmonic transforms aimed at pseudospectral numerical simulations. +!! Geochemistry, Geophysics, Geosystems, 14(3), pp.751-758. +!! https://doi.org/10.1002/ggge.20071 +end module MOM_spherical_harmonics diff --git a/parameterizations/lateral/MOM_thickness_diffuse.F90 b/parameterizations/lateral/MOM_thickness_diffuse.F90 new file mode 100644 index 0000000000..c3e251a7e9 --- /dev/null +++ b/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -0,0 +1,2502 @@ +!> Isopycnal height diffusion (or Gent McWilliams diffusion) +module MOM_thickness_diffuse + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : hchksum, uvchksum +use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type +use MOM_diag_mediator, only : diag_update_remap_grids +use MOM_domains, only : pass_var, CORNER, pass_vector +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : calculate_density_second_derivs +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : MOM_read_data, slasher +use MOM_interface_heights, only : find_eta, thickness_to_dz +use MOM_isopycnal_slopes, only : vert_fill_TS +use MOM_lateral_mixing_coeffs, only : VarMix_CS +use MOM_MEKE_types, only : MEKE_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, cont_diag_ptrs +use MOM_verticalGrid, only : verticalGrid_type +implicit none ; private + +#include + +public thickness_diffuse, thickness_diffuse_init, thickness_diffuse_end +public thickness_diffuse_get_KH + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure for thickness_diffuse +type, public :: thickness_diffuse_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + real :: Khth !< Background isopycnal depth diffusivity [L2 T-1 ~> m2 s-1] + real :: Khth_Slope_Cff !< Slope dependence coefficient of Khth [nondim] + real :: Grad_L_Scale !< Gradient model coefficient [nondim] + real :: max_Khth_CFL !< Maximum value of the diffusive CFL for isopycnal height diffusion [nondim] + real :: Khth_Min !< Minimum value of Khth [L2 T-1 ~> m2 s-1] + real :: Khth_Max !< Maximum value of Khth [L2 T-1 ~> m2 s-1], or 0 for no max + real :: Kh_eta_bg !< Background isopycnal height diffusivity [L2 T-1 ~> m2 s-1] + real :: Kh_eta_vel !< Velocity scale that is multiplied by the grid spacing to give + !! the isopycnal height diffusivity [L T-1 ~> m s-1] + real :: slope_max !< Slopes steeper than slope_max are limited in some way [Z L-1 ~> nondim] + real :: kappa_smooth !< Vertical diffusivity used to interpolate more sensible values + !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + logical :: thickness_diffuse !< If true, interfaces heights are diffused. + logical :: use_FGNV_streamfn !< If true, use the streamfunction formulation of + !! Ferrari et al., 2010, which effectively emphasizes + !! graver vertical modes by smoothing in the vertical. + real :: FGNV_scale !< A coefficient scaling the vertical smoothing term in the + !! Ferrari et al., 2010, streamfunction formulation [nondim]. + real :: FGNV_c_min !< A minimum wave speed used in the Ferrari et al., 2010, + !! streamfunction formulation [L T-1 ~> m s-1]. + real :: N2_floor !< A floor for squared buoyancy frequency in the Ferrari et al., 2010, + !! streamfunction formulation [T-2 ~> s-2]. + logical :: detangle_interfaces !< If true, add 3-d structured interface height + !! diffusivities to horizontally smooth jagged layers. + real :: detangle_time !< If detangle_interfaces is true, this is the + !! timescale over which maximally jagged grid-scale + !! thickness variations are suppressed [T ~> s]. This must be + !! longer than DT, or 0 (the default) to use DT. + integer :: nkml !< number of layers within mixed layer + logical :: debug !< write verbose checksums for debugging purposes + logical :: use_GME_thickness_diffuse !< If true, passes GM coefficients to MOM_hor_visc for use + !! with GME closure. + logical :: MEKE_GEOMETRIC !< If true, uses the GM coefficient formulation from the GEOMETRIC + !! framework (Marshall et al., 2012) + real :: MEKE_GEOMETRIC_alpha!< The nondimensional coefficient governing the efficiency of + !! the GEOMETRIC isopycnal height diffusion [nondim] + real :: MEKE_GEOMETRIC_epsilon !< Minimum Eady growth rate for the GEOMETRIC thickness + !! diffusivity [T-1 ~> s-1]. + integer :: MEKE_GEOM_answer_date !< The vintage of the expressions in the MEKE_GEOMETRIC + !! calculation. Values below 20190101 recover the answers from the + !! original implementation, while higher values use expressions that + !! satisfy rotational symmetry. + logical :: Use_KH_in_MEKE !< If true, uses the isopycnal height diffusivity calculated here to diffuse MEKE. + real :: MEKE_min_depth_diff !< The minimum total depth over which to average the diffusivity + !! used for MEKE [H ~> m or kg m-2]. When the total depth is less + !! than this, the diffusivity is scaled away. + logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather + !! than the streamfunction for the GM source term. + logical :: use_GM_work_bug !< If true, use the incorrect sign for the + !! top-level work tendency on the top layer. + real :: Stanley_det_coeff !< The coefficient correlating SGS temperature variance with the mean + !! temperature gradient in the deterministic part of the Stanley parameterization. + !! Negative values disable the scheme. [nondim] + logical :: read_khth !< If true, read a file containing the spatially varying horizontal + !! isopycnal height diffusivity + logical :: use_stanley_gm !< If true, also use the Stanley parameterization in MOM_thickness_diffuse + + type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics + real, allocatable :: GMwork(:,:) !< Work by isopycnal height diffusion [R Z L2 T-3 ~> W m-2] + real, allocatable :: diagSlopeX(:,:,:) !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] + real, allocatable :: diagSlopeY(:,:,:) !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] + + real, allocatable :: Kh_eta_u(:,:) !< Isopycnal height diffusivities at u points [L2 T-1 ~> m2 s-1] + real, allocatable :: Kh_eta_v(:,:) !< Isopycnal height diffusivities in v points [L2 T-1 ~> m2 s-1] + + real, allocatable :: KH_u_GME(:,:,:) !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: KH_v_GME(:,:,:) !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: khth2d(:,:) !< 2D isopycnal height diffusivity at h-points [L2 T-1 ~> m2 s-1] + + !>@{ + !! Diagnostic identifier + integer :: id_uhGM = -1, id_vhGM = -1, id_GMwork = -1 + integer :: id_KH_u = -1, id_KH_v = -1, id_KH_t = -1 + integer :: id_KH_u1 = -1, id_KH_v1 = -1, id_KH_t1 = -1 + integer :: id_slope_x = -1, id_slope_y = -1 + integer :: id_sfn_unlim_x = -1, id_sfn_unlim_y = -1, id_sfn_x = -1, id_sfn_y = -1 + !>@} +end type thickness_diffuse_CS + +contains + +!> Calculates isopycnal height diffusion coefficients and applies isopycnal height diffusion +!! by modifying to the layer thicknesses, h. Diffusivities are limited to ensure stability. +!! Also returns along-layer mass fluxes used in the continuity equation. +subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [L2 H ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [L2 H ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, intent(in) :: dt !< Time increment [T ~> s] + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(VarMix_CS), target, intent(in) :: VarMix !< Variable mixing coefficients + type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse + ! Local variables + real :: e(SZI_(G),SZJ_(G),SZK_(GV)+1) ! heights of interfaces, relative to mean + ! sea level [Z ~> m], positive up. + real :: uhD(SZIB_(G),SZJ_(G),SZK_(GV)) ! Diffusive u*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] + real :: vhD(SZI_(G),SZJB_(G),SZK_(GV)) ! Diffusive v*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & + KH_u, & ! Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + int_slope_u ! A nondimensional ratio from 0 to 1 that gives the relative + ! weighting of the interface slopes to that calculated also + ! using density gradients at u points. The physically correct + ! slopes occur at 0, while 1 is used for numerical closures [nondim]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & + KH_v, & ! Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + int_slope_v ! A nondimensional ratio from 0 to 1 that gives the relative + ! weighting of the interface slopes to that calculated also + ! using density gradients at v points. The physically correct + ! slopes occur at 0, while 1 is used for numerical closures [nondim]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + KH_t ! diagnosed diffusivity at tracer points [L2 T-1 ~> m2 s-1] + + real, dimension(SZIB_(G),SZJ_(G)) :: & + KH_u_CFL ! The maximum stable isopycnal height diffusivity at u grid points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G)) :: & + KH_v_CFL ! The maximum stable isopycnal height diffusivity at v grid points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJ_(G)) :: & + htot ! The sum of the total layer thicknesses [H ~> m or kg m-2] + real :: Khth_Loc_u(SZIB_(G),SZJ_(G)) ! The isopycnal height diffusivity at u points [L2 T-1 ~> m2 s-1] + real :: Khth_Loc_v(SZI_(G),SZJB_(G)) ! The isopycnal height diffusivity at v points [L2 T-1 ~> m2 s-1] + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real, dimension(:,:), pointer :: cg1 => null() !< Wave speed [L T-1 ~> m s-1] + real :: hu(SZI_(G),SZJ_(G)) ! A thickness-based mask at u points, used for diagnostics [nondim] + real :: hv(SZI_(G),SZJ_(G)) ! A thickness-based mask at v points, used for diagnostics [nondim] + real :: KH_u_lay(SZI_(G),SZJ_(G)) ! Diagnostic of isopycnal height diffusivities at u-points averaged + ! to layer centers [L2 T-1 ~> m2 s-1] + real :: KH_v_lay(SZI_(G),SZJ_(G)) ! Diagnostic of isopycnal height diffusivities at v-points averaged + ! to layer centers [L2 T-1 ~> m2 s-1] + logical :: use_VarMix, Resoln_scaled, Depth_scaled, use_stored_slopes, khth_use_ebt_struct, use_Visbeck + logical :: use_QG_Leith + integer :: i, j, k, is, ie, js, je, nz + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_thickness_diffuse: "//& + "Module must be initialized before it is used.") + + if ((.not.CS%thickness_diffuse) & + .or. .not. (CS%Khth > 0.0 .or. CS%read_khth & + .or. VarMix%use_variable_mixing)) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + h_neglect = GV%H_subroundoff + + if (allocated(MEKE%GM_src)) then + do j=js,je ; do i=is,ie ; MEKE%GM_src(i,j) = 0. ; enddo ; enddo + endif + + use_VarMix = .false. ; Resoln_scaled = .false. ; use_stored_slopes = .false. + khth_use_ebt_struct = .false. ; use_Visbeck = .false. ; use_QG_Leith = .false. + Depth_scaled = .false. + + if (VarMix%use_variable_mixing) then + use_VarMix = VarMix%use_variable_mixing .and. (CS%KHTH_Slope_Cff > 0.) .or. (CS%Grad_L_Scale > 0.) + Resoln_scaled = VarMix%Resoln_scaled_KhTh + Depth_scaled = VarMix%Depth_scaled_KhTh + use_stored_slopes = VarMix%use_stored_slopes + khth_use_ebt_struct = VarMix%khth_use_ebt_struct + use_Visbeck = VarMix%use_Visbeck + use_QG_Leith = VarMix%use_QG_Leith_GM +!> use_gradient_model = VarMix%use_gradient_model + if (allocated(VarMix%cg1)) cg1 => VarMix%cg1 + else + cg1 => null() + endif + + + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + KH_u_CFL(I,j) = (0.25*CS%max_Khth_CFL) / & + (dt * (G%IdxCu(I,j)*G%IdxCu(I,j) + G%IdyCu(I,j)*G%IdyCu(I,j))) + enddo ; enddo + !$OMP parallel do default(shared) + do j=js-1,je ; do I=is,ie + KH_v_CFL(i,J) = (0.25*CS%max_Khth_CFL) / & + (dt * (G%IdxCv(i,J)*G%IdxCv(i,J) + G%IdyCv(i,J)*G%IdyCv(i,J))) + enddo ; enddo + + ! Calculates interface heights, e, in [Z ~> m]. + call find_eta(h, tv, G, GV, US, e, halo_size=1) + + ! Set the diffusivities. + !$OMP parallel default(shared) + if (.not. CS%read_khth) then + !$OMP do + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = CS%Khth + enddo ; enddo + else ! use 2d KHTH that was read in from file + !$OMP do + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = 0.5 * (CS%khth2d(i,j) + CS%khth2d(i+1,j)) + enddo ; enddo + endif + + if (use_VarMix) then + if (use_Visbeck) then + !$OMP do + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = Khth_loc_u(I,j) + & + CS%KHTH_Slope_Cff*VarMix%L2u(I,j) * VarMix%SN_u(I,j) + enddo ; enddo + endif + endif + + if (allocated(MEKE%Kh)) then + if (CS%MEKE_GEOMETRIC) then + !$OMP do + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = Khth_loc_u(I,j) + G%OBCmaskCu(I,j) * CS%MEKE_GEOMETRIC_alpha * & + 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i+1,j)) / & + (VarMix%SN_u(I,j) + CS%MEKE_GEOMETRIC_epsilon) + enddo ; enddo + else + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = Khth_loc_u(I,j) + MEKE%KhTh_fac*sqrt(MEKE%Kh(i,j)*MEKE%Kh(i+1,j)) + enddo ; enddo + endif + endif + + if (Resoln_scaled) then + !$OMP do + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = Khth_loc_u(I,j) * VarMix%Res_fn_u(I,j) + enddo ; enddo + endif + + if (Depth_scaled) then + !$OMP do + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = Khth_loc_u(I,j) * VarMix%Depth_fn_u(I,j) + enddo ; enddo + endif + + if (CS%Khth_Max > 0) then + !$OMP do + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = max(CS%Khth_Min, min(Khth_loc_u(I,j), CS%Khth_Max)) + enddo ; enddo + else + !$OMP do + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = max(CS%Khth_Min, Khth_loc_u(I,j)) + enddo ; enddo + endif + !$OMP do + do j=js,je ; do I=is-1,ie + KH_u(I,j,1) = min(KH_u_CFL(I,j), Khth_loc_u(I,j)) + enddo ; enddo + + if (khth_use_ebt_struct) then + !$OMP do + do K=2,nz+1 ; do j=js,je ; do I=is-1,ie + KH_u(I,j,K) = KH_u(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + enddo ; enddo ; enddo + else + !$OMP do + do K=2,nz+1 ; do j=js,je ; do I=is-1,ie + KH_u(I,j,K) = KH_u(I,j,1) + enddo ; enddo ; enddo + endif + + if (use_VarMix) then + if (use_QG_Leith) then + !$OMP do + do k=1,nz ; do j=js,je ; do I=is-1,ie + KH_u(I,j,k) = VarMix%KH_u_QG(I,j,k) + enddo ; enddo ; enddo + endif + endif + + if (use_VarMix) then + if (CS%Grad_L_Scale > 0.0) then + !$OMP do + do k=1,nz ; do j=js,je ; do I=is-1,ie + KH_u(I,j,k) = CS%Grad_L_Scale*VarMix%L2grad_u(I,j)*VarMix%UH_grad(I,j,k) + enddo ; enddo ; enddo + endif + endif + + + if (CS%use_GME_thickness_diffuse) then + !$OMP do + do k=1,nz+1 ; do j=js,je ; do I=is-1,ie + CS%KH_u_GME(I,j,k) = KH_u(I,j,k) + enddo ; enddo ; enddo + endif + + if (.not. CS%read_khth) then + !$OMP do + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = CS%Khth + enddo ; enddo + else ! read KHTH from file + !$OMP do + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = 0.5 * (CS%khth2d(i,j) + CS%khth2d(i,j+1)) + enddo ; enddo + endif + + if (use_VarMix) then + if (use_Visbeck) then + !$OMP do + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = Khth_loc_v(i,J) + CS%KHTH_Slope_Cff*VarMix%L2v(i,J)*VarMix%SN_v(i,J) + enddo ; enddo + endif + endif + if (allocated(MEKE%Kh)) then + if (CS%MEKE_GEOMETRIC) then + !$OMP do + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = Khth_loc_v(i,J) + G%OBCmaskCv(i,J) * CS%MEKE_GEOMETRIC_alpha * & + 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i,j+1)) / & + (VarMix%SN_v(i,J) + CS%MEKE_GEOMETRIC_epsilon) + enddo ; enddo + else + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = Khth_loc_v(i,J) + MEKE%KhTh_fac*sqrt(MEKE%Kh(i,j)*MEKE%Kh(i,j+1)) + enddo ; enddo + endif + endif + + if (Resoln_scaled) then + !$OMP do + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = Khth_loc_v(i,J) * VarMix%Res_fn_v(i,J) + enddo ; enddo + endif + + if (Depth_scaled) then + !$OMP do + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = Khth_loc_v(i,J) * VarMix%Depth_fn_v(i,J) + enddo ; enddo + endif + + if (CS%Khth_Max > 0) then + !$OMP do + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = max(CS%Khth_Min, min(Khth_loc_v(i,J), CS%Khth_Max)) + enddo ; enddo + else + !$OMP do + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = max(CS%Khth_Min, Khth_loc_v(i,J)) + enddo ; enddo + endif + + if (CS%max_Khth_CFL > 0.0) then + !$OMP do + do J=js-1,je ; do i=is,ie + KH_v(i,J,1) = min(KH_v_CFL(i,J), Khth_loc_v(i,J)) + enddo ; enddo + endif + + if (khth_use_ebt_struct) then + !$OMP do + do K=2,nz+1 ; do J=js-1,je ; do i=is,ie + KH_v(i,J,K) = KH_v(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + enddo ; enddo ; enddo + else + !$OMP do + do K=2,nz+1 ; do J=js-1,je ; do i=is,ie + KH_v(i,J,K) = KH_v(i,J,1) + enddo ; enddo ; enddo + endif + + if (use_VarMix) then + if (use_QG_Leith) then + !$OMP do + do k=1,nz ; do J=js-1,je ; do i=is,ie + KH_v(i,J,k) = VarMix%KH_v_QG(i,J,k) + enddo ; enddo ; enddo + endif + endif + + if (use_VarMix) then + if (CS%Grad_L_Scale > 0.0) then !< Gradient model + !$OMP do + do k=1,nz ; do J=js-1,je ; do i=is,ie + KH_v(i,J,k) = CS%Grad_L_Scale*VarMix%L2grad_v(i,J)*VarMix%VH_grad(i,J,k) + enddo ; enddo ; enddo + endif + endif + + if (CS%use_GME_thickness_diffuse) then + !$OMP do + do k=1,nz+1 ; do J=js-1,je ; do i=is,ie + CS%KH_v_GME(i,J,k) = KH_v(i,J,k) + enddo ; enddo ; enddo + endif + + if (allocated(MEKE%Kh)) then + if (CS%MEKE_GEOMETRIC) then + if (CS%MEKE_GEOM_answer_date < 20190101) then + !$OMP do + do j=js,je ; do I=is,ie + ! This does not give bitwise rotational symmetry. + MEKE%Kh(i,j) = CS%MEKE_GEOMETRIC_alpha * MEKE%MEKE(i,j) / & + (0.25*(VarMix%SN_u(I,j)+VarMix%SN_u(I-1,j) + & + VarMix%SN_v(i,J)+VarMix%SN_v(i,J-1)) + & + CS%MEKE_GEOMETRIC_epsilon) + enddo ; enddo + else + !$OMP do + do j=js,je ; do I=is,ie + ! With the additional parentheses this gives bitwise rotational symmetry. + MEKE%Kh(i,j) = CS%MEKE_GEOMETRIC_alpha * MEKE%MEKE(i,j) / & + (0.25*((VarMix%SN_u(I,j)+VarMix%SN_u(I-1,j)) + & + (VarMix%SN_v(i,J)+VarMix%SN_v(i,J-1))) + & + CS%MEKE_GEOMETRIC_epsilon) + enddo ; enddo + endif + endif + endif + + !$OMP do + do K=1,nz+1 ; do j=js,je ; do I=is-1,ie ; int_slope_u(I,j,K) = 0.0 ; enddo ; enddo ; enddo + !$OMP do + do K=1,nz+1 ; do J=js-1,je ; do i=is,ie ; int_slope_v(i,J,K) = 0.0 ; enddo ; enddo ; enddo + !$OMP end parallel + + if (CS%detangle_interfaces) then + call add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, US, & + CS, int_slope_u, int_slope_v) + endif + + if ((CS%Kh_eta_bg > 0.0) .or. (CS%Kh_eta_vel > 0.0)) then + call add_interface_Kh(G, GV, US, CS, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, int_slope_u, int_slope_v) + endif + + if (CS%debug) then + call uvchksum("Kh_[uv]", Kh_u, Kh_v, G%HI, haloshift=0, & + scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + call uvchksum("Kh_[uv]_CFL", Kh_u_CFL, Kh_v_CFL, G%HI, haloshift=0, & + scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + if (Resoln_scaled) then + call uvchksum("Res_fn_[uv]", VarMix%Res_fn_u, VarMix%Res_fn_v, G%HI, haloshift=0, & + scale=1.0, scalar_pair=.true.) + endif + call uvchksum("int_slope_[uv]", int_slope_u, int_slope_v, G%HI, haloshift=0) + call hchksum(h, "thickness_diffuse_1 h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(e, "thickness_diffuse_1 e", G%HI, haloshift=1, scale=US%Z_to_m) + if (use_stored_slopes) then + call uvchksum("VarMix%slope_[xy]", VarMix%slope_x, VarMix%slope_y, & + G%HI, haloshift=0, scale=US%Z_to_L) + endif + if (associated(tv%eqn_of_state)) then + call hchksum(tv%T, "thickness_diffuse T", G%HI, haloshift=1, scale=US%C_to_degC) + call hchksum(tv%S, "thickness_diffuse S", G%HI, haloshift=1, scale=US%S_to_ppt) + endif + endif + + ! Calculate uhD, vhD from h, e, KH_u, KH_v, tv%T/S + if (use_stored_slopes) then + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & + int_slope_u, int_slope_v, VarMix%slope_x, VarMix%slope_y) + else + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & + int_slope_u, int_slope_v) + endif + + if (VarMix%use_variable_mixing) then + if (allocated(MEKE%Rd_dx_h) .and. allocated(VarMix%Rd_dx_h)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%Rd_dx_h(i,j) = VarMix%Rd_dx_h(i,j) + enddo ; enddo + endif + endif + + ! offer diagnostic fields for averaging + if (query_averaging_enabled(CS%diag)) then + if (CS%id_uhGM > 0) call post_data(CS%id_uhGM, uhD, CS%diag) + if (CS%id_vhGM > 0) call post_data(CS%id_vhGM, vhD, CS%diag) + if (CS%id_GMwork > 0) call post_data(CS%id_GMwork, CS%GMwork, CS%diag) + if (CS%id_KH_u > 0) call post_data(CS%id_KH_u, KH_u, CS%diag) + if (CS%id_KH_v > 0) call post_data(CS%id_KH_v, KH_v, CS%diag) + if (CS%id_KH_u1 > 0) call post_data(CS%id_KH_u1, KH_u(:,:,1), CS%diag) + if (CS%id_KH_v1 > 0) call post_data(CS%id_KH_v1, KH_v(:,:,1), CS%diag) + + ! Diagnose diffusivity at T-cell point. Do a simple average, rather than a + ! thickness-weighted average, so that KH_t is depth-independent when KH_u and KH_v + ! are depth independent. If a thickness-weighted average were used, the variations + ! of thickness could give a spurious depth dependence to the diagnosed KH_t. + if (CS%id_KH_t > 0 .or. CS%id_KH_t1 > 0 .or. CS%Use_KH_in_MEKE) then + do k=1,nz + ! thicknesses across u and v faces, converted to 0/1 mask + ! layer average of the interface diffusivities KH_u and KH_v + do j=js,je ; do I=is-1,ie + ! This expression uses harmonic mean thicknesses: + ! hu(I,j) = 2.0*h(i,j,k)*h(i+1,j,k) / (h(i,j,k)+h(i+1,j,k)+h_neglect) + ! This expression is a 0/1 mask based on depths where there are thick layers: + hu(I,j) = 0.0 ; if (h(i,j,k)*h(i+1,j,k) /= 0.0) hu(I,j) = 1.0 + KH_u_lay(I,j) = 0.5*(KH_u(I,j,k)+KH_u(I,j,k+1)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + ! This expression uses harmonic mean thicknesses: + ! hv(i,J) = 2.0*h(i,j,k)*h(i,j+1,k)/(h(i,j,k)+h(i,j+1,k)+h_neglect) + ! This expression is a 0/1 mask based on depths where there are thick layers: + hv(i,J) = 0.0 ; if (h(i,j,k)*h(i,j+1,k) /= 0.0) hv(i,J) = 1.0 + KH_v_lay(i,J) = 0.5*(KH_v(i,J,k)+KH_v(i,J,k+1)) + enddo ; enddo + ! diagnose diffusivity at T-points + do j=js,je ; do i=is,ie + Kh_t(i,j,k) = ((hu(I-1,j)*KH_u_lay(i-1,j) + hu(I,j)*KH_u_lay(I,j)) + & + (hv(i,J-1)*KH_v_lay(i,J-1) + hv(i,J)*KH_v_lay(i,J))) / & + ((hu(I-1,j)+hu(I,j)) + (hv(i,J-1)+hv(i,J)) + 1.0e-20) + ! Use this denominator instead if hu and hv are actual thicknesses rather than a 0/1 mask: + ! ((hu(I-1,j)+hu(I,j)) + (hv(i,J-1)+hv(i,J)) + h_neglect) + enddo ; enddo + enddo + + if (CS%Use_KH_in_MEKE) then + MEKE%Kh_diff(:,:) = 0.0 + htot(:,:) = 0.0 + do k=1,nz + do j=js,je ; do i=is,ie + MEKE%Kh_diff(i,j) = MEKE%Kh_diff(i,j) + Kh_t(i,j,k) * h(i,j,k) + htot(i,j) = htot(i,j) + h(i,j,k) + enddo ; enddo + enddo + + do j=js,je ; do i=is,ie + MEKE%Kh_diff(i,j) = MEKE%Kh_diff(i,j) / MAX(CS%MEKE_min_depth_diff, htot(i,j)) + enddo ; enddo + endif + + if (CS%id_KH_t > 0) call post_data(CS%id_KH_t, KH_t, CS%diag) + if (CS%id_KH_t1 > 0) call post_data(CS%id_KH_t1, KH_t(:,:,1), CS%diag) + endif + + endif + + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=is-1,ie + uhtr(I,j,k) = uhtr(I,j,k) + uhD(I,j,k) * dt + if (associated(CDp%uhGM)) CDp%uhGM(I,j,k) = uhD(I,j,k) + enddo ; enddo + do J=js-1,je ; do i=is,ie + vhtr(i,J,k) = vhtr(i,J,k) + vhD(i,J,k) * dt + if (associated(CDp%vhGM)) CDp%vhGM(i,J,k) = vhD(i,J,k) + enddo ; enddo + do j=js,je ; do i=is,ie + h(i,j,k) = h(i,j,k) - dt * G%IareaT(i,j) * & + ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) + if (h(i,j,k) < GV%Angstrom_H) h(i,j,k) = GV%Angstrom_H + enddo ; enddo + enddo + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + ! This needs to happen after the H update and before the next post_data. + call diag_update_remap_grids(CS%diag) + + if (CS%debug) then + call uvchksum("thickness_diffuse [uv]hD", uhD, vhD, & + G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2*US%s_to_T) + call uvchksum("thickness_diffuse [uv]htr", uhtr, vhtr, & + G%HI, haloshift=0, scale=US%L_to_m**2*GV%H_to_m) + call hchksum(h, "thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_m) + endif + +end subroutine thickness_diffuse + +!> Calculates parameterized layer transports for use in the continuity equation. +!! Fluxes are limited to give positive definite thicknesses. +!! Called by thickness_diffuse(). +subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, & + CS, int_slope_u, int_slope_v, slope_x, slope_y) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface positions [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Kh_u !< Isopycnal height diffusivity + !! at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Kh_v !< Isopycnal height diffusivity + !! at v points [L2 T-1 ~> m2 s-1] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: uhD !< Zonal mass fluxes + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: vhD !< Meridional mass fluxes + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(:,:), pointer :: cg1 !< Wave speed [L T-1 ~> m s-1] + real, intent(in) :: dt !< Time increment [T ~> s] + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: int_slope_u !< Ratio that determine how much of + !! the isopycnal slopes are taken directly from + !! the interface slopes without consideration of + !! density gradients [nondim]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: int_slope_v !< Ratio that determine how much of + !! the isopycnal slopes are taken directly from + !! the interface slopes without consideration of + !! density gradients [nondim]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), optional, intent(in) :: slope_x !< Isopyc. slope at u [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), optional, intent(in) :: slope_y !< Isopyc. slope at v [Z L-1 ~> nondim] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + T, & ! The temperature [C ~> degC], with the values in + ! in massless layers filled vertically by diffusion. + S, & ! The filled salinity [S ~> ppt], with the values in + ! in massless layers filled vertically by diffusion. + h_avail, & ! The mass available for diffusion out of each face, divided + ! by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. + h_frac ! The fraction of the mass in the column above the bottom + ! interface of a layer that is within a layer [nondim]. 0 m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & + Slope_y_PE, & ! 3D array of neutral slopes at v-points, set equal to Slope (below) [nondim] + hN2_y_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency + ! at v-points with unit conversion factors [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2], + ! used for calculating the potential energy release + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & + Slope_x_PE, & ! 3D array of neutral slopes at u-points, set equal to Slope (below) [nondim] + hN2_x_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency + ! at u-points with unit conversion factors [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2], + ! used for calculating the potential energy release + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + pres, & ! The pressure at an interface [R L2 T-2 ~> Pa]. + h_avail_rsum ! The running sum of h_avail above an interface [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G)) :: & + drho_dT_u, & ! The derivative of density with temperature at u points [R C-1 ~> kg m-3 degC-1] + drho_dS_u ! The derivative of density with salinity at u points [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() + ! with various units that will be ignored [various] + real, dimension(SZI_(G)) :: & + drho_dT_v, & ! The derivative of density with temperature at v points [R C-1 ~> kg m-3 degC-1] + drho_dS_v, & ! The derivative of density with salinity at v points [R S-1 ~> kg m-3 ppt-1]. + drho_dT_dT_h, & ! The second derivative of density with temperature at h points [R C-2 ~> kg m-3 degC-2] + drho_dT_dT_hr ! The second derivative of density with temperature at h (+1) points [R C-2 ~> kg m-3 degC-2] + real :: uhtot(SZIB_(G),SZJ_(G)) ! The vertical sum of uhD [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: vhtot(SZI_(G),SZJB_(G)) ! The vertical sum of vhD [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G)) :: & + T_u, & ! Temperature on the interface at the u-point [C ~> degC]. + S_u, & ! Salinity on the interface at the u-point [S ~> ppt]. + pres_u ! Pressure on the interface at the u-point [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G)) :: & + T_v, & ! Temperature on the interface at the v-point [C ~> degC]. + S_v, & ! Salinity on the interface at the v-point [S ~> ppt]. + pres_v, & ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. + T_h, & ! Temperature on the interface at the h-point [C ~> degC]. + S_h, & ! Salinity on the interface at the h-point [S ~> ppt]. + pres_h, & ! Pressure on the interface at the h-point [R L2 T-2 ~> Pa]. + T_hr, & ! Temperature on the interface at the h (+1) point [C ~> degC]. + S_hr, & ! Salinity on the interface at the h (+1) point [S ~> ppt]. + pres_hr ! Pressure on the interface at the h (+1) point [R L2 T-2 ~> Pa]. + real :: Work_u(SZIB_(G),SZJ_(G)) ! The work done by the isopycnal height diffusion + ! integrated over u-point water columns [R Z L4 T-3 ~> W] + real :: Work_v(SZI_(G),SZJB_(G)) ! The work done by the isopycnal height diffusion + ! integrated over v-point water columns [R Z L4 T-3 ~> W] + real :: Work_h ! The work averaged over an h-cell [R Z L2 T-3 ~> W m-2]. + real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell + ! [R Z L2 T-3 ~> W m-2]. The calculation equals rho0 * h * S^2 * N^2 * kappa_GM. + real :: I4dt ! 1 / 4 dt [T-1 ~> s-1]. + real :: drdiA, drdiB ! Along layer zonal potential density gradients in the layers above (A) + ! and below (B) the interface times the grid spacing [R ~> kg m-3]. + real :: drdjA, drdjB ! Along layer meridional potential density gradients in the layers above (A) + ! and below (B) the interface times the grid spacing [R ~> kg m-3]. + real :: drdkL, drdkR ! Vertical density differences across an interface [R ~> kg m-3]. + real :: drdi_u(SZIB_(G),SZK_(GV)) ! Copy of drdi at u-points [R ~> kg m-3]. + real :: drdj_v(SZI_(G),SZK_(GV)) ! Copy of drdj at v-points [R ~> kg m-3]. + real :: drdkDe_u(SZIB_(G),SZK_(GV)+1) ! Lateral difference of product of drdk and e at u-points + ! [Z R ~> kg m-2]. + real :: drdkDe_v(SZI_(G),SZK_(GV)+1) ! Lateral difference of product of drdk and e at v-points + ! [Z R ~> kg m-2]. + real :: hg2A, hg2B, hg2L, hg2R ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. + real :: haA, haB, haL, haR ! Arithmetic mean thicknesses [H ~> m or kg m-2]. + real :: dzg2A, dzg2B ! Squares of geometric mean vertical layer extents [Z2 ~> m2]. + real :: dzaA, dzaB ! Arithmetic mean vertical layer extents [Z ~> m]. + real :: dzaL, dzaR ! Temporary vertical layer extents [Z ~> m] + real :: wtA, wtB ! Unnormalized weights of the slopes above and below [H3 ~> m3 or kg3 m-6] + real :: wtL, wtR ! Unnormalized weights of the slopes to the left and right [H3 Z ~> m4 or kg3 m-5] + real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. + real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. + real :: dz_harm ! Harmonic mean layer vertical extent [Z ~> m]. + real :: c2_dz_u(SZIB_(G),SZK_(GV)+1) ! Wave speed squared divided by dz at u-points times rescaling + ! factors from depths to thicknesses [H2 L2 Z-3 T-2 ~> m s-2 or kg m-2 s-2] + real :: c2_dz_v(SZI_(G),SZK_(GV)+1) ! Wave speed squared divided by dz at v-points times rescaling + ! factors from depths to thicknesses [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real :: dzN2_u(SZIB_(G),SZK_(GV)+1) ! Vertical extent times N2 at interfaces above u-points times + ! rescaling factors from vertical to horizontal distances [L2 Z-1 T-2 ~> m s-2] + real :: dzN2_v(SZI_(G),SZK_(GV)+1) ! Vertical extent times N2 at interfaces above v-points times + ! rescaling factors from vertical to horizontal distances [L2 Z-1 T-2 ~> m s-2] + real :: Sfn_est ! A preliminary estimate (before limiting) of the overturning + ! streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: Sfn_unlim_u(SZIB_(G),SZK_(GV)+1) ! Volume streamfunction for u-points [Z L2 T-1 ~> m3 s-1] + real :: Sfn_unlim_v(SZI_(G),SZK_(GV)+1) ! Volume streamfunction for v-points [Z L2 T-1 ~> m3 s-1] + real :: slope2_Ratio_u(SZIB_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared [nondim] + real :: slope2_Ratio_v(SZI_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared [nondim] + real :: Sfn_in_h ! The overturning streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1] (note that + ! the units are different from other Sfn vars). + real :: Sfn_safe ! The streamfunction that goes linearly back to 0 at the surface + ! [H L2 T-1 ~> m3 s-1 or kg s-1]. This is a good value to use when the + ! slope is so large as to be meaningless, usually due to weak stratification. + real :: Slope ! The slope of density surfaces, calculated in a way that is always + ! between -1 and 1 after undoing dimensional scaling, [Z L-1 ~> nondim] + real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 L-2 ~> kg2 m-8]. + real :: I_slope_max2 ! The inverse of slope_max squared [L2 Z-2 ~> nondim]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: hn_2 ! Half of h_neglect [H ~> m or kg m-2]. + real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4]. + real :: dz_neglect ! A thickness [Z ~> m], that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] + real :: G_scale ! The gravitational acceleration times a unit conversion + ! factor [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: find_work ! If true, find the change in energy due to the fluxes. + integer :: nk_linear ! The number of layers over which the streamfunction goes to 0. + real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. + real :: Rho_avg ! The in situ density averaged to an interface [R ~> kg m-3] + real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver + ! times unit conversion factors [L2 Z-2 T-2 ~> s-2] + real :: N2_unlim ! An unlimited estimate of the buoyancy frequency + ! times unit conversion factors [L2 Z-2 T-2 ~> s-2] + real :: Tl(5) ! copy of T in local stencil [C ~> degC] + real :: mn_T ! mean of T in local stencil [C ~> degC] + real :: mn_T2 ! mean of T**2 in local stencil [C2 ~> degC2] + real :: hl(5) ! Copy of local stencil of H [H ~> m] + real :: r_sm_H ! Reciprocal of sum of H in local stencil [H-1 ~> m-1] + real :: Z_to_H ! A conversion factor from heights to thicknesses, perhaps based on + ! a spatially variable local density [H Z-1 ~> nondim or kg m-3] + real :: Tsgs2(SZI_(G),SZJ_(G),SZK_(GV)) ! Sub-grid temperature variance [C2 ~> degC2] + real :: diag_sfn_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction + ! [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: diag_sfn_unlim_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction before + ! applying limiters [Z L2 T-1 ~> m3 s-1] + real :: diag_sfn_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction + ! [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: diag_sfn_unlim_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction before + ! applying limiters [Z L2 T-1 ~> m3 s-1] + logical :: present_slope_x, present_slope_y, calc_derivatives + integer, dimension(2) :: EOSdom_u ! The shifted I-computational domain to use for equation of + ! state calculations at u-points. + integer, dimension(2) :: EOSdom_v ! The shifted i-computational domain to use for equation of + ! state calculations at v-points. + integer, dimension(2) :: EOSdom_h1 ! The shifted i-computational domain to use for equation of + ! state calculations at h points with 1 extra halo point + logical :: use_stanley + integer :: is, ie, js, je, nz, IsdB, halo + integer :: i, j, k + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ; IsdB = G%IsdB + + I4dt = 0.25 / dt + I_slope_max2 = 1.0 / (CS%slope_max**2) + + h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 ; hn_2 = 0.5*h_neglect + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect**2 + if (GV%Boussinesq) G_rho0 = GV%g_Earth / GV%Rho0 + N2_floor = CS%N2_floor * US%Z_to_L**2 + + use_EOS = associated(tv%eqn_of_state) + present_slope_x = PRESENT(slope_x) + present_slope_y = PRESENT(slope_y) + + use_stanley = CS%use_stanley_gm + + nk_linear = max(GV%nkml, 1) + + Slope_x_PE(:,:,:) = 0.0 + Slope_y_PE(:,:,:) = 0.0 + hN2_x_PE(:,:,:) = 0.0 + hN2_y_PE(:,:,:) = 0.0 + + find_work = allocated(MEKE%GM_src) + find_work = (allocated(CS%GMwork) .or. find_work) + + if (use_EOS) then + halo = 1 ! Default halo to fill is 1 + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, US, halo, larger_h_denom=.true.) + endif + + ! Rescale the thicknesses, perhaps using the specific volume. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + + if (CS%use_FGNV_streamfn .and. .not. associated(cg1)) call MOM_error(FATAL, & + "cg1 must be associated when using FGNV streamfunction.") + + !$OMP parallel default(shared) private(hl,r_sm_H,Tl,mn_T,mn_T2) + ! Find the maximum and minimum permitted streamfunction. + !$OMP do + do j=js-1,je+1 ; do i=is-1,ie+1 + h_avail_rsum(i,j,1) = 0.0 + pres(i,j,1) = 0.0 + if (associated(tv%p_surf)) then ; pres(i,j,1) = tv%p_surf(i,j) ; endif + + h_avail(i,j,1) = max(I4dt*G%areaT(i,j)*(h(i,j,1)-GV%Angstrom_H),0.0) + h_avail_rsum(i,j,2) = h_avail(i,j,1) + h_frac(i,j,1) = 1.0 + pres(i,j,2) = pres(i,j,1) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,1) + enddo ; enddo + do j=js-1,je+1 + do k=2,nz ; do i=is-1,ie+1 + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + h_avail_rsum(i,j,k+1) = h_avail_rsum(i,j,k) + h_avail(i,j,k) + h_frac(i,j,k) = 0.0 ; if (h_avail(i,j,k) > 0.0) & + h_frac(i,j,k) = h_avail(i,j,k) / h_avail_rsum(i,j,k+1) + pres(i,j,K+1) = pres(i,j,K) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,k) + enddo ; enddo + enddo + !$OMP do + do j=js,je ; do I=is-1,ie + uhtot(I,j) = 0.0 ; Work_u(I,j) = 0.0 + enddo ; enddo + !$OMP do + do J=js-1,je ; do i=is,ie + vhtot(i,J) = 0.0 ; Work_v(i,J) = 0.0 + enddo ; enddo + !$OMP end parallel + + if (CS%id_sfn_x > 0) then ; diag_sfn_x(:,:,1) = 0.0 ; diag_sfn_x(:,:,nz+1) = 0.0 ; endif + if (CS%id_sfn_y > 0) then ; diag_sfn_y(:,:,1) = 0.0 ; diag_sfn_y(:,:,nz+1) = 0.0 ; endif + if (CS%id_sfn_unlim_x > 0) then ; diag_sfn_unlim_x(:,:,1) = 0.0 ; diag_sfn_unlim_x(:,:,nz+1) = 0.0 ; endif + if (CS%id_sfn_unlim_y > 0) then ; diag_sfn_unlim_y(:,:,1) = 0.0 ; diag_sfn_unlim_y(:,:,nz+1) = 0.0 ; endif + + EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) + EOSdom_v(:) = EOS_domain(G%HI) + EOSdom_h1(:) = EOS_domain(G%HI, halo=1) + + !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & + !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz,dz_neglect,dz_neglect2, & + !$OMP h_neglect2,hn_2,I_slope_max2,int_slope_u,KH_u,uhtot, & + !$OMP h_frac,h_avail_rsum,uhD,h_avail,Work_u,CS,slope_x,cg1, & + !$OMP diag_sfn_x,diag_sfn_unlim_x,N2_floor,EOSdom_u,EOSdom_h1, & + !$OMP use_stanley,Tsgs2,present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & + !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u,G_scale, & + !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,N2_unlim, & + !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & + !$OMP dzg2A,dzg2B,dzaA,dzaB,dz_harm,Z_to_H, & + !$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,dzN2_u, & + !$OMP Sfn_unlim_u,Rho_avg,drdi_u,drdkDe_u,c2_dz_u, & + !$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) + do j=js,je + do I=is-1,ie ; dzN2_u(I,1) = 0. ; dzN2_u(I,nz+1) = 0. ; enddo + do K=nz,2,-1 + if (find_work .and. .not.(use_EOS)) then + drdiA = 0.0 ; drdiB = 0.0 + drdkL = GV%Rlay(k) - GV%Rlay(k-1) ; drdkR = drdkL + endif + + calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & + (find_work .or. .not. present_slope_x .or. CS%use_FGNV_streamfn .or. use_stanley) + + ! Calculate the zonal fluxes and gradients. + if (calc_derivatives) then + do I=is-1,ie + pres_u(I) = 0.5*(pres(i,j,K) + pres(i+1,j,K)) + T_u(I) = 0.25*((T(i,j,k) + T(i+1,j,k)) + (T(i,j,k-1) + T(i+1,j,k-1))) + S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) + enddo + call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & + tv%eqn_of_state, EOSdom_u) + endif + if (use_stanley) then + do i=is-1,ie+1 + pres_h(i) = pres(i,j,K) + T_h(i) = 0.5*(T(i,j,k) + T(i,j,k-1)) + S_h(i) = 0.5*(S(i,j,k) + S(i,j,k-1)) + enddo + + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_h, S_h, pres_h, & + scrap, scrap, drho_dT_dT_h, scrap, scrap, & + tv%eqn_of_state, EOSdom_h1) + endif + + do I=is-1,ie + if (calc_derivatives) then + ! Estimate the horizontal density gradients along layers. + drdiA = drho_dT_u(I) * (T(i+1,j,k-1)-T(i,j,k-1)) + & + drho_dS_u(I) * (S(i+1,j,k-1)-S(i,j,k-1)) + drdiB = drho_dT_u(I) * (T(i+1,j,k)-T(i,j,k)) + & + drho_dS_u(I) * (S(i+1,j,k)-S(i,j,k)) + + ! Estimate the vertical density gradients times the grid spacing. + drdkL = (drho_dT_u(I) * (T(i,j,k)-T(i,j,k-1)) + & + drho_dS_u(I) * (S(i,j,k)-S(i,j,k-1))) + drdkR = (drho_dT_u(I) * (T(i+1,j,k)-T(i+1,j,k-1)) + & + drho_dS_u(I) * (S(i+1,j,k)-S(i+1,j,k-1))) + drdkDe_u(I,K) = drdkR * e(i+1,j,K) - drdkL * e(i,j,K) + elseif (find_work) then ! This is used in pure stacked SW mode + drdkDe_u(I,K) = drdkR * e(i+1,j,K) - drdkL * e(i,j,K) + endif + if (use_stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdiA = drdiA + 0.5 * ((drho_dT_dT_h(i+1) * tv%varT(i+1,j,k-1)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k-1)) ) + drdiB = drdiB + 0.5 * ((drho_dT_dT_h(i+1) * tv%varT(i+1,j,k)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k)) ) + endif + if (find_work) drdi_u(I,k) = drdiB + + if (k > nk_linear) then + if (use_EOS) then + if (CS%use_FGNV_streamfn .or. find_work .or. .not.present_slope_x) then + hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 + hg2R = h(i+1,j,k-1)*h(i+1,j,k) + h_neglect2 + haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect + haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect + if (GV%Boussinesq) then + dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z + elseif (GV%semi_Boussinesq) then + dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect + dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect + else + dzaL = 0.5*(dz(i,j,k-1) + dz(i,j,k)) + dz_neglect + dzaR = 0.5*(dz(i+1,j,k-1) + dz(i+1,j,k)) + dz_neglect + endif + ! Use the harmonic mean thicknesses to weight the horizontal gradients. + ! These unnormalized weights have been rearranged to minimize divisions. + wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) + + drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) + ! The expression for drdz above is mathematically equivalent to: + ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & + ! ((hg2L/haL) + (hg2R/haR)) + hg2A = h(i,j,k-1)*h(i+1,j,k-1) + h_neglect2 + hg2B = h(i,j,k)*h(i+1,j,k) + h_neglect2 + haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + h_neglect + haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect + + if (GV%Boussinesq) then + N2_unlim = drdz*G_rho0 + else + N2_unlim = (GV%g_Earth*GV%RZ_to_H) * & + ((wtL * drdkL + wtR * drdkR) / (haL*wtL + haR*wtR)) + endif + + dzg2A = dz(i,j,k-1)*dz(i+1,j,k-1) + dz_neglect2 + dzg2B = dz(i,j,k)*dz(i+1,j,k) + dz_neglect2 + dzaA = 0.5*(dz(i,j,k-1) + dz(i+1,j,k-1)) + dz_neglect + dzaB = 0.5*(dz(i,j,k) + dz(i+1,j,k)) + dz_neglect + ! dzN2_u is used with the FGNV streamfunction formulation + dzN2_u(I,K) = (0.5 * ( dzg2A / dzaA + dzg2B / dzaB )) * max(N2_unlim, N2_floor) + if (find_work .and. CS%GM_src_alt) & + hN2_x_PE(I,j,k) = (0.5 * ( hg2A / haA + hg2B / haB )) * max(N2_unlim, N2_floor) + endif + + if (present_slope_x) then + Slope = slope_x(I,j,k) + slope2_Ratio_u(I,K) = Slope**2 * I_slope_max2 + else + ! Use the harmonic mean thicknesses to weight the horizontal gradients. + ! These unnormalized weights have been rearranged to minimize divisions. + wtA = hg2A*haB ; wtB = hg2B*haA + ! This is the gradient of density along geopotentials. + drdx = ((wtA * drdiA + wtB * drdiB) / (wtA + wtB) - & + drdz * (e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) + + ! This estimate of slope is accurate for small slopes, but bounded + ! to be between -1 and 1. + mag_grad2 = (US%Z_to_L*drdx)**2 + drdz**2 + if (mag_grad2 > 0.0) then + Slope = drdx / sqrt(mag_grad2) + slope2_Ratio_u(I,K) = Slope**2 * I_slope_max2 + else ! Just in case mag_grad2 = 0 ever. + Slope = 0.0 + slope2_Ratio_u(I,K) = 1.0e20 ! Force the use of the safe streamfunction. + endif + endif + + ! Adjust real slope by weights that bias towards slope of interfaces + ! that ignore density gradients along layers. + Slope = (1.0 - int_slope_u(I,j,K)) * Slope + & + int_slope_u(I,j,K) * ((e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j)) + slope2_Ratio_u(I,K) = (1.0 - int_slope_u(I,j,K)) * slope2_Ratio_u(I,K) + + Slope_x_PE(I,j,k) = MIN(Slope,CS%slope_max) + if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope + + ! Estimate the streamfunction at each interface [H L2 T-1 ~> m3 s-1 or kg s-1]. + Sfn_unlim_u(I,K) = -(KH_u(I,j,K)*G%dy_Cu(I,j))*Slope + + ! Avoid moving dense water upslope from below the level of + ! the bottom on the receiving side. + if (Sfn_unlim_u(I,K) > 0.0) then ! The flow below this interface is positive. + if (e(i,j,K) < e(i+1,j,nz+1)) then + Sfn_unlim_u(I,K) = 0.0 ! This is not uhtot, because it may compensate for + ! deeper flow in very unusual cases. + elseif (e(i+1,j,nz+1) > e(i,j,K+1)) then + ! Scale the transport with the fraction of the donor layer above + ! the bottom on the receiving side. + Sfn_unlim_u(I,K) = Sfn_unlim_u(I,K) * ((e(i,j,K) - e(i+1,j,nz+1)) / & + ((e(i,j,K) - e(i,j,K+1)) + dz_neglect)) + endif + else + if (e(i+1,j,K) < e(i,j,nz+1)) then ; Sfn_unlim_u(I,K) = 0.0 + elseif (e(i,j,nz+1) > e(i+1,j,K+1)) then + Sfn_unlim_u(I,K) = Sfn_unlim_u(I,K) * ((e(i+1,j,K) - e(i,j,nz+1)) / & + ((e(i+1,j,K) - e(i+1,j,K+1)) + dz_neglect)) + endif + endif + + else ! .not. use_EOS + if (present_slope_x) then + Slope = slope_x(I,j,k) + else + Slope = ((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) * G%OBCmaskCu(I,j) + endif + if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope + Sfn_unlim_u(I,K) = ((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) + dzN2_u(I,K) = GV%g_prime(K) + endif ! if (use_EOS) + else ! if (k > nk_linear) + dzN2_u(I,K) = N2_floor * dz_neglect + Sfn_unlim_u(I,K) = 0. + endif ! if (k > nk_linear) + if (CS%id_sfn_unlim_x>0) diag_sfn_unlim_x(I,j,K) = Sfn_unlim_u(I,K) + enddo ! i-loop + enddo ! k-loop + + if (CS%use_FGNV_streamfn) then + do k=1,nz ; do I=is-1,ie ; if (G%OBCmaskCu(I,j)>0.) then + dz_harm = max( dz_neglect, & + 2. * dz(i,j,k) * dz(i+1,j,k) / ( ( dz(i,j,k) + dz(i+1,j,k) ) + dz_neglect ) ) + c2_dz_u(I,k) = CS%FGNV_scale * ( 0.5*( cg1(i,j) + cg1(i+1,j) ) )**2 / dz_harm + endif ; enddo ; enddo + + ! Solve an elliptic equation for the streamfunction following Ferrari et al., 2010. + do I=is-1,ie + if (G%OBCmaskCu(I,j)>0.) then + do K=2,nz + Sfn_unlim_u(I,K) = (1. + CS%FGNV_scale) * Sfn_unlim_u(I,K) + enddo + call streamfn_solver(nz, c2_dz_u(I,:), dzN2_u(I,:), Sfn_unlim_u(I,:)) + else + do K=2,nz + Sfn_unlim_u(I,K) = 0. + enddo + endif + enddo + endif + + do K=nz,2,-1 + do I=is-1,ie + + if (allocated(tv%SpV_avg) .and. (find_work .or. (k > nk_linear)) ) then + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i+1,j,k) + h(i+1,j,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i+1,j,k)+hn_2)*tv%SpV_avg(i+1,j,k) + (h(i+1,j,k-1)+hn_2)*tv%SpV_avg(i+1,j,k-1)) ) + ! Use an average density to convert the volume streamfunction estimate into a mass streamfunction. + Z_to_H = (GV%RZ_to_H*Rho_avg) + else + Z_to_H = GV%Z_to_H + endif + + if (k > nk_linear) then + if (use_EOS) then + + if (uhtot(I,j) <= 0.0) then + ! The transport that must balance the transport below is positive. + Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i,j,k)) + else ! (uhtot(I,j) > 0.0) + Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i+1,j,k)) + endif + + ! Determine the actual streamfunction at each interface. + Sfn_est = (Z_to_H*Sfn_unlim_u(I,K) + slope2_Ratio_u(I,K)*Sfn_safe) / (1.0 + slope2_Ratio_u(I,K)) + else ! When use_EOS is false, the layers are constant density. + Sfn_est = Z_to_H*Sfn_unlim_u(I,K) + endif + + ! Make sure that there is enough mass above to allow the streamfunction + ! to satisfy the boundary condition of 0 at the surface. + Sfn_in_H = min(max(Sfn_est, -h_avail_rsum(i,j,K)), h_avail_rsum(i+1,j,K)) + + ! The actual transport is limited by the mass available in the two + ! neighboring grid cells. + uhD(I,j,k) = max(min((Sfn_in_H - uhtot(I,j)), h_avail(i,j,k)), & + -h_avail(i+1,j,k)) + + if (CS%id_sfn_x>0) diag_sfn_x(I,j,K) = diag_sfn_x(I,j,K+1) + uhD(I,j,k) +! sfn_x(I,j,K) = max(min(Sfn_in_h, uhtot(I,j)+h_avail(i,j,k)), & +! uhtot(I,j)-h_avail(i+1,j,K)) +! sfn_slope_x(I,j,K) = max(uhtot(I,j)-h_avail(i+1,j,k), & +! min(uhtot(I,j)+h_avail(i,j,k), & +! min(h_avail_rsum(i+1,j,K), max(-h_avail_rsum(i,j,K), & +! (KH_u(I,j,K)*G%dy_Cu(I,j)) * ((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) )) )) + else ! k <= nk_linear + ! Balance the deeper flow with a return flow uniformly distributed + ! though the remaining near-surface layers. This is the same as + ! using Sfn_safe above. There is no need to apply the limiters in + ! this case. + if (uhtot(I,j) <= 0.0) then + uhD(I,j,k) = -uhtot(I,j) * h_frac(i,j,k) + else ! (uhtot(I,j) > 0.0) + uhD(I,j,k) = -uhtot(I,j) * h_frac(i+1,j,k) + endif + + if (CS%id_sfn_x>0) diag_sfn_x(I,j,K) = diag_sfn_x(I,j,K+1) + uhD(I,j,k) +! if (sfn_slope_x(I,j,K+1) <= 0.0) then +! sfn_slope_x(I,j,K) = sfn_slope_x(I,j,K+1) * (1.0 - h_frac(i,j,k)) +! else +! sfn_slope_x(I,j,K) = sfn_slope_x(I,j,K+1) * (1.0 - h_frac(i+1,j,k)) +! endif + + endif + + uhtot(I,j) = uhtot(I,j) + uhD(I,j,k) + + if (find_work) then + ! This is the energy tendency based on the original profiles, and does + ! not include any nonlinear terms due to a finite time step (which would + ! involve interactions between the fluxes through the different faces. + ! A second order centered estimate is used for the density transferred + ! between water columns. + + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth / Rho_avg + else + G_scale = GV%g_Earth * GV%H_to_Z + endif + + Work_u(I,j) = Work_u(I,j) + G_scale * & + ( uhtot(I,j) * drdkDe_u(I,K) - & + (uhD(I,j,k) * drdi_u(I,k)) * 0.25 * & + ((e(i,j,K) + e(i,j,K+1)) + (e(i+1,j,K) + e(i+1,j,K+1))) ) + endif + + enddo + enddo ! end of k-loop + enddo ! end of j-loop + + ! Calculate the meridional fluxes and gradients. + + !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S,dz, & + !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,dz_neglect2, & + !$OMP h_neglect2,int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & + !$OMP I_slope_max2,vhD,h_avail,Work_v,CS,slope_y,cg1,hn_2,& + !$OMP diag_sfn_y,diag_sfn_unlim_y,N2_floor,EOSdom_v,use_stanley,& + !$OMP Tsgs2, present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & + !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v,S_h,S_hr, & + !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA,G_scale, & + !$OMP drho_dT_dT_h,drho_dT_dT_hr,scrap,pres_h,T_h,T_hr, & + !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz,pres_hr, & + !$OMP dzg2A,dzg2B,dzaA,dzaB,dz_harm,Z_to_H, & + !$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,dzN2_v,N2_unlim, & + !$OMP Sfn_unlim_v,Rho_avg,drdj_v,drdkDe_v,c2_dz_v, & + !$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) + do J=js-1,je + do K=nz,2,-1 + if (find_work .and. .not.(use_EOS)) then + drdjA = 0.0 ; drdjB = 0.0 + drdkL = GV%Rlay(k) - GV%Rlay(k-1) ; drdkR = drdkL + endif + + calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & + (find_work .or. .not. present_slope_y .or. CS%use_FGNV_streamfn .or. use_stanley) + + if (calc_derivatives) then + do i=is,ie + pres_v(i) = 0.5*(pres(i,j,K) + pres(i,j+1,K)) + T_v(i) = 0.25*((T(i,j,k) + T(i,j+1,k)) + (T(i,j,k-1) + T(i,j+1,k-1))) + S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) + enddo + call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & + tv%eqn_of_state, EOSdom_v) + endif + if (use_stanley) then + do i=is,ie + pres_h(i) = pres(i,j,K) + T_h(i) = 0.5*(T(i,j,k) + T(i,j,k-1)) + S_h(i) = 0.5*(S(i,j,k) + S(i,j,k-1)) + + pres_hr(i) = pres(i,j+1,K) + T_hr(i) = 0.5*(T(i,j+1,k) + T(i,j+1,k-1)) + S_hr(i) = 0.5*(S(i,j+1,k) + S(i,j+1,k-1)) + enddo + + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_h, S_h, pres_h, & + scrap, scrap, drho_dT_dT_h, scrap, scrap, & + tv%eqn_of_state, EOSdom_v) + call calculate_density_second_derivs(T_hr, S_hr, pres_hr, & + scrap, scrap, drho_dT_dT_hr, scrap, scrap, & + tv%eqn_of_state, EOSdom_v) + endif + do i=is,ie + if (calc_derivatives) then + ! Estimate the horizontal density gradients along layers. + drdjA = drho_dT_v(i) * (T(i,j+1,k-1)-T(i,j,k-1)) + & + drho_dS_v(i) * (S(i,j+1,k-1)-S(i,j,k-1)) + drdjB = drho_dT_v(i) * (T(i,j+1,k)-T(i,j,k)) + & + drho_dS_v(i) * (S(i,j+1,k)-S(i,j,k)) + + ! Estimate the vertical density gradients times the grid spacing. + drdkL = (drho_dT_v(i) * (T(i,j,k)-T(i,j,k-1)) + & + drho_dS_v(i) * (S(i,j,k)-S(i,j,k-1))) + drdkR = (drho_dT_v(i) * (T(i,j+1,k)-T(i,j+1,k-1)) + & + drho_dS_v(i) * (S(i,j+1,k)-S(i,j+1,k-1))) + drdkDe_v(i,K) = drdkR * e(i,j+1,K) - drdkL * e(i,j,K) + elseif (find_work) then ! This is used in pure stacked SW mode + drdkDe_v(i,K) = drdkR * e(i,j+1,K) - drdkL * e(i,j,K) + endif + if (use_stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdjA = drdjA + 0.5 * ((drho_dT_dT_hr(i) * tv%varT(i,j+1,k-1)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k-1)) ) + drdjB = drdjB + 0.5 * ((drho_dT_dT_hr(i) * tv%varT(i,j+1,k)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k)) ) + endif + + if (find_work) drdj_v(i,k) = drdjB + + if (k > nk_linear) then + if (use_EOS) then + if (CS%use_FGNV_streamfn .or. find_work .or. .not. present_slope_y) then + hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 + hg2R = h(i,j+1,k-1)*h(i,j+1,k) + h_neglect2 + haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect + haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect + + if (GV%Boussinesq) then + dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z + elseif (GV%semi_Boussinesq) then + dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect + dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect + else + dzaL = 0.5*(dz(i,j,k-1) + dz(i,j,k)) + dz_neglect + dzaR = 0.5*(dz(i,j+1,k-1) + dz(i,j+1,k)) + dz_neglect + endif + ! Use the harmonic mean thicknesses to weight the horizontal gradients. + ! These unnormalized weights have been rearranged to minimize divisions. + wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) + + drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) + ! The expression for drdz above is mathematically equivalent to: + ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & + ! ((hg2L/haL) + (hg2R/haR)) + hg2A = h(i,j,k-1)*h(i,j+1,k-1) + h_neglect2 + hg2B = h(i,j,k)*h(i,j+1,k) + h_neglect2 + haA = 0.5*(h(i,j,k-1) + h(i,j+1,k-1)) + h_neglect + haB = 0.5*(h(i,j,k) + h(i,j+1,k)) + h_neglect + + if (GV%Boussinesq) then + N2_unlim = drdz*G_rho0 + else + N2_unlim = (GV%g_Earth*GV%RZ_to_H) * & + ((wtL * drdkL + wtR * drdkR) / (haL*wtL + haR*wtR)) + endif + + dzg2A = dz(i,j,k-1)*dz(i,j+1,k-1) + dz_neglect2 + dzg2B = dz(i,j,k)*dz(i,j+1,k) + dz_neglect2 + dzaA = 0.5*(dz(i,j,k-1) + dz(i,j+1,k-1)) + dz_neglect + dzaB = 0.5*(dz(i,j,k) + dz(i,j+1,k)) + dz_neglect + + ! dzN2_v is used with the FGNV streamfunction formulation + dzN2_v(i,K) = (0.5*( dzg2A / dzaA + dzg2B / dzaB )) * max(N2_unlim, N2_floor) + if (find_work .and. CS%GM_src_alt) & + hN2_y_PE(i,J,k) = (0.5*( hg2A / haA + hg2B / haB )) * max(N2_unlim, N2_floor) + endif + if (present_slope_y) then + Slope = slope_y(i,J,k) + slope2_Ratio_v(i,K) = Slope**2 * I_slope_max2 + else + ! Use the harmonic mean thicknesses to weight the horizontal gradients. + ! These unnormalized weights have been rearranged to minimize divisions. + wtA = hg2A*haB ; wtB = hg2B*haA + ! This is the gradient of density along geopotentials. + drdy = ((wtA * drdjA + wtB * drdjB) / (wtA + wtB) - & + drdz * (e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) + + ! This estimate of slope is accurate for small slopes, but bounded + ! to be between -1 and 1. + mag_grad2 = (US%Z_to_L*drdy)**2 + drdz**2 + if (mag_grad2 > 0.0) then + Slope = drdy / sqrt(mag_grad2) + slope2_Ratio_v(i,K) = Slope**2 * I_slope_max2 + else ! Just in case mag_grad2 = 0 ever. + Slope = 0.0 + slope2_Ratio_v(i,K) = 1.0e20 ! Force the use of the safe streamfunction. + endif + endif + + ! Adjust real slope by weights that bias towards slope of interfaces + ! that ignore density gradients along layers. + Slope = (1.0 - int_slope_v(i,J,K)) * Slope + & + int_slope_v(i,J,K) * ((e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J)) + slope2_Ratio_v(i,K) = (1.0 - int_slope_v(i,J,K)) * slope2_Ratio_v(i,K) + + Slope_y_PE(i,J,k) = MIN(Slope,CS%slope_max) + if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope + + Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) + + ! Avoid moving dense water upslope from below the level of + ! the bottom on the receiving side. + if (Sfn_unlim_v(i,K) > 0.0) then ! The flow below this interface is positive. + if (e(i,j,K) < e(i,j+1,nz+1)) then + Sfn_unlim_v(i,K) = 0.0 ! This is not vhtot, because it may compensate for + ! deeper flow in very unusual cases. + elseif (e(i,j+1,nz+1) > e(i,j,K+1)) then + ! Scale the transport with the fraction of the donor layer above + ! the bottom on the receiving side. + Sfn_unlim_v(i,K) = Sfn_unlim_v(i,K) * ((e(i,j,K) - e(i,j+1,nz+1)) / & + ((e(i,j,K) - e(i,j,K+1)) + dz_neglect)) + endif + else + if (e(i,j+1,K) < e(i,j,nz+1)) then ; Sfn_unlim_v(i,K) = 0.0 + elseif (e(i,j,nz+1) > e(i,j+1,K+1)) then + Sfn_unlim_v(i,K) = Sfn_unlim_v(i,K) * ((e(i,j+1,K) - e(i,j,nz+1)) / & + ((e(i,j+1,K) - e(i,j+1,K+1)) + dz_neglect)) + endif + endif + + else ! .not. use_EOS + if (present_slope_y) then + Slope = slope_y(i,J,k) + else + Slope = ((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) * G%OBCmaskCv(i,J) + endif + if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope + Sfn_unlim_v(i,K) = ((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) + dzN2_v(i,K) = GV%g_prime(K) + endif ! if (use_EOS) + else ! if (k > nk_linear) + dzN2_v(i,K) = N2_floor * dz_neglect + Sfn_unlim_v(i,K) = 0. + endif ! if (k > nk_linear) + if (CS%id_sfn_unlim_y>0) diag_sfn_unlim_y(i,J,K) = Sfn_unlim_v(i,K) + enddo ! i-loop + enddo ! k-loop + + if (CS%use_FGNV_streamfn) then + do k=1,nz ; do i=is,ie ; if (G%OBCmaskCv(i,J)>0.) then + dz_harm = max( dz_neglect, & + 2. * dz(i,j,k) * dz(i,j+1,k) / ( ( dz(i,j,k) + dz(i,j+1,k) ) + dz_neglect ) ) + c2_dz_v(i,k) = CS%FGNV_scale * ( 0.5*( cg1(i,j) + cg1(i,j+1) ) )**2 / dz_harm + endif ; enddo ; enddo + + ! Solve an elliptic equation for the streamfunction following Ferrari et al., 2010. + do i=is,ie + if (G%OBCmaskCv(i,J)>0.) then + do K=2,nz + Sfn_unlim_v(i,K) = (1. + CS%FGNV_scale) * Sfn_unlim_v(i,K) + enddo + call streamfn_solver(nz, c2_dz_v(i,:), dzN2_v(i,:), Sfn_unlim_v(i,:)) + else + do K=2,nz + Sfn_unlim_v(i,K) = 0. + enddo + endif + enddo + endif + + do K=nz,2,-1 + do i=is,ie + if (allocated(tv%SpV_avg) .and. (find_work .or. (k > nk_linear)) ) then + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i,j+1,k) + h(i,j+1,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i,j+1,k)+hn_2)*tv%SpV_avg(i,j+1,k) + (h(i,j+1,k-1)+hn_2)*tv%SpV_avg(i,j+1,k-1)) ) + ! Use an average density to convert the volume streamfunction estimate into a mass streamfunction. + Z_to_H = (GV%RZ_to_H*Rho_avg) + else + Z_to_H = GV%Z_to_H + endif + + if (k > nk_linear) then + if (use_EOS) then + + if (vhtot(i,J) <= 0.0) then + ! The transport that must balance the transport below is positive. + Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j,k)) + else ! (vhtot(I,j) > 0.0) + Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j+1,k)) + endif + + ! Find the actual streamfunction at each interface. + Sfn_est = (Z_to_H*Sfn_unlim_v(i,K) + slope2_Ratio_v(i,K)*Sfn_safe) / (1.0 + slope2_Ratio_v(i,K)) + else ! When use_EOS is false, the layers are constant density. + Sfn_est = Z_to_H*Sfn_unlim_v(i,K) + endif + + ! Make sure that there is enough mass above to allow the streamfunction + ! to satisfy the boundary condition of 0 at the surface. + Sfn_in_H = min(max(Sfn_est, -h_avail_rsum(i,j,K)), h_avail_rsum(i,j+1,K)) + + ! The actual transport is limited by the mass available in the two + ! neighboring grid cells. + vhD(i,J,k) = max(min((Sfn_in_H - vhtot(i,J)), h_avail(i,j,k)), -h_avail(i,j+1,k)) + + if (CS%id_sfn_y>0) diag_sfn_y(i,J,K) = diag_sfn_y(i,J,K+1) + vhD(i,J,k) +! sfn_y(i,J,K) = max(min(Sfn_in_h, vhtot(i,J)+h_avail(i,j,k)), & +! vhtot(i,J)-h_avail(i,j+1,k)) +! sfn_slope_y(i,J,K) = max(vhtot(i,J)-h_avail(i,j+1,k), & +! min(vhtot(i,J)+h_avail(i,j,k), & +! min(h_avail_rsum(i,j+1,K), max(-h_avail_rsum(i,j,K), & +! (KH_v(i,J,K)*G%dx_Cv(i,J)) * ((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) )) )) + else ! k <= nk_linear + ! Balance the deeper flow with a return flow uniformly distributed + ! though the remaining near-surface layers. This is the same as + ! using Sfn_safe above. There is no need to apply the limiters in + ! this case. + if (vhtot(i,J) <= 0.0) then + vhD(i,J,k) = -vhtot(i,J) * h_frac(i,j,k) + else ! (vhtot(i,J) > 0.0) + vhD(i,J,k) = -vhtot(i,J) * h_frac(i,j+1,k) + endif + + if (CS%id_sfn_y>0) diag_sfn_y(i,J,K) = diag_sfn_y(i,J,K+1) + vhD(i,J,k) +! if (sfn_slope_y(i,J,K+1) <= 0.0) then +! sfn_slope_y(i,J,K) = sfn_slope_y(i,J,K+1) * (1.0 - h_frac(i,j,k)) +! else +! sfn_slope_y(i,J,K) = sfn_slope_y(i,J,K+1) * (1.0 - h_frac(i,j+1,k)) +! endif + endif + + vhtot(i,J) = vhtot(i,J) + vhD(i,J,k) + + if (find_work) then + ! This is the energy tendency based on the original profiles, and does + ! not include any nonlinear terms due to a finite time step (which would + ! involve interactions between the fluxes through the different faces. + ! A second order centered estimate is used for the density transferred + ! between water columns. + + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth / Rho_avg + else + G_scale = GV%g_Earth * GV%H_to_Z + endif + + Work_v(i,J) = Work_v(i,J) + G_scale * & + ( vhtot(i,J) * drdkDe_v(i,K) - & + (vhD(i,J,k) * drdj_v(i,k)) * 0.25 * & + ((e(i,j,K) + e(i,j,K+1)) + (e(i,j+1,K) + e(i,j+1,K+1))) ) + endif + + enddo + enddo ! end of k-loop + enddo ! end of j-loop + + ! In layer 1, enforce the boundary conditions that Sfn(z=0) = 0.0 + if (.not.find_work .or. .not.(use_EOS)) then + do j=js,je ; do I=is-1,ie ; uhD(I,j,1) = -uhtot(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; vhD(i,J,1) = -vhtot(i,J) ; enddo ; enddo + else + EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) + !$OMP parallel do default(shared) private(pres_u,T_u,S_u,drho_dT_u,drho_dS_u,drdiB,G_scale) + do j=js,je + if (use_EOS) then + do I=is-1,ie + pres_u(I) = 0.5*(pres(i,j,1) + pres(i+1,j,1)) + T_u(I) = 0.5*(T(i,j,1) + T(i+1,j,1)) + S_u(I) = 0.5*(S(i,j,1) + S(i+1,j,1)) + enddo + call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & + tv%eqn_of_state, EOSdom_u ) + endif + do I=is-1,ie + uhD(I,j,1) = -uhtot(I,j) + + G_scale = GV%g_Earth * GV%H_to_Z + if (use_EOS) then + drdiB = drho_dT_u(I) * (T(i+1,j,1)-T(i,j,1)) + & + drho_dS_u(I) * (S(i+1,j,1)-S(i,j,1)) + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth * & + ( ((h(i,j,1)+hn_2) * tv%SpV_avg(i,j,1) + (h(i+1,j,1)+hn_2) * tv%SpV_avg(i+1,j,1)) / & + ( (h(i,j,1) + h(i+1,j,1)) + 2.0*hn_2 ) ) + endif + endif + if (CS%use_GM_work_bug) then + Work_u(I,j) = Work_u(I,j) + G_scale * & + ( (uhD(I,j,1) * drdiB) * 0.25 * & + ((e(i,j,1) + e(i,j,2)) + (e(i+1,j,1) + e(i+1,j,2))) ) + else + Work_u(I,j) = Work_u(I,j) - G_scale * & + ( (uhD(I,j,1) * drdiB) * 0.25 * & + ((e(i,j,1) + e(i,j,2)) + (e(i+1,j,1) + e(i+1,j,2))) ) + endif + enddo + enddo + + EOSdom_v(:) = EOS_domain(G%HI) + !$OMP parallel do default(shared) private(pres_v,T_v,S_v,drho_dT_v,drho_dS_v,drdjB,G_scale) + do J=js-1,je + if (use_EOS) then + do i=is,ie + pres_v(i) = 0.5*(pres(i,j,1) + pres(i,j+1,1)) + T_v(i) = 0.5*(T(i,j,1) + T(i,j+1,1)) + S_v(i) = 0.5*(S(i,j,1) + S(i,j+1,1)) + enddo + call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & + tv%eqn_of_state, EOSdom_v) + endif + do i=is,ie + vhD(i,J,1) = -vhtot(i,J) + + G_scale = GV%g_Earth * GV%H_to_Z + if (use_EOS) then + drdjB = drho_dT_v(i) * (T(i,j+1,1)-T(i,j,1)) + & + drho_dS_v(i) * (S(i,j+1,1)-S(i,j,1)) + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth * & + ( ((h(i,j,1)+hn_2) * tv%SpV_avg(i,j,1) + (h(i,j+1,1)+hn_2) * tv%SpV_avg(i,j+1,1)) / & + ( (h(i,j,1) + h(i,j+1,1)) + 2.0*hn_2 ) ) + endif + endif + Work_v(i,J) = Work_v(i,J) - G_scale * & + ( (vhD(i,J,1) * drdjB) * 0.25 * & + ((e(i,j,1) + e(i,j,2)) + (e(i,j+1,1) + e(i,j+1,2))) ) + enddo + enddo + endif + + if (find_work) then ; do j=js,je ; do i=is,ie + ! Note that the units of Work_v and Work_u are [R Z L4 T-3 ~> W], while Work_h is in [R Z L2 T-3 ~> W m-2]. + Work_h = 0.5 * G%IareaT(i,j) * & + ((Work_u(I-1,j) + Work_u(I,j)) + (Work_v(i,J-1) + Work_v(i,J))) + if (allocated(CS%GMwork)) CS%GMwork(i,j) = Work_h + if (.not. CS%GM_src_alt) then ; if (allocated(MEKE%GM_src)) then + MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + Work_h + endif ; endif + enddo ; enddo ; endif + + if (find_work .and. CS%GM_src_alt) then ; if (allocated(MEKE%GM_src)) then + do j=js,je ; do i=is,ie ; do k=nz,1,-1 + PE_release_h = -0.25 * (GV%H_to_RZ*US%L_to_Z**2) * & + (KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k) + & + Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k) + & + Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k) + & + Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k)) + MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + PE_release_h + enddo ; enddo ; enddo + endif ; endif + + if (CS%id_slope_x > 0) call post_data(CS%id_slope_x, CS%diagSlopeX, CS%diag) + if (CS%id_slope_y > 0) call post_data(CS%id_slope_y, CS%diagSlopeY, CS%diag) + if (CS%id_sfn_x > 0) call post_data(CS%id_sfn_x, diag_sfn_x, CS%diag) + if (CS%id_sfn_y > 0) call post_data(CS%id_sfn_y, diag_sfn_y, CS%diag) + if (CS%id_sfn_unlim_x > 0) call post_data(CS%id_sfn_unlim_x, diag_sfn_unlim_x, CS%diag) + if (CS%id_sfn_unlim_y > 0) call post_data(CS%id_sfn_unlim_y, diag_sfn_unlim_y, CS%diag) + +end subroutine thickness_diffuse_full + +!> Tridiagonal solver for streamfunction at interfaces +subroutine streamfn_solver(nk, c2_h, hN2, sfn) + integer, intent(in) :: nk !< Number of layers + real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers, rescaled to + !! [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces times rescaling factors + !! [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real, dimension(nk+1), intent(inout) :: sfn !< Streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1] or arbitrary units + !! On entry, equals diffusivity times slope. + !! On exit, equals the streamfunction. + ! Local variables + real :: c1(nk) ! The dependence of the final streamfunction on the values below [nondim] + real :: d1 ! The complement of c1(k) (i.e., 1 - c1(k)) [nondim] + real :: b_denom ! A term in the denominator of beta [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real :: beta ! The normalization for the pivot [Z2 T2 H-1 L-2 ~> s2 m-1 or m2 s2 kg-1] + integer :: k + + sfn(1) = 0. + b_denom = hN2(2) + c2_h(1) + beta = 1.0 / ( b_denom + c2_h(2) ) + d1 = beta * b_denom + sfn(2) = ( beta * hN2(2) )*sfn(2) + do K=3,nk + c1(k-1) = beta * c2_h(k-1) + b_denom = hN2(K) + d1*c2_h(k-1) + beta = 1.0 / (b_denom + c2_h(k)) + d1 = beta * b_denom + sfn(K) = beta * (hN2(K)*sfn(K) + c2_h(k-1)*sfn(K-1)) + enddo + c1(nk) = beta * c2_h(nk) + sfn(nk+1) = 0. + do K=nk,2,-1 + sfn(K) = sfn(K) + c1(k)*sfn(K+1) + enddo + +end subroutine streamfn_solver + +!> Add a diffusivity that acts on the isopycnal heights, regardless of the densities +subroutine add_interface_Kh(G, GV, US, CS, Kh_u, Kh_v, Kh_u_CFL, Kh_v_CFL, int_slope_u, int_slope_v) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for thickness_diffuse + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kh_u !< Isopycnal height diffusivity + !! at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: Kh_v !< Isopycnal height diffusivity + !! at v points [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable isopycnal height + !! diffusivity at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable isopycnal height + !! diffusivity at v points [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: int_slope_u !< Ratio that determine how much of + !! the isopycnal slopes are taken directly from + !! the interface slopes without consideration + !! of density gradients [nondim]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: int_slope_v !< Ratio that determine how much of + !! the isopycnal slopes are taken directly from + !! the interface slopes without consideration + !! of density gradients [nondim]. + + ! Local variables + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + do k=1,nz+1 ; do j=js,je ; do I=is-1,ie ; if (CS%Kh_eta_u(I,j) > 0.0) then + int_slope_u(I,j,K) = (int_slope_u(I,j,K)*Kh_u(I,j,K) + CS%Kh_eta_u(I,j)) / & + (Kh_u(I,j,K) + CS%Kh_eta_u(I,j)) + Kh_u(I,j,K) = min(Kh_u(I,j,K) + CS%Kh_eta_u(I,j), Kh_u_CFL(I,j)) + endif ; enddo ; enddo ; enddo + + do k=1,nz+1 ; do J=js-1,je ; do i=is,ie ; if (CS%Kh_eta_v(i,J) > 0.0) then + int_slope_v(i,J,K) = (int_slope_v(i,J,K)*Kh_v(i,J,K) + CS%Kh_eta_v(i,J)) / & + (Kh_v(i,J,K) + CS%Kh_eta_v(i,J)) + Kh_v(i,J,K) = min(Kh_v(i,J,K) + CS%Kh_eta_v(i,J), Kh_v_CFL(i,J)) + endif ; enddo ; enddo ; enddo + +end subroutine add_interface_Kh + +!> Modifies isopycnal height diffusivities to untangle layer structures +subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, US, CS, & + int_slope_u, int_slope_v) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface positions [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kh_u !< Isopycnal height diffusivity + !! at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: Kh_v !< Isopycnal height diffusivity + !! at v points [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable isopycnal height + !! diffusivity at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable isopycnal height + !! diffusivity at v points [L2 T-1 ~> m2 s-1] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, intent(in) :: dt !< Time increment [T ~> s] + type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for thickness_diffuse + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: int_slope_u !< Ratio that determine how much of + !! the isopycnal slopes are taken directly from + !! the interface slopes without consideration + !! of density gradients [nondim]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: int_slope_v !< Ratio that determine how much of + !! the isopycnal slopes are taken directly from + !! the interface slopes without consideration + !! of density gradients [nondim]. + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + de_top ! The distances between the top of a layer and the top of the + ! region where the detangling is applied [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + Kh_lay_u ! The tentative isopycnal height diffusivity for each layer at + ! u points [L2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + Kh_lay_v ! The tentative isopycnal height diffusivity for each layer at + ! v points [L2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: & + de_bot ! The distances from the bottom of the region where the + ! detangling is applied [H ~> m or kg m-2]. + real :: h1, h2 ! The thinner and thicker surrounding thicknesses [H ~> m or kg m-2], + ! with the thinner modified near the boundaries to mask out + ! thickness variations due to topography, etc. + real :: jag_Rat ! The nondimensional jaggedness ratio for a layer, going + ! from 0 (smooth) to 1 (jagged) [nondim]. This is the difference + ! between the arithmetic and harmonic mean thicknesses + ! normalized by the arithmetic mean thickness. + real :: Kh_scale ! A ratio by which Kh_u_CFL is scaled for maximally jagged + ! layers [nondim]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + + real :: I_sl ! The absolute value of the larger in magnitude of the slopes + ! above and below [L Z-1 ~> nondim]. + real :: Rsl ! The ratio of the smaller magnitude slope to the larger + ! magnitude one [nondim]. 0 <= Rsl <1. + real :: IRsl ! The (limited) inverse of Rsl [nondim]. 1 < IRsl <= 1e9. + real :: dH ! The thickness gradient divided by the damping timescale + ! and the ratio of the face length to the adjacent cell + ! areas for comparability with the diffusivities [L Z T-1 ~> m2 s-1]. + real :: adH ! The absolute value of dH [L Z T-1 ~> m2 s-1]. + real :: sign ! 1 or -1, with the same sign as the layer thickness gradient [nondim]. + real :: sl_K ! The sign-corrected slope of the interface above [Z L-1 ~> nondim]. + real :: sl_Kp1 ! The sign-corrected slope of the interface below [Z L-1 ~> nondim]. + real :: I_sl_K ! The (limited) inverse of sl_K [L Z-1 ~> nondim]. + real :: I_sl_Kp1 ! The (limited) inverse of sl_Kp1 [L Z-1 ~> nondim]. + real :: I_4t ! A quarter of a flux scaling factor divided by + ! the damping timescale [T-1 ~> s-1]. + real :: Fn_R ! A function of Rsl, such that Rsl < Fn_R < 1 [nondim] + real :: Idx_eff ! The effective inverse x-grid spacing at a u-point [L-1 ~> m-1] + real :: Idy_eff ! The effective inverse y-grid spacing at a v-point [L-1 ~> m-1] + real :: slope_sq ! The sum of the squared slopes above and below a layer [Z2 L-2 ~> nondim] + real :: Kh_max ! A local ceiling on the diffusivity [L2 T-1 ~> m2 s-1]. + real :: wt1, wt2 ! Nondimensional weights [nondim]. + ! Variables used only in testing code. + ! real, dimension(SZK_(GV)) :: uh_here ! The transport in a layer [Z L2 T-1 ~> m3 s-1] + ! real, dimension(SZK_(GV)+1) :: Sfn ! The streamfunction at an interface [Z L T-1 ~> m2 s-1] + real :: dKh ! An increment in the diffusivity [L2 T-1 ~> m2 s-1]. + + real, dimension(SZIB_(G),SZK_(GV)+1) :: & + Kh_bg, & ! The background (floor) value of Kh [L2 T-1 ~> m2 s-1]. + Kh, & ! The tentative value of Kh [L2 T-1 ~> m2 s-1]. + Kh_detangle, & ! The detangling diffusivity that could be used [L2 T-1 ~> m2 s-1]. + Kh_min_max_p, & ! The smallest ceiling that can be placed on Kh(I,K) + ! based on the value of Kh(I,K+1) [L2 T-1 ~> m2 s-1]. + Kh_min_max_m, & ! The smallest ceiling that can be placed on Kh(I,K) + ! based on the value of Kh(I,K-1) [L2 T-1 ~> m2 s-1]. + ! The following are variables that define the relationships between + ! successive values of Kh. + ! Search for Kh that satisfy... + ! Kh(I,K) >= Kh_min_m(I,K)*Kh(I,K-1) + Kh0_min_m(I,K) + ! Kh(I,K) >= Kh_min_p(I,K)*Kh(I,K+1) + Kh0_min_p(I,K) + ! Kh(I,K) <= Kh_max_m(I,K)*Kh(I,K-1) + Kh0_max_m(I,K) + ! Kh(I,K) <= Kh_max_p(I,K)*Kh(I,K+1) + Kh0_max_p(I,K) + Kh_min_m , & ! See above [nondim]. + Kh0_min_m , & ! See above [L2 T-1 ~> m2 s-1]. + Kh_max_m , & ! See above [nondim]. + Kh0_max_m, & ! See above [L2 T-1 ~> m2 s-1]. + Kh_min_p , & ! See above [nondim]. + Kh0_min_p , & ! See above [L2 T-1 ~> m2 s-1]. + Kh_max_p , & ! See above [nondim]. + Kh0_max_p ! See above [L2 T-1 ~> m2 s-1]. + real, dimension(SZIB_(G)) :: & + Kh_max_max ! The maximum diffusivity permitted in a column [L2 T-1 ~> m2 s-1] + logical, dimension(SZIB_(G)) :: & + do_i ! If true, work on a column. + integer :: i, j, k, n, ish, jsh, is, ie, js, je, nz, k_top + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + k_top = GV%nk_rho_varies + 1 + h_neglect = GV%H_subroundoff + ! The 0.5 is because we are not using uniform weightings, but are + ! distributing the diffusivities more effectively (with wt1 & wt2), but this + ! means that the additions to a single interface can be up to twice as large. + Kh_scale = 0.5 + if (CS%detangle_time > dt) Kh_scale = 0.5 * dt / CS%detangle_time + + do j=js-1,je+1 ; do i=is-1,ie+1 + de_top(i,j,k_top) = 0.0 ; de_bot(i,j) = 0.0 + enddo ; enddo + do k=k_top+1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + de_top(i,j,k) = de_top(i,j,k-1) + h(i,j,k-1) + enddo ; enddo ; enddo + + do j=js,je ; do I=is-1,ie + Kh_lay_u(I,j,nz) = 0.0 ; Kh_lay_u(I,j,k_top) = 0.0 + enddo ; enddo + do J=js-1,je ; do i=is,ie + Kh_lay_v(i,J,nz) = 0.0 ; Kh_lay_v(i,J,k_top) = 0.0 + enddo ; enddo + + do k=nz-1,k_top+1,-1 + ! Find the diffusivities associated with each layer. + do j=js-1,je+1 ; do i=is-1,ie+1 + de_bot(i,j) = de_bot(i,j) + h(i,j,k+1) + enddo ; enddo + + do j=js,je ; do I=is-1,ie ; if (G%OBCmaskCu(I,j) > 0.0) then + if (h(i,j,k) > h(i+1,j,k)) then + h2 = h(i,j,k) + h1 = max( h(i+1,j,k), h2 - min(de_bot(i+1,j), de_top(i+1,j,k)) ) + else + h2 = h(i+1,j,k) + h1 = max( h(i,j,k), h2 - min(de_bot(i,j), de_top(i,j,k)) ) + endif + jag_Rat = (h2 - h1)**2 / (h2 + h1 + h_neglect)**2 + KH_lay_u(I,j,k) = (Kh_scale * KH_u_CFL(I,j)) * jag_Rat**2 + endif ; enddo ; enddo + + do J=js-1,je ; do i=is,ie ; if (G%OBCmaskCv(i,J) > 0.0) then + if (h(i,j,k) > h(i,j+1,k)) then + h2 = h(i,j,k) + h1 = max( h(i,j+1,k), h2 - min(de_bot(i,j+1), de_top(i,j+1,k)) ) + else + h2 = h(i,j+1,k) + h1 = max( h(i,j,k), h2 - min(de_bot(i,j), de_top(i,j,k)) ) + endif + jag_Rat = (h2 - h1)**2 / (h2 + h1 + h_neglect)**2 + KH_lay_v(i,J,k) = (Kh_scale * KH_v_CFL(i,J)) * jag_Rat**2 + endif ; enddo ; enddo + enddo + + ! Limit the diffusivities + + I_4t = Kh_scale / (4.0 * dt) + + do n=1,2 + if (n==1) then ; jsh = js ; ish = is-1 + else ; jsh = js-1 ; ish = is ; endif + + do j=jsh,je + + ! First, populate the diffusivities + if (n==1) then ! This is a u-column. + do i=ish,ie + do_i(I) = (G%OBCmaskCu(I,j) > 0.0) + Kh_Max_max(I) = KH_u_CFL(I,j) + enddo + do K=1,nz+1 ; do i=ish,ie + Kh_bg(I,K) = KH_u(I,j,K) ; Kh(I,K) = Kh_bg(I,K) + Kh_min_max_p(I,K) = Kh_bg(I,K) ; Kh_min_max_m(I,K) = Kh_bg(I,K) + Kh_detangle(I,K) = 0.0 + enddo ; enddo + else ! This is a v-column. + do i=ish,ie + do_i(i) = (G%OBCmaskCv(i,J) > 0.0) ; Kh_Max_max(I) = KH_v_CFL(i,J) + enddo + do K=1,nz+1 ; do i=ish,ie + Kh_bg(I,K) = KH_v(I,j,K) ; Kh(I,K) = Kh_bg(I,K) + Kh_min_max_p(I,K) = Kh_bg(I,K) ; Kh_min_max_m(I,K) = Kh_bg(I,K) + Kh_detangle(I,K) = 0.0 + enddo ; enddo + endif + + ! Determine the limits on the diffusivities. + do k=k_top,nz ; do i=ish,ie ; if (do_i(i)) then + if (n==1) then ! This is a u-column. + dH = 0.0 + Idx_eff = ((G%IareaT(i+1,j) + G%IareaT(i,j)) * G%dy_Cu(I,j)) + ! This expression uses differences in e in place of h for better + ! consistency with the slopes. + if (Idx_eff > 0.0) & + dH = I_4t * ((e(i+1,j,K) - e(i+1,j,K+1)) - & + (e(i,j,K) - e(i,j,K+1))) / Idx_eff + ! dH = I_4t * (h(i+1,j,k) - h(i,j,k)) / Idx_eff + + adH = abs(dH) + sign = 1.0 ; if (dH < 0) sign = -1.0 + sl_K = sign * (e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j) + sl_Kp1 = sign * (e(i+1,j,K+1)-e(i,j,K+1)) * G%IdxCu(I,j) + + ! Add the incremental diffusivities to the surrounding interfaces. + ! Adding more to the more steeply sloping layers (as below) makes + ! the diffusivities more than twice as effective. + slope_sq = (sl_K**2 + sl_Kp1**2) + wt1 = 0.5 ; wt2 = 0.5 + if (slope_sq > 0.0) then + wt1 = sl_K**2 / slope_sq ; wt2 = sl_Kp1**2 / slope_sq + endif + Kh_detangle(I,K) = Kh_detangle(I,K) + wt1*KH_lay_u(I,j,k) + Kh_detangle(I,K+1) = Kh_detangle(I,K+1) + wt2*KH_lay_u(I,j,k) + else ! This is a v-column. + dH = 0.0 + Idy_eff = ((G%IareaT(i,j+1) + G%IareaT(i,j)) * G%dx_Cv(I,j)) + if (Idy_eff > 0.0) & + dH = I_4t * ((e(i,j+1,K) - e(i,j+1,K+1)) - & + (e(i,j,K) - e(i,j,K+1))) / Idy_eff + ! dH = I_4t * (h(i,j+1,k) - h(i,j,k)) / Idy_eff + + adH = abs(dH) + sign = 1.0 ; if (dH < 0) sign = -1.0 + sl_K = sign * (e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J) + sl_Kp1 = sign * (e(i,j+1,K+1)-e(i,j,K+1)) * G%IdyCv(i,J) + + ! Add the incremental diffusivities to the surrounding interfaces. + ! Adding more to the more steeply sloping layers (as below) makes + ! the diffusivities more than twice as effective. + slope_sq = (sl_K**2 + sl_Kp1**2) + wt1 = 0.5 ; wt2 = 0.5 + if (slope_sq > 0.0) then + wt1 = sl_K**2 / slope_sq ; wt2 = sl_Kp1**2 / slope_sq + endif + Kh_detangle(I,K) = Kh_detangle(I,K) + wt1*KH_lay_v(i,J,k) + Kh_detangle(I,K+1) = Kh_detangle(I,K+1) + wt2*KH_lay_v(i,J,k) + endif + + if (adH == 0.0) then + Kh_min_m(I,K+1) = 1.0 ; Kh0_min_m(I,K+1) = 0.0 + Kh_max_m(I,K+1) = 1.0 ; Kh0_max_m(I,K+1) = 0.0 + Kh_min_p(I,K) = 1.0 ; Kh0_min_p(I,K) = 0.0 + Kh_max_p(I,K) = 1.0 ; Kh0_max_p(I,K) = 0.0 + elseif (adH > 0.0) then + if (sl_K <= sl_Kp1) then + ! This case should only arise from nonlinearities in the equation of state. + ! Treat it as though dedx(K) = dedx(K+1) & dH = 0. + Kh_min_m(I,K+1) = 1.0 ; Kh0_min_m(I,K+1) = 0.0 + Kh_max_m(I,K+1) = 1.0 ; Kh0_max_m(I,K+1) = 0.0 + Kh_min_p(I,K) = 1.0 ; Kh0_min_p(I,K) = 0.0 + Kh_max_p(I,K) = 1.0 ; Kh0_max_p(I,K) = 0.0 + elseif (sl_K <= 0.0) then ! Both slopes are opposite to dH + I_sl = -1.0 / sl_Kp1 + Rsl = -sl_K * I_sl ! 0 <= Rsl < 1 + IRsl = 1e9 ; if (Rsl > 1e-9) IRsl = 1.0/Rsl ! 1 < IRsl <= 1e9 + + Fn_R = Rsl + if (Kh_max_max(I) > 0) & + Fn_R = min(sqrt(Rsl), Rsl + (adH * I_sl) / (Kh_Max_max(I))) + + Kh_min_m(I,K+1) = Fn_R ; Kh0_min_m(I,K+1) = 0.0 + Kh_max_m(I,K+1) = Rsl ; Kh0_max_m(I,K+1) = adH * I_sl + Kh_min_p(I,K) = IRsl ; Kh0_min_p(I,K) = -adH * (I_sl*IRsl) + Kh_max_p(I,K) = 1.0/(Fn_R + 1.0e-30) ; Kh0_max_p(I,K) = 0.0 + elseif (sl_Kp1 < 0.0) then ! Opposite (nonzero) signs of slopes. + I_sl_K = 1e18*US%Z_to_L ; if (sl_K > 1e-18*US%L_to_Z) I_sl_K = 1.0 / sl_K + I_sl_Kp1 = 1e18*US%Z_to_L ; if (-sl_Kp1 > 1e-18*US%L_to_Z) I_sl_Kp1 = -1.0 / sl_Kp1 + + Kh_min_m(I,K+1) = 0.0 ; Kh0_min_m(I,K+1) = 0.0 + Kh_max_m(I,K+1) = - sl_K*I_sl_Kp1 ; Kh0_max_m(I,K+1) = adH*I_sl_Kp1 + Kh_min_p(I,K) = 0.0 ; Kh0_min_p(I,K) = 0.0 + Kh_max_p(I,K) = sl_Kp1*I_sl_K ; Kh0_max_p(I,K) = adH*I_sl_K + + ! This limit does not use the slope weighting so that potentially + ! sharp gradients in diffusivities are not forced to occur. + Kh_Max = adH / (sl_K - sl_Kp1) + Kh_min_max_p(I,K) = max(Kh_min_max_p(I,K), Kh_Max) + Kh_min_max_m(I,K+1) = max(Kh_min_max_m(I,K+1), Kh_Max) + else ! Both slopes are of the same sign as dH. + I_sl = 1.0 / sl_K + Rsl = sl_Kp1 * I_sl ! 0 <= Rsl < 1 + IRsl = 1e9 ; if (Rsl > 1e-9) IRsl = 1.0/Rsl ! 1 < IRsl <= 1e9 + + ! Rsl <= Fn_R <= 1 + Fn_R = Rsl + if (Kh_max_max(I) > 0) & + Fn_R = min(sqrt(Rsl), Rsl + (adH * I_sl) / Kh_Max_max(I)) + + Kh_min_m(I,K+1) = IRsl ; Kh0_min_m(I,K+1) = -adH * (I_sl*IRsl) + Kh_max_m(I,K+1) = 1.0/(Fn_R + 1.0e-30) ; Kh0_max_m(I,K+1) = 0.0 + Kh_min_p(I,K) = Fn_R ; Kh0_min_p(I,K) = 0.0 + Kh_max_p(I,K) = Rsl ; Kh0_max_p(I,K) = adH * I_sl + endif + endif + endif ; enddo ; enddo ! I-loop & k-loop + + do k=k_top,nz+1,nz+1-k_top ; do i=ish,ie ; if (do_i(i)) then + ! The diffusivities at k_top and nz+1 are both fixed. + Kh_min_m(I,k) = 0.0 ; Kh0_min_m(I,k) = 0.0 + Kh_max_m(I,k) = 0.0 ; Kh0_max_m(I,k) = 0.0 + Kh_min_p(I,k) = 0.0 ; Kh0_min_p(I,k) = 0.0 + Kh_max_p(I,k) = 0.0 ; Kh0_max_p(I,k) = 0.0 + Kh_min_max_p(I,K) = Kh_bg(I,K) + Kh_min_max_m(I,K) = Kh_bg(I,K) + endif ; enddo ; enddo ! I-loop and k_top/nz+1 loop + + ! Search for Kh that satisfy... + ! Kh(I,K) >= Kh_min_m(I,K)*Kh(I,K-1) + Kh0_min_m(I,K) + ! Kh(I,K) >= Kh_min_p(I,K)*Kh(I,K+1) + Kh0_min_p(I,K) + ! Kh(I,K) <= Kh_max_m(I,K)*Kh(I,K-1) + Kh0_max_m(I,K) + ! Kh(I,K) <= Kh_max_p(I,K)*Kh(I,K+1) + Kh0_max_p(I,K) + + ! Increase the diffusivities to satisfy the min constraints. + ! All non-zero min constraints on one diffusivity are max constraints on another. + do K=k_top+1,nz ; do i=ish,ie ; if (do_i(i)) then + Kh(I,K) = max(Kh_bg(I,K), Kh_detangle(I,K), & + min(Kh_min_m(I,K)*Kh(I,K-1) + Kh0_min_m(I,K), Kh(I,K-1))) + + if (Kh0_max_m(I,K) > Kh_bg(I,K)) Kh(I,K) = min(Kh(I,K), Kh0_max_m(I,K)) + if (Kh0_max_p(I,K) > Kh_bg(I,K)) Kh(I,K) = min(Kh(I,K), Kh0_max_p(I,K)) + endif ; enddo ; enddo ! I-loop & k-loop + ! This is still true... do i=ish,ie ; Kh(I,nz+1) = Kh_bg(I,nz+1) ; enddo + do K=nz,k_top+1,-1 ; do i=ish,ie ; if (do_i(i)) then + Kh(I,k) = max(Kh(I,K), min(Kh_min_p(I,K)*Kh(I,K+1) + Kh0_min_p(I,K), Kh(I,K+1))) + + Kh_Max = max(Kh_min_max_p(I,K), Kh_max_p(I,K)*Kh(I,K+1) + Kh0_max_p(I,K)) + Kh(I,k) = min(Kh(I,k), Kh_Max) + endif ; enddo ; enddo ! I-loop & k-loop + ! All non-zero min constraints on one diffusivity are max constraints on + ! another layer, so the min constraints can now be discounted. + + ! Decrease the diffusivities to satisfy the max constraints. + do K=k_top+1,nz ; do i=ish,ie ; if (do_i(i)) then + Kh_Max = max(Kh_min_max_m(I,K), Kh_max_m(I,K)*Kh(I,K-1) + Kh0_max_m(I,K)) + if (Kh(I,k) > Kh_Max) Kh(I,k) = Kh_Max + endif ; enddo ; enddo ! i- and K-loops + + ! This code tests the solutions... +! do i=ish,ie +! Sfn(:) = 0.0 ; uh_here(:) = 0.0 +! do K=k_top,nz +! if ((Kh(i,K) > Kh_bg(i,K)) .or. (Kh(i,K+1) > Kh_bg(i,K+1))) then +! if (n==1) then ! u-point. +! if ((h(i+1,j,k) - h(i,j,k)) * & +! ((e(i+1,j,K)-e(i+1,j,K+1)) - (e(i,j,K)-e(i,j,K+1))) > 0.0) then +! Sfn(K) = -Kh(i,K) * (e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j) +! Sfn(K+1) = -Kh(i,K+1) * (e(i+1,j,K+1)-e(i,j,K+1)) * G%IdxCu(I,j) +! uh_here(k) = (Sfn(K) - Sfn(K+1))*G%dy_Cu(I,j) +! if (abs(uh_here(k)) * min(G%IareaT(i,j), G%IareaT(i+1,j)) > & +! (1e-10*GV%m_to_H)) then +! if (uh_here(k) * (h(i+1,j,k) - h(i,j,k)) > 0.0) then +! call MOM_error(WARNING, "Corrective u-transport is up the thickness gradient.", .true.) +! endif +! if (((h(i,j,k) - 4.0*dt*G%IareaT(i,j)*uh_here(k)) - & +! (h(i+1,j,k) + 4.0*dt*G%IareaT(i+1,j)*uh_here(k))) * & +! (h(i,j,k) - h(i+1,j,k)) < 0.0) then +! call MOM_error(WARNING, "Corrective u-transport is too large.", .true.) +! endif +! endif +! endif +! else ! v-point +! if ((h(i,j+1,k) - h(i,j,k)) * & +! ((e(i,j+1,K)-e(i,j+1,K+1)) - (e(i,j,K)-e(i,j,K+1))) > 0.0) then +! Sfn(K) = -Kh(i,K) * (e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J) +! Sfn(K+1) = -Kh(i,K+1) * (e(i,j+1,K+1)-e(i,j,K+1)) * G%IdyCv(i,J) +! uh_here(k) = (Sfn(K) - Sfn(K+1))*G%dx_Cv(i,J) +! if (abs(uh_here(K)) * min(G%IareaT(i,j), G%IareaT(i,j+1)) > & +! (1e-10*GV%m_to_H)) then +! if (uh_here(K) * (h(i,j+1,k) - h(i,j,k)) > 0.0) then +! call MOM_error(WARNING, & +! "Corrective v-transport is up the thickness gradient.", .true.) +! endif +! if (((h(i,j,k) - 4.0*dt*G%IareaT(i,j)*uh_here(K)) - & +! (h(i,j+1,k) + 4.0*dt*G%IareaT(i,j+1)*uh_here(K))) * & +! (h(i,j,k) - h(i,j+1,k)) < 0.0) then +! call MOM_error(WARNING, & +! "Corrective v-transport is too large.", .true.) +! endif +! endif +! endif +! endif ! u- or v- selection. +! ! de_dx(I,K) = (e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j) +! endif +! enddo +! enddo + + if (n==1) then ! This is a u-column. + do K=k_top+1,nz ; do i=ish,ie + if (Kh(I,K) > KH_u(I,j,K)) then + dKh = (Kh(I,K) - KH_u(I,j,K)) + int_slope_u(I,j,K) = dKh / Kh(I,K) + KH_u(I,j,K) = Kh(I,K) + endif + enddo ; enddo + else ! This is a v-column. + do K=k_top+1,nz ; do i=ish,ie + if (Kh(i,K) > KH_v(i,J,K)) then + dKh = Kh(i,K) - KH_v(i,J,K) + int_slope_v(i,J,K) = dKh / Kh(i,K) + KH_v(i,J,K) = Kh(i,K) + endif + enddo ; enddo + endif + + enddo ! j-loop + enddo ! n-loop over u- and v- directions. + +end subroutine add_detangling_Kh + +!> Initialize the isopycnal height diffusion module and its control structure +subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) + type(time_type), intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handles + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation diagnostics + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse + + ! Local variables + character(len=40) :: mdl = "MOM_thickness_diffuse" ! This module's name. + character(len=200) :: khth_file, inputdir, khth_varname + ! This include declares and sets the variable "version". +# include "version_variable.h" + real :: grid_sp ! The local grid spacing [L ~> m] + real :: omega ! The Earth's rotation rate [T-1 ~> s-1] + real :: strat_floor ! A floor for buoyancy frequency in the Ferrari et al. 2010, + ! streamfunction formulation, expressed as a fraction of planetary + ! rotation [nondim]. + real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale + ! temperature variance [nondim] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: i, j + + CS%initialized = .true. + CS%diag => diag + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "THICKNESSDIFFUSE", CS%thickness_diffuse, & + "If true, interface heights are diffused with a "//& + "coefficient of KHTH.", default=.false.) + call get_param(param_file, mdl, "KHTH", CS%Khth, & + "The background horizontal thickness diffusivity.", & + default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "READ_KHTH", CS%read_khth, & + "If true, read a file (given by KHTH_FILE) containing the "//& + "spatially varying horizontal isopycnal height diffusivity.", & + default=.false.) + if (CS%read_khth) then + if (CS%Khth > 0) then + call MOM_error(FATAL, "thickness_diffuse_init: KHTH > 0 is not "// & + "compatible with READ_KHTH = TRUE. ") + endif + call get_param(param_file, mdl, "INPUTDIR", inputdir, & + "The directory in which all input files are found.", & + default=".", do_not_log=.true.) + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "KHTH_FILE", khth_file, & + "The file containing the spatially varying horizontal "//& + "isopycnal height diffusivity.", default="khth.nc") + call get_param(param_file, mdl, "KHTH_VARIABLE", khth_varname, & + "The name of the isopycnal height diffusivity variable to read "//& + "from KHTH_FILE.", & + default="khth") + khth_file = trim(inputdir) // trim(khth_file) + + allocate(CS%khth2d(G%isd:G%ied, G%jsd:G%jed), source=0.0) + call MOM_read_data(khth_file, khth_varname, CS%khth2d(:,:), G%domain, scale=US%m_to_L**2*US%T_to_s) + call pass_var(CS%khth2d, G%domain) + endif + call get_param(param_file, mdl, "KHTH_SLOPE_CFF", CS%KHTH_Slope_Cff, & + "The nondimensional coefficient in the Visbeck formula for "//& + "the interface depth diffusivity", units="nondim", default=0.0) + call get_param(param_file, mdl, "GRAD_L_SCALE", CS%GRAD_L_Scale, & + "The nondimensional coefficient in the Gradient model for "//& + "the thickness depth diffusivity", units="nondim", default=1.0) + call get_param(param_file, mdl, "KHTH_MIN", CS%KHTH_Min, & + "The minimum horizontal thickness diffusivity.", & + default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KHTH_MAX", CS%KHTH_Max, & + "The maximum horizontal thickness diffusivity.", & + default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KHTH_MAX_CFL", CS%max_Khth_CFL, & + "The maximum value of the local diffusive CFL ratio that "//& + "is permitted for the thickness diffusivity. 1.0 is the "//& + "marginally unstable value in a pure layered model, but "//& + "much smaller numbers (e.g. 0.1) seem to work better for "//& + "ALE-based models.", units="nondimensional", default=0.8) + + call get_param(param_file, mdl, "KH_ETA_CONST", CS%Kh_eta_bg, & + "The background horizontal diffusivity of the interface heights (without "//& + "considering the layer density structure). If diffusive CFL limits are "//& + "encountered, the diffusivities of the isopycnals and the interfaces heights "//& + "are scaled back proportionately.", & + default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KH_ETA_VEL_SCALE", CS%Kh_eta_vel, & + "A velocity scale that is multiplied by the grid spacing to give a contribution "//& + "to the horizontal diffusivity of the interface heights (without considering "//& + "the layer density structure).", & + default=0.0, units="m s-1", scale=US%m_to_L*US%T_to_s) + + if ((CS%Kh_eta_bg > 0.0) .or. (CS%Kh_eta_vel > 0.0)) then + allocate(CS%Kh_eta_u(G%IsdB:G%IedB, G%jsd:G%jed), source=0.) + allocate(CS%Kh_eta_v(G%isd:G%ied, G%JsdB:G%JedB), source=0.) + do j=G%jsc,G%jec ; do I=G%isc-1,G%iec + grid_sp = sqrt((2.0*G%dxCu(I,j)**2 * G%dyCu(I,j)**2) / (G%dxCu(I,j)**2 + G%dyCu(I,j)**2)) + CS%Kh_eta_u(I,j) = G%OBCmaskCu(I,j) * MAX(0.0, CS%Kh_eta_bg + CS%Kh_eta_vel * grid_sp) + enddo ; enddo + do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + grid_sp = sqrt((2.0*G%dxCv(i,J)**2 * G%dyCv(i,J)**2) / (G%dxCv(i,J)**2 + G%dyCv(i,J)**2)) + CS%Kh_eta_v(i,J) = G%OBCmaskCv(i,J) * MAX(0.0, CS%Kh_eta_bg + CS%Kh_eta_vel * grid_sp) + enddo ; enddo + endif + + if (CS%max_Khth_CFL < 0.0) CS%max_Khth_CFL = 0.0 + call get_param(param_file, mdl, "DETANGLE_INTERFACES", CS%detangle_interfaces, & + "If defined add 3-d structured enhanced interface height "//& + "diffusivities to horizontally smooth jagged layers.", & + default=.false.) + CS%detangle_time = 0.0 + if (CS%detangle_interfaces) & + call get_param(param_file, mdl, "DETANGLE_TIMESCALE", CS%detangle_time, & + "A timescale over which maximally jagged grid-scale "//& + "thickness variations are suppressed. This must be "//& + "longer than DT, or 0 to use DT.", units="s", default=0.0, scale=US%s_to_T) + call get_param(param_file, mdl, "KHTH_SLOPE_MAX", CS%slope_max, & + "A slope beyond which the calculated isopycnal slope is "//& + "not reliable and is scaled away.", units="nondim", default=0.01, scale=US%L_to_Z) + call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & + "A diapycnal diffusivity that is used to interpolate "//& + "more sensible values of T & S into thin layers.", & + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", CS%use_FGNV_streamfn, & + "If true, use the streamfunction formulation of "//& + "Ferrari et al., 2010, which effectively emphasizes "//& + "graver vertical modes by smoothing in the vertical.", & + default=.false.) + call get_param(param_file, mdl, "FGNV_FILTER_SCALE", CS%FGNV_scale, & + "A coefficient scaling the vertical smoothing term in the "//& + "Ferrari et al., 2010, streamfunction formulation.", & + units="nondim", default=1., do_not_log=.not.CS%use_FGNV_streamfn) + call get_param(param_file, mdl, "FGNV_C_MIN", CS%FGNV_c_min, & + "A minium wave speed used in the Ferrari et al., 2010, "//& + "streamfunction formulation.", & + default=0., units="m s-1", scale=US%m_s_to_L_T, do_not_log=.not.CS%use_FGNV_streamfn) + call get_param(param_file, mdl, "FGNV_STRAT_FLOOR", strat_floor, & + "A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010, "//& + "streamfunction formulation, expressed as a fraction of planetary "//& + "rotation, OMEGA. This should be tiny but non-zero to avoid degeneracy.", & + default=1.e-15, units="nondim", do_not_log=.not.CS%use_FGNV_streamfn) + call get_param(param_file, mdl, "USE_STANLEY_GM", CS%use_stanley_gm, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in GM code.", default=.false.) + if (CS%use_stanley_gm) then + call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & + "Coefficient correlating the temperature gradient and SGS T variance.", & + units="nondim", default=-1.0, do_not_log=.true.) + if (Stanley_coeff < 0.0) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if USE_STANLEY_GM is true.") + endif + call get_param(param_file, mdl, "OMEGA", omega, & + "The rotation rate of the earth.", & + default=7.2921e-5, units="s-1", scale=US%T_to_s, do_not_log=.not.CS%use_FGNV_streamfn) + CS%N2_floor = 0. + if (CS%use_FGNV_streamfn) CS%N2_floor = (strat_floor*omega)**2 + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + + call get_param(param_file, mdl, "MEKE_GM_SRC_ALT", CS%GM_src_alt, & + "If true, use the GM energy conversion form S^2*N^2*kappa rather "//& + "than the streamfunction for the GM source term.", default=.false.) + call get_param(param_file, mdl, "MEKE_GEOMETRIC", CS%MEKE_GEOMETRIC, & + "If true, uses the GM coefficient formulation from the GEOMETRIC "//& + "framework (Marshall et al., 2012).", default=.false.) + if (CS%MEKE_GEOMETRIC) then + call get_param(param_file, mdl, "MEKE_GEOMETRIC_EPSILON", CS%MEKE_GEOMETRIC_epsilon, & + "Minimum Eady growth rate used in the calculation of GEOMETRIC "//& + "thickness diffusivity.", units="s-1", default=1.0e-7, scale=US%T_to_s) + call get_param(param_file, mdl, "MEKE_GEOMETRIC_ALPHA", CS%MEKE_GEOMETRIC_alpha, & + "The nondimensional coefficient governing the efficiency of the GEOMETRIC "//& + "thickness diffusion.", units="nondim", default=0.05) + + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "MEKE_GEOMETRIC_ANSWER_DATE", CS%MEKE_GEOM_answer_date, & + "The vintage of the expressions in the MEKE_GEOMETRIC calculation. "//& + "Values below 20190101 recover the answers from the original implementation, "//& + "while higher values use expressions that satisfy rotational symmetry.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%MEKE_GEOM_answer_date = max(CS%MEKE_GEOM_answer_date, 20230701) + endif + + call get_param(param_file, mdl, "USE_KH_IN_MEKE", CS%Use_KH_in_MEKE, & + "If true, uses the thickness diffusivity calculated here to diffuse MEKE.", & + default=.false.) + call get_param(param_file, mdl, "MEKE_MIN_DEPTH_DIFF", CS%MEKE_min_depth_diff, & + "The minimum total depth over which to average the diffusivity used for MEKE. "//& + "When the total depth is less than this, the diffusivity is scaled away.", & + units="m", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%Use_KH_in_MEKE) + + call get_param(param_file, mdl, "USE_GME", CS%use_GME_thickness_diffuse, & + "If true, use the GM+E backscatter scheme in association "//& + "with the Gent and McWilliams parameterization.", default=.false.) + + call get_param(param_file, mdl, "USE_GM_WORK_BUG", CS%use_GM_work_bug, & + "If true, compute the top-layer work tendency on the u-grid "//& + "with the incorrect sign, for legacy reproducibility.", & + default=.false.) + + if (CS%use_GME_thickness_diffuse) then + allocate(CS%KH_u_GME(G%IsdB:G%IedB, G%jsd:G%jed, GV%ke+1), source=0.) + allocate(CS%KH_v_GME(G%isd:G%ied, G%JsdB:G%JedB, GV%ke+1), source=0.) + endif + + CS%id_uhGM = register_diag_field('ocean_model', 'uhGM', diag%axesCuL, Time, & + 'Time Mean Diffusive Zonal Thickness Flux', & + 'kg s-1', conversion=GV%H_to_kg_m2*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) + if (CS%id_uhGM > 0) call safe_alloc_ptr(CDp%uhGM,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) + CS%id_vhGM = register_diag_field('ocean_model', 'vhGM', diag%axesCvL, Time, & + 'Time Mean Diffusive Meridional Thickness Flux', & + 'kg s-1', conversion=GV%H_to_kg_m2*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) + if (CS%id_vhGM > 0) call safe_alloc_ptr(CDp%vhGM,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) + + CS%id_GMwork = register_diag_field('ocean_model', 'GMwork', diag%axesT1, Time, & + 'Integrated Tendency of Ocean Mesoscale Eddy KE from Parameterized Eddy Advection', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2, cmor_field_name='tnkebto', & + cmor_long_name='Integrated Tendency of Ocean Mesoscale Eddy KE from Parameterized Eddy Advection', & + cmor_standard_name='tendency_of_ocean_eddy_kinetic_energy_content_due_to_parameterized_eddy_advection') + if (CS%id_GMwork > 0) & + allocate(CS%GMwork(G%isd:G%ied,G%jsd:G%jed), source=0.) + + CS%id_KH_u = register_diag_field('ocean_model', 'KHTH_u', diag%axesCui, Time, & + 'Parameterized mesoscale eddy advection diffusivity at U-point', & + 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_KH_v = register_diag_field('ocean_model', 'KHTH_v', diag%axesCvi, Time, & + 'Parameterized mesoscale eddy advection diffusivity at V-point', & + 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_KH_t = register_diag_field('ocean_model', 'KHTH_t', diag%axesTL, Time, & + 'Ocean Tracer Diffusivity due to Parameterized Mesoscale Advection', & + 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T, & + cmor_field_name='diftrblo', & + cmor_long_name='Ocean Tracer Diffusivity due to Parameterized Mesoscale Advection', & + cmor_standard_name='ocean_tracer_diffusivity_due_to_parameterized_mesoscale_advection') + + CS%id_KH_u1 = register_diag_field('ocean_model', 'KHTH_u1', diag%axesCu1, Time, & + 'Parameterized mesoscale eddy advection diffusivity at U-points (2-D)', & + 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_KH_v1 = register_diag_field('ocean_model', 'KHTH_v1', diag%axesCv1, Time, & + 'Parameterized mesoscale eddy advection diffusivity at V-points (2-D)', & + 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_KH_t1 = register_diag_field('ocean_model', 'KHTH_t1', diag%axesT1, Time, & + 'Parameterized mesoscale eddy advection diffusivity at T-points (2-D)', & + 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + + CS%id_slope_x = register_diag_field('ocean_model', 'neutral_slope_x', diag%axesCui, Time, & + 'Zonal slope of neutral surface', 'nondim', conversion=US%Z_to_L) + if (CS%id_slope_x > 0) & + allocate(CS%diagSlopeX(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke+1), source=0.) + + CS%id_slope_y = register_diag_field('ocean_model', 'neutral_slope_y', diag%axesCvi, Time, & + 'Meridional slope of neutral surface', 'nondim', conversion=US%Z_to_L) + if (CS%id_slope_y > 0) & + allocate(CS%diagSlopeY(G%isd:G%ied,G%JsdB:G%JedB,GV%ke+1), source=0.) + + CS%id_sfn_x = register_diag_field('ocean_model', 'GM_sfn_x', diag%axesCui, Time, & + 'Parameterized Zonal Overturning Streamfunction', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) + CS%id_sfn_y = register_diag_field('ocean_model', 'GM_sfn_y', diag%axesCvi, Time, & + 'Parameterized Meridional Overturning Streamfunction', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) + CS%id_sfn_unlim_x = register_diag_field('ocean_model', 'GM_sfn_unlim_x', diag%axesCui, Time, & + 'Parameterized Zonal Overturning Streamfunction before limiting/smoothing', & + 'm3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_sfn_unlim_y = register_diag_field('ocean_model', 'GM_sfn_unlim_y', diag%axesCvi, Time, & + 'Parameterized Meridional Overturning Streamfunction before limiting/smoothing', & + 'm3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + +end subroutine thickness_diffuse_init + +!> Copies KH_u_GME and KH_v_GME from private type into arrays provided as arguments +subroutine thickness_diffuse_get_KH(CS, KH_u_GME, KH_v_GME, G, GV) + type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for this module + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: KH_u_GME !< Isopycnal height + !! diffusivities at u-faces [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: KH_v_GME !< Isopycnal height + !! diffusivities at v-faces [L2 T-1 ~> m2 s-1] + ! Local variables + integer :: i,j,k + + do k=1,GV%ke+1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec + KH_u_GME(I,j,k) = CS%KH_u_GME(I,j,k) + enddo ; enddo ; enddo + + do k=1,GV%ke+1 ; do J = G%jsc-1, G%jec ; do i = G%isc, G%iec + KH_v_GME(i,J,k) = CS%KH_v_GME(i,J,k) + enddo ; enddo ; enddo + +end subroutine thickness_diffuse_get_KH + +!> Deallocate the thickness_diffus3 control structure +subroutine thickness_diffuse_end(CS, CDp) + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse + type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity diagnostic control structure + + if (CS%id_slope_x > 0) deallocate(CS%diagSlopeX) + if (CS%id_slope_y > 0) deallocate(CS%diagSlopeY) + + if (CS%id_GMwork > 0) deallocate(CS%GMwork) + + ! NOTE: [uv]hGM may be allocated either here or the diagnostic module + if (associated(CDp%uhGM)) deallocate(CDp%uhGM) + if (associated(CDp%vhGM)) deallocate(CDp%vhGM) + + if (CS%use_GME_thickness_diffuse) then + deallocate(CS%KH_u_GME) + deallocate(CS%KH_v_GME) + endif + + if (allocated(CS%khth2d)) deallocate(CS%khth2d) +end subroutine thickness_diffuse_end + +!> \namespace mom_thickness_diffuse +!! +!! \section section_gm Isopycnal height diffusion (aka Gent-McWilliams) +!! +!! Isopycnal height diffusion is implemented via along-layer mass fluxes +!! \f[ +!! h^\dagger \leftarrow h^n - \Delta t \nabla \cdot ( \vec{uh}^* ) +!! \f] +!! where the mass fluxes are cast as the difference in vector streamfunction +!! +!! \f[ +!! \vec{uh}^* = \delta_k \vec{\psi} . +!! \f] +!! +!! The GM implementation of isopycnal height diffusion made the streamfunction proportional +!! to the potential density slope +!! \f[ +!! \vec{\psi} = - \kappa_h \frac{\nabla_z \rho}{\partial_z \rho} +!! = \frac{g\kappa_h}{\rho_o} \frac{\nabla \rho}{N^2} = \kappa_h \frac{M^2}{N^2} +!! \f] +!! but for robustness the scheme is implemented as +!! \f[ +!! \vec{\psi} = \kappa_h \frac{M^2}{\sqrt{N^4 + M^4}} +!! \f] +!! since the quantity \f$\frac{M^2}{\sqrt{N^2 + M^2}}\f$ is bounded between $-1$ and $1$ and does not change sign +!! if \f$N^2<0\f$. +!! +!! Optionally, the method of Ferrari et al, 2010, can be used to obtain the streamfunction which solves the +!! vertically elliptic equation: +!! \f[ +!! \gamma_F \partial_z c^2 \partial_z \psi - N_*^2 \psi = ( 1 + \gamma_F ) \kappa_h N_*^2 \frac{M^2}{\sqrt{N^4+M^4}} +!! \f] +!! which recovers the previous streamfunction relation in the limit that \f$ c \rightarrow 0 \f$. +!! Here, \f$c=\max(c_{min},c_g)\f$ is the maximum of either \f$c_{min}\f$ and either the first baroclinic mode +!! wave-speed or the equivalent barotropic mode wave-speed. +!! \f$N_*^2 = \max(N^2,0)\f$ is a non-negative form of the square of the buoyancy frequency. +!! The parameter \f$\gamma_F\f$ is used to reduce the vertical smoothing length scale. +!! \f[ +!! \kappa_h = \left( \kappa_o + \alpha_{s} L_{s}^2 < S N > + \alpha_{M} \kappa_{M} \right) r(\Delta x,L_d) +!! \f] +!! where \f$ S \f$ is the isoneutral slope magnitude, \f$ N \f$ is the buoyancy frequency, +!! \f$\kappa_{M}\f$ is the diffusivity calculated by the MEKE parameterization (mom_meke module) and +!! \f$ r(\Delta x,L_d) \f$ is a function of the local resolution (ratio of grid-spacing, \f$\Delta x\f$, +!! to deformation radius, \f$L_d\f$). The length \f$L_s\f$ is provided by the mom_lateral_mixing_coeffs module +!! (enabled with USE_VARIABLE_MIXING=True and the term \f$\f$ is the vertical average slope +!! times the buoyancy frequency prescribed by Visbeck et al., 1996. +!! +!! The result of the above expression is subsequently bounded by minimum and maximum values, including an upper +!! diffusivity consistent with numerical stability (\f$ \kappa_{cfl} \f$ is calculated internally). +!! \f[ +!! \kappa_h \leftarrow \min{\left( \kappa_{max}, \kappa_{cfl}, \max{\left( \kappa_{min}, \kappa_h \right)} \right)} +!! f(c_g,z) +!! \f] +!! +!! where \f$f(c_g,z)\f$ is a vertical structure function. +!! \f$f(c_g,z)\f$ is calculated in module mom_lateral_mixing_coeffs. +!! If KHTH_USE_EBT_STRUCT=True then \f$f(c_g,z)\f$ is set to look like the equivalent barotropic +!! modal velocity structure. Otherwise \f$f(c_g,z)=1\f$ and the diffusivity is independent of depth. +!! +!! In order to calculate meaningful slopes in vanished layers, temporary copies of the thermodynamic variables +!! are passed through a vertical smoother, function vert_fill_ts(): +!! \f{eqnarray*}{ +!! \left[ 1 + \Delta t \kappa_{smth} \frac{\partial^2}{\partial_z^2} \right] \theta & \leftarrow & \theta \\ +!! \left[ 1 + \Delta t \kappa_{smth} \frac{\partial^2}{\partial_z^2} \right] s & \leftarrow & s +!! \f} +!! +!! \subsection section_khth_module_parameters Module mom_thickness_diffuse parameters +!! +!! | Symbol | Module parameter | +!! | ------ | --------------- | +!! | - | THICKNESSDIFFUSE | +!! | \f$ \kappa_o \f$ | KHTH | +!! | \f$ \alpha_{s} \f$ | KHTH_SLOPE_CFF | +!! | \f$ \kappa_{min} \f$ | KHTH_MIN | +!! | \f$ \kappa_{max} \f$ | KHTH_MAX | +!! | - | KHTH_MAX_CFL | +!! | \f$ \kappa_{smth} \f$ | KD_SMOOTH | +!! | \f$ \alpha_{M} \f$ | MEKE_KHTH_FAC (from mom_meke module) | +!! | - | KHTH_USE_EBT_STRUCT (from mom_lateral_mixing_coeffs module) | +!! | - | KHTH_USE_FGNV_STREAMFUNCTION | +!! | \f$ \gamma_F \f$ | FGNV_FILTER_SCALE | +!! | \f$ c_{min} \f$ | FGNV_C_MIN | +!! +!! \subsection section_khth_module_reference References +!! +!! Ferrari, R., S.M. Griffies, A.J.G. Nurser and G.K. Vallis, 2010: +!! A boundary-value problem for the parameterized mesoscale eddy transport. +!! Ocean Modelling, 32, 143-156. http://doi.org/10.1016/j.ocemod.2010.01.004 +!! +!! Visbeck, M., J.C. Marshall, H. Jones, 1996: +!! Dynamics of isolated convective regions in the ocean. J. Phys. Oceangr., 26, 1721-1734. +!! http://dx.doi.org/10.1175/1520-0485(1996)026%3C1721:DOICRI%3E2.0.CO;2 + +end module MOM_thickness_diffuse diff --git a/parameterizations/lateral/MOM_tidal_forcing.F90 b/parameterizations/lateral/MOM_tidal_forcing.F90 new file mode 100644 index 0000000000..1cd8a45a78 --- /dev/null +++ b/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -0,0 +1,758 @@ +!> Tidal contributions to geopotential +module MOM_tidal_forcing + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, & + CLOCK_MODULE, CLOCK_ROUTINE +use MOM_domains, only : pass_var +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : field_exists, file_exists, MOM_read_data +use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +public calc_tidal_forcing, tidal_forcing_init, tidal_forcing_end +public calc_tidal_forcing_legacy +! MOM_open_boundary uses the following to set tides on the boundary. +public astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency + +#include + +integer, parameter :: MAX_CONSTITUENTS = 10 !< The maximum number of tidal + !! constituents that could be used. +!> Simple type to store astronomical longitudes used to calculate tidal phases. +type, public :: astro_longitudes + real :: s !< Mean longitude of moon [rad] + real :: h !< Mean longitude of sun [rad] + real :: p !< Mean longitude of lunar perigee [rad] + real :: N !< Longitude of ascending node [rad] +end type astro_longitudes + +!> The control structure for the MOM_tidal_forcing module +type, public :: tidal_forcing_CS ; private + logical :: use_tidal_sal_file !< If true, Read the tidal self-attraction + !! and loading from input files, specified + !! by TIDAL_INPUT_FILE. + logical :: use_tidal_sal_prev !< If true, use the SAL from the previous + !! iteration of the tides to facilitate convergence. + logical :: use_eq_phase !< If true, tidal forcing is phase-shifted to match + !! equilibrium tide. Set to false if providing tidal phases + !! that have already been shifted by the + !! astronomical/equilibrium argument. + real :: sal_scalar !< The constant of proportionality between sea surface + !! height (really it should be bottom pressure) anomalies + !! and bottom geopotential anomalies [nondim]. + integer :: nc !< The number of tidal constituents in use. + real, dimension(MAX_CONSTITUENTS) :: & + freq, & !< The frequency of a tidal constituent [T-1 ~> s-1]. + phase0, & !< The phase of a tidal constituent at time 0 [rad]. + amp, & !< The amplitude of a tidal constituent at time 0 [Z ~> m]. + love_no !< The Love number of a tidal constituent at time 0 [nondim]. + integer :: struct(MAX_CONSTITUENTS) !< An encoded spatial structure for each constituent + character (len=16) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent + + type(time_type) :: time_ref !< Reference time (t = 0) used to calculate tidal forcing. + type(astro_longitudes) :: tidal_longitudes !< Astronomical longitudes used to calculate + !! tidal phases at t = 0. + real, allocatable :: & + sin_struct(:,:,:), & !< The sine based structures that can be associated with + !! the astronomical forcing [nondim]. + cos_struct(:,:,:), & !< The cosine based structures that can be associated with + !! the astronomical forcing [nondim]. + cosphasesal(:,:,:), & !< The cosine of the phase of the self-attraction and loading amphidromes [nondim]. + sinphasesal(:,:,:), & !< The sine of the phase of the self-attraction and loading amphidromes [nondim]. + ampsal(:,:,:), & !< The amplitude of the SAL [Z ~> m]. + cosphase_prev(:,:,:), & !< The cosine of the phase of the amphidromes in the previous tidal solutions [nondim]. + sinphase_prev(:,:,:), & !< The sine of the phase of the amphidromes in the previous tidal solutions [nondim]. + amp_prev(:,:,:) !< The amplitude of the previous tidal solution [Z ~> m]. +end type tidal_forcing_CS + +integer :: id_clock_tides !< CPU clock for tides + +contains + +!> Finds astronomical longitudes s, h, p, and N, +!! the mean longitude of the moon, sun, lunar perigee, and ascending node, respectively, +!! at the specified reference time time_ref. +!! These formulas were obtained from +!! Kowalik and Luick, "Modern Theory and Practice of Tide Analysis and Tidal Power", 2019 +!! (their Equation I.71), which are based on Schureman, 1958. +!! For simplicity, the time associated with time_ref should +!! be at midnight. These formulas also only make sense if +!! the calendar is Gregorian. +subroutine astro_longitudes_init(time_ref, longitudes) + type(time_type), intent(in) :: time_ref !> Time to calculate longitudes for. + type(astro_longitudes), intent(out) :: longitudes !> Lunar and solar longitudes at time_ref. + + ! Local variables + real :: D !> Time since the reference date [days] + real :: T !> Time in Julian centuries [centuries] + real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... [nondim] + + ! Find date at time_ref in days since 1900-01-01 + D = time_type_to_real(time_ref - set_date(1900, 1, 1)) / (24.0 * 3600.0) + ! Time since 1900-01-01 in Julian centuries + ! Kowalik and Luick use 36526, but Schureman uses 36525 which I think is correct. + T = D / 36525.0 + ! Calculate longitudes, including converting to radians on [0, 2pi) + ! s: Mean longitude of moon + longitudes%s = mod((277.0248 + 481267.8906 * T) + 0.0011 * (T**2), 360.0) * PI / 180.0 + ! h: Mean longitude of sun + longitudes%h = mod((280.1895 + 36000.7689 * T) + 3.0310e-4 * (T**2), 360.0) * PI / 180.0 + ! p: Mean longitude of lunar perigee + longitudes%p = mod((334.3853 + 4069.0340 * T) - 0.0103 * (T**2), 360.0) * PI / 180.0 + ! n: Longitude of ascending node + longitudes%N = mod((259.1568 - 1934.142 * T) + 0.0021 * (T**2), 360.0) * PI / 180.0 +end subroutine astro_longitudes_init + +!> Calculates the equilibrium phase argument for the given tidal +!! constituent constit and the astronomical longitudes and the reference time. +!! These formulas follow Table I.4 of Kowalik and Luick, +!! "Modern Theory and Practice of Tide Analysis and Tidal Power", 2019. +function eq_phase(constit, longitudes) + character (len=2), intent(in) :: constit !> Name of constituent (e.g., M2). + type(astro_longitudes), intent(in) :: longitudes !> Mean longitudes calculated using astro_longitudes_init + real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... [nondim] + real :: eq_phase !> The equilibrium phase argument for the constituent [rad]. + + select case (constit) + case ("M2") + eq_phase = 2 * (longitudes%h - longitudes%s) + case ("S2") + eq_phase = 0.0 + case ("N2") + eq_phase = (- 3 * longitudes%s + 2 * longitudes%h) + longitudes%p + case ("K2") + eq_phase = 2 * longitudes%h + case ("K1") + eq_phase = longitudes%h + PI / 2.0 + case ("O1") + eq_phase = (- 2 * longitudes%s + longitudes%h) - PI / 2.0 + case ("P1") + eq_phase = - longitudes%h - PI / 2.0 + case ("Q1") + eq_phase = ((- 3 * longitudes%s + longitudes%h) + longitudes%p) - PI / 2.0 + case ("MF") + eq_phase = 2 * longitudes%s + case ("MM") + eq_phase = longitudes%s - longitudes%p + case default + call MOM_error(FATAL, "eq_phase: unrecognized constituent") + end select +end function eq_phase + +!> Looks up angular frequencies for the main tidal constituents. +!! Values used here are from previous versions of MOM. +function tidal_frequency(constit) + character (len=2), intent(in) :: constit !> Constituent to look up + real :: tidal_frequency !> Angular frequency [s-1] + + select case (constit) + case ("M2") + tidal_frequency = 1.4051890e-4 + case ("S2") + tidal_frequency = 1.4544410e-4 + case ("N2") + tidal_frequency = 1.3787970e-4 + case ("K2") + tidal_frequency = 1.4584234e-4 + case ("K1") + tidal_frequency = 0.7292117e-4 + case ("O1") + tidal_frequency = 0.6759774e-4 + case ("P1") + tidal_frequency = 0.7252295e-4 + case ("Q1") + tidal_frequency = 0.6495854e-4 + case ("MF") + tidal_frequency = 0.053234e-4 + case ("MM") + tidal_frequency = 0.026392e-4 + case default + call MOM_error(FATAL, "tidal_frequency: unrecognized constituent") + end select +end function tidal_frequency + +!> Find amplitude (f) and phase (u) modulation of tidal constituents by the 18.6 +!! year nodal cycle. Values here follow Table I.6 in Kowalik and Luick, +!! "Modern Theory and Practice of Tide Analysis and Tidal Power", 2019. +subroutine nodal_fu(constit, nodelon, fn, un) + character (len=2), intent(in) :: constit !> Tidal constituent to find modulation for. + real, intent(in) :: nodelon !> Longitude of ascending node [rad], which + !! can be calculated using astro_longitudes_init. + real, intent(out) :: fn !> Amplitude modulation [nondim] + real, intent(out) :: un !> Phase modulation [rad] + + real, parameter :: RADIANS = 4.0 * atan(1.0) / 180.0 !> Converts degrees to radians [nondim] + + select case (constit) + case ("M2") + fn = 1.0 - 0.037 * cos(nodelon) + un = -2.1 * RADIANS * sin(nodelon) + case ("S2") + fn = 1.0 ! Solar S2 has no amplitude modulation. + un = 0.0 ! S2 has no phase modulation. + case ("N2") + fn = 1.0 - 0.037 * cos(nodelon) + un = -2.1 * RADIANS * sin(nodelon) + case ("K2") + fn = 1.024 + 0.286 * cos(nodelon) + un = -17.7 * RADIANS * sin(nodelon) + case ("K1") + fn = 1.006 + 0.115 * cos(nodelon) + un = -8.9 * RADIANS * sin(nodelon) + case ("O1") + fn = 1.009 + 0.187 * cos(nodelon) + un = 10.8 * RADIANS * sin(nodelon) + case ("P1") + fn = 1.0 ! P1 has no amplitude modulation. + un = 0.0 ! P1 has no phase modulation. + case ("Q1") + fn = 1.009 + 0.187 * cos(nodelon) + un = 10.8 * RADIANS * sin(nodelon) + case ("MF") + fn = 1.043 + 0.414 * cos(nodelon) + un = -23.7 * RADIANS * sin(nodelon) + case ("MM") + fn = 1.0 - 0.130 * cos(nodelon) + un = 0.0 ! MM has no phase modulation. + case default + call MOM_error(FATAL, "nodal_fu: unrecognized constituent") + end select + +end subroutine nodal_fu + +!> This subroutine allocates space for the static variables used +!! by this module. The metrics may be effectively 0, 1, or 2-D arrays, +!! while fields like the background viscosities are 2-D arrays. +!! ALLOC is a macro defined in MOM_memory.h for allocate or nothing with +!! static memory. +subroutine tidal_forcing_init(Time, G, US, param_file, CS) + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. + type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control structure + + ! Local variables + real, dimension(SZI_(G), SZJ_(G)) :: & + phase, & ! The phase of some tidal constituent [radians]. + lat_rad, lon_rad ! Latitudes and longitudes of h-points [radians]. + real :: deg_to_rad ! A conversion factor from degrees to radians [radian degree-1] + real, dimension(MAX_CONSTITUENTS) :: freq_def ! Default frequency for each tidal constituent [s-1] + real, dimension(MAX_CONSTITUENTS) :: phase0_def ! Default reference phase for each tidal constituent [rad] + real, dimension(MAX_CONSTITUENTS) :: amp_def ! Default amplitude for each tidal constituent [m] + real, dimension(MAX_CONSTITUENTS) :: love_def ! Default love number for each constituent [nondim] + integer, dimension(3) :: tide_ref_date !< Reference date (t = 0) for tidal forcing. + logical :: use_M2, use_S2, use_N2, use_K2, use_K1, use_O1, use_P1, use_Q1 + logical :: use_MF, use_MM + logical :: tides ! True if a tidal forcing is to be used. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name. + character(len=128) :: mesg + character(len=200) :: tidal_input_files(4*MAX_CONSTITUENTS) + real :: tide_sal_scalar_value ! The constant of proportionality with the scalar approximation to SAL [nondim] + integer :: i, j, c, is, ie, js, je, isd, ied, jsd, jed, nc + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd; jed = G%jed + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "TIDES", tides, & + "If true, apply tidal momentum forcing.", default=.false.) + + if (.not.tides) return + + ! Set up the spatial structure functions for the diurnal, semidiurnal, and + ! low-frequency tidal components. + allocate(CS%sin_struct(isd:ied,jsd:jed,3), source=0.0) + allocate(CS%cos_struct(isd:ied,jsd:jed,3), source=0.0) + deg_to_rad = 4.0*ATAN(1.0)/180.0 + do j=js-1,je+1 ; do i=is-1,ie+1 + lat_rad(i,j) = G%geoLatT(i,j)*deg_to_rad + lon_rad(i,j) = G%geoLonT(i,j)*deg_to_rad + enddo ; enddo + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%sin_struct(i,j,1) = -sin(2.0*lat_rad(i,j)) * sin(lon_rad(i,j)) + CS%cos_struct(i,j,1) = sin(2.0*lat_rad(i,j)) * cos(lon_rad(i,j)) + CS%sin_struct(i,j,2) = -cos(lat_rad(i,j))**2 * sin(2.0*lon_rad(i,j)) + CS%cos_struct(i,j,2) = cos(lat_rad(i,j))**2 * cos(2.0*lon_rad(i,j)) + CS%sin_struct(i,j,3) = 0.0 + CS%cos_struct(i,j,3) = (0.5-1.5*sin(lat_rad(i,j))**2) + enddo ; enddo + + call get_param(param_file, mdl, "TIDE_M2", use_M2, & + "If true, apply tidal momentum forcing at the M2 "//& + "frequency. This is only used if TIDES is true.", & + default=.false.) + call get_param(param_file, mdl, "TIDE_S2", use_S2, & + "If true, apply tidal momentum forcing at the S2 "//& + "frequency. This is only used if TIDES is true.", & + default=.false.) + call get_param(param_file, mdl, "TIDE_N2", use_N2, & + "If true, apply tidal momentum forcing at the N2 "//& + "frequency. This is only used if TIDES is true.", & + default=.false.) + call get_param(param_file, mdl, "TIDE_K2", use_K2, & + "If true, apply tidal momentum forcing at the K2 "//& + "frequency. This is only used if TIDES is true.", & + default=.false.) + call get_param(param_file, mdl, "TIDE_K1", use_K1, & + "If true, apply tidal momentum forcing at the K1 "//& + "frequency. This is only used if TIDES is true.", & + default=.false.) + call get_param(param_file, mdl, "TIDE_O1", use_O1, & + "If true, apply tidal momentum forcing at the O1 "//& + "frequency. This is only used if TIDES is true.", & + default=.false.) + call get_param(param_file, mdl, "TIDE_P1", use_P1, & + "If true, apply tidal momentum forcing at the P1 "//& + "frequency. This is only used if TIDES is true.", & + default=.false.) + call get_param(param_file, mdl, "TIDE_Q1", use_Q1, & + "If true, apply tidal momentum forcing at the Q1 "//& + "frequency. This is only used if TIDES is true.", & + default=.false.) + call get_param(param_file, mdl, "TIDE_MF", use_MF, & + "If true, apply tidal momentum forcing at the MF "//& + "frequency. This is only used if TIDES is true.", & + default=.false.) + call get_param(param_file, mdl, "TIDE_MM", use_MM, & + "If true, apply tidal momentum forcing at the MM "//& + "frequency. This is only used if TIDES is true.", & + default=.false.) + + ! Determine how many tidal components are to be used. + nc = 0 + if (use_M2) nc=nc+1 ; if (use_S2) nc=nc+1 + if (use_N2) nc=nc+1 ; if (use_K2) nc=nc+1 + if (use_K1) nc=nc+1 ; if (use_O1) nc=nc+1 + if (use_P1) nc=nc+1 ; if (use_Q1) nc=nc+1 + if (use_MF) nc=nc+1 ; if (use_MM) nc=nc+1 + CS%nc = nc + + if (nc == 0) then + call MOM_error(FATAL, "tidal_forcing_init: "// & + "TIDES are defined, but no tidal constituents are used.") + return + endif + + call get_param(param_file, mdl, "TIDAL_SAL_FROM_FILE", CS%use_tidal_sal_file, & + "If true, read the tidal self-attraction and loading "//& + "from input files, specified by TIDAL_INPUT_FILE. "//& + "This is only used if TIDES is true.", default=.false.) + call get_param(param_file, mdl, "USE_PREVIOUS_TIDES", CS%use_tidal_sal_prev, & + "If true, use the SAL from the previous iteration of the "//& + "tides to facilitate convergent iteration. "//& + "This is only used if TIDES is true.", default=.false.) + call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", tide_sal_scalar_value, & + units="m m-1", default=0.0, do_not_log=.True.) + if (tide_sal_scalar_value/=0.0) & + call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& + "Use SAL_SCALAR_VALUE instead." ) + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar, & + "The constant of proportionality between sea surface "//& + "height (really it should be bottom pressure) anomalies "//& + "and bottom geopotential anomalies. This is only used if "//& + "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & + default=tide_sal_scalar_value, units="m m-1", & + do_not_log=(.not. CS%use_tidal_sal_prev)) + + if (nc > MAX_CONSTITUENTS) then + write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & + &"to accommodate all the registered tidal constituents.")') nc + call MOM_error(FATAL, "MOM_tidal_forcing"//mesg) + endif + + do c=1,4*MAX_CONSTITUENTS ; tidal_input_files(c) = "" ; enddo + + if (CS%use_tidal_sal_file .or. CS%use_tidal_sal_prev) then + call get_param(param_file, mdl, "TIDAL_INPUT_FILE", tidal_input_files, & + "A list of input files for tidal information.", & + default="", fail_if_missing=.true.) + endif + + call get_param(param_file, mdl, "TIDE_REF_DATE", tide_ref_date, & + "Year,month,day to use as reference date for tidal forcing. "//& + "If not specified, defaults to 0.", & + default=0) + + call get_param(param_file, mdl, "TIDE_USE_EQ_PHASE", CS%use_eq_phase, & + "Correct phases by calculating equilibrium phase arguments for TIDE_REF_DATE. ", & + default=.false., fail_if_missing=.false.) + + if (sum(tide_ref_date) == 0) then ! tide_ref_date defaults to 0. + CS%time_ref = set_date(1, 1, 1) + else + if (.not. CS%use_eq_phase) then + ! Using a reference date but not using phase relative to equilibrium. + ! This makes sense as long as either phases are overridden, or + ! correctly simulating tidal phases is not desired. + call MOM_mesg('Tidal phases will *not* be corrected with equilibrium arguments.') + endif + CS%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3)) + endif + + ! Initialize reference time for tides and find relevant lunar and solar + ! longitudes at the reference time. + if (CS%use_eq_phase) call astro_longitudes_init(CS%time_ref, CS%tidal_longitudes) + + ! Set the parameters for all components that are in use. + c=0 + if (use_M2) then + c=c+1 ; CS%const_name(c) = "M2" ; CS%struct(c) = 2 + CS%love_no(c) = 0.693 ; amp_def(c) = 0.242334 ! Default amplitude in m. + endif + + if (use_S2) then + c=c+1 ; CS%const_name(c) = "S2" ; CS%struct(c) = 2 + CS%love_no(c) = 0.693 ; amp_def(c) = 0.112743 ! Default amplitude in m. + endif + + if (use_N2) then + c=c+1 ; CS%const_name(c) = "N2" ; CS%struct(c) = 2 + CS%love_no(c) = 0.693 ; amp_def(c) = 0.046397 ! Default amplitude in m. + endif + + if (use_K2) then + c=c+1 ; CS%const_name(c) = "K2" ; CS%struct(c) = 2 + CS%love_no(c) = 0.693 ; amp_def(c) = 0.030684 ! Default amplitude in m. + endif + + if (use_K1) then + c=c+1 ; CS%const_name(c) = "K1" ; CS%struct(c) = 1 + CS%love_no(c) = 0.736 ; amp_def(c) = 0.141565 ! Default amplitude in m. + endif + + if (use_O1) then + c=c+1 ; CS%const_name(c) = "O1" ; CS%struct(c) = 1 + CS%love_no(c) = 0.695 ; amp_def(c) = 0.100661 ! Default amplitude in m. + endif + + if (use_P1) then + c=c+1 ; CS%const_name(c) = "P1" ; CS%struct(c) = 1 + CS%love_no(c) = 0.706 ; amp_def(c) = 0.046848 ! Default amplitude in m. + endif + + if (use_Q1) then + c=c+1 ; CS%const_name(c) = "Q1" ; CS%struct(c) = 1 + CS%love_no(c) = 0.695 ; amp_def(c) = 0.019273 ! Default amplitude in m. + endif + + if (use_MF) then + c=c+1 ; CS%const_name(c) = "MF" ; CS%struct(c) = 3 + CS%love_no(c) = 0.693 ; amp_def(c) = 0.042041 ! Default amplitude in m. + endif + + if (use_MM) then + c=c+1 ; CS%const_name(c) = "MM" ; CS%struct(c) = 3 + CS%love_no(c) = 0.693 ; amp_def(c) = 0.022191 ! Default amplitude in m. + endif + + ! Set defaults for all included constituents + ! and things that can be set by functions + do c=1,nc + freq_def(c) = tidal_frequency(CS%const_name(c)) + love_def(c) = CS%love_no(c) + CS%phase0(c) = 0.0 + if (CS%use_eq_phase) then + phase0_def(c) = eq_phase(CS%const_name(c), CS%tidal_longitudes) + else + phase0_def(c) = 0.0 + endif + enddo + + ! Parse the input file to potentially override the default values for the + ! frequency, amplitude and initial phase of each constituent, and log the + ! values that are actually used. + do c=1,nc + call get_param(param_file, mdl, "TIDE_"//trim(CS%const_name(c))//"_FREQ", CS%freq(c), & + "Frequency of the "//trim(CS%const_name(c))//" tidal constituent. "//& + "This is only used if TIDES and TIDE_"//trim(CS%const_name(c))// & + " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and "//trim(CS%const_name(c))// & + " is in OBC_TIDE_CONSTITUENTS.", units="s-1", default=freq_def(c), scale=US%T_to_s) + call get_param(param_file, mdl, "TIDE_"//trim(CS%const_name(c))//"_AMP", CS%amp(c), & + "Amplitude of the "//trim(CS%const_name(c))//" tidal constituent. "//& + "This is only used if TIDES and TIDE_"//trim(CS%const_name(c))// & + " are true.", units="m", default=amp_def(c), scale=US%m_to_Z) + call get_param(param_file, mdl, "TIDE_"//trim(CS%const_name(c))//"_PHASE_T0", CS%phase0(c), & + "Phase of the "//trim(CS%const_name(c))//" tidal constituent at time 0. "//& + "This is only used if TIDES and TIDE_"//trim(CS%const_name(c))// & + " are true.", units="radians", default=phase0_def(c)) + enddo + + if (CS%use_tidal_sal_file) then + allocate(CS%cosphasesal(isd:ied,jsd:jed,nc)) + allocate(CS%sinphasesal(isd:ied,jsd:jed,nc)) + allocate(CS%ampsal(isd:ied,jsd:jed,nc)) + do c=1,nc + ! Read variables with names like PHASE_SAL_M2 and AMP_SAL_M2. + call find_in_files(tidal_input_files, "PHASE_SAL_"//trim(CS%const_name(c)), phase, G) + call find_in_files(tidal_input_files, "AMP_SAL_"//trim(CS%const_name(c)), CS%ampsal(:,:,c), & + G, scale=US%m_to_Z) + call pass_var(phase, G%domain,complete=.false.) + call pass_var(CS%ampsal(:,:,c),G%domain,complete=.true.) + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%cosphasesal(i,j,c) = cos(phase(i,j)*deg_to_rad) + CS%sinphasesal(i,j,c) = sin(phase(i,j)*deg_to_rad) + enddo ; enddo + enddo + endif + + if (CS%use_tidal_sal_prev) then + allocate(CS%cosphase_prev(isd:ied,jsd:jed,nc)) + allocate(CS%sinphase_prev(isd:ied,jsd:jed,nc)) + allocate(CS%amp_prev(isd:ied,jsd:jed,nc)) + do c=1,nc + ! Read variables with names like PHASE_PREV_M2 and AMP_PREV_M2. + call find_in_files(tidal_input_files, "PHASE_PREV_"//trim(CS%const_name(c)), phase, G) + call find_in_files(tidal_input_files, "AMP_PREV_"//trim(CS%const_name(c)), CS%amp_prev(:,:,c), & + G, scale=US%m_to_Z) + call pass_var(phase, G%domain,complete=.false.) + call pass_var(CS%amp_prev(:,:,c),G%domain,complete=.true.) + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%cosphase_prev(i,j,c) = cos(phase(i,j)*deg_to_rad) + CS%sinphase_prev(i,j,c) = sin(phase(i,j)*deg_to_rad) + enddo ; enddo + enddo + endif + + id_clock_tides = cpu_clock_id('(Ocean tides)', grain=CLOCK_MODULE) + +end subroutine tidal_forcing_init + +!> This subroutine finds a named variable in a list of files and reads its +!! values into a domain-decomposed 2-d array +subroutine find_in_files(filenames, varname, array, G, scale) + character(len=*), dimension(:), intent(in) :: filenames !< The names of the files to search for the named variable + character(len=*), intent(in) :: varname !< The name of the variable to read + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: array !< The array to fill with the data [arbitrary] + real, optional, intent(in) :: scale !< A factor by which to rescale the array to translate it + !! into its desired units [arbitrary] + ! Local variables + integer :: nf + + do nf=1,size(filenames) + if (LEN_TRIM(filenames(nf)) == 0) cycle + if (field_exists(filenames(nf), varname, MOM_domain=G%Domain)) then + call MOM_read_data(filenames(nf), varname, array, G%Domain, scale=scale) + return + endif + enddo + + do nf=size(filenames),1,-1 + if (file_exists(filenames(nf), G%Domain)) then + call MOM_error(FATAL, "MOM_tidal_forcing.F90: Unable to find "// & + trim(varname)//" in any of the tidal input files, last tried "// & + trim(filenames(nf))) + endif + enddo + + call MOM_error(FATAL, "MOM_tidal_forcing.F90: Unable to find any of the "// & + "tidal input files, including "//trim(filenames(1))) + +end subroutine find_in_files + +!> This subroutine calculates the geopotential anomalies that drive the tides, +!! including tidal self-attraction and loading from previous solutions. +subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< The time for the caluculation. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_eq !< The geopotential height anomalies + !! due to the equilibrium tides [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_sal !< The geopotential height anomalies + !! due to the tidal SAL [Z ~> m]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a + !! previous call to tidal_forcing_init. + + ! Local variables + real :: now ! The relative time compared with the tidal reference [T ~> s] + real :: amp_cosomegat, amp_sinomegat ! The tidal amplitudes times the components of phase [Z ~> m] + real :: cosomegat, sinomegat ! The components of the phase [nondim] + integer :: i, j, c, m, is, ie, js, je, Isq, Ieq, Jsq, Jeq + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + call cpu_clock_begin(id_clock_tides) + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_tide_eq(i,j) = 0.0 + e_tide_sal(i,j) = 0.0 + enddo ; enddo + + if (CS%nc == 0) then + return + endif + + now = US%s_to_T * time_type_to_real(Time - cs%time_ref) + + do c=1,CS%nc + m = CS%struct(c) + amp_cosomegat = CS%amp(c)*CS%love_no(c) * cos(CS%freq(c)*now + CS%phase0(c)) + amp_sinomegat = CS%amp(c)*CS%love_no(c) * sin(CS%freq(c)*now + CS%phase0(c)) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_tide_eq(i,j) = e_tide_eq(i,j) + (amp_cosomegat*CS%cos_struct(i,j,m) + & + amp_sinomegat*CS%sin_struct(i,j,m)) + enddo ; enddo + enddo + + if (CS%use_tidal_sal_file) then ; do c=1,CS%nc + cosomegat = cos(CS%freq(c)*now) + sinomegat = sin(CS%freq(c)*now) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_tide_sal(i,j) = e_tide_sal(i,j) + CS%ampsal(i,j,c) * & + (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) + enddo ; enddo + enddo ; endif + + if (CS%use_tidal_sal_prev) then ; do c=1,CS%nc + cosomegat = cos(CS%freq(c)*now) + sinomegat = sin(CS%freq(c)*now) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_tide_sal(i,j) = e_tide_sal(i,j) - CS%sal_scalar * CS%amp_prev(i,j,c) * & + (cosomegat*CS%cosphase_prev(i,j,c) + sinomegat*CS%sinphase_prev(i,j,c)) + enddo ; enddo + enddo ; endif + + call cpu_clock_end(id_clock_tides) + +end subroutine calc_tidal_forcing + +!> This subroutine functions the same as calc_tidal_forcing but outputs a field that combines +!! previously calculated self-attraction and loading (SAL) and tidal forcings, so that old answers +!! can be preserved bitwise before SAL is separated out as an individual module. +subroutine calc_tidal_forcing_legacy(Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, G, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< The time for the caluculation. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: e_sal !< The self-attraction and loading fields + !! calculated previously used to + !! initialized e_sal_tide [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_sal_tide !< The total geopotential height anomalies + !! due to both SAL and tidal forcings [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_eq !< The geopotential height anomalies + !! due to the equilibrium tides [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_sal !< The geopotential height anomalies + !! due to the tidal SAL [Z ~> m]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a + !! previous call to tidal_forcing_init. + + ! Local variables + real :: now ! The relative time compared with the tidal reference [T ~> s] + real :: amp_cosomegat, amp_sinomegat ! The tidal amplitudes times the components of phase [Z ~> m] + real :: cosomegat, sinomegat ! The components of the phase [nondim] + real :: amp_cossin ! A temporary field that adds cosines and sines [nondim] + integer :: i, j, c, m, is, ie, js, je, Isq, Ieq, Jsq, Jeq + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + call cpu_clock_begin(id_clock_tides) + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal_tide(i,j) = 0.0 + e_tide_eq(i,j) = 0.0 + e_tide_sal(i,j) = 0.0 + enddo ; enddo + + if (CS%nc == 0) then + return + endif + + now = US%s_to_T * time_type_to_real(Time - cs%time_ref) + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal_tide(i,j) = e_sal(i,j) + enddo ; enddo + + do c=1,CS%nc + m = CS%struct(c) + amp_cosomegat = CS%amp(c)*CS%love_no(c) * cos(CS%freq(c)*now + CS%phase0(c)) + amp_sinomegat = CS%amp(c)*CS%love_no(c) * sin(CS%freq(c)*now + CS%phase0(c)) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + amp_cossin = (amp_cosomegat*CS%cos_struct(i,j,m) + amp_sinomegat*CS%sin_struct(i,j,m)) + e_sal_tide(i,j) = e_sal_tide(i,j) + amp_cossin + e_tide_eq(i,j) = e_tide_eq(i,j) + amp_cossin + enddo ; enddo + enddo + + if (CS%use_tidal_sal_file) then ; do c=1,CS%nc + cosomegat = cos(CS%freq(c)*now) + sinomegat = sin(CS%freq(c)*now) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + amp_cossin = CS%ampsal(i,j,c) & + * (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) + e_sal_tide(i,j) = e_sal_tide(i,j) + amp_cossin + e_tide_sal(i,j) = e_tide_sal(i,j) + amp_cossin + enddo ; enddo + enddo ; endif + + if (CS%use_tidal_sal_prev) then ; do c=1,CS%nc + cosomegat = cos(CS%freq(c)*now) + sinomegat = sin(CS%freq(c)*now) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + amp_cossin = -CS%sal_scalar * CS%amp_prev(i,j,c) & + * (cosomegat*CS%cosphase_prev(i,j,c) + sinomegat*CS%sinphase_prev(i,j,c)) + e_sal_tide(i,j) = e_sal_tide(i,j) + amp_cossin + e_tide_sal(i,j) = e_tide_sal(i,j) + amp_cossin + enddo ; enddo + enddo ; endif + call cpu_clock_end(id_clock_tides) + +end subroutine calc_tidal_forcing_legacy + +!> This subroutine deallocates memory associated with the tidal forcing module. +subroutine tidal_forcing_end(CS) + type(tidal_forcing_CS), intent(inout) :: CS !< The control structure returned by a previous call + !! to tidal_forcing_init; it is deallocated here. + + if (allocated(CS%sin_struct)) deallocate(CS%sin_struct) + if (allocated(CS%cos_struct)) deallocate(CS%cos_struct) + + if (allocated(CS%cosphasesal)) deallocate(CS%cosphasesal) + if (allocated(CS%sinphasesal)) deallocate(CS%sinphasesal) + if (allocated(CS%ampsal)) deallocate(CS%ampsal) + + if (allocated(CS%cosphase_prev)) deallocate(CS%cosphase_prev) + if (allocated(CS%sinphase_prev)) deallocate(CS%sinphase_prev) + if (allocated(CS%amp_prev)) deallocate(CS%amp_prev) +end subroutine tidal_forcing_end + +!> \namespace tidal_forcing +!! +!! Code by Robert Hallberg, August 2005, based on C-code by Harper +!! Simmons, February, 2003, in turn based on code by Brian Arbic. +!! +!! The main subroutine in this file calculates the total tidal +!! contribution to the geopotential, including self-attraction and +!! loading terms and the astronomical contributions. All options +!! are selected with entries in a file that is parsed at run-time. +!! Overall tides are enabled with the run-time parameter 'TIDES=True'. +!! Tidal constituents must be individually enabled with lines like +!! 'TIDE_M2=True'. This file has default values of amplitude, +!! frequency, Love number, and phase at time 0 for the Earth's M2, +!! S2, N2, K2, K1, O1, P1, Q1, MF, and MM tidal constituents, but +!! the frequency, amplitude and phase ant time 0 for each constituent +!! can be changed at run time by setting variables like TIDE_M2_FREQ, +!! TIDE_M2_AMP and TIDE_M2_PHASE_T0 (for M2). +!! +!! In addition, approaches to calculate self-attraction and loading +!! due to tides (harmonics of astronomical forcing frequencies) +!! are provided. TIDAL_SAL_FROM_FILE can be set to read the phase and +!! amplitude of the tidal SAL. USE_PREVIOUS_TIDES may be useful in +!! combination with the scalar approximation to iterate the SAL to +!! convergence (for details, see Arbic et al., 2004, DSR II). With +!! TIDAL_SAL_FROM_FILE or USE_PREVIOUS_TIDES, a list of input files +!! must be provided to describe each constituent's properties from +!! a previous solution. The online SAL calculations that are functions +!! of SSH (rather should be bottom pressure anmoaly), either a scalar +!! approximation or with spherical harmonic transforms, are located in +!! MOM_self_attr_load. +end module MOM_tidal_forcing From c25d6503a6b5c51366dadfeb86a852e9cc878337 Mon Sep 17 00:00:00 2001 From: Sina Khani Date: Mon, 22 Jul 2024 14:08:02 -0500 Subject: [PATCH 2/7] MOM6 is updated with adding the Gradient model --- ALE/MOM_ALE.F90 | 1646 +++++ ALE/MOM_hybgen_regrid.F90 | 1013 +++ ALE/MOM_hybgen_remap.F90 | 390 ++ ALE/MOM_hybgen_unmix.F90 | 527 ++ ALE/MOM_regridding.F90 | 2569 +++++++ ALE/MOM_remapping.F90 | 1801 +++++ ALE/P1M_functions.F90 | 163 + ALE/P3M_functions.F90 | 588 ++ ALE/PCM_functions.F90 | 48 + ALE/PLM_functions.F90 | 317 + ALE/PPM_functions.F90 | 318 + ALE/PQM_functions.F90 | 842 +++ ALE/_ALE.dox | 184 + ALE/_ALE_timestep.dox | 62 + ALE/coord_adapt.F90 | 304 + ALE/coord_hycom.F90 | 266 + ALE/coord_rho.F90 | 422 ++ ALE/coord_sigma.F90 | 83 + ALE/coord_zlike.F90 | 146 + ALE/polynomial_functions.F90 | 117 + ALE/regrid_consts.F90 | 125 + ALE/regrid_edge_values.F90 | 1486 ++++ ALE/regrid_interp.F90 | 557 ++ ALE/regrid_solvers.F90 | 291 + ALE/remapping_attic.F90 | 661 ++ core/MOM.F90 | 4650 +++++++++++++ core/MOM_CoriolisAdv.F90 | 1355 ++++ core/MOM_PressureForce.F90 | 122 + core/MOM_PressureForce_FV.F90 | 1053 +++ core/MOM_PressureForce_Montgomery.F90 | 945 +++ core/MOM_barotropic.F90 | 5277 ++++++++++++++ core/MOM_boundary_update.F90 | 191 + core/MOM_check_scaling.F90 | 235 + core/MOM_checksum_packages.F90 | 393 ++ core/MOM_continuity.F90 | 30 + core/MOM_continuity_PPM.F90 | 2810 ++++++++ core/MOM_density_integrals.F90 | 1697 +++++ core/MOM_dynamics_split_RK2.F90 | 1864 +++++ core/MOM_dynamics_split_RK2b.F90 | 1698 +++++ core/MOM_dynamics_unsplit.F90 | 771 +++ core/MOM_dynamics_unsplit_RK2.F90 | 734 ++ core/MOM_forcing_type.F90 | 4168 +++++++++++ core/MOM_grid.F90 | 671 ++ core/MOM_interface_heights.F90 | 827 +++ core/MOM_isopycnal_slopes.F90 | 631 ++ core/MOM_open_boundary.F90 | 6113 +++++++++++++++++ core/MOM_porous_barriers.F90 | 487 ++ core/MOM_stoch_eos.F90 | 261 + core/MOM_transcribe_grid.F90 | 338 + core/MOM_unit_tests.F90 | 56 + core/MOM_variables.F90 | 590 ++ core/MOM_verticalGrid.F90 | 366 + core/_Baroclinic_Momentum.dox | 37 + core/_Barotropic_Baroclinic_Coupling.dox | 305 + core/_Barotropic_Momentum.dox | 50 + core/_Discrete_Coriolis.dox | 121 + core/_Discrete_OBC.dox | 7 + core/_Discrete_PG.dox | 147 + core/_Discrete_grids.dox | 65 + core/_Energetic_consistancy.dox | 5 + core/_General_coordinate.dox | 158 + core/_Governing.dox | 176 + core/_Notation.dox | 63 + core/_PPM.dox | 65 + core/_Sea_ice.dox | 11 + core/_Solar_radiation.dox | 7 + core/_Specifics.dox | 87 + core/_Timestep_Overview.dox | 10 + diagnostics/MOM_PointAccel.F90 | 805 +++ diagnostics/MOM_debugging.F90 | 983 +++ diagnostics/MOM_diagnostics.F90 | 2307 +++++++ diagnostics/MOM_obsolete_diagnostics.F90 | 82 + diagnostics/MOM_obsolete_params.F90 | 292 + diagnostics/MOM_spatial_means.F90 | 639 ++ diagnostics/MOM_sum_output.F90 | 1406 ++++ diagnostics/MOM_wave_speed.F90 | 1757 +++++ equation_of_state/MOM_EOS.F90 | 2529 +++++++ equation_of_state/MOM_EOS_Jackett06.F90 | 508 ++ equation_of_state/MOM_EOS_Roquet_SpV.F90 | 774 +++ equation_of_state/MOM_EOS_Roquet_rho.F90 | 689 ++ equation_of_state/MOM_EOS_TEOS10.F90 | 278 + equation_of_state/MOM_EOS_UNESCO.F90 | 584 ++ equation_of_state/MOM_EOS_Wright.F90 | 948 +++ equation_of_state/MOM_EOS_Wright_full.F90 | 965 +++ equation_of_state/MOM_EOS_Wright_red.F90 | 967 +++ equation_of_state/MOM_EOS_base_type.F90 | 464 ++ equation_of_state/MOM_EOS_linear.F90 | 661 ++ equation_of_state/MOM_TFreeze.F90 | 253 + equation_of_state/MOM_temperature_convert.F90 | 166 + .../gsw_chem_potential_water_t_exact.f90 | 82 + .../TEOS10/gsw_ct_freezing_exact.f90 | 43 + .../TEOS10/gsw_ct_freezing_poly.f90 | 53 + equation_of_state/TEOS10/gsw_ct_from_pt.f90 | 52 + equation_of_state/TEOS10/gsw_ct_from_t.f90 | 32 + equation_of_state/TEOS10/gsw_entropy_part.f90 | 62 + .../TEOS10/gsw_entropy_part_zerop.f90 | 44 + equation_of_state/TEOS10/gsw_gibbs.f90 | 317 + equation_of_state/TEOS10/gsw_gibbs_ice.f90 | 130 + .../TEOS10/gsw_gibbs_pt0_pt0.f90 | 47 + .../TEOS10/gsw_mod_error_functions.f90 | 160 + .../gsw_mod_freezing_poly_coefficients.f90 | 63 + .../TEOS10/gsw_mod_gibbs_ice_coefficients.f90 | 30 + equation_of_state/TEOS10/gsw_mod_kinds.f90 | 16 + .../TEOS10/gsw_mod_specvol_coefficients.f90 | 313 + .../TEOS10/gsw_mod_teos10_constants.f90 | 71 + equation_of_state/TEOS10/gsw_mod_toolbox.f90 | 1493 ++++ equation_of_state/TEOS10/gsw_pt0_from_t.f90 | 59 + equation_of_state/TEOS10/gsw_pt_from_ct.f90 | 72 + equation_of_state/TEOS10/gsw_pt_from_t.f90 | 61 + equation_of_state/TEOS10/gsw_rho.f90 | 36 + .../TEOS10/gsw_rho_first_derivatives.f90 | 110 + .../TEOS10/gsw_rho_second_derivatives.f90 | 78 + equation_of_state/TEOS10/gsw_sp_from_sr.f90 | 30 + equation_of_state/TEOS10/gsw_specvol.f90 | 52 + .../TEOS10/gsw_specvol_first_derivatives.f90 | 104 + .../TEOS10/gsw_specvol_second_derivatives.f90 | 131 + equation_of_state/TEOS10/gsw_sr_from_sp.f90 | 30 + ...w_t_deriv_chem_potential_water_t_exact.f90 | 88 + .../TEOS10/gsw_t_freezing_exact.f90 | 71 + .../TEOS10/gsw_t_freezing_poly.f90 | 78 + equation_of_state/TEOS10/gsw_t_from_ct.f90 | 33 + equation_of_state/_Equation_of_State.dox | 108 + framework/MOM_array_transform.F90 | 357 + framework/MOM_checksums.F90 | 2416 +++++++ framework/MOM_coms.F90 | 884 +++ framework/MOM_coupler_types.F90 | 493 ++ framework/MOM_cpu_clock.F90 | 36 + framework/MOM_data_override.F90 | 24 + framework/MOM_diag_mediator.F90 | 4616 +++++++++++++ framework/MOM_diag_remap.F90 | 954 +++ framework/MOM_document.F90 | 1091 +++ framework/MOM_domains.F90 | 390 ++ framework/MOM_dyn_horgrid.F90 | 548 ++ framework/MOM_ensemble_manager.F90 | 36 + framework/MOM_error_handler.F90 | 307 + framework/MOM_file_parser.F90 | 2191 ++++++ framework/MOM_get_input.F90 | 132 + framework/MOM_hor_index.F90 | 185 + framework/MOM_horizontal_regridding.F90 | 1033 +++ framework/MOM_interpolate.F90 | 213 + framework/MOM_intrinsic_functions.F90 | 238 + framework/MOM_io.F90 | 3072 +++++++++ framework/MOM_io_file.F90 | 1823 +++++ framework/MOM_memory_macros.h | 191 + framework/MOM_netcdf.F90 | 796 +++ framework/MOM_random.F90 | 600 ++ framework/MOM_restart.F90 | 2214 ++++++ framework/MOM_safe_alloc.F90 | 149 + framework/MOM_string_functions.F90 | 427 ++ framework/MOM_unique_scales.F90 | 356 + framework/MOM_unit_scaling.F90 | 262 + framework/MOM_unit_testing.F90 | 306 + framework/MOM_write_cputime.F90 | 227 + framework/_Diagnostics.dox | 234 + framework/_Dimensional_consistency.dox | 85 + framework/_Domain_decomposition.dox | 29 + framework/_Global_grids.dox | 9 + framework/_Horizontal_indexing.dox | 103 + framework/_Parallel_IO.dox | 10 + framework/_Regional_grids.dox | 9 + framework/_Runtime_parameter_system.dox | 82 + framework/_Testing.dox | 145 + framework/_Vertical_grids.dox | 13 + framework/posix.F90 | 484 ++ framework/posix.h | 44 + framework/testing/MOM_file_parser_tests.F90 | 1924 ++++++ framework/version_variable.h | 5 + ice_shelf/MOM_ice_shelf.F90 | 2361 +++++++ ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 761 ++ ice_shelf/MOM_ice_shelf_dynamics.F90 | 4099 +++++++++++ ice_shelf/MOM_ice_shelf_initialize.F90 | 704 ++ ice_shelf/MOM_ice_shelf_state.F90 | 102 + ice_shelf/MOM_marine_ice.F90 | 206 + ice_shelf/user_shelf_init.F90 | 208 + initialization/MOM_coord_initialization.F90 | 610 ++ initialization/MOM_fixed_initialization.F90 | 261 + initialization/MOM_grid_initialize.F90 | 1287 ++++ initialization/MOM_shared_initialization.F90 | 1460 ++++ initialization/MOM_state_initialization.F90 | 3118 +++++++++ .../MOM_tracer_initialization_from_Z.F90 | 237 + ocean_data_assim/MOM_oda_driver.F90 | 802 +++ ocean_data_assim/MOM_oda_incupd.F90 | 840 +++ parameterizations/CVmix/INSTALL | 54 + parameterizations/CVmix/Makefile | 89 + parameterizations/CVmix/cvmix_background.F90 | 1162 ++++ parameterizations/CVmix/cvmix_convection.F90 | 560 ++ parameterizations/CVmix/cvmix_ddiff.F90 | 668 ++ .../CVmix/cvmix_kinds_and_types.F90 | 217 + parameterizations/CVmix/cvmix_kpp.F90 | 2787 ++++++++ parameterizations/CVmix/cvmix_math.F90 | 252 + parameterizations/CVmix/cvmix_put_get.F90 | 595 ++ parameterizations/CVmix/cvmix_shear.F90 | 692 ++ parameterizations/CVmix/cvmix_tidal.F90 | 1362 ++++ parameterizations/CVmix/cvmix_utils.F90 | 242 + parameterizations/CVmix/makedep.py | 74 + .../stochastic/MOM_stochastics.F90 | 147 + parameterizations/vertical/MOM_ALE_sponge.F90 | 1422 ++++ parameterizations/vertical/MOM_CVMix_KPP.F90 | 1556 +++++ parameterizations/vertical/MOM_CVMix_conv.F90 | 310 + .../vertical/MOM_CVMix_ddiff.F90 | 290 + .../vertical/MOM_CVMix_shear.F90 | 366 + .../vertical/MOM_bkgnd_mixing.F90 | 550 ++ .../vertical/MOM_bulk_mixed_layer.F90 | 4265 ++++++++++++ .../vertical/MOM_diabatic_aux.F90 | 1979 ++++++ .../vertical/MOM_diabatic_driver.F90 | 3674 ++++++++++ .../vertical/MOM_diapyc_energy_req.F90 | 1110 +++ .../vertical/MOM_energetic_PBL.F90 | 2573 +++++++ .../vertical/MOM_entrain_diffusive.F90 | 2193 ++++++ .../vertical/MOM_full_convection.F90 | 419 ++ parameterizations/vertical/MOM_geothermal.F90 | 609 ++ .../vertical/MOM_internal_tide_input.F90 | 573 ++ .../vertical/MOM_kappa_shear.F90 | 2063 ++++++ parameterizations/vertical/MOM_opacity.F90 | 1182 ++++ .../vertical/MOM_regularize_layers.F90 | 794 +++ .../vertical/MOM_set_diffusivity.F90 | 2437 +++++++ .../vertical/MOM_set_viscosity.F90 | 3169 +++++++++ parameterizations/vertical/MOM_sponge.F90 | 672 ++ .../vertical/MOM_tidal_mixing.F90 | 1725 +++++ .../vertical/MOM_vert_friction.F90 | 3200 +++++++++ parameterizations/vertical/_BML.dox | 49 + parameterizations/vertical/_CVMix_KPP.dox | 57 + parameterizations/vertical/_EPBL.dox | 254 + parameterizations/vertical/_Frazil.dox | 33 + parameterizations/vertical/_V_diffusivity.dox | 590 ++ parameterizations/vertical/_V_viscosity.dox | 122 + tracer/DOME_tracer.F90 | 408 ++ tracer/ISOMIP_tracer.F90 | 351 + tracer/MOM_CFC_cap.F90 | 746 ++ tracer/MOM_OCMIP2_CFC.F90 | 624 ++ tracer/MOM_generic_tracer.F90 | 1046 +++ tracer/MOM_hor_bnd_diffusion.F90 | 1230 ++++ tracer/MOM_neutral_diffusion.F90 | 3345 +++++++++ tracer/MOM_offline_aux.F90 | 842 +++ tracer/MOM_offline_main.F90 | 1649 +++++ tracer/MOM_tracer_Z_init.F90 | 743 ++ tracer/MOM_tracer_advect.F90 | 1173 ++++ tracer/MOM_tracer_diabatic.F90 | 643 ++ tracer/MOM_tracer_flow_control.F90 | 893 +++ tracer/MOM_tracer_hor_diff.F90 | 1681 +++++ tracer/MOM_tracer_registry.F90 | 890 +++ tracer/MOM_tracer_types.F90 | 130 + tracer/RGC_tracer.F90 | 324 + tracer/_Advection.dox | 62 + tracer/_Discrete_tracer.dox | 5 + tracer/_Horizontal_diffusion.dox | 173 + tracer/_Passive_tracer.dox | 9 + tracer/_Tracer_Transport.dox | 124 + tracer/_Tracer_fluxes.dox | 9 + tracer/_Tracer_timestep.dox | 31 + tracer/_Vertical_diffusion.dox | 9 + tracer/advection_test_tracer.F90 | 386 ++ tracer/boundary_impulse_tracer.F90 | 395 ++ tracer/dye_example.F90 | 424 ++ tracer/dyed_obc_tracer.F90 | 268 + tracer/ideal_age_example.F90 | 626 ++ tracer/nw2_tracers.F90 | 319 + tracer/oil_tracer.F90 | 500 ++ tracer/pseudo_salt_tracer.F90 | 349 + tracer/tracer_example.F90 | 460 ++ user/BFB_initialization.F90 | 181 + user/BFB_surface_forcing.F90 | 255 + user/DOME2d_initialization.F90 | 552 ++ user/DOME_initialization.F90 | 489 ++ user/ISOMIP_initialization.F90 | 709 ++ user/Idealized_Hurricane.F90 | 676 ++ user/Kelvin_initialization.F90 | 375 + user/MOM_controlled_forcing.F90 | 649 ++ user/MOM_wave_interface.F90 | 2121 ++++++ user/Neverworld_initialization.F90 | 313 + user/Phillips_initialization.F90 | 409 ++ user/RGC_initialization.F90 | 203 + user/Rossby_front_2d_initialization.F90 | 376 + user/SCM_CVMix_tests.F90 | 283 + user/adjustment_initialization.F90 | 319 + user/baroclinic_zone_initialization.F90 | 157 + user/basin_builder.F90 | 335 + user/benchmark_initialization.F90 | 302 + user/circle_obcs_initialization.F90 | 122 + user/dense_water_initialization.F90 | 338 + user/dumbbell_initialization.F90 | 500 ++ user/dumbbell_surface_forcing.F90 | 276 + user/dyed_channel_initialization.F90 | 198 + user/dyed_obcs_initialization.F90 | 86 + user/external_gwave_initialization.F90 | 82 + user/lock_exchange_initialization.F90 | 90 + user/seamount_initialization.F90 | 308 + user/shelfwave_initialization.F90 | 184 + user/sloshing_initialization.F90 | 255 + user/soliton_initialization.F90 | 120 + user/supercritical_initialization.F90 | 83 + user/tidal_bay_initialization.F90 | 128 + user/user_change_diffusivity.F90 | 269 + user/user_initialization.F90 | 269 + user/user_revise_forcing.F90 | 61 + 294 files changed, 203655 insertions(+) create mode 100644 ALE/MOM_ALE.F90 create mode 100644 ALE/MOM_hybgen_regrid.F90 create mode 100644 ALE/MOM_hybgen_remap.F90 create mode 100644 ALE/MOM_hybgen_unmix.F90 create mode 100644 ALE/MOM_regridding.F90 create mode 100644 ALE/MOM_remapping.F90 create mode 100644 ALE/P1M_functions.F90 create mode 100644 ALE/P3M_functions.F90 create mode 100644 ALE/PCM_functions.F90 create mode 100644 ALE/PLM_functions.F90 create mode 100644 ALE/PPM_functions.F90 create mode 100644 ALE/PQM_functions.F90 create mode 100644 ALE/_ALE.dox create mode 100644 ALE/_ALE_timestep.dox create mode 100644 ALE/coord_adapt.F90 create mode 100644 ALE/coord_hycom.F90 create mode 100644 ALE/coord_rho.F90 create mode 100644 ALE/coord_sigma.F90 create mode 100644 ALE/coord_zlike.F90 create mode 100644 ALE/polynomial_functions.F90 create mode 100644 ALE/regrid_consts.F90 create mode 100644 ALE/regrid_edge_values.F90 create mode 100644 ALE/regrid_interp.F90 create mode 100644 ALE/regrid_solvers.F90 create mode 100644 ALE/remapping_attic.F90 create mode 100644 core/MOM.F90 create mode 100644 core/MOM_CoriolisAdv.F90 create mode 100644 core/MOM_PressureForce.F90 create mode 100644 core/MOM_PressureForce_FV.F90 create mode 100644 core/MOM_PressureForce_Montgomery.F90 create mode 100644 core/MOM_barotropic.F90 create mode 100644 core/MOM_boundary_update.F90 create mode 100644 core/MOM_check_scaling.F90 create mode 100644 core/MOM_checksum_packages.F90 create mode 100644 core/MOM_continuity.F90 create mode 100644 core/MOM_continuity_PPM.F90 create mode 100644 core/MOM_density_integrals.F90 create mode 100644 core/MOM_dynamics_split_RK2.F90 create mode 100644 core/MOM_dynamics_split_RK2b.F90 create mode 100644 core/MOM_dynamics_unsplit.F90 create mode 100644 core/MOM_dynamics_unsplit_RK2.F90 create mode 100644 core/MOM_forcing_type.F90 create mode 100644 core/MOM_grid.F90 create mode 100644 core/MOM_interface_heights.F90 create mode 100644 core/MOM_isopycnal_slopes.F90 create mode 100644 core/MOM_open_boundary.F90 create mode 100644 core/MOM_porous_barriers.F90 create mode 100644 core/MOM_stoch_eos.F90 create mode 100644 core/MOM_transcribe_grid.F90 create mode 100644 core/MOM_unit_tests.F90 create mode 100644 core/MOM_variables.F90 create mode 100644 core/MOM_verticalGrid.F90 create mode 100644 core/_Baroclinic_Momentum.dox create mode 100644 core/_Barotropic_Baroclinic_Coupling.dox create mode 100644 core/_Barotropic_Momentum.dox create mode 100644 core/_Discrete_Coriolis.dox create mode 100644 core/_Discrete_OBC.dox create mode 100644 core/_Discrete_PG.dox create mode 100644 core/_Discrete_grids.dox create mode 100644 core/_Energetic_consistancy.dox create mode 100644 core/_General_coordinate.dox create mode 100644 core/_Governing.dox create mode 100644 core/_Notation.dox create mode 100644 core/_PPM.dox create mode 100644 core/_Sea_ice.dox create mode 100644 core/_Solar_radiation.dox create mode 100644 core/_Specifics.dox create mode 100644 core/_Timestep_Overview.dox create mode 100644 diagnostics/MOM_PointAccel.F90 create mode 100644 diagnostics/MOM_debugging.F90 create mode 100644 diagnostics/MOM_diagnostics.F90 create mode 100644 diagnostics/MOM_obsolete_diagnostics.F90 create mode 100644 diagnostics/MOM_obsolete_params.F90 create mode 100644 diagnostics/MOM_spatial_means.F90 create mode 100644 diagnostics/MOM_sum_output.F90 create mode 100644 diagnostics/MOM_wave_speed.F90 create mode 100644 equation_of_state/MOM_EOS.F90 create mode 100644 equation_of_state/MOM_EOS_Jackett06.F90 create mode 100644 equation_of_state/MOM_EOS_Roquet_SpV.F90 create mode 100644 equation_of_state/MOM_EOS_Roquet_rho.F90 create mode 100644 equation_of_state/MOM_EOS_TEOS10.F90 create mode 100644 equation_of_state/MOM_EOS_UNESCO.F90 create mode 100644 equation_of_state/MOM_EOS_Wright.F90 create mode 100644 equation_of_state/MOM_EOS_Wright_full.F90 create mode 100644 equation_of_state/MOM_EOS_Wright_red.F90 create mode 100644 equation_of_state/MOM_EOS_base_type.F90 create mode 100644 equation_of_state/MOM_EOS_linear.F90 create mode 100644 equation_of_state/MOM_TFreeze.F90 create mode 100644 equation_of_state/MOM_temperature_convert.F90 create mode 100644 equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 create mode 100644 equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 create mode 100644 equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 create mode 100644 equation_of_state/TEOS10/gsw_ct_from_pt.f90 create mode 100644 equation_of_state/TEOS10/gsw_ct_from_t.f90 create mode 100644 equation_of_state/TEOS10/gsw_entropy_part.f90 create mode 100644 equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 create mode 100644 equation_of_state/TEOS10/gsw_gibbs.f90 create mode 100644 equation_of_state/TEOS10/gsw_gibbs_ice.f90 create mode 100644 equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 create mode 100644 equation_of_state/TEOS10/gsw_mod_error_functions.f90 create mode 100644 equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 create mode 100644 equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 create mode 100644 equation_of_state/TEOS10/gsw_mod_kinds.f90 create mode 100644 equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 create mode 100644 equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 create mode 100644 equation_of_state/TEOS10/gsw_mod_toolbox.f90 create mode 100644 equation_of_state/TEOS10/gsw_pt0_from_t.f90 create mode 100644 equation_of_state/TEOS10/gsw_pt_from_ct.f90 create mode 100644 equation_of_state/TEOS10/gsw_pt_from_t.f90 create mode 100644 equation_of_state/TEOS10/gsw_rho.f90 create mode 100644 equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 create mode 100644 equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 create mode 100644 equation_of_state/TEOS10/gsw_sp_from_sr.f90 create mode 100644 equation_of_state/TEOS10/gsw_specvol.f90 create mode 100644 equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 create mode 100644 equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 create mode 100644 equation_of_state/TEOS10/gsw_sr_from_sp.f90 create mode 100644 equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 create mode 100644 equation_of_state/TEOS10/gsw_t_freezing_exact.f90 create mode 100644 equation_of_state/TEOS10/gsw_t_freezing_poly.f90 create mode 100644 equation_of_state/TEOS10/gsw_t_from_ct.f90 create mode 100644 equation_of_state/_Equation_of_State.dox create mode 100644 framework/MOM_array_transform.F90 create mode 100644 framework/MOM_checksums.F90 create mode 100644 framework/MOM_coms.F90 create mode 100644 framework/MOM_coupler_types.F90 create mode 100644 framework/MOM_cpu_clock.F90 create mode 100644 framework/MOM_data_override.F90 create mode 100644 framework/MOM_diag_mediator.F90 create mode 100644 framework/MOM_diag_remap.F90 create mode 100644 framework/MOM_document.F90 create mode 100644 framework/MOM_domains.F90 create mode 100644 framework/MOM_dyn_horgrid.F90 create mode 100644 framework/MOM_ensemble_manager.F90 create mode 100644 framework/MOM_error_handler.F90 create mode 100644 framework/MOM_file_parser.F90 create mode 100644 framework/MOM_get_input.F90 create mode 100644 framework/MOM_hor_index.F90 create mode 100644 framework/MOM_horizontal_regridding.F90 create mode 100644 framework/MOM_interpolate.F90 create mode 100644 framework/MOM_intrinsic_functions.F90 create mode 100644 framework/MOM_io.F90 create mode 100644 framework/MOM_io_file.F90 create mode 100644 framework/MOM_memory_macros.h create mode 100644 framework/MOM_netcdf.F90 create mode 100644 framework/MOM_random.F90 create mode 100644 framework/MOM_restart.F90 create mode 100644 framework/MOM_safe_alloc.F90 create mode 100644 framework/MOM_string_functions.F90 create mode 100644 framework/MOM_unique_scales.F90 create mode 100644 framework/MOM_unit_scaling.F90 create mode 100644 framework/MOM_unit_testing.F90 create mode 100644 framework/MOM_write_cputime.F90 create mode 100644 framework/_Diagnostics.dox create mode 100644 framework/_Dimensional_consistency.dox create mode 100644 framework/_Domain_decomposition.dox create mode 100644 framework/_Global_grids.dox create mode 100644 framework/_Horizontal_indexing.dox create mode 100644 framework/_Parallel_IO.dox create mode 100644 framework/_Regional_grids.dox create mode 100644 framework/_Runtime_parameter_system.dox create mode 100644 framework/_Testing.dox create mode 100644 framework/_Vertical_grids.dox create mode 100644 framework/posix.F90 create mode 100644 framework/posix.h create mode 100644 framework/testing/MOM_file_parser_tests.F90 create mode 100644 framework/version_variable.h create mode 100644 ice_shelf/MOM_ice_shelf.F90 create mode 100644 ice_shelf/MOM_ice_shelf_diag_mediator.F90 create mode 100644 ice_shelf/MOM_ice_shelf_dynamics.F90 create mode 100644 ice_shelf/MOM_ice_shelf_initialize.F90 create mode 100644 ice_shelf/MOM_ice_shelf_state.F90 create mode 100644 ice_shelf/MOM_marine_ice.F90 create mode 100644 ice_shelf/user_shelf_init.F90 create mode 100644 initialization/MOM_coord_initialization.F90 create mode 100644 initialization/MOM_fixed_initialization.F90 create mode 100644 initialization/MOM_grid_initialize.F90 create mode 100644 initialization/MOM_shared_initialization.F90 create mode 100644 initialization/MOM_state_initialization.F90 create mode 100644 initialization/MOM_tracer_initialization_from_Z.F90 create mode 100644 ocean_data_assim/MOM_oda_driver.F90 create mode 100644 ocean_data_assim/MOM_oda_incupd.F90 create mode 100644 parameterizations/CVmix/INSTALL create mode 100644 parameterizations/CVmix/Makefile create mode 100644 parameterizations/CVmix/cvmix_background.F90 create mode 100644 parameterizations/CVmix/cvmix_convection.F90 create mode 100644 parameterizations/CVmix/cvmix_ddiff.F90 create mode 100644 parameterizations/CVmix/cvmix_kinds_and_types.F90 create mode 100644 parameterizations/CVmix/cvmix_kpp.F90 create mode 100644 parameterizations/CVmix/cvmix_math.F90 create mode 100644 parameterizations/CVmix/cvmix_put_get.F90 create mode 100644 parameterizations/CVmix/cvmix_shear.F90 create mode 100644 parameterizations/CVmix/cvmix_tidal.F90 create mode 100644 parameterizations/CVmix/cvmix_utils.F90 create mode 100755 parameterizations/CVmix/makedep.py create mode 100644 parameterizations/stochastic/MOM_stochastics.F90 create mode 100644 parameterizations/vertical/MOM_ALE_sponge.F90 create mode 100644 parameterizations/vertical/MOM_CVMix_KPP.F90 create mode 100644 parameterizations/vertical/MOM_CVMix_conv.F90 create mode 100644 parameterizations/vertical/MOM_CVMix_ddiff.F90 create mode 100644 parameterizations/vertical/MOM_CVMix_shear.F90 create mode 100644 parameterizations/vertical/MOM_bkgnd_mixing.F90 create mode 100644 parameterizations/vertical/MOM_bulk_mixed_layer.F90 create mode 100644 parameterizations/vertical/MOM_diabatic_aux.F90 create mode 100644 parameterizations/vertical/MOM_diabatic_driver.F90 create mode 100644 parameterizations/vertical/MOM_diapyc_energy_req.F90 create mode 100644 parameterizations/vertical/MOM_energetic_PBL.F90 create mode 100644 parameterizations/vertical/MOM_entrain_diffusive.F90 create mode 100644 parameterizations/vertical/MOM_full_convection.F90 create mode 100644 parameterizations/vertical/MOM_geothermal.F90 create mode 100644 parameterizations/vertical/MOM_internal_tide_input.F90 create mode 100644 parameterizations/vertical/MOM_kappa_shear.F90 create mode 100644 parameterizations/vertical/MOM_opacity.F90 create mode 100644 parameterizations/vertical/MOM_regularize_layers.F90 create mode 100644 parameterizations/vertical/MOM_set_diffusivity.F90 create mode 100644 parameterizations/vertical/MOM_set_viscosity.F90 create mode 100644 parameterizations/vertical/MOM_sponge.F90 create mode 100644 parameterizations/vertical/MOM_tidal_mixing.F90 create mode 100644 parameterizations/vertical/MOM_vert_friction.F90 create mode 100644 parameterizations/vertical/_BML.dox create mode 100644 parameterizations/vertical/_CVMix_KPP.dox create mode 100644 parameterizations/vertical/_EPBL.dox create mode 100644 parameterizations/vertical/_Frazil.dox create mode 100644 parameterizations/vertical/_V_diffusivity.dox create mode 100644 parameterizations/vertical/_V_viscosity.dox create mode 100644 tracer/DOME_tracer.F90 create mode 100644 tracer/ISOMIP_tracer.F90 create mode 100644 tracer/MOM_CFC_cap.F90 create mode 100644 tracer/MOM_OCMIP2_CFC.F90 create mode 100644 tracer/MOM_generic_tracer.F90 create mode 100644 tracer/MOM_hor_bnd_diffusion.F90 create mode 100644 tracer/MOM_neutral_diffusion.F90 create mode 100644 tracer/MOM_offline_aux.F90 create mode 100644 tracer/MOM_offline_main.F90 create mode 100644 tracer/MOM_tracer_Z_init.F90 create mode 100644 tracer/MOM_tracer_advect.F90 create mode 100644 tracer/MOM_tracer_diabatic.F90 create mode 100644 tracer/MOM_tracer_flow_control.F90 create mode 100644 tracer/MOM_tracer_hor_diff.F90 create mode 100644 tracer/MOM_tracer_registry.F90 create mode 100644 tracer/MOM_tracer_types.F90 create mode 100644 tracer/RGC_tracer.F90 create mode 100644 tracer/_Advection.dox create mode 100644 tracer/_Discrete_tracer.dox create mode 100644 tracer/_Horizontal_diffusion.dox create mode 100644 tracer/_Passive_tracer.dox create mode 100644 tracer/_Tracer_Transport.dox create mode 100644 tracer/_Tracer_fluxes.dox create mode 100644 tracer/_Tracer_timestep.dox create mode 100644 tracer/_Vertical_diffusion.dox create mode 100644 tracer/advection_test_tracer.F90 create mode 100644 tracer/boundary_impulse_tracer.F90 create mode 100644 tracer/dye_example.F90 create mode 100644 tracer/dyed_obc_tracer.F90 create mode 100644 tracer/ideal_age_example.F90 create mode 100644 tracer/nw2_tracers.F90 create mode 100644 tracer/oil_tracer.F90 create mode 100644 tracer/pseudo_salt_tracer.F90 create mode 100644 tracer/tracer_example.F90 create mode 100644 user/BFB_initialization.F90 create mode 100644 user/BFB_surface_forcing.F90 create mode 100644 user/DOME2d_initialization.F90 create mode 100644 user/DOME_initialization.F90 create mode 100644 user/ISOMIP_initialization.F90 create mode 100644 user/Idealized_Hurricane.F90 create mode 100644 user/Kelvin_initialization.F90 create mode 100644 user/MOM_controlled_forcing.F90 create mode 100644 user/MOM_wave_interface.F90 create mode 100644 user/Neverworld_initialization.F90 create mode 100644 user/Phillips_initialization.F90 create mode 100644 user/RGC_initialization.F90 create mode 100644 user/Rossby_front_2d_initialization.F90 create mode 100644 user/SCM_CVMix_tests.F90 create mode 100644 user/adjustment_initialization.F90 create mode 100644 user/baroclinic_zone_initialization.F90 create mode 100644 user/basin_builder.F90 create mode 100644 user/benchmark_initialization.F90 create mode 100644 user/circle_obcs_initialization.F90 create mode 100644 user/dense_water_initialization.F90 create mode 100644 user/dumbbell_initialization.F90 create mode 100644 user/dumbbell_surface_forcing.F90 create mode 100644 user/dyed_channel_initialization.F90 create mode 100644 user/dyed_obcs_initialization.F90 create mode 100644 user/external_gwave_initialization.F90 create mode 100644 user/lock_exchange_initialization.F90 create mode 100644 user/seamount_initialization.F90 create mode 100644 user/shelfwave_initialization.F90 create mode 100644 user/sloshing_initialization.F90 create mode 100644 user/soliton_initialization.F90 create mode 100644 user/supercritical_initialization.F90 create mode 100644 user/tidal_bay_initialization.F90 create mode 100644 user/user_change_diffusivity.F90 create mode 100644 user/user_initialization.F90 create mode 100644 user/user_revise_forcing.F90 diff --git a/ALE/MOM_ALE.F90 b/ALE/MOM_ALE.F90 new file mode 100644 index 0000000000..543d77a0f3 --- /dev/null +++ b/ALE/MOM_ALE.F90 @@ -0,0 +1,1646 @@ +!> This module contains the main regridding routines. +!! +!! Regridding comprises two steps: +!! 1. Interpolation and creation of a new grid based on target interface +!! densities (or any other criterion). +!! 2. Remapping of quantities between old grid and new grid. +!! +!! Original module written by Laurent White, 2008.06.09 +module MOM_ALE + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : check_column_integrals +use MOM_diag_mediator, only : register_diag_field, post_data, diag_ctrl +use MOM_diag_mediator, only : time_type, diag_update_remap_grids, query_averaging_enabled +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +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, calc_derived_thermo +use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W +use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S +use MOM_regridding, only : initialize_regridding, regridding_main, end_regridding +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 +use MOM_regridding, only : regriddingDefaultBoundaryExtrapolation +use MOM_regridding, only : regriddingDefaultMinThickness +use MOM_regridding, only : regridding_CS, set_regrid_params, write_regrid_file +use MOM_regridding, only : getCoordinateInterfaces +use MOM_regridding, only : getCoordinateUnits, getCoordinateShortName +use MOM_regridding, only : getStaticThickness +use MOM_remapping, only : initialize_remapping, end_remapping +use MOM_remapping, only : remapping_core_h, remapping_core_w +use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme +use MOM_remapping, only : interpolate_column, reintegrate_column +use MOM_remapping, only : remapping_CS, dzFromH1H2 +use MOM_string_functions, only : uppercase, extractWord, extract_integer +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 : get_thickness_units, verticalGrid_type + +!use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +use regrid_consts, only : coordinateUnits, coordinateMode, state_dependent +use regrid_edge_values, only : edge_values_implicit_h4 +use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation +use PLM_functions, only : PLM_extrapolate_slope, PLM_monotonized_slope, PLM_slope_wa +use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation + +implicit none ; private +#include + + +!> ALE control structure +type, public :: ALE_CS ; private + logical :: remap_uv_using_old_alg !< If true, uses the old "remapping via a delta z" + !! method. If False, uses the new method that + !! remaps between grids described by h. + logical :: partial_cell_vel_remap !< If true, use partial cell thicknesses at velocity points + !! that are masked out where they extend below the shallower + !! of the neighboring bathymetry for remapping velocity. + + real :: regrid_time_scale !< The time-scale used in blending between the current (old) grid + !! and the target (new) grid [T ~> s] + + type(regridding_CS) :: regridCS !< Regridding parameters and work arrays + 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 + !! Hybgen remapping, or a negative value to avoid such filtering + !! altogether, in [H ~> m or kg m-2]. + real :: h_vel_mask !< A thickness at velocity points below which near-bottom layers are + !! zeroed out after remapping, following the practice with Hybgen + !! remapping, or a negative value to avoid such filtering altogether, + !! in [H ~> m or kg m-2]. + + logical :: remap_after_initialization !< Indicates whether to regrid/remap after initializing the state. + + integer :: answer_date !< The vintage of the expressions and order of arithmetic to use for + !! remapping. Values below 20190101 result in the use of older, less + !! accurate expressions that were in use at the end of 2018. Higher + !! values result in the use of more robust and accurate forms of + !! mathematically equivalent expressions. + + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: show_call_tree !< For debugging + + ! for diagnostics + type(diag_ctrl), pointer :: diag !< structure to regulate output + integer, dimension(:), allocatable :: id_tracer_remap_tendency !< diagnostic id + integer, dimension(:), allocatable :: id_Htracer_remap_tendency !< diagnostic id + integer, dimension(:), allocatable :: id_Htracer_remap_tendency_2d !< diagnostic id + logical, dimension(:), allocatable :: do_tendency_diag !< flag for doing diagnostics + integer :: id_dzRegrid = -1 !< diagnostic id + + ! diagnostic for fields prior to applying ALE remapping + integer :: id_u_preale = -1 !< diagnostic id for zonal velocity before ALE. + integer :: id_v_preale = -1 !< diagnostic id for meridional velocity before ALE. + integer :: id_h_preale = -1 !< diagnostic id for layer thicknesses before ALE. + integer :: id_T_preale = -1 !< diagnostic id for temperatures before ALE. + integer :: id_S_preale = -1 !< diagnostic id for salinities before ALE. + integer :: id_e_preale = -1 !< diagnostic id for interface heights before ALE. + integer :: id_vert_remap_h = -1 !< diagnostic id for layer thicknesses used for remapping + integer :: id_vert_remap_h_tendency = -1 !< diagnostic id for layer thickness tendency due to ALE + +end type + +! Publicly available functions +public ALE_init +public ALE_end +public ALE_regrid +public ALE_offline_inputs +public ALE_regrid_accelerated +public ALE_remap_scalar +public ALE_remap_tracers +public ALE_remap_velocities +public ALE_remap_set_h_vel, ALE_remap_set_h_vel_via_dz +public ALE_remap_interface_vals +public ALE_remap_vertex_vals +public ALE_PLM_edge_values +public TS_PLM_edge_values +public TS_PPM_edge_values +public adjustGridForIntegrity +public ALE_initRegridding +public ALE_getCoordinate +public ALE_getCoordinateUnits +public ALE_writeCoordinateFile +public ALE_updateVerticalGridType +public ALE_initThicknessToCoord +public ALE_update_regrid_weights +public pre_ALE_diagnostics +public pre_ALE_adjustments +public ALE_remap_init_conds +public ALE_register_diags + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> This routine is typically called (from initialize_MOM in file MOM.F90) +!! before the main time integration loop to initialize the regridding stuff. +!! We read the MOM_input file to register the values of different +!! regridding/remapping parameters. +subroutine ALE_init( param_file, GV, US, max_depth, CS) + type(param_file_type), intent(in) :: param_file !< Parameter file + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m]. + type(ALE_CS), pointer :: CS !< Module control structure + + ! Local variables + character(len=40) :: mdl = "MOM_ALE" ! This module's name. + character(len=80) :: string, vel_string ! Temporary strings + real :: filter_shallow_depth, filter_deep_depth ! Depth ranges of filtering [H ~> m or kg m-2] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: check_reconstruction + logical :: check_remapping + 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 "// & + "control structure.") + return + endif + allocate(CS) + + CS%show_call_tree = callTree_showQuery() + if (CS%show_call_tree) call callTree_enter("ALE_init(), MOM_ALE.F90") + + call get_param(param_file, mdl, "REMAP_UV_USING_OLD_ALG", CS%remap_uv_using_old_alg, & + "If true, uses the old remapping-via-a-delta-z method for "//& + "remapping u and v. If false, uses the new method that remaps "//& + "between grids described by an old and new thickness.", & + default=.false.) + + ! 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, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: \n"//& + trim(remappingSchemesDoc), default=remappingDefaultScheme) + call get_param(param_file, mdl, "VELOCITY_REMAPPING_SCHEME", vel_string, & + "This sets the reconstruction scheme used for vertical remapping "//& + "of velocities. By default it is the same as REMAPPING_SCHEME. "//& + "It can be one of the following schemes: \n"//& + trim(remappingSchemesDoc), default=trim(string)) + call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & + "If true, cell-by-cell reconstructions are checked for "//& + "consistency and if non-monotonicity or an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.) + call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & + "If true, the results of remapping are checked for "//& + "conservation and new extrema and if an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.) + call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & + "If true, the values on the intermediate grid used for remapping "//& + "are forced to be bounded, which might not be the case due to "//& + "round off.", default=.false.) + call get_param(param_file, mdl, "REMAP_BOUNDARY_EXTRAP", remap_boundary_extrap, & + "If true, values at the interfaces of boundary cells are "//& + "extrapolated instead of piecewise constant", default=.false.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + + call initialize_remapping( CS%remapCS, string, & + boundary_extrapolation=remap_boundary_extrap, & + check_reconstruction=check_reconstruction, & + check_remapping=check_remapping, & + force_bounds_in_subcell=force_bounds_in_subcell, & + answer_date=CS%answer_date) + call initialize_remapping( CS%vel_remapCS, vel_string, & + boundary_extrapolation=remap_boundary_extrap, & + check_reconstruction=check_reconstruction, & + check_remapping=check_remapping, & + force_bounds_in_subcell=force_bounds_in_subcell, & + answer_date=CS%answer_date) + + call get_param(param_file, mdl, "PARTIAL_CELL_VELOCITY_REMAP", CS%partial_cell_vel_remap, & + "If true, use partial cell thicknesses at velocity points that are masked out "//& + "where they extend below the shallower of the neighboring bathymetry for "//& + "remapping velocity.", default=.false.) + + call get_param(param_file, mdl, "REMAP_AFTER_INITIALIZATION", CS%remap_after_initialization, & + "If true, applies regridding and remapping immediately after "//& + "initialization so that the state is ALE consistent. This is a "//& + "legacy step and should not be needed if the initialization is "//& + "consistent with the coordinate mode.", default=.true.) + + call get_param(param_file, mdl, "REGRID_TIME_SCALE", CS%regrid_time_scale, & + "The time-scale used in blending between the current (old) grid "//& + "and the target (new) grid. A short time-scale favors the target "//& + "grid (0. or anything less than DT_THERM) has no memory of the old "//& + "grid. A very long time-scale makes the model more Lagrangian.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "REGRID_FILTER_SHALLOW_DEPTH", filter_shallow_depth, & + "The depth above which no time-filtering is applied. Above this depth "//& + "final grid exactly matches the target (new) grid.", & + units="m", default=0., scale=GV%m_to_H) + call get_param(param_file, mdl, "REGRID_FILTER_DEEP_DEPTH", filter_deep_depth, & + "The depth below which full time-filtering is applied with time-scale "//& + "REGRID_TIME_SCALE. Between depths REGRID_FILTER_SHALLOW_DEPTH and "//& + "REGRID_FILTER_SHALLOW_DEPTH the filter weights adopt a cubic profile.", & + units="m", default=0., scale=GV%m_to_H) + call set_regrid_params(CS%regridCS, depth_of_time_filter_shallow=filter_shallow_depth, & + depth_of_time_filter_deep=filter_deep_depth) + call get_param(param_file, mdl, "REGRID_USE_OLD_DIRECTION", local_logical, & + "If true, the regridding integrates upwards from the bottom for "//& + "interface positions, much as the main model does. If false "//& + "regridding integrates downward, consistent with the remapping code.", & + default=.true., do_not_log=.true.) + call set_regrid_params(CS%regridCS, integrate_downward_for_e=.not.local_logical) + + call get_param(param_file, mdl, "REMAP_VEL_MASK_BBL_THICK", CS%BBL_h_vel_mask, & + "A thickness of a bottom boundary layer below which velocities in thin layers "//& + "are zeroed out after remapping, following practice with Hybgen remapping, "//& + "or a negative value to avoid such filtering altogether.", & + default=-0.001, units="m", scale=GV%m_to_H) + call get_param(param_file, mdl, "REMAP_VEL_MASK_H_THIN", CS%h_vel_mask, & + "A thickness at velocity points below which near-bottom layers are zeroed out "//& + "after remapping, following practice with Hybgen remapping, or a negative value "//& + "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.) + + ! Keep a record of values for subsequent queries + CS%nk = GV%ke + + if (CS%show_call_tree) call callTree_leave("ALE_init()") +end subroutine ALE_init + +!> Initialize diagnostics for the ALE module. +subroutine ALE_register_diags(Time, G, GV, US, diag, CS) + type(time_type),target, intent(in) :: Time !< Time structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(diag_ctrl), target, intent(in) :: diag !< Diagnostics control structure + type(ALE_CS), pointer :: CS !< Module control structure + + ! Local variables + character(len=48) :: thickness_units + + CS%diag => diag + thickness_units = get_thickness_units(GV) + + ! These diagnostics of the state variables before ALE are useful for + ! debugging the ALE code. + CS%id_u_preale = register_diag_field('ocean_model', 'u_preale', diag%axesCuL, Time, & + 'Zonal velocity before remapping', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_v_preale = register_diag_field('ocean_model', 'v_preale', diag%axesCvL, Time, & + 'Meridional velocity before remapping', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_h_preale = register_diag_field('ocean_model', 'h_preale', diag%axesTL, Time, & + 'Layer Thickness before remapping', thickness_units, conversion=GV%H_to_MKS, & + v_extensive=.true.) + CS%id_T_preale = register_diag_field('ocean_model', 'T_preale', diag%axesTL, Time, & + 'Temperature before remapping', 'degC', conversion=US%C_to_degC) + CS%id_S_preale = register_diag_field('ocean_model', 'S_preale', diag%axesTL, Time, & + 'Salinity before remapping', 'PSU', conversion=US%S_to_ppt) + CS%id_e_preale = register_diag_field('ocean_model', 'e_preale', diag%axesTi, Time, & + 'Interface Heights before remapping', 'm', conversion=US%Z_to_m) + + CS%id_dzRegrid = register_diag_field('ocean_model', 'dzRegrid', diag%axesTi, Time, & + 'Change in interface height due to ALE regridding', 'm', conversion=GV%H_to_m) + cs%id_vert_remap_h = register_diag_field('ocean_model', 'vert_remap_h', diag%axestl, Time, & + 'layer thicknesses after ALE regridding and remapping', & + thickness_units, conversion=GV%H_to_MKS, 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', & + trim(thickness_units)//" s-1", conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) + +end subroutine ALE_register_diags + +!> Crudely adjust (initial) grid for integrity. +!! This routine is typically called (from initialize_MOM in file MOM.F90) +!! before the main time integration loop to initialize the regridding stuff. +!! We read the MOM_input file to register the values of different +!! regridding/remapping parameters. +subroutine adjustGridForIntegrity( CS, G, GV, h ) + type(ALE_CS), intent(in) :: CS !< Regridding parameters and options + type(ocean_grid_type), intent(in) :: G !< Ocean grid informations + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid thickness that + !! are to be adjusted [H ~> m or kg m-2] + call inflate_vanished_layers_old( CS%regridCS, G, GV, h(:,:,:) ) + +end subroutine adjustGridForIntegrity + + +!> End of regridding (memory deallocation). +!! This routine is typically called (from MOM_end in file MOM.F90) +!! after the main time integration loop to deallocate the regridding stuff. +subroutine ALE_end(CS) + type(ALE_CS), pointer :: CS !< module control structure + + ! 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) + +end subroutine ALE_end + +!> Save any diagnostics of the state before ALE remapping. These diagnostics are +!! mostly used for debugging. +subroutine pre_ALE_diagnostics(G, GV, US, h, u, v, tv, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid informations + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the + !! last time step [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< Zonal velocity field [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< Meridional velocity field [L T-1 ~> m s-1] + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure + type(ALE_CS), pointer :: CS !< Regridding parameters and options + + ! Local variables + real :: eta_preale(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Interface heights before remapping [Z ~> m] + + if (CS%id_u_preale > 0) call post_data(CS%id_u_preale, u, CS%diag) + if (CS%id_v_preale > 0) call post_data(CS%id_v_preale, v, CS%diag) + if (CS%id_h_preale > 0) call post_data(CS%id_h_preale, h, CS%diag) + if (CS%id_T_preale > 0) call post_data(CS%id_T_preale, tv%T, CS%diag) + if (CS%id_S_preale > 0) call post_data(CS%id_S_preale, tv%S, CS%diag) + if (CS%id_e_preale > 0) then + call find_eta(h, tv, G, GV, US, eta_preale, dZref=G%Z_ref) + call post_data(CS%id_e_preale, eta_preale, CS%diag) + endif + +end subroutine pre_ALE_diagnostics + + +!> Potentially do some preparatory work, such as convective adjustment, to clean up the model +!! state before regridding. +subroutine pre_ALE_adjustments(G, GV, US, h, tv, Reg, CS, u, v) + type(ocean_grid_type), intent(in) :: G !< Ocean grid informations + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the + !! last time step [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure + type(tracer_registry_type), pointer :: Reg !< Tracer registry structure + type(ALE_CS), pointer :: CS !< Regridding parameters and options + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(inout) :: u !< Zonal velocity field [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(inout) :: v !< Meridional velocity field [L T-1 ~> m s-1] + + integer :: ntr + + ! Do column-wise convective adjustment. + ! Tracers and velocities should probably also undergo consistent adjustments. + 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, US, CS%hybgen_unmixCS, tv, Reg, ntr, h) + endif + +end subroutine pre_ALE_adjustments + +!> Takes care of building a new grid. The creation of the new grid can be based on z coordinates, +!! target interface densities, sigma coordinates or any arbitrary coordinate system. +subroutine ALE_regrid( G, GV, US, h, h_new, dzRegrid, tv, CS, frac_shelf_h, PCM_cell) + type(ocean_grid_type), intent(in) :: G !< Ocean grid informations + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses in 3D grid before + !! regridding [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h_new !< Layer thicknesses in 3D grid after + !! regridding [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: dzRegrid !< The change in grid interface positions + !! due to regridding, in the same units as + !! thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure + type(ALE_CS), pointer :: CS !< Regridding parameters and options + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice shelf coverage [nondim] + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: PCM_cell !< If true, use PCM remapping in a cell. + + ! Local variables + logical :: showCallTree + + showCallTree = callTree_showQuery() + + if (showCallTree) call callTree_enter("ALE_regrid(), MOM_ALE.F90") + + ! Build the new grid and store it in h_new. The old grid is retained as h. + ! Both are needed for the subsequent remapping of variables. + dzRegrid(:,:,:) = 0.0 + call regridding_main( CS%remapCS, CS%regridCS, G, GV, US, h, tv, h_new, dzRegrid, & + frac_shelf_h=frac_shelf_h, PCM_cell=PCM_cell) + + if (CS%id_dzRegrid>0) then ; if (query_averaging_enabled(CS%diag)) then + call post_data(CS%id_dzRegrid, dzRegrid, CS%diag, alt_h=h_new) + endif ; endif + + if (showCallTree) call callTree_leave("ALE_regrid()") + +end subroutine ALE_regrid + +!> Regrid/remap stored fields used for offline tracer integrations. These input fields are assumed to have +!! the same layer thicknesses at the end of the last offline interval (which should be a Zstar grid). This +!! routine builds a grid on the runtime specified vertical coordinate +subroutine ALE_offline_inputs(CS, G, GV, US, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) + type(ALE_CS), pointer :: CS !< Regridding parameters and options + type(ocean_grid_type), intent(in ) :: G !< Ocean grid informations + type(verticalGrid_type), intent(in ) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure + type(tracer_registry_type), pointer :: Reg !< Tracer registry structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Zonal mass fluxes [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Meridional mass fluxes [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd !< Input diffusivities + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + logical, intent(in ) :: debug !< If true, then turn checksums + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + ! Local variables + integer :: nk, i, j, k, isc, iec, jsc, jec + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new ! Layer thicknesses after regridding [H ~> m or kg m-2] + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: h_src ! Source grid thicknesses at velocity points [H ~> m or kg m-2] + 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] + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke + dzRegrid(:,:,:) = 0.0 + h_new(:,:,:) = 0.0 + + if (debug) call MOM_tracer_chkinv("Before ALE_offline_inputs", G, GV, h, Reg%Tr, Reg%ntr) + + ! Build new grid from the Zstar state onto the requested vertical coordinate. The new grid is stored + ! in h_new. The old grid is h. Both are needed for the subsequent remapping of variables. Convective + ! adjustment right now is not used because it is unclear what to do with vanished layers + call regridding_main( CS%remapCS, CS%regridCS, G, GV, US, h, tv, h_new, dzRegrid) + if (CS%show_call_tree) call callTree_waypoint("new grid generated (ALE_offline_inputs)") + + ! Remap all variables from old grid h onto new grid h_new + call ALE_remap_tracers(CS, G, GV, h, h_new, Reg, debug=CS%show_call_tree) + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_inputs)") + + ! Reintegrate mass transports from Zstar to the offline vertical coordinate + do j=jsc,jec ; do i=G%iscB,G%iecB + if (G%mask2dCu(i,j)>0.) then + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (h_new(i,j,:) + h_new(i+1,j,:)) + call reintegrate_column(nk, h_src, uhtr(I,j,:), nk, h_dest, temp_vec) + uhtr(I,j,:) = temp_vec + endif + enddo ; enddo + do j=G%jscB,G%jecB ; do i=isc,iec + if (G%mask2dCv(i,j)>0.) then + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (h_new(i,j,:) + h_new(i,j+1,:)) + call reintegrate_column(nk, h_src, vhtr(I,j,:), nk, h_dest, temp_vec) + vhtr(I,j,:) = temp_vec + endif + enddo ; enddo + + do j=jsc,jec ; do i=isc,iec + if (G%mask2dT(i,j)>0.) then + if (check_column_integrals(nk, h_src, nk, h_dest)) then + call MOM_error(FATAL, "ALE_offline_inputs: Kd interpolation columns do not match") + endif + call interpolate_column(nk, h(i,j,:), Kd(i,j,:), nk, h_new(i,j,:), Kd(i,j,:), .true.) + endif + enddo ; enddo + + call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%T, h_new, tv%T, answer_date=CS%answer_date) + call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%S, h_new, tv%S, answer_date=CS%answer_date) + + if (debug) call MOM_tracer_chkinv("After ALE_offline_inputs", G, GV, h_new, Reg%Tr, Reg%ntr) + + ! Copy over the new layer thicknesses + do k = 1,nk ; do j = jsc-1,jec+1 ; do i = isc-1,iec+1 + h(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + + if (CS%show_call_tree) call callTree_leave("ALE_offline_inputs()") +end subroutine ALE_offline_inputs + + +!> For a state-based coordinate, accelerate the process of regridding by +!! repeatedly applying the grid calculation algorithm +subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, dt, dzRegrid, initial) + type(ALE_CS), pointer :: CS !< ALE control structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Vertical grid + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Original thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Thermo vars (T/S/EOS) + 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)), & + intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(tracer_registry_type), & + optional, pointer :: Reg !< Tracer registry to remap onto new grid + real, optional, intent(in) :: dt !< Model timestep to provide a timescale for regridding [T ~> s] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzRegrid !< Final change in interface positions [H ~> m or kg m-2] + logical, optional, intent(in) :: initial !< Whether we're being called from an initialization + !! routine (and expect diagnostics to work) + + ! Local variables + 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 ! A working copy of layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_orig ! The original layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: T ! local temporary temperatures [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: S ! local temporary salinities [S ~> ppt] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: h_old_u ! Source grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: h_old_v ! Source grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: h_new_u ! Destination grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: h_new_v ! Destination grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + + ! we have to keep track of the total dzInterface if for some reason + ! we're using the old remapping algorithm for u/v + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzInterface ! Interface height changes within + ! an iteration [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzIntTotal ! Cumulative interface position changes [H ~> m or kg m-2] + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] + + nz = GV%ke + + ! initial total interface displacement due to successive regridding + if (CS%remap_uv_using_old_alg) & + dzIntTotal(:,:,:) = 0. + + call create_group_pass(pass_T_S_h, T, G%domain) + call create_group_pass(pass_T_S_h, S, G%domain) + call create_group_pass(pass_T_S_h, h_loc, G%domain) + + ! copy original temp/salt and set our local tv_pointers to them + tv_local = tv + T(:,:,:) = tv%T(:,:,:) + S(:,:,:) = tv%S(:,:,:) + tv_local%T => T + tv_local%S => S + + ! get local copy of thickness and save original state for remapping + h_loc(:,:,:) = h(:,:,:) + h_orig(:,:,:) = h(:,:,:) + + ! Apply timescale to regridding (for e.g. filtered_grid_motion) + if (present(dt)) & + call ALE_update_regrid_weights(dt, CS) + + if (CS%answer_date >= 20190101) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + else + h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + endif + + do itt = 1, n_itt + + call do_group_pass(pass_T_S_h, G%domain) + + ! generate new grid + if (CS%do_conv_adj) call convective_adjustment(G, GV, h_loc, tv_local) + + ! Update the layer specific volumes if necessary + if (allocated(tv_local%SpV_avg)) call calc_derived_thermo(tv_local, h, G, GV, US, halo=1) + + call regridding_main(CS%remapCS, CS%regridCS, G, GV, US, h_loc, tv_local, h, dzInterface) + if (CS%remap_uv_using_old_alg) & + dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) + + ! remap from original grid onto new grid + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h(i,j,:), tv_local%S(i,j,:), & + h_neglect, h_neglect_edge) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), tv_local%T(i,j,:), & + h_neglect, h_neglect_edge) + enddo ; enddo + + ! starting grid for next iteration + h_loc(:,:,:) = h(:,:,:) + enddo + + ! remap all state variables (including those that weren't needed for regridding) + call ALE_remap_tracers(CS, G, GV, h_orig, h, Reg) + + call ALE_remap_set_h_vel(CS, G, GV, h_orig, h_old_u, h_old_v, OBC) + if (CS%remap_uv_using_old_alg) then + call ALE_remap_set_h_vel_via_dz(CS, G, GV, h, h_new_u, h_new_v, OBC, h_orig, dzIntTotal) + else + call ALE_remap_set_h_vel(CS, G, GV, h, h_new_u, h_new_v, OBC) + endif + + call ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v) + + ! save total dzregrid for diags if needed? + if (present(dzRegrid)) dzRegrid(:,:,:) = dzIntTotal(:,:,:) + + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + +end subroutine ALE_regrid_accelerated + +!> This routine takes care of remapping all tracer variables between the old and the +!! new grids. This routine is called during initialization of the model at time=0, to +!! remap initial conditions to the model grid. It is also called during a +!! time step to update the state. +subroutine ALE_remap_tracers(CS, G, GV, h_old, h_new, Reg, debug, dt, PCM_cell) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid + !! [H ~> m or kg m-2] + type(tracer_registry_type), pointer :: Reg !< Tracer registry structure + logical, optional, intent(in) :: debug !< If true, show the call tree + real, optional, intent(in) :: dt !< time step for diagnostics [T ~> s] + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: PCM_cell !< Use PCM remapping in cells where true + + ! Local variables + real :: tr_column(GV%ke) ! A column of updated tracer concentrations [CU ~> Conc] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_conc ! The rate of change of concentrations [Conc T-1 ~> Conc s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_cont ! The rate of change of cell-integrated tracer + ! content [Conc H T-1 ~> Conc m s-1 or Conc kg m-2 s-1] or + ! cell thickness [H T-1 ~> m s-1 or Conc kg m-2 s-1] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! The rate of change of column-integrated tracer + ! content [Conc H T-1 ~> Conc m s-1 or Conc kg m-2 s-1] + logical :: PCM(GV%ke) ! If true, do PCM remapping from a cell. + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: h1(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] + real :: h2(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] + real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H ~> m or kg m-2] + logical :: show_call_tree + type(tracer_type), pointer :: Tr => NULL() + integer :: i, j, k, m, nz, ntr + + show_call_tree = .false. + if (present(debug)) show_call_tree = debug + + if (CS%answer_date >= 20190101) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + + if (show_call_tree) call callTree_enter("ALE_remap_tracers(), MOM_ALE.F90") + + nz = GV%ke + + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr + + if (present(dt)) then + Idt = 1.0/dt + work_conc(:,:,:) = 0.0 + work_cont(:,:,:) = 0.0 + endif + + ! Remap all registered tracers, including temperature and salinity. + if (ntr>0) then + if (show_call_tree) call callTree_waypoint("remapping tracers (ALE_remap_tracers)") + !$OMP parallel do default(shared) private(h1,h2,tr_column,Tr,PCM,work_conc,work_cont,work_2d) + do m=1,ntr ! For each tracer + Tr => Reg%Tr(m) + do j = G%jsc,G%jec ; do i = G%isc,G%iec ; if (G%mask2dT(i,j)>0.) then + ! Build the start and final grids + h1(:) = h_old(i,j,:) + h2(:) = h_new(i,j,:) + if (present(PCM_cell)) then + PCM(:) = PCM_cell(i,j,:) + call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column, & + h_neglect, h_neglect_edge, PCM_cell=PCM) + else + call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column, & + h_neglect, h_neglect_edge) + endif + + ! Possibly underflow any very tiny tracer concentrations to 0. Note that this is not conservative! + if (Tr%conc_underflow > 0.0) then ; do k=1,GV%ke + if (abs(tr_column(k)) < Tr%conc_underflow) tr_column(k) = 0.0 + enddo ; endif + + ! Intermediate steps for tendency of tracer concentration and tracer content. + if (present(dt)) then + if (Tr%id_remap_conc > 0) then + do k=1,GV%ke + work_conc(i,j,k) = (tr_column(k) - Tr%t(i,j,k)) * Idt + enddo + endif + if (Tr%id_remap_cont > 0 .or. Tr%id_remap_cont_2d > 0) then + do k=1,GV%ke + work_cont(i,j,k) = (tr_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt + enddo + endif + endif + + ! update tracer concentration + Tr%t(i,j,:) = tr_column(:) + endif ; enddo ; enddo + + ! tendency diagnostics. + if (present(dt)) then + if (Tr%id_remap_conc > 0) then + call post_data(Tr%id_remap_conc, work_conc, CS%diag) + endif + if (Tr%id_remap_cont > 0) then + call post_data(Tr%id_remap_cont, work_cont, CS%diag) + endif + + if (Tr%id_remap_cont_2d > 0) then + do j = G%jsc,G%jec ; do i = G%isc,G%iec + work_2d(i,j) = 0.0 + do k = 1,GV%ke + work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) + enddo + enddo ; enddo + call post_data(Tr%id_remap_cont_2d, work_2d, CS%diag) + endif + endif + enddo ! m=1,ntr + + endif ! endif for ntr > 0 + + + if (CS%id_vert_remap_h > 0) call post_data(CS%id_vert_remap_h, h_old, CS%diag) + if ((CS%id_vert_remap_h_tendency > 0) .and. present(dt)) then + do k = 1, nz ; do j = G%jsc,G%jec ; do i = G%isc,G%iec + work_cont(i,j,k) = (h_new(i,j,k) - h_old(i,j,k))*Idt + enddo ; enddo ; enddo + call post_data(CS%id_vert_remap_h_tendency, work_cont, CS%diag) + endif + + if (show_call_tree) call callTree_leave("ALE_remap_tracers(), MOM_ALE.F90") + +end subroutine ALE_remap_tracers + +!> This routine sets the thicknesses at velocity points used for vertical remapping. +subroutine ALE_remap_set_h_vel(CS, G, GV, h_new, h_u, h_v, OBC, debug) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness at tracer points of the + !! grid being interpolated to velocity + !! points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + logical, optional, intent(in) :: debug !< If true, show the call tree + + ! Local variables + logical :: show_call_tree + integer :: i, j, k + + show_call_tree = .false. + if (present(debug)) show_call_tree = debug + if (show_call_tree) call callTree_enter("ALE_remap_set_h_vel()") + + ! Build the u- and v-velocity grid thicknesses for remapping. + + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + h_u(I,j,k) = 0.5*(h_new(i,j,k) + h_new(i+1,j,k)) + endif ; enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do k=1,GV%ke ; do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + h_v(i,J,k) = 0.5*(h_new(i,j,k) + h_new(i,j+1,k)) + endif ; enddo ; enddo ; enddo + + ! Mask out blocked portions of velocity cells. + if (CS%partial_cell_vel_remap) call ALE_remap_set_h_vel_partial(CS, G, GV, h_new, h_u, h_v) + + ! Take open boundary conditions into account. + if (associated(OBC)) call ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) + + if (show_call_tree) call callTree_leave("ALE_remap_set_h_vel()") + +end subroutine ALE_remap_set_h_vel + +!> This routine sets the thicknesses at velocity points used for vertical remapping using a +!! combination of the old grid and interface movements. +subroutine ALE_remap_set_h_vel_via_dz(CS, G, GV, h_new, h_u, h_v, OBC, h_old, dzInterface, debug) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness at tracer points of the + !! grid being interpolated to velocity + !! points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Thickness of source grid when generating + !! the destination grid via the old + !! algorithm [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(in) :: dzInterface !< Change in interface position + !! [H ~> m or kg m-2] + logical, optional, intent(in) :: debug !< If true, show the call tree + + ! Local variables + logical :: show_call_tree + integer :: i, j, k + + show_call_tree = .false. + if (present(debug)) show_call_tree = debug + if (show_call_tree) call callTree_enter("ALE_remap_set_h_vel()") + + ! Build the u- and v-velocity grid thicknesses for remapping using the old grid and interface movement. + + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + h_u(I,j,k) = max( 0., 0.5*(h_old(i,j,k) + h_old(i+1,j,k)) + & + 0.5 * (( dzInterface(i,j,k) + dzInterface(i+1,j,k) ) - & + ( dzInterface(i,j,k+1) + dzInterface(i+1,j,k+1) )) ) + endif ; enddo ; enddo ; enddo + + !$OMP parallel do default(shared) + do k=1,GV%ke ; do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + h_v(i,J,k) = max( 0., 0.5*(h_old(i,j,k) + h_old(i,j+1,k)) + & + 0.5 * (( dzInterface(i,j,k) + dzInterface(i,j+1,k) ) - & + ( dzInterface(i,j,k+1) + dzInterface(i,j+1,k+1) )) ) + endif ; enddo ; enddo ; enddo + + ! Mask out blocked portions of velocity cells. + if (CS%partial_cell_vel_remap) call ALE_remap_set_h_vel_partial(CS, G, GV, h_old, h_u, h_v) + + ! Take open boundary conditions into account. + if (associated(OBC)) call ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) + + if (show_call_tree) call callTree_leave("ALE_remap_set_h_vel()") + +end subroutine ALE_remap_set_h_vel_via_dz + +!> Mask out the thicknesses at velocity points where they are below the minimum depth +!! at adjacent tracer points +subroutine ALE_remap_set_h_vel_partial(CS, G, GV, h_mask, h_u, h_v) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_mask !< Thickness at tracer points + !! used to apply the partial + !! cell masking [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: h_tot ! The vertically summed thicknesses [H ~> m or kg m-2] + real :: h_mask_vel ! A depth below which the thicknesses at a velocity point are masked out [H ~> m or kg m-2] + integer :: i, j, k + + h_tot(:,:) = 0.0 + do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + h_tot(i,j) = h_tot(i,j) + h_mask(i,j,k) + enddo ; enddo ; enddo + + !$OMP parallel do default(shared) private(h_mask_vel) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + h_mask_vel = min(h_tot(i,j), h_tot(i+1,j)) + call apply_partial_cell_mask(h_u(I,j,:), h_mask_vel) + endif ; enddo ; enddo + + !$OMP parallel do default(shared) private(h_mask_vel) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + h_mask_vel = min(h_tot(i,j), h_tot(i,j+1)) + call apply_partial_cell_mask(h_v(i,J,:), h_mask_vel) + endif ; enddo ; enddo + +end subroutine ALE_remap_set_h_vel_partial + +! Reset thicknesses at velocity points on open boundary condition segments +subroutine ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness at tracer points of the + !! grid being interpolated to velocity + !! points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + + ! Local variables + integer :: i, j, k, nz + + if (.not.associated(OBC)) return + + nz = GV%ke + + ! Take open boundary conditions into account. + !$OMP parallel do default(shared) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do k=1,nz ; h_u(I,j,k) = h_new(i,j,k) ; enddo + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + do k=1,nz ; h_u(I,j,k) = h_new(i+1,j,k) ; enddo + endif + endif ; enddo ; enddo + + !$OMP parallel do default(shared) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do k=1,nz ; h_v(i,J,k) = h_new(i,j,k) ; enddo + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + do k=1,nz ; h_v(i,J,k) = h_new(i,j+1,k) ; enddo + endif + endif ; enddo ; enddo + +end subroutine ALE_remap_set_h_vel_OBC + +!> This routine remaps velocity components between the old and the new grids, +!! with thicknesses at velocity points taken to be arithmetic averages of tracer thicknesses. +!! This routine may be called during initialization of the model at time=0, to +!! remap initial conditions to the model grid. It is also called during a +!! time step to update the state. +subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v, debug) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old_u !< Source grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_old_v !< Source grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new_u !< Destination grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_new_v !< Destination grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + logical, optional, intent(in) :: debug !< If true, show the call tree + + ! Local variables + real :: h_mask_vel ! A depth below which the thicknesses at a velocity point are masked out [H ~> m or kg m-2] + real :: u_src(GV%ke) ! A column of u-velocities on the source grid [L T-1 ~> m s-1] + real :: u_tgt(GV%ke) ! A column of u-velocities on the target grid [L T-1 ~> m s-1] + real :: v_src(GV%ke) ! A column of v-velocities on the source grid [L T-1 ~> m s-1] + real :: v_tgt(GV%ke) ! A column of v-velocities on the target grid [L T-1 ~> m s-1] + real :: h1(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] + real :: h2(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] + real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H ~> m or kg m-2] + logical :: show_call_tree + integer :: i, j, k, nz + + show_call_tree = .false. + if (present(debug)) show_call_tree = debug + if (show_call_tree) call callTree_enter("ALE_remap_velocities()") + + if (CS%answer_date >= 20190101) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + + nz = GV%ke + + ! --- Remap u profiles from the source vertical grid onto the new target grid. + + !$OMP parallel do default(shared) private(h1,h2,u_src,h_mask_vel,u_tgt) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + ! Make a 1-d copy of the start and final grids and the source velocity + do k=1,nz + h1(k) = h_old_u(I,j,k) + h2(k) = h_new_u(I,j,k) + u_src(k) = u(I,j,k) + enddo + + call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt, & + h_neglect, h_neglect_edge) + + if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) & + call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) + + ! Copy the column of new velocities back to the 3-d array + do k=1,nz + u(I,j,k) = u_tgt(k) + enddo !k + endif ; enddo ; enddo + + if (show_call_tree) call callTree_waypoint("u remapped (ALE_remap_velocities)") + + + ! --- Remap v profiles from the source vertical grid onto the new target grid. + + !$OMP parallel do default(shared) private(h1,h2,v_src,h_mask_vel,v_tgt) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + + do k=1,nz + h1(k) = h_old_v(i,J,k) + h2(k) = h_new_v(i,J,k) + v_src(k) = v(i,J,k) + enddo + + call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt, & + h_neglect, h_neglect_edge) + + if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then + call mask_near_bottom_vel(v_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) + endif + + ! Copy the column of new velocities back to the 3-d array + do k=1,nz + v(i,J,k) = v_tgt(k) + enddo !k + endif ; enddo ; enddo + + if (show_call_tree) call callTree_waypoint("v remapped (ALE_remap_velocities)") + if (show_call_tree) call callTree_leave("ALE_remap_velocities()") + +end subroutine ALE_remap_velocities + +!> Interpolate to find an updated array of values at interfaces after remapping. +subroutine ALE_remap_interface_vals(CS, G, GV, h_old, h_new, int_val) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(inout) :: int_val !< The interface values to interpolate [A] + + real :: val_src(GV%ke+1) ! A column of interface values on the source grid [A] + real :: val_tgt(GV%ke+1) ! A column of interface values on the target grid [A] + real :: h_src(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] + real :: h_tgt(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] + integer :: i, j, k, nz + + nz = GV%ke + + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (G%mask2dT(i,j)>0.) then + do k=1,nz + h_src(k) = h_old(i,j,k) + h_tgt(k) = h_new(i,j,k) + enddo + + do K=1,nz+1 + val_src(K) = int_val(i,j,K) + enddo + + call interpolate_column(nz, h_src, val_src, nz, h_tgt, val_tgt, .false.) + + do K=1,nz+1 + int_val(i,j,K) = val_tgt(K) + enddo + endif ; enddo ; enddo + +end subroutine ALE_remap_interface_vals + +!> Interpolate to find an updated array of values at vertices of tracer cells after remapping. +subroutine ALE_remap_vertex_vals(CS, G, GV, h_old, h_new, vert_val) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid + !! [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & + intent(inout) :: vert_val !< The interface values to interpolate [A] + + real :: val_src(GV%ke+1) ! A column of interface values on the source grid [A] + real :: val_tgt(GV%ke+1) ! A column of interface values on the target grid [A] + real :: h_src(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] + real :: h_tgt(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] + real :: I_mask_sum ! The inverse of the tracer point masks surrounding a corner [nondim] + integer :: i, j, k, nz + + nz = GV%ke + + do J=G%JscB,G%JecB ; do I=G%IscB,G%IecB + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) > 0.0 ) then + I_mask_sum = 1.0 / ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1))) + + do k=1,nz + h_src(k) = ((G%mask2dT(i,j) * h_old(i,j,k) + G%mask2dT(i+1,j+1) * h_old(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h_old(i+1,j,k) + G%mask2dT(i,j+1) * h_old(i,j+1,k)) ) * I_mask_sum + h_tgt(k) = ((G%mask2dT(i,j) * h_new(i,j,k) + G%mask2dT(i+1,j+1) * h_new(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h_new(i+1,j,k) + G%mask2dT(i,j+1) * h_new(i,j+1,k)) ) * I_mask_sum + enddo + + do K=1,nz+1 + val_src(K) = vert_val(I,J,K) + enddo + + call interpolate_column(nz, h_src, val_src, nz, h_tgt, val_tgt, .false.) + + do K=1,nz+1 + vert_val(I,J,K) = val_tgt(K) + enddo + endif ; enddo ; enddo + +end subroutine ALE_remap_vertex_vals + +!> Mask out thicknesses to 0 when their running sum exceeds a specified value. +subroutine apply_partial_cell_mask(h1, h_mask) + real, dimension(:), intent(inout) :: h1 !< A column of thicknesses to be masked out after their + !! running vertical sum exceeds h_mask [H ~> m or kg m-2] + real, intent(in) :: h_mask !< The depth after which the thicknesses in h1 are + !! masked out [H ~> m or kg m-2] + ! Local variables + real :: h1_rsum ! The running sum of h1 [H ~> m or kg m-2] + integer :: k + + h1_rsum = 0.0 + do k=1,size(h1) + if (h1(k) > h_mask - h1_rsum) then + ! This thickness is reduced because it extends below the shallower neighboring bathymetry. + h1(k) = max(h_mask - h1_rsum, 0.0) + h1_rsum = h_mask + else + h1_rsum = h1_rsum + h1(k) + endif + enddo +end subroutine apply_partial_cell_mask + + +!> Zero out velocities in a column in very thin layers near the seafloor +subroutine mask_near_bottom_vel(vel, h, h_BBL, h_thin, nk) + integer, intent(in) :: nk !< The number of layers in this column + real, intent(inout) :: vel(nk) !< The velocity component being zeroed out [L T-1 ~> m s-1] + real, intent(in) :: h(nk) !< The layer thicknesses at velocity points [H ~> m or kg m-2] + real, intent(in) :: h_BBL !< The thickness of the near-bottom region over which to apply + !! the filtering [H ~> m or kg m-2] + real, intent(in) :: h_thin !< A layer thickness below which the filtering is applied [H ~> m or kg m-2] + + ! Local variables + real :: h_from_bot ! The distance between the top of a layer and the seafloor [H ~> m or kg m-2] + integer :: k + + if ((h_BBL < 0.0) .or. (h_thin < 0.0)) return + + h_from_bot = 0.0 + do k=nk,1,-1 + h_from_bot = h_from_bot + h(k) + if (h_from_bot > h_BBL) return + ! Set the velocity to zero in thin, near-bottom layers. + if (h(k) <= h_thin) vel(k) = 0.0 + enddo !k + +end subroutine mask_near_bottom_vel + + +!> Remaps a single scalar between grids described by thicknesses h_src and h_dst. +!! h_dst must be dimensioned as a model array with GV%ke layers while h_src can +!! have an arbitrary number of layers specified by nk_src. +subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_cells, old_remap, & + answers_2018, answer_date, h_neglect, h_neglect_edge) + type(remapping_CS), intent(in) :: CS !< Remapping control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + integer, intent(in) :: nk_src !< Number of levels on source grid + real, dimension(SZI_(G),SZJ_(G),nk_src), intent(in) :: h_src !< Level thickness of source grid + !! [H ~> m or kg m-2] or other units + !! if H_neglect is provided + real, dimension(SZI_(G),SZJ_(G),nk_src), intent(in) :: s_src !< Scalar on source grid, in arbitrary units [A] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),intent(in) :: h_dst !< Level thickness of destination grid in the + !! same units as h_src, often [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),intent(inout) :: s_dst !< Scalar on destination grid, in the same + !! arbitrary units as s_src [A] + logical, optional, intent(in) :: all_cells !< If false, only reconstruct for + !! non-vanished cells. Use all vanished + !! layers otherwise (default). + logical, optional, intent(in) :: old_remap !< If true, use the old "remapping_core_w" + !! method, otherwise use "remapping_core_h". + logical, optional, intent(in) :: answers_2018 !< If true, use the order of arithmetic + !! and expressions that recover the answers for + !! remapping from the end of 2018. Otherwise, + !! use more robust forms of the same expressions. + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + !! for remapping + real, optional, intent(in) :: h_neglect !< A negligibly small thickness used in + !! remapping cell reconstructions, in the same + !! units as h_src, often [H ~> m or kg m-2] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small thickness used in + !! remapping edge value calculations, in the same + !! units as h_src, often [H ~> m or kg m-2] + ! Local variables + integer :: i, j, k, n_points + real :: dx(GV%ke+1) ! Change in interface position [H ~> m or kg m-2] + real :: h_neg, h_neg_edge ! Tiny thicknesses used in remapping [H ~> m or kg m-2] + logical :: ignore_vanished_layers, use_remapping_core_w, use_2018_remap + + ignore_vanished_layers = .false. + if (present(all_cells)) ignore_vanished_layers = .not. all_cells + use_remapping_core_w = .false. + if (present(old_remap)) use_remapping_core_w = old_remap + n_points = nk_src + use_2018_remap = .true. ; if (present(answers_2018)) use_2018_remap = answers_2018 + if (present(answer_date)) use_2018_remap = (answer_date < 20190101) + + if (present(h_neglect)) then + h_neg = h_neglect + h_neg_edge = h_neg ; if (present(h_neglect_edge)) h_neg_edge = h_neglect_edge + else + if (.not.use_2018_remap) then + h_neg = GV%H_subroundoff ; h_neg_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neg = GV%m_to_H*1.0e-30 ; h_neg_edge = GV%m_to_H*1.0e-10 + else + h_neg = GV%kg_m2_to_H*1.0e-30 ; h_neg_edge = GV%kg_m2_to_H*1.0e-10 + endif + endif + + !$OMP parallel do default(shared) firstprivate(n_points,dx) + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j) > 0.) then + if (ignore_vanished_layers) then + n_points = 0 + do k = 1, nk_src + if (h_src(i,j,k)>0.) n_points = n_points + 1 + enddo + s_dst(i,j,:) = 0. + endif + if (use_remapping_core_w) then + call dzFromH1H2( n_points, h_src(i,j,1:n_points), GV%ke, h_dst(i,j,:), dx ) + call remapping_core_w(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), & + GV%ke, dx, s_dst(i,j,:), h_neg, h_neg_edge) + else + call remapping_core_h(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), & + GV%ke, h_dst(i,j,:), s_dst(i,j,:), h_neg, h_neg_edge) + endif + else + s_dst(i,j,:) = 0. + endif + enddo ; enddo + +end subroutine ALE_remap_scalar + + +!> Calculate edge values (top and bottom of layer) for T and S consistent with a PLM reconstruction +!! in the vertical direction. Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine TS_PLM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(ALE_CS), intent(inout) :: CS !< module control structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: S_t !< Salinity at the top edge of each layer [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: S_b !< Salinity at the bottom edge of each layer [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: T_t !< Temperature at the top edge of each layer [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: T_b !< Temperature at the bottom edge of each layer [C ~> degC] + type(thermo_var_ptrs), intent(in) :: tv !< thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< layer thickness [H ~> m or kg m-2] + logical, intent(in) :: bdry_extrap !< If true, use high-order boundary + !! extrapolation within boundary cells + + call ALE_PLM_edge_values( CS, G, GV, h, tv%S, bdry_extrap, S_t, S_b ) + call ALE_PLM_edge_values( CS, G, GV, h, tv%T, bdry_extrap, T_t, T_b ) + +end subroutine TS_PLM_edge_values + +!> Calculate edge values (top and bottom of layer) 3d scalar array. +!! Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b ) + type(ALE_CS), intent(in) :: CS !< module control structure + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: Q !< 3d scalar array, in arbitrary units [A] + logical, intent(in) :: bdry_extrap !< If true, use high-order boundary + !! extrapolation within boundary cells + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: Q_t !< Scalar at the top edge of each layer [A] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: Q_b !< Scalar at the bottom edge of each layer [A] + ! Local variables + integer :: i, j, k + real :: slp(GV%ke) ! Tracer slope times the cell width [A] + real :: mslp ! Monotonized tracer slope times the cell width [A] + real :: h_neglect ! Tiny thicknesses used in remapping [H ~> m or kg m-2] + + if (CS%answer_date >= 20190101) then + h_neglect = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 + endif + + !$OMP parallel do default(shared) private(slp,mslp) + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + slp(1) = 0. + do k = 2, GV%ke-1 + slp(k) = PLM_slope_wa(h(i,j,k-1), h(i,j,k), h(i,j,k+1), h_neglect, Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1)) + enddo + slp(GV%ke) = 0. + + do k = 2, GV%ke-1 + mslp = PLM_monotonized_slope(Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1), slp(k-1), slp(k), slp(k+1)) + Q_t(i,j,k) = Q(i,j,k) - 0.5 * mslp + Q_b(i,j,k) = Q(i,j,k) + 0.5 * mslp + enddo + if (bdry_extrap) then + mslp = - PLM_extrapolate_slope(h(i,j,2), h(i,j,1), h_neglect, Q(i,j,2), Q(i,j,1)) + Q_t(i,j,1) = Q(i,j,1) - 0.5 * mslp + Q_b(i,j,1) = Q(i,j,1) + 0.5 * mslp + mslp = PLM_extrapolate_slope(h(i,j,GV%ke-1), h(i,j,GV%ke), h_neglect, Q(i,j,GV%ke-1), Q(i,j,GV%ke)) + Q_t(i,j,GV%ke) = Q(i,j,GV%ke) - 0.5 * mslp + Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + 0.5 * mslp + else + Q_t(i,j,1) = Q(i,j,1) + Q_b(i,j,1) = Q(i,j,1) + Q_t(i,j,GV%ke) = Q(i,j,GV%ke) + Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + endif + + enddo ; enddo + +end subroutine ALE_PLM_edge_values + +!> Calculate edge values (top and bottom of layer) for T and S consistent with a PPM reconstruction +!! in the vertical direction. Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(ALE_CS), intent(inout) :: CS !< module control structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: S_t !< Salinity at the top edge of each layer [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: S_b !< Salinity at the bottom edge of each layer [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: T_t !< Temperature at the top edge of each layer [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: T_b !< Temperature at the bottom edge of each layer [C ~> degC] + type(thermo_var_ptrs), intent(in) :: tv !< thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< layer thicknesses [H ~> m or kg m-2] + logical, intent(in) :: bdry_extrap !< If true, use high-order boundary + !! extrapolation within boundary cells + + ! Local variables + integer :: i, j, k + real :: hTmp(GV%ke) ! A 1-d copy of h [H ~> m or kg m-2] + real :: tmp(GV%ke) ! A 1-d copy of a column of temperature [degC] or salinity [ppt] + real, dimension(CS%nk,2) :: & + ppol_E ! Edge value of polynomial in [degC] or [ppt] + real, dimension(CS%nk,3) :: & + ppol_coefs ! Coefficients of polynomial, all in [degC] or [ppt] + real :: h_neglect, h_neglect_edge ! Tiny thicknesses [H ~> m or kg m-2] + + if (CS%answer_date >= 20190101) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + + ! Determine reconstruction within each column + !$OMP parallel do default(shared) private(hTmp,tmp,ppol_E,ppol_coefs) + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + + ! Build current grid + hTmp(:) = h(i,j,:) + tmp(:) = tv%S(i,j,:) + + ! Reconstruct salinity profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=h_neglect_edge, & + answer_date=CS%answer_date ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect, & + answer_date=CS%answer_date ) + if (bdry_extrap) & + call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + S_t(i,j,k) = ppol_E(k,1) + S_b(i,j,k) = ppol_E(k,2) + enddo + + ! Reconstruct temperature profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + tmp(:) = tv%T(i,j,:) + if (CS%answer_date < 20190101) then + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=1.0e-10*GV%m_to_H, & + answer_date=CS%answer_date ) + else + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=GV%H_subroundoff, & + answer_date=CS%answer_date ) + endif + call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect, & + answer_date=CS%answer_date ) + if (bdry_extrap) & + call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + T_t(i,j,k) = ppol_E(k,1) + T_b(i,j,k) = ppol_E(k,2) + enddo + + enddo ; enddo + +end subroutine TS_PPM_edge_values + + +!> Initializes regridding for the main ALE algorithm +subroutine ALE_initRegridding(GV, US, max_depth, param_file, mdl, regridCS) + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m]. + type(param_file_type), intent(in) :: param_file !< parameter file + character(len=*), intent(in) :: mdl !< Name of calling module + type(regridding_CS), intent(out) :: regridCS !< Regridding parameters and work arrays + ! Local variables + character(len=30) :: coord_mode + + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", coord_mode, & + "Coordinate mode for vertical regridding. "//& + "Choose among the following possibilities: "//& + trim(regriddingCoordinateModeDoc), & + default=DEFAULT_COORDINATE_MODE, fail_if_missing=.true.) + + call initialize_regridding(regridCS, GV, US, max_depth, param_file, mdl, coord_mode, '', '') + +end subroutine ALE_initRegridding + +!> Query the target coordinate interfaces positions +function ALE_getCoordinate( CS ) + type(ALE_CS), pointer :: CS !< module control structure + + real, dimension(CS%nk+1) :: ALE_getCoordinate !< The coordinate positions, in the appropriate units + !! of the target coordinate, e.g. [Z ~> m] for z*, + !! non-dimensional for sigma, etc. + ALE_getCoordinate(:) = getCoordinateInterfaces( CS%regridCS, undo_scaling=.true. ) + +end function ALE_getCoordinate + + +!> Query the target coordinate units +function ALE_getCoordinateUnits( CS ) + type(ALE_CS), pointer :: CS !< module control structure + + character(len=20) :: ALE_getCoordinateUnits + + ALE_getCoordinateUnits = getCoordinateUnits( CS%regridCS ) + +end function ALE_getCoordinateUnits + + +!> Returns true if initial conditions should be regridded and remapped +logical function ALE_remap_init_conds( CS ) + type(ALE_CS), pointer :: CS !< module control structure + + ALE_remap_init_conds = .false. + if (associated(CS)) ALE_remap_init_conds = CS%remap_after_initialization +end function ALE_remap_init_conds + +!> Updates the weights for time filtering the new grid generated in regridding +subroutine ALE_update_regrid_weights( dt, CS ) + real, intent(in) :: dt !< Time-step used between ALE calls [T ~> s] + type(ALE_CS), pointer :: CS !< ALE control structure + ! Local variables + real :: w ! An implicit weighting estimate [nondim] + + if (associated(CS)) then + w = 0.0 + if (CS%regrid_time_scale > 0.0) then + w = CS%regrid_time_scale / (CS%regrid_time_scale + dt) + endif + call set_regrid_params(CS%regridCS, old_grid_weight=w) + endif + +end subroutine ALE_update_regrid_weights + +!> Update the vertical grid type with ALE information. +!! This subroutine sets information in the verticalGrid_type to be +!! consistent with the use of ALE mode. +subroutine ALE_updateVerticalGridType(CS, GV) + type(ALE_CS), pointer :: CS !< ALE control structure + type(verticalGrid_type), pointer :: GV !< vertical grid information + + integer :: nk + + nk = GV%ke + GV%sInterface(1:nk+1) = getCoordinateInterfaces( CS%regridCS, undo_scaling=.true. ) + GV%sLayer(1:nk) = 0.5*( GV%sInterface(1:nk) + GV%sInterface(2:nk+1) ) + GV%zAxisUnits = getCoordinateUnits( CS%regridCS ) + GV%zAxisLongName = getCoordinateShortName( CS%regridCS ) + GV%direction = -1 ! Because of ferret in z* mode. Need method to set + ! as function of coordinate mode. + +end subroutine ALE_updateVerticalGridType + + +!> Write the vertical coordinate information into a file. +!! This subroutine writes out a file containing any available data related +!! to the vertical grid used by the MOM ocean model when in ALE mode. +subroutine ALE_writeCoordinateFile( CS, GV, directory ) + type(ALE_CS), pointer :: CS !< module control structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + character(len=*), intent(in) :: directory !< directory for writing grid info + + character(len=240) :: filepath + + filepath = trim(directory) // trim("Vertical_coordinate.nc") + + call write_regrid_file(CS%regridCS, GV, filepath) + +end subroutine ALE_writeCoordinateFile + +!> Set h to coordinate values for fixed coordinate systems +subroutine ALE_initThicknessToCoord( CS, G, GV, h, height_units ) + type(ALE_CS), intent(inout) :: CS !< module control structure + type(ocean_grid_type), intent(in) :: G !< module grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness in thickness units + !! [H ~> m or kg m-2] or height units [Z ~> m] + logical, optional, intent(in) :: height_units !< If present and true, the + !! thicknesses are in height units + + ! Local variables + real :: scale ! A scaling value for the thicknesses [nondim] or [H Z-1 ~> nondim or kg m-3] + integer :: i, j + + scale = GV%Z_to_H + if (present(height_units)) then ; if (height_units) scale = 1.0 ; endif + do j = G%jsd,G%jed ; do i = G%isd,G%ied + h(i,j,:) = scale * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j)+G%Z_ref ) + enddo ; enddo + +end subroutine ALE_initThicknessToCoord + +end module MOM_ALE diff --git a/ALE/MOM_hybgen_regrid.F90 b/ALE/MOM_hybgen_regrid.F90 new file mode 100644 index 0000000000..491693549f --- /dev/null +++ b/ALE/MOM_hybgen_regrid.F90 @@ -0,0 +1,1013 @@ +!> 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 : create_MOM_file, file_exists +use MOM_io, only : MOM_infra_file, MOM_field +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 [m H-1 ~> 1 or m3 kg-1] + real :: Rho_coord_scale = 1.0 !< A scaling factor to restores the denesity coordinates to + !! values in kg m-3 [kg m-3 R-1 ~> 1] + + 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 :: dp_far_from_sfc !< A distance that determines when an interface is suffiently far from + !! the surface that certain adjustments can be made in the Hybgen regridding + !! code [H ~> m or kg m-2]. In Hycom, this is set to tenm (nominally 10 m). + real :: dp_far_from_bot !< A distance that determines when an interface is suffiently far from + !! the bottom that certain adjustments can be made in the Hybgen regridding + !! code [H ~> m or kg m-2]. In Hycom, this is set to onem (nominally 1 m). + real :: h_thin !< A layer thickness below which a layer is considered to be too thin for + !! certain adjustments to be made in the Hybgen regridding code [H ~> m or kg m-2]. + !! In Hycom, this is set to onemm (nominally 0.001 m). + + real :: rho_eps !< A small nonzero density that is used to prevent division by zero + !! in several expressions in the Hybgen regridding code [R ~> kg m-3]. + + real :: onem !< Nominally one m in thickness units [H ~> m or kg m-2], used only in + !! certain debugging tests. + +end type hybgen_regrid_CS + + +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%Pa_to_RL2_T2) + + 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_FAR_FROM_SURFACE", CS%dp_far_from_sfc, & + "A distance that determines when an interface is suffiently far "//& + "from the surface that certain adjustments can be made in the Hybgen "//& + "regridding code. In Hycom, this is set to tenm (nominally 10 m).", & + units="m", default=10.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_FAR_FROM_BOTTOM", CS%dp_far_from_bot, & + "A distance that determines when an interface is suffiently far "//& + "from the bottom that certain adjustments can be made in the Hybgen "//& + "regridding code. In Hycom, this is set to onem (nominally 1 m).", & + units="m", default=1.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_H_THIN", CS%h_thin, & + "A layer thickness below which a layer is considered to be too thin for "//& + "certain adjustments to be made in the Hybgen regridding code. "//& + "In Hycom, this is set to onemm (nominally 0.001 m).", & + units="m", default=0.001, scale=GV%m_to_H) + + call get_param(param_file, mdl, "HYBGEN_DENSITY_EPSILON", CS%rho_eps, & + "A small nonzero density that is used to prevent division by zero "//& + "in several expressions in the Hybgen regridding code.", & + units="kg m-3", default=1e-11, scale=US%kg_m3_to_R) + + + call get_param(param_file, mdl, "HYBGEN_REMAP_DENSITY_MATCH", CS%hybiso, & + "A tolerance between the layer densities and their target, within which "//& + "Hybgen determines that remapping uses PCM for a layer.", & + 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.", & + units="nondim", 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.", & + units="nondim", 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(MOM_field) :: fields(3) + type(MOM_infra_file) :: 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_MOM_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 IO_handle%close() +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 [H ~> m or kg m-2] + 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, nom_depth_H, tv, CS, dzInterface, PCM_cell) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dp !< Source grid layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(hybgen_regrid_CS), intent(in) :: CS !< hybgen control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), & + 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 [C ~> degC] + real :: saln_in(GV%ke) ! A column of input layer salinities [S ~> 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, 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 = nom_depth_H(i,j) + if (h_tot <= CS%min_dilate*nominalDepth) then + dilate = CS%min_dilate + elseif (h_tot >= CS%max_dilate*nominalDepth) then + 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, 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 + 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] + + ! 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 ! A scaling factor based on qqmn and qqmx [nondim] + real, parameter :: I_qqmx = 1.0 / qqmx ! The inverse of qqmx [nondim] + + ! --- 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, 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) :: 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] + 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 [nondim] +! real, parameter :: qqmn=-2.0, qqmx=4.0 ! traditional range for cushn [nondim] +! real, parameter :: qqmn=-4.0, qqmx=6.0 ! somewhat wider range for cushn [nondim] + + trap_errors = .true. + + 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 with the loop correcting water that is + ! too light, and it ran down the water column, but if there are a set of layers + ! that are very dense, that structure can lead to all of the water being remapped + ! into a single thick layer. Splitting the loops and running the loop upwards + ! (as is done here) avoids that catastrophic problem for layers that are far from + ! 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) + CS%rho_eps)) then + ! Water in layer k is too dense, so try to dilute with water from layer k-1 + ! Do not move interface if k = fixlay + 1 + + if ((Rcv(k-1) >= Rcv_tgt(k-1)) .or. & + (p_int(k) <= dp0cum(k) + CS%dp_far_from_bot) .or. & + (h_col(k) <= h_col(k-1))) then + ! If layer k-1 is too light, there is a conflict in the direction the + ! inteface between them should move, so thicken the thinner of the two. + + if ((Rcv_tgt(k) - Rcv(k-1)) <= CS%rho_eps) then + ! layer k-1 is far too dense, take the entire layer + ! If this code is working downward and this branch is repeated in a series + ! of successive layers, it can accumulate into a very thick homogenous layers. + 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) + CS%dp_far_from_sfc)) then + + ! Only act if interface k-1 is near the bottom or layer k-2 could donate water. + if ( (p_int(nk+1) - p_int(k-1) < thkbot) .or. & + (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 < -CS%h_thin) then + dh_cor = qhrlx(k-1) * max(h_hat2, -h_hat - h_col(k-1)) + h_col(k-2) = h_col(k-2) + dh_cor + h_col(k-1) = h_col(k-1) - dh_cor + 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) + CS%dp_far_from_sfc) .and. & + ( (p_int(nk+1) - p_int(k-2) < thkbot) .or. & + (h_col(k-3) > qqmx*dp0ij(k-3)) ) ) then + + ! Determine how much water layer k-3 could supply without becoming too thin. + if (k == fixlay+4) then + ! 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 < -CS%h_thin) then + ! Water is moved from layer k-3 to k-2, but do not dilute layer k-2 too much. + dh_cor = qhrlx(k-2) * max(h_hat3, -h_col(k-2)) + h_col(k-3) = h_col(k-3) + dh_cor + 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 < -CS%h_thin) then + dh_cor = qhrlx(k-1) * (max(h_hat2, -h_hat - h_col(k-1)) ) + h_col(k-2) = h_col(k-2) + dh_cor + h_col(k-1) = h_col(k-1) - dh_cor + 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) - CS%rho_eps) then ! layer too light + ! Water in layer k is too light, so try to dilute with water from layer k+1. + ! Entrainment is not possible if layer k touches the bottom. + if (p_int(k+1) < p_int(nk+1)) then ! k 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), CS%onem)) then + write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4," err ",es13.4)') & + k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), (h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1)) + call MOM_error(FATAL, "Mismatched thickness changes in hybgen_regrid: "//trim(mesg)) + endif + if (h_col(k) < 0.0) then ! Could instead do: -1.0e-15*max(p_int(nk+1), CS%onem)) then + write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4, " fixlay ",i4)') & + k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), fixlay + call MOM_error(FATAL, "Significantly negative final thickness in hybgen_regrid: "//trim(mesg)) + endif + enddo + do K=1,nk+1 + if (abs(dp_int(K) - (p_int(K) - pres_in(K))) > 1.0e-13*max(p_int(nk+1), CS%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/ALE/MOM_hybgen_remap.F90 b/ALE/MOM_hybgen_remap.F90 new file mode 100644 index 0000000000..f97b0e9c62 --- /dev/null +++ b/ALE/MOM_hybgen_remap.F90 @@ -0,0 +1,390 @@ +!> This module contains the hybgen remapping routines from HYCOM, with minor +!! modifications to follow the MOM6 coding conventions +module MOM_hybgen_remap + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs + +contains + +!> Set up the coefficients for PLM remapping of a set of scalars +subroutine hybgen_plm_coefs(si, dpi, slope, nk, ns, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + integer, intent(in) :: ns !< The number of scalar fields to work on + real, intent(in) :: si(nk,ns) !< The cell-averaged input scalar fields [A] + real, intent(in) :: dpi(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: slope(nk,ns) !< The PLM slope times cell width [A] + real, intent(in) :: thin !< A negligible layer thickness that can be ignored [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping for that layer + +!----------------------------------------------------------------------- +! 1) coefficients for remapping from one set of vertical cells to another. +! method: piecewise linear across each input cell with +! monotonized central-difference limiter. +! +! van Leer, B., 1977, J. Comp. Phys., 23 276-299. +! +! 2) input arguments: +! si - initial scalar fields in pi-layer space +! dpi - initial layer thicknesses (dpi(k) = pi(k+1)-pi(k)) +! nk - number of layers +! ns - number of fields +! thin - layer thickness (>0) that can be ignored +! PCM_lay - use PCM for selected layers (optional) +! +! 3) output arguments: +! slope - coefficients for hybgen_plm_remap +! profile(y) = si+slope*(y-1), -0.5 <= y <= 0.5 +! +! 4) Tim Campbell, Mississippi State University, October 2002. +! Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007. +!----------------------------------------------------------------------- +! + real :: qcen ! A layer's thickness divided by the distance between the centers + ! of the adjacent cells, usually ~0.5, but always <= 1 [nondim] + real :: zbot, zcen, ztop ! Tracer slopes times the layer thickness [A] + integer :: i, k + + do i=1,ns + slope(1, i) = 0.0 + slope(nk,i) = 0.0 + enddo !i + do k= 2,nk-1 + if (dpi(k) <= thin) then !use PCM + do i=1,ns ; slope(k,i) = 0.0 ; enddo + else +! --- use qcen in place of 0.5 to allow for non-uniform grid + qcen = dpi(k) / (dpi(k)+0.5*(dpi(k-1)+dpi(k+1))) !dpi(k)>thin + do i=1,ns +! --- PLM (non-zero slope, but no new extrema) +! --- layer value is si-0.5*slope at top interface, +! --- and si+0.5*slope at bottom interface. +! +! --- monotonized central-difference limiter (van Leer, 1977, +! --- JCP 23 pp 276-299). For a discussion of PLM limiters, see +! --- Finite Volume Methods for Hyperbolic Problems by R.J. Leveque. + ztop = 2.0*(si(k, i)-si(k-1,i)) + zbot = 2.0*(si(k+1,i)-si(k, i)) + zcen = qcen*(si(k+1,i)-si(k-1,i)) + if (ztop*zbot > 0.0) then !ztop,zbot are the same sign + slope(k,i) = sign(min(abs(zcen),abs(zbot),abs(ztop)), zbot) + else + slope(k,i) = 0.0 !local extrema, so no slope + endif + enddo !i + endif !PCM:PLM + enddo !k + + if (present(PCM_lay)) then + do k=1,nk ; if (PCM_lay(k)) then + do i=1,ns ; slope(k,i) = 0.0 ; enddo + endif ; enddo + endif + +end subroutine hybgen_plm_coefs + + +!> Set up the coefficients for PPM remapping of a set of scalars +subroutine hybgen_ppm_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + integer, intent(in) :: ns !< The scalar fields to work on + real, intent(in) :: s(nk,ns) !< The input scalar fields [A] + real, intent(in) :: h_src(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: edges(nk,2,ns) !< The PPM interpolation edge values of the scalar fields [A] + real, intent(in) :: thin !< A negligible layer thickness that can be ignored [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping for that layer + +!----------------------------------------------------------------------- +! 1) coefficients for remapping from one set of vertical cells to another. +! method: monotonic piecewise parabolic across each input cell +! +! Colella, P. & P.R. Woodward, 1984, J. Comp. Phys., 54, 174-201. +! +! 2) input arguments: +! s - initial scalar fields in pi-layer space +! h_src - initial layer thicknesses (>=0) +! nk - number of layers +! ns - number of fields +! thin - layer thickness (>0) that can be ignored +! PCM_lay - use PCM for selected layers (optional) +! +! 3) output arguments: +! edges - cell edge scalar values for the PPM reconstruction +! edges.1 is value at interface above +! edges.2 is value at interface below +! +! 4) Tim Campbell, Mississippi State University, October 2002. +! Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007. +!----------------------------------------------------------------------- +! + real :: dp(nk) ! Input grid layer thicknesses, but with a minimum thickness given by thin [H ~> m or kg m-2] + logical :: PCM_layer(nk) ! True for layers that should use PCM remapping, either because they are + ! very thin, or because this is specified by PCM_lay. + real :: da ! Difference between the unlimited scalar edge value estimates [A] + real :: a6 ! Scalar field differences that are proportional to the curvature [A] + real :: slk, srk ! Differences between adjacent cell averages of scalars [A] + real :: sck ! Scalar differences across a cell [A] + real :: as(nk) ! Scalar field difference across each cell [A] + real :: al(nk), ar(nk) ! Scalar field at the left and right edges of a cell [A] + real :: h112(nk+1), h122(nk+1) ! Combinations of thicknesses [H ~> m or kg m-2] + real :: I_h12(nk+1) ! Inverses of combinations of thickesses [H-1 ~> m-1 or m2 kg-1] + real :: h2_h123(nk) ! A ratio of a layer thickness of the sum of 3 adjacent thicknesses [nondim] + real :: I_h0123(nk) ! Inverse of the sum of 4 adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: h01_h112(nk+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + real :: h23_h122(nk+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + integer :: k, i + + ! This PPM remapper is not currently written to work with massless layers, so set + ! the thicknesses for very thin layers to some minimum value. + do k=1,nk ; dp(k) = max(h_src(k), thin) ; enddo + + ! Specify the layers that will use PCM remapping. + if (present(PCM_lay)) then + do k=1,nk ; PCM_layer(k) = (PCM_lay(k) .or. dp(k) <= thin) ; enddo + else + do k=1,nk ; PCM_layer(k) = (dp(k) <= thin) ; enddo + endif + + !compute grid metrics + do k=2,nk + h112(K) = 2.*dp(k-1) + dp(k) + h122(K) = dp(k-1) + 2.*dp(k) + I_h12(K) = 1.0 / (dp(k-1) + dp(k)) + enddo !k + do k=2,nk-1 + h2_h123(k) = dp(k) / (dp(k) + (dp(k-1)+dp(k+1))) + enddo + do K=3,nk-1 + I_h0123(K) = 1.0 / ((dp(k-2) + dp(k-1)) + (dp(k) + dp(k+1))) + + h01_h112(K) = (dp(k-2) + dp(k-1)) / (2.0*dp(k-1) + dp(k)) + h23_h122(K) = (dp(k) + dp(k+1)) / (dp(k-1) + 2.0*dp(k)) + enddo + + do i=1,ns + !Compute average slopes: Colella, Eq. (1.8) + as(1) = 0. + do k=2,nk-1 + if (PCM_layer(k)) then !use PCM + as(k) = 0.0 + else + slk = s(k, i)-s(k-1,i) + srk = s(k+1,i)-s(k, i) + if (slk*srk > 0.) then + sck = h2_h123(k)*( h112(K)*srk*I_h12(K+1) + h122(K+1)*slk*I_h12(K) ) + as(k) = sign(min(abs(2.0*slk), abs(sck), abs(2.0*srk)), sck) + else + as(k) = 0. + endif + endif !PCM:PPM + enddo !k + as(nk) = 0. + !Compute "first guess" edge values: Colella, Eq. (1.6) + al(1) = s(1,i) ! 1st layer PCM + ar(1) = s(1,i) ! 1st layer PCM + al(2) = s(1,i) ! 1st layer PCM + do K=3,nk-1 + ! This is a 4th order explicit edge value estimate. + al(k) = (dp(k)*s(k-1,i) + dp(k-1)*s(k,i)) * I_h12(K) & + + 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) + enddo !k + ar(nk-1) = s(nk,i) ! last layer PCM + al(nk) = s(nk,i) ! last layer PCM + ar(nk) = s(nk,i) ! last layer PCM + !Impose monotonicity: Colella, Eq. (1.10) + do k=2,nk-1 + if ((PCM_layer(k)) .or. ((s(k+1,i)-s(k,i))*(s(k,i)-s(k-1,i)) <= 0.)) then !local extremum + al(k) = s(k,i) + ar(k) = s(k,i) + else + da = ar(k)-al(k) + a6 = 6.0*s(k,i) - 3.0*(al(k)+ar(k)) + if (da*a6 > da*da) then !peak in right half of zone + al(k) = 3.0*s(k,i) - 2.0*ar(k) + elseif (da*a6 < -da*da) then !peak in left half of zone + ar(k) = 3.0*s(k,i) - 2.0*al(k) + endif + endif + enddo !k + !Set coefficients + do k=1,nk + edges(k,1,i) = al(k) + edges(k,2,i) = ar(k) + enddo !k + enddo !i + +end subroutine hybgen_ppm_coefs + + +!> Set up the coefficients for PPM remapping of a set of scalars +subroutine hybgen_weno_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + integer, intent(in) :: ns !< The number of scalar fields to work on + real, intent(in) :: s(nk,ns) !< The input scalar fields [A] + real, intent(in) :: h_src(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: edges(nk,2,ns) !< The WENO interpolation edge values of the scalar fields [A] + real, intent(in) :: thin !< A negligible layer thickness that can be ignored [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping for that layer + +!----------------------------------------------------------------------- +! 1) coefficients for remapping from one set of vertical cells to another. +! method: monotonic WENO-like alternative to PPM across each input cell +! a second order polynomial approximation of the profiles +! using a WENO reconciliation of the slopes to compute the +! interfacial values +! +! This scheme might have ben developed by Shchepetkin. A.F., personal communication. +! See also Engwirda, D., and M. Kelley, A WENO-type slope-limiter for a family of piecewise +! polynomial methods, arXive:1606.08188v1, 27 June 2016. +! +! 2) input arguments: +! s - initial scalar fields in pi-layer space +! h_src - initial layer thicknesses (>=0) +! nk - number of layers +! ns - number of fields +! thin - layer thickness (>0) that can be ignored +! PCM_lay - use PCM for selected layers (optional) +! +! 3) output arguments: +! edges - cell edge scalar values for the WENO reconstruction +! edges.1 is value at interface above +! edges.2 is value at interface below +! +! 4) Laurent Debreu, Grenoble. +! Alan J. Wallcraft, Naval Research Laboratory, July 2008. +!----------------------------------------------------------------------- +! +! real, parameter :: dsmll=1.0e-8 ! This has units of [A2], and hence can not be a parameter. +! + real :: curv_cell ! An estimate of the tracer curvature centered on a cell times the grid + ! spacing [A H-1 ~> A m-1 or A m2 kg-1] + real :: seh1, seh2 ! Tracer slopes at the cell edges times the cell grid spacing [A] + real :: q01, q02 ! Various tracer differences between a cell average and the edge values [A] + real :: q001, q002 ! Tracer slopes at the cell edges times the cell grid spacing [A] + logical :: PCM_layer(nk) ! True for layers that should use PCM remapping, either because they are + ! very thin, or because this is specified by PCM_lay. + real :: dp(nk) ! Input grid layer thicknesses, but with a minimum thickness given by thin [H ~> m or kg m-2] + real :: qdpkm(nk) ! Inverse of the sum of two adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: qdpkmkp(nk) ! Inverse of the sum of three adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: dpkm2kp(nk) ! Twice the distance between the centers of the layers two apart [H ~> m or kg m-2] + real :: zw(nk,2) ! Squared combinations of the differences between the the cell average tracer + ! concentrations and the left and right edges [A2] + real :: min_ratio ! The minimum ratio of the values of zw used to interpolate the edge values [nondim] + real :: wt1 ! The weight of the upper layer in the interpolated shared edge value [nondim] + real :: slope_edge(nk+1) ! Tracer slopes at the edges [A H-1 ~> A m-1 or A m2 kg-1] + real :: val_edge(nk+1) ! A weighted average edge concentration [A] + integer :: i, k + + min_ratio = 1.0e-8 + + ! The WENO remapper is not currently written to work with massless layers, so set + ! the thicknesses for very thin layers to some minimum value. + do k=1,nk ; dp(k) = max(h_src(k), thin) ; enddo + + ! Specify the layers that will use PCM remapping. + if (present(PCM_lay)) then + do k=1,nk ; PCM_layer(k) = (PCM_lay(k) .or. dp(k) <= thin) ; enddo + else + do k=1,nk ; PCM_layer(k) = (dp(k) <= thin) ; enddo + endif + + !compute grid metrics + do k=2,nk-1 + qdpkm( K) = 1.0 / (dp(k-1) + dp(k)) + qdpkmkp(k) = 1.0 / (dp(k-1) + dp(k) + dp(k+1)) + dpkm2kp(k) = dp(k-1) + 2.0*dp(k) + dp(k+1) + enddo !k + qdpkm(nk) = 1.0 / (dp(nk-1) + dp(nk)) + + do i=1,ns + do K=2,nk + slope_edge(K) = qdpkm(K) * (s(k,i)-s(k-1,i)) + enddo !k + k = 1 !PCM first layer + edges(k,1,i) = s(k,i) + edges(k,2,i) = s(k,i) + zw(k,1) = 0.0 + zw(k,2) = 0.0 + do k=2,nk-1 + if ((slope_edge(K)*slope_edge(K+1) < 0.0) .or. PCM_layer(k)) then !use PCM + edges(k,1,i) = s(k,i) + edges(k,2,i) = s(k,i) + zw(k,1) = 0.0 + zw(k,2) = 0.0 + else + seh1 = dp(k)*slope_edge(K+1) + seh2 = dp(k)*slope_edge(K) + q01 = dpkm2kp(k)*slope_edge(K+1) + q02 = dpkm2kp(k)*slope_edge(K) + if (abs(seh1) > abs(q02)) then + seh1 = q02 + endif + if (abs(seh2) > abs(q01)) then + seh2 = q01 + endif + curv_cell = (seh1 - seh2) * qdpkmkp(k) + q001 = seh1 - curv_cell*dp(k+1) + q002 = seh2 + curv_cell*dp(k-1) + ! q001 = (seh1 * (dp(k-1) + dp(k)) + seh2 * dp(k+1)) * qdpkmkp(k) + ! q002 = (seh2 * (dp(k+1) + dp(k)) + seh1 * dp(k-1)) * qdpkmkp(k) + + edges(k,2,i) = s(k,i) + q001 + edges(k,1,i) = s(k,i) - q002 + zw(k,1) = (2.0*q001 - q002)**2 + zw(k,2) = (2.0*q002 - q001)**2 + endif !PCM:WENO + enddo !k + k = nk !PCM last layer + edges(k,1,i) = s(k,i) + edges(k,2,i) = s(k,i) + zw(k, 1) = 0.0 + zw(k, 2) = 0.0 + + do k=2,nk + ! This was the original code based on that in Hycom, but because zw has + ! dimensions of [A2], it can not use a constant (hard coded) value of dsmll. + ! ds2a = max(zw(k-1,2), dsmll) + ! ds2b = max(zw(k, 1), dsmll) + ! val_edge(K) = (ds2b*edges(k-1,2,i)+ds2a*edges(k,1,i)) / (ds2b+ds2a) + ! Use a weighted average of the two layers' estimated edge values as the actual edge value. + if (zw(k,1) + zw(k-1,2) <= 0.0) then + wt1 = 0.5 + elseif (zw(k,1) <= min_ratio * (zw(k,1) + zw(k-1,2))) then + wt1 = min_ratio + elseif (zw(k-1,2) <= min_ratio * (zw(k,1) + zw(k-1,2))) then + wt1 = (1.0 - min_ratio) + else + wt1 = zw(k,1) / (zw(k,1) + zw(k-1,2)) + endif + val_edge(k) = wt1*edges(k-1,2,i) + (1.0-wt1)*edges(k,1,i) + enddo !k + val_edge( 1) = 2.0*s( 1,i)-val_edge( 2) !not used? + val_edge(nk+1) = 2.0*s(nk,i)-val_edge(nk) !not used? + + do k=2,nk-1 + if (.not.PCM_layer(k)) then !don't use PCM + q01 = val_edge(K+1) - s(k,i) + q02 = s(k,i) - val_edge(K) + if (q01*q02 < 0.0) then + q01 = 0.0 + q02 = 0.0 + elseif (abs(q01) > abs(2.0*q02)) then + q01 = 2.0*q02 + elseif (abs(q02) > abs(2.0*q01)) then + q02 = 2.0*q01 + endif + edges(k,1,i) = s(k,i) - q02 + edges(k,2,i) = s(k,i) + q01 + endif ! PCM:WENO + enddo !k + enddo !i + +end subroutine hybgen_weno_coefs + +end module MOM_hybgen_remap diff --git a/ALE/MOM_hybgen_unmix.F90 b/ALE/MOM_hybgen_unmix.F90 new file mode 100644 index 0000000000..6ddb828abe --- /dev/null +++ b/ALE/MOM_hybgen_unmix.F90 @@ -0,0 +1,527 @@ +!> 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_interface_heights, only : calc_derived_thermo +use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chkinv +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : ocean_grid_type, thermo_var_ptrs +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. + 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 [C ~> degC] + real :: saln(GV%ke) ! A column of salinity [S ~> 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 :: dz_tot ! Vertical distance between the top and bottom of the water column [Z ~> m] + real :: nominalDepth ! Depth of ocean bottom in thickness units (positive downward) [H ~> m or kg m-2] + real :: h_thin ! A negligibly small thickness to identify essentially + ! vanished layers [H ~> m or kg m-2] + real :: dilate ! A factor by which to dilate the target positions from z to z* [nondim] + + real :: Th_tot_in, Th_tot_out ! Column integrated temperature [C H ~> degC m or degC kg m-2] + real :: Sh_tot_in, Sh_tot_out ! Column integrated salinity [S 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 + + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < 1)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + mesg = "insufficiently large SpV_avg halos of width 0 but 1 is needed." + endif + call MOM_error(FATAL, "hybgen_unmix called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + p_col(:) = CS%ref_pressure + + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 ; if (G%mask2dT(i,j)>0.) then + + 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. + if (allocated(tv%SpV_avg)) then ! This is the fully non-Boussiesq version + dz_tot = 0.0 + do k=1,nk + dz_tot = dz_tot + GV%H_to_RZ * tv%SpV_avg(i,j,k) * h_col(k) + enddo + if (dz_tot <= CS%min_dilate*(G%bathyT(i,j)+G%Z_ref)) then + dilate = CS%min_dilate + elseif (dz_tot >= CS%max_dilate*(G%bathyT(i,j)+G%Z_ref)) then + dilate = CS%max_dilate + else + dilate = dz_tot / (G%bathyT(i,j)+G%Z_ref) + endif + else + nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H + if (h_tot <= CS%min_dilate*nominalDepth) then + dilate = CS%min_dilate + elseif (h_tot >= CS%max_dilate*nominalDepth) then + dilate = CS%max_dilate + else + dilate = h_tot / nominalDepth + endif + endif + + terrain_following = (h_tot < dilate*CS%dpns) .and. (CS%dpns >= CS%dsns) + + ! 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. + + ! Update the layer properties + if (allocated(tv%SpV_avg)) call calc_derived_thermo(tv, h, G, GV, US, halo=1) + +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 [C ~> degC] + real, intent(inout) :: saln(nk) !< A column of salinity [S ~> 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 [C ~> degC] + real :: dels, delsm ! Salinity differences between successive layers [S ~> ppt] + real :: abs_dRdT ! The absolute value of the derivative of the coordinate density + ! with temperature [R C-1 ~> kg m-3 degC-1] + real :: abs_dRdS ! The absolute value of the derivative of the coordinate density + ! with salinity [R S-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 [C ~> degC] + real :: swap_S ! A swap variable for salinity [S ~> ppt] + 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/ALE/MOM_regridding.F90 b/ALE/MOM_regridding.F90 new file mode 100644 index 0000000000..8faec6c495 --- /dev/null +++ b/ALE/MOM_regridding.F90 @@ -0,0 +1,2569 @@ +!> Generates vertical grids as part of the ALE algorithm +module MOM_regridding + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, FATAL, WARNING, assert +use MOM_file_parser, only : param_file_type, get_param, log_param +use MOM_io, only : file_exists, field_exists, field_size, MOM_read_data +use MOM_io, only : vardesc, var_desc, SINGLE_FILE +use MOM_io, only : MOM_netCDF_file, MOM_field +use MOM_io, only : create_MOM_file, MOM_write_field +use MOM_io, only : verify_variable_units, 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 +use MOM_EOS, only : EOS_type, calculate_density +use MOM_string_functions, only : uppercase, extractWord, extract_integer, extract_real + +use MOM_remapping, only : remapping_CS +use regrid_consts, only : state_dependent, coordinateUnits +use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +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_HYBGEN, REGRIDDING_ADAPTIVE +use regrid_interp, only : interp_CS_type, set_interp_scheme, set_interp_extrap, set_interp_answer_date + +use coord_zlike, only : init_coord_zlike, zlike_CS, set_zlike_params, build_zstar_column, end_coord_zlike +use coord_sigma, only : init_coord_sigma, sigma_CS, set_sigma_params, build_sigma_column, end_coord_sigma +use coord_rho, only : init_coord_rho, rho_CS, set_rho_params, build_rho_column, end_coord_rho +use coord_rho, only : old_inflate_layers_1d +use coord_hycom, only : init_coord_hycom, hycom_CS, set_hycom_params, build_hycom1_column, end_coord_hycom +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 + +#include + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Regridding control structure +type, public :: regridding_CS ; private + + !> This array is set by function setCoordinateResolution() + !! It contains the "resolution" or delta coordinate of the target + !! coordinate. It has the units of the target coordinate, e.g. + !! [Z ~> m] for z*, [nondim] for sigma, etc. + real, dimension(:), allocatable :: coordinateResolution + + !> This is a scaling factor that restores coordinateResolution to values in + !! the natural units for output, perhaps [nondim] + real :: coord_scale = 1.0 + + !> This array is set by function set_target_densities() + !! This array is the nominal coordinate of interfaces and is the + !! running sum of coordinateResolution, in [R ~> kg m-3]. i.e. + !! target_density(k+1) = coordinateResolution(k) + coordinateResolution(k) + !! It is only used in "rho" or "Hycom" mode. + real, dimension(:), allocatable :: target_density + + !> A flag to indicate that the target_density arrays has been filled with data. + logical :: target_density_set = .false. + + !> This array is set by function set_regrid_max_depths() + !! It specifies the maximum depth that every interface is allowed to take [H ~> m or kg m-2]. + real, dimension(:), allocatable :: max_interface_depths + + !> This array is set by function set_regrid_max_thickness() + !! It specifies the maximum depth that every interface is allowed to take [H ~> m or kg m-2]. + real, dimension(:), allocatable :: max_layer_thickness + + integer :: nk !< Number of layers/levels in generated grid + + !> Indicates which grid to use in the vertical (z*, sigma, target interface + !! densities) + integer :: regridding_scheme + + !> Interpolation control structure + type(interp_CS_type) :: interp_CS + + !> Minimum thickness allowed when building the new grid through regridding [H ~> m or kg m-2]. + real :: min_thickness + + !> Reference pressure for potential density calculations [R L2 T-2 ~> Pa] + real :: ref_pressure = 2.e7 + + !> Weight given to old coordinate when blending between new and old grids [nondim] + !! Used only below depth_of_time_filter_shallow, with a cubic variation + !! from zero to full effect between depth_of_time_filter_shallow and + !! depth_of_time_filter_deep. + real :: old_grid_weight = 0. + + !> Depth above which no time-filtering of grid is applied [H ~> m or kg m-2] + real :: depth_of_time_filter_shallow = 0. + + !> Depth below which time-filtering of grid is applied at full effect [H ~> m or kg m-2] + real :: depth_of_time_filter_deep = 0. + + !> Fraction (between 0 and 1) of compressibility to add to potential density + !! profiles when interpolating for target grid positions [nondim] + real :: compressibility_fraction = 0. + + !> If true, each interface is given a maximum depth based on a rescaling of + !! the indexing of coordinateResolution. + logical :: set_maximum_depths = .false. + + !> If true, integrate for interface positions from the top downward. + !! If false, integrate from the bottom upward, as does the rest of the model. + logical :: integrate_downward_for_e = .true. + + !> The vintage of the order of arithmetic and expressions to use for remapping. + !! Values below 20190101 recover the remapping answers from 2018. + !! Higher values use more robust forms of the same remapping expressions. + integer :: remap_answer_date = 99991231 + + 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(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_grid_column +public set_regrid_params, get_regrid_size, write_regrid_file +public uniformResolution, setCoordinateResolution +public set_target_densities_from_GV, set_target_densities +public set_regrid_max_depths, set_regrid_max_thickness +public getCoordinateResolution, getCoordinateInterfaces +public getCoordinateUnits, getCoordinateShortName, getStaticThickness +public DEFAULT_COORDINATE_MODE +public set_h_neglect, set_dz_neglect +public get_zlike_CS, get_sigma_CS, get_rho_CS + +!> Documentation for coordinate options +character(len=*), parameter, public :: regriddingCoordinateModeDoc = & + " LAYER - Isopycnal or stacked shallow water layers\n"//& + " ZSTAR, Z* - stretched geopotential z*\n"//& + " SIGMA_SHELF_ZSTAR - stretched geopotential z* ignoring shelf\n"//& + " SIGMA - terrain following coordinates\n"//& + " RHO - continuous isopycnal\n"//& + " HYCOM1 - HyCOM-like hybrid coordinate\n"//& + " HYBGEN - Hybrid coordinate from the Hycom hybgen code\n"//& + " ADAPTIVE - optimize for smooth neutral density surfaces" + +!> Documentation for regridding interpolation schemes +character(len=*), parameter, public :: regriddingInterpSchemeDoc = & + " P1M_H2 (2nd-order accurate)\n"//& + " P1M_H4 (2nd-order accurate)\n"//& + " P1M_IH4 (2nd-order accurate)\n"//& + " PLM (2nd-order accurate)\n"//& + " PPM_CW (3rd-order accurate)\n"//& + " PPM_H4 (3rd-order accurate)\n"//& + " PPM_IH4 (3rd-order accurate)\n"//& + " P3M_IH4IH3 (4th-order accurate)\n"//& + " P3M_IH6IH5 (4th-order accurate)\n"//& + " PQM_IH4IH3 (4th-order accurate)\n"//& + " PQM_IH6IH5 (5th-order accurate)" + +!> Default interpolation scheme +character(len=*), parameter, public :: regriddingDefaultInterpScheme = "P1M_H2" +!> Default mode for boundary extrapolation +logical, parameter, public :: regriddingDefaultBoundaryExtrapolation = .false. +!> Default minimum thickness for some coordinate generation modes [m] +real, parameter, public :: regriddingDefaultMinThickness = 1.e-3 + +!> Maximum length of parameters +integer, parameter :: MAX_PARAM_LENGTH = 120 + +#undef __DO_SAFETY_CHECKS__ + +contains + +!> Initialization and configures a regridding control structure based on customizable run-time parameters +subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_mode, param_prefix, param_suffix) + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m]. + type(param_file_type), intent(in) :: param_file !< Parameter file + character(len=*), intent(in) :: mdl !< Name of calling module. + character(len=*), intent(in) :: coord_mode !< Coordinate mode + character(len=*), intent(in) :: param_prefix !< String to prefix to parameter names. + !! If empty, causes main model parameters to be used. + character(len=*), intent(in) :: param_suffix !< String to append to parameter names. + + ! Local variables + integer :: ke ! Number of levels + character(len=80) :: string, string2, varName ! Temporary strings + character(len=40) :: coord_units, coord_res_param ! Temporary strings + character(len=MAX_PARAM_LENGTH) :: param_name + character(len=200) :: inputdir, fileName + character(len=320) :: message ! Temporary strings + character(len=12) :: expected_units, alt_units ! Temporary strings + logical :: tmpLogical, do_sum, main_parameters + logical :: coord_is_state_dependent, ierr + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: remap_answer_date ! The vintage of the remapping expressions to use. + integer :: regrid_answer_date ! The vintage of the regridding expressions to use. + real :: tmpReal ! A temporary variable used in setting other variables [various] + real :: P_Ref ! The coordinate variable reference pression [R L2 T-2 ~> Pa] + real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). + real :: adaptTimeRatio, adaptZoomCoeff ! Temporary variables for input parameters [nondim] + real :: adaptBuoyCoeff, adaptAlpha ! Temporary variables for input parameters [nondim] + real :: adaptZoom ! The thickness of the near-surface zooming region with the adaptive coordinate [H ~> m or kg m-2] + real :: adaptDrho0 ! Reference density difference for stratification-dependent diffusion. [R ~> kg m-3] + integer :: k, nzf(4) + real, dimension(:), allocatable :: dz ! Resolution (thickness) in units of coordinate, which may be [m] + ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units. + real, dimension(:), allocatable :: h_max ! Maximum layer thicknesses [H ~> m or kg m-2] + real, dimension(:), allocatable :: z_max ! Maximum interface depths [H ~> m or kg m-2] or other + ! units depending on the coordinate + real, dimension(:), allocatable :: dz_max ! Thicknesses used to find maximum interface depths + ! [H ~> m or kg m-2] or other units + real, dimension(:), allocatable :: rho_target ! Target density used in HYBRID mode [kg m-3] + !> Thicknesses [m] that give level centers corresponding to table 2 of WOA09 + real, dimension(40) :: woa09_dz = (/ 5., 10., 10., 15., 22.5, 25., 25., 25., & + 37.5, 50., 50., 75., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 175., & + 250., 375., 500., 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., 500., 500., 500. /) + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + main_parameters=.false. + if (len_trim(param_prefix)==0) main_parameters=.true. + if (main_parameters .and. len_trim(param_suffix)>0) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'Suffix provided without prefix for parameter names!') + + CS%nk = 0 + CS%regridding_scheme = coordinateMode(coord_mode) + coord_is_state_dependent = state_dependent(coord_mode) + maximum_depth = US%Z_to_m*max_depth + + if (main_parameters) then + ! Read coordinate units parameter (main model = REGRIDDING_COORDINATE_UNITS) + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_UNITS", coord_units, & + "Units of the regridding coordinate.", default=coordinateUnits(coord_mode)) + else + coord_units=coordinateUnits(coord_mode) + endif + + if (coord_is_state_dependent) then + if (main_parameters) then + param_name = "INTERPOLATION_SCHEME" + string2 = regriddingDefaultInterpScheme + else + param_name = create_coord_param(param_prefix, "INTERP_SCHEME", param_suffix) + string2 = 'PPM_H4' ! Default for diagnostics + endif + call get_param(param_file, mdl, param_name, string, & + "This sets the interpolation scheme to use to "//& + "determine the new grid. These parameters are "//& + "only relevant when REGRIDDING_COORDINATE_MODE is "//& + "set to a function of state. Otherwise, it is not "//& + "used. It can be one of the following schemes: \n"//& + trim(regriddingInterpSchemeDoc), default=trim(string2)) + call set_regrid_params(CS, interp_scheme=string) + + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) + call set_regrid_params(CS, remap_answer_date=remap_answer_date) + call get_param(param_file, mdl, "REGRIDDING_ANSWER_DATE", regrid_answer_date, & + "The vintage of the expressions and order of arithmetic to use for regridding. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=20181231, do_not_log=.not.GV%Boussinesq) ! ### change to default=default_answer_date) + if (.not.GV%Boussinesq) regrid_answer_date = max(regrid_answer_date, 20230701) + call set_regrid_params(CS, regrid_answer_date=regrid_answer_date) + endif + + if (main_parameters .and. coord_is_state_dependent) then + call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", tmpLogical, & + "When defined, a proper high-order reconstruction "//& + "scheme is used within boundary cells rather "//& + "than PCM. E.g., if PPM is used for remapping, a "//& + "PPM reconstruction will also be used within "//& + "boundary cells.", default=regriddingDefaultBoundaryExtrapolation) + call set_regrid_params(CS, boundary_extrapolation=tmpLogical) + else + call set_regrid_params(CS, boundary_extrapolation=.false.) + endif + + ! Read coordinate configuration parameter (main model = ALE_COORDINATE_CONFIG) + if (main_parameters) then + param_name = "ALE_COORDINATE_CONFIG" + coord_res_param = "ALE_RESOLUTION" + string2 = 'UNIFORM' + else + param_name = create_coord_param(param_prefix, "DEF", param_suffix) + coord_res_param = create_coord_param(param_prefix, "RES", param_suffix) + string2 = 'UNIFORM' + if (maximum_depth>3000.) string2='WOA09' ! For convenience + endif + call get_param(param_file, mdl, param_name, string, & + "Determines how to specify the coordinate "//& + "resolution. Valid options are:\n"//& + " PARAM - use the vector-parameter "//trim(coord_res_param)//"\n"//& + " UNIFORM[:N] - uniformly distributed\n"//& + " FILE:string - read from a file. The string specifies\n"//& + " the filename and variable name, separated\n"//& + " by a comma or space, e.g. FILE:lev.nc,dz\n"//& + " or FILE:lev.nc,interfaces=zw\n"//& + " WOA09[:N] - the WOA09 vertical grid (approximately)\n"//& + " FNC1:string - FNC1:dz_min,H_total,power,precision\n"//& + " HYBRID:string - read from a file. The string specifies\n"//& + " the filename and two variable names, separated\n"//& + " by a comma or space, for sigma-2 and dz. e.g.\n"//& + " HYBRID:vgrid.nc,sigma2,dz",& + default=trim(string2)) + message = "The distribution of vertical resolution for the target\n"//& + "grid used for Eulerian-like coordinates. For example,\n"//& + "in z-coordinate mode, the parameter is a list of level\n"//& + "thicknesses (in m). In sigma-coordinate mode, the list\n"//& + "is of non-dimensional fractions of the water column." + if (index(trim(string),'UNIFORM')==1) then + if (len_trim(string)==7) then + ke = GV%ke ! Use model nk by default + tmpReal = maximum_depth + elseif (index(trim(string),'UNIFORM:')==1 .and. len_trim(string)>8) then + ! Format is "UNIFORM:N" or "UNIFORM:N,dz" + ke = extract_integer(string(9:len_trim(string)),'',1) + tmpReal = extract_real(string(9:len_trim(string)),',',2,missing_value=maximum_depth) + else + call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'Unable to interpret "'//trim(string)//'".') + endif + allocate(dz(ke)) + dz(:) = uniformResolution(ke, coord_mode, tmpReal, & + US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(min(2,ke)))), & + US%R_to_kg_m3*(GV%Rlay(ke) + 0.5*(GV%Rlay(ke)-GV%Rlay(max(ke-1,1)))) ) + if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, & + trim(message), units=trim(coord_units)) + elseif (trim(string)=='PARAM') then + ! Read coordinate resolution (main model = ALE_RESOLUTION) + ke = GV%ke ! Use model nk by default + allocate(dz(ke)) + call get_param(param_file, mdl, coord_res_param, dz, & + trim(message), units=trim(coord_units), fail_if_missing=.true.) + elseif (index(trim(string),'FILE:')==1) then + ! FILE:filename,var_name is assumed to be reading level thickness variables + ! FILE:filename,interfaces=var_name reads positions + if (string(6:6)=='.' .or. string(6:6)=='/') then + ! If we specified "FILE:./xyz" or "FILE:/xyz" then we have a relative or absolute path + fileName = trim( extractWord(trim(string(6:80)), 1) ) + else + ! Otherwise assume we should look for the file in INPUTDIR + fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) ) + endif + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + + varName = trim( extractWord(trim(string(6:)), 2) ) + if (len_trim(varName)==0) then + if (field_exists(fileName,'dz')) then; varName = 'dz' + elseif (field_exists(fileName,'dsigma')) then; varName = 'dsigma' + elseif (field_exists(fileName,'ztest')) then; varName = 'ztest' + else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "Coordinate variable not specified and none could be guessed.") + endif + endif + ! This check fails when the variable is a dimension variable! -AJA + !if (.not. field_exists(fileName,trim(varName))) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + ! "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + if (CS%regridding_scheme == REGRIDDING_SIGMA) then + expected_units = 'nondim' ; alt_units = expected_units + elseif (CS%regridding_scheme == REGRIDDING_RHO) then + expected_units = 'kg m-3' ; alt_units = expected_units + else + expected_units = 'meters' ; alt_units = 'm' + endif + if (index(trim(varName),'interfaces=')==1) then + varName=trim(varName(12:)) + call verify_variable_units(filename, varName, expected_units, message, ierr, alt_units) + if (ierr) call MOM_error(FATAL, trim(mdl)//", initialize_regridding: "//& + "Unsupported format in grid definition '"//trim(filename)//"'. Error message "//trim(message)) + call field_size(trim(fileName), trim(varName), nzf) + ke = nzf(1)-1 + if (ke < 1) call MOM_error(FATAL, trim(mdl)//" initialize_regridding via Var "//trim(varName)//& + "in FILE "//trim(filename)//" requires at least 2 target interface values.") + if (CS%regridding_scheme == REGRIDDING_RHO) then + allocate(rho_target(ke+1)) + call MOM_read_data(trim(fileName), trim(varName), rho_target) + else + allocate(dz(ke)) + allocate(z_max(ke+1)) + call MOM_read_data(trim(fileName), trim(varName), z_max) + dz(:) = abs(z_max(1:ke) - z_max(2:ke+1)) + deallocate(z_max) + endif + else + ! Assume reading resolution + call field_size(trim(fileName), trim(varName), nzf) + ke = nzf(1) + allocate(dz(ke)) + call MOM_read_data(trim(fileName), trim(varName), dz) + endif + if (main_parameters .and. (ke/=GV%ke)) then + call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'Mismatch in number of model levels and "'//trim(string)//'".') + endif + if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, & + trim(message), units=coordinateUnits(coord_mode)) + elseif (index(trim(string),'FNC1:')==1) then + ke = GV%ke; allocate(dz(ke)) + call dz_function1( trim(string(6:)), dz ) + if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, & + trim(message), units=coordinateUnits(coord_mode)) + elseif (index(trim(string),'RFNC1:')==1) then + ! Function used for set target interface densities + ke = rho_function1( trim(string(7:)), rho_target ) + elseif (index(trim(string),'HYBRID:')==1) then + ke = GV%ke; allocate(dz(ke)) + ! The following assumes the FILE: syntax of above but without "FILE:" in the string + allocate(rho_target(ke+1)) + fileName = trim( extractWord(trim(string(8:)), 1) ) + if (fileName(1:1)/='.' .and. filename(1:1)/='/') fileName = trim(inputdir) // trim( fileName ) + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + varName = trim( extractWord(trim(string(8:)), 2) ) + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + call MOM_read_data(trim(fileName), trim(varName), rho_target) + varName = trim( extractWord(trim(string(8:)), 3) ) + if (varName(1:5) == 'FNC1:') then ! Use FNC1 to calculate dz + call dz_function1( trim(string((index(trim(string),'FNC1:')+5):)), dz ) + else ! Read dz from file + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + call MOM_read_data(trim(fileName), trim(varName), dz) + endif + if (main_parameters) then + call log_param(param_file, mdl, "!"//coord_res_param, dz, & + trim(message), units=coordinateUnits(coord_mode)) + call log_param(param_file, mdl, "!TARGET_DENSITIES", rho_target, & + 'HYBRID target densities for interfaces', units=coordinateUnits(coord_mode)) + endif + elseif (index(trim(string),'WOA09')==1) then + if (len_trim(string)==5) then + tmpReal = 0. ; ke = 0 + do while (tmpReal40 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'For "WOA05:N" N must 0 maximum_depth) then + if ( dz(ke) + ( maximum_depth - tmpReal ) > 0. ) then + dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) + else + call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "MAXIMUM_DEPTH was too shallow to adjust bottom layer of DZ!"//trim(string)) + endif + endif + endif + endif + + CS%nk=ke + + ! Target resolution (for fixed coordinates) + allocate( CS%coordinateResolution(CS%nk), source=-1.E30 ) + if (state_dependent(CS%regridding_scheme)) then + ! Target values + allocate( CS%target_density(CS%nk+1), source=-1.E30*US%kg_m3_to_R ) + endif + + if (allocated(dz)) then + if (coordinateMode(coord_mode) == REGRIDDING_SIGMA) then + call setCoordinateResolution(dz, CS, scale=1.0) + elseif (coordinateMode(coord_mode) == REGRIDDING_RHO) then + call setCoordinateResolution(dz, CS, scale=US%kg_m3_to_R) + elseif (coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then + call setCoordinateResolution(dz, CS, scale=GV%m_to_H) + CS%coord_scale = GV%H_to_m + else + call setCoordinateResolution(dz, CS, scale=US%m_to_Z) + CS%coord_scale = US%Z_to_m + endif + endif + + ! set coord_scale for RHO regridding independent of allocation status of dz + if (coordinateMode(coord_mode) == REGRIDDING_RHO) then + CS%coord_scale = US%R_to_kg_m3 + endif + + ! ensure CS%ref_pressure is rescaled properly + CS%ref_pressure = US%Pa_to_RL2_T2 * CS%ref_pressure + + if (allocated(rho_target)) then + call set_target_densities(CS, US%kg_m3_to_R*rho_target) + deallocate(rho_target) + + ! \todo This line looks like it would overwrite the target densities set just above? + elseif (coordinateMode(coord_mode) == REGRIDDING_RHO) then + call set_target_densities_from_GV(GV, US, CS) + call log_param(param_file, mdl, "!TARGET_DENSITIES", US%R_to_kg_m3*CS%target_density(:), & + 'RHO target densities for interfaces', units=coordinateUnits(coord_mode)) + endif + + ! initialise coordinate-specific control structure + call initCoord(CS, GV, US, coord_mode, param_file) + + if (coord_is_state_dependent) then + if (main_parameters) then + call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), P_Ref, & + "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%Pa_to_RL2_T2) + else + call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), P_Ref, & + "The pressure that is used for calculating the diagnostic coordinate "//& + "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& + "This is only used for the RHO coordinate.", & + units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2) + endif + call get_param(param_file, mdl, create_coord_param(param_prefix, "REGRID_COMPRESSIBILITY_FRACTION", param_suffix), & + tmpReal, & + "When interpolating potential density profiles we can add "//& + "some artificial compressibility solely to make homogeneous "//& + "regions appear stratified.", units="nondim", default=0.) + call set_regrid_params(CS, compress_fraction=tmpReal, ref_pressure=P_Ref) + endif + + if (main_parameters) then + call get_param(param_file, mdl, "MIN_THICKNESS", tmpReal, & + "When regridding, this is the minimum layer "//& + "thickness allowed.", units="m", scale=GV%m_to_H, & + default=regriddingDefaultMinThickness ) + call set_regrid_params(CS, min_thickness=tmpReal) + else + call set_regrid_params(CS, min_thickness=0.) + endif + + if (main_parameters .and. coordinateMode(coord_mode) == REGRIDDING_HYCOM1) then + call get_param(param_file, mdl, "HYCOM1_ONLY_IMPROVES", tmpLogical, & + "When regridding, an interface is only moved if this improves the fit to the target density.", & + default=.false.) + call set_hycom_params(CS%hycom_CS, only_improves=tmpLogical) + 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_ADAPTIVE) then + call get_param(param_file, mdl, "ADAPT_TIME_RATIO", adaptTimeRatio, & + "Ratio of ALE timestep to grid timescale.", units="nondim", default=1.0e-1) + call get_param(param_file, mdl, "ADAPT_ZOOM_DEPTH", adaptZoom, & + "Depth of near-surface zooming region.", units="m", default=200.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "ADAPT_ZOOM_COEFF", adaptZoomCoeff, & + "Coefficient of near-surface zooming diffusivity.", units="nondim", default=0.2) + call get_param(param_file, mdl, "ADAPT_BUOY_COEFF", adaptBuoyCoeff, & + "Coefficient of buoyancy diffusivity.", units="nondim", default=0.8) + call get_param(param_file, mdl, "ADAPT_ALPHA", adaptAlpha, & + "Scaling on optimization tendency.", units="nondim", default=1.0) + call get_param(param_file, mdl, "ADAPT_DO_MIN_DEPTH", tmpLogical, & + "If true, make a HyCOM-like mixed layer by preventing interfaces "//& + "from being shallower than the depths specified by the regridding coordinate.", & + default=.false.) + call get_param(param_file, mdl, "ADAPT_DRHO0", adaptDrho0, & + "Reference density difference for stratification-dependent diffusion.", & + units="kg m-3", default=0.5, scale=US%kg_m3_to_R) + + call set_regrid_params(CS, adaptTimeRatio=adaptTimeRatio, adaptZoom=adaptZoom, & + adaptZoomCoeff=adaptZoomCoeff, adaptBuoyCoeff=adaptBuoyCoeff, adaptAlpha=adaptAlpha, & + adaptDoMin=tmpLogical, adaptDrho0=adaptDrho0) + endif + + if (main_parameters .and. coord_is_state_dependent) then + call get_param(param_file, mdl, "MAXIMUM_INT_DEPTH_CONFIG", string, & + "Determines how to specify the maximum interface depths.\n"//& + "Valid options are:\n"//& + " NONE - there are no maximum interface depths\n"//& + " PARAM - use the vector-parameter MAXIMUM_INTERFACE_DEPTHS\n"//& + " FILE:string - read from a file. The string specifies\n"//& + " the filename and variable name, separated\n"//& + " by a comma or space, e.g. FILE:lev.nc,Z\n"//& + " FNC1:string - FNC1:dz_min,H_total,power,precision",& + default='NONE') + message = "The list of maximum depths for each interface." + allocate(z_max(ke+1)) + allocate(dz_max(ke)) + if ( trim(string) == "NONE") then + ! Do nothing. + elseif ( trim(string) == "PARAM") then + call get_param(param_file, mdl, "MAXIMUM_INTERFACE_DEPTHS", z_max, & + trim(message), units="m", scale=GV%m_to_H, fail_if_missing=.true.) + call set_regrid_max_depths(CS, z_max) + elseif (index(trim(string),'FILE:')==1) then + if (string(6:6)=='.' .or. string(6:6)=='/') then + ! If we specified "FILE:./xyz" or "FILE:/xyz" then we have a relative or absolute path + fileName = trim( extractWord(trim(string(6:80)), 1) ) + else + ! Otherwise assume we should look for the file in INPUTDIR + fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) ) + endif + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + + do_sum = .false. + varName = trim( extractWord(trim(string(6:)), 2) ) + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + if (len_trim(varName)==0) then + if (field_exists(fileName,'z_max')) then; varName = 'z_max' + elseif (field_exists(fileName,'dz')) then; varName = 'dz' ; do_sum = .true. + elseif (field_exists(fileName,'dz_max')) then; varName = 'dz_max' ; do_sum = .true. + else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.") + endif + endif + if (do_sum) then + call MOM_read_data(trim(fileName), trim(varName), dz_max) + z_max(1) = 0.0 ; do K=1,ke ; z_max(K+1) = z_max(K) + dz_max(k) ; enddo + else + call MOM_read_data(trim(fileName), trim(varName), z_max) + endif + call log_param(param_file, mdl, "!MAXIMUM_INT_DEPTHS", z_max, & + trim(message), units=coordinateUnits(coord_mode)) + call set_regrid_max_depths(CS, z_max, GV%m_to_H) + elseif (index(trim(string),'FNC1:')==1) then + call dz_function1( trim(string(6:)), dz_max ) + z_max(1) = 0.0 ; do K=1,ke ; z_max(K+1) = z_max(K) + dz_max(K) ; enddo + call log_param(param_file, mdl, "!MAXIMUM_INT_DEPTHS", z_max, & + trim(message), units=coordinateUnits(coord_mode)) + call set_regrid_max_depths(CS, z_max, GV%m_to_H) + else + call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "Unrecognized MAXIMUM_INT_DEPTH_CONFIG "//trim(string)) + endif + deallocate(z_max) + deallocate(dz_max) + + ! Optionally specify maximum thicknesses for each layer, enforced by moving + ! the interface below a layer downward. + call get_param(param_file, mdl, "MAX_LAYER_THICKNESS_CONFIG", string, & + "Determines how to specify the maximum layer thicknesses.\n"//& + "Valid options are:\n"//& + " NONE - there are no maximum layer thicknesses\n"//& + " PARAM - use the vector-parameter MAX_LAYER_THICKNESS\n"//& + " FILE:string - read from a file. The string specifies\n"//& + " the filename and variable name, separated\n"//& + " by a comma or space, e.g. FILE:lev.nc,Z\n"//& + " FNC1:string - FNC1:dz_min,H_total,power,precision",& + default='NONE') + message = "The list of maximum thickness for each layer." + allocate(h_max(ke)) + if ( trim(string) == "NONE") then + ! Do nothing. + elseif ( trim(string) == "PARAM") then + call get_param(param_file, mdl, "MAX_LAYER_THICKNESS", h_max, & + trim(message), units="m", fail_if_missing=.true., scale=GV%m_to_H) + call set_regrid_max_thickness(CS, h_max) + elseif (index(trim(string),'FILE:')==1) then + if (string(6:6)=='.' .or. string(6:6)=='/') then + ! If we specified "FILE:./xyz" or "FILE:/xyz" then we have a relative or absolute path + fileName = trim( extractWord(trim(string(6:80)), 1) ) + else + ! Otherwise assume we should look for the file in INPUTDIR + fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) ) + endif + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + + varName = trim( extractWord(trim(string(6:)), 2) ) + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + if (len_trim(varName)==0) then + if (field_exists(fileName,'h_max')) then; varName = 'h_max' + elseif (field_exists(fileName,'dz_max')) then; varName = 'dz_max' + else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.") + endif + endif + call MOM_read_data(trim(fileName), trim(varName), h_max) + call log_param(param_file, mdl, "!MAX_LAYER_THICKNESS", h_max, & + trim(message), units=coordinateUnits(coord_mode)) + call set_regrid_max_thickness(CS, h_max, GV%m_to_H) + elseif (index(trim(string),'FNC1:')==1) then + call dz_function1( trim(string(6:)), h_max ) + call log_param(param_file, mdl, "!MAX_LAYER_THICKNESS", h_max, & + trim(message), units=coordinateUnits(coord_mode)) + call set_regrid_max_thickness(CS, h_max, GV%m_to_H) + else + call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "Unrecognized MAX_LAYER_THICKNESS_CONFIG "//trim(string)) + endif + deallocate(h_max) + endif + + if (allocated(dz)) deallocate(dz) +end subroutine initialize_regridding + + + +!> Deallocation of regridding memory +subroutine end_regridding(CS) + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + + if (associated(CS%zlike_CS)) call end_coord_zlike(CS%zlike_CS) + if (associated(CS%sigma_CS)) call end_coord_sigma(CS%sigma_CS) + if (associated(CS%rho_CS)) call end_coord_rho(CS%rho_CS) + if (associated(CS%hycom_CS)) call end_coord_hycom(CS%hycom_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 ) + if (allocated(CS%max_interface_depths) ) deallocate( CS%max_interface_depths ) + if (allocated(CS%max_layer_thickness) ) deallocate( CS%max_layer_thickness ) + +end subroutine end_regridding + +!------------------------------------------------------------------------------ +!> Dispatching regridding routine for orchestrating regridding & remapping +subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, & + frac_shelf_h, PCM_cell) +!------------------------------------------------------------------------------ +! This routine takes care of (1) building a new grid and (2) remapping between +! the old grid and the new grid. The creation of the new grid can be based +! on z coordinates, target interface densities, sigma coordinates or any +! arbitrary coordinate system. +! The MOM6 interface positions are always calculated from the bottom up by +! accumulating the layer thicknesses starting at z=-G%bathyT. z increases +! upwards (decreasing k-index). +! The new grid is defined by the change in position of those interfaces in z +! dzInterface = zNew - zOld. +! Thus, if the regridding inflates the top layer, hNew(1) > hOld(1), then the +! second interface moves downward, zNew(2) < zOld(2), and dzInterface(2) < 0. +! hNew(k) = hOld(k) - dzInterface(k+1) + dzInterface(k) +! IMPORTANT NOTE: +! This is the converse of the sign convention used in the remapping code! +!------------------------------------------------------------------------------ + + ! Arguments + type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Current 3D grid obtained after + !! the last time step [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamical variables (T, S, ...) + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target + !! coordinate [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in position of each + !! interface [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage [nomdim] + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out ) :: PCM_cell !< Use PCM remapping in cells where true + + ! Local variables + real :: nom_depth_H(SZI_(G),SZJ_(G)) !< The nominal ocean depth at each point in thickness units [H ~> m or kg m-2] + real :: tot_h(SZI_(G),SZJ_(G)) !< The total thickness of the water column [H ~> m or kg m-2] + real :: tot_dz(SZI_(G),SZJ_(G)) !< The total distance between the top and bottom of the water column [Z ~> m] + real :: Z_to_H ! A conversion factor used by some routines to convert coordinate + ! parameters to depth units [H Z-1 ~> nondim or kg m-3] + character(len=128) :: mesg ! A string for error messages + integer :: i, j, k + + if (present(PCM_cell)) PCM_cell(:,:,:) = .false. + + Z_to_H = US%Z_to_m * GV%m_to_H ! Often this is equivalent to GV%Z_to_H. + + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < 1)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + mesg = "insufficiently large SpV_avg halos of width 0 but 1 is needed." + endif + call MOM_error(FATAL, "Regridding_main called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + if (allocated(tv%SpV_avg)) then ! This is the fully non-Boussinesq case + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + tot_h(i,j) = 0.0 ; tot_dz(i,j) = 0.0 + enddo ; enddo + do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + tot_h(i,j) = tot_h(i,j) + h(i,j,k) + tot_dz(i,j) = tot_dz(i,j) + GV%H_to_RZ * tv%SpV_avg(i,j,k) * h(i,j,k) + enddo ; enddo ; enddo + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + if ((tot_dz(i,j) > 0.0) .and. (G%bathyT(i,j)+G%Z_ref > 0.0)) then + nom_depth_H(i,j) = (G%bathyT(i,j)+G%Z_ref) * (tot_h(i,j) / tot_dz(i,j)) + else + nom_depth_H(i,j) = 0.0 + endif + enddo ; enddo + else + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + nom_depth_H(i,j) = max((G%bathyT(i,j)+G%Z_ref) * Z_to_H, 0.0) + enddo ; enddo + endif + + select case ( CS%regridding_scheme ) + + case ( REGRIDDING_ZSTAR ) + call build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, frac_shelf_h, zScale=Z_to_H ) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) + case ( REGRIDDING_SIGMA_SHELF_ZSTAR) + call build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, zScale=Z_to_H ) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) + case ( REGRIDDING_SIGMA ) + call build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface ) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) + case ( REGRIDDING_RHO ) + call build_rho_grid( G, GV, G%US, h, nom_depth_H, tv, dzInterface, remapCS, CS, frac_shelf_h ) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) + case ( REGRIDDING_HYCOM1 ) + call build_grid_HyCOM1( G, GV, G%US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, & + frac_shelf_h, zScale=Z_to_H ) + case ( REGRIDDING_HYBGEN ) + call hybgen_regrid(G, GV, G%US, h, nom_depth_H, tv, CS%hybgen_CS, dzInterface, PCM_cell) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) + case ( REGRIDDING_ADAPTIVE ) + call build_grid_adaptive(G, GV, G%US, h, nom_depth_H, tv, dzInterface, remapCS, CS) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) + + case ( REGRIDDING_ARBITRARY ) + call MOM_error(FATAL,'MOM_regridding, regridding_main: '//& + 'Regridding mode "ARB" is not implemented.') + case default + call MOM_error(FATAL,'MOM_regridding, regridding_main: '//& + 'Unknown regridding scheme selected!') + + end select ! type of grid + +#ifdef __DO_SAFETY_CHECKS__ + if (CS%nk == GV%ke) then + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 ; if (G%mask2dT(i,j)>0.) then + call check_grid_column( GV%ke, h(i,j,:), dzInterface(i,j,:), 'in regridding_main') + endif ; enddo ; enddo + endif +#endif + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (G%mask2dT(i,j) > 0.) then + if (minval(h(i,j,:)) < 0.0) then + write(0,*) 'regridding_main check_grid: i,j=', i, j, 'h_new(i,j,:)=', h_new(i,j,:) + call MOM_error(FATAL, "regridding_main: negative thickness encountered.") + endif + endif ; enddo ; enddo + +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_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 + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Old layer thicknesses [H ~> m or kg m-2] + !! or other units + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: dzInterface !< Change in interface positions + !! in the same units as h [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses in the same + !! units as h [H ~> m or kg m-2] + ! Local variables + integer :: i, j, k, nki + + nki = min(CS%nk, GV%ke) + + !$OMP parallel do default(shared) + do j = G%jsc-1,G%jec+1 + do i = G%isc-1,G%iec+1 + if (G%mask2dT(i,j)>0.) then + do k=1,nki + h_new(i,j,k) = max( 0., h(i,j,k) + ( dzInterface(i,j,k) - dzInterface(i,j,k+1) ) ) + enddo + if (CS%nk > GV%ke) then + do k=nki+1, CS%nk + h_new(i,j,k) = max( 0., dzInterface(i,j,k) - dzInterface(i,j,k+1) ) + enddo + endif + else + h_new(i,j,1:nki) = h(i,j,1:nki) + if (CS%nk > GV%ke) h_new(i,j,nki+1:CS%nk) = 0. + ! On land points, why are we keeping the original h rather than setting to zero? -AJA + endif + enddo + enddo + +end subroutine calc_h_new_by_dz + + +!> Check that the total thickness of new and old grids are consistent +subroutine check_grid_column( nk, h, dzInterface, msg ) + integer, intent(in) :: nk !< Number of cells + real, dimension(nk), intent(in) :: h !< Cell thicknesses [Z ~> m] or arbitrary units + real, dimension(nk+1), intent(in) :: dzInterface !< Change in interface positions (same units as h), often [Z ~> m] + character(len=*), intent(in) :: msg !< Message to append to errors + ! Local variables + integer :: k + real :: eps ! A tiny relative thickness [nondim] + real :: total_h_old ! The total thickness in the old column, in [Z ~> m] or arbitrary units + real :: total_h_new ! The total thickness in the updated column, in [Z ~> m] or arbitrary units + real :: h_new ! A thickness in the updated column, in [Z ~> m] or arbitrary units + + eps =1. ; eps = epsilon(eps) + + ! Total thickness of grid h + total_h_old = 0. + do k = 1,nk + total_h_old = total_h_old + h(k) + enddo + + total_h_new = 0. + do k = nk,1,-1 + h_new = h(k) + ( dzInterface(k) - dzInterface(k+1) ) ! New thickness + if (h_new<0.) then + write(0,*) 'k,h,hnew=',k,h(k),h_new + write(0,*) 'dzI(k+1),dzI(k)=',dzInterface(k+1),dzInterface(k) + call MOM_error( FATAL, 'MOM_regridding, check_grid_column: '//& + 'Negative layer thickness implied by re-gridding, '//trim(msg)) + endif + total_h_new = total_h_new + h_new + + enddo + + ! Conservation by implied h_new + if (abs(total_h_new-total_h_old)>real(nk-1)*0.5*(total_h_old+total_h_new)*eps) then + write(0,*) 'nk=',nk + do k = 1,nk + write(0,*) 'k,h,hnew=',k,h(k),h(k)+(dzInterface(k)-dzInterface(k+1)) + enddo + write(0,*) 'Hold,Hnew,Hnew-Hold=',total_h_old,total_h_new,total_h_new-total_h_old + write(0,*) 'eps,(n)/2*eps*H=',eps,real(nk-1)*0.5*(total_h_old+total_h_new)*eps + call MOM_error( FATAL, 'MOM_regridding, check_grid_column: '//& + 'Re-gridding did NOT conserve total thickness to within roundoff '//trim(msg)) + endif + + ! Check that the top and bottom are intentionally moving + if (dzInterface(1) /= 0.) call MOM_error( FATAL, & + 'MOM_regridding, check_grid_column: Non-zero dzInterface at surface! '//trim(msg)) + if (dzInterface(nk+1) /= 0.) call MOM_error( FATAL, & + 'MOM_regridding, check_grid_column: Non-zero dzInterface at bottom! '//trim(msg)) + +end subroutine check_grid_column + +!> Returns the change in interface position motion after filtering and +!! assuming the top and bottom interfaces do not move. The filtering is +!! a function of depth, and is applied as the integrated average filtering +!! over the trajectory of the interface. By design, this code can not give +!! tangled interfaces provided that z_old and z_new are not already tangled. +subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + integer, intent(in) :: nk !< Number of cells in source grid + real, dimension(nk+1), intent(in) :: z_old !< Old grid position [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(in) :: z_new !< New grid position before filtering [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(inout) :: dz_g !< Change in interface positions including + !! the effects of filtering [H ~> m or kg m-2] + ! Local variables + real :: sgn ! The sign convention for downward [nondim]. + real :: dz_tgt ! The target grid movement of the unfiltered grid [H ~> m or kg m-2] + real :: zr1 ! The old grid position of an interface relative to the surface [H ~> m or kg m-2] + real :: z_old_k ! The corrected position of the old grid [H ~> m or kg m-2] + real :: Aq ! A temporary variable related to the grid weights [nondim] + real :: Bq ! A temporary variable used in the linear term in the quadratic expression for the + ! filtered grid movement [H ~> m or kg m-2] + real :: z0, dz0 ! Together these give the position of an interface relative to a reference hieght + ! that may be adjusted for numerical accuracy in a solver [H ~> m or kg m-2] + real :: F0 ! An estimated grid movement [H ~> m or kg m-2] + real :: zs ! The depth at which the shallow filtering timescale applies [H ~> m or kg m-2] + real :: zd ! The depth at which the deep filtering timescale applies [H ~> m or kg m-2] + real :: dzwt ! The depth range over which the transition in the filtering timescale occurs [H ~> m or kg m-2] + real :: Idzwt ! The Adcroft reciprocal of dzwt [H-1 ~> m-1 or m2 kg-1] + real :: wtd ! The weight given to the new grid when time filtering [nondim] + real :: Iwtd ! The inverse of wtd [nondim] + real :: Int_zs ! A depth integral of the weights in [H ~> m or kg m-2] + real :: Int_zd ! A depth integral of the weights in [H ~> m or kg m-2] + real :: dInt_zs_zd ! The depth integral of the weights between the deep and shallow depths in [H ~> m or kg m-2] +! For debugging: + real, dimension(nk+1) :: z_act ! The final grid positions after the filtered movement [H ~> m or kg m-2] +! real, dimension(nk+1) :: ddz_g_s, ddz_g_d + logical :: debug = .false. + integer :: k + + if ((z_old(nk+1) - z_old(1)) * (z_new(CS%nk+1) - z_new(1)) < 0.0) then + call MOM_error(FATAL, "filtered_grid_motion: z_old and z_new use different sign conventions.") + elseif ((z_old(nk+1) - z_old(1)) * (z_new(CS%nk+1) - z_new(1)) == 0.0) then + ! This is a massless column, so do nothing and return. + do k=1,CS%nk+1 ; dz_g(k) = 0.0 ; enddo ; return + elseif ((z_old(nk+1) - z_old(1)) + (z_new(CS%nk+1) - z_new(1)) > 0.0) then + sgn = 1.0 + else + sgn = -1.0 + endif + + if (debug) then + do k=2,CS%nk+1 + if (sgn*(z_new(k)-z_new(k-1)) < -5e-16*(abs(z_new(k))+abs(z_new(k-1))) ) & + call MOM_error(FATAL, "filtered_grid_motion: z_new is tangled.") + enddo + do k=2,nk+1 + if (sgn*(z_old(k)-z_old(k-1)) < -5e-16*(abs(z_old(k))+abs(z_old(k-1))) ) & + call MOM_error(FATAL, "filtered_grid_motion: z_old is tangled.") + enddo + ! ddz_g_s(:) = 0.0 ; ddz_g_d(:) = 0.0 + endif + + zs = CS%depth_of_time_filter_shallow + zd = CS%depth_of_time_filter_deep + wtd = 1.0 - CS%old_grid_weight + Iwtd = 1.0 / wtd + + dzwt = (zd - zs) + Idzwt = 0.0 ; if (abs(zd - zs) > 0.0) Idzwt = 1.0 / (zd - zs) + dInt_zs_zd = 0.5*(1.0 + Iwtd) * (zd - zs) + Aq = 0.5*(Iwtd - 1.0) + + dz_g(1) = 0.0 + z_old_k = z_old(1) + do k = 2,CS%nk+1 + if (k<=nk+1) z_old_k = z_old(k) ! This allows for virtual z_old interface at bottom of the model + ! zr1 is positive and increases with depth, and dz_tgt is positive downward. + dz_tgt = sgn*(z_new(k) - z_old_k) + zr1 = sgn*(z_old_k - z_old(1)) + + ! First, handle the two simple and common cases that do not pass through + ! the adjustment rate transition zone. + if ((zr1 > zd) .and. (zr1 + wtd * dz_tgt > zd)) then + dz_g(k) = sgn * wtd * dz_tgt + elseif ((zr1 < zs) .and. (zr1 + dz_tgt < zs)) then + dz_g(k) = sgn * dz_tgt + else + ! Find the new value by inverting the equation + ! integral(0 to dz_new) Iwt(z) dz = dz_tgt + ! This is trivial where Iwt is a constant, and agrees with the two limits above. + + ! Take test values at the transition points to figure out which segment + ! the new value will be found in. + if (zr1 >= zd) then + Int_zd = Iwtd*(zd - zr1) + Int_zs = Int_zd - dInt_zs_zd + elseif (zr1 <= zs) then + Int_zs = (zs - zr1) + Int_zd = dInt_zs_zd + (zs - zr1) + else +! Int_zd = (zd - zr1) * (Iwtd + 0.5*(1.0 - Iwtd) * (zd - zr1) / (zd - zs)) + Int_zd = (zd - zr1) * (Iwtd*(0.5*(zd+zr1) - zs) + 0.5*(zd - zr1)) * Idzwt + Int_zs = (zs - zr1) * (0.5*Iwtd * ((zr1 - zs)) + (zd - 0.5*(zr1+zs))) * Idzwt + ! It has been verified that Int_zs = Int_zd - dInt_zs_zd to within roundoff. + endif + + if (dz_tgt >= Int_zd) then ! The new location is in the deep, slow region. + dz_g(k) = sgn * ((zd-zr1) + wtd*(dz_tgt - Int_zd)) + elseif (dz_tgt <= Int_zs) then ! The new location is in the shallow region. + dz_g(k) = sgn * ((zs-zr1) + (dz_tgt - Int_zs)) + else ! We need to solve a quadratic equation for z_new. + ! For accuracy, do the integral from the starting depth or the nearest + ! edge of the transition region. The results with each choice are + ! mathematically equivalent, but differ in roundoff, and this choice + ! should minimize the likelihood of inadvertently overlapping interfaces. + if (zr1 <= zs) then ; dz0 = zs-zr1 ; z0 = zs ; F0 = dz_tgt - Int_zs + elseif (zr1 >= zd) then ; dz0 = zd-zr1 ; z0 = zd ; F0 = dz_tgt - Int_zd + else ; dz0 = 0.0 ; z0 = zr1 ; F0 = dz_tgt ; endif + + Bq = (dzwt + 2.0*Aq*(z0-zs)) + ! Solve the quadratic: Aq*(zn-z0)**2 + Bq*(zn-z0) - F0*dzwt = 0 + ! Note that b>=0, and the two terms in the standard form cancel for the right root. + dz_g(k) = sgn * (dz0 + 2.0*F0*dzwt / (Bq + sqrt(Bq**2 + 4.0*Aq*F0*dzwt) )) + +! if (debug) then +! dz0 = zs-zr1 ; z0 = zs ; F0 = dz_tgt - Int_zs ; Bq = (dzwt + 2.0*Aq*(z0-zs)) +! ddz_g_s(k) = sgn * (dz0 + 2.0*F0*dzwt / (Bq + sqrt(Bq**2 + 4.0*Aq*F0*dzwt) )) - dz_g(k) +! dz0 = zd-zr1 ; z0 = zd ; F0 = dz_tgt - Int_zd ; Bq = (dzwt + 2.0*Aq*(z0-zs)) +! ddz_g_d(k) = sgn * (dz0 + 2.0*F0*dzwt / (Bq + sqrt(Bq**2 + 4.0*Aq*F0*dzwt) )) - dz_g(k) +! +! if (abs(ddz_g_s(k)) > 1e-12*(abs(dz_g(k)) + abs(dz_g(k)+ddz_g_s(k)))) & +! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled (sc).") +! if (abs(ddz_g_d(k) - ddz_g_s(k)) > 1e-12*(abs(dz_g(k)+ddz_g_d(k)) + abs(dz_g(k)+ddz_g_s(k)))) & +! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled.") +! endif + endif + + endif + enddo + !dz_g(CS%nk+1) = 0.0 + + if (debug) then + z_old_k = z_old(1) + do k=1,CS%nk+1 + if (k<=nk+1) z_old_k = z_old(k) ! This allows for virtual z_old interface at bottom of the model + z_act(k) = z_old_k + dz_g(k) + enddo + do k=2,CS%nk+1 + if (sgn*((z_act(k))-z_act(k-1)) < -1e-15*(abs(z_act(k))+abs(z_act(k-1))) ) & + call MOM_error(FATAL, "filtered_grid_motion: z_output is tangled.") + enddo + endif + +end subroutine filtered_grid_motion + +!> Builds a z*-coordinate grid with partial steps (Adcroft and Campin, 2004). +!! z* is defined as +!! z* = (z-eta)/(H+eta)*H s.t. z*=0 when z=eta and z*=-H when z=-H . +subroutine build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, frac_shelf_h, zScale) + + ! Arguments + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: frac_shelf_h !< Fractional + !! ice shelf coverage [nondim]. + real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate + !! resolution in Z to desired units for zInterface, + !! usually Z_to_H in which case it is in + !! units of [H Z-1 ~> nondim or kg m-3] + ! Local variables + real :: nominalDepth, minThickness, totalThickness ! Depths and thicknesses [H ~> m or kg m-2] +#ifdef __DO_SAFETY_CHECKS__ + real :: dh ! The larger of the total column thickness or bathymetric depth [H ~> m or kg m-2] +#endif + real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] + integer :: i, j, k, nz + logical :: ice_shelf + + nz = GV%ke + minThickness = CS%min_thickness + ice_shelf = present(frac_shelf_h) + + !$OMP parallel do default(none) shared(G,GV,dzInterface,CS,nz,h,frac_shelf_h, & + !$OMP ice_shelf,minThickness,zScale,nom_depth_H) & + !$OMP private(nominalDepth,totalThickness, & +#ifdef __DO_SAFETY_CHECKS__ + !$OMP dh, & +#endif + !$OMP zNew,zOld) + do j = G%jsc-1,G%jec+1 + do i = G%isc-1,G%iec+1 + + if (G%mask2dT(i,j)==0.) then + dzInterface(i,j,:) = 0. + cycle + endif + + ! Local depth (positive downward) + nominalDepth = nom_depth_H(i,j) + + ! Determine water column thickness + totalThickness = 0.0 + do k = 1,nz + totalThickness = totalThickness + h(i,j,k) + enddo + + ! if (GV%Boussinesq) then + zOld(nz+1) = - nominalDepth + do k = nz,1,-1 + zOld(k) = zOld(k+1) + h(i,j,k) + enddo + ! else ! Work downward? + ! endif + + if (ice_shelf) then + if (frac_shelf_h(i,j) > 0.) then ! under ice shelf + call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, zNew, & + z_rigid_top=totalThickness-nominalDepth, & + eta_orig=zOld(1), zScale=zScale) + else + call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, & + zNew, zScale=zScale) + endif + else + call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, & + zNew, zScale=zScale) + endif + + ! Calculate the final change in grid position after blending new and old grids + call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) + +#ifdef __DO_SAFETY_CHECKS__ + dh = max(nominalDepth,totalThickness) + if (abs(zNew(1)-zOld(1)) > (nz-1)*0.5*epsilon(dh)*dh) then + write(0,*) 'min_thickness=',CS%min_thickness + write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness + write(0,*) 'dzInterface(1) = ', dzInterface(i,j,1), epsilon(dh), nz, CS%nk + do k=1,min(nz,CS%nk)+1 + write(0,*) k,zOld(k),zNew(k) + enddo + do k=min(nz,CS%nk)+2,CS%nk+1 + write(0,*) k,zOld(nz+1),zNew(k) + enddo + do k=1,min(nz,CS%nk) + write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),CS%coordinateResolution(k) + enddo + do k=min(nz,CS%nk)+1,CS%nk + write(0,*) k, 0.0, zNew(k)-zNew(k+1), CS%coordinateResolution(k) + enddo + call MOM_error( FATAL, & + 'MOM_regridding, build_zstar_grid(): top surface has moved!!!' ) + endif +#endif + + call adjust_interface_motion( CS, nz, h(i,j,:), dzInterface(i,j,:) ) + + enddo + enddo + +end subroutine build_zstar_grid + +!------------------------------------------------------------------------------ +! Build sigma grid +!> This routine builds a grid based on terrain-following coordinates. +subroutine build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface ) +!------------------------------------------------------------------------------ +! This routine builds a grid based on terrain-following coordinates. +! The module parameter coordinateResolution(:) determines the resolution in +! sigma coordinate, dSigma(:). sigma-coordinates are defined by +! sigma = (eta-z)/(H+eta) s.t. sigma=0 at z=eta and sigma=1 at z=-H . +!------------------------------------------------------------------------------ + + ! Arguments + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + !! [H ~> m or kg m-2] + + ! Local variables + real :: nominalDepth ! The nominal depth of the sea-floor in thickness units [H ~> m or kg m-2] + real :: totalThickness ! The total thickness of the water column [H ~> m or kg m-2] +#ifdef __DO_SAFETY_CHECKS__ + real :: dh ! The larger of the total column thickness or bathymetric depth [H ~> m or kg m-2] +#endif + real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] + integer :: i, j, k, nz + + nz = GV%ke + + do i = G%isc-1,G%iec+1 + do j = G%jsc-1,G%jec+1 + + if (G%mask2dT(i,j)==0.) then + dzInterface(i,j,:) = 0. + cycle + endif + + ! Determine water column height + totalThickness = 0.0 + do k = 1,nz + totalThickness = totalThickness + h(i,j,k) + enddo + + ! In sigma coordinates, the bathymetric depth is only used as an arbitrary offset that + ! cancels out when determining coordinate motion, so referencing the column postions to + ! the surface is perfectly acceptable, but for preservation of previous answers the + ! referencing is done relative to the bottom when in Boussinesq or semi-Boussinesq mode. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + nominalDepth = nom_depth_H(i,j) + else + nominalDepth = totalThickness + endif + + call build_sigma_column(CS%sigma_CS, nominalDepth, totalThickness, zNew) + + ! Calculate the final change in grid position after blending new and old grids + zOld(nz+1) = -nominalDepth + do k = nz,1,-1 + zOld(k) = zOld(k+1) + h(i,j,k) + enddo + + call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) + +#ifdef __DO_SAFETY_CHECKS__ + dh = max(nominalDepth,totalThickness) + if (abs(zNew(1)-zOld(1)) > (CS%nk-1)*0.5*epsilon(dh)*dh) then + write(0,*) 'min_thickness=',CS%min_thickness + write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness + write(0,*) 'dzInterface(1) = ',dzInterface(i,j,1),epsilon(dh),nz,CS%nk + do k=1,min(nz,CS%nk)+1 + write(0,*) k,zOld(k),zNew(k) + enddo + do k=min(nz,CS%nk)+2,CS%nk+1 + write(0,*) k,zOld(nz+1),zNew(k) + enddo + do k=1,min(nz,CS%nk) + write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k),CS%coordinateResolution(k) + enddo + do k=min(nz,CS%nk)+1,CS%nk + write(0,*) k,0.0,zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k),CS%coordinateResolution(k) + enddo + call MOM_error( FATAL, & + 'MOM_regridding, build_sigma_grid: top surface has moved!!!' ) + endif + dzInterface(i,j,1) = 0. + dzInterface(i,j,CS%nk+1) = 0. +#endif + + enddo + enddo + +end subroutine build_sigma_grid + +!------------------------------------------------------------------------------ +! Build grid based on target interface densities +!------------------------------------------------------------------------------ +!> This routine builds a new grid based on a given set of target interface densities. +subroutine build_rho_grid( G, GV, US, h, nom_depth_H, tv, dzInterface, remapCS, CS, frac_shelf_h ) +!------------------------------------------------------------------------------ +! This routine builds a new grid based on a given set of target interface +! densities (these target densities are computed by taking the mean value +! of given layer densities). The algorithm operates as follows within each +! column: +! 1. Given T & S within each layer, the layer densities are computed. +! 2. Based on these layer densities, a global density profile is reconstructed +! (this profile is monotonically increasing and may be discontinuous) +! 3. The new grid interfaces are determined based on the target interface +! densities. +! 4. T & S are remapped onto the new grid. +! 5. Return to step 1 until convergence or until the maximum number of +! iterations is reached, whichever comes first. +!------------------------------------------------------------------------------ + + ! Arguments + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + !! [H ~> m or kg m-2] + type(remapping_CS), intent(in) :: remapCS !< The remapping control structure + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice + !! shelf coverage [nondim] + ! Local variables + integer :: nz ! The number of layers in the input grid + integer :: i, j, k + real :: nominalDepth ! Depth of the bottom of the ocean, positive downward [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + real :: totalThickness ! Total thicknesses [H ~> m or kg m-2] +#ifdef __DO_SAFETY_CHECKS__ + real :: dh ! The larger of the total column thickness or bathymetric depth [H ~> m or kg m-2] +#endif + logical :: ice_shelf + + h_neglect = set_h_neglect(GV, CS%remap_answer_date, h_neglect_edge) + + nz = GV%ke + ice_shelf = present(frac_shelf_h) + + if (.not.CS%target_density_set) call MOM_error(FATAL, "build_rho_grid: "//& + "Target densities must be set before build_rho_grid is called.") + + ! Build grid based on target interface densities + do j = G%jsc-1,G%jec+1 + do i = G%isc-1,G%iec+1 + + if (G%mask2dT(i,j)==0.) then + dzInterface(i,j,:) = 0. + cycle + endif + + ! Determine total water column thickness + totalThickness = 0.0 + do k=1,nz + totalThickness = totalThickness + h(i,j,k) + enddo + + ! In rho coordinates, the bathymetric depth is only used as an arbitrary offset that + ! cancels out when determining coordinate motion, so referencing the column postions to + ! the surface is perfectly acceptable, but for preservation of previous answers the + ! referencing is done relative to the bottom when in Boussinesq or semi-Boussinesq mode. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + nominalDepth = nom_depth_H(i,j) + else + nominalDepth = totalThickness + endif + + ! Determine absolute interface positions + zOld(nz+1) = - nominalDepth + do k = nz,1,-1 + zOld(k) = zOld(k+1) + h(i,j,k) + enddo + + if (ice_shelf) then + call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i,j,:), & + tv%T(i,j,:), tv%S(i,j,:), tv%eqn_of_state, zNew, & + z_rigid_top=totalThickness - nominalDepth, eta_orig = zOld(1), & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + else + call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i,j,:), & + tv%T(i,j,:), tv%S(i,j,:), tv%eqn_of_state, zNew, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + endif + + if (CS%integrate_downward_for_e) then + zOld(1) = 0. + do k = 1,nz + zOld(k+1) = zOld(k) - h(i,j,k) + enddo + else + ! The rest of the model defines grids integrating up from the bottom + zOld(nz+1) = - nominalDepth + do k = nz,1,-1 + zOld(k) = zOld(k+1) + h(i,j,k) + enddo + endif + + ! Calculate the final change in grid position after blending new and old grids + call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) + +#ifdef __DO_SAFETY_CHECKS__ + do k=2,CS%nk + if (zNew(k) > zOld(1)) then + write(0,*) 'zOld=',zOld + write(0,*) 'zNew=',zNew + call MOM_error( FATAL, 'MOM_regridding, build_rho_grid: '//& + 'interior interface above surface!' ) + endif + if (zNew(k) > zNew(k-1)) then + write(0,*) 'zOld=',zOld + write(0,*) 'zNew=',zNew + call MOM_error( FATAL, 'MOM_regridding, build_rho_grid: '//& + 'interior interfaces cross!' ) + endif + enddo + + totalThickness = 0.0 + do k = 1,nz + totalThickness = totalThickness + h(i,j,k) + enddo + + dh = max(nominalDepth, totalThickness) + if (abs(zNew(1)-zOld(1)) > (nz-1)*0.5*epsilon(dh)*dh) then + write(0,*) 'min_thickness=',CS%min_thickness + write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness + write(0,*) 'zNew(1)-zOld(1) = ',zNew(1)-zOld(1),epsilon(dh),nz + do k=1,min(nz,CS%nk)+1 + write(0,*) k,zOld(k),zNew(k) + enddo + do k=min(nz,CS%nk)+2,CS%nk+1 + write(0,*) k,zOld(nz+1),zNew(k) + enddo + do k=1,nz + write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1) + enddo + do k=min(nz,CS%nk)+1,CS%nk + write(0,*) k, 0.0, zNew(k)-zNew(k+1), CS%coordinateResolution(k) + enddo + call MOM_error( FATAL, & + 'MOM_regridding, build_rho_grid: top surface has moved!!!' ) + endif +#endif + + enddo ! end loop on i + enddo ! end loop on j + +end subroutine build_rho_grid + +!> Builds a simple HyCOM-like grid with the deepest location of potential +!! density interpolated from the column profile and a clipping of depth for +!! each interface to a fixed z* or p* grid. This should probably be (optionally?) +!! changed to find the nearest location of the target density. +!! \remark { Based on Bleck, 2002: An ocean-ice general circulation model framed in +!! hybrid isopycnic-Cartesian coordinates, Ocean Modelling 37, 55-88. +!! http://dx.doi.org/10.1016/S1463-5003(01)00012-9 } +subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h, zScale ) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(remapping_CS), intent(in) :: remapCS !< The remapping control structure + type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position + !! in thickness units [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice shelf + !! coverage [nondim] + real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate + !! resolution in Z to desired units for zInterface, + !! usually Z_to_H in which case it is in + !! units of [H Z-1 ~> nondim or kg m-3] + + ! Local variables + real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: p_col ! Layer center pressure in the input column [R L2 T-2 ~> Pa] + real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] + real :: nominalDepth ! The nominal depth of the seafloor in thickness units [H ~> m or kg m-2] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses used for remapping [H ~> m or kg m-2] + real :: z_top_col ! The nominal height of the sea surface or ice-ocean interface + ! in thickness units [H ~> m or kg m-2] + real :: totalThickness ! The total thickness of the water column [H ~> m or kg m-2] + logical :: ice_shelf + integer :: i, j, k, nki + + h_neglect = set_h_neglect(GV, CS%remap_answer_date, h_neglect_edge) + + if (.not.CS%target_density_set) call MOM_error(FATAL, "build_grid_HyCOM1 : "//& + "Target densities must be set before build_grid_HyCOM1 is called.") + + nki = min(GV%ke, CS%nk) + ice_shelf = present(frac_shelf_h) + + ! Build grid based on target interface densities + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + if (G%mask2dT(i,j)>0.) then + + nominalDepth = nom_depth_H(i,j) + + if (ice_shelf) then + totalThickness = 0.0 + do k=1,GV%ke + totalThickness = totalThickness + h(i,j,k) + enddo + z_top_col = max(nominalDepth-totalThickness,0.0) + else + z_top_col = 0.0 + endif + + z_col(1) = z_top_col ! Work downward rather than bottom up + do K = 1, GV%ke + z_col(K+1) = z_col(K) + h(i,j,k) + p_col(k) = tv%P_Ref + CS%compressibility_fraction * & + ( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref ) + enddo + + call build_hycom1_column(CS%hycom_CS, remapCS, tv%eqn_of_state, GV%ke, nominalDepth, & + h(i,j,:), tv%T(i,j,:), tv%S(i,j,:), p_col, & + z_col, z_col_new, zScale=zScale, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + + ! Calculate the final change in grid position after blending new and old grids + call filtered_grid_motion( CS, GV%ke, z_col, z_col_new, dz_col ) + + ! This adjusts things robust to round-off errors + dz_col(:) = -dz_col(:) + call adjust_interface_motion( CS, GV%ke, h(i,j,:), dz_col(:) ) + + dzInterface(i,j,1:nki+1) = dz_col(1:nki+1) + if (nki This subroutine builds an adaptive grid that follows density surfaces where +!! possible, subject to constraints on the smoothness of interface heights. +subroutine build_grid_adaptive(G, GV, US, h, nom_depth_H, tv, dzInterface, remapCS, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + !! [H ~> m or kg m-2] + type(remapping_CS), intent(in) :: remapCS !< The remapping control structure + + ! local variables + integer :: i, j, k, nz ! indices and dimension lengths + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: tInt ! Temperature on interfaces [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: sInt ! Salinity on interfaces [S ~> ppt] + ! current interface positions and after tendency term is applied + ! positive downward + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zInt ! Interface depths [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: zNext ! New interface depths [H ~> m or kg m-2] + + nz = GV%ke + + call assert((GV%ke == CS%nk), "build_grid_adaptive is only written to work "//& + "with the same number of input and target layers.") + + ! position surface at z = 0. + zInt(:,:,1) = 0. + + ! work on interior interfaces + do K = 2, nz ; do j = G%jsc-2,G%jec+2 ; do i = G%isc-2,G%iec+2 + tInt(i,j,K) = 0.5 * (tv%T(i,j,k-1) + tv%T(i,j,k)) + sInt(i,j,K) = 0.5 * (tv%S(i,j,k-1) + tv%S(i,j,k)) + zInt(i,j,K) = zInt(i,j,K-1) + h(i,j,k-1) ! zInt in [H] + enddo ; enddo ; enddo + + ! top and bottom temp/salt interfaces are just the layer + ! average values + tInt(:,:,1) = tv%T(:,:,1) ; tInt(:,:,nz+1) = tv%T(:,:,nz) + sInt(:,:,1) = tv%S(:,:,1) ; sInt(:,:,nz+1) = tv%S(:,:,nz) + + ! set the bottom interface depth + zInt(:,:,nz+1) = zInt(:,:,nz) + h(:,:,nz) + + ! calculate horizontal density derivatives (alpha/beta) + ! between cells in a 5-point stencil, columnwise + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + if (G%mask2dT(i,j) < 0.5) then + dzInterface(i,j,:) = 0. ! land point, don't move interfaces, and skip + cycle + endif + + call build_adapt_column(CS%adapt_CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, nom_depth_H, zNext) + + call filtered_grid_motion(CS, nz, zInt(i,j,:), zNext, dzInterface(i,j,:)) + ! convert from depth to z + do K = 1, nz+1 ; dzInterface(i,j,K) = -dzInterface(i,j,K) ; enddo + call adjust_interface_motion(CS, nz, h(i,j,:), dzInterface(i,j,:)) + enddo ; enddo +end subroutine build_grid_adaptive + +!> Adjust dz_Interface to ensure non-negative future thicknesses +subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + integer, intent(in) :: nk !< Number of layers in h_old + real, dimension(nk), intent(in) :: h_old !< Layer thicknesses on the old grid [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(inout) :: dz_int !< Interface movements, adjusted to keep the thicknesses + !! thicker than their minimum value [H ~> m or kg m-2] + ! Local variables + real :: h_new ! A layer thickness on the new grid [H ~> m or kg m-2] + real :: eps ! A tiny relative thickness [nondim] + real :: h_total ! The total thickness of the old grid [H ~> m or kg m-2] + real :: h_err ! An error tolerance that use used to flag unacceptably large negative layer thicknesses + ! that can not be explained by roundoff errors [H ~> m or kg m-2] + integer :: k + + eps = 1. ; eps = epsilon(eps) + + h_total = 0. ; h_err = 0. + do k = 1, min(CS%nk,nk) + h_total = h_total + h_old(k) + h_err = h_err + max( h_old(k), abs(dz_int(k)), abs(dz_int(k+1)) )*eps + h_new = h_old(k) + ( dz_int(k) - dz_int(k+1) ) + if (h_new < -3.0*h_err) then + write(0,*) 'h<0 at k=',k,'h_old=',h_old(k), & + 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), & + 'h_new=',h_new,'h_err=',h_err + call MOM_error( FATAL, 'MOM_regridding: adjust_interface_motion() - '//& + 'implied h<0 is larger than roundoff!') + endif + enddo + if (CS%nk>nk) then + do k = nk+1, CS%nk + h_err = h_err + max( abs(dz_int(k)), abs(dz_int(k+1)) )*eps + h_new = ( dz_int(k) - dz_int(k+1) ) + if (h_new < -3.0*h_err) then + write(0,*) 'h<0 at k=',k,'h_old was empty',& + 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), & + 'h_new=',h_new,'h_err=',h_err + call MOM_error( FATAL, 'MOM_regridding: adjust_interface_motion() - '//& + 'implied h<0 is larger than roundoff!') + endif + enddo + endif + do k = min(CS%nk,nk),2,-1 + h_new = h_old(k) + ( dz_int(k) - dz_int(k+1) ) + if (h_new make sure all layers are at least as thick as the minimum thickness allowed +!! for regridding purposes by inflating thin layers. This breaks mass conservation +!! and adds mass to the model when there are excessively thin layers. +subroutine inflate_vanished_layers_old( CS, G, GV, h ) +!------------------------------------------------------------------------------ +! This routine is called when initializing the regridding options. The +! objective is to make sure all layers are at least as thick as the minimum +! thickness allowed for regridding purposes (this parameter is set in the +! MOM_input file or defaulted to 1.0e-3). When layers are too thin, they +! are inflated up to the minimum thickness. +!------------------------------------------------------------------------------ + + ! Arguments + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + + ! Local variables + integer :: i, j, k + real :: hTmp(GV%ke) ! A copy of a 1-d column of h [H ~> m or kg m-2] + + do i = G%isc-1,G%iec+1 + do j = G%jsc-1,G%jec+1 + + ! Build grid for current column + do k = 1,GV%ke + hTmp(k) = h(i,j,k) + enddo + + call old_inflate_layers_1d( CS%min_thickness, GV%ke, hTmp ) + + ! Save modified grid + do k = 1,GV%ke + h(i,j,k) = hTmp(k) + enddo + + enddo + enddo + +end subroutine inflate_vanished_layers_old + +!------------------------------------------------------------------------------ +!> Achieve convective adjustment by swapping layers +subroutine convective_adjustment(G, GV, h, tv) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables +!------------------------------------------------------------------------------ +! Check each water column to see whether it is stratified. If not, sort the +! layers by successive swappings of water masses (bubble sort algorithm) +!------------------------------------------------------------------------------ + + ! Local variables + real :: T0, T1 ! temperatures of two layers [C ~> degC] + real :: S0, S1 ! salinities of two layers [S ~> 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 + 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 + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + + ! Compute densities within current water column + call calculate_density(tv%T(i,j,:), tv%S(i,j,:), p_col, densities, tv%eqn_of_state) + + ! Repeat restratification until complete + do + stratified = .true. + do k = 1,GV%ke-1 + ! Gather information of current and next cells + T0 = tv%T(i,j,k) ; T1 = tv%T(i,j,k+1) + S0 = tv%S(i,j,k) ; S1 = tv%S(i,j,k+1) + r0 = densities(k) ; r1 = densities(k+1) + h0 = h(i,j,k) ; h1 = h(i,j,k+1) + ! If the density of the current cell is larger than the density + ! below it, we swap the cells and recalculate the densitiies + ! within the swapped cells + if ( r0 > r1 ) then + tv%T(i,j,k) = T1 ; tv%T(i,j,k+1) = T0 + tv%S(i,j,k) = S1 ; tv%S(i,j,k+1) = S0 + h(i,j,k) = h1 ; h(i,j,k+1) = h0 + ! Recompute densities at levels k and k+1 + 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 + + if ( stratified ) exit + enddo + + enddo ; enddo ! i & j + +end subroutine convective_adjustment + + +!------------------------------------------------------------------------------ +!> Return a uniform resolution vector in the units of the coordinate +function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) +!------------------------------------------------------------------------------ +! Calculate a vector of uniform resolution in the units of the coordinate +!------------------------------------------------------------------------------ + ! Arguments + integer, intent(in) :: nk !< Number of cells in source grid + character(len=*), intent(in) :: coordMode !< A string indicating the coordinate mode. + !! See the documentation for regrid_consts + !! for the recognized values. + real, intent(in) :: maxDepth !< The range of the grid values in some modes, in coordinate + !! dependent units that might be [m] or [kg m-3] or [nondim] + !! or something else. + real, intent(in) :: rhoLight !< The minimum value of the grid in RHO mode [kg m-3] + real, intent(in) :: rhoHeavy !< The maximum value of the grid in RHO mode [kg m-3] + + real :: uniformResolution(nk) !< The returned uniform resolution grid, in + !! coordinate dependent units that might be [m] or + !! [kg m-3] or [nondim] or something else. + + ! Local variables + integer :: scheme + + scheme = coordinateMode(coordMode) + select case ( scheme ) + + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & + REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_ADAPTIVE ) + uniformResolution(:) = maxDepth / real(nk) + + case ( REGRIDDING_RHO ) + uniformResolution(:) = (rhoHeavy - rhoLight) / real(nk) + + case ( REGRIDDING_SIGMA ) + uniformResolution(:) = 1. / real(nk) + + case default + call MOM_error(FATAL, "MOM_regridding, uniformResolution: "//& + "Unrecognized choice for coordinate mode ("//trim(coordMode)//").") + + end select ! type of grid + +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, 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) + call init_coord_zlike(CS%zlike_CS, CS%nk, CS%coordinateResolution) + case (REGRIDDING_SIGMA_SHELF_ZSTAR) + call init_coord_zlike(CS%zlike_CS, CS%nk, CS%coordinateResolution) + case (REGRIDDING_SIGMA) + call init_coord_sigma(CS%sigma_CS, CS%nk, CS%coordinateResolution) + case (REGRIDDING_RHO) + call init_coord_rho(CS%rho_CS, CS%nk, CS%ref_pressure, CS%target_density, CS%interp_CS) + 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_ADAPTIVE) + call init_coord_adapt(CS%adapt_CS, CS%nk, CS%coordinateResolution, GV%m_to_H, US%kg_m3_to_R) + end select +end subroutine initCoord + +!------------------------------------------------------------------------------ +!> Set the fixed resolution data +subroutine setCoordinateResolution( dz, CS, scale ) + real, dimension(:), intent(in) :: dz !< A vector of vertical grid spacings, in arbitrary coordinate + !! dependent units, such as [m] for a z-coordinate or [kg m-3] + !! for a density coordinate. + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + real, optional, intent(in) :: scale !< A scaling factor converting dz to the internal represetation + !! of coordRes, in various units that depend on the coordinate, + !! such as [Z m-1 ~> 1 for a z-coordinate or [R m3 kg-1 ~> 1] for + !! a density coordinate. + + if (size(dz)/=CS%nk) call MOM_error( FATAL, & + 'setCoordinateResolution: inconsistent number of levels' ) + + if (present(scale)) then + CS%coordinateResolution(:) = scale*dz(:) + else + CS%coordinateResolution(:) = dz(:) + endif + +end subroutine setCoordinateResolution + +!> Set target densities based on the old Rlay variable +subroutine set_target_densities_from_GV( GV, US, CS ) + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + ! Local variables + integer :: k, nz + + nz = CS%nk + if (nz == 1) then ! Set a broad range of bounds. Regridding may not be meaningful in this case. + CS%target_density(1) = 0.0 + CS%target_density(2) = 2.0*GV%Rlay(1) + else + CS%target_density(1) = (GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2))) + CS%target_density(nz+1) = (GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1))) + do k=2,nz + CS%target_density(k) = CS%target_density(k-1) + CS%coordinateResolution(k) + enddo + endif + CS%target_density_set = .true. + +end subroutine set_target_densities_from_GV + +!> Set target densities based on vector of interface values +subroutine set_target_densities( CS, rho_int ) + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + real, dimension(CS%nk+1), intent(in) :: rho_int !< Interface densities [R ~> kg m-3] + + if (size(CS%target_density)/=size(rho_int)) then + call MOM_error(FATAL, "set_target_densities inconsistent args!") + endif + + CS%target_density(:) = rho_int(:) + CS%target_density_set = .true. + +end subroutine set_target_densities + +!> Set maximum interface depths based on a vector of input values. +subroutine set_regrid_max_depths( CS, max_depths, units_to_H ) + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + real, dimension(CS%nk+1), intent(in) :: max_depths !< Maximum interface depths, in arbitrary units, often [m] + real, optional, intent(in) :: units_to_H !< A conversion factor for max_depths into H units, + !! often in [H m-1 ~> 1 or kg m-3] + ! Local variables + real :: val_to_H ! A conversion factor from the units for max_depths into H units, often [H m-1 ~> 1 or kg m-3] + ! if units_to_H is present, or [nondim] if it is absent. + integer :: K + + if (.not.allocated(CS%max_interface_depths)) allocate(CS%max_interface_depths(1:CS%nk+1)) + + val_to_H = 1.0 ; if (present(units_to_H)) val_to_H = units_to_H + if (max_depths(CS%nk+1) < max_depths(1)) val_to_H = -1.0*val_to_H + + ! Check for sign reversals in the depths. + if (max_depths(CS%nk+1) < max_depths(1)) then + do K=1,CS%nk ; if (max_depths(K+1) > max_depths(K)) & + call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths!") + enddo + else + do K=1,CS%nk ; if (max_depths(K+1) < max_depths(K)) & + call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths.") + enddo + endif + + do K=1,CS%nk+1 + CS%max_interface_depths(K) = val_to_H * max_depths(K) + enddo + + ! set max depths for coordinate + select case (CS%regridding_scheme) + case (REGRIDDING_HYCOM1) + call set_hycom_params(CS%hycom_CS, max_interface_depths=CS%max_interface_depths) + end select +end subroutine set_regrid_max_depths + +!> Set maximum layer thicknesses based on a vector of input values. +subroutine set_regrid_max_thickness( CS, max_h, units_to_H ) + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + real, dimension(CS%nk+1), intent(in) :: max_h !< Maximum layer thicknesses, in arbitrary units, often [m] + real, optional, intent(in) :: units_to_H !< A conversion factor for max_h into H units, + !! often [H m-1 ~> 1 or kg m-3] + ! Local variables + real :: val_to_H ! A conversion factor from the units for max_h into H units, often [H m-1 ~> 1 or kg m-3] + ! if units_to_H is present, or [nondim] if it is absent. + integer :: k + + if (.not.allocated(CS%max_layer_thickness)) allocate(CS%max_layer_thickness(1:CS%nk)) + + val_to_H = 1.0 ; if (present( units_to_H)) val_to_H = units_to_H + + do k=1,CS%nk + CS%max_layer_thickness(k) = val_to_H * max_h(k) + enddo + + ! set max thickness for coordinate + select case (CS%regridding_scheme) + case (REGRIDDING_HYCOM1) + call set_hycom_params(CS%hycom_CS, max_layer_thickness=CS%max_layer_thickness) + end select +end subroutine set_regrid_max_thickness + + +!> Write the vertical coordinate information into a file. +!! This subroutine writes out a file containing any available data related +!! to the vertical grid used by the MOM ocean model when in ALE mode. +subroutine write_regrid_file( CS, GV, filepath ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + character(len=*), intent(in) :: filepath !< The full path to the file to write + + type(vardesc) :: vars(2) + type(MOM_field) :: fields(2) + type(MOM_netCDF_file) :: IO_handle ! The I/O handle of the fileset + real :: ds(GV%ke), dsi(GV%ke+1) ! The labeling layer and interface coordinates for output + ! in axes in files, in coordinate-dependent units that can + ! be obtained from getCoordinateUnits [various] + + 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) ) + dsi(GV%ke+1) = 0.5*ds(GV%ke) + + vars(1) = var_desc('ds', getCoordinateUnits( CS ), & + 'Layer Coordinate Thickness', '1', 'L', '1') + vars(2) = var_desc('ds_interface', getCoordinateUnits( CS ), & + 'Layer Center Coordinate Separation', '1', 'i', '1') + + call create_MOM_file(IO_handle, trim(filepath), vars, 2, fields, & + SINGLE_FILE, GV=GV) + call MOM_write_field(IO_handle, fields(1), ds) + call MOM_write_field(IO_handle, fields(2), dsi) + call IO_handle%close() + +end subroutine write_regrid_file + +!> Set appropriate values for the negligible thicknesses used for remapping based on an answer date. +function set_h_neglect(GV, remap_answer_date, h_neglect_edge) result(h_neglect) + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + integer, intent(in) :: remap_answer_date !< The vintage of the expressions to use + !! for remapping. Values below 20190101 recover the + !! remapping answers from 2018. Higher values use more + !! robust forms of the same remapping algorithms. + real, intent(out) :: h_neglect_edge !< A negligibly small thickness used in + !! remapping edge value calculations [H ~> m or kg m-2] + real :: h_neglect !< A negligibly small thickness used in + !! remapping cell reconstructions [H ~> m or kg m-2] + + if (remap_answer_date >= 20190101) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif +end function set_h_neglect + +!> Set appropriate values for the negligible vertical layer extents used for remapping based on an answer date. +function set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) result(dz_neglect) + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: remap_answer_date !< The vintage of the expressions to use + !! for remapping. Values below 20190101 recover the + !! remapping answers from 2018. Higher values use more + !! robust forms of the same remapping algorithms. + real, intent(out) :: dz_neglect_edge !< A negligibly small vertical layer extent + !! used in remapping edge value calculations [Z ~> m] + real :: dz_neglect !< A negligibly small vertical layer extent + !! used in remapping cell reconstructions [Z ~> m] + + if (remap_answer_date >= 20190101) then + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + elseif (GV%Boussinesq) then + dz_neglect = US%m_to_Z*1.0e-30 ; dz_neglect_edge = US%m_to_Z*1.0e-10 + else + dz_neglect = GV%kg_m2_to_H * (GV%H_to_m*US%m_to_Z) * 1.0e-30 + dz_neglect_edge = GV%kg_m2_to_H * (GV%H_to_m*US%m_to_Z) * 1.0e-10 + endif +end function set_dz_neglect + +!------------------------------------------------------------------------------ +!> Query the fixed resolution data +function getCoordinateResolution( CS, undo_scaling ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + logical, optional, intent(in) :: undo_scaling !< If present and true, undo any internal + !! rescaling of the resolution data. + real, dimension(CS%nk) :: getCoordinateResolution !< The resolution or delta of the target coordinate, + !! in units that depend on the coordinate [various] + + logical :: unscale + unscale = .false. ; if (present(undo_scaling)) unscale = undo_scaling + + if (unscale) then + getCoordinateResolution(:) = CS%coord_scale * CS%coordinateResolution(:) + else + getCoordinateResolution(:) = CS%coordinateResolution(:) + endif + +end function getCoordinateResolution + +!> Query the target coordinate interface positions +function getCoordinateInterfaces( CS, undo_scaling ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + logical, optional, intent(in) :: undo_scaling !< If present and true, undo any internal + !! rescaling of the resolution data. + real, dimension(CS%nk+1) :: getCoordinateInterfaces !< Interface positions in target coordinate, + !! in units that depend on the coordinate [various] + + integer :: k + logical :: unscale + unscale = .false. ; if (present(undo_scaling)) unscale = undo_scaling + + ! When using a coordinate with target densities, we need to get the actual + ! densities, rather than computing the interfaces based on resolution + if (CS%regridding_scheme == REGRIDDING_RHO) then + if (.not. CS%target_density_set) & + call MOM_error(FATAL, 'MOM_regridding, getCoordinateInterfaces: '//& + 'target densities not set!') + + if (unscale) then + getCoordinateInterfaces(:) = CS%coord_scale * CS%target_density(:) + else + getCoordinateInterfaces(:) = CS%target_density(:) + endif + else + if (unscale) then + getCoordinateInterfaces(1) = 0. + do k = 1, CS%nk + getCoordinateInterfaces(K+1) = getCoordinateInterfaces(K) - & + CS%coord_scale * CS%coordinateResolution(k) + enddo + else + getCoordinateInterfaces(1) = 0. + do k = 1, CS%nk + getCoordinateInterfaces(K+1) = getCoordinateInterfaces(K) - & + CS%coordinateResolution(k) + enddo + endif + ! The following line has an "abs()" to allow ferret users to reference + ! data by index. It is a temporary work around... :( -AJA + getCoordinateInterfaces(:) = abs( getCoordinateInterfaces(:) ) + endif + +end function getCoordinateInterfaces + +!------------------------------------------------------------------------------ +!> Query the target coordinate units +function getCoordinateUnits( CS ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + character(len=20) :: getCoordinateUnits + + select case ( CS%regridding_scheme ) + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & + REGRIDDING_ADAPTIVE ) + getCoordinateUnits = 'meter' + case ( REGRIDDING_SIGMA_SHELF_ZSTAR ) + getCoordinateUnits = 'meter/fraction' + case ( REGRIDDING_SIGMA ) + getCoordinateUnits = 'fraction' + case ( REGRIDDING_RHO ) + getCoordinateUnits = 'kg/m3' + case ( REGRIDDING_ARBITRARY ) + getCoordinateUnits = 'unknown' + case default + call MOM_error(FATAL,'MOM_regridding, getCoordinateUnits: '//& + 'Unknown regridding scheme selected!') + end select ! type of grid + +end function getCoordinateUnits + +!------------------------------------------------------------------------------ +!> Query the short name of the coordinate +function getCoordinateShortName( CS ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + character(len=20) :: getCoordinateShortName + + select case ( CS%regridding_scheme ) + case ( REGRIDDING_ZSTAR ) + !getCoordinateShortName = 'z*' + ! The following line is a temporary work around... :( -AJA + getCoordinateShortName = 'pseudo-depth, -z*' + case ( REGRIDDING_SIGMA_SHELF_ZSTAR ) + getCoordinateShortName = 'pseudo-depth, -z*/sigma' + case ( REGRIDDING_SIGMA ) + getCoordinateShortName = 'sigma' + case ( REGRIDDING_RHO ) + getCoordinateShortName = 'rho' + case ( REGRIDDING_ARBITRARY ) + getCoordinateShortName = 'coordinate' + case ( REGRIDDING_HYCOM1 ) + getCoordinateShortName = 'z-rho' + case ( REGRIDDING_HYBGEN ) + getCoordinateShortName = 'hybrid' + case ( REGRIDDING_ADAPTIVE ) + getCoordinateShortName = 'adaptive' + case default + call MOM_error(FATAL,'MOM_regridding, getCoordinateShortName: '//& + 'Unknown regridding scheme selected!') + end select ! type of grid + +end function getCoordinateShortName + +!> Can be used to set any of the parameters for MOM_regridding. +subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_grid_weight, & + interp_scheme, depth_of_time_filter_shallow, depth_of_time_filter_deep, & + compress_fraction, ref_pressure, & + integrate_downward_for_e, remap_answers_2018, remap_answer_date, regrid_answer_date, & + adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin, adaptDrho0) + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + logical, optional, intent(in) :: boundary_extrapolation !< Extrapolate in boundary cells + real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the + !! new grid [H ~> m or kg m-2] + real, optional, intent(in) :: old_grid_weight !< Weight given to old coordinate when time-filtering grid [nondim] + character(len=*), optional, intent(in) :: interp_scheme !< Interpolation method for state-dependent coordinates + real, optional, intent(in) :: depth_of_time_filter_shallow !< Depth to start cubic [H ~> m or kg m-2] + real, optional, intent(in) :: depth_of_time_filter_deep !< Depth to end cubic [H ~> m or kg m-2] + real, optional, intent(in) :: compress_fraction !< Fraction of compressibility to add to potential density [nondim] + real, optional, intent(in) :: ref_pressure !< The reference pressure for density-dependent + !! coordinates [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface positions downward + !! from the top. + logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions + !! that recover the remapping answers from 2018. Otherwise + !! use more robust but mathematically equivalent expressions. + integer, optional, intent(in) :: remap_answer_date !< The vintage of the expressions to use for remapping + integer, optional, intent(in) :: regrid_answer_date !< The vintage of the expressions to use for regridding + real, optional, intent(in) :: adaptTimeRatio !< Ratio of the ALE timestep to the grid timescale [nondim]. + real, optional, intent(in) :: adaptZoom !< Depth of near-surface zooming region [H ~> m or kg m-2]. + real, optional, intent(in) :: adaptZoomCoeff !< Coefficient of near-surface zooming diffusivity [nondim]. + real, optional, intent(in) :: adaptBuoyCoeff !< Coefficient of buoyancy diffusivity [nondim]. + real, optional, intent(in) :: adaptAlpha !< Scaling factor on optimization tendency [nondim]. + logical, optional, intent(in) :: adaptDoMin !< If true, make a HyCOM-like mixed layer by + !! preventing interfaces from being shallower than + !! the depths specified by the regridding coordinate. + real, optional, intent(in) :: adaptDrho0 !< Reference density difference for stratification-dependent + !! diffusion. [R ~> kg m-3] + + if (present(interp_scheme)) call set_interp_scheme(CS%interp_CS, interp_scheme) + if (present(boundary_extrapolation)) call set_interp_extrap(CS%interp_CS, boundary_extrapolation) + if (present(regrid_answer_date)) call set_interp_answer_date(CS%interp_CS, regrid_answer_date) + + if (present(old_grid_weight)) then + if (old_grid_weight<0. .or. old_grid_weight>1.) & + call MOM_error(FATAL,'MOM_regridding, set_regrid_params: Weight is out side the range 0..1!') + CS%old_grid_weight = old_grid_weight + endif + if (present(depth_of_time_filter_shallow)) CS%depth_of_time_filter_shallow = depth_of_time_filter_shallow + if (present(depth_of_time_filter_deep)) CS%depth_of_time_filter_deep = depth_of_time_filter_deep + if (present(depth_of_time_filter_shallow) .or. present(depth_of_time_filter_deep)) then + if (CS%depth_of_time_filter_deep Returns the number of levels/layers in the regridding control structure +integer function get_regrid_size(CS) + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + + get_regrid_size = CS%nk + +end function get_regrid_size + +!> This returns a copy of the zlike_CS stored in the regridding control structure. +function get_zlike_CS(CS) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(zlike_CS) :: get_zlike_CS + + get_zlike_CS = CS%zlike_CS +end function get_zlike_CS + +!> This returns a copy of the sigma_CS stored in the regridding control structure. +function get_sigma_CS(CS) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(sigma_CS) :: get_sigma_CS + + get_sigma_CS = CS%sigma_CS +end function get_sigma_CS + +!> This returns a copy of the rho_CS stored in the regridding control structure. +function get_rho_CS(CS) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(rho_CS) :: get_rho_CS + + get_rho_CS = CS%rho_CS +end function get_rho_CS + +!------------------------------------------------------------------------------ +!> Return coordinate-derived thicknesses for fixed coordinate systems +function getStaticThickness( CS, SSH, depth ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, intent(in) :: SSH !< The sea surface height, in the same units as depth, often [Z ~> m] + real, intent(in) :: depth !< The maximum depth of the grid, often [Z ~> m] + real, dimension(CS%nk) :: getStaticThickness !< The returned thicknesses in the units of + !! depth, often [Z ~> m] + ! Local + integer :: k + real :: z, dz ! Vertical positions and grid spacing [Z ~> m] + + select case ( CS%regridding_scheme ) + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & + REGRIDDING_ADAPTIVE ) + if (depth>0.) then + z = ssh + do k = 1, CS%nk + dz = CS%coordinateResolution(k) * ( 1. + ssh/depth ) ! Nominal dz* + dz = max(dz, 0.) ! Avoid negative incase ssh=-depth + dz = min(dz, depth - z) ! Clip if below topography + z = z + dz ! Bottom of layer + getStaticThickness(k) = dz + enddo + else + getStaticThickness(:) = 0. ! On land ... + endif + case ( REGRIDDING_SIGMA ) + getStaticThickness(:) = CS%coordinateResolution(:) * ( depth + ssh ) + case ( REGRIDDING_RHO ) + getStaticThickness(:) = 0. ! Not applicable + case ( REGRIDDING_ARBITRARY ) + getStaticThickness(:) = 0. ! Not applicable + case default + call MOM_error(FATAL,'MOM_regridding, getStaticThickness: '//& + 'Unknown regridding scheme selected!') + end select ! type of grid + +end function getStaticThickness + +!> Parses a string and generates a dz(:) profile that goes like k**power. +subroutine dz_function1( string, dz ) + character(len=*), intent(in) :: string !< String with list of parameters in form + !! dz_min, H_total, power, precision + real, dimension(:), intent(inout) :: dz !< Profile of nominal thicknesses [m] or other units + ! Local variables + integer :: nk, k + real :: dz_min ! minimum grid spacing [m] or other units + real :: power ! A power to raise the relative position in index space [nondim] + real :: prec ! The precision with which positions are returned [m] or other units + real :: H_total ! The sum of the nominal thicknesses [m] or other units + + nk = size(dz) ! Number of cells + prec = -1024. + read( string, *) dz_min, H_total, power, prec + if (prec == -1024.) call MOM_error(FATAL,"dz_function1: "// & + "Problem reading FNC1: string ="//trim(string)) + ! Create profile of ( dz - dz_min ) + do k = 1, nk + dz(k) = (real(k-1)/real(nk-1))**power + enddo + dz(:) = ( H_total - real(nk) * dz_min ) * ( dz(:) / sum(dz) ) ! Rescale to so total is H_total + dz(:) = anint( dz(:) / prec ) * prec ! Rounds to precision prec + dz(:) = ( H_total - real(nk) * dz_min ) * ( dz(:) / sum(dz) ) ! Rescale to so total is H_total + dz(:) = anint( dz(:) / prec ) * prec ! Rounds to precision prec + dz(nk) = dz(nk) + ( H_total - sum( dz(:) + dz_min ) ) ! Adjust bottommost layer + dz(:) = anint( dz(:) / prec ) * prec ! Rounds to precision prec + dz(:) = dz(:) + dz_min ! Finally add in the constant dz_min + +end subroutine dz_function1 + +!> Construct the name of a parameter for a specific coordinate based on param_prefix and param_suffix. For the main, +!! prognostic coordinate this will simply return the parameter name (e.g. P_REF) +function create_coord_param(param_prefix, param_name, param_suffix) result(coord_param) + character(len=*) :: param_name !< The base name of the parameter (e.g. the one used for the main coordinate) + character(len=*) :: param_prefix !< String to prefix to parameter names. + character(len=*) :: param_suffix !< String to append to parameter names. + character(len=MAX_PARAM_LENGTH) :: coord_param !< Parameter name prepended by param_prefix + !! and appended with param_suffix + integer :: out_length + + if (len_trim(param_prefix) + len_trim(param_suffix) == 0) then + coord_param = param_name + else + ! Note the +2 is because of two underscores + out_length = len_trim(param_name)+len_trim(param_prefix)+len_trim(param_suffix)+2 + if (out_length > MAX_PARAM_LENGTH) then + call MOM_error(FATAL,"Coordinate parameter is too long; increase MAX_PARAM_LENGTH") + endif + coord_param = TRIM(param_prefix)//"_"//TRIM(param_name)//"_"//TRIM(param_suffix) + endif + +end function create_coord_param + +!> Parses a string and generates a rho_target(:) profile with refined resolution downward +!! and returns the number of levels +integer function rho_function1( string, rho_target ) + character(len=*), intent(in) :: string !< String with list of parameters in form + !! dz_min, H_total, power, precision + real, dimension(:), allocatable, intent(inout) :: rho_target !< Profile of interface densities [kg m-3] + ! Local variables + integer :: nki, k, nk + real :: dx ! Fractional distance from interface nki [nondim] + real :: ddx ! Change in dx between interfaces [nondim] + real :: rho_1, rho_2 ! Density of the top two layers in a profile [kg m-3] + real :: rho_3 ! Density in the third layer, below which the density increase linearly + ! in subsequent layers [kg m-3] + real :: drho ! Change in density over the linear region [kg m-3] + real :: rho_4 ! The densest density in this profile [kg m-3], which might be very large. + real :: drho_min ! A minimal fractional density difference [nondim]? + + read( string, *) nk, rho_1, rho_2, rho_3, drho, rho_4, drho_min + allocate(rho_target(nk+1)) + nki = nk + 1 - 4 ! Number of interfaces minus 4 specified values + rho_target(1) = rho_1 + rho_target(2) = rho_2 + dx = 0. + do k = 0, nki + ddx = max( drho_min, real(nki-k)/real(nki*nki) ) + dx = dx + ddx + rho_target(3+k) = rho_3 + (2. * drho) * dx + enddo + rho_target(nki+4) = rho_4 + + rho_function1 = nk + +end function rho_function1 + +!> \namespace mom_regridding +!! +!! A vertical grid is defined solely by the cell thicknesses, \f$h\f$. +!! Most calculations in this module start with the coordinate at the bottom +!! of the column set to -depth, and use a increasing value of coordinate with +!! decreasing k. This is consistent with the rest of MOM6 that uses position, +!! \f$z\f$ which is a negative quantity for most of the ocean. +!! +!! A change in grid is define through a change in position of the interfaces: +!! \f[ +!! z^n_{k+1/2} = z^{n-1}_{k+1/2} + \Delta z_{k+1/2} +!! \f] +!! with the positive upward coordinate convention +!! \f[ +!! z_{k-1/2} = z_{k+1/2} + h_k +!! \f] +!! so that +!! \f[ +!! h^n_k = h^{n-1}_k + ( \Delta z_{k-1/2} - \Delta z_{k+1/2} ) +!! \f] +!! +!! Original date of creation: 2008.06.09 by L. White + +end module MOM_regridding diff --git a/ALE/MOM_remapping.F90 b/ALE/MOM_remapping.F90 new file mode 100644 index 0000000000..abcd821790 --- /dev/null +++ b/ALE/MOM_remapping.F90 @@ -0,0 +1,1801 @@ +!> Provides column-wise vertical remapping functions +module MOM_remapping + +! This file is part of MOM6. See LICENSE.md for the license. +! Original module written by Laurent White, 2008.06.09 + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_io, only : stdout, stderr +use MOM_string_functions, only : uppercase +use regrid_edge_values, only : edge_values_explicit_h4, edge_values_implicit_h4 +use regrid_edge_values, only : edge_values_explicit_h4cw +use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 +use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 +use remapping_attic, only : remapping_attic_unit_tests +use PCM_functions, only : PCM_reconstruction +use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation +use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use PPM_functions, only : PPM_monotonicity +use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 +use MOM_hybgen_remap, only : hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs + +implicit none ; private + +!> Container for remapping parameters +type, public :: remapping_CS ; private + !> Determines which reconstruction to use + integer :: remapping_scheme = -911 + !> Degree of polynomial reconstruction + integer :: degree = 0 + !> If true, extrapolate boundaries + logical :: boundary_extrapolation = .true. + !> If true, reconstructions are checked for consistency. + logical :: check_reconstruction = .false. + !> If true, the result of remapping are checked for conservation and bounds. + logical :: check_remapping = .false. + !> If true, the intermediate values used in remapping are forced to be bounded. + logical :: force_bounds_in_subcell = .false. + !> The vintage of the expressions to use for remapping. Values below 20190101 result + !! in the use of older, less accurate expressions. + integer :: answer_date = 99991231 +end type + +! The following routines are visible to the outside world +public remapping_core_h, remapping_core_w +public initialize_remapping, end_remapping, remapping_set_param, extract_member_remapping_CS +public remapping_unit_tests, build_reconstructions_1d, average_value_ppoly +public interpolate_column, reintegrate_column, dzFromH1H2 + +! The following are private parameter constants +integer, parameter :: REMAPPING_PCM = 0 !< O(h^1) remapping scheme +integer, parameter :: REMAPPING_PLM = 2 !< O(h^2) remapping scheme +integer, parameter :: REMAPPING_PLM_HYBGEN = 3 !< O(h^2) remapping scheme +integer, parameter :: REMAPPING_PPM_CW =10 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PPM_H4 = 4 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PPM_IH4 = 5 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PPM_HYBGEN = 6 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_WENO_HYBGEN= 7 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PQM_IH4IH3 = 8 !< O(h^4) remapping scheme +integer, parameter :: REMAPPING_PQM_IH6IH5 = 9 !< O(h^5) remapping scheme + +integer, parameter :: INTEGRATION_PCM = 0 !< Piecewise Constant Method +integer, parameter :: INTEGRATION_PLM = 1 !< Piecewise Linear Method +integer, parameter :: INTEGRATION_PPM = 3 !< Piecewise Parabolic Method +integer, parameter :: INTEGRATION_PQM = 5 !< Piecewise Quartic Method + +character(len=40) :: mdl = "MOM_remapping" !< This module's name. + +!> Documentation for external callers +character(len=360), public :: remappingSchemesDoc = & + "PCM (1st-order accurate)\n"//& + "PLM (2nd-order accurate)\n"//& + "PLM_HYBGEN (2nd-order accurate)\n"//& + "PPM_H4 (3rd-order accurate)\n"//& + "PPM_IH4 (3rd-order accurate)\n"//& + "PPM_HYBGEN (3rd-order accurate)\n"//& + "WENO_HYBGEN (3rd-order accurate)\n"//& + "PQM_IH4IH3 (4th-order accurate)\n"//& + "PQM_IH6IH5 (5th-order accurate)\n" +character(len=3), public :: remappingDefaultScheme = "PLM" !< Default remapping method + +contains + +!> Set parameters within remapping object +subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & + check_reconstruction, check_remapping, force_bounds_in_subcell, answers_2018, answer_date) + type(remapping_CS), intent(inout) :: CS !< Remapping control structure + character(len=*), optional, intent(in) :: remapping_scheme !< Remapping scheme to use + logical, optional, intent(in) :: boundary_extrapolation !< Indicate to extrapolate in boundary cells + logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions + logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping + logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded + logical, optional, intent(in) :: answers_2018 !< If true use older, less accurate expressions. + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + if (present(remapping_scheme)) then + call setReconstructionType( remapping_scheme, CS ) + endif + if (present(boundary_extrapolation)) then + CS%boundary_extrapolation = boundary_extrapolation + endif + if (present(check_reconstruction)) then + CS%check_reconstruction = check_reconstruction + endif + if (present(check_remapping)) then + CS%check_remapping = check_remapping + endif + if (present(force_bounds_in_subcell)) then + CS%force_bounds_in_subcell = force_bounds_in_subcell + endif + if (present(answers_2018)) then + if (answers_2018) then + CS%answer_date = 20181231 + else + CS%answer_date = 20190101 + endif + endif + if (present(answer_date)) then + CS%answer_date = answer_date + endif + +end subroutine remapping_set_param + +subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_extrapolation, check_reconstruction, & + check_remapping, force_bounds_in_subcell) + type(remapping_CS), intent(in) :: CS !< Control structure for remapping module + integer, optional, intent(out) :: remapping_scheme !< Determines which reconstruction scheme to use + integer, optional, intent(out) :: degree !< Degree of polynomial reconstruction + logical, optional, intent(out) :: boundary_extrapolation !< If true, extrapolate boundaries + logical, optional, intent(out) :: check_reconstruction !< If true, reconstructions are checked for consistency. + logical, optional, intent(out) :: check_remapping !< If true, the result of remapping are checked + !! for conservation and bounds. + logical, optional, intent(out) :: force_bounds_in_subcell !< If true, the intermediate values used in + !! remapping are forced to be bounded. + + if (present(remapping_scheme)) remapping_scheme = CS%remapping_scheme + if (present(degree)) degree = CS%degree + if (present(boundary_extrapolation)) boundary_extrapolation = CS%boundary_extrapolation + if (present(check_reconstruction)) check_reconstruction = CS%check_reconstruction + if (present(check_remapping)) check_remapping = CS%check_remapping + if (present(force_bounds_in_subcell)) force_bounds_in_subcell = CS%force_bounds_in_subcell + +end subroutine extract_member_remapping_CS + +!> Calculate edge coordinate x from cell width h +subroutine buildGridFromH(nz, h, x) + integer, intent(in) :: nz !< Number of cells + real, dimension(nz), intent(in) :: h !< Cell widths [H] + real, dimension(nz+1), intent(inout) :: x !< Edge coordinates starting at x(1)=0 [H] + ! Local variables + integer :: k + + x(1) = 0.0 + do k = 1,nz + x(k+1) = x(k) + h(k) + enddo + +end subroutine buildGridFromH + +!> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. +subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge, PCM_cell) + type(remapping_CS), intent(in) :: CS !< Remapping control structure + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] + integer, intent(in) :: n1 !< Number of cells on target grid + real, dimension(n1), intent(in) :: h1 !< Cell widths on target grid [H] + real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0 [H] + 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 + !! cells in the source grid where this is true. + + ! Local variables + real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] + real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial reconstructions [A] + real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] + real :: hNeglect, hNeglect_edge ! Negligibly small cell widths in the same units as h0 [H] + integer :: iMethod ! An integer indicating the integration method used + integer :: k + + hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge + + call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod, & + hNeglect, hNeglect_edge, PCM_cell ) + + if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) + + call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & + CS%force_bounds_in_subcell, u1, uh_err ) + + if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & + n1, h1, u1, iMethod, uh_err, "remapping_core_h") + +end subroutine remapping_core_h + +!> Remaps column of values u0 on grid h0 to implied grid h1 +!! where the interfaces of h1 differ from those of h0 by dx. +subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_edge ) + type(remapping_CS), intent(in) :: CS !< Remapping control structure + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] + integer, intent(in) :: n1 !< Number of cells on target grid + real, dimension(n1+1), intent(in) :: dx !< Cell widths on target grid [H] + real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0 [H]. + 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]. + ! Local variables + real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] + real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial reconstructions [A] + real, dimension(n1) :: h1 !< Cell widths on target grid [H] + real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] + real :: hNeglect, hNeglect_edge ! Negligibly small thicknesses [H] + integer :: iMethod ! An integer indicating the integration method used + integer :: k + + hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge + + call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod,& + hNeglect, hNeglect_edge ) + + if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) + + ! This is a temporary step prior to switching to remapping_core_h() + do k = 1, n1 + if (k<=n0) then + h1(k) = max( 0., h0(k) + ( dx(k+1) - dx(k) ) ) + else + h1(k) = max( 0., dx(k+1) - dx(k) ) + endif + enddo + call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & + CS%force_bounds_in_subcell, u1, uh_err ) +! call remapByDeltaZ( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, dx, iMethod, u1, hNeglect ) +! call remapByProjection( n0, h0, u0, CS%ppoly_r, n1, h1, iMethod, u1, hNeglect ) + + if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & + n1, h1, u1, iMethod, uh_err, "remapping_core_w") + +end subroutine remapping_core_w + +!> Creates polynomial reconstructions of u0 on the source grid h0. +subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & + ppoly_r_E, ppoly_r_S, iMethod, h_neglect, & + h_neglect_edge, PCM_cell ) + type(remapping_CS), intent(in) :: CS !< Remapping control structure + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] + real, dimension(n0,CS%degree+1), & + intent(out) :: ppoly_r_coefs !< Coefficients of polynomial [A] + real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial [A] + real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial [A H-1] + integer, intent(out) :: iMethod !< Integration method + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0 [H] + 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, optional, intent(in) :: PCM_cell(n0) !< If present, use PCM remapping for + !! cells from the source grid where this is true. + + ! Local variables + integer :: local_remapping_scheme + integer :: k, n + + ! Reset polynomial + ppoly_r_E(:,:) = 0.0 + ppoly_r_S(:,:) = 0.0 + ppoly_r_coefs(:,:) = 0.0 + iMethod = -999 + + local_remapping_scheme = CS%remapping_scheme + if (n0<=1) then + local_remapping_scheme = REMAPPING_PCM + elseif (n0<=3) then + local_remapping_scheme = min( local_remapping_scheme, REMAPPING_PLM ) + elseif (n0<=4 .and. local_remapping_scheme /= REMAPPING_PPM_CW ) then + local_remapping_scheme = min( local_remapping_scheme, REMAPPING_PPM_H4 ) + endif + select case ( local_remapping_scheme ) + case ( REMAPPING_PCM ) + call PCM_reconstruction( n0, u0, ppoly_r_E, ppoly_r_coefs) + iMethod = INTEGRATION_PCM + case ( REMAPPING_PLM ) + call PLM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + if ( CS%boundary_extrapolation ) then + call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect) + endif + iMethod = INTEGRATION_PLM + case ( REMAPPING_PLM_HYBGEN ) + call hybgen_PLM_coefs(u0, h0, ppoly_r_coefs(:,2), n0, 1, h_neglect) + do k=1,n0 + ppoly_r_E(k,1) = u0(k) - 0.5 * ppoly_r_coefs(k,2) ! Left edge value of cell k + ppoly_r_E(k,2) = u0(k) + 0.5 * ppoly_r_coefs(k,2) ! Right edge value of cell k + ppoly_r_coefs(k,1) = ppoly_r_E(k,1) + enddo + if ( CS%boundary_extrapolation ) & + call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + iMethod = INTEGRATION_PLM + case ( REMAPPING_PPM_CW ) + ! identical to REMAPPING_PPM_HYBGEN + call edge_values_explicit_h4cw( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call PPM_monotonicity( n0, u0, ppoly_r_E ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) + if ( CS%boundary_extrapolation ) then + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + endif + iMethod = INTEGRATION_PPM + case ( REMAPPING_PPM_H4 ) + call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) + if ( CS%boundary_extrapolation ) then + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + endif + iMethod = INTEGRATION_PPM + case ( REMAPPING_PPM_IH4 ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) + if ( CS%boundary_extrapolation ) then + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + endif + iMethod = INTEGRATION_PPM + case ( REMAPPING_PPM_HYBGEN ) + call hybgen_PPM_coefs(u0, h0, ppoly_r_E, n0, 1, h_neglect) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=99991231 ) + if ( CS%boundary_extrapolation ) & + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + iMethod = INTEGRATION_PPM + case ( REMAPPING_WENO_HYBGEN ) + call hybgen_weno_coefs(u0, h0, ppoly_r_E, n0, 1, h_neglect) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=99991231 ) + if ( CS%boundary_extrapolation ) & + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + iMethod = INTEGRATION_PPM + case ( REMAPPING_PQM_IH4IH3 ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect, answer_date=CS%answer_date ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect, & + answer_date=CS%answer_date ) + if ( CS%boundary_extrapolation ) then + call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & + ppoly_r_coefs, h_neglect ) + endif + iMethod = INTEGRATION_PQM + case ( REMAPPING_PQM_IH6IH5 ) + call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect, answer_date=CS%answer_date ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect, & + answer_date=CS%answer_date ) + if ( CS%boundary_extrapolation ) then + call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & + ppoly_r_coefs, h_neglect ) + endif + iMethod = INTEGRATION_PQM + case default + call MOM_error( FATAL, 'MOM_remapping, build_reconstructions_1d: '//& + 'The selected remapping method is invalid' ) + end select + + if (present(PCM_cell)) then + ! Change the coefficients to those for the piecewise constant method in indicated cells. + do k=1,n0 ; if (PCM_cell(k)) then + ppoly_r_coefs(k,1) = u0(k) + ppoly_r_E(k,1:2) = u0(k) + ppoly_r_S(k,1:2) = 0.0 + do n=2,CS%degree+1 ; ppoly_r_coefs(k,n) = 0.0 ; enddo + endif ; enddo + endif + +end subroutine build_reconstructions_1d + +!> Checks that edge values and reconstructions satisfy bounds +subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & + ppoly_r_coefs, ppoly_r_E, ppoly_r_S) + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] + integer, intent(in) :: deg !< Degree of polynomial reconstruction + logical, intent(in) :: boundary_extrapolation !< Extrapolate at boundaries if true + real, dimension(n0,deg+1),intent(out) :: ppoly_r_coefs !< Coefficients of polynomial [A] + real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial [A] + real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial [A H-1] + ! Local variables + integer :: i0, n + real :: u_l, u_c, u_r ! Cell averages [A] + real :: u_min, u_max ! Cell extrema [A] + logical :: problem_detected + + problem_detected = .false. + do i0 = 1, n0 + u_l = u0(max(1,i0-1)) + u_c = u0(i0) + u_r = u0(min(n0,i0+1)) + if (i0 > 1 .or. .not. boundary_extrapolation) then + u_min = min(u_l, u_c) + u_max = max(u_l, u_c) + if (ppoly_r_E(i0,1) < u_min) then + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Left edge undershoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_min + problem_detected = .true. + endif + if (ppoly_r_E(i0,1) > u_max) then + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Left edge overshoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_max + problem_detected = .true. + endif + endif + if (i0 < n0 .or. .not. boundary_extrapolation) then + u_min = min(u_c, u_r) + u_max = max(u_c, u_r) + if (ppoly_r_E(i0,2) < u_min) then + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Right edge undershoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & + 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_min + problem_detected = .true. + endif + if (ppoly_r_E(i0,2) > u_max) then + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Right edge overshoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & + 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_max + problem_detected = .true. + endif + endif + if (i0 > 1) then + if ( (u_c-u_l)*(ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2)) < 0.) then + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Non-monotonic edges at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + 'right edge=',ppoly_r_E(i0-1,2),'left edge=',ppoly_r_E(i0,1) + write(0,'(5(a,1pe24.16,1x))') 'u(i0)-u(i0-1)',u_c-u_l,'edge diff=',ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2) + problem_detected = .true. + endif + endif + if (problem_detected) then + write(0,'(a,1p9e24.16)') 'Polynomial coeffs:',ppoly_r_coefs(i0,:) + write(0,'(3(a,1pe24.16,1x))') 'u_l=',u_l,'u_c=',u_c,'u_r=',u_r + write(0,'(a4,10a24)') 'i0','h0(i0)','u0(i0)','left edge','right edge','Polynomial coefficients' + do n = 1, n0 + write(0,'(i4,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefs(n,:) + enddo + call MOM_error(FATAL, 'MOM_remapping, check_reconstructions_1d: '// & + 'Edge values or polynomial coefficients were inconsistent!') + endif + enddo + +end subroutine check_reconstructions_1d + +!> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating +!! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the +!! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. +subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & + force_bounds_in_subcell, u1, uh_err, ah_sub, aisub_src, aiss, aise ) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(n0) !< Source cell averages (size n0) [A] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] + integer, intent(in) :: method !< Remapping scheme to use + logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded + real, intent(out) :: u1(n1) !< Target cell averages (size n1) [A] + real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h [A H] + real, optional, intent(out) :: ah_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + integer, optional, intent(out) :: aisub_src(n0+n1+1) !< i_sub_src + integer, optional, intent(out) :: aiss(n0) !< isrc_start + integer, optional, intent(out) :: aise(n0) !< isrc_ens + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i1 ! Index into h1(1:n1), target column + integer :: i_start0 ! Used to record which sub-cells map to source cells + integer :: i_start1 ! Used to record which sub-cells map to target cells + integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] + real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] + real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] + integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell + integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell + integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell + integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell + real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] + real, dimension(n0) :: u0_min ! Minimum value of reconstructions in source cell [A] + real, dimension(n0) :: u0_max ! Minimum value of reconstructions in source cell [A] + integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell + integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell + real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + real :: h0_supply, h1_supply ! The amount of width available for constructing sub-cells [H] + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: dh0_eff ! Running sum of source cell thickness [H] + ! For error checking/debugging + logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues + logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues + logical, parameter :: debug_bounds = .false. ! For debugging overshoots etc. + integer :: k, i0_last_thick_cell + real :: h0tot, h1tot, h2tot ! Summed thicknesses used for debugging [H] + real :: h0err, h1err, h2err ! Estimates of round-off errors used for debugging [H] + real :: u02_err, u0err, u1err, u2err ! Integrated reconstruction error estimates [H A] + real :: u0tot, u1tot, u2tot ! Integrated reconstruction values [H A] + real :: u_orig ! The original value of the reconstruction in a cell [A] + real :: u0min, u0max, u1min, u1max, u2min, u2max ! Minimum and maximum values of reconstructions [A] + logical :: src_has_volume !< True if h0 has not been consumed + logical :: tgt_has_volume !< True if h1 has not been consumed + + i0_last_thick_cell = 0 + do i0 = 1, n0 + u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) + u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) + if (h0(i0)>0.) i0_last_thick_cell = i0 + enddo + + ! Initialize algorithm + h0_supply = h0(1) + h1_supply = h1(1) + src_has_volume = .true. + tgt_has_volume = .true. + i0 = 1 ; i1 = 1 + i_start0 = 1 ; i_start1 = 1 + i_max = 1 + dh_max = 0. + dh0_eff = 0. + + ! First sub-cell is always vanished + h_sub(1) = 0. + isrc_start(1) = 1 + isrc_end(1) = 1 + isrc_max(1) = 1 + isub_src(1) = 1 + + ! Loop over each sub-cell to calculate intersections with source and target grids + do i_sub = 2, n0+n1+1 + + ! This is the width of the sub-cell, determined by which ever column has the least + ! supply available to consume. + dh = min(h0_supply, h1_supply) + + ! This is the running sum of the source cell thickness. After summing over each + ! sub-cell, the sum of sub-cell thickness might differ from the original source + ! cell thickness due to round off. + dh0_eff = dh0_eff + min(dh, h0_supply) + + ! Record the source index (i0) that this sub-cell integral belongs to. This + ! is needed to index the reconstruction coefficients for the source cell + ! used in the integrals of the sub-cell width. + isub_src(i_sub) = i0 + h_sub(i_sub) = dh + + ! For recording the largest sub-cell within a source cell. + if (dh >= dh_max) then + i_max = i_sub + dh_max = dh + endif + + ! Which ever column (source or target) has the least width left to consume determined + ! the width, dh, of sub-cell i_sub in the expression for dh above. + if (h0_supply <= h1_supply .and. src_has_volume) then + ! h0_supply is smaller than h1_supply) so we consume h0_supply and increment the + ! source cell index. + h1_supply = h1_supply - dh ! Although this is a difference the result will + ! be non-negative because of the conditional. + ! Record the sub-cell start/end index that span the source cell i0. + isrc_start(i0) = i_start0 + isrc_end(i0) = i_sub + i_start0 = i_sub + 1 + ! Record the sub-cell that is the largest fraction of the source cell. + isrc_max(i0) = i_max + i_max = i_sub + 1 + dh_max = 0. + ! Record the source cell thickness found by summing the sub-cell thicknesses. + h0_eff(i0) = dh0_eff + ! Move the source index. + if (i0 < n0) then + i0 = i0 + 1 + h0_supply = h0(i0) + dh0_eff = 0. + else + h0_supply = 0. + src_has_volume = .false. + endif + elseif (h0_supply >= h1_supply .and. tgt_has_volume) then + ! h1_supply is smaller than h0_supply) so we consume h1_supply and increment the + ! target cell index. + h0_supply = h0_supply - dh ! Although this is a difference the result will + ! be non-negative because of the conditional. + ! Record the sub-cell start/end index that span the target cell i1. + itgt_start(i1) = i_start1 + itgt_end(i1) = i_sub + i_start1 = i_sub + 1 + ! Move the target index. + if (i1 < n1) then + i1 = i1 + 1 + h1_supply = h1(i1) + else + h1_supply = 0. + tgt_has_volume = .false. + endif + elseif (src_has_volume) then + ! We ran out of target volume but still have source cells to consume + h_sub(i_sub) = h0_supply + ! Record the sub-cell start/end index that span the source cell i0. + isrc_start(i0) = i_start0 + isrc_end(i0) = i_sub + i_start0 = i_sub + 1 + ! Record the sub-cell that is the largest fraction of the source cell. + isrc_max(i0) = i_max + i_max = i_sub + 1 + dh_max = 0. + ! Record the source cell thickness found by summing the sub-cell thicknesses. + h0_eff(i0) = dh0_eff + if (i0 < n0) then + i0 = i0 + 1 + h0_supply = h0(i0) + dh0_eff = 0. + else + h0_supply = 0. + src_has_volume = .false. + endif + elseif (tgt_has_volume) then + ! We ran out of source volume but still have target cells to consume + h_sub(i_sub) = h1_supply + ! Record the sub-cell start/end index that span the target cell i1. + itgt_start(i1) = i_start1 + itgt_end(i1) = i_sub + i_start1 = i_sub + 1 + ! Move the target index. + if (i1 < n1) then + i1 = i1 + 1 + h1_supply = h1(i1) + else + h1_supply = 0. + tgt_has_volume = .false. + endif + else + stop 'remap_via_sub_cells: THIS SHOULD NEVER HAPPEN!' + endif + + enddo + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + xa = 0. + dh0_eff = 0. + uh_sub(1) = 0. + u_sub(1) = ppoly0_E(1,1) + u02_err = 0. + do i_sub = 2, n0+n1 + + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0_eff(i0)>0.) then + xb = dh0_eff / h0_eff(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + if (debug_bounds) then + if (method<5 .and.(u_sub(i_sub)u0_max(i0))) then + write(0,*) 'Sub cell average is out of bounds',i_sub,'method=',method + write(0,*) 'xa,xb: ',xa,xb + write(0,*) 'Edge values: ',ppoly0_E(i0,:),'mean',u0(i0) + write(0,*) 'a_c: ',(u0(i0)-ppoly0_E(i0,1))+(u0(i0)-ppoly0_E(i0,2)) + write(0,*) 'Polynomial coeffs: ',ppoly0_coefs(i0,:) + write(0,*) 'Bounds min=',u0_min(i0),'max=',u0_max(i0) + write(0,*) 'Average: ',u_sub(i_sub),'rel to min=',u_sub(i_sub)-u0_min(i0),'rel to max=',u_sub(i_sub)-u0_max(i0) + call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& + 'Sub-cell average is out of bounds!' ) + endif + endif + if (force_bounds_in_subcell) then + ! These next two lines should not be needed but when using PQM we found roundoff + ! can lead to overshoots. These lines sweep issues under the rug which need to be + ! properly .. later. -AJA + u_orig = u_sub(i_sub) + u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) + u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + u02_err = u02_err + dh*abs( u_sub(i_sub) - u_orig ) + endif + uh_sub(i_sub) = dh * u_sub(i_sub) + + if (isub_src(i_sub+1) /= i0) then + ! If the next sub-cell is in a different source cell, reset the position counters + dh0_eff = 0. + xa = 0. + else + xa = xb ! Next integral will start at end of last + endif + + enddo + u_sub(n0+n1+1) = ppoly0_E(n0,2) ! This value is only needed when total target column + uh_sub(n0+n1+1) = ppoly0_E(n0,2) * h_sub(n0+n1+1) ! is wider than the source column + + if (adjust_thickest_subcell) then + ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within + ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals + ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (@Hallberg-NOAA). + do i0 = 1, i0_last_thick_cell + i_max = isrc_max(i0) + dh_max = h_sub(i_max) + if (dh_max > 0.) then + ! duh will be the sum of sub-cell integrals within the source cell except for the thickest sub-cell. + duh = 0. + do i_sub = isrc_start(i0), isrc_end(i0) + if (i_sub /= i_max) duh = duh + uh_sub(i_sub) + enddo + uh_sub(i_max) = u0(i0)*h0(i0) - duh + u02_err = u02_err + max( abs(uh_sub(i_max)), abs(u0(i0)*h0(i0)), abs(duh) ) + endif + enddo + endif + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + uh_err = 0. + do i1 = 1, n1 + if (h1(i1) > 0.) then + duh = 0. ; dh = 0. + i_sub = itgt_start(i1) + if (force_bounds_in_target) then + u1min = u_sub(i_sub) + u1max = u_sub(i_sub) + endif + do i_sub = itgt_start(i1), itgt_end(i1) + if (force_bounds_in_target) then + u1min = min(u1min, u_sub(i_sub)) + u1max = max(u1max, u_sub(i_sub)) + endif + dh = dh + h_sub(i_sub) + duh = duh + uh_sub(i_sub) + ! This accumulates the contribution to the error bound for the sum of u*h + uh_err = uh_err + max(abs(duh),abs(uh_sub(i_sub)))*epsilon(duh) + enddo + u1(i1) = duh / dh + ! This is the contribution from the division to the error bound for the sum of u*h + uh_err = uh_err + abs(duh)*epsilon(duh) + if (force_bounds_in_target) then + u_orig = u1(i1) + u1(i1) = max(u1min, min(u1max, u1(i1))) + ! Adjusting to be bounded contributes to the error for the sum of u*h + uh_err = uh_err + dh*abs( u1(i1)-u_orig ) + endif + else + u1(i1) = u_sub(itgt_start(i1)) + endif + enddo + + ! Check errors and bounds + if (debug_bounds) then + call measure_input_bounds( n0, h0, u0, ppoly0_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) + call measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) + call measure_output_bounds( n0+n1+1, h_sub, u_sub, h2tot, h2err, u2tot, u2err, u2min, u2max ) + if (method<5) then ! We except PQM until we've debugged it + if ( (abs(u1tot-u0tot)>(u0err+u1err)+uh_err+u02_err .and. abs(h1tot-h0tot)u0err+u2err+u02_err .and. abs(h2tot-h0tot)u0max) ) then + write(0,*) 'method = ',method + write(0,*) 'Source to sub-cells:' + write(0,*) 'H: h0tot=',h0tot,'h2tot=',h2tot,'dh=',h2tot-h0tot,'h0err=',h0err,'h2err=',h2err + if (abs(h2tot-h0tot)>h0err+h2err) & + write(0,*) 'H non-conservation difference=',h2tot-h0tot,'allowed err=',h0err+h2err,' <-----!' + write(0,*) 'UH: u0tot=',u0tot,'u2tot=',u2tot,'duh=',u2tot-u0tot,'u0err=',u0err,'u2err=',u2err,& + 'adjustment err=',u02_err + if (abs(u2tot-u0tot)>u0err+u2err) & + write(0,*) 'U non-conservation difference=',u2tot-u0tot,'allowed err=',u0err+u2err,' <-----!' + write(0,*) 'Sub-cells to target:' + write(0,*) 'H: h2tot=',h2tot,'h1tot=',h1tot,'dh=',h1tot-h2tot,'h2err=',h2err,'h1err=',h1err + if (abs(h1tot-h2tot)>h2err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h2tot,'allowed err=',h2err+h1err,' <-----!' + write(0,*) 'UH: u2tot=',u2tot,'u1tot=',u1tot,'duh=',u1tot-u2tot,'u2err=',u2err,'u1err=',u1err,'uh_err=',uh_err + if (abs(u1tot-u2tot)>u2err+u1err) & + write(0,*) 'U non-conservation difference=',u1tot-u2tot,'allowed err=',u2err+u1err,' <-----!' + write(0,*) 'Source to target:' + write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err + if (abs(h1tot-h0tot)>h0err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' + write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err + if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & + write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' + write(0,*) 'U: u0min=',u0min,'u1min=',u1min,'u2min=',u2min + if (u1minu0max) write(0,*) 'U2 maximum overshoot=',u2max-u0max,' <-----!' + write(0,'(a3,6a24,2a3)') 'k','h0','left edge','u0','right edge','h1','u1','is','ie' + do k = 1, max(n0,n1) + if (k<=min(n0,n1)) then + write(0,'(i3,1p6e24.16,2i3)') k,h0(k),ppoly0_E(k,1),u0(k),ppoly0_E(k,2),h1(k),u1(k),itgt_start(k),itgt_end(k) + elseif (k>n0) then + write(0,'(i3,96x,1p2e24.16,2i3)') k,h1(k),u1(k),itgt_start(k),itgt_end(k) + else + write(0,'(i3,1p4e24.16)') k,h0(k),ppoly0_E(k,1),u0(k),ppoly0_E(k,2) + endif + enddo + write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' + do k = 1, n0 + write(0,'(i3,1p6e24.16)') k,u0(k),ppoly0_coefs(k,:) + enddo + write(0,'(a3,3a24,a3,2a24)') 'k','Sub-cell h','Sub-cell u','Sub-cell hu','i0','xa','xb' + xa = 0. + dh0_eff = 0. + do k = 1, n0+n1+1 + dh = h_sub(k) + i0 = isub_src(k) + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + xb = dh0_eff / h0_eff(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + write(0,'(i3,1p3e24.16,i3,1p2e24.16)') k,h_sub(k),u_sub(k),uh_sub(k),i0,xa,xb + if (k<=n0+n1) then + if (isub_src(k+1) /= i0) then + dh0_eff = 0.; xa = 0. + else + xa = xb + endif + endif + enddo + call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& + 'Remapping result is inconsistent!' ) + endif + endif ! method<5 + endif ! debug_bounds + + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err + + if (present(ah_sub)) ah_sub(1:n0+n1+1) = h_sub(1:n0+n1+1) + if (present(aisub_src)) aisub_src(1:n0+n1+1) = isub_src(1:n0+n1+1) + if (present(aiss)) aiss(1:n0) = isrc_start(1:n0) + if (present(aise)) aise(1:n0) = isrc_end(1:n0) + +end subroutine remap_via_sub_cells + +!> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest +subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, mask_edges) + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest+1), intent(inout) :: u_dest !< Interpolated value at destination cell interfaces [A] + logical, intent(in) :: mask_edges !< If true, mask the values outside of massless + !! layers at the top and bottom of the column. + + ! Local variables + real :: x_dest ! Relative position of target interface [H] + real :: dh ! Source cell thickness [H] + real :: frac_pos(ndest+1) ! Fractional position of the destination interface + ! within the source layer [nondim], 0 <= frac_pos <= 1. + integer :: k_src(ndest+1) ! Source grid layer index of destination interface, 1 <= k_src <= ndest. + integer :: ks, k_dest ! Index of cell in src and dest columns + + ! The following forces the "do while" loop to do one cycle that will set u1, u2, dh. + ks = 0 + dh = 0. + x_dest = 0. + + ! Find the layer index and fractional position of the interfaces of the target + ! grid on the source grid. + do k_dest=1,ndest+1 + do while (dh<=x_dest .and. ks0.) then + frac_pos(k_dest) = max(0., min(1., x_dest / dh)) ! Weight of u2 + else ! For a vanished source layer we need to do something reasonable... + frac_pos(k_dest) = 0.5 + endif + + if (k_dest <= ndest) then + x_dest = x_dest + h_dest(k_dest) ! Position of interface k_dest+1 + endif + enddo + + do k_dest=1,ndest+1 + ! Linear interpolation between surrounding edge values. + ks = k_src(k_dest) + u_dest(k_dest) = (1.0 - frac_pos(k_dest)) * u_src(ks) + frac_pos(k_dest) * u_src(ks+1) + enddo + + if (mask_edges) then + ! Mask vanished layers at the surface which would be under an ice-shelf. + ! When the layer k_dest is vanished and all layers above are also vanished, + ! the k_dest interface value should be missing. + do k_dest=1,ndest + if (h_dest(k_dest) > 0.) exit + u_dest(k_dest) = 0.0 + enddo + + ! Mask interfaces below vanished layers at the bottom + do k_dest=ndest,1,-1 + if (h_dest(k_dest) > 0.) exit + u_dest(k_dest+1) = 0.0 + enddo + endif + +end subroutine interpolate_column + +!> Conservatively calculate integrated data, uh_dest, on grid h_dest, from layer-integrated data, uh_src, on grid h_src +subroutine reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc), intent(in) :: uh_src !< Values at source cell interfaces [A H] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest), intent(inout) :: uh_dest !< Interpolated value at destination cell interfaces [A H] + + ! Local variables + real :: h_src_rem, h_dest_rem, dh ! Incremental thicknesses [H] + real :: uh_src_rem, duh ! Incremental amounts of stuff [A H] + integer :: k_src, k_dest ! Index of cell in src and dest columns + logical :: src_ran_out + + uh_dest(:) = 0.0 + + k_src = 0 + k_dest = 0 + h_dest_rem = 0. + h_src_rem = 0. + src_ran_out = .false. + + do while(.true.) + if (h_src_rem==0. .and. k_src0.) duh = uh_src_rem + h_src_rem = 0. + uh_src_rem = 0. + h_dest_rem = max(0., h_dest_rem - dh) + elseif (h_src_rem>h_dest_rem) then + ! Only part of the source cell can be used up + dh = h_dest_rem + duh = (dh / h_src_rem) * uh_src_rem + h_src_rem = max(0., h_src_rem - dh) + uh_src_rem = uh_src_rem - duh + h_dest_rem = 0. + else ! h_src_rem==h_dest_rem + ! The source cell exactly fits the destination cell + duh = uh_src_rem + h_src_rem = 0. + uh_src_rem = 0. + h_dest_rem = 0. + endif + uh_dest(k_dest) = uh_dest(k_dest) + duh + if (k_dest==ndest .and. (k_src==nsrc .or. h_dest_rem==0.)) exit + enddo + +end subroutine reintegrate_column + +!> Returns the average value of a reconstruction within a single source cell, i0, +!! between the non-dimensional positions xa and xb (xa<=xb) with dimensional +!! separation dh. +real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: u0(:) !< Cell means [A] + real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] + integer, intent(in) :: method !< Remapping scheme to use + integer, intent(in) :: i0 !< Source cell index + real, intent(in) :: xa !< Non-dimensional start position within source cell [nondim] + real, intent(in) :: xb !< Non-dimensional end position within source cell [nondim] + ! Local variables + real :: u_ave ! The average value of the polynomial over the specified range [A] + real :: xapxb ! A sum of fracional positions [nondim] + real :: mx, Ya, Yb, my ! Various fractional positions [nondim] + real :: xa_2, xb_2 ! Squared fractional positions [nondim] + real :: xa2pxb2, xa2b2ab, Ya2b2ab ! Sums of squared fractional positions [nondim] + real :: a_L, a_R, u_c, a_c ! Values of the polynomial at various locations [A] + real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials [nondim] + + if (xb > xa) then + select case ( method ) + case ( INTEGRATION_PCM ) + u_ave = u0(i0) + case ( INTEGRATION_PLM ) + u_ave = ( & + ppoly0_coefs(i0,1) & + + ppoly0_coefs(i0,2) * 0.5 * ( xb + xa ) ) + case ( INTEGRATION_PPM ) + mx = 0.5 * ( xa + xb ) + a_L = ppoly0_E(i0, 1) + a_R = ppoly0_E(i0, 2) + u_c = u0(i0) + a_c = 0.5 * ( ( u_c - a_L ) + ( u_c - a_R ) ) ! a_6 / 6 + if (mx<0.5) then + ! This integration of the PPM reconstruction is expressed in distances from the left edge + xa2b2ab = (xa*xa+xb*xb)+xa*xb + u_ave = a_L + ( ( a_R - a_L ) * mx & + + a_c * ( 3. * ( xb + xa ) - 2.*xa2b2ab ) ) + else + ! This integration of the PPM reconstruction is expressed in distances from the right edge + Ya = 1. - xa + Yb = 1. - xb + my = 0.5 * ( Ya + Yb ) + Ya2b2ab = (Ya*Ya+Yb*Yb)+Ya*Yb + u_ave = a_R + ( ( a_L - a_R ) * my & + + a_c * ( 3. * ( Yb + Ya ) - 2.*Ya2b2ab ) ) + endif + case ( INTEGRATION_PQM ) + xa_2 = xa*xa + xb_2 = xb*xb + xa2pxb2 = xa_2 + xb_2 + xapxb = xa + xb + u_ave = ( & + ppoly0_coefs(i0,1) & + + ( ppoly0_coefs(i0,2) * 0.5 * ( xapxb ) & + + ( ppoly0_coefs(i0,3) * r_3 * ( xa2pxb2 + xa*xb ) & + + ( ppoly0_coefs(i0,4) * 0.25* ( xa2pxb2 * xapxb ) & + + ppoly0_coefs(i0,5) * 0.2 * ( ( xb*xb_2 + xa*xa_2 ) * xapxb + xa_2*xb_2 ) ) ) ) ) + case default + call MOM_error( FATAL,'The selected integration method is invalid' ) + end select + else ! dh == 0. + select case ( method ) + case ( INTEGRATION_PCM ) + u_ave = ppoly0_coefs(i0,1) + case ( INTEGRATION_PLM ) + !u_ave = ppoly0_coefs(i0,1) & + ! + xa * ppoly0_coefs(i0,2) + a_L = ppoly0_E(i0, 1) + a_R = ppoly0_E(i0, 2) + Ya = 1. - xa + if (xa < 0.5) then + u_ave = a_L + xa * ( a_R - a_L ) + else + u_ave = a_R + Ya * ( a_L - a_R ) + endif + case ( INTEGRATION_PPM ) + !u_ave = ppoly0_coefs(i0,1) & + ! + xa * ( ppoly0_coefs(i0,2) & + ! + xa * ppoly0_coefs(i0,3) ) + a_L = ppoly0_E(i0, 1) + a_R = ppoly0_E(i0, 2) + u_c = u0(i0) + a_c = 3. * ( ( u_c - a_L ) + ( u_c - a_R ) ) ! a_6 + Ya = 1. - xa + if (xa < 0.5) then + u_ave = a_L + xa * ( ( a_R - a_L ) + a_c * Ya ) + else + u_ave = a_R + Ya * ( ( a_L - a_R ) + a_c * xa ) + endif + case ( INTEGRATION_PQM ) + u_ave = ppoly0_coefs(i0,1) & + + xa * ( ppoly0_coefs(i0,2) & + + xa * ( ppoly0_coefs(i0,3) & + + xa * ( ppoly0_coefs(i0,4) & + + xa * ppoly0_coefs(i0,5) ) ) ) + case default + call MOM_error( FATAL,'The selected integration method is invalid' ) + end select + endif + average_value_ppoly = u_ave + +end function average_value_ppoly + +!> This subroutine checks for sufficient consistence in the extrema and total amounts on the old +!! and new grids. +subroutine check_remapped_values(n0, h0, u0, ppoly_r_E, deg, ppoly_r_coefs, & + n1, h1, u1, iMethod, uh_err, caller) + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] + real, dimension(n0,2), intent(in) :: ppoly_r_E !< Edge values of polynomial fits [A] + integer, intent(in) :: deg !< Degree of the piecewise polynomial reconstrution + real, dimension(n0,deg+1), intent(in) :: ppoly_r_coefs !< Coefficients of the piecewise + !! polynomial reconstructions [A] + integer, intent(in) :: n1 !< Number of cells on target grid + real, dimension(n1), intent(in) :: h1 !< Cell widths on target grid [H] + real, dimension(n1), intent(in) :: u1 !< Cell averages on target grid [A] + integer, intent(in) :: iMethod !< An integer indicating the integration method used + real, intent(in) :: uh_err !< A bound on the error in the sum of u*h as + !! estimated by the remapping code [H A] + character(len=*), intent(in) :: caller !< The name of the calling routine. + + ! Local variables + real :: h0tot, h0err ! Sum of source cell widths and round-off error in this sum [H] + real :: h1tot, h1err ! Sum of target cell widths and round-off error in this sum [H] + real :: u0tot, u0err ! Integrated values on the source grid and round-off error in this sum [H A] + real :: u1tot, u1err ! Integrated values on the target grid and round-off error in this sum [H A] + real :: u0min, u0max, u1min, u1max ! Extrema of values on the two grids [A] + integer :: k + + ! Check errors and bounds + call measure_input_bounds( n0, h0, u0, ppoly_r_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) + call measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) + + if (iMethod<5) return ! We except PQM until we've debugged it + + if ( (abs(u1tot-u0tot)>(u0err+u1err)+uh_err .and. abs(h1tot-h0tot)u0max) ) then + write(0,*) 'iMethod = ',iMethod + write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err + if (abs(h1tot-h0tot)>h0err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' + write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err + if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & + write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' + write(0,*) 'U: u0min=',u0min,'u1min=',u1min + if (u1minn0) then + write(0,'(i3,96x,1p2e24.16)') k,h1(k),u1(k) + else + write(0,'(i3,1p4e24.16)') k,h0(k),ppoly_r_E(k,1),u0(k),ppoly_r_E(k,2) + endif + enddo + write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' + do k = 1, n0 + write(0,'(i3,1p6e24.16)') k,u0(k),ppoly_r_coefs(k,:) + enddo + call MOM_error( FATAL, 'MOM_remapping, '//trim(caller)//': '//& + 'Remapping result is inconsistent!' ) + endif + +end subroutine check_remapped_values + +!> Measure totals and bounds on source grid +subroutine measure_input_bounds( n0, h0, u0, edge_values, h0tot, h0err, u0tot, u0err, u0min, u0max ) + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] + real, dimension(n0,2), intent(in) :: edge_values !< Cell edge values on source grid [A] + real, intent(out) :: h0tot !< Sum of cell widths [H] + real, intent(out) :: h0err !< Magnitude of round-off error in h0tot [H] + real, intent(out) :: u0tot !< Sum of cell widths times values [H A] + real, intent(out) :: u0err !< Magnitude of round-off error in u0tot [H A] + real, intent(out) :: u0min !< Minimum value in reconstructions of u0 [A] + real, intent(out) :: u0max !< Maximum value in reconstructions of u0 [A] + ! Local variables + real :: eps ! The smallest representable fraction of a number [nondim] + integer :: k + + eps = epsilon(h0(1)) + h0tot = h0(1) + h0err = 0. + u0tot = h0(1) * u0(1) + u0err = 0. + u0min = min( edge_values(1,1), edge_values(1,2) ) + u0max = max( edge_values(1,1), edge_values(1,2) ) + do k = 2, n0 + h0tot = h0tot + h0(k) + h0err = h0err + eps * max(h0tot, h0(k)) + u0tot = u0tot + h0(k) * u0(k) + u0err = u0err + eps * max(abs(u0tot), abs(h0(k) * u0(k))) + u0min = min( u0min, edge_values(k,1), edge_values(k,2) ) + u0max = max( u0max, edge_values(k,1), edge_values(k,2) ) + enddo + +end subroutine measure_input_bounds + +!> Measure totals and bounds on destination grid +subroutine measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) + integer, intent(in) :: n1 !< Number of cells on destination grid + real, dimension(n1), intent(in) :: h1 !< Cell widths on destination grid [H] + real, dimension(n1), intent(in) :: u1 !< Cell averages on destination grid [A] + real, intent(out) :: h1tot !< Sum of cell widths [H] + real, intent(out) :: h1err !< Magnitude of round-off error in h1tot [H] + real, intent(out) :: u1tot !< Sum of cell widths times values [H A] + real, intent(out) :: u1err !< Magnitude of round-off error in u1tot [H A] + real, intent(out) :: u1min !< Minimum value in reconstructions of u1 [A] + real, intent(out) :: u1max !< Maximum value in reconstructions of u1 [A] + ! Local variables + real :: eps ! The smallest representable fraction of a number [nondim] + integer :: k + + eps = epsilon(h1(1)) + h1tot = h1(1) + h1err = 0. + u1tot = h1(1) * u1(1) + u1err = 0. + u1min = u1(1) + u1max = u1(1) + do k = 2, n1 + h1tot = h1tot + h1(k) + h1err = h1err + eps * max(h1tot, h1(k)) + u1tot = u1tot + h1(k) * u1(k) + u1err = u1err + eps * max(abs(u1tot), abs(h1(k) * u1(k))) + u1min = min(u1min, u1(k)) + u1max = max(u1max, u1(k)) + enddo + +end subroutine measure_output_bounds + +!> Calculates the change in interface positions based on h1 and h2 +subroutine dzFromH1H2( n1, h1, n2, h2, dx ) + integer, intent(in) :: n1 !< Number of cells on source grid + real, dimension(:), intent(in) :: h1 !< Cell widths of source grid (size n1) [H] + integer, intent(in) :: n2 !< Number of cells on target grid + real, dimension(:), intent(in) :: h2 !< Cell widths of target grid (size n2) [H] + real, dimension(:), intent(out) :: dx !< Change in interface position (size n2+1) [H] + ! Local variables + integer :: k + real :: x1, x2 ! Interface positions [H] + + x1 = 0. + x2 = 0. + dx(1) = 0. + do K = 1, max(n1,n2) + if (k <= n1) x1 = x1 + h1(k) ! Interface k+1, right of source cell k + if (k <= n2) then + x2 = x2 + h2(k) ! Interface k+1, right of target cell k + dx(K+1) = x2 - x1 ! Change of interface k+1, target - source + endif + enddo + +end subroutine dzFromH1H2 + +!> Constructor for remapping control structure +subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & + check_reconstruction, check_remapping, force_bounds_in_subcell, answers_2018, answer_date) + ! Arguments + type(remapping_CS), intent(inout) :: CS !< Remapping control structure + character(len=*), intent(in) :: remapping_scheme !< Remapping scheme to use + logical, optional, intent(in) :: boundary_extrapolation !< Indicate to extrapolate in boundary cells + logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions + logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping + logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded + logical, optional, intent(in) :: answers_2018 !< If true use older, less accurate expressions. + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Note that remapping_scheme is mandatory for initialize_remapping() + call remapping_set_param(CS, remapping_scheme=remapping_scheme, boundary_extrapolation=boundary_extrapolation, & + check_reconstruction=check_reconstruction, check_remapping=check_remapping, & + force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018, answer_date=answer_date) + +end subroutine initialize_remapping + +!> Changes the method of reconstruction +!! Use this routine to parse a string parameter specifying the reconstruction +!! and re-allocates work arrays appropriately. It is called from +!! initialize_remapping but can be called from an external module too. +subroutine setReconstructionType(string,CS) + character(len=*), intent(in) :: string !< String to parse for method + type(remapping_CS), intent(inout) :: CS !< Remapping control structure + ! Local variables + integer :: degree + degree = -99 + select case ( uppercase(trim(string)) ) + case ("PCM") + CS%remapping_scheme = REMAPPING_PCM + degree = 0 + case ("PLM") + CS%remapping_scheme = REMAPPING_PLM + degree = 1 + case ("PLM_HYBGEN") + CS%remapping_scheme = REMAPPING_PLM_HYBGEN + degree = 1 + case ("PPM_CW") + CS%remapping_scheme = REMAPPING_PPM_CW + degree = 2 + case ("PPM_H4") + CS%remapping_scheme = REMAPPING_PPM_H4 + degree = 2 + case ("PPM_IH4") + CS%remapping_scheme = REMAPPING_PPM_IH4 + degree = 2 + case ("PPM_HYBGEN") + CS%remapping_scheme = REMAPPING_PPM_HYBGEN + degree = 2 + case ("WENO_HYBGEN") + CS%remapping_scheme = REMAPPING_WENO_HYBGEN + degree = 2 + case ("PQM_IH4IH3") + CS%remapping_scheme = REMAPPING_PQM_IH4IH3 + degree = 4 + case ("PQM_IH6IH5") + CS%remapping_scheme = REMAPPING_PQM_IH6IH5 + degree = 4 + case default + call MOM_error(FATAL, "setReconstructionType: "//& + "Unrecognized choice for REMAPPING_SCHEME ("//trim(string)//").") + end select + + CS%degree = degree + +end subroutine setReconstructionType + +!> Destrcutor for remapping control structure +subroutine end_remapping(CS) + type(remapping_CS), intent(inout) :: CS !< Remapping control structure + + CS%degree = 0 + +end subroutine end_remapping + +!> Runs unit tests on remapping functions. +!! Should only be called from a single/root thread +!! Returns True if a test fails, otherwise False +logical function remapping_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + integer, parameter :: n0 = 4, n1 = 3, n2 = 6 + real :: h0(n0), x0(n0+1), u0(n0) ! Thicknesses [H], interface heights [H] and values [A] for profile 0 + real :: h1(n1), x1(n1+1), u1(n1) ! Thicknesses [H], interface heights [H] and values [A] for profile 1 + real :: dx1(n1+1) ! Interface height changes for profile 1 [H] + real :: h2(n2), x2(n2+1), u2(n2) ! Thicknesses [H], interface heights [H] and values [A] for profile 2 + data u0 /9., 3., -3., -9./ ! Linear profile, 4 at surface to -4 at bottom [A] + data h0 /4*0.75/ ! 4 uniform layers with total depth of 3 [H] + data h1 /3*1./ ! 3 uniform layers with total depth of 3 [H] + data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 [H] + type(remapping_CS) :: CS !< Remapping control structure + real, allocatable, dimension(:,:) :: ppoly0_E ! Edge values of polynomials [A] + real, allocatable, dimension(:,:) :: ppoly0_S ! Edge slopes of polynomials [A H-1] + real, allocatable, dimension(:,:) :: ppoly0_coefs ! Coefficients of polynomials [A] + integer :: answer_date ! The vintage of the expressions to test + integer :: i + real, parameter :: hNeglect_dflt = 1.0e-30 ! A thickness [H ~> m or kg m-2] that can be + ! added to thicknesses in a denominator without + ! changing the numerical result, except where + ! a division by zero would otherwise occur. + real :: err ! Errors in the remapped thicknesses [H] or values [A] + real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H] + logical :: thisTest, v, fail + + v = verbose + answer_date = 20190101 ! 20181231 + h_neglect = hNeglect_dflt + h_neglect_edge = hNeglect_dflt ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 + + write(stdout,*) '==== MOM_remapping: remapping_unit_tests =================' + remapping_unit_tests = .false. ! Normally return false + + thisTest = .false. + call buildGridFromH(n0, h0, x0) + do i=1,n0+1 + err=x0(i)-0.75*real(i-1) + if (abs(err)>real(i-1)*epsilon(err)) thisTest = .true. + enddo + if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed buildGridFromH() 1' + remapping_unit_tests = remapping_unit_tests .or. thisTest + call buildGridFromH(n1, h1, x1) + do i=1,n1+1 + err=x1(i)-real(i-1) + if (abs(err)>real(i-1)*epsilon(err)) thisTest = .true. + enddo + if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed buildGridFromH() 2' + remapping_unit_tests = remapping_unit_tests .or. thisTest + + thisTest = .false. + call initialize_remapping(CS, 'PPM_H4', answer_date=answer_date) + if (verbose) write(stdout,*) 'h0 (test data)' + if (verbose) call dumpGrid(n0,h0,x0,u0) + + call dzFromH1H2( n0, h0, n1, h1, dx1 ) + call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1, h_neglect, h_neglect_edge) + do i=1,n1 + err=u1(i)-8.*(0.5*real(1+n1)-real(i)) + if (abs(err)>real(n1-1)*epsilon(err)) thisTest = .true. + enddo + if (verbose) write(stdout,*) 'h1 (by projection)' + if (verbose) call dumpGrid(n1,h1,x1,u1) + if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapping_core_w()' + remapping_unit_tests = remapping_unit_tests .or. thisTest + + thisTest = .false. + allocate(ppoly0_E(n0,2)) + allocate(ppoly0_S(n0,2)) + allocate(ppoly0_coefs(n0,CS%degree+1)) + + ppoly0_E(:,:) = 0.0 + ppoly0_S(:,:) = 0.0 + ppoly0_coefs(:,:) = 0.0 + + call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10, answer_date=answer_date ) + call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=answer_date ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + + thisTest = .false. + call buildGridFromH(n2, h2, x2) + + if (verbose) write(stdout,*) 'Via sub-cells' + thisTest = .false. + call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n2, h2, INTEGRATION_PPM, .false., u2, err ) + if (verbose) call dumpGrid(n2,h2,x2,u2) + + do i=1,n2 + err=u2(i)-8./2.*(0.5*real(1+n2)-real(i)) + if (abs(err)>2.*epsilon(err)) thisTest = .true. + enddo + if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remap_via_sub_cells() 2' + remapping_unit_tests = remapping_unit_tests .or. thisTest + + call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & + 6, (/.125,.125,.125,.125,.125,.125/), INTEGRATION_PPM, .false., u2, err ) + if (verbose) call dumpGrid(6,h2,x2,u2) + + call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & + 3, (/2.25,1.5,1./), INTEGRATION_PPM, .false., u2, err ) + if (verbose) call dumpGrid(3,h2,x2,u2) + + if (.not. remapping_unit_tests) write(stdout,*) 'Pass' + + write(stdout,*) '===== MOM_remapping: new remapping_unit_tests ==================' + + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) + allocate(ppoly0_coefs(5,6)) + allocate(ppoly0_E(5,2)) + allocate(ppoly0_S(5,2)) + + call PCM_reconstruction(3, (/1.,2.,4./), ppoly0_E(1:3,:), & + ppoly0_coefs(1:3,:) ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,4./), 'PCM: P0') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), ppoly0_E(1:3,:), & + ppoly0_coefs(1:3,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,5./), 'Unlim PLM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Unlim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), ppoly0_E(1:3,:), & + ppoly0_coefs(1:3,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,1.,7./), 'Left lim PLM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Left lim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), ppoly0_E(1:3,:), & + ppoly0_coefs(1:3,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,5.,7./), 'Right lim PLM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Right lim PLM: P1') + + call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), ppoly0_E(1:3,:), & + ppoly0_coefs(1:3,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') + + call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & + h_neglect=1e-10, answer_date=answer_date ) + ! The next two tests currently fail due to roundoff, but pass when given a reasonable tolerance. + thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges', tol=8.0e-15) + remapping_unit_tests = remapping_unit_tests .or. thisTest + thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges', tol=1.0e-14) + remapping_unit_tests = remapping_unit_tests .or. thisTest + ppoly0_E(:,1) = (/0.,2.,4.,6.,8./) + ppoly0_E(:,2) = (/2.,4.,6.,8.,10./) + call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), & + ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefs(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') + + call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & + h_neglect=1e-10, answer_date=answer_date ) + ! The next two tests are now passing when answer_date >= 20190101, but otherwise only work to roundoff. + thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges', tol=2.7e-14) + remapping_unit_tests = remapping_unit_tests .or. thisTest + thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges', tol=4.8e-14) + remapping_unit_tests = remapping_unit_tests .or. thisTest + ppoly0_E(:,1) = (/0.,0.,3.,12.,27./) + ppoly0_E(:,2) = (/0.,3.,12.,27.,48./) + call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), & + ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefs(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefs(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefs(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') + + ppoly0_E(:,1) = (/0.,0.,6.,10.,15./) + ppoly0_E(:,2) = (/0.,6.,12.,17.,15./) + call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,5.,7.,16.,15./), ppoly0_E(1:5,:), & + ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefs(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') + + call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & + ppoly0_coefs(1:4,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') + call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & + ppoly0_coefs(1:4,:), & + 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') + + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) + + ! This line carries out tests on some older remapping schemes. + remapping_unit_tests = remapping_unit_tests .or. remapping_attic_unit_tests(verbose) + + if (.not. remapping_unit_tests) write(stdout,*) 'Pass' + + write(stdout,*) '=== MOM_remapping: interpolation and reintegration unit tests ===' + if (verbose) write(stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + + fail = test_interp(verbose, 'Identity: 3 layer', & + 3, (/1.,2.,3./), (/1.,2.,3.,4./), & + 3, (/1.,2.,3./), (/1.,2.,3.,4./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(verbose, 'A: 3 layer to 2', & + 3, (/1.,1.,1./), (/1.,2.,3.,4./), & + 2, (/1.5,1.5/), (/1.,2.5,4./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(verbose, 'B: 2 layer to 3', & + 2, (/1.5,1.5/), (/1.,4.,7./), & + 3, (/1.,1.,1./), (/1.,3.,5.,7./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(verbose, 'C: 3 layer (vanished middle) to 2', & + 3, (/1.,0.,2./), (/1.,2.,2.,3./), & + 2, (/1.,2./), (/1.,2.,3./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(verbose, 'D: 3 layer (deep) to 3', & + 3, (/1.,2.,3./), (/1.,2.,4.,7./), & + 2, (/2.,2./), (/1.,3.,5./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(verbose, 'E: 3 layer to 3 (deep)', & + 3, (/1.,2.,4./), (/1.,2.,4.,8./), & + 3, (/2.,3.,4./), (/1.,3.,6.,8./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(verbose, 'F: 3 layer to 4 with vanished top/botton', & + 3, (/1.,2.,4./), (/1.,2.,4.,8./), & + 4, (/0.,2.,5.,0./), (/0.,1.,3.,8.,0./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(verbose, 'Fs: 3 layer to 4 with vanished top/botton (shallow)', & + 3, (/1.,2.,4./), (/1.,2.,4.,8./), & + 4, (/0.,2.,4.,0./), (/0.,1.,3.,7.,0./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(verbose, 'Fd: 3 layer to 4 with vanished top/botton (deep)', & + 3, (/1.,2.,4./), (/1.,2.,4.,8./), & + 4, (/0.,2.,6.,0./), (/0.,1.,3.,8.,0./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + if (verbose) write(stdout,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' + + fail = test_reintegrate(verbose, 'Identity: 3 layer', & + 3, (/1.,2.,3./), (/-5.,2.,1./), & + 3, (/1.,2.,3./), (/-5.,2.,1./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(verbose, 'A: 3 layer to 2', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 2, (/3.,3./), (/-4.,2./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(verbose, 'A: 3 layer to 2 (deep)', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 2, (/3.,4./), (/-4.,2./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(verbose, 'A: 3 layer to 2 (shallow)', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 2, (/3.,2./), (/-4.,1.5/) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(verbose, 'B: 3 layer to 4 with vanished top/bottom', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 4, (/0.,3.,3.,0./), (/0.,-4.,2.,0./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(verbose, 'C: 3 layer to 4 with vanished top//middle/bottom', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 5, (/0.,3.,0.,3.,0./), (/0.,-4.,0.,2.,0./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(verbose, 'D: 3 layer to 3 (vanished)', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 3, (/0.,0.,0./), (/0.,0.,0./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3', & + 3, (/0.,0.,0./), (/-5.,2.,1./), & + 3, (/2.,2.,2./), (/0., 0., 0./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3 (vanished)', & + 3, (/0.,0.,0./), (/-5.,2.,1./), & + 3, (/0.,0.,0./), (/0., 0., 0./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3 (vanished)', & + 3, (/0.,0.,0./), (/0.,0.,0./), & + 3, (/0.,0.,0./), (/0., 0., 0./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + if (.not. remapping_unit_tests) write(stdout,*) 'Pass' + +end function remapping_unit_tests + +!> Returns true if any cell of u and u_true are not identical. Returns false otherwise. +logical function test_answer(verbose, n, u, u_true, label, tol) + logical, intent(in) :: verbose !< If true, write results to stdout + integer, intent(in) :: n !< Number of cells in u + real, dimension(n), intent(in) :: u !< Values to test [A] + real, dimension(n), intent(in) :: u_true !< Values to test against (correct answer) [A] + character(len=*), intent(in) :: label !< Message + real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A] + ! Local variables + real :: tolerance ! The tolerance for differences between u and u_true [A] + integer :: k + + tolerance = 0.0 ; if (present(tol)) tolerance = tol + test_answer = .false. + do k = 1, n + if (abs(u(k) - u_true(k)) > tolerance) test_answer = .true. + enddo + if (test_answer .or. verbose) then + write(stdout,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label + do k = 1, n + if (abs(u(k) - u_true(k)) > tolerance) then + write(stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' + write(stderr,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' + else + write(stdout,'(i4,1p2e24.16)') k,u(k),u_true(k) + endif + enddo + endif + +end function test_answer + +!> Returns true if a test of interpolate_column() produces the wrong answer +logical function test_interp(verbose, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest+1), intent(in) :: u_true !< Correct value at destination cell interfaces [A] + ! Local variables + real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces [A] + integer :: k + real :: error ! The difference between the evaluated and expected solutions [A] + + ! Interpolate from src to dest + call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, .true.) + + test_interp = .false. + do k=1,ndest+1 + if (u_dest(k)/=u_true(k)) test_interp = .true. + enddo + if (verbose .or. test_interp) then + write(stdout,'(2a)') ' Test: ',msg + write(stdout,'(a3,3(a24))') 'k','u_result','u_true','error' + do k=1,ndest+1 + error = u_dest(k)-u_true(k) + if (error==0.) then + write(stdout,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) + else + write(stdout,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' + write(stderr,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' + endif + enddo + endif +end function test_interp + +!> Returns true if a test of reintegrate_column() produces the wrong answer +logical function test_reintegrate(verbose, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff [A H] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff [A H] + ! Local variables + real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells [A H] + integer :: k + real :: error ! The difference between the evaluated and expected solutions [A H] + + ! Interpolate from src to dest + call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) + + test_reintegrate = .false. + do k=1,ndest + if (uh_dest(k)/=uh_true(k)) test_reintegrate = .true. + enddo + if (verbose .or. test_reintegrate) then + write(stdout,'(2a)') ' Test: ',msg + write(stdout,'(a3,3(a24))') 'k','uh_result','uh_true','error' + do k=1,ndest + error = uh_dest(k)-uh_true(k) + if (error==0.) then + write(stdout,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) + else + write(stdout,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' + write(stderr,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' + endif + enddo + endif +end function test_reintegrate + +!> Convenience function for printing grid to screen +subroutine dumpGrid(n,h,x,u) + integer, intent(in) :: n !< Number of cells + real, dimension(:), intent(in) :: h !< Cell thickness [H] + real, dimension(:), intent(in) :: x !< Interface delta [H] + real, dimension(:), intent(in) :: u !< Cell average values [A] + integer :: i + write(stdout,'("i=",20i10)') (i,i=1,n+1) + write(stdout,'("x=",20es10.2)') (x(i),i=1,n+1) + write(stdout,'("i=",5x,20i10)') (i,i=1,n) + write(stdout,'("h=",5x,20es10.2)') (h(i),i=1,n) + write(stdout,'("u=",5x,20es10.2)') (u(i),i=1,n) +end subroutine dumpGrid + +end module MOM_remapping diff --git a/ALE/P1M_functions.F90 b/ALE/P1M_functions.F90 new file mode 100644 index 0000000000..7889966135 --- /dev/null +++ b/ALE/P1M_functions.F90 @@ -0,0 +1,163 @@ +!> Linear interpolation functions +module P1M_functions + +! This file is part of MOM6. See LICENSE.md for the license. + +use regrid_edge_values, only : bound_edge_values, average_discontinuous_edge_values + +implicit none ; private + +! The following routines are visible to the outside world +public P1M_interpolation, P1M_boundary_extrapolation + +contains + +!> Linearly interpolate between edge values +!! +!! The resulting piecewise interpolant is stored in 'ppoly'. +!! See 'ppoly.F90' for a definition of this structure. +!! +!! The edge values MUST have been estimated prior to calling this routine. +!! +!! The estimated edge values must be limited to ensure monotonicity of the +!! interpolant. We also make sure that edge values are NOT discontinuous. +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine P1M_interpolation( N, h, u, edge_values, ppoly_coef, h_neglect, answer_date ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Potentially modified + !! piecewise polynomial coefficients, mainly [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Local variables + integer :: k ! loop index + real :: u0_l, u0_r ! edge values (left and right) [A] + + ! Bound edge values (routine found in 'edge_values.F90') + call bound_edge_values( N, h, u, edge_values, h_neglect, answer_date=answer_date ) + + ! Systematically average discontinuous edge values (routine found in + ! 'edge_values.F90') + call average_discontinuous_edge_values( N, edge_values ) + + ! Loop on interior cells to build interpolants + do k = 1,N + + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) + + ppoly_coef(k,1) = u0_l + ppoly_coef(k,2) = u0_r - u0_l + + enddo ! end loop on interior cells + +end subroutine P1M_interpolation + +!> Interpolation by linear polynomials within boundary cells +!! +!! The left and right edge values in the left and right boundary cells, +!! respectively, are estimated using a linear extrapolation within the cells. +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine P1M_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) + ! Arguments + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) [A] + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials [A] + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] + + ! Local variables + real :: u0, u1 ! cell averages [A] + real :: h0, h1 ! corresponding cell widths [H] + real :: slope ! retained PLM slope [A] + real :: u0_l, u0_r ! edge values [A] + + ! ----------------------------------------- + ! Left edge value in the left boundary cell + ! ----------------------------------------- + h0 = h(1) + h1 = h(2) + + u0 = u(1) + u1 = u(2) + + ! The standard PLM slope is computed as a first estimate for the + ! interpolation within the cell + slope = 2.0 * ( u1 - u0 ) + + ! The right edge value is then computed and we check whether this + ! right edge value is consistent: it cannot be larger than the edge + ! value in the neighboring cell if the data set is increasing. + ! If the right value is found to too large, the slope is further limited + ! by using the edge value in the neighboring cell. + u0_r = u0 + 0.5 * slope + + if ( (u1 - u0) * (edge_values(2,1) - u0_r) < 0.0 ) then + slope = 2.0 * ( edge_values(2,1) - u0 ) + endif + + ! Using the limited slope, the left edge value is reevaluated and + ! the interpolant coefficients recomputed + if ( h0 /= 0.0 ) then + edge_values(1,1) = u0 - 0.5 * slope + else + edge_values(1,1) = u0 + endif + + ppoly_coef(1,1) = edge_values(1,1) + ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) + + ! ------------------------------------------ + ! Right edge value in the left boundary cell + ! ------------------------------------------ + h0 = h(N-1) + h1 = h(N) + + u0 = u(N-1) + u1 = u(N) + + slope = 2.0 * ( u1 - u0 ) + + u0_l = u1 - 0.5 * slope + + if ( (u1 - u0) * (u0_l - edge_values(N-1,2)) < 0.0 ) then + slope = 2.0 * ( u1 - edge_values(N-1,2) ) + endif + + if ( h1 /= 0.0 ) then + edge_values(N,2) = u1 + 0.5 * slope + else + edge_values(N,2) = u1 + endif + + ppoly_coef(N,1) = edge_values(N,1) + ppoly_coef(N,2) = edge_values(N,2) - edge_values(N,1) + +end subroutine P1M_boundary_extrapolation + +!> \namespace p1m_functions +!! +!! Date of creation: 2008.06.09 +!! L. White +!! +!! This module contains p1m (linear) interpolation routines. +!! +!! p1m interpolation is performed by estimating the edge values and +!! linearly interpolating between them. +! +!! Once the edge values are estimated, the limiting process takes care of +!! ensuring that (1) edge values are bounded by neighboring cell averages +!! and (2) discontinuous edge values are averaged in order to provide a +!! fully continuous interpolant throughout the domain. This last step is +!! essential for the regridding problem to yield a unique solution. +!! Also, a routine is provided that takes care of linear extrapolation +!! within the boundary cells. + +end module P1M_functions diff --git a/ALE/P3M_functions.F90 b/ALE/P3M_functions.F90 new file mode 100644 index 0000000000..6039b197fb --- /dev/null +++ b/ALE/P3M_functions.F90 @@ -0,0 +1,588 @@ +!> Cubic interpolation functions +module P3M_functions + +! This file is part of MOM6. See LICENSE.md for the license. + +use regrid_edge_values, only : bound_edge_values, average_discontinuous_edge_values + +implicit none ; private + +public P3M_interpolation +public P3M_boundary_extrapolation + +real, parameter :: hNeglect_dflt = 1.E-30 !< Default value of a negligible cell thickness +real, parameter :: hNeglect_edge_dflt = 1.E-10 !< Default value of a negligible edge thickness + +contains + +!> Set up a piecewise cubic interpolation from cell averages and estimated +!! edge slopes and values +!! +!! Cubic interpolation between edges. +!! +!! The edge values and slopes MUST have been estimated prior to calling +!! this routine. +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine P3M_interpolation( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answer_date ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1]. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Call the limiter for p3m, which takes care of everything from + ! computing the coefficients of the cubic to monotonizing it. + ! This routine could be called directly instead of having to call + ! 'P3M_interpolation' first but we do that to provide an homogeneous + ! interface. + call P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, & + answer_date=answer_date ) + +end subroutine P3M_interpolation + +!> Adust a piecewise cubic reconstruction with a limiter that adjusts the edge +!! values and slopes +!! +!! The p3m limiter operates as follows: +!! +!! 1. Edge values are bounded +!! 2. Discontinuous edge values are systematically averaged +!! 3. Loop on cells and do the following +!! a. Build cubic curve +!! b. Check if cubic curve is monotonic +!! c. If not, monotonize cubic curve and rebuild it +!! +!! Step 3 of the monotonization process leaves all edge values unchanged. +subroutine P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answer_date ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Local variables + integer :: k ! loop index + logical :: monotonic ! boolean indicating whether the cubic is monotonic + real :: u0_l, u0_r ! edge values [A] + real :: u1_l, u1_r ! edge slopes [A H-1] + real :: u_l, u_c, u_r ! left, center and right cell averages [A] + real :: h_l, h_c, h_r ! left, center and right cell widths [H] + real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes [A H-1] + real :: slope ! retained PLM slope [A H-1] + real :: eps + real :: hNeglect ! A negligibly small thickness [H] + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + eps = 1e-10 + + ! 1. Bound edge values (boundary cells are assumed to be local extrema) + call bound_edge_values( N, h, u, edge_values, hNeglect, answer_date=answer_date ) + + ! 2. Systematically average discontinuous edge values + call average_discontinuous_edge_values( N, edge_values ) + + + ! 3. Loop on cells and do the following + ! (a) Build cubic curve + ! (b) Check if cubic curve is monotonic + ! (c) If not, monotonize cubic curve and rebuild it + do k = 1,N + + ! Get edge values, edge slopes and cell width + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) + u1_l = ppoly_S(k,1) + u1_r = ppoly_S(k,2) + + ! Get cell widths and cell averages (boundary cells are assumed to + ! be local extrema for the sake of slopes) + u_c = u(k) + h_c = h(k) + + if ( k == 1 ) then + h_l = h(k) + u_l = u(k) + else + h_l = h(k-1) + u_l = u(k-1) + endif + + if ( k == N ) then + h_r = h(k) + u_r = u(k) + else + h_r = h(k+1) + u_r = u(k+1) + endif + + ! Compute limited slope + sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) + sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) + sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) + + if ( (sigma_l * sigma_r) > 0.0 ) then + slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) + else + slope = 0.0 + endif + + ! If the slopes are small, set them to zero to prevent asymmetric representation near extrema. + if ( abs(u1_l*h_c) < epsilon(u_c)*abs(u_c) ) u1_l = 0.0 + if ( abs(u1_r*h_c) < epsilon(u_c)*abs(u_c) ) u1_r = 0.0 + + ! The edge slopes are limited from above by the respective + ! one-sided slopes + if ( abs(u1_l) > abs(sigma_l) ) then + u1_l = sigma_l + endif + + if ( abs(u1_r) > abs(sigma_r) ) then + u1_r = sigma_r + endif + + ! Build cubic interpolant (compute the coefficients) + call build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) + + ! Check whether cubic is monotonic + monotonic = is_cubic_monotonic( ppoly_coef, k ) + + ! If cubic is not monotonic, monotonize it by modifiying the + ! edge slopes, store the new edge slopes and recompute the + ! cubic coefficients + if ( .not.monotonic ) then + call monotonize_cubic( h_c, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) + endif + + ! Store edge slopes + ppoly_S(k,1) = u1_l + ppoly_S(k,2) = u1_r + + ! Recompute coefficients of cubic + call build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) + + enddo ! loop on cells + +end subroutine P3M_limiter + + +!> Calculate the edge values and slopes at boundary cells as part of building a +!! piecewise cubic sub-grid scale profiles +!! +!! The following explanations apply to the left boundary cell. The same +!! reasoning holds for the right boundary cell. +!! +!! A cubic needs to be built in the cell and requires four degrees of freedom, +!! which are the edge values and slopes. The right edge values and slopes are +!! taken to be that of the neighboring cell (i.e., the left edge value and slope +!! of the neighboring cell). The left edge value and slope are determined by +!! computing the parabola based on the cell average and the right edge value +!! and slope. The resulting cubic is not necessarily monotonic and the slopes +!! are subsequently modified to yield a monotonic cubic. +subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef, & + h_neglect, h_neglect_edge ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions [H] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of finding edge values [H] + ! Local variables + integer :: i0, i1 + logical :: monotonic ! boolean indicating whether the cubic is monotonic + real :: u0, u1 ! Values of u in two adjacent cells [A] + real :: h0, h1 ! Values of h in two adjacent cells, plus a smal increment [H] + real :: b, c, d ! Temporary variables [A] + real :: u0_l, u0_r ! Left and right edge values [A] + real :: u1_l, u1_r ! Left and right edge slopes [A H-1] + real :: slope ! The cell center slope [A H-1] + real :: hNeglect, hNeglect_edge ! Negligibly small thickness [H] + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect_edge = hNeglect_edge_dflt ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge + + ! ----- Left boundary ----- + i0 = 1 + i1 = 2 + h0 = h(i0) + hNeglect_edge + h1 = h(i1) + hNeglect_edge + u0 = u(i0) + u1 = u(i1) + + ! Compute the left edge slope in neighboring cell and express it in + ! the global coordinate system + b = ppoly_coef(i1,2) + u1_r = b / h1 ! derivative evaluated at xi = 0.0, expressed w.r.t. x + + ! Limit the right slope by the PLM limited slope + slope = 2.0 * ( u1 - u0 ) / ( h0 + hNeglect ) + if ( abs(u1_r) > abs(slope) ) then + u1_r = slope + endif + + ! The right edge value in the boundary cell is taken to be the left + ! edge value in the neighboring cell + u0_r = edge_values(i1,1) + + ! Given the right edge value and slope, we determine the left + ! edge value and slope by computing the parabola as determined by + ! the right edge value and slope and the boundary cell average + u0_l = 3.0 * u0 + 0.5 * h0*u1_r - 2.0 * u0_r + u1_l = ( - 6.0 * u0 - 2.0 * h0*u1_r + 6.0 * u0_r) / ( h0 + hNeglect ) + + ! Check whether the edge values are monotonic. For example, if the left edge + ! value is larger than the right edge value while the slope is positive, the + ! edge values are inconsistent and we need to modify the left edge value + if ( (u0_r-u0_l) * slope < 0.0 ) then + u0_l = u0_r + u1_l = 0.0 + u1_r = 0.0 + endif + + ! Store edge values and slope, build cubic and check monotonicity + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r + ppoly_S(i0,1) = u1_l + ppoly_S(i0,2) = u1_r + + ! Store edge values and slope, build cubic and check monotonicity + call build_cubic_interpolant( h, i0, edge_values, ppoly_S, ppoly_coef ) + monotonic = is_cubic_monotonic( ppoly_coef, i0 ) + + if ( .not.monotonic ) then + call monotonize_cubic( h0, u0_l, u0_r, 0.0, slope, slope, u1_l, u1_r ) + + ! Rebuild cubic after monotonization + ppoly_S(i0,1) = u1_l + ppoly_S(i0,2) = u1_r + call build_cubic_interpolant( h, i0, edge_values, ppoly_S, ppoly_coef ) + + endif + + ! ----- Right boundary ----- + i0 = N-1 + i1 = N + h0 = h(i0) + hNeglect_edge + h1 = h(i1) + hNeglect_edge + u0 = u(i0) + u1 = u(i1) + + ! Compute the right edge slope in neighboring cell and express it in + ! the global coordinate system + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + d = ppoly_coef(i0,4) + u1_l = (b + 2*c + 3*d) / ( h0 + hNeglect ) ! derivative evaluated at xi = 1.0 + + ! Limit the left slope by the PLM limited slope + slope = 2.0 * ( u1 - u0 ) / ( h1 + hNeglect ) + if ( abs(u1_l) > abs(slope) ) then + u1_l = slope + endif + + ! The left edge value in the boundary cell is taken to be the right + ! edge value in the neighboring cell + u0_l = edge_values(i0,2) + + ! Given the left edge value and slope, we determine the right + ! edge value and slope by computing the parabola as determined by + ! the left edge value and slope and the boundary cell average + u0_r = 3.0 * u1 - 0.5 * h1*u1_l - 2.0 * u0_l + u1_r = ( 6.0 * u1 - 2.0 * h1*u1_l - 6.0 * u0_l) / ( h1 + hNeglect ) + + ! Check whether the edge values are monotonic. For example, if the right edge + ! value is smaller than the left edge value while the slope is positive, the + ! edge values are inconsistent and we need to modify the right edge value + if ( (u0_r-u0_l) * slope < 0.0 ) then + u0_r = u0_l + u1_l = 0.0 + u1_r = 0.0 + endif + + ! Store edge values and slope, build cubic and check monotonicity + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r + ppoly_S(i1,1) = u1_l + ppoly_S(i1,2) = u1_r + + call build_cubic_interpolant( h, i1, edge_values, ppoly_S, ppoly_coef ) + monotonic = is_cubic_monotonic( ppoly_coef, i1 ) + + if ( .not.monotonic ) then + call monotonize_cubic( h1, u0_l, u0_r, slope, 0.0, slope, u1_l, u1_r ) + + ! Rebuild cubic after monotonization + ppoly_S(i1,1) = u1_l + ppoly_S(i1,2) = u1_r + call build_cubic_interpolant( h, i1, edge_values, ppoly_S, ppoly_coef ) + + endif + +end subroutine P3M_boundary_extrapolation + + +!> Build cubic interpolant in cell k +!! +!! Given edge values and edge slopes, compute coefficients of cubic in cell k. +!! +!! NOTE: edge values and slopes MUST have been properly calculated prior to +!! calling this routine. +subroutine build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + integer, intent(in) :: k !< The index of the cell to work on + real, dimension(:,:), intent(in) :: edge_values !< Edge value of polynomial in arbitrary units [A] + real, dimension(:,:), intent(in) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] + + ! Local variables + real :: u0_l, u0_r ! edge values [A] + real :: u1_l, u1_r ! edge slopes times the cell width [A] + real :: h_c ! cell width [H] + real :: a0, a1, a2, a3 ! cubic coefficients [A] + + h_c = h(k) + + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) + + u1_l = ppoly_S(k,1) * h_c + u1_r = ppoly_S(k,2) * h_c + + a0 = u0_l + a1 = u1_l + a2 = 3.0 * ( u0_r - u0_l ) - u1_r - 2.0 * u1_l + a3 = u1_r + u1_l + 2.0 * ( u0_l - u0_r ) + + ppoly_coef(k,1) = a0 + ppoly_coef(k,2) = a1 + ppoly_coef(k,3) = a2 + ppoly_coef(k,4) = a3 + +end subroutine build_cubic_interpolant + + +!> Check whether the cubic reconstruction in cell k is monotonic +!! +!! This function checks whether the cubic curve in cell k is monotonic. +!! If so, returns 1. Otherwise, returns 0. +!! +!! The cubic is monotonic if the first derivative is single-signed in (0,1). +!! Hence, we check whether the roots (if any) lie inside this interval. If there +!! is no root or if both roots lie outside this interval, the cubic is monotonic. +logical function is_cubic_monotonic( ppoly_coef, k ) + real, dimension(:,:), intent(in) :: ppoly_coef !< Coefficients of cubic polynomial in arbitrary units [A] + integer, intent(in) :: k !< The index of the cell to work on + ! Local variables + real :: a, b, c ! Coefficients of the first derivative of the cubic [A] + + a = ppoly_coef(k,2) + b = 2.0 * ppoly_coef(k,3) + c = 3.0 * ppoly_coef(k,4) + + ! Look for real roots of the quadratic derivative equation, c*x**2 + b*x + a = 0, in (0, 1) + if (b*b - 4.0*a*c <= 0.0) then ! The cubic is monotonic everywhere. + is_cubic_monotonic = .true. + elseif (a * (a + (b + c)) < 0.0) then ! The derivative changes sign between the endpoints of (0, 1) + is_cubic_monotonic = .false. + elseif (b * (b + 2.0*c) < 0.0) then ! The second derivative changes sign inside of (0, 1) + is_cubic_monotonic = .false. + else + is_cubic_monotonic = .true. + endif + +end function is_cubic_monotonic + +!> Monotonize a cubic curve by modifying the edge slopes. +!! +!! This routine takes care of monotonizing a cubic on [0,1] by modifying the +!! edge slopes. The edge values are NOT modified. The cubic is entirely +!! determined by the four degrees of freedom u0_l, u0_r, u1_l and u1_r. +!! +!! u1_l and u1_r are the edge slopes expressed in the GLOBAL coordinate system. +!! +!! The monotonization occurs as follows. +! +!! 1. The edge slopes are set to 0 if they are inconsistent with the limited +!! PLM slope +!! 2. We check whether we can find an inflexion point in [0,1]. At most one +!! inflexion point may exist. +!! a. If there is no inflexion point, the cubic is monotonic. +!! b. If there is one inflexion point and it lies outside [0,1], the +!! cubic is monotonic. +!! c. If there is one inflexion point and it lies in [0,1] and the slope +!! at the location of the inflexion point is consistent, the cubic +!! is monotonic. +!! d. If the inflexion point lies in [0,1] but the slope is inconsistent, +!! we go to (3) to shift the location of the inflexion point to the left +!! or to the right. To the left when the 2nd-order left slope is smaller +!! than the 2nd order right slope. +!! 3. Edge slopes are modified to shift the inflexion point, either onto the left +!! edge or onto the right edge. + +subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) + real, intent(in) :: h !< cell width [H] + real, intent(in) :: u0_l !< left edge value in arbitrary units [A] + real, intent(in) :: u0_r !< right edge value [A] + real, intent(in) :: sigma_l !< left 2nd-order slopes [A H-1] + real, intent(in) :: sigma_r !< right 2nd-order slopes [A H-1] + real, intent(in) :: slope !< limited PLM slope [A H-1] + real, intent(inout) :: u1_l !< left edge slopes [A H-1] + real, intent(inout) :: u1_r !< right edge slopes [A H-1] + ! Local variables + logical :: found_ip + logical :: inflexion_l ! bool telling if inflex. pt must be on left + logical :: inflexion_r ! bool telling if inflex. pt must be on right + real :: a1, a2, a3 ! Temporary slopes times the cell width [A] + real :: u1_l_tmp ! trial left edge slope [A H-1] + real :: u1_r_tmp ! trial right edge slope [A H-1] + real :: xi_ip ! location of inflexion point in cell coordinates (0,1) [nondim] + real :: slope_ip ! slope at inflexion point times cell width [A] + + found_ip = .false. + inflexion_l = .false. + inflexion_r = .false. + + ! If the edge slopes are inconsistent w.r.t. the limited PLM slope, + ! set them to zero + if ( u1_l*slope <= 0.0 ) then + u1_l = 0.0 + endif + + if ( u1_r*slope <= 0.0 ) then + u1_r = 0.0 + endif + + ! Compute the location of the inflexion point, which is the root + ! of the second derivative + a1 = h * u1_l + a2 = 3.0 * ( u0_r - u0_l ) - h*(u1_r + 2.0*u1_l) + a3 = h*(u1_r + u1_l) + 2.0*(u0_l - u0_r) + + ! There is a possible root (and inflexion point) only if a3 is nonzero. + ! When a3 is zero, the second derivative of the cubic is constant (the + ! cubic degenerates into a parabola) and no inflexion point exists. + if ( a3 /= 0.0 ) then + ! Location of inflexion point + xi_ip = - a2 / (3.0 * a3) + + ! If the inflexion point lies in [0,1], change boolean value + if ( (xi_ip >= 0.0) .AND. (xi_ip <= 1.0) ) then + found_ip = .true. + endif + endif + + ! When there is an inflexion point within [0,1], check the slope + ! to see if it is consistent with the limited PLM slope. If not, + ! decide on which side we want to collapse the inflexion point. + ! If the inflexion point lies on one of the edges, the cubic is + ! guaranteed to be monotonic + if ( found_ip ) then + slope_ip = a1 + 2.0*a2*xi_ip + 3.0*a3*xi_ip*xi_ip + + ! Check whether slope is consistent + if ( slope_ip*slope < 0.0 ) then + if ( abs(sigma_l) < abs(sigma_r) ) then + inflexion_l = .true. + else + inflexion_r = .true. + endif + endif + endif ! found_ip + + ! At this point, if the cubic is not monotonic, we know where the + ! inflexion point should lie. When the cubic is monotonic, both + ! 'inflexion_l' and 'inflexion_r' are false and nothing is to be done. + + ! Move inflexion point on the left + if ( inflexion_l ) then + + u1_l_tmp = 1.5*(u0_r-u0_l)/h - 0.5*u1_r + u1_r_tmp = 3.0*(u0_r-u0_l)/h - 2.0*u1_l + + if ( (u1_l_tmp*slope < 0.0) .AND. (u1_r_tmp*slope < 0.0) ) then + + u1_l = 0.0 + u1_r = 3.0 * (u0_r - u0_l) / h + + elseif (u1_l_tmp*slope < 0.0) then + + u1_r = u1_r_tmp + u1_l = 1.5*(u0_r - u0_l)/h - 0.5*u1_r + + elseif (u1_r_tmp*slope < 0.0) then + + u1_l = u1_l_tmp + u1_r = 3.0*(u0_r - u0_l)/h - 2.0*u1_l + + else + + u1_l = u1_l_tmp + u1_r = u1_r_tmp + + endif + + endif ! end treating case with inflexion point on the left + + ! Move inflexion point on the right + if ( inflexion_r ) then + + u1_l_tmp = 3.0*(u0_r-u0_l)/h - 2.0*u1_r + u1_r_tmp = 1.5*(u0_r-u0_l)/h - 0.5*u1_l + + if ( (u1_l_tmp*slope < 0.0) .AND. (u1_r_tmp*slope < 0.0) ) then + + u1_l = 3.0 * (u0_r - u0_l) / h + u1_r = 0.0 + + elseif (u1_l_tmp*slope < 0.0) then + + u1_r = u1_r_tmp + u1_l = 3.0*(u0_r - u0_l)/h - 2.0*u1_r + + elseif (u1_r_tmp*slope < 0.0) then + + u1_l = u1_l_tmp + u1_r = 1.5*(u0_r - u0_l)/h - 0.5*u1_l + + else + + u1_l = u1_l_tmp + u1_r = u1_r_tmp + + endif + + endif ! end treating case with inflexion point on the right + + ! Zero out negligibly small slopes. + if ( abs(u1_l*h) < epsilon(u0_l) * (abs(u0_l) + abs(u0_r)) ) u1_l = 0.0 + if ( abs(u1_r*h) < epsilon(u0_l) * (abs(u0_l) + abs(u0_r)) ) u1_r = 0.0 + +end subroutine monotonize_cubic + +!> \namespace p3m_functions +!! +!! Date of creation: 2008.06.09 +!! L. White +!! +!! This module contains p3m interpolation routines. +!! +!! p3m interpolation is performed by estimating the edge values and slopes +!! and constructing a cubic polynomial. We then make sure that the edge values +!! are bounded and continuous and we then modify the slopes to get a monotonic +!! cubic curve. + +end module P3M_functions diff --git a/ALE/PCM_functions.F90 b/ALE/PCM_functions.F90 new file mode 100644 index 0000000000..f5899339e4 --- /dev/null +++ b/ALE/PCM_functions.F90 @@ -0,0 +1,48 @@ +!> Piecewise constant reconstruction functions +module PCM_functions + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public PCM_reconstruction + +contains + +!> Reconstruction by constant polynomials within each cell. There is nothing to +!! do but this routine is provided to ensure a homogeneous interface +!! throughout the regridding toolbox. +!! +!! It is assumed that the dimension of 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed. +subroutine PCM_reconstruction( N, u, edge_values, ppoly_coef ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: u !< cell averages in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial, + !! with the same units as u [A]. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, + !! with the same units as u [A]. + + ! Local variables + integer :: k + + ! The coefficients of the piecewise constant polynomial are simply + ! the cell averages. + ppoly_coef(:,1) = u(:) + + ! The edge values are equal to the cell average + do k = 1,N + edge_values(k,:) = u(k) + enddo + +end subroutine PCM_reconstruction + +!> \namespace PCM_functions +!! +!! Date of creation: 2008.06.06 +!! L. White +!! +!! This module contains routines that handle one-dimensional finite volume +!! reconstruction using the piecewise constant method (PCM). + +end module PCM_functions diff --git a/ALE/PLM_functions.F90 b/ALE/PLM_functions.F90 new file mode 100644 index 0000000000..c0c4516fe2 --- /dev/null +++ b/ALE/PLM_functions.F90 @@ -0,0 +1,317 @@ +!> Piecewise linear reconstruction functions +module PLM_functions + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public PLM_boundary_extrapolation +public PLM_extrapolate_slope +public PLM_monotonized_slope +public PLM_reconstruction +public PLM_slope_wa +public PLM_slope_cw + +real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness + +contains + +!> Returns a limited PLM slope following White and Adcroft, 2008, in the same arbitrary +!! units [A] as the input values. +!! Note that this is not the same as the Colella and Woodward method. +real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_r !< Thickness of right cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + ! Local variables + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! Quasi-second order difference + sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + h_neglect) ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_wa = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_wa = 0.0 + endif + + ! This block tests to see if roundoff causes edge values to be out of bounds + if (u_c - 0.5*abs(PLM_slope_wa) < u_min .or. u_c + 0.5*abs(PLM_slope_wa) > u_max) then + PLM_slope_wa = PLM_slope_wa * ( 1. - epsilon(PLM_slope_wa) ) + endif + + ! An attempt to avoid inconsistency when the values become unrepresentable. + ! ### The following 1.E-140 is dimensionally inconsistent. A newer version of + ! PLM is progress that will avoid the need for such rounding. + if (abs(PLM_slope_wa) < 1.E-140) PLM_slope_wa = 0. + +end function PLM_slope_wa + +!> Returns a limited PLM slope following Colella and Woodward 1984, in the same +!! arbitrary units as the input values [A]. +real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_r !< Thickness of right cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + ! Local variables + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: h_cn ! Thickness of center cell [H] + + h_cn = h_c + h_neglect + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = ( h_c / ( h_cn + ( h_l + h_r ) ) ) * ( & + ( 2.*h_l + h_c ) / ( h_r + h_cn ) * sigma_r & + + ( 2.*h_r + h_c ) / ( h_l + h_cn ) * sigma_l ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_cw = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_cw = 0.0 + endif + + ! This block tests to see if roundoff causes edge values to be out of bounds + if (u_c - 0.5*abs(PLM_slope_cw) < u_min .or. u_c + 0.5*abs(PLM_slope_cw) > u_max) then + PLM_slope_cw = PLM_slope_cw * ( 1. - epsilon(PLM_slope_cw) ) + endif + + ! An attempt to avoid inconsistency when the values become unrepresentable. + ! ### The following 1.E-140 is dimensionally inconsistent. A newer version of + ! PLM is progress that will avoid the need for such rounding. + if (abs(PLM_slope_cw) < 1.E-140) PLM_slope_cw = 0. + +end function PLM_slope_cw + +!> Returns a limited PLM slope following Colella and Woodward 1984, in the same +!! arbitrary units as the input values [A]. +real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + real, intent(in) :: s_l !< PLM slope of left cell [A] + real, intent(in) :: s_c !< PLM slope of center cell [A] + real, intent(in) :: s_r !< PLM slope of right cell [A] + ! Local variables + real :: e_r, e_l, edge ! Right, left and temporary edge values [A] + real :: almost_two ! The number 2, almost [nondim] + real :: slp ! Magnitude of PLM central slope [A] + + almost_two = 2. * ( 1. - epsilon(s_c) ) + + ! Edge values of neighbors abutting this cell + e_r = u_l + 0.5*s_l + e_l = u_r - 0.5*s_r + slp = abs(s_c) + + ! Check that left edge is between right edge of cell to the left and this cell mean + edge = u_c - 0.5 * s_c + if ( ( edge - e_r ) * ( u_c - edge ) < 0. ) then + edge = 0.5 * ( edge + e_r ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + ! Check that right edge is between left edge of cell to the right and this cell mean + edge = u_c + 0.5 * s_c + if ( ( edge - u_c ) * ( e_l - edge ) < 0. ) then + edge = 0.5 * ( edge + e_l ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + PLM_monotonized_slope = sign( slp, s_c ) + +end function PLM_monotonized_slope + +!> Returns a PLM slope using h2 extrapolation from a cell to the left, in the same +!! arbitrary units as the input values [A]. +!! Use the negative to extrapolate from the cell to the right. +real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c) + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + ! Local variables + real :: left_edge ! Left edge value [A] + real :: hl, hc ! Left and central cell thicknesses [H] + + ! Avoid division by zero for vanished cells + hl = h_l + h_neglect + hc = h_c + h_neglect + + ! The h2 scheme is used to compute the left edge value + left_edge = (u_l*hc + u_c*hl) / (hl + hc) + + PLM_extrapolate_slope = 2.0 * ( u_c - left_edge ) + +end function PLM_extrapolate_slope + + +!> Reconstruction by linear polynomials within each cell +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials, + !! with the same units as u [A]. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u [A]. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h [H] + + ! Local variables + integer :: k ! loop index + real :: u_l, u_r ! left and right cell averages [A] + real :: slope ! retained PLM slope for a normalized cell width [A] + real :: e_r ! The edge value in the neighboring cell [A] + real :: edge ! The projected edge value in the cell [A] + real :: almost_one ! A value that is slightly smaller than 1 [nondim] + real, dimension(N) :: slp ! The first guess at the normalized tracer slopes [A] + real, dimension(N) :: mslp ! The monotonized normalized tracer slopes [A] + real :: hNeglect ! A negligibly small width used in cell reconstructions [H] + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + almost_one = 1. - epsilon(slope) + + ! Loop on interior cells + do k = 2,N-1 + slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), hNeglect, u(k-1), u(k), u(k+1)) + enddo ! end loop on interior cells + + ! Boundary cells use PCM. Extrapolation is handled after monotonization. + slp(1) = 0. + slp(N) = 0. + + ! This loop adjusts the slope so that edge values are monotonic. + do K = 2, N-1 + mslp(k) = PLM_monotonized_slope( u(k-1), u(k), u(k+1), slp(k-1), slp(k), slp(k+1) ) + enddo ! end loop on interior cells + mslp(1) = 0. + mslp(N) = 0. + + ! Store and return edge values and polynomial coefficients. + edge_values(1,1) = u(1) + edge_values(1,2) = u(1) + ppoly_coef(1,1) = u(1) + ppoly_coef(1,2) = 0. + do k = 2, N-1 + slope = mslp(k) + u_l = u(k) - 0.5 * slope ! Left edge value of cell k + u_r = u(k) + 0.5 * slope ! Right edge value of cell k + + edge_values(k,1) = u_l + edge_values(k,2) = u_r + ppoly_coef(k,1) = u_l + ppoly_coef(k,2) = ( u_r - u_l ) + ! Check to see if this evaluation of the polynomial at x=1 would be + ! monotonic w.r.t. the next cell's edge value. If not, scale back! + edge = ppoly_coef(k,2) + ppoly_coef(k,1) + e_r = u(k+1) - 0.5 * sign( mslp(k+1), slp(k+1) ) + if ( (edge-u(k))*(e_r-edge)<0.) then + ppoly_coef(k,2) = ppoly_coef(k,2) * almost_one + endif + enddo + edge_values(N,1) = u(N) + edge_values(N,2) = u(N) + ppoly_coef(N,1) = u(N) + ppoly_coef(N,2) = 0. + +end subroutine PLM_reconstruction + + +!> Reconstruction by linear polynomials within boundary cells +!! +!! The left and right edge values in the left and right boundary cells, +!! respectively, are estimated using a linear extrapolation within the cells. +!! +!! This extrapolation is EXACT when the underlying profile is linear. +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials, + !! with the same units as u [A]. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u [A]. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h [H] + ! Local variables + real :: slope ! retained PLM slope for a normalized cell width [A] + real :: hNeglect ! A negligibly small width used in cell reconstructions [H] + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + ! Extrapolate from 2 to 1 to estimate slope + slope = - PLM_extrapolate_slope( h(2), h(1), hNeglect, u(2), u(1) ) + + edge_values(1,1) = u(1) - 0.5 * slope + edge_values(1,2) = u(1) + 0.5 * slope + + ppoly_coef(1,1) = edge_values(1,1) + ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) + + ! Extrapolate from N-1 to N to estimate slope + slope = PLM_extrapolate_slope( h(N-1), h(N), hNeglect, u(N-1), u(N) ) + + edge_values(N,1) = u(N) - 0.5 * slope + edge_values(N,2) = u(N) + 0.5 * slope + + ppoly_coef(N,1) = edge_values(N,1) + ppoly_coef(N,2) = edge_values(N,2) - edge_values(N,1) + +end subroutine PLM_boundary_extrapolation + +!> \namespace plm_functions +!! +!! Date of creation: 2008.06.06 +!! L. White +!! +!! This module contains routines that handle one-dimensional finite volume +!! reconstruction using the piecewise linear method (PLM). + +end module PLM_functions diff --git a/ALE/PPM_functions.F90 b/ALE/PPM_functions.F90 new file mode 100644 index 0000000000..ef6841f635 --- /dev/null +++ b/ALE/PPM_functions.F90 @@ -0,0 +1,318 @@ +!> Provides functions used with the Piecewise-Parabolic-Method in the vertical ALE algorithm. +module PPM_functions + +! This file is part of MOM6. See LICENSE.md for the license. + +! First version was created by Laurent White, June 2008. +! Substantially re-factored January 2016. + +!! @todo Re-factor PPM_boundary_extrapolation to give round-off safe and +!! optimization independent results. + +use regrid_edge_values, only : bound_edge_values, check_discontinuous_edge_values + +implicit none ; private + +public PPM_reconstruction, PPM_boundary_extrapolation, PPM_monotonicity + +!> A tiny width that is so small that adding it to cell widths does not +!! change the value due to a computational representation. It is used +!! to avoid division by zero. +!! @note This is a dimensional parameter and should really include a unit +!! conversion. +real, parameter :: hNeglect_dflt = 1.E-30 + +contains + +!> Builds quadratic polynomials coefficients from cell mean and edge values. +subroutine PPM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect, answer_date) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< Cell widths [H] + real, dimension(N), intent(in) :: u !< Cell averages in arbitrary coordinates [A] + real, dimension(N,2), intent(inout) :: edge_values !< Edge values [A] + real, dimension(N,3), intent(inout) :: ppoly_coef !< Polynomial coefficients, mainly [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Local variables + integer :: k ! Loop index + real :: edge_l, edge_r ! Edge values (left and right) [A] + + ! PPM limiter + call PPM_limiter_standard( N, h, u, edge_values, h_neglect, answer_date=answer_date ) + + ! Loop over all cells + do k = 1,N + + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) + + ! Store polynomial coefficients + ppoly_coef(k,1) = edge_l + ppoly_coef(k,2) = 4.0 * ( u(k) - edge_l ) + 2.0 * ( u(k) - edge_r ) + ppoly_coef(k,3) = 3.0 * ( ( edge_r - u(k) ) + ( edge_l - u(k) ) ) + + enddo + +end subroutine PPM_reconstruction + +!> Adjusts edge values using the standard PPM limiter (Colella & Woodward, JCP 1984) +!! after first checking that the edge values are bounded by neighbors cell averages +!! and that the edge values are monotonic between cell averages. +subroutine PPM_limiter_standard( N, h, u, edge_values, h_neglect, answer_date ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Local variables + integer :: k ! Loop index + real :: u_l, u_c, u_r ! Cell averages (left, center and right) [A] + real :: edge_l, edge_r ! Edge values (left and right) [A] + real :: expr1, expr2 ! Temporary expressions [A2] + + ! Bound edge values + call bound_edge_values( N, h, u, edge_values, h_neglect, answer_date=answer_date ) + + ! Make discontinuous edge values monotonic + call check_discontinuous_edge_values( N, u, edge_values ) + + ! Loop on interior cells to apply the standard + ! PPM limiter (Colella & Woodward, JCP 84) + do k = 2,N-1 + + ! Get cell averages + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) + + if ( (u_r - u_c)*(u_c - u_l) <= 0.0) then + ! Flatten extremum + edge_l = u_c + edge_r = u_c + else + expr1 = 3.0 * (edge_r - edge_l) * ( (u_c - edge_l) + (u_c - edge_r)) + expr2 = (edge_r - edge_l) * (edge_r - edge_l) + if ( expr1 > expr2 ) then + ! Place extremum at right edge of cell by adjusting left edge value + edge_l = u_c + 2.0 * ( u_c - edge_r ) + edge_l = max( min( edge_l, max(u_l, u_c) ), min(u_l, u_c) ) ! In case of round off + elseif ( expr1 < -expr2 ) then + ! Place extremum at left edge of cell by adjusting right edge value + edge_r = u_c + 2.0 * ( u_c - edge_l ) + edge_r = max( min( edge_r, max(u_r, u_c) ), min(u_r, u_c) ) ! In case of round off + endif + endif + ! This checks that the difference in edge values is representable + ! and avoids overshoot problems due to round off. + !### The 1.e-60 needs to have units of [A], so this dimensionally inconsistent. + if ( abs( edge_r - edge_l ) Adjusts edge values using the original monotonicity constraint (Colella & Woodward, JCP 1984) +!! Based on hybgen_ppm_coefs +subroutine PPM_monotonicity( N, u, edge_values ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] + + ! Local variables + integer :: k ! Loop index + real :: a6, da ! Normalized scalar curvature and slope [A] + + ! Loop on interior cells to impose monotonicity + ! Eq. 1.10 of (Colella & Woodward, JCP 84) + do k = 2,N-1 + if (((u(k+1)-u(k))*(u(k)-u(k-1)) <= 0.)) then !local extremum + edge_values(k,1) = u(k) + edge_values(k,2) = u(k) + else + da = edge_values(k,2)-edge_values(k,1) + a6 = 6.0*u(k) - 3.0*(edge_values(k,1)+edge_values(k,2)) + if (da*a6 > da*da) then !peak in right half of zone + edge_values(k,1) = 3.0*u(k) - 2.0*edge_values(k,2) + elseif (da*a6 < -da*da) then !peak in left half of zone + edge_values(k,2) = 3.0*u(k) - 2.0*edge_values(k,1) + endif + endif + enddo ! end loop on interior cells + +end subroutine PPM_monotonicity + +!------------------------------------------------------------------------------ +!> Reconstruction by parabolas within boundary cells +subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_neglect) +!------------------------------------------------------------------------------ +! Reconstruction by parabolas within boundary cells. +! +! The following explanations apply to the left boundary cell. The same +! reasoning holds for the right boundary cell. +! +! A parabola needs to be built in the cell and requires three degrees of +! freedom, which are the right edge value and slope and the cell average. +! The right edge values and slopes are taken to be that of the neighboring +! cell (i.e., the left edge value and slope of the neighboring cell). +! The resulting parabola is not necessarily monotonic and the traditional +! PPM limiter is used to modify one of the edge values in order to yield +! a monotonic parabola. +! +! N: number of cells in grid +! h: thicknesses of grid cells +! u: cell averages to use in constructing piecewise polynomials +! edge_values : edge values of piecewise polynomials +! ppoly_coef : coefficients of piecewise polynomials +! +! It is assumed that the size of the array 'u' is equal to the number of cells +! defining 'grid' and 'ppoly'. No consistency check is performed here. +!------------------------------------------------------------------------------ + + ! Arguments + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) [A] + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials [A] + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions [H] + + ! Local variables + integer :: i0, i1 + real :: u0, u1 ! Average concentrations in the two neighboring cells [A] + real :: h0, h1 ! Thicknesses of the two neighboring cells [H] + real :: a, b, c ! An edge value, normalized slope and normalized curvature + ! of a reconstructed distribution [A] + real :: u0_l, u0_r ! Edge values of a neighboring cell [A] + real :: u1_l, u1_r ! Neighboring cell slopes renormalized by the thickness of + ! the cell being worked on [A] + real :: slope ! The normalized slope [A] + real :: exp1, exp2 ! Temporary expressions [A2] + real :: hNeglect ! A negligibly small width used in cell reconstructions [H] + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + ! ----- Left boundary ----- + i0 = 1 + i1 = 2 + h0 = h(i0) + h1 = h(i1) + u0 = u(i0) + u1 = u(i1) + + ! Compute the left edge slope in neighboring cell and express it in + ! the global coordinate system + b = ppoly_coef(i1,2) + u1_r = b *((h0+hNeglect)/(h1+hNeglect)) ! derivative evaluated at xi = 0.0, + ! expressed w.r.t. xi (local coord. system) + + ! Limit the right slope by the PLM limited slope + slope = 2.0 * ( u1 - u0 ) + if ( abs(u1_r) > abs(slope) ) then + u1_r = slope + endif + + ! The right edge value in the boundary cell is taken to be the left + ! edge value in the neighboring cell + u0_r = edge_values(i1,1) + + ! Given the right edge value and slope, we determine the left + ! edge value and slope by computing the parabola as determined by + ! the right edge value and slope and the boundary cell average + u0_l = 3.0 * u0 + 0.5 * u1_r - 2.0 * u0_r + + ! Apply the traditional PPM limiter + exp1 = (u0_r - u0_l) * (u0 - 0.5*(u0_l+u0_r)) + exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 + + if ( exp1 > exp2 ) then + u0_l = 3.0 * u0 - 2.0 * u0_r + endif + + if ( exp1 < -exp2 ) then + u0_r = 3.0 * u0 - 2.0 * u0_l + endif + + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r + + a = u0_l + b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r + c = 3.0 * ( u0_r + u0_l - 2.0 * u0 ) + + ppoly_coef(i0,1) = a + ppoly_coef(i0,2) = b + ppoly_coef(i0,3) = c + + ! ----- Right boundary ----- + i0 = N-1 + i1 = N + h0 = h(i0) + h1 = h(i1) + u0 = u(i0) + u1 = u(i1) + + ! Compute the right edge slope in neighboring cell and express it in + ! the global coordinate system + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + u1_l = (b + 2*c) ! derivative evaluated at xi = 1.0 + u1_l = u1_l * ((h1+hNeglect)/(h0+hNeglect)) + + ! Limit the left slope by the PLM limited slope + slope = 2.0 * ( u1 - u0 ) + if ( abs(u1_l) > abs(slope) ) then + u1_l = slope + endif + + ! The left edge value in the boundary cell is taken to be the right + ! edge value in the neighboring cell + u0_l = edge_values(i0,2) + + ! Given the left edge value and slope, we determine the right + ! edge value and slope by computing the parabola as determined by + ! the left edge value and slope and the boundary cell average + u0_r = 3.0 * u1 - 0.5 * u1_l - 2.0 * u0_l + + ! Apply the traditional PPM limiter + exp1 = (u0_r - u0_l) * (u1 - 0.5*(u0_l+u0_r)) + exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 + + if ( exp1 > exp2 ) then + u0_l = 3.0 * u1 - 2.0 * u0_r + endif + + if ( exp1 < -exp2 ) then + u0_r = 3.0 * u1 - 2.0 * u0_l + endif + + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r + + a = u0_l + b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r + c = 3.0 * ( u0_r + u0_l - 2.0 * u1 ) + + ppoly_coef(i1,1) = a + ppoly_coef(i1,2) = b + ppoly_coef(i1,3) = c + +end subroutine PPM_boundary_extrapolation + +end module PPM_functions diff --git a/ALE/PQM_functions.F90 b/ALE/PQM_functions.F90 new file mode 100644 index 0000000000..ef42fb9f01 --- /dev/null +++ b/ALE/PQM_functions.F90 @@ -0,0 +1,842 @@ +!> Piecewise quartic reconstruction functions +module PQM_functions + +! This file is part of MOM6. See LICENSE.md for the license. + +use regrid_edge_values, only : bound_edge_values, check_discontinuous_edge_values + +implicit none ; private + +public PQM_reconstruction, PQM_boundary_extrapolation, PQM_boundary_extrapolation_v1 + +real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness + +contains + +!> Reconstruction by quartic polynomials within each cell. +!! +!! It is assumed that the dimension of 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed. +subroutine PQM_reconstruction( N, h, u, edge_values, edge_slopes, ppoly_coef, h_neglect, answer_date ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Local variables + integer :: k ! loop index + real :: h_c ! cell width [H] + real :: u0_l, u0_r ! edge values (left and right) [A] + real :: u1_l, u1_r ! edge slopes (left and right) [A H-1] + real :: a, b, c, d, e ! quartic fit coefficients [A] + + ! PQM limiter + call PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_date=answer_date ) + + ! Loop on cells to construct the cubic within each cell + do k = 1,N + + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) + + u1_l = edge_slopes(k,1) + u1_r = edge_slopes(k,2) + + h_c = h(k) + + a = u0_l + b = h_c * u1_l + c = 30.0 * u(k) - 12.0*u0_r - 18.0*u0_l + 1.5*h_c*(u1_r - 3.0*u1_l) + d = -60.0 * u(k) + h_c *(6.0*u1_l - 4.0*u1_r) + 28.0*u0_r + 32.0*u0_l + e = 30.0 * u(k) + 2.5*h_c*(u1_r - u1_l) - 15.0*(u0_l + u0_r) + + ! Store coefficients + ppoly_coef(k,1) = a + ppoly_coef(k,2) = b + ppoly_coef(k,3) = c + ppoly_coef(k,4) = d + ppoly_coef(k,5) = e + + enddo ! end loop on cells + +end subroutine PQM_reconstruction + +!> Limit the piecewise quartic method reconstruction +!! +!! Standard PQM limiter (White & Adcroft, JCP 2008). +!! +!! It is assumed that the dimension of 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed. +subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_date ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Potentially modified edge slopes [A H-1] + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Local variables + integer :: k ! loop index + integer :: inflexion_l + integer :: inflexion_r + real :: u0_l, u0_r ! edge values [A] + real :: u1_l, u1_r ! edge slopes [A H-1] + real :: u_l, u_c, u_r ! left, center and right cell averages [A] + real :: h_l, h_c, h_r ! left, center and right cell widths [H] + real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes [A H-1] + real :: slope ! retained PLM slope [A H-1] + real :: a, b, c, d, e ! quartic fit coefficients [A] + real :: alpha1, alpha2, alpha3 ! Normalized second derivative coefficients [A] + real :: rho ! A temporary expression [A2] + real :: sqrt_rho ! The square root of rho [A] + real :: gradient1, gradient2 ! Normalized gradients [A] + real :: x1, x2 ! Fractional inflection point positions in a cell [nondim] + real :: hNeglect ! A negligibly small width for the purpose of cell reconstructions [H] + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + ! Bound edge values + call bound_edge_values( N, h, u, edge_values, hNeglect, answer_date=answer_date ) + + ! Make discontinuous edge values monotonic (thru averaging) + call check_discontinuous_edge_values( N, u, edge_values ) + + ! Loop on interior cells to apply the PQM limiter + do k = 2,N-1 + + !if ( h(k) < 1.0 ) cycle + + inflexion_l = 0 + inflexion_r = 0 + + ! Get edge values, edge slopes and cell width + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) + u1_l = edge_slopes(k,1) + u1_r = edge_slopes(k,2) + + ! Get cell widths and cell averages (boundary cells are assumed to + ! be local extrema for the sake of slopes) + h_l = h(k-1) + h_c = h(k) + h_r = h(k+1) + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + ! Compute limited slope + sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) + sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) + sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) + + if ( (sigma_l * sigma_r) > 0.0 ) then + slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) + else + slope = 0.0 + endif + + ! If one of the slopes has the wrong sign compared with the + ! limited PLM slope, it is set equal to the limited PLM slope + if ( u1_l*slope <= 0.0 ) u1_l = slope + if ( u1_r*slope <= 0.0 ) u1_r = slope + + ! Local extremum --> flatten + if ( (u0_r - u_c) * (u_c - u0_l) <= 0.0) then + u0_l = u_c + u0_r = u_c + u1_l = 0.0 + u1_r = 0.0 + inflexion_l = -1 + inflexion_r = -1 + endif + + ! Edge values are bounded and averaged when discontinuous and not + ! monotonic, edge slopes are consistent and the cell is not an extremum. + ! We now need to check and enforce the monotonicity of the quartic within + ! the cell + if ( (inflexion_l == 0) .AND. (inflexion_r == 0) ) then + + a = u0_l + b = h_c * u1_l + c = 30.0 * u(k) - 12.0*u0_r - 18.0*u0_l + 1.5*h_c*(u1_r - 3.0*u1_l) + d = -60.0 * u(k) + h_c *(6.0*u1_l - 4.0*u1_r) + 28.0*u0_r + 32.0*u0_l + e = 30.0 * u(k) + 2.5*h_c*(u1_r - u1_l) - 15.0*(u0_l + u0_r) + + ! Determine the coefficients of the second derivative + ! alpha1 xi^2 + alpha2 xi + alpha3 + alpha1 = 6*e + alpha2 = 3*d + alpha3 = c + + rho = alpha2 * alpha2 - 4.0 * alpha1 * alpha3 + + ! Check whether inflexion points exist + if (( alpha1 /= 0.0 ) .and. ( rho >= 0.0 )) then + + sqrt_rho = sqrt( rho ) + + x1 = 0.5 * ( - alpha2 - sqrt_rho ) / alpha1 + x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 + + ! Check whether both inflexion points lie in [0,1] + if ( (x1 >= 0.0) .AND. (x1 <= 1.0) .AND. & + (x2 >= 0.0) .AND. (x2 <= 1.0) ) then + + gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b + gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b + + ! Check whether one of the gradients is inconsistent + if ( (gradient1 * slope < 0.0) .OR. & + (gradient2 * slope < 0.0) ) then + ! Decide where to collapse inflexion points + ! (depends on one-sided slopes) + if ( abs(sigma_l) < abs(sigma_r) ) then + inflexion_l = 1 + else + inflexion_r = 1 + endif + endif + + ! If both x1 and x2 do not lie in [0,1], check whether + ! only x1 lies in [0,1] + elseif ( (x1 >= 0.0) .AND. (x1 <= 1.0) ) then + + gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b + + ! Check whether the gradient is inconsistent + if ( gradient1 * slope < 0.0 ) then + ! Decide where to collapse inflexion points + ! (depends on one-sided slopes) + if ( abs(sigma_l) < abs(sigma_r) ) then + inflexion_l = 1 + else + inflexion_r = 1 + endif + endif + + ! If x1 does not lie in [0,1], check whether x2 lies in [0,1] + elseif ( (x2 >= 0.0) .AND. (x2 <= 1.0) ) then + + gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b + + ! Check whether the gradient is inconsistent + if ( gradient2 * slope < 0.0 ) then + ! Decide where to collapse inflexion points + ! (depends on one-sided slopes) + if ( abs(sigma_l) < abs(sigma_r) ) then + inflexion_l = 1 + else + inflexion_r = 1 + endif + endif + + endif ! end checking where the inflexion points lie + + endif ! end checking if alpha1 != 0 AND rho >= 0 + + ! If alpha1 is zero, the second derivative of the quartic reduces + ! to a straight line + if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then + + x1 = - alpha3 / alpha2 + if ( (x1 >= 0.0) .AND. (x1 <= 1.0) ) then + + gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b + + ! Check whether the gradient is inconsistent + if ( gradient1 * slope < 0.0 ) then + ! Decide where to collapse inflexion points + ! (depends on one-sided slopes) + if ( abs(sigma_l) < abs(sigma_r) ) then + inflexion_l = 1 + else + inflexion_r = 1 + endif + endif ! check slope consistency + + endif + + endif ! end check whether we can find the root of the straight line + + endif ! end checking whether to shift inflexion points + + ! At this point, we know onto which edge to shift inflexion points + if ( inflexion_l == 1 ) then + + ! We modify the edge slopes so that both inflexion points + ! collapse onto the left edge + u1_l = ( 10.0 * u_c - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h_c + hNeglect ) + u1_r = ( -10.0 * u_c + 6.0 * u0_r + 4.0 * u0_l ) / ( h_c + hNeglect ) + + ! One of the modified slopes might be inconsistent. When that happens, + ! the inconsistent slope is set equal to zero and the opposite edge value + ! and edge slope are modified in compliance with the fact that both + ! inflexion points must still be located on the left edge + if ( u1_l * slope < 0.0 ) then + + u1_l = 0.0 + u0_r = 5.0 * u_c - 4.0 * u0_l + u1_r = 20.0 * (u_c - u0_l) / ( h_c + hNeglect ) + + elseif ( u1_r * slope < 0.0 ) then + + u1_r = 0.0 + u0_l = (5.0*u_c - 3.0*u0_r) / 2.0 + u1_l = 10.0 * (-u_c + u0_r) / (3.0 * h_c + hNeglect) + + endif + + elseif ( inflexion_r == 1 ) then + + ! We modify the edge slopes so that both inflexion points + ! collapse onto the right edge + u1_r = ( -10.0 * u_c + 8.0 * u0_r + 2.0 * u0_l ) / (3.0 * h_c + hNeglect) + u1_l = ( 10.0 * u_c - 4.0 * u0_r - 6.0 * u0_l ) / (h_c + hNeglect) + + ! One of the modified slopes might be inconsistent. When that happens, + ! the inconsistent slope is set equal to zero and the opposite edge value + ! and edge slope are modified in compliance with the fact that both + ! inflexion points must still be located on the right edge + if ( u1_l * slope < 0.0 ) then + + u1_l = 0.0 + u0_r = ( 5.0 * u_c - 3.0 * u0_l ) / 2.0 + u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + hNeglect) + + elseif ( u1_r * slope < 0.0 ) then + + u1_r = 0.0 + u0_l = 5.0 * u_c - 4.0 * u0_r + u1_l = 20.0 * ( -u_c + u0_r ) / (h_c + hNeglect) + + endif + + endif ! clause to check where to collapse inflexion points + + ! Save edge values and edge slopes for reconstruction + edge_values(k,1) = u0_l + edge_values(k,2) = u0_r + edge_slopes(k,1) = u1_l + edge_slopes(k,2) = u1_r + + enddo ! end loop on interior cells + + ! Constant reconstruction within boundary cells + edge_values(1,:) = u(1) + edge_slopes(1,:) = 0.0 + + edge_values(N,:) = u(N) + edge_slopes(N,:) = 0.0 + +end subroutine PQM_limiter + +!> Reconstruction by parabolas within boundary cells. +!! +!! The following explanations apply to the left boundary cell. The same +!! reasoning holds for the right boundary cell. +!! +!! A parabola needs to be built in the cell and requires three degrees of +!! freedom, which are the right edge value and slope and the cell average. +!! The right edge values and slopes are taken to be that of the neighboring +!! cell (i.e., the left edge value and slope of the neighboring cell). +!! The resulting parabola is not necessarily monotonic and the traditional +!! PPM limiter is used to modify one of the edge values in order to yield +!! a monotonic parabola. +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine PQM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] + ! Local variables + integer :: i0, i1 + real :: u0, u1 ! Successive cell averages [A] + real :: h0, h1 ! Successive cell thicknesses [H] + real :: a, b, c, d, e ! quartic fit coefficients [A] + real :: u0_l, u0_r ! Edge values [A] + real :: u1_l, u1_r ! Edge slopes [A H-1] + real :: slope ! The integrated slope across the cell [A] + real :: exp1, exp2 ! Two temporary expressions [A2] + + ! ----- Left boundary ----- + i0 = 1 + i1 = 2 + h0 = h(i0) + h1 = h(i1) + u0 = u(i0) + u1 = u(i1) + + ! Compute the left edge slope in neighboring cell and express it in + ! the global coordinate system + b = ppoly_coef(i1,2) + u1_r = b *(h0/h1) ! derivative evaluated at xi = 0.0, + ! expressed w.r.t. xi (local coord. system) + + ! Limit the right slope by the PLM limited slope + slope = 2.0 * ( u1 - u0 ) + if ( abs(u1_r) > abs(slope) ) then + u1_r = slope + endif + + ! The right edge value in the boundary cell is taken to be the left + ! edge value in the neighboring cell + u0_r = edge_values(i1,1) + + ! Given the right edge value and slope, we determine the left + ! edge value and slope by computing the parabola as determined by + ! the right edge value and slope and the boundary cell average + u0_l = 3.0 * u0 + 0.5 * u1_r - 2.0 * u0_r + + ! Apply the traditional PPM limiter + exp1 = (u0_r - u0_l) * (u0 - 0.5*(u0_l+u0_r)) + exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 + + if ( exp1 > exp2 ) then + u0_l = 3.0 * u0 - 2.0 * u0_r + endif + + if ( exp1 < -exp2 ) then + u0_r = 3.0 * u0 - 2.0 * u0_l + endif + + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r + + a = u0_l + b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r + c = 3.0 * ( u0_r + u0_l - 2.0 * u0 ) + + ! The quartic is reduced to a parabola in the boundary cell + ppoly_coef(i0,1) = a + ppoly_coef(i0,2) = b + ppoly_coef(i0,3) = c + ppoly_coef(i0,4) = 0.0 + ppoly_coef(i0,5) = 0.0 + + ! ----- Right boundary ----- + i0 = N-1 + i1 = N + h0 = h(i0) + h1 = h(i1) + u0 = u(i0) + u1 = u(i1) + + ! Compute the right edge slope in neighboring cell and express it in + ! the global coordinate system + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + d = ppoly_coef(i0,4) + e = ppoly_coef(i0,5) + u1_l = (b + 2*c + 3*d + 4*e) ! derivative evaluated at xi = 1.0 + u1_l = u1_l * (h1/h0) + + ! Limit the left slope by the PLM limited slope + slope = 2.0 * ( u1 - u0 ) + if ( abs(u1_l) > abs(slope) ) then + u1_l = slope + endif + + ! The left edge value in the boundary cell is taken to be the right + ! edge value in the neighboring cell + u0_l = edge_values(i0,2) + + ! Given the left edge value and slope, we determine the right + ! edge value and slope by computing the parabola as determined by + ! the left edge value and slope and the boundary cell average + u0_r = 3.0 * u1 - 0.5 * u1_l - 2.0 * u0_l + + ! Apply the traditional PPM limiter + exp1 = (u0_r - u0_l) * (u1 - 0.5*(u0_l+u0_r)) + exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 + + if ( exp1 > exp2 ) then + u0_l = 3.0 * u1 - 2.0 * u0_r + endif + + if ( exp1 < -exp2 ) then + u0_r = 3.0 * u1 - 2.0 * u0_l + endif + + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r + + a = u0_l + b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r + c = 3.0 * ( u0_r + u0_l - 2.0 * u1 ) + + ! The quartic is reduced to a parabola in the boundary cell + ppoly_coef(i1,1) = a + ppoly_coef(i1,2) = b + ppoly_coef(i1,3) = c + ppoly_coef(i1,4) = 0.0 + ppoly_coef(i1,5) = 0.0 + +end subroutine PQM_boundary_extrapolation + + +!> Reconstruction by parabolas within boundary cells. +!! +!! The following explanations apply to the left boundary cell. The same +!! reasoning holds for the right boundary cell. +!! +!! A parabola needs to be built in the cell and requires three degrees of +!! freedom, which are the right edge value and slope and the cell average. +!! The right edge values and slopes are taken to be that of the neighboring +!! cell (i.e., the left edge value and slope of the neighboring cell). +!! The resulting parabola is not necessarily monotonic and the traditional +!! PPM limiter is used to modify one of the edge values in order to yield +!! a monotonic parabola. +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppoly_coef, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions [H] + ! Local variables + integer :: i0, i1 + integer :: inflexion_l + integer :: inflexion_r + real :: u0, u1, um ! Successive cell averages [A] + real :: h0, h1 ! Successive cell thicknesses [H] + real :: a, b, c, d, e ! quartic fit coefficients [A] + real :: ar, br ! Temporary variables in [A] + real :: beta ! A rational function coefficient [nondim] + real :: u0_l, u0_r ! Edge values [A] + real :: u1_l, u1_r ! Edge slopes [A H-1] + real :: u_plm ! The integrated piecewise linear method slope [A] + real :: slope ! The integrated slope across the cell [A] + real :: alpha1, alpha2, alpha3 ! Normalized second derivative coefficients [A] + real :: rho ! A temporary expression [A2] + real :: sqrt_rho ! The square root of rho [A] + real :: gradient1, gradient2 ! Normalized gradients [A] + real :: x1, x2 ! Fractional inflection point positions in a cell [nondim] + real :: hNeglect ! A negligibly small width for the purpose of cell reconstructions [H] + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + ! ----- Left boundary (TOP) ----- + i0 = 1 + i1 = 2 + h0 = h(i0) + h1 = h(i1) + u0 = u(i0) + u1 = u(i1) + um = u0 + + ! Compute real slope and express it w.r.t. local coordinate system + ! within boundary cell + slope = 2.0 * ( u1 - u0 ) / ( ( h0 + h1 ) + hNeglect ) + slope = slope * h0 + + ! The right edge value and slope of the boundary cell are taken to be the + ! left edge value and slope of the adjacent cell + a = ppoly_coef(i1,1) + b = ppoly_coef(i1,2) + + u0_r = a ! edge value + u1_r = b / (h1 + hNeglect) ! edge slope (w.r.t. global coord.) + + ! Compute coefficient for rational function based on mean and right + ! edge value and slope + if (u1_r /= 0.) then ! HACK by AJA + beta = 2.0 * ( u0_r - um ) / ( (h0 + hNeglect)*u1_r) - 1.0 + else + beta = 0. + endif ! HACK by AJA + br = u0_r + beta*u0_r - um + ar = um + beta*um - br + + ! Left edge value estimate based on rational function + u0_l = ar + + ! Edge value estimate based on PLM + u_plm = um - 0.5 * slope + + ! Check whether the left edge value is bounded by the mean and + ! the PLM edge value. If so, keep it and compute left edge slope + ! based on the rational function. If not, keep the PLM edge value and + ! compute corresponding slope. + if ( abs(um-u0_l) < abs(um-u_plm) ) then + u1_l = 2.0 * ( br - ar*beta) + u1_l = u1_l / (h0 + hNeglect) + else + u0_l = u_plm + u1_l = slope / (h0 + hNeglect) + endif + + ! Monotonize quartic + inflexion_l = 0 + + a = u0_l + b = h0 * u1_l + c = 30.0 * um - 12.0*u0_r - 18.0*u0_l + 1.5*h0*(u1_r - 3.0*u1_l) + d = -60.0 * um + h0 *(6.0*u1_l - 4.0*u1_r) + 28.0*u0_r + 32.0*u0_l + e = 30.0 * um + 2.5*h0*(u1_r - u1_l) - 15.0*(u0_l + u0_r) + + alpha1 = 6*e + alpha2 = 3*d + alpha3 = c + + rho = alpha2 * alpha2 - 4.0 * alpha1 * alpha3 + + ! Check whether inflexion points exist. If so, transform the quartic + ! so that both inflexion points coalesce on the left edge. + if (( alpha1 /= 0.0 ) .and. ( rho >= 0.0 )) then + + sqrt_rho = sqrt( rho ) + + x1 = 0.5 * ( - alpha2 - sqrt_rho ) / alpha1 + if ( (x1 > 0.0) .and. (x1 < 1.0) ) then + gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b + if ( gradient1 * slope < 0.0 ) then + inflexion_l = 1 + endif + endif + + x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 + if ( (x2 > 0.0) .and. (x2 < 1.0) ) then + gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b + if ( gradient2 * slope < 0.0 ) then + inflexion_l = 1 + endif + endif + + endif + + if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then + + x1 = - alpha3 / alpha2 + if ( (x1 >= 0.0) .and. (x1 <= 1.0) ) then + gradient1 = 3.0 * d * (x1**2) + 2.0 * c * x1 + b + if ( gradient1 * slope < 0.0 ) then + inflexion_l = 1 + endif + endif + + endif + + if ( inflexion_l == 1 ) then + + ! We modify the edge slopes so that both inflexion points + ! collapse onto the left edge + u1_l = ( 10.0 * um - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h0 + hNeglect) + u1_r = ( -10.0 * um + 6.0 * u0_r + 4.0 * u0_l ) / (h0 + hNeglect) + + ! One of the modified slopes might be inconsistent. When that happens, + ! the inconsistent slope is set equal to zero and the opposite edge value + ! and edge slope are modified in compliance with the fact that both + ! inflexion points must still be located on the left edge + if ( u1_l * slope < 0.0 ) then + + u1_l = 0.0 + u0_r = 5.0 * um - 4.0 * u0_l + u1_r = 20.0 * (um - u0_l) / ( h0 + hNeglect ) + + elseif ( u1_r * slope < 0.0 ) then + + u1_r = 0.0 + u0_l = (5.0*um - 3.0*u0_r) / 2.0 + u1_l = 10.0 * (-um + u0_r) / (3.0 * h0 + hNeglect ) + + endif + + endif + + ! Store edge values, edge slopes and coefficients + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r + edge_slopes(i0,1) = u1_l + edge_slopes(i0,2) = u1_r + + a = u0_l + b = h0 * u1_l + c = 30.0 * um - 12.0*u0_r - 18.0*u0_l + 1.5*h0*(u1_r - 3.0*u1_l) + d = -60.0 * um + h0 *(6.0*u1_l - 4.0*u1_r) + 28.0*u0_r + 32.0*u0_l + e = 30.0 * um + 2.5*h0*(u1_r - u1_l) - 15.0*(u0_l + u0_r) + + ! Store coefficients + ppoly_coef(i0,1) = a + ppoly_coef(i0,2) = b + ppoly_coef(i0,3) = c + ppoly_coef(i0,4) = d + ppoly_coef(i0,5) = e + + ! ----- Right boundary (BOTTOM) ----- + i0 = N-1 + i1 = N + h0 = h(i0) + h1 = h(i1) + u0 = u(i0) + u1 = u(i1) + um = u1 + + ! Compute real slope and express it w.r.t. local coordinate system + ! within boundary cell + slope = 2.0 * ( u1 - u0 ) / ( h0 + h1 ) + slope = slope * h1 + + ! The left edge value and slope of the boundary cell are taken to be the + ! right edge value and slope of the adjacent cell + a = ppoly_coef(i0,1) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + d = ppoly_coef(i0,4) + e = ppoly_coef(i0,5) + u0_l = a + b + c + d + e ! edge value + u1_l = (b + 2*c + 3*d + 4*e) / h0 ! edge slope (w.r.t. global coord.) + + ! Compute coefficient for rational function based on mean and left + ! edge value and slope + if (um-u0_l /= 0.) then ! HACK by AJA + beta = 0.5*h1*u1_l / (um-u0_l) - 1.0 + else + beta = 0. + endif ! HACK by AJA + br = beta*um + um - u0_l + ar = u0_l + + ! Right edge value estimate based on rational function + if (1+beta /= 0.) then ! HACK by AJA + u0_r = (ar + 2*br + beta*br ) / ((1+beta)*(1+beta)) + else + u0_r = um + 0.5 * slope ! PLM + endif ! HACK by AJA + + ! Right edge value estimate based on PLM + u_plm = um + 0.5 * slope + + ! Check whether the right edge value is bounded by the mean and + ! the PLM edge value. If so, keep it and compute right edge slope + ! based on the rational function. If not, keep the PLM edge value and + ! compute corresponding slope. + if ( abs(um-u0_r) < abs(um-u_plm) ) then + u1_r = 2.0 * ( br - ar*beta ) / ( (1+beta)*(1+beta)*(1+beta) ) + u1_r = u1_r / h1 + else + u0_r = u_plm + u1_r = slope / h1 + endif + + ! Monotonize quartic + inflexion_r = 0 + + a = u0_l + b = h1 * u1_l + c = 30.0 * um - 12.0*u0_r - 18.0*u0_l + 1.5*h1*(u1_r - 3.0*u1_l) + d = -60.0 * um + h1*(6.0*u1_l - 4.0*u1_r) + 28.0*u0_r + 32.0*u0_l + e = 30.0 * um + 2.5*h1*(u1_r - u1_l) - 15.0*(u0_l + u0_r) + + alpha1 = 6*e + alpha2 = 3*d + alpha3 = c + + rho = alpha2 * alpha2 - 4.0 * alpha1 * alpha3 + + ! Check whether inflexion points exist. If so, transform the quartic + ! so that both inflexion points coalesce on the right edge. + if (( alpha1 /= 0.0 ) .and. ( rho >= 0.0 )) then + + sqrt_rho = sqrt( rho ) + + x1 = 0.5 * ( - alpha2 - sqrt_rho ) / alpha1 + if ( (x1 > 0.0) .and. (x1 < 1.0) ) then + gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b + if ( gradient1 * slope < 0.0 ) then + inflexion_r = 1 + endif + endif + + x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 + if ( (x2 > 0.0) .and. (x2 < 1.0) ) then + gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b + if ( gradient2 * slope < 0.0 ) then + inflexion_r = 1 + endif + endif + + endif + + if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then + + x1 = - alpha3 / alpha2 + if ( (x1 >= 0.0) .and. (x1 <= 1.0) ) then + gradient1 = 3.0 * d * (x1**2) + 2.0 * c * x1 + b + if ( gradient1 * slope < 0.0 ) then + inflexion_r = 1 + endif + endif + + endif + + if ( inflexion_r == 1 ) then + + ! We modify the edge slopes so that both inflexion points + ! collapse onto the right edge + u1_r = ( -10.0 * um + 8.0 * u0_r + 2.0 * u0_l ) / (3.0 * h1) + u1_l = ( 10.0 * um - 4.0 * u0_r - 6.0 * u0_l ) / h1 + + ! One of the modified slopes might be inconsistent. When that happens, + ! the inconsistent slope is set equal to zero and the opposite edge value + ! and edge slope are modified in compliance with the fact that both + ! inflexion points must still be located on the right edge + if ( u1_l * slope < 0.0 ) then + + u1_l = 0.0 + u0_r = ( 5.0 * um - 3.0 * u0_l ) / 2.0 + u1_r = 10.0 * (um - u0_l) / (3.0 * h1) + + elseif ( u1_r * slope < 0.0 ) then + + u1_r = 0.0 + u0_l = 5.0 * um - 4.0 * u0_r + u1_l = 20.0 * ( -um + u0_r ) / h1 + + endif + + endif + + ! Store edge values, edge slopes and coefficients + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r + edge_slopes(i1,1) = u1_l + edge_slopes(i1,2) = u1_r + + a = u0_l + b = h1 * u1_l + c = 30.0 * um - 12.0*u0_r - 18.0*u0_l + 1.5*h1*(u1_r - 3.0*u1_l) + d = -60.0 * um + h1 *(6.0*u1_l - 4.0*u1_r) + 28.0*u0_r + 32.0*u0_l + e = 30.0 * um + 2.5*h1*(u1_r - u1_l) - 15.0*(u0_l + u0_r) + + ppoly_coef(i1,1) = a + ppoly_coef(i1,2) = b + ppoly_coef(i1,3) = c + ppoly_coef(i1,4) = d + ppoly_coef(i1,5) = e + +end subroutine PQM_boundary_extrapolation_v1 + +!> \namespace pqm_functions +!! +!! Date of creation: 2008.06.06 +!! L. White +!! +!! This module contains routines that handle one-dimensional finite volume +!! reconstruction using the piecewise quartic method (PQM). + +end module PQM_functions diff --git a/ALE/_ALE.dox b/ALE/_ALE.dox new file mode 100644 index 0000000000..b3b4f54213 --- /dev/null +++ b/ALE/_ALE.dox @@ -0,0 +1,184 @@ +/*! \page ALE Vertical Lagrangian method: conceptual + +\section section_ALE Lagrangian and ALE + +As discussed by Adcroft and Hallberg (2008) \cite adcroft2006 and +Griffies, Adcroft and Hallberg (2020) \cite Griffies_Adcroft_Hallberg2020, +we can conceive of two general classes +of algorithms that frame how hydrostatic ocean models are +formulated. The two classes differ in how they treat the vertical +direction. Quasi-Eulerian methods follow the approach traditionally +used in geopotential coordinate models, whereby vertical motion is +diagnosed via the continuity equation. Quasi-Lagrangian methods are +traditionally used by layered isopycnal models, with the vertical +Lagrangian approach specifying motion that crosses coordinate +surfaces. Indeed, such dia-surface flow can be set to zero using +Lagrangian methods for studies of adiabatic dynamics. MOM6 makes use +of the vertical Lagrangian remap method, as pioneered for ocean +modeling by Bleck (2002) \cite bleck2002 and further documented by +\cite Griffies_Adcroft_Hallberg2020, with this method a limit case of +the Arbitrary-Lagrangian-Eulerian method (\cite hirt1997). Dia-surface +transport is implemented via a remapping so that the method can be +summarized as the Lagrangian plus remap approach and so it is a +one-dimensional version of the incremental remapping of Dukowicz (2000) +\cite dukowicz2000. + +\image html ALE_general_schematic.png "Schematic of the 3d Lagrangian regrid/remap method" width=70% +\image latex ALE_general_schematic.png "Schematic of the 3d Lagrangian regrid/remap method" width=0.7\textwidth + +Refer to the above figure taken from Griffies, Adcroft, and Hallberg +(2020) \cite Griffies_Adcroft_Hallberg2020. It shows a schematic of +the Lagrangian-remap method as well as the Arbitrary +Lagrangian-Eulerian (ALE) method. The first panel shows a square fluid +region and square grid used to represent the fluid, along with +rectangular subregions partitioned by grid lines. The second panel +shows the result of evolving the fluid region and evolving the +grid. The grid can evolve according to the fluid flow, as per a +Lagrangian method, or it can evolve according to some specified grid +evolution, as per an ALE method. The right panel depicts the grid +reinitialization onto a target grid (the regrid step). A regrid step +necessitates a corresponding remap step to estimate the ocean state on +the target grid, with conservative remapping required to preserve +integrated scalar contents (e.g., potential enthalpy, salt mass, and +seawater mass). The regrid/remap steps are needed for Lagrangian +methods in order for the grid to retain an accurate representation of +the ocean state. Ideally, the remap step does not affect any changes +to the fluid state; rather, it only modifies where in space the fluid +state is represented. However, any numerical realization incurs +interpolation inaccuracies that lead to unphysical (spurious) state +changes. + +\section section_ALE_MOM Vertical Lagrangian regrid/remap method + +We now get a bit more specific to the vertical Lagrangian method. +For this purpose, recall recall the basic dynamical equations (those +equations with a time derivative) of MOM6 discussed in +\ref General_Coordinate +\f{align} +\rho_0 +\left[ \frac{\partial \mathbf{u}}{\partial t} + \frac{( f + \zeta )}{h} \, +\hat{\mathbf{z}} \times h \, \mathbf{u} + \underbrace{ \dot{r} \, +\frac{\partial \mathbf{u}}{\partial r} } +\right] +&= -\nabla_r \, (p + \rho_{0} \, K) - +\rho \nabla_r \, \Phi + \mathbf{\mathcal{F}} +&\mbox{horizontal momentum} +\label{eq:h-horz-momentum-vlm} +\\ +\frac{\partial h}{\partial t} + \nabla_r \cdot \left( h \, \mathbf{u} \right) + +\underbrace{ \delta_r ( z_r \dot{r} ) } + &= 0 +&\mbox{thickness} +\label{eq:h-thickness-equation-vlm} +\\ +\frac{\partial ( \theta \, h )}{\partial t} + \nabla_r \cdot \left( \theta h \, +\mathbf{u} \right) + \underbrace{ \delta_r ( \theta \, z_r \dot{r} ) } +&= +h \mathbf{\mathcal{N}}_\theta^\gamma - \delta_r J_\theta^{(z)} +&\mbox{potential/Conservative temp} +\label{eq:h-temperature-equation-vlm} + \\ +\frac{\partial ( S \, h )}{\partial t} + \nabla_r \cdot \left( S \, h \, +\mathbf{u} \right) + \underbrace{ \delta_r ( S \, z_r \dot{r} ) } + &= +h \mathbf{\mathcal{N}}_S^\gamma - \delta_r J_S^{(z)} +&\mbox{salinity} +\label{eq:h-salinity-equation-vlm} +\f} +The MOM6 implementation of the vertical Lagrangian method makes +use of two general steps. The first evolves the ocean state forward in +time according to a vertical Lagrangian approach with with +\f$\dot{r}=0\f$. Hence, the horizontal momentum, thickness, and +tracers are time stepped with the underbraced terms removed in the +above equations. All advective transport occurs within a layer as +defined by constant \f$r\f$-surfaces so that the volume within each +layer is fixed. All other terms are retained in their full form, +including subgrid scale terms that contribute to the transfer of +tracer and momentum into distinct \f$r\f$ layers (e.g., dia-surface +diffusion of tracer and velocity). Maintaining constant volume within +a layer yet allowing for tracers to move between layers engenders no +inconsistency between tracer and thickness evolution. The reason is +that tracer diffusion, even dia-surface diffusion, does not transfer +volume. + +The second step in the method comprises the generation of a new +vertical grid following a prescription, such as whether the grid +should align with isopcynals or constant \f$z^{*}\f$ or a combination. +This second step is known as the regrid step. The ocean state is then +vertically remapped to the newly generated vertical grid. This +remapping step incorporates dia-surface transfer of properties, with +such transfer depending on the prescription given for the vertical +grid generation. To minimize discretization errors and the associated +spurious mixing, the remapping step makes use of the high order +accurate methods developed by \cite white2008 and \cite white2009. + + +\section section_ALE_MOM_numerics Outlining the numerical algorithm + +The underlying algorithm for treatment of the vertical can be related +to operator-splitting of the underbraced terms in the above equations. +If we consider, for simplicity, an Euler-forward update for a +time-step \f$\Delta t\f$, the time-stepping for the thickness and +tracer equation (\f$C\f$ is an arbitrary tracer) can be summarized as +(from Table 1 in Griffies, Adcroft and Hallberg (2020) +\cite Griffies_Adcroft_Hallberg2020) +\f{align} +\label{html:ale-equations}\notag +\\ + \delta_{r} w^{\scriptstyle{\mathrm{grid}}} + &= -\nabla_{r} \cdot [h \, \mathbf{u}]^{(n)} + &\mbox{layer motion via horz conv} +\\ + h^{\dagger} &= h^{(n)} + \Delta t \, \delta_{r} w^{\scriptstyle{\mathrm{grid}}} += h^{(n)} - \Delta t \, \nabla_{r} \cdot [h \, \mathbf{u}]^{(n)} + &\mbox{update thickness via horz advect} +\\ + [h \, C]^{\dagger} &= [h \, C]^{(n)} -\Delta t \, \nabla_{r} \cdot [ h \, C \, \mathbf{u} ]^{(n)} + &\mbox{update tracer via horz advect} +\\ + h^{(n+1)} &= h^{\scriptstyle{\mathrm{target}}} + &\mbox{regrid to the target grid} +\\ + \delta_{r} w^{(\dot{r})} &= -(h^{\scriptstyle{\mathrm{target}}} - h^{\dagger})/\Delta t + &\mbox{diagnose dia-surface transport} +\\ + [h \, C]^{(n+1)} &= [h \, C]^{\dagger} - \Delta t \, \delta_{r} ( w^{(\dot{r})} \, C^{\dagger}) + &\mbox{remap tracer via dia-surface transport} +\f} +The first three equations constitute the Lagrangian portion of the +algorithm. In particular, the second equation provides an +intermediate or predictor value for the updated thickness, +\f$h^{\dagger}\f$, resulting from the vertical Lagrangian update. +Similarly, the third equation performs a Lagrangian update of the +thickness-weighted tracer to intermediate values, again operationally +realized by dropping the \f$w^{(\dot{r})}\f$ contribution. +The fourth equation is the regrid step, which is the key step in the +algorithm with the new grid defined by the new thickness +\f$h^{(n+1)}\f$. The new thickness is prescribed by the target values +for the vertical grid, +\f{align} + h^{(n+1)} = h^{\scriptstyle{\mathrm{target}}}. +\f} +The prescribed target grid thicknesses are then used to diagnose the +dia-surface velocity according to +\f{align} + \delta_{r} w^{(\dot{r})} = -(h^{\scriptstyle{\mathrm{target}}} - h^{\dagger})/\Delta t. +\f} +This step, and the remaining step for tracers, constitute the +remapping portion of the algorithm. For example, if the prescribed +coordinate surfaces are geopotentials, then \f$w^{(\dot{r})}\f$ and +\f$h^{\scriptstyle{\mathrm{target}}} = h^{(n)}\f$, in which case the +remap step reduces to Cartesian vertical advection. + +Within the above framework for evolving the ocean state, we make use +of a standard split-explicit time stepping method by decomposing the +horizontal momentum equation into its fast (depth integrated) and slow +(deviation from depth integrated) components. Furthermore, we follow +the methods of Hallberg and Adcroft (2009) \cite hallberg2009 to +ensure that the free surface resulting from time stepping the depth +integrated thickness equation (i.e., the free surface equation) is +consistent with the sum of the thicknesses that result from time +stepping the layer thickness equations for each of the discretized +layers; i.e., \f$\sum_{k} h = H + \eta\f$. + +*/ diff --git a/ALE/_ALE_timestep.dox b/ALE/_ALE_timestep.dox new file mode 100644 index 0000000000..04ed495e77 --- /dev/null +++ b/ALE/_ALE_timestep.dox @@ -0,0 +1,62 @@ +/*! \page ALE_Timestep Vertical Lagrangian method in pictures + +\section section_ALE_remap Graphical explanation of vertical Lagrangian method + +Vertical Lagrangian regridding/remapping is not a timestep method in +the traditional sense. Rather, it is a sequence of operations +performed to bring the vertical grid back to a target specification +(the regrid step), and then to remap the ocean state onto this new +grid (the remap step). This regrid/remap process can be chosen to be +less frequent than the momentum or thermodynamic timesteps. We are +motivated to choose less frequent regrid/remap steps to save +computational time and to reduce spurious mixing that occurs due to +truncation errors in the remap step. However, there is a downside to +delaying the regrid/remap. Namely, if delayed too long then the layer +interfaces can become entangled (i.e., no longer monotonic in the +vertical), which is a common problem with purely Lagrangian methods. +On this page we illustrate the regrid/remap steps by making use of +Figure 3 from Griffies, Adcroft, and Hallberg (2020) +\cite Griffies_Adcroft_Hallberg2020. + +For purposes of this example, assume that the target vertical grid is +comprised of geopotential \f$z\f$-surfaces, with the initial ocean +state (e.g., the temperature field) shown on the left in the following +figure. + +\image html remapping1.png "Initial state with level surface (left) and perturbed state after a wave has come through (right)" width=60% +\image latex remapping1.png "Initial state with level surface (left) and perturbed state after a wave has come through (right)" width=0.6\textwidth + +Some time later, assume a wave has perturbed the ocean state. During +the Lagrangian portion of the algorithm, the coordinate surfaces move +vertically with the ocean fluid according to \f$\dot{r}=0\f$. Assume +now that the algorithm has determined that a regrid step is needed, +with the target vertical grid still geopotential \f$z\f$-surfaces, so +this new target grid is shown overlaid on the left as a regrid. + +\image html remapping2.png "The regrid operation (left) and the remap operation (right)" width=60% +\image latex remapping2.png "The regrid operation (left) and the remap operation (right)" width=0.6\textwidth + +The most complex part of the method involves remapping the wavy ocean +field onto the new grid. This step also incurs truncation errors that +are a function of the vertical grid spacing and the numerical method +used to perform the remapping. We illustrate this remap step in the +figure above, as well as in the frame below shown after the old +deformed coordinate grid has been deleted: + +\image html remapping3.png "The final state after regriddinig and remapping" width=30% +\image latex remapping3.png "The final state after regridding and remapping" width=0.3\textwidth + +The new layer thicknesses, \f$h_k\f$, are computed and then the layers +are populated with the new velocities and tracers +\f{align} + \sum h_k^{\scriptstyle{\mathrm{new}}} &= \sum h_k^{\scriptstyle{\mathrm{old}}} +\\ + \mathbf{u}_k^{\scriptstyle{\mathrm{new}}} + &= \frac{1}{h_k} + \int_{z_{k + 1/2}}^{z_{k + 1/2} + h_k} \mathbf{u}^{\scriptstyle{\mathrm{old}}}(z') \, \mathrm{d}z' +\\ + \theta_k^{\scriptstyle{\mathrm{new}}} &= \frac{1}{h_k} + \int_{z_{k + 1/2}}^{z_{k + 1/2} + h_k} \theta^{\scriptstyle{\mathrm{old}}}(z') \, \mathrm{d}z' +\f} + +*/ diff --git a/ALE/coord_adapt.F90 b/ALE/coord_adapt.F90 new file mode 100644 index 0000000000..32513c8ad3 --- /dev/null +++ b/ALE/coord_adapt.F90 @@ -0,0 +1,304 @@ +!> Regrid columns for the adaptive coordinate +module coord_adapt + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : calculate_density_derivs +use MOM_error_handler, only : MOM_error, FATAL +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 for adaptive coordinates (coord_adapt). +type, public :: adapt_CS ; private + + !> Number of layers/levels + integer :: nk + + !> Nominal near-surface resolution [H ~> m or kg m-2] + real, allocatable, dimension(:) :: coordinateResolution + + !> Ratio of optimisation and diffusion timescales [nondim] + real :: adaptTimeRatio + + !> Nondimensional coefficient determining how much optimisation to apply [nondim] + real :: adaptAlpha + + !> Near-surface zooming depth [H ~> m or kg m-2] + real :: adaptZoom + + !> Near-surface zooming coefficient [nondim] + real :: adaptZoomCoeff + + !> Stratification-dependent diffusion coefficient [nondim] + real :: adaptBuoyCoeff + + !> Reference density difference for stratification-dependent diffusion [R ~> kg m-3] + real :: adaptDrho0 + + !> If true, form a HYCOM1-like mixed layet by preventing interfaces + !! from becoming shallower than the depths set by coordinateResolution + logical :: adaptDoMin = .false. +end type adapt_CS + +public init_coord_adapt, set_adapt_params, build_adapt_column, end_coord_adapt + +contains + +!> Initialise an adapt_CS with parameters +subroutine init_coord_adapt(CS, nk, coordinateResolution, m_to_H, kg_m3_to_R) + type(adapt_CS), pointer :: CS !< Unassociated pointer to hold the control structure + integer, intent(in) :: nk !< Number of layers in the grid + real, dimension(:), intent(in) :: coordinateResolution !< Nominal near-surface resolution [m] or + !! other units specified with m_to_H + real, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses, + !! perhaps in units of [H m-1 ~> 1 or kg m-3] + real, intent(in) :: kg_m3_to_R !< A conversion factor from kg m-3 to the units of density, + !! perhaps in units of [R m3 kg-1 ~> 1] + + if (associated(CS)) call MOM_error(FATAL, "init_coord_adapt: CS already associated") + allocate(CS) + allocate(CS%coordinateResolution(nk)) + + CS%nk = nk + CS%coordinateResolution(:) = coordinateResolution(:) + + ! Set real parameter default values + CS%adaptTimeRatio = 1e-1 ! Nondim. + CS%adaptAlpha = 1.0 ! Nondim. + CS%adaptZoom = 200.0 * m_to_H ! [H ~> m or kg m-2] + CS%adaptZoomCoeff = 0.0 ! Nondim. + CS%adaptBuoyCoeff = 0.0 ! Nondim. + CS%adaptDrho0 = 0.5 * kg_m3_to_R ! [R ~> kg m-3] + +end subroutine init_coord_adapt + +!> Clean up the coordinate control structure +subroutine end_coord_adapt(CS) + type(adapt_CS), pointer :: CS !< The control structure for this module + + ! nothing to do + if (.not. associated(CS)) return + deallocate(CS%coordinateResolution) + deallocate(CS) +end subroutine end_coord_adapt + +!> This subtroutine can be used to set the parameters for coord_adapt module +subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoomCoeff, & + adaptBuoyCoeff, adaptDrho0, adaptDoMin) + type(adapt_CS), pointer :: CS !< The control structure for this module + real, optional, intent(in) :: adaptTimeRatio !< Ratio of optimisation and diffusion timescales [nondim] + real, optional, intent(in) :: adaptAlpha !< Nondimensional coefficient determining + !! how much optimisation to apply + real, optional, intent(in) :: adaptZoom !< Near-surface zooming depth [H ~> m or kg m-2] + real, optional, intent(in) :: adaptZoomCoeff !< Near-surface zooming coefficient [nondim] + real, optional, intent(in) :: adaptBuoyCoeff !< Stratification-dependent diffusion coefficient + real, optional, intent(in) :: adaptDrho0 !< Reference density difference for + !! stratification-dependent diffusion [R ~> kg m-3] + logical, optional, intent(in) :: adaptDoMin !< If true, form a HYCOM1-like mixed layer by + !! preventing interfaces from becoming shallower than + !! the depths set by coordinateResolution + + if (.not. associated(CS)) call MOM_error(FATAL, "set_adapt_params: CS not associated") + + if (present(adaptTimeRatio)) CS%adaptTimeRatio = adaptTimeRatio + if (present(adaptAlpha)) CS%adaptAlpha = adaptAlpha + if (present(adaptZoom)) CS%adaptZoom = adaptZoom + if (present(adaptZoomCoeff)) CS%adaptZoomCoeff = adaptZoomCoeff + if (present(adaptBuoyCoeff)) CS%adaptBuoyCoeff = adaptBuoyCoeff + if (present(adaptDrho0)) CS%adaptDrho0 = adaptDrho0 + if (present(adaptDoMin)) CS%adaptDoMin = adaptDoMin +end subroutine set_adapt_params + +subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, nom_depth_H, zNext) + type(adapt_CS), intent(in) :: CS !< The control structure for this module + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + integer, intent(in) :: i !< The i-index of the column to work on + integer, intent(in) :: j !< The j-index of the column to work on + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: zInt !< Interface heights [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: tInt !< Interface temperatures [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: sInt !< Interface salinities [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1), intent(inout) :: zNext !< updated interface positions [H ~> m or kg m-2] + + ! Local variables + integer :: k, nz + real :: h_up ! The upwind source grid thickness based on the direction of the + ! adjustive fluxes [H ~> m or kg m-2] + real :: b1 ! The inverse of the tridiagonal denominator [nondim] + real :: b_denom_1 ! The leading term in the tridiagonal denominator [nondim] + real :: d1 ! A term in the tridiagonal expressions [nondim] + real :: depth ! Depth in thickness units [H ~> m or kg m-2] + real :: nominal_z ! A nominal interface position in thickness units [H ~> m or kg m-2] + real :: stretching ! A stretching factor for the water column [nondim] + real :: drdz ! The vertical density gradient [R H-1 ~> kg m-4 or m-1] + real, dimension(SZK_(GV)+1) :: alpha ! drho/dT [R C-1 ~> kg m-3 degC-1] + real, dimension(SZK_(GV)+1) :: beta ! drho/dS [R S-1 ~> kg m-3 ppt-1] + real, dimension(SZK_(GV)+1) :: del2sigma ! Laplacian of in situ density times grid spacing [R ~> kg m-3] + real, dimension(SZK_(GV)+1) :: dh_d2s ! Thickness change in response to del2sigma [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: kGrid ! grid diffusivity on layers [nondim] + real, dimension(SZK_(GV)) :: c1 ! A tridiagonal work array [nondim] + + nz = CS%nk + + ! set bottom and surface of zNext + zNext(1) = 0. + zNext(nz+1) = zInt(i,j,nz+1) + + ! local depth for scaling diffusivity + depth = nom_depth_H(i,j) + + ! initialize del2sigma and the thickness change response to it zero + del2sigma(:) = 0.0 ; dh_d2s(:) = 0.0 + + ! calculate del-squared of neutral density by a + ! stencilled finite difference + ! TODO: this needs to be adjusted to account for vanished layers near topography + + ! up (j-1) + 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)), & + 0.5 * (zInt(i,j,2:nz) + zInt(i,j-1,2:nz)) * (GV%H_to_RZ * GV%g_Earth), & + alpha, beta, tv%eqn_of_state, (/2,nz/) ) + + del2sigma(2:nz) = del2sigma(2:nz) + & + (alpha(2:nz) * (tInt(i,j-1,2:nz) - tInt(i,j,2:nz)) + & + 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.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)), & + 0.5 * (zInt(i,j,2:nz) + zInt(i,j+1,2:nz)) * (GV%H_to_RZ * GV%g_Earth), & + alpha, beta, tv%eqn_of_state, (/2,nz/) ) + + del2sigma(2:nz) = del2sigma(2:nz) + & + (alpha(2:nz) * (tInt(i,j+1,2:nz) - tInt(i,j,2:nz)) + & + 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.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)), & + 0.5 * (zInt(i,j,2:nz) + zInt(i-1,j,2:nz)) * (GV%H_to_RZ * GV%g_Earth), & + alpha, beta, tv%eqn_of_state, (/2,nz/) ) + + del2sigma(2:nz) = del2sigma(2:nz) + & + (alpha(2:nz) * (tInt(i-1,j,2:nz) - tInt(i,j,2:nz)) + & + 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.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)), & + 0.5 * (zInt(i,j,2:nz) + zInt(i+1,j,2:nz)) * (GV%H_to_RZ * GV%g_Earth), & + alpha, beta, tv%eqn_of_state, (/2,nz/) ) + + del2sigma(2:nz) = del2sigma(2:nz) + & + (alpha(2:nz) * (tInt(i+1,j,2:nz) - tInt(i,j,2:nz)) + & + beta(2:nz) * (sInt(i+1,j,2:nz) - sInt(i,j,2:nz))) + endif + + ! at this point, del2sigma contains the local neutral density curvature at + ! h-points, on interfaces + ! we need to divide by drho/dz to give an interfacial displacement + ! + ! a positive curvature means we're too light relative to adjacent columns, + ! so del2sigma needs to be positive too (push the interface deeper) + call calculate_density_derivs(tInt(i,j,:), sInt(i,j,:), zInt(i,j,:) * (GV%H_to_RZ * GV%g_Earth), & + alpha, beta, tv%eqn_of_state, (/1,nz+1/) ) + do K = 2, nz + ! TODO make lower bound here configurable + dh_d2s(K) = del2sigma(K) * (0.5 * (h(i,j,k-1) + h(i,j,k))) / & + max(alpha(K) * (tv%T(i,j,k) - tv%T(i,j,k-1)) + & + beta(K) * (tv%S(i,j,k) - tv%S(i,j,k-1)), 1e-20*US%kg_m3_to_R) + + ! don't move the interface so far that it would tangle with another + ! interface in the direction we're moving (or exceed a Nyquist limit + ! that could cause oscillations of the interface) + h_up = merge(h(i,j,k), h(i,j,k-1), dh_d2s(K) > 0.) + dh_d2s(K) = 0.5 * CS%adaptAlpha * & + sign(min(abs(del2sigma(K)), 0.5 * h_up), dh_d2s(K)) + + ! update interface positions so we can diffuse them + zNext(K) = zInt(i,j,K) + dh_d2s(K) + enddo + + ! solve diffusivity equation to smooth grid + ! upper diagonal coefficients: -kGrid(2:nz) + ! lower diagonal coefficients: -kGrid(1:nz-1) + ! diagonal coefficients: 1 + (kGrid(1:nz-1) + kGrid(2:nz)) + ! + ! first, calculate the diffusivities within layers + do k = 1, nz + ! calculate the dr bit of drdz + drdz = 0.5 * (alpha(K) + alpha(K+1)) * (tInt(i,j,K+1) - tInt(i,j,K)) + & + 0.5 * (beta(K) + beta(K+1)) * (sInt(i,j,K+1) - sInt(i,j,K)) + ! divide by dz from the new interface positions + drdz = drdz / (zNext(K) - zNext(K+1) + GV%H_subroundoff) + ! don't do weird stuff in unstably-stratified regions + drdz = max(drdz, 0.) + + ! set vertical grid diffusivity + kGrid(k) = (CS%adaptTimeRatio * nz**2 * depth) * & + ( CS%adaptZoomCoeff / (CS%adaptZoom + 0.5*(zNext(K) + zNext(K+1))) + & + (CS%adaptBuoyCoeff * drdz / CS%adaptDrho0) + & + max(1.0 - CS%adaptZoomCoeff - CS%adaptBuoyCoeff, 0.0) / depth) + enddo + + ! initial denominator (first diagonal element) + b1 = 1.0 + ! initial Q_1 = 1 - q_1 = 1 - 0/1 + d1 = 1.0 + ! work on all interior interfaces + do K = 2, nz + ! calculate numerator of Q_k + b_denom_1 = 1. + d1 * kGrid(k-1) + ! update denominator for k + b1 = 1.0 / (b_denom_1 + kGrid(k)) + + ! calculate q_k + c1(K) = kGrid(k) * b1 + ! update Q_k = 1 - q_k + d1 = b_denom_1 * b1 + + ! update RHS + zNext(K) = b1 * (zNext(K) + kGrid(k-1)*zNext(K-1)) + enddo + ! final substitution + do K = nz, 2, -1 + zNext(K) = zNext(K) + c1(K)*zNext(K+1) + enddo + + if (CS%adaptDoMin) then + nominal_z = 0. + stretching = zInt(i,j,nz+1) / depth + + do k = 2, nz+1 + nominal_z = nominal_z + CS%coordinateResolution(k-1) * stretching + ! take the deeper of the calculated and nominal positions + zNext(K) = max(zNext(K), nominal_z) + ! interface can't go below topography + zNext(K) = min(zNext(K), zInt(i,j,nz+1)) + enddo + endif +end subroutine build_adapt_column + +end module coord_adapt diff --git a/ALE/coord_hycom.F90 b/ALE/coord_hycom.F90 new file mode 100644 index 0000000000..ddc569e45e --- /dev/null +++ b/ALE/coord_hycom.F90 @@ -0,0 +1,266 @@ +!> Regrid columns for the HyCOM coordinate +module coord_hycom + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_remapping, only : remapping_CS, remapping_core_h +use MOM_EOS, only : EOS_type, calculate_density +use regrid_interp, only : interp_CS_type, build_and_interpolate_grid, regridding_set_ppolys +use regrid_interp, only : DEGREE_MAX + +implicit none ; private + +!> Control structure containing required parameters for the HyCOM coordinate +type, public :: hycom_CS ; private + + !> Number of layers/levels in generated grid + integer :: nk + + !> Nominal near-surface resolution [Z ~> m] + real, allocatable, dimension(:) :: coordinateResolution + + !> Nominal density of interfaces [R ~> kg m-3] + real, allocatable, dimension(:) :: target_density + + !> Maximum depths of interfaces [H ~> m or kg m-2] + real, allocatable, dimension(:) :: max_interface_depths + + !> Maximum thicknesses of layers [H ~> m or kg m-2] + real, allocatable, dimension(:) :: max_layer_thickness + + !> If true, an interface only moves if it improves the density fit + logical :: only_improves = .false. + + !> Interpolation control structure + type(interp_CS_type) :: interp_CS +end type hycom_CS + +public init_coord_hycom, set_hycom_params, build_hycom1_column, end_coord_hycom + +contains + +!> Initialise a hycom_CS with pointers to parameters +subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp_CS) + type(hycom_CS), pointer :: CS !< Unassociated pointer to hold the control structure + integer, intent(in) :: nk !< Number of layers in generated grid + real, dimension(nk), intent(in) :: coordinateResolution !< Nominal near-surface resolution [Z ~> m] + real, dimension(nk+1),intent(in) :: target_density !< Interface target densities [R ~> kg m-3] + type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation + + if (associated(CS)) call MOM_error(FATAL, "init_coord_hycom: CS already associated!") + allocate(CS) + allocate(CS%coordinateResolution(nk)) + allocate(CS%target_density(nk+1)) + + CS%nk = nk + CS%coordinateResolution(:) = coordinateResolution(:) + CS%target_density(:) = target_density(:) + CS%interp_CS = interp_CS + +end subroutine init_coord_hycom + +!> This subroutine deallocates memory in the control structure for the coord_hycom module +subroutine end_coord_hycom(CS) + type(hycom_CS), pointer :: CS !< Coordinate control structure + + ! nothing to do + if (.not. associated(CS)) return + deallocate(CS%coordinateResolution) + deallocate(CS%target_density) + if (allocated(CS%max_interface_depths)) deallocate(CS%max_interface_depths) + if (allocated(CS%max_layer_thickness)) deallocate(CS%max_layer_thickness) + deallocate(CS) +end subroutine end_coord_hycom + +!> This subroutine can be used to set the parameters for the coord_hycom module +subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, only_improves, interp_CS) + type(hycom_CS), pointer :: CS !< Coordinate control structure + real, dimension(:), optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces [H ~> m or kg m-2] + real, dimension(:), optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers [H ~> m or kg m-2] + logical, optional, intent(in) :: only_improves !< If true, an interface only moves if it improves the density fit + type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation + + if (.not. associated(CS)) call MOM_error(FATAL, "set_hycom_params: CS not associated") + + if (present(max_interface_depths)) then + if (size(max_interface_depths) /= CS%nk+1) & + call MOM_error(FATAL, "set_hycom_params: max_interface_depths inconsistent size") + allocate(CS%max_interface_depths(CS%nk+1)) + CS%max_interface_depths(:) = max_interface_depths(:) + endif + + if (present(max_layer_thickness)) then + if (size(max_layer_thickness) /= CS%nk) & + call MOM_error(FATAL, "set_hycom_params: max_layer_thickness inconsistent size") + allocate(CS%max_layer_thickness(CS%nk)) + CS%max_layer_thickness(:) = max_layer_thickness(:) + endif + + if (present(only_improves)) CS%only_improves = only_improves + + if (present(interp_CS)) CS%interp_CS = interp_CS +end subroutine set_hycom_params + +!> Build a HyCOM coordinate column +subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_col, & + z_col, z_col_new, zScale, h_neglect, h_neglect_edge) + type(hycom_CS), intent(in) :: CS !< Coordinate control structure + type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + integer, intent(in) :: nz !< Number of levels + real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) + real, dimension(nz), intent(in) :: T !< Temperature of column [C ~> degC] + real, dimension(nz), intent(in) :: S !< Salinity of column [S ~> ppt] + real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(nz), intent(in) :: p_col !< Layer pressure [R L2 T-2 ~> Pa] + real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(inout) :: z_col_new !< Absolute positions of interfaces [H ~> m or kg m-2] + real, optional, intent(in) :: zScale !< Scaling factor from the input coordinate thicknesses in [Z ~> m] + !! to desired units for zInterface, perhaps GV%Z_to_H in which + !! case this has units of [H Z-1 ~> nondim or kg m-3] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of + !! cell reconstruction [H ~> m or kg m-2] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of + !! edge value calculation [H ~> m or kg m-2] + + ! Local variables + integer :: k + real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] + real, dimension(CS%nk) :: h_col_new ! New layer thicknesses [H ~> m or kg m-2] + real, dimension(CS%nk) :: r_col_new ! New layer densities [R ~> kg m-3] + real, dimension(CS%nk) :: T_col_new ! New layer temperatures [C ~> degC] + real, dimension(CS%nk) :: S_col_new ! New layer salinities [S ~> ppt] + real, dimension(CS%nk) :: p_col_new ! New layer pressure [R L2 T-2 ~> Pa] + real, dimension(CS%nk+1) :: RiA_ini ! Initial nk+1 interface density anomaly w.r.t. the + ! interface target densities [R ~> kg m-3] + real, dimension(CS%nk+1) :: RiA_new ! New interface density anomaly w.r.t. the + ! interface target densities [R ~> kg m-3] + real :: z_1, z_nz ! mid point of 1st and last layers [H ~> m or kg m-2] + real :: z_scale ! A scaling factor from the input thicknesses to the target thicknesses, + ! perhaps 1 or a factor in [H Z-1 ~> 1 or kg m-3] + real :: stretching ! z* stretching, converts z* to z [nondim]. + real :: nominal_z ! Nominal depth of interface when using z* [H ~> m or kg m-2] + logical :: maximum_depths_set ! If true, the maximum depths of interface have been set. + logical :: maximum_h_set ! If true, the maximum layer thicknesses have been set. + + maximum_depths_set = allocated(CS%max_interface_depths) + maximum_h_set = allocated(CS%max_layer_thickness) + + z_scale = 1.0 ; if (present(zScale)) z_scale = zScale + + if (CS%only_improves .and. nz == CS%nk) then + call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, depth, & + h, T, S, p_col, rho_col, RiA_ini, h_neglect, h_neglect_edge) + else + ! Work bottom recording potential density + call calculate_density(T, S, p_col, rho_col, eqn_of_state) + ! This ensures the potential density profile is monotonic + ! although not necessarily single valued. + do k = nz-1, 1, -1 + rho_col(k) = min( rho_col(k), rho_col(k+1) ) + enddo + endif + + ! Interpolates for the target interface position with the rho_col profile + ! Based on global density profile, interpolate to generate a new grid + call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, & + CS%target_density, CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge) + if (CS%only_improves .and. nz == CS%nk) then + ! Only move an interface if it improves the density fit + z_1 = 0.5 * ( z_col(1) + z_col(2) ) + z_nz = 0.5 * ( z_col(nz) + z_col(nz+1) ) + do k = 1,CS%nk + p_col_new(k) = p_col(1) + ( 0.5 * ( z_col_new(K) + z_col_new(K+1) ) - z_1 ) / ( z_nz - z_1 ) * & + ( p_col(nz) - p_col(1) ) + enddo + ! Remap from original h and T,S to get T,S_col_new + call remapping_core_h(remapCS, nz, h(:), T, CS%nk, h_col_new, T_col_new, h_neglect, h_neglect_edge) + call remapping_core_h(remapCS, nz, h(:), S, CS%nk, h_col_new, S_col_new, h_neglect, h_neglect_edge) + call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, depth, & + h_col_new, T_col_new, S_col_new, p_col_new, r_col_new, RiA_new, h_neglect, h_neglect_edge) + do k= 2,CS%nk + if ( abs(RiA_ini(K)) <= abs(RiA_new(K)) .and. z_col(K) > z_col_new(K-1) .and. & + z_col(K) < z_col_new(K+1)) then + z_col_new(K) = z_col(K) + endif + enddo + endif !only_improves + + ! Sweep down the interfaces and make sure that the interface is at least + ! as deep as a nominal target z* grid + nominal_z = 0. + stretching = z_col(nz+1) / depth ! Stretches z* to z + do k = 2, CS%nk+1 + nominal_z = nominal_z + (z_scale * CS%coordinateResolution(k-1)) * stretching + z_col_new(k) = max( z_col_new(k), nominal_z ) + z_col_new(k) = min( z_col_new(k), z_col(nz+1) ) + enddo + + if (maximum_depths_set .and. maximum_h_set) then ; do k=2,CS%nk + ! The loop bounds are 2 & nz so the top and bottom interfaces do not move. + ! Recall that z_col_new is positive downward. + z_col_new(K) = min(z_col_new(K), CS%max_interface_depths(K), & + z_col_new(K-1) + CS%max_layer_thickness(k-1)) + enddo ; elseif (maximum_depths_set) then ; do K=2,CS%nk + z_col_new(K) = min(z_col_new(K), CS%max_interface_depths(K)) + enddo ; elseif (maximum_h_set) then ; do k=2,CS%nk + z_col_new(K) = min(z_col_new(K), z_col_new(K-1) + CS%max_layer_thickness(k-1)) + enddo ; endif +end subroutine build_hycom1_column + +!> Calculate interface density anomaly w.r.t. the target. +subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_col, & + R, RiAnom, h_neglect, h_neglect_edge) + type(hycom_CS), intent(in) :: CS !< Coordinate control structure + type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + integer, intent(in) :: nz !< Number of levels + real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) + real, dimension(nz), intent(in) :: T !< Temperature of column [C ~> degC] + real, dimension(nz), intent(in) :: S !< Salinity of column [S ~> ppt] + real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(nz), intent(in) :: p_col !< Layer pressure [R L2 T-2 ~> Pa] + real, dimension(nz), intent(out) :: R !< Layer density [R ~> kg m-3] + real, dimension(nz+1), intent(out) :: RiAnom !< The interface density anomaly + !! w.r.t. the interface target + !! densities [R ~> kg m-3] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of + !! cell reconstruction [H ~> m or kg m-2] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of + !! edge value calculation [H ~> m or kg m-2] + ! Local variables + integer :: degree,k + real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] + real, dimension(nz,2) :: ppoly_E ! Polynomial edge values [R ~> kg m-3] + real, dimension(nz,2) :: ppoly_S ! Polynomial edge slopes [R H-1] + real, dimension(nz,DEGREE_MAX+1) :: ppoly_C ! Polynomial interpolant coeficients on the local 0-1 grid [R ~> kg m-3] + + ! Work bottom recording potential density + call calculate_density(T, S, p_col, rho_col, eqn_of_state) + ! This ensures the potential density profile is monotonic + ! although not necessarily single valued. + do k = nz-1, 1, -1 + rho_col(k) = min( rho_col(k), rho_col(k+1) ) + enddo + + call regridding_set_ppolys(CS%interp_CS, rho_col, nz, h, ppoly_E, ppoly_S, ppoly_C, & + degree, h_neglect, h_neglect_edge) + + R(1) = rho_col(1) + RiAnom(1) = ppoly_E(1,1) - CS%target_density(1) + do k= 2,nz + R(k) = rho_col(k) + if (ppoly_E(k-1,2) > CS%target_density(k)) then + RiAnom(k) = ppoly_E(k-1,2) - CS%target_density(k) !interface is heavier than target + elseif (ppoly_E(k,1) < CS%target_density(k)) then + RiAnom(k) = ppoly_E(k,1) - CS%target_density(k) !interface is lighter than target + else + RiAnom(k) = 0.0 !interface spans the target + endif + enddo + RiAnom(nz+1) = ppoly_E(nz,2) - CS%target_density(nz+1) + +end subroutine build_hycom1_target_anomaly + +end module coord_hycom diff --git a/ALE/coord_rho.F90 b/ALE/coord_rho.F90 new file mode 100644 index 0000000000..3ed769f4e4 --- /dev/null +++ b/ALE/coord_rho.F90 @@ -0,0 +1,422 @@ +!> Regrid columns for the continuous isopycnal (rho) coordinate +module coord_rho + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_remapping, only : remapping_CS, remapping_core_h +use MOM_EOS, only : EOS_type, calculate_density +use regrid_interp, only : interp_CS_type, build_and_interpolate_grid, DEGREE_MAX + +implicit none ; private + +!> Control structure containing required parameters for the rho coordinate +type, public :: rho_CS ; private + + !> Number of layers + integer :: nk + + !> Minimum thickness allowed for layers, often in [H ~> m or kg m-2] + real :: min_thickness = 0. + + !> Reference pressure for density calculations [R L2 T-2 ~> Pa] + real :: ref_pressure + + !> If true, integrate for interface positions from the top downward. + !! If false, integrate from the bottom upward, as does the rest of the model. + logical :: integrate_downward_for_e = .false. + + !> Nominal density of interfaces [R ~> kg m-3] + real, allocatable, dimension(:) :: target_density + + !> Interpolation control structure + type(interp_CS_type) :: interp_CS +end type rho_CS + +public init_coord_rho, set_rho_params, build_rho_column, old_inflate_layers_1d, end_coord_rho + +contains + +!> Initialise a rho_CS with pointers to parameters +subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS) + type(rho_CS), pointer :: CS !< Unassociated pointer to hold the control structure + integer, intent(in) :: nk !< Number of layers in the grid + real, intent(in) :: ref_pressure !< Coordinate reference pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [R ~> kg m-3] + type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation + + if (associated(CS)) call MOM_error(FATAL, "init_coord_rho: CS already associated!") + allocate(CS) + allocate(CS%target_density(nk+1)) + + CS%nk = nk + CS%ref_pressure = ref_pressure + CS%target_density(:) = target_density(:) + CS%interp_CS = interp_CS + +end subroutine init_coord_rho + +!> This subroutine deallocates memory in the control structure for the coord_rho module +subroutine end_coord_rho(CS) + type(rho_CS), pointer :: CS !< Coordinate control structure + + ! nothing to do + if (.not. associated(CS)) return + deallocate(CS%target_density) + deallocate(CS) +end subroutine end_coord_rho + +!> This subroutine can be used to set the parameters for the coord_rho module +subroutine set_rho_params(CS, min_thickness, integrate_downward_for_e, interp_CS, ref_pressure) + type(rho_CS), pointer :: CS !< Coordinate control structure + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] + logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface + !! positions from the top downward. If false, integrate + !! from the bottom upward, as does the rest of the model. + real, optional, intent(in) :: ref_pressure !< The reference pressure for density-dependent + !! coordinates [R L2 T-2 ~> Pa] + + type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation + + if (.not. associated(CS)) call MOM_error(FATAL, "set_rho_params: CS not associated") + + if (present(min_thickness)) CS%min_thickness = min_thickness + if (present(integrate_downward_for_e)) CS%integrate_downward_for_e = integrate_downward_for_e + if (present(interp_CS)) CS%interp_CS = interp_CS + if (present(ref_pressure)) CS%ref_pressure = ref_pressure +end subroutine set_rho_params + +!> Build a rho coordinate column +!! +!! 1. Density profiles are calculated on the source grid. +!! 2. Positions of target densities (for interfaces) are found by interpolation. +subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & + z_rigid_top, eta_orig, h_neglect, h_neglect_edge) + type(rho_CS), intent(in) :: CS !< coord_rho control structure + integer, intent(in) :: nz !< Number of levels on source grid (i.e. length of h, T, S) + real, intent(in) :: depth !< Depth of ocean bottom (positive downward) [H ~> m or kg m-2] + real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(nz), intent(in) :: T !< Temperature for source column [C ~> degC] + real, dimension(nz), intent(in) :: S !< Salinity for source column [S ~> ppt] + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + real, dimension(CS%nk+1), & + intent(inout) :: z_interface !< Absolute positions of interfaces [H ~> m or kg m-2] + real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (positive upward in the same + !! units as depth) [H ~> m or kg m-2] + real, optional, intent(in) :: eta_orig !< The actual original height of the top in the same + !! units as depth) [H ~> m or kg m-2] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose + !! of cell reconstructions [H ~> m or kg m-2] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose + !! of edge value calculations [H ~> m or kg m-2] + + ! Local variables + integer :: k, count_nonzero_layers + integer, dimension(nz) :: mapping + real, dimension(nz) :: pres ! Pressures used to calculate density [R L2 T-2 ~> Pa] + real, dimension(nz) :: h_nv ! Thicknesses of non-vanishing layers [H ~> m or kg m-2] + real, dimension(nz) :: densities ! Layer density [R ~> kg m-3] + real, dimension(nz+1) :: xTmp ! Temporary positions [H ~> m or kg m-2] + real, dimension(CS%nk) :: h_new ! New thicknesses [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: x1 ! Interface heights [H ~> m or kg m-2] + + ! Construct source column with vanished layers removed (stored in h_nv) + call copy_finite_thicknesses(nz, h, CS%min_thickness, count_nonzero_layers, h_nv, mapping) + + if (count_nonzero_layers > 1) then + xTmp(1) = 0.0 + do k = 1,count_nonzero_layers + xTmp(k+1) = xTmp(k) + h_nv(k) + enddo + + ! Compute densities on source column + pres(:) = CS%ref_pressure + call calculate_density(T, S, pres, densities, eqn_of_state) + do k = 1,count_nonzero_layers + densities(k) = densities(mapping(k)) + enddo + + ! Based on source column density profile, interpolate to generate a new grid + call build_and_interpolate_grid(CS%interp_CS, densities, count_nonzero_layers, & + h_nv, xTmp, CS%target_density, CS%nk, h_new, & + x1, h_neglect, h_neglect_edge) + + ! Inflate vanished layers + call old_inflate_layers_1d(CS%min_thickness, CS%nk, h_new) + + ! Comment: The following adjustment of h_new, and re-calculation of h_new via x1 needs to be removed + x1(1) = 0.0 ; do k = 1,CS%nk ; x1(k+1) = x1(k) + h_new(k) ; enddo + do k = 1,CS%nk + h_new(k) = x1(k+1) - x1(k) + enddo + + else ! count_nonzero_layers <= 1 + if (nz == CS%nk) then + h_new(:) = h(:) ! This keeps old behavior + else + h_new(:) = 0. + h_new(1) = h(1) + endif + endif + + ! Return interface positions + if (CS%integrate_downward_for_e) then + ! Remapping is defined integrating from zero + z_interface(1) = 0. + do k = 1,CS%nk + z_interface(k+1) = z_interface(k) - h_new(k) + enddo + else + ! The rest of the model defines grids integrating up from the bottom + z_interface(CS%nk+1) = -depth + do k = CS%nk,1,-1 + z_interface(k) = z_interface(k+1) + h_new(k) + enddo + endif + +end subroutine build_rho_column + +!### build_rho_column_iteratively is never used or called. + +!> Iteratively build a rho coordinate column +!! +!! The algorithm operates as follows within each column: +!! +!! 1. Given T & S within each layer, the layer densities are computed. +!! 2. Based on these layer densities, a global density profile is reconstructed +!! (this profile is monotonically increasing and may be discontinuous) +!! 3. The new grid interfaces are determined based on the target interface +!! densities. +!! 4. T & S are remapped onto the new grid. +!! 5. Return to step 1 until convergence or until the maximum number of +!! iterations is reached, whichever comes first. +subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_state, & + zInterface, h_neglect, h_neglect_edge, dev_tol) + type(rho_CS), intent(in) :: CS !< Regridding control structure + type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options + integer, intent(in) :: nz !< Number of levels + real, intent(in) :: depth !< Depth of ocean bottom [Z ~> m] + real, dimension(nz), intent(in) :: h !< Layer thicknesses in Z coordinates [Z ~> m] + real, dimension(nz), intent(in) :: T !< T for column [C ~> degC] + real, dimension(nz), intent(in) :: S !< S for column [S ~> ppt] + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + real, dimension(nz+1), intent(inout) :: zInterface !< Absolute positions of interfaces [Z ~> m] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h [Z ~> m] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h [Z ~> m] + real, optional, intent(in) :: dev_tol !< The tolerance for the deviation between + !! successive grids for determining when the + !! iterative solver has converged [Z ~> m] + + ! Local variables + real, dimension(nz+1) :: x0, x1, xTmp ! Temporary interface heights [Z ~> m] + real, dimension(nz) :: pres ! The pressure used in the equation of state [R L2 T-2 ~> Pa]. + real, dimension(nz) :: densities ! Layer densities [R ~> kg m-3] + real, dimension(nz) :: T_tmp, S_tmp ! A temporary profile of temperature [C ~> degC] and salinity [S ~> ppt]. + real, dimension(nz) :: h0, h1, hTmp ! Temporary thicknesses [Z ~> m] + real :: deviation ! When iterating to determine the final grid, this is the + ! deviation between two successive grids [Z ~> m]. + real :: deviation_tol ! Deviation tolerance between succesive grids in + ! regridding iterations [Z ~> m] + real :: threshold ! The minimum thickness for a layer to be considered to exist [Z ~> m] + integer, dimension(nz) :: mapping ! The indices of the massive layers in the initial column. + integer :: k, m, count_nonzero_layers + + ! Maximum number of regridding iterations + integer, parameter :: NB_REGRIDDING_ITERATIONS = 1 + + threshold = CS%min_thickness + pres(:) = CS%ref_pressure + T_tmp(:) = T(:) + S_tmp(:) = S(:) + h0(:) = h(:) + + ! Start iterations to build grid + m = 1 + deviation_tol = 1.0e-15*depth ; if (present(dev_tol)) deviation_tol = dev_tol + + do m=1,NB_REGRIDDING_ITERATIONS + + ! Construct column with vanished layers removed + call copy_finite_thicknesses(nz, h0, threshold, count_nonzero_layers, hTmp, mapping) + if ( count_nonzero_layers <= 1 ) then + h1(:) = h0(:) + exit ! stop iterations here + endif + + xTmp(1) = 0.0 + do k = 1,count_nonzero_layers + xTmp(k+1) = xTmp(k) + hTmp(k) + enddo + + ! Compute densities within current water column + call calculate_density(T_tmp, S_tmp, pres, densities, eqn_of_state) + + do k = 1,count_nonzero_layers + densities(k) = densities(mapping(k)) + enddo + + ! One regridding iteration + ! Based on global density profile, interpolate to generate a new grid + call build_and_interpolate_grid(CS%interp_CS, densities, count_nonzero_layers, & + hTmp, xTmp, CS%target_density, nz, h1, x1, h_neglect, h_neglect_edge) + + call old_inflate_layers_1d( CS%min_thickness, nz, h1 ) + x1(1) = 0.0 ; do k = 1,nz ; x1(k+1) = x1(k) + h1(k) ; enddo + + ! Remap T and S from previous grid to new grid + do k = 1,nz + h1(k) = x1(k+1) - x1(k) + enddo + + call remapping_core_h(remapCS, nz, h0, S, nz, h1, S_tmp, h_neglect, h_neglect_edge) + + call remapping_core_h(remapCS, nz, h0, T, nz, h1, T_tmp, h_neglect, h_neglect_edge) + + ! Compute the deviation between two successive grids + deviation = 0.0 + x0(1) = 0.0 + x1(1) = 0.0 + do k = 2,nz + x0(k) = x0(k-1) + h0(k-1) + x1(k) = x1(k-1) + h1(k-1) + deviation = deviation + (x0(k)-x1(k))**2 + enddo + deviation = sqrt( deviation / (nz-1) ) + + if ( deviation <= deviation_tol ) exit + + ! Copy final grid onto start grid for next iteration + h0(:) = h1(:) + enddo ! end regridding iterations + + if (CS%integrate_downward_for_e) then + zInterface(1) = 0. + do k = 1,nz + zInterface(k+1) = zInterface(k) - h1(k) + ! Adjust interface position to accommodate inflating layers + ! without disturbing the interface above + enddo + else + ! The rest of the model defines grids integrating up from the bottom + zInterface(nz+1) = -depth + do k = nz,1,-1 + zInterface(k) = zInterface(k+1) + h1(k) + ! Adjust interface position to accommodate inflating layers + ! without disturbing the interface above + enddo + endif + +end subroutine build_rho_column_iteratively + +!> Copy column thicknesses with vanished layers removed +subroutine copy_finite_thicknesses(nk, h_in, thresh, nout, h_out, mapping) + integer, intent(in) :: nk !< Number of layer for h_in, T_in, S_in + real, dimension(nk), intent(in) :: h_in !< Thickness of input column [H ~> m or kg m-2] or [Z ~> m] + real, intent(in) :: thresh !< Thickness threshold defining vanished + !! layers [H ~> m or kg m-2] or [Z ~> m] + integer, intent(out) :: nout !< Number of non-vanished layers + real, dimension(nk), intent(out) :: h_out !< Thickness of output column [H ~> m or kg m-2] or [Z ~> m] + integer, dimension(nk), intent(out) :: mapping !< Index of k-out corresponding to k-in + ! Local variables + integer :: k, k_thickest + real :: thickness_in_vanished ! Summed thicknesses in discarded layers [H ~> m or kg m-2] or [Z ~> m] + real :: thickest_h_out ! Thickness of the thickest layer [H ~> m or kg m-2] or [Z ~> m] + + ! Build up new grid + nout = 0 + thickness_in_vanished = 0.0 + thickest_h_out = h_in(1) + k_thickest = 1 + do k = 1, nk + mapping(k) = nout ! Note k>=nout always + h_out(k) = 0. ! Make sure h_out is set everywhere + if (h_in(k) > thresh) then + ! For non-vanished layers + nout = nout + 1 + mapping(nout) = k + h_out(nout) = h_in(k) + if (h_out(nout) > thickest_h_out) then + thickest_h_out = h_out(nout) + k_thickest = nout + endif + else + ! Add up mass in vanished layers + thickness_in_vanished = thickness_in_vanished + h_in(k) + endif + enddo + + ! No finite layers + if (nout <= 1) return + + ! Adjust for any lost volume in vanished layers + h_out(k_thickest) = h_out(k_thickest) + thickness_in_vanished + +end subroutine copy_finite_thicknesses + +!------------------------------------------------------------------------------ +!> Inflate vanished layers to finite (nonzero) width +subroutine old_inflate_layers_1d( min_thickness, nk, h ) + + ! Argument + real, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] or other units + integer, intent(in) :: nk !< Number of layers in the grid + real, dimension(:), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] or other units + + ! Local variable + integer :: k + integer :: k_found + integer :: count_nonzero_layers + real :: delta ! An increase to a layer to increase it to the minimum thickness in the + ! same units as h, often [H ~> m or kg m-2] + real :: correction ! The accumulated correction that will be applied to the thickest layer + ! to give mass conservation in the same units as h, often [H ~> m or kg m-2] + real :: maxThickness ! The thickness of the thickest layer in the same units as h, often [H ~> m or kg m-2] + + ! Count number of nonzero layers + count_nonzero_layers = 0 + do k = 1,nk + if ( h(k) > min_thickness ) then + count_nonzero_layers = count_nonzero_layers + 1 + endif + enddo + + ! If all layer thicknesses are greater than the threshold, exit routine + if ( count_nonzero_layers == nk ) return + + ! If all thicknesses are zero, inflate them all and exit + if ( count_nonzero_layers == 0 ) then + do k = 1,nk + h(k) = min_thickness + enddo + return + endif + + ! Inflate zero layers + correction = 0.0 + do k = 1,nk + if ( h(k) <= min_thickness ) then + delta = min_thickness - h(k) + correction = correction + delta + h(k) = h(k) + delta + endif + enddo + + ! Modify thicknesses of nonzero layers to ensure volume conservation + maxThickness = h(1) + k_found = 1 + do k = 1,nk + if ( h(k) > maxThickness ) then + maxThickness = h(k) + k_found = k + endif + enddo + + h(k_found) = h(k_found) - correction + +end subroutine old_inflate_layers_1d + +end module coord_rho diff --git a/ALE/coord_sigma.F90 b/ALE/coord_sigma.F90 new file mode 100644 index 0000000000..a2a5820487 --- /dev/null +++ b/ALE/coord_sigma.F90 @@ -0,0 +1,83 @@ +!> Regrid columns for the sigma coordinate +module coord_sigma + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, FATAL + +implicit none ; private + +!> Control structure containing required parameters for the sigma coordinate +type, public :: sigma_CS ; private + + !> Number of levels + integer :: nk + + !> Minimum thickness allowed for layers [H ~> m or kg m-2] + real :: min_thickness + + !> Target coordinate resolution [nondim] + real, allocatable, dimension(:) :: coordinateResolution +end type sigma_CS + +public init_coord_sigma, set_sigma_params, build_sigma_column, end_coord_sigma + +contains + +!> Initialise a sigma_CS with pointers to parameters +subroutine init_coord_sigma(CS, nk, coordinateResolution) + type(sigma_CS), pointer :: CS !< Unassociated pointer to hold the control structure + integer, intent(in) :: nk !< Number of layers in the grid + real, dimension(:), intent(in) :: coordinateResolution !< Nominal coordinate resolution [nondim] + + if (associated(CS)) call MOM_error(FATAL, "init_coord_sigma: CS already associated!") + allocate(CS) + allocate(CS%coordinateResolution(nk)) + + CS%nk = nk + CS%coordinateResolution = coordinateResolution +end subroutine init_coord_sigma + +!> This subroutine deallocates memory in the control structure for the coord_sigma module +subroutine end_coord_sigma(CS) + type(sigma_CS), pointer :: CS !< Coordinate control structure + + ! nothing to do + if (.not. associated(CS)) return + deallocate(CS%coordinateResolution) + deallocate(CS) +end subroutine end_coord_sigma + +!> This subroutine can be used to set the parameters for the coord_sigma module +subroutine set_sigma_params(CS, min_thickness) + type(sigma_CS), pointer :: CS !< Coordinate 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_sigma_params: CS not associated") + + if (present(min_thickness)) CS%min_thickness = min_thickness +end subroutine set_sigma_params + + +!> Build a sigma coordinate column +subroutine build_sigma_column(CS, depth, totalThickness, zInterface) + type(sigma_CS), intent(in) :: CS !< Coordinate control structure + real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) + real, intent(in) :: totalThickness !< Column thickness (positive [H ~> m or kg m-2]) + real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces [H ~> m or kg m-2] + + ! Local variables + integer :: k + + zInterface(CS%nk+1) = -depth + do k = CS%nk,1,-1 + zInterface(k) = zInterface(k+1) + (totalThickness * CS%coordinateResolution(k)) + ! Adjust interface position to accommodate inflating layers + ! without disturbing the interface above + if (zInterface(k) < (zInterface(k+1) + CS%min_thickness)) then + zInterface(k) = zInterface(k+1) + CS%min_thickness + endif + enddo +end subroutine build_sigma_column + +end module coord_sigma diff --git a/ALE/coord_zlike.F90 b/ALE/coord_zlike.F90 new file mode 100644 index 0000000000..7f284217b2 --- /dev/null +++ b/ALE/coord_zlike.F90 @@ -0,0 +1,146 @@ +!> Regrid columns for a z-like coordinate (z-star, z-level) +module coord_zlike + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, FATAL + +implicit none ; private + +!> Control structure containing required parameters for a z-like coordinate +type, public :: zlike_CS ; private + + !> Number of levels to be generated + integer :: nk + + !> Minimum thickness allowed for layers, in the same thickness units (perhaps [H ~> m or kg m-2]) + !! that will be used in all subsequent calls to build_zstar_column with this structure. + real :: min_thickness + + !> Target coordinate resolution, usually in [Z ~> m] + real, allocatable, dimension(:) :: coordinateResolution +end type zlike_CS + +public init_coord_zlike, set_zlike_params, build_zstar_column, end_coord_zlike + +contains + +!> Initialise a zlike_CS with pointers to parameters +subroutine init_coord_zlike(CS, nk, coordinateResolution) + type(zlike_CS), pointer :: CS !< Unassociated pointer to hold the control structure + integer, intent(in) :: nk !< Number of levels in the grid + real, dimension(:), intent(in) :: coordinateResolution !< Target coordinate resolution [Z ~> m] + + if (associated(CS)) call MOM_error(FATAL, "init_coord_zlike: CS already associated!") + allocate(CS) + allocate(CS%coordinateResolution(nk)) + + CS%nk = nk + CS%coordinateResolution = coordinateResolution +end subroutine init_coord_zlike + +!> Deallocates the zlike control structure +subroutine end_coord_zlike(CS) + type(zlike_CS), pointer :: CS !< Coordinate control structure + + ! Nothing to do + if (.not. associated(CS)) return + deallocate(CS%coordinateResolution) + deallocate(CS) +end subroutine end_coord_zlike + +!> Set parameters in the zlike structure +subroutine set_zlike_params(CS, min_thickness) + type(zlike_CS), pointer :: CS !< Coordinate 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_zlike_params: CS not associated") + + if (present(min_thickness)) CS%min_thickness = min_thickness +end subroutine set_zlike_params + +!> Builds a z* coordinate with a minimum thickness +subroutine build_zstar_column(CS, depth, total_thickness, zInterface, & + z_rigid_top, eta_orig, zScale) + type(zlike_CS), intent(in) :: CS !< Coordinate control structure + real, intent(in) :: depth !< Depth of ocean bottom (positive downward in the + !! output units), units may be [Z ~> m] or [H ~> m or kg m-2] + real, intent(in) :: total_thickness !< Column thickness (positive definite in the same + !! units as depth) [Z ~> m] or [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces (in the same + !! units as depth) [Z ~> m] or [H ~> m or kg m-2] + real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (positive upward in the same + !! units as depth) [Z ~> m] or [H ~> m or kg m-2] + real, optional, intent(in) :: eta_orig !< The actual original height of the top (in the same + !! units as depth) [Z ~> m] or [H ~> m or kg m-2] + real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate resolution + !! in Z to desired units for zInterface, perhaps Z_to_H, + !! often [nondim] or [H Z-1 ~> 1 or kg m-3] + ! Local variables + real :: eta ! Free surface height [Z ~> m] or [H ~> m or kg m-2] + real :: stretching ! A stretching factor for the coordinate [nondim] + real :: dh, min_thickness, z0_top, z_star, z_scale ! Thicknesses or heights [Z ~> m] or [H ~> m or kg m-2] + integer :: k + logical :: new_zstar_def + + z_scale = 1.0 ; if (present(zScale)) z_scale = zScale + + new_zstar_def = .false. + min_thickness = min( CS%min_thickness, total_thickness/real(CS%nk) ) + z0_top = 0. + if (present(z_rigid_top)) then + z0_top = z_rigid_top + new_zstar_def = .true. + endif + + ! Position of free-surface (or the rigid top, for which eta ~ z0_top) + eta = total_thickness - depth + if (present(eta_orig)) eta = eta_orig + + ! Conventional z* coordinate: + ! z* = (z-eta) / stretching where stretching = (H+eta)/H + ! z = eta + stretching * z* + ! The above gives z*(z=eta) = 0, z*(z=-H) = -H. + ! With a rigid top boundary at eta = z0_top then + ! z* = z0 + (z-eta) / stretching where stretching = (H+eta)/(H+z0) + ! z = eta + stretching * (z*-z0) * stretching + stretching = total_thickness / ( depth + z0_top ) + + if (new_zstar_def) then + ! z_star is the notional z* coordinate in absence of upper/lower topography + z_star = 0. ! z*=0 at the free-surface + zInterface(1) = eta ! The actual position of the top of the column + do k = 2,CS%nk + z_star = z_star - CS%coordinateResolution(k-1)*z_scale + ! This ensures that z is below a rigid upper surface (ice shelf bottom) + zInterface(k) = min( eta + stretching * ( z_star - z0_top ), z0_top ) + ! This ensures that the layer in inflated + zInterface(k) = min( zInterface(k), zInterface(k-1) - min_thickness ) + ! This ensures that z is above or at the topography + zInterface(k) = max( zInterface(k), -depth + real(CS%nk+1-k) * min_thickness ) + enddo + zInterface(CS%nk+1) = -depth + + else + ! Integrate down from the top for a notional new grid, ignoring topography + ! The starting position is offset by z0_top which, if z0_top<0, will place + ! interfaces above the rigid boundary. + zInterface(1) = eta + do k = 1,CS%nk + dh = stretching * CS%coordinateResolution(k)*z_scale ! Notional grid spacing + zInterface(k+1) = zInterface(k) - dh + enddo + + ! Integrating up from the bottom adjusting interface position to accommodate + ! inflating layers without disturbing the interface above + zInterface(CS%nk+1) = -depth + do k = CS%nk,1,-1 + if ( zInterface(k) < (zInterface(k+1) + min_thickness) ) then + zInterface(k) = zInterface(k+1) + min_thickness + endif + enddo + endif + +end subroutine build_zstar_column + +end module coord_zlike diff --git a/ALE/polynomial_functions.F90 b/ALE/polynomial_functions.F90 new file mode 100644 index 0000000000..b01e097b83 --- /dev/null +++ b/ALE/polynomial_functions.F90 @@ -0,0 +1,117 @@ +!> Polynomial functions +module polynomial_functions + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public :: evaluation_polynomial, integration_polynomial, first_derivative_polynomial + +contains + +!> Pointwise evaluation of a polynomial in arbitrary units [A] at x +!! +!! The polynomial is defined by the coefficients contained in the +!! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... +!! where C refers to the array 'coeff'. +!! The number of coefficients is given by ncoef and x +!! is the coordinate where the polynomial is to be evaluated. +real function evaluation_polynomial( coeff, ncoef, x ) + real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial, in units that + !! vary with the index k as [A H^(k-1)] + integer, intent(in) :: ncoef !< The number of polynomial coefficients + real, intent(in) :: x !< The position at which to evaluate the polynomial + !! in arbitrary thickness units [H] + ! Local variables + integer :: k + real :: f ! value of polynomial at x in arbitrary units [A] + + f = 0.0 + do k = 1,ncoef + f = f + coeff(k) * ( x**(k-1) ) + enddo + + evaluation_polynomial = f + +end function evaluation_polynomial + +!> Calculates the first derivative of a polynomial evaluated in arbitrary units of [A H-1] +!! at a point x +!! +!! The polynomial is defined by the coefficients contained in the +!! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... +!! where C refers to the array 'coeff'. +!! The number of coefficients is given by ncoef and x +!! is the coordinate where the polynomial's derivative is to be evaluated. +real function first_derivative_polynomial( coeff, ncoef, x ) + real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial, in units that + !! vary with the index k as [A H^(k-1)] + integer, intent(in) :: ncoef !< The number of polynomial coefficients + real, intent(in) :: x !< The position at which to evaluate the derivative + !! in arbitrary thickness units [H] + ! Local variables + integer :: k + real :: f ! value of the derivative at x in [A H-1] + + f = 0.0 + do k = 2,ncoef + f = f + REAL(k-1)*coeff(k) * ( x**(k-2) ) + enddo + + first_derivative_polynomial = f + +end function first_derivative_polynomial + +!> Exact integration of polynomial of degree npoly in arbitrary units of [A H] +!! +!! The array of coefficients (Coeff) must be of size npoly+1. +real function integration_polynomial( xi0, xi1, Coeff, npoly ) + real, intent(in) :: xi0 !< The lower bound of the integral in arbitrary + !! thickness units [H] + real, intent(in) :: xi1 !< The upper bound of the integral in arbitrary + !! thickness units [H] + real, dimension(:), intent(in) :: Coeff !< The coefficients of the polynomial, in units that + !! vary with the index k as [A H^(k-1)] + integer, intent(in) :: npoly !< The degree of the polynomial + ! Local variables + integer :: k + real :: integral ! The integral of the polynomial over the specified range in [A H] + + integral = 0.0 + + do k = 1,npoly+1 + integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) + enddo +! +!One non-answer-changing way of unrolling the above is: +! k=1 +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) +! if (npoly>=1) then +! k=2 +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) +! endif +! if (npoly>=2) then +! k=3 +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) +! endif +! if (npoly>=3) then +! k=4 +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) +! endif +! if (npoly>=4) then +! k=5 +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) +! endif +! + integration_polynomial = integral + +end function integration_polynomial + +!> \namespace polynomial_functions +!! +!! Date of creation: 2008.06.12 +!! L. White +!! +!! This module contains routines that handle polynomials. + +end module polynomial_functions diff --git a/ALE/regrid_consts.F90 b/ALE/regrid_consts.F90 new file mode 100644 index 0000000000..0c5ccf268f --- /dev/null +++ b/ALE/regrid_consts.F90 @@ -0,0 +1,125 @@ +!> Contains constants for interpreting input parameters that control regridding. +module regrid_consts + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_string_functions, only : uppercase + +implicit none ; public + +! List of regridding types. These should be consecutive and starting at 1. +! This allows them to be used as array indices. +integer, parameter :: REGRIDDING_LAYER = 1 !< Layer mode identifier +integer, parameter :: REGRIDDING_ZSTAR = 2 !< z* coordinates identifier +integer, parameter :: REGRIDDING_RHO = 3 !< Density coordinates identifier +integer, parameter :: REGRIDDING_SIGMA = 4 !< Sigma coordinates identifier +integer, parameter :: REGRIDDING_ARBITRARY = 5 !< Arbitrary coordinates identifier +integer, parameter :: REGRIDDING_HYCOM1 = 6 !< Simple HyCOM coordinates without BBL +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) +character(len=*), parameter :: REGRIDDING_ZSTAR_STRING = "ZSTAR" !< z* string +character(len=*), parameter :: REGRIDDING_RHO_STRING = "RHO" !< Rho string +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_SIGMA_SHELF_ZSTAR_STRING = "SIGMA_SHELF_ZSTAR" !< Hybrid z*/sigma +character(len=*), parameter :: REGRIDDING_ADAPTIVE_STRING = "ADAPTIVE" !< Adaptive coordinate string +character(len=*), parameter :: DEFAULT_COORDINATE_MODE = REGRIDDING_LAYER_STRING !< Default coordinate mode + +!> Returns a string with the coordinate units associated with the coordinate mode. +interface coordinateUnits + module procedure coordinateUnitsI + module procedure coordinateUnitsS +end interface + +!> Returns true if the coordinate is dependent on the state density, returns false otherwise. +interface state_dependent + module procedure state_dependent_char + module procedure state_dependent_int +end interface + +contains + +!> Parse a string parameter specifying the coordinate mode and +!! return the appropriate enumerated integer +function coordinateMode(string) + integer :: coordinateMode !< Enumerated integer indicating coordinate mode + character(len=*), intent(in) :: string !< String to indicate coordinate mode + select case ( uppercase(trim(string)) ) + case (trim(REGRIDDING_LAYER_STRING)); coordinateMode = REGRIDDING_LAYER + case (trim(REGRIDDING_ZSTAR_STRING)); coordinateMode = REGRIDDING_ZSTAR + case (trim(REGRIDDING_ZSTAR_STRING_OLD)); coordinateMode = REGRIDDING_ZSTAR + 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_ARBITRARY_STRING)); coordinateMode = REGRIDDING_ARBITRARY + case (trim(REGRIDDING_SIGMA_SHELF_ZSTAR_STRING)); coordinateMode = REGRIDDING_SIGMA_SHELF_ZSTAR + case (trim(REGRIDDING_ADAPTIVE_STRING)); coordinateMode = REGRIDDING_ADAPTIVE + case default ; call MOM_error(FATAL, "coordinateMode: "//& + "Unrecognized choice of coordinate ("//trim(string)//").") + end select +end function coordinateMode + +!> Returns a string with the coordinate units associated with the +!! enumerated integer, +function coordinateUnitsI(coordMode) + character(len=16) :: coordinateUnitsI !< Units of coordinate + integer, intent(in) :: coordMode !< Coordinate mode + select case ( coordMode ) + case (REGRIDDING_LAYER); coordinateUnitsI = "kg m^-3" + case (REGRIDDING_ZSTAR); coordinateUnitsI = "m" + case (REGRIDDING_SIGMA_SHELF_ZSTAR); coordinateUnitsI = "m" + 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_ADAPTIVE); coordinateUnitsI = "m" + case default ; call MOM_error(FATAL, "coordinateUnts: "//& + "Unrecognized coordinate mode.") + end select +end function coordinateUnitsI + +!> Returns a string with the coordinate units associated with the +!! string defining the coordinate mode. +function coordinateUnitsS(string) + character(len=16) :: coordinateUnitsS !< Units of coordinate + character(len=*), intent(in) :: string !< Coordinate mode + integer :: coordMode + coordMode = coordinateMode(string) + coordinateUnitsS = coordinateUnitsI(coordMode) +end function coordinateUnitsS + +!> Returns true if the coordinate is dependent on the state density, returns false otherwise. +logical function state_dependent_char(string) + character(len=*), intent(in) :: string !< String to indicate coordinate mode + + state_dependent_char = state_dependent_int( coordinateMode(string) ) + +end function state_dependent_char + +!> Returns true if the coordinate is dependent on the state density, returns false otherwise. +logical function state_dependent_int(mode) + integer, intent(in) :: mode !< Coordinate mode + select case ( mode ) + case (REGRIDDING_LAYER); state_dependent_int = .true. + case (REGRIDDING_ZSTAR); state_dependent_int = .false. + case (REGRIDDING_SIGMA_SHELF_ZSTAR); state_dependent_int = .false. + 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_ADAPTIVE); state_dependent_int = .true. + case default ; call MOM_error(FATAL, "state_dependent: "//& + "Unrecognized choice of coordinate.") + end select +end function state_dependent_int + +end module regrid_consts diff --git a/ALE/regrid_edge_values.F90 b/ALE/regrid_edge_values.F90 new file mode 100644 index 0000000000..0814c6a907 --- /dev/null +++ b/ALE/regrid_edge_values.F90 @@ -0,0 +1,1486 @@ +!> Edge value estimation for high-order reconstruction +module regrid_edge_values + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, FATAL +use regrid_solvers, only : solve_linear_system, linear_solver +use regrid_solvers, only : solve_tridiagonal_system, solve_diag_dominant_tridiag +use polynomial_functions, only : evaluation_polynomial + +implicit none ; private + +! ----------------------------------------------------------------------------- +! The following routines are visible to the outside world +! ----------------------------------------------------------------------------- +public bound_edge_values, average_discontinuous_edge_values, check_discontinuous_edge_values +public edge_values_explicit_h2, edge_values_explicit_h4, edge_values_explicit_h4cw +public edge_values_implicit_h4, edge_values_implicit_h6 +public edge_slopes_implicit_h3, edge_slopes_implicit_h5 + +! The following parameters are used to avoid singular matrices for boundary +! extrapolation. The are needed only in the case where thicknesses vanish +! to a small enough values such that the eigenvalues of the matrix can not +! be separated. +! Specifying a dimensional parameter value, as is done here, is a terrible idea. +real, parameter :: hNeglect_edge_dflt = 1.e-10 !< The default value for cut-off minimum + !! thickness for sum(h) in edge value inversions +real, parameter :: hNeglect_dflt = 1.e-30 !< The default value for cut-off minimum + !! thickness for sum(h) in other calculations +real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) [nondim] + +contains + +!> Bound edge values by neighboring cell averages +!! +!! In this routine, we loop on all cells to bound their left and right +!! edge values by the cell averages. That is, the left edge value must lie +!! between the left cell average and the central cell average. A similar +!! reasoning applies to the right edge values. +!! +!! Both boundary edge values are set equal to the boundary cell averages. +!! Any extrapolation scheme is applied after this routine has been called. +!! Therefore, boundary cells are treated as if they were local extrema. +subroutine bound_edge_values( N, h, u, edge_val, h_neglect, answer_date ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Potentially modified edge values [A]; the + !! second index is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Local variables + real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes [A H-1] or [A] + real :: slope_x_h ! retained PLM slope times half grid step [A] + real :: hNeglect ! A negligible thickness [H]. + logical :: use_2018_answers ! If true use older, less accurate expressions. + integer :: k, km1, kp1 ! Loop index and the values to either side. + + use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) + if (use_2018_answers) then + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + endif + + ! Loop on cells to bound edge value + do k = 1,N + + ! For the sake of bounding boundary edge values, the left neighbor of the left boundary cell + ! is assumed to be the same as the left boundary cell and the right neighbor of the right + ! boundary cell is assumed to be the same as the right boundary cell. This effectively makes + ! boundary cells look like extrema. + km1 = max(1,k-1) ; kp1 = min(k+1,N) + + slope_x_h = 0.0 + if (use_2018_answers) then + sigma_l = 2.0 * ( u(k) - u(km1) ) / ( h(k) + hNeglect ) + sigma_c = 2.0 * ( u(kp1) - u(km1) ) / ( h(km1) + 2.0*h(k) + h(kp1) + hNeglect ) + sigma_r = 2.0 * ( u(kp1) - u(k) ) / ( h(k) + hNeglect ) + + ! The limiter is used in the local coordinate system to each cell, so for convenience store + ! the slope times a half grid spacing. (See White and Adcroft JCP 2008 Eqs 19 and 20) + if ( (sigma_l * sigma_r) > 0.0 ) & + slope_x_h = 0.5 * h(k) * sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) + elseif ( ((h(km1) + h(kp1)) + 2.0*h(k)) > 0.0 ) then + sigma_l = ( u(k) - u(km1) ) + sigma_c = ( u(kp1) - u(km1) ) * ( h(k) / ((h(km1) + h(kp1)) + 2.0*h(k)) ) + sigma_r = ( u(kp1) - u(k) ) + + ! The limiter is used in the local coordinate system to each cell, so for convenience store + ! the slope times a half grid spacing. (See White and Adcroft JCP 2008 Eqs 19 and 20) + if ( (sigma_l * sigma_r) > 0.0 ) & + slope_x_h = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) + endif + + ! Limit the edge values + if ( (u(km1)-edge_val(k,1)) * (edge_val(k,1)-u(k)) < 0.0 ) then + edge_val(k,1) = u(k) - sign( min( abs(slope_x_h), abs(edge_val(k,1)-u(k)) ), slope_x_h ) + endif + + if ( (u(kp1)-edge_val(k,2)) * (edge_val(k,2)-u(k)) < 0.0 ) then + edge_val(k,2) = u(k) + sign( min( abs(slope_x_h), abs(edge_val(k,2)-u(k)) ), slope_x_h ) + endif + + ! Finally bound by neighboring cell means in case of roundoff + edge_val(k,1) = max( min( edge_val(k,1), max(u(km1), u(k)) ), min(u(km1), u(k)) ) + edge_val(k,2) = max( min( edge_val(k,2), max(u(kp1), u(k)) ), min(u(kp1), u(k)) ) + + enddo ! loop on interior edges + +end subroutine bound_edge_values + +!> Replace discontinuous collocated edge values with their average +!! +!! For each interior edge, check whether the edge values are discontinuous. +!! If so, compute the average and replace the edge values by the average. +subroutine average_discontinuous_edge_values( N, edge_val ) + integer, intent(in) :: N !< Number of cells + real, dimension(N,2), intent(inout) :: edge_val !< Edge values that may be modified [A]; the + !! second index is for the two edges of each cell. + ! Local variables + integer :: k ! loop index + real :: u0_avg ! avg value at given edge [A] + + ! Loop on interior edges + do k = 1,N-1 + ! Compare edge values on the right and left sides of the edge + if ( edge_val(k,2) /= edge_val(k+1,1) ) then + u0_avg = 0.5 * ( edge_val(k,2) + edge_val(k+1,1) ) + edge_val(k,2) = u0_avg + edge_val(k+1,1) = u0_avg + endif + + enddo ! end loop on interior edges + +end subroutine average_discontinuous_edge_values + +!> Check discontinuous edge values and replace them with their average if not monotonic +!! +!! For each interior edge, check whether the edge values are discontinuous. +!! If so and if they are not monotonic, replace each edge value by their average. +subroutine check_discontinuous_edge_values( N, u, edge_val ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: u !< cell averages in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Cell edge values [A]; the + !! second index is for the two edges of each cell. + ! Local variables + integer :: k ! loop index + real :: u0_avg ! avg value at given edge [A] + + do k = 1,N-1 + if ( (edge_val(k+1,1) - edge_val(k,2)) * (u(k+1) - u(k)) < 0.0 ) then + u0_avg = 0.5 * ( edge_val(k,2) + edge_val(k+1,1) ) + u0_avg = max( min( u0_avg, max(u(k), u(k+1)) ), min(u(k), u(k+1)) ) + edge_val(k,2) = u0_avg + edge_val(k+1,1) = u0_avg + endif + enddo ! end loop on interior edges + +end subroutine check_discontinuous_edge_values + + +!> Compute h2 edge values (explicit second order accurate) +!! in the same units as u. +! +!! Compute edge values based on second-order explicit estimates. +!! These estimates are based on a straight line spanning two cells and evaluated +!! at the location of the middle edge. An interpolant spanning cells +!! k-1 and k is evaluated at edge k-1/2. The estimate for each edge is unique. +!! +!! k-1 k +!! ..--o------o------o--.. +!! k-1/2 +!! +!! Boundary edge values are set to be equal to the boundary cell averages. +subroutine edge_values_explicit_h2( N, h, u, edge_val ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the + !! second index is for the two edges of each cell. + + ! Local variables + integer :: k ! loop index + + ! Boundary edge values are simply equal to the boundary cell averages + edge_val(1,1) = u(1) + edge_val(N,2) = u(N) + + do k = 2,N + ! Compute left edge value + if (h(k-1) + h(k) == 0.0) then ! Avoid singularities when h0+h1=0 + edge_val(k,1) = 0.5 * (u(k-1) + u(k)) + else + edge_val(k,1) = ( u(k-1)*h(k) + u(k)*h(k-1) ) / ( h(k-1) + h(k) ) + endif + + ! Left edge value of the current cell is equal to right edge value of left cell + edge_val(k-1,2) = edge_val(k,1) + enddo + +end subroutine edge_values_explicit_h2 + +!> Compute h4 edge values (explicit fourth order accurate) +!! in the same units as u. +!! +!! Compute edge values based on fourth-order explicit estimates. +!! These estimates are based on a cubic interpolant spanning four cells +!! and evaluated at the location of the middle edge. An interpolant spanning +!! cells i-2, i-1, i and i+1 is evaluated at edge i-1/2. The estimate for +!! each edge is unique. +!! +!! i-2 i-1 i i+1 +!! ..--o------o------o------o------o--.. +!! i-1/2 +!! +!! The first two edge values are estimated by evaluating the first available +!! cubic interpolant, i.e., the interpolant spanning cells 1, 2, 3 and 4. +!! Similarly, the last two edge values are estimated by evaluating the last +!! available interpolant. +!! +!! For this fourth-order scheme, at least four cells must exist. +subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index + !! is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Local variables + real :: h0, h1, h2, h3 ! temporary thicknesses [H] + real :: h_min ! A minimal cell width [H] + real :: f1 ! An auxiliary variable [H] + real :: f2 ! An auxiliary variable [A H] + real :: f3 ! An auxiliary variable [H-1] + real :: et1, et2, et3 ! terms the expression for edge values [A H] + real :: I_h12 ! The inverse of the sum of the two central thicknesses [H-1] + real :: I_h012, I_h123 ! Inverses of sums of three successive thicknesses [H-1] + real :: I_den_et2, I_den_et3 ! Inverses of denominators in edge value terms [H-2] + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] + real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational constant [nondim] + real :: dx ! Difference of successive values of x [H] + real, dimension(4,4) :: A ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + real, dimension(4) :: B ! The right hand side of the system to solve for C [A H] + real, dimension(4) :: C ! The coefficients of a fit polynomial in units that vary + ! with the index (j) as [A H^(j-1)] + real :: hNeglect ! A negligible thickness in the same units as h [H]. + integer :: i, j + logical :: use_2018_answers ! If true use older, less accurate expressions. + + use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) + if (use_2018_answers) then + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect + else + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + endif + + ! Loop on interior cells + do i = 3,N-1 + + h0 = h(i-2) + h1 = h(i-1) + h2 = h(i) + h3 = h(i+1) + + ! Avoid singularities when consecutive pairs of h vanish + if (h0+h1==0.0 .or. h1+h2==0.0 .or. h2+h3==0.0) then + if (use_2018_answers) then + h_min = hMinFrac*max( hNeglect, h0+h1+h2+h3 ) + else + h_min = hMinFrac*max( hNeglect, (h0+h1)+(h2+h3) ) + endif + h0 = max( h_min, h(i-2) ) + h1 = max( h_min, h(i-1) ) + h2 = max( h_min, h(i) ) + h3 = max( h_min, h(i+1) ) + endif + + if (use_2018_answers) then + f1 = (h0+h1) * (h2+h3) / (h1+h2) + f2 = h2 * u(i-1) + h1 * u(i) + f3 = 1.0 / (h0+h1+h2) + 1.0 / (h1+h2+h3) + et1 = f1 * f2 * f3 + et2 = ( h2 * (h2+h3) / ( (h0+h1+h2)*(h0+h1) ) ) * & + ((h0+2.0*h1) * u(i-1) - h1 * u(i-2)) + et3 = ( h1 * (h0+h1) / ( (h1+h2+h3)*(h2+h3) ) ) * & + ((2.0*h2+h3) * u(i) - h2 * u(i+1)) + edge_val(i,1) = (et1 + et2 + et3) / ( h0 + h1 + h2 + h3) + else + I_h12 = 1.0 / (h1+h2) + I_den_et2 = 1.0 / ( ((h0+h1)+h2)*(h0+h1) ) ; I_h012 = (h0+h1) * I_den_et2 + I_den_et3 = 1.0 / ( (h1+(h2+h3))*(h2+h3) ) ; I_h123 = (h2+h3) * I_den_et3 + + et1 = ( 1.0 + (h1 * I_h012 + (h0+h1) * I_h123) ) * I_h12 * (h2*(h2+h3)) * u(i-1) + & + ( 1.0 + (h2 * I_h123 + (h2+h3) * I_h012) ) * I_h12 * (h1*(h0+h1)) * u(i) + et2 = ( h1 * (h2*(h2+h3)) * I_den_et2 ) * (u(i-1)-u(i-2)) + et3 = ( h2 * (h1*(h0+h1)) * I_den_et3 ) * (u(i) - u(i+1)) + edge_val(i,1) = (et1 + (et2 + et3)) / ((h0 + h1) + (h2 + h3)) + endif + edge_val(i-1,2) = edge_val(i,1) + + enddo ! end loop on interior cells + + ! Determine first two edge values + if (use_2018_answers) then + h_min = max( hNeglect, hMinFrac*sum(h(1:4)) ) + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(i) ) + x(i+1) = x(i) + dx + do j = 1,4 ; A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) ; enddo + B(i) = u(i) * dx + enddo + + call solve_linear_system( A, B, C, 4 ) + + ! Set the edge values of the first cell + edge_val(1,1) = evaluation_polynomial( C, 4, x(1) ) + edge_val(1,2) = evaluation_polynomial( C, 4, x(2) ) + else ! Use expressions with less sensitivity to roundoff + do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo + call end_value_h4(dz, u_tmp, C) + + ! Set the edge values of the first cell + edge_val(1,1) = C(1) + edge_val(1,2) = C(1) + dz(1)*(C(2) + dz(1)*(C(3) + dz(1)*C(4))) + endif + edge_val(2,1) = edge_val(1,2) + + ! Determine two edge values of the last cell + if (use_2018_answers) then + h_min = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) + + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(N-4+i) ) + x(i+1) = x(i) + dx + do j = 1,4 ; A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) ; enddo + B(i) = u(N-4+i) * dx + enddo + + call solve_linear_system( A, B, C, 4 ) + + ! Set the last and second to last edge values + edge_val(N,2) = evaluation_polynomial( C, 4, x(5) ) + edge_val(N,1) = evaluation_polynomial( C, 4, x(4) ) + else + ! Use expressions with less sensitivity to roundoff, including using a coordinate + ! system that sets the origin at the last interface in the domain. + do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo + call end_value_h4(dz, u_tmp, C) + + ! Set the last and second to last edge values + edge_val(N,2) = C(1) + edge_val(N,1) = C(1) + dz(1)*(C(2) + dz(1)*(C(3) + dz(1)*C(4))) + endif + edge_val(N-1,2) = edge_val(N,1) + +end subroutine edge_values_explicit_h4 + +!> Compute h4 edge values (explicit fourth order accurate) +!! in the same units as u. +!! +!! From (Colella & Woodward, JCP, 1984) and based on hybgen_ppm_coefs. +!! +!! Compute edge values based on fourth-order explicit estimates. +!! These estimates are based on a cubic interpolant spanning four cells +!! and evaluated at the location of the middle edge. An interpolant spanning +!! cells i-2, i-1, i and i+1 is evaluated at edge i-1/2. The estimate for +!! each edge is unique. +!! +!! i-2 i-1 i i+1 +!! ..--o------o------o------o------o--.. +!! i-1/2 +!! +!! For this fourth-order scheme, at least four cells must exist. +subroutine edge_values_explicit_h4cw( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index + !! is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + + ! Local variables + real :: dp(N) ! Input grid layer thicknesses, but with a minimum thickness [H ~> m or kg m-2] + real :: hNeglect ! A negligible thickness in the same units as h [H] + real :: da ! Difference between the unlimited scalar edge value estimates [A] + real :: a6 ! Scalar field differences that are proportional to the curvature [A] + real :: slk, srk ! Differences between adjacent cell averages of scalars [A] + real :: sck ! Scalar differences across a cell [A] + real :: au(N) ! Scalar field difference across each cell [A] + real :: al(N), ar(N) ! Scalar field at the left and right edges of a cell [A] + real :: h112(N+1), h122(N+1) ! Combinations of thicknesses [H ~> m or kg m-2] + real :: I_h12(N+1) ! Inverses of combinations of thickesses [H-1 ~> m-1 or m2 kg-1] + real :: h2_h123(N) ! A ratio of a layer thickness of the sum of 3 adjacent thicknesses [nondim] + real :: I_h0123(N) ! Inverse of the sum of 4 adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: h01_h112(N+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + real :: h23_h122(N+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + integer :: k + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + ! Set the thicknesses for very thin layers to some minimum value. + do k=1,N ; dp(k) = max(h(k), hNeglect) ; enddo + + !compute grid metrics + do k=2,N + h112(K) = 2.*dp(k-1) + dp(k) + h122(K) = dp(k-1) + 2.*dp(k) + I_h12(K) = 1.0 / (dp(k-1) + dp(k)) + enddo !k + do k=2,N-1 + h2_h123(k) = dp(k) / (dp(k) + (dp(k-1)+dp(k+1))) + enddo + do K=3,N-1 + I_h0123(K) = 1.0 / ((dp(k-2) + dp(k-1)) + (dp(k) + dp(k+1))) + + h01_h112(K) = (dp(k-2) + dp(k-1)) / (2.0*dp(k-1) + dp(k)) + h23_h122(K) = (dp(k) + dp(k+1)) / (dp(k-1) + 2.0*dp(k)) + enddo + + !Compute average slopes: Colella, Eq. (1.8) + au(1) = 0. + do k=2,N-1 + slk = u(k )-u(k-1) + srk = u(k+1)-u(k) + if (slk*srk > 0.) then + sck = h2_h123(k)*( h112(K)*srk*I_h12(K+1) + h122(K+1)*slk*I_h12(K) ) + au(k) = sign(min(abs(2.0*slk), abs(sck), abs(2.0*srk)), sck) + else + au(k) = 0. + endif + enddo !k + au(N) = 0. + + !Compute "first guess" edge values: Colella, Eq. (1.6) + al(1) = u(1) ! 1st layer PCM + ar(1) = u(1) ! 1st layer PCM + al(2) = u(1) ! 1st layer PCM + do K=3,N-1 + ! This is a 4th order explicit edge value estimate. + al(k) = (dp(k)*u(k-1) + dp(k-1)*u(k)) * I_h12(K) & + + I_h0123(K)*( 2.*dp(k)*dp(k-1)*I_h12(K)*(u(k)-u(k-1)) * & + ( h01_h112(K) - h23_h122(K) ) & + + (dp(k)*au(k-1)*h23_h122(K) - dp(k-1)*au(k)*h01_h112(K)) ) + ar(k-1) = al(k) + enddo !k + ar(N-1) = u(N) ! last layer PCM + al(N) = u(N) ! last layer PCM + ar(N) = u(N) ! last layer PCM + + !Set coefficients + do k=1,N + edge_val(k,1) = al(k) + edge_val(k,2) = ar(k) + enddo !k + +end subroutine edge_values_explicit_h4cw + +!> Compute ih4 edge values (implicit fourth order accurate) +!! in the same units as u. +!! +!! Compute edge values based on fourth-order implicit estimates. +!! +!! Fourth-order implicit estimates of edge values are based on a two-cell +!! stencil. A tridiagonal system is set up and is based on expressing the +!! edge values in terms of neighboring cell averages. The generic +!! relationship is +!! +!! \f[ +!! \alpha u_{i-1/2} + u_{i+1/2} + \beta u_{i+3/2} = a \bar{u}_i + b \bar{u}_{i+1} +!! \f] +!! +!! and the stencil looks like this +!! +!! i i+1 +!! ..--o------o------o--.. +!! i-1/2 i+1/2 i+3/2 +!! +!! In this routine, the coefficients \f$\alpha\f$, \f$\beta\f$, \f$a\f$ and \f$b\f$ are +!! computed, the tridiagonal system is built, boundary conditions are prescribed and +!! the system is solved to yield edge-value estimates. +!! +!! There are N+1 unknowns and we are able to write N-1 equations. The +!! boundary conditions close the system. +subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index + !! is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Local variables + integer :: i, j ! loop indexes + real :: h0, h1 ! cell widths [H] + real :: h_min ! A minimal cell width [H] + real :: h0_2, h1_2, h0h1 ! Squares or products of thicknesses [H2] + real :: h0ph1_2 ! The square of a sum of thicknesses [H2] + real :: h0ph1_4 ! The fourth power of a sum of thicknesses [H4] + real :: alpha, beta ! stencil coefficients [nondim] + real :: I_h2, abmix ! stencil coefficients [nondim] + real :: a, b ! Combinations of stencil coefficients [nondim] + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational constant [nondim] + real, parameter :: C1_3 = 1.0 / 3.0 ! A rational constant [nondim] + real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] + real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] + real :: dx ! Differences and averages of successive values of x [H] + real, dimension(4,4) :: Asys ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + real, dimension(4) :: Bsys ! The right hand side of the system to solve for C [A H] + real, dimension(4) :: Csys ! The coefficients of a fit polynomial in units that vary + ! with the index (j) as [A H^(j-1)] + real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] + tri_d, & ! tridiagonal system (middle diagonal) [nondim] + tri_c, & ! tridiagonal system central value [nondim], with tri_d = tri_c+tri_l+tri_u + tri_u, & ! tridiagonal system (upper diagonal) [nondim] + tri_b, & ! tridiagonal system (right hand side) [A] + tri_x ! tridiagonal system (solution vector) [A] + real :: hNeglect ! A negligible thickness [H] + logical :: use_2018_answers ! If true use older, less accurate expressions. + + use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) + if (use_2018_answers) then + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect + else + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + endif + + ! Loop on cells (except last one) + do i = 1,N-1 + if (use_2018_answers) then + ! Get cell widths + h0 = h(i) + h1 = h(i+1) + ! Avoid singularities when h0+h1=0 + if (h0+h1==0.) then + h0 = hNeglect + h1 = hNeglect + endif + + ! Auxiliary calculations + h0ph1_2 = (h0 + h1)**2 + h0ph1_4 = h0ph1_2**2 + h0h1 = h0 * h1 + h0_2 = h0 * h0 + h1_2 = h1 * h1 + + ! Coefficients + alpha = h1_2 / h0ph1_2 + beta = h0_2 / h0ph1_2 + a = 2.0 * h1_2 * ( h1_2 + 2.0 * h0_2 + 3.0 * h0h1 ) / h0ph1_4 + b = 2.0 * h0_2 * ( h0_2 + 2.0 * h1_2 + 3.0 * h0h1 ) / h0ph1_4 + + tri_d(i+1) = 1.0 + else ! Use expressions with less sensitivity to roundoff + ! Get cell widths + h0 = max(h(i), hNeglect) + h1 = max(h(i+1), hNeglect) + ! The 1e-12 here attempts to balance truncation errors from the differences of + ! large numbers against errors from approximating thin layers as non-vanishing. + if (abs(h0) < 1.0e-12*abs(h1)) h0 = 1.0e-12*h1 + if (abs(h1) < 1.0e-12*abs(h0)) h1 = 1.0e-12*h0 + I_h2 = 1.0 / ((h0 + h1)**2) + alpha = (h1 * h1) * I_h2 + beta = (h0 * h0) * I_h2 + abmix = (h0 * h1) * I_h2 + a = 2.0 * alpha * ( alpha + 2.0 * beta + 3.0 * abmix ) + b = 2.0 * beta * ( beta + 2.0 * alpha + 3.0 * abmix ) + + tri_c(i+1) = 2.0*abmix ! = 1.0 - alpha - beta + endif + + tri_l(i+1) = alpha + tri_u(i+1) = beta + + tri_b(i+1) = a * u(i) + b * u(i+1) + + enddo ! end loop on cells + + ! Boundary conditions: set the first boundary value + if (use_2018_answers) then + h_min = max( hNeglect, hMinFrac*sum(h(1:4)) ) + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(i) ) + x(i+1) = x(i) + dx + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(i) * dx + enddo + + call solve_linear_system( Asys, Bsys, Csys, 4 ) + + tri_b(1) = evaluation_polynomial( Csys, 4, x(1) ) ! Set the first edge value + tri_d(1) = 1.0 + else ! Use expressions with less sensitivity to roundoff + do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo + call end_value_h4(dz, u_tmp, Csys) + + tri_b(1) = Csys(1) ! Set the first edge value. + tri_c(1) = 1.0 + endif + tri_u(1) = 0.0 ! tri_l(1) = 0.0 + + ! Boundary conditions: set the last boundary value + if (use_2018_answers) then + h_min = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) + x(1) = 0.0 + do i=1,4 + dx = max(h_min, h(N-4+i) ) + x(i+1) = x(i) + dx + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(N-4+i) * dx + enddo + + call solve_linear_system( Asys, Bsys, Csys, 4 ) + + ! Set the last edge value + tri_b(N+1) = evaluation_polynomial( Csys, 4, x(5) ) + tri_d(N+1) = 1.0 + + else + ! Use expressions with less sensitivity to roundoff, including using a coordinate + ! system that sets the origin at the last interface in the domain. + do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo + call end_value_h4(dz, u_tmp, Csys) + + tri_b(N+1) = Csys(1) ! Set the last edge value + tri_c(N+1) = 1.0 + endif + tri_l(N+1) = 0.0 ! tri_u(N+1) = 0.0 + + ! Solve tridiagonal system and assign edge values + if (use_2018_answers) then + call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) + else + call solve_diag_dominant_tridiag( tri_l, tri_c, tri_u, tri_b, tri_x, N+1 ) + endif + + edge_val(1,1) = tri_x(1) + do i=2,N + edge_val(i,1) = tri_x(i) + edge_val(i-1,2) = tri_x(i) + enddo + edge_val(N,2) = tri_x(N+1) + +end subroutine edge_values_implicit_h4 + +!> Determine a one-sided 4th order polynomial fit of u to the data points for the purposes of specifying +!! edge values, as described in the appendix of White and Adcroft JCP 2008. +subroutine end_value_h4(dz, u, Csys) + real, dimension(4), intent(in) :: dz !< The thicknesses of 4 layers, starting at the edge [H]. + !! The values of dz must be positive. + real, dimension(4), intent(in) :: u !< The average properties of 4 layers, starting at the edge [A] + real, dimension(4), intent(out) :: Csys !< The four coefficients of a 4th order polynomial fit + !! of u as a function of z [A H-(n-1)] + + ! Local variables + real :: Wt(3,4) ! The weights of successive u differences in the 4 closed form expressions. + ! The units of Wt vary with the second index as [H-(n-1)]. + real :: h1, h2, h3, h4 ! Copies of the layer thicknesses [H] + real :: h12, h23, h34 ! Sums of two successive thicknesses [H] + real :: h123, h234 ! Sums of three successive thicknesses [H] + real :: h1234 ! Sums of all four thicknesses [H] + ! real :: I_h1 ! The inverse of the a thickness [H-1] + real :: I_h12, I_h23, I_h34 ! The inverses of sums of two thicknesses [H-1] + real :: I_h123, I_h234 ! The inverse of the sum of three thicknesses [H-1] + real :: I_h1234 ! The inverse of the sum of all four thicknesses [H-1] + real :: I_denom ! The inverse of the denominator some expressions [H-3] + real :: I_denB3 ! The inverse of the product of three sums of thicknesses [H-3] + real :: min_frac = 1.0e-6 ! The square of min_frac should be much larger than roundoff [nondim] + real, parameter :: C1_3 = 1.0 / 3.0 ! A rational parameter [nondim] + + ! These are only used for code verification + ! real, dimension(4) :: Atest ! The coefficients of an expression that is being tested. + ! real :: zavg, u_mag, c_mag + ! character(len=128) :: mesg + ! real, parameter :: C1_12 = 1.0 / 12.0 + + ! if ((dz(1) == dz(2)) .and. (dz(1) == dz(3)) .and. (dz(1) == dz(4))) then + ! ! There are simple closed-form expressions in this case + ! I_h1 = 0.0 ; if (dz(1) > 0.0) I_h1 = 1.0 / dz(1) + ! Csys(1) = u(1) + (-13.0 * (u(2)-u(1)) + 10.0 * (u(3)-u(2)) - 3.0 * (u(4)-u(3))) * (0.25*C1_3) + ! Csys(2) = (35.0 * (u(2)-u(1)) - 34.0 * (u(3)-u(2)) + 11.0 * (u(4)-u(3))) * (0.25*C1_3 * I_h1) + ! Csys(3) = (-5.0 * (u(2)-u(1)) + 8.0 * (u(3)-u(2)) - 3.0 * (u(4)-u(3))) * (0.25 * I_h1**2) + ! Csys(4) = ((u(2)-u(1)) - 2.0 * (u(3)-u(2)) + (u(4)-u(3))) * (0.5*C1_3) + ! else + + ! Express the coefficients as sums of the differences between properties of successive layers. + + h1 = dz(1) ; h2 = dz(2) ; h3 = dz(3) ; h4 = dz(4) + ! Some of the weights used below are proportional to (h1/(h2+h3))**2 or (h1/(h2+h3))*(h2/(h3+h4)) + ! so h2 and h3 should be adjusted to ensure that these ratios are not so large that property + ! differences at the level of roundoff are amplified to be of order 1. + if ((h2+h3) < min_frac*h1) h3 = min_frac*h1 - h2 + if ((h3+h4) < min_frac*h1) h4 = min_frac*h1 - h3 + + h12 = h1+h2 ; h23 = h2+h3 ; h34 = h3+h4 + h123 = h12 + h3 ; h234 = h2 + h34 ; h1234 = h12 + h34 + ! Find 3 reciprocals with a single division for efficiency. + I_denB3 = 1.0 / (h123 * h12 * h23) + I_h12 = (h123 * h23) * I_denB3 + I_h23 = (h12 * h123) * I_denB3 + I_h123 = (h12 * h23) * I_denB3 + I_denom = 1.0 / ( h1234 * (h234 * h34) ) + I_h34 = (h1234 * h234) * I_denom + I_h234 = (h1234 * h34) * I_denom + I_h1234 = (h234 * h34) * I_denom + + ! Calculation coefficients in the four equations + + ! The expressions for Csys(3) and Csys(4) come from reducing the 4x4 matrix problem into the following 2x2 + ! matrix problem, then manipulating the analytic solution to avoid any subtraction and simplifying. + ! (C1_3 * h123 * h23) * Csys(3) + (0.25 * h123 * h23 * (h3 + 2.0*h2 + 3.0*h1)) * Csys(4) = + ! (u(3)-u(1)) - (u(2)-u(1)) * (h12 + h23) * I_h12 + ! (C1_3 * ((h23 + h34) * h1234 + h23 * h3)) * Csys(3) + + ! (0.25 * ((h1234 + h123 + h12 + h1) * h23 * h3 + (h1234 + h12 + h1) * (h23 + h34) * h1234)) * Csys(4) = + ! (u(4)-u(1)) - (u(2)-u(1)) * (h123 + h234) * I_h12 + ! The final expressions for Csys(1) and Csys(2) were derived by algebraically manipulating the following expressions: + ! Csys(1) = (C1_3 * h1 * h12 * Csys(3) + 0.25 * h1 * h12 * (2.0*h1+h2) * Csys(4)) - & + ! (h1*I_h12)*(u(2)-u(1)) + u(1) + ! Csys(2) = (-2.0*C1_3 * (2.0*h1+h2) * Csys(3) - 0.5 * (h1**2 + h12 * (2.0*h1+h2)) * Csys(4)) + & + ! 2.0*I_h12 * (u(2)-u(1)) + ! These expressions are typically evaluated at x=0 and x=h1, so it is important that these are well behaved + ! for these values, suggesting that h1/h23 and h1/h34 should not be allowed to be too large. + + Wt(1,1) = -h1 * (I_h1234 + I_h123 + I_h12) ! > -3 + Wt(2,1) = h1 * h12 * ( I_h234 * I_h1234 + I_h23 * (I_h234 + I_h123) ) ! < (h1/h234) + (h1/h23)*(2+(h1/h234)) + Wt(3,1) = -h1 * h12 * h123 * I_denom ! > -(h1/h34)*(1+(h1/h234)) + + Wt(1,2) = 2.0 * (I_h12*(1.0 + (h1+h12) * (I_h1234 + I_h123)) + h1 * I_h1234*I_h123) ! < 10/h12 + Wt(2,2) = -2.0 * ((h1 * h12 * I_h1234) * (I_h23 * (I_h234 + I_h123)) + & ! > -(10+6*(h1/h234))/h23 + (h1+h12) * ( I_h1234*I_h234 + I_h23 * (I_h234 + I_h123) ) ) + Wt(3,2) = 2.0 * ((h1+h12) * h123 + h1*h12 ) * I_denom ! < (2+(6*h1/h234)) / h34 + + Wt(1,3) = -3.0 * I_h12 * I_h123* ( 1.0 + I_h1234 * ((h1+h12)+h123) ) ! > -12 / (h12*h123) + Wt(2,3) = 3.0 * I_h23 * ( I_h123 + I_h1234 * ((h1+h12)+h123) * (I_h123 + I_h234) ) ! < 12 / (h23^2) + Wt(3,3) = -3.0 * ((h1+h12)+h123) * I_denom ! > -9 / (h234*h23) + + Wt(1,4) = 4.0 * I_h1234 * I_h123 * I_h12 ! Wt*h1^3 < 4 + Wt(2,4) = -4.0 * I_h1234 * (I_h23 * (I_h123 + I_h234)) ! Wt*h1^3 > -4* (h1/h23)*(1+h1/h234) + Wt(3,4) = 4.0 * I_denom ! = 4.0*I_h1234 * I_h234 * I_h34 ! Wt*h1^3 < 4 * (h1/h234)*(h1/h34) + + Csys(1) = ((u(1) + Wt(1,1) * (u(2)-u(1))) + Wt(2,1) * (u(3)-u(2))) + Wt(3,1) * (u(4)-u(3)) + Csys(2) = (Wt(1,2) * (u(2)-u(1)) + Wt(2,2) * (u(3)-u(2))) + Wt(3,2) * (u(4)-u(3)) + Csys(3) = (Wt(1,3) * (u(2)-u(1)) + Wt(2,3) * (u(3)-u(2))) + Wt(3,3) * (u(4)-u(3)) + Csys(4) = (Wt(1,4) * (u(2)-u(1)) + Wt(2,4) * (u(3)-u(2))) + Wt(3,4) * (u(4)-u(3)) + + ! endif ! End of non-uniform layer thickness branch. + + ! To verify that these answers are correct, uncomment the following: +! u_mag = 0.0 ; do i=1,4 ; u_mag = max(u_mag, abs(u(i))) ; enddo +! do i = 1,4 +! if (i==1) then ; zavg = 0.5*dz(i) ; else ; zavg = zavg + 0.5*(dz(i-1)+dz(i)) ; endif +! Atest(1) = 1.0 +! Atest(2) = zavg ! = ( (z(i+1)**2) - (z(i)**2) ) / (2*dz(i)) +! Atest(3) = (zavg**2 + 0.25*C1_3*dz(i)**2) ! = ( (z(i+1)**3) - (z(i)**3) ) / (3*dz(i)) +! Atest(4) = zavg * (zavg**2 + 0.25*dz(i)**2) ! = ( (z(i+1)**4) - (z(i)**4) ) / (4*dz(i)) +! c_mag = 1.0 ; do k=0,3 ; do j=1,3 ; c_mag = c_mag + abs(Wt(j,k+1) * zavg**k) ; enddo ; enddo +! write(mesg, '("end_value_h4 line ", i2, " c_mag = ", es10.2, " u_mag = ", es10.2)') i, c_mag, u_mag +! call test_line(mesg, 4, Atest, Csys, u(i), u_mag*c_mag, tol=1.0e-15) +! enddo + +end subroutine end_value_h4 + + +!------------------------------------------------------------------------------ +!> Compute ih3 edge slopes (implicit third order accurate) +!! in the same units as h. +!! +!! Compute edge slopes based on third-order implicit estimates. Note that +!! the estimates are fourth-order accurate on uniform grids +!! +!! Third-order implicit estimates of edge slopes are based on a two-cell +!! stencil. A tridiagonal system is set up and is based on expressing the +!! edge slopes in terms of neighboring cell averages. The generic +!! relationship is +!! +!! \f[ +!! \alpha u'_{i-1/2} + u'_{i+1/2} + \beta u'_{i+3/2} = +!! a \bar{u}_i + b \bar{u}_{i+1} +!! \f] +!! +!! and the stencil looks like this +!! +!! i i+1 +!! ..--o------o------o--.. +!! i-1/2 i+1/2 i+3/2 +!! +!! In this routine, the coefficients \f$\alpha\f$, \f$\beta\f$, a and b are computed, +!! the tridiagonal system is built, boundary conditions are prescribed and +!! the system is solved to yield edge-slope estimates. +!! +!! There are N+1 unknowns and we are able to write N-1 equations. The +!! boundary conditions close the system. +subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the + !! second index is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Local variables + integer :: i, j ! loop indexes + real :: h0, h1 ! cell widths [H or nondim] + real :: h0_2, h1_2, h0h1 ! products of cell widths [H2 or nondim] + real :: h0_3, h1_3 ! products of three cell widths [H3 or nondim] + real :: d ! A temporary variable [H3] + real :: I_d ! A temporary variable [nondim] + real :: I_h ! Inverses of thicknesses [H-1] + real :: alpha, beta ! stencil coefficients [nondim] + real :: a, b ! weights of cells [H-1] + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational parameter [nondim] + real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] + real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real :: dx ! Differences and averages of successive values of x [H] + real, dimension(4,4) :: Asys ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + real, dimension(4) :: Bsys ! The right hand side of the system to solve for C [A H] + real, dimension(4) :: Csys ! The coefficients of a fit polynomial in units that vary with the + ! index (j) as [A H^(j-1)] + real, dimension(3) :: Dsys ! The coefficients of the first derivative of the fit polynomial + ! in units that vary with the index (j) as [A H^(j-2)] + real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] + tri_d, & ! tridiagonal system (middle diagonal) [nondim] + tri_c, & ! tridiagonal system central value [nondim], with tri_d = tri_c+tri_l+tri_u + tri_u, & ! tridiagonal system (upper diagonal) [nondim] + tri_b, & ! tridiagonal system (right hand side) [A H-1] + tri_x ! tridiagonal system (solution vector) [A H-1] + real :: hNeglect ! A negligible thickness [H]. + real :: hNeglect3 ! hNeglect^3 [H3]. + logical :: use_2018_answers ! If true use older, less accurate expressions. + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect3 = hNeglect**3 + use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) + + ! Loop on cells (except last one) + do i = 1,N-1 + + if (use_2018_answers) then + ! Get cell widths + h0 = h(i) + h1 = h(i+1) + + ! Auxiliary calculations + h0h1 = h0 * h1 + h0_2 = h0 * h0 + h1_2 = h1 * h1 + h0_3 = h0_2 * h0 + h1_3 = h1_2 * h1 + + d = 4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3 + + ! Coefficients + alpha = h1 * (h0_2 + h0h1 - h1_2) / ( d + hNeglect3 ) + beta = h0 * (h1_2 + h0h1 - h0_2) / ( d + hNeglect3 ) + a = -12.0 * h0h1 / ( d + hNeglect3 ) + b = -a + + tri_l(i+1) = alpha + tri_d(i+1) = 1.0 + tri_u(i+1) = beta + + tri_b(i+1) = a * u(i) + b * u(i+1) + else + ! Get cell widths + h0 = max(h(i), hNeglect) + h1 = max(h(i+1), hNeglect) + + I_h = 1.0 / (h0 + h1) + h0 = h0 * I_h ; h1 = h1 * I_h + + h0h1 = h0 * h1 ; h0_2 = h0 * h0 ; h1_2 = h1 * h1 + h0_3 = h0_2 * h0 ; h1_3 = h1_2 * h1 + + ! Set the tridiagonal coefficients + I_d = 1.0 / (4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3) ! = 1 / ((h0 + h1)**3 + h0*h1*(h0 + h1)) + tri_l(i+1) = (h1 * ((h0_2 + h0h1) - h1_2)) * I_d + ! tri_d(i+1) = 1.0 + tri_c(i+1) = 2.0 * ((h0_2 + h1_2) * (h0 + h1)) * I_d + tri_u(i+1) = (h0 * ((h1_2 + h0h1) - h0_2)) * I_d + ! The following expressions have been simplified using the nondimensionalization above: + ! I_d = 1.0 / (1.0 + h0h1) + ! tri_l(i+1) = (h0h1 - h1_3) * I_d + ! tri_c(i+1) = 2.0 * (h0_2 + h1_2) * I_d + ! tri_u(i+1) = (h0h1 - h0_3) * I_d + + tri_b(i+1) = 12.0 * (h0h1 * I_d) * ((u(i+1) - u(i)) * I_h) + endif + + enddo ! end loop on cells + + ! Boundary conditions: set the first edge slope + if (use_2018_answers) then + x(1) = 0.0 + do i = 1,4 + dx = h(i) + x(i+1) = x(i) + dx + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(i) * dx + enddo + + call solve_linear_system( Asys, Bsys, Csys, 4 ) + + Dsys(1) = Csys(2) ; Dsys(2) = 2.0 * Csys(3) ; Dsys(3) = 3.0 * Csys(4) + tri_b(1) = evaluation_polynomial( Dsys, 3, x(1) ) ! Set the first edge slope + tri_d(1) = 1.0 + else ! Use expressions with less sensitivity to roundoff + do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo + call end_value_h4(dz, u_tmp, Csys) + + ! Set the first edge slope + tri_b(1) = Csys(2) + tri_c(1) = 1.0 + endif + tri_u(1) = 0.0 ! tri_l(1) = 0.0 + + ! Boundary conditions: set the last edge slope + if (use_2018_answers) then + x(1) = 0.0 + do i = 1,4 + dx = h(N-4+i) + x(i+1) = x(i) + dx + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(N-4+i) * dx + enddo + + call solve_linear_system( Asys, Bsys, Csys, 4 ) + + Dsys(1) = Csys(2) ; Dsys(2) = 2.0 * Csys(3) ; Dsys(3) = 3.0 * Csys(4) + ! Set the last edge slope + tri_b(N+1) = evaluation_polynomial( Dsys, 3, x(5) ) + tri_d(N+1) = 1.0 + else + ! Use expressions with less sensitivity to roundoff, including using a coordinate + ! system that sets the origin at the last interface in the domain. + do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo + + call end_value_h4(dz, u_tmp, Csys) + + ! Set the last edge slope + tri_b(N+1) = -Csys(2) + tri_c(N+1) = 1.0 + endif + tri_l(N+1) = 0.0 ! tri_u(N+1) = 0.0 + + ! Solve tridiagonal system and assign edge slopes + if (use_2018_answers) then + call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) + else + call solve_diag_dominant_tridiag( tri_l, tri_c, tri_u, tri_b, tri_x, N+1 ) + endif + + do i = 2,N + edge_slopes(i,1) = tri_x(i) + edge_slopes(i-1,2) = tri_x(i) + enddo + edge_slopes(1,1) = tri_x(1) + edge_slopes(N,2) = tri_x(N+1) + +end subroutine edge_slopes_implicit_h3 + + +!------------------------------------------------------------------------------ +!> Compute ih5 edge slopes (implicit fifth order accurate) +subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the + !! second index is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + +! ----------------------------------------------------------------------------- +! Fifth-order implicit estimates of edge slopes are based on a four-cell, +! three-edge stencil. A tridiagonal system is set up and is based on +! expressing the edge slopes in terms of neighboring cell averages. +! +! The generic relationship is +! +! \alpha u'_{i-1/2} + u'_{i+1/2} + \beta u'_{i+3/2} = +! a \bar{u}_{i-1} + b \bar{u}_i + c \bar{u}_{i+1} + d \bar{u}_{i+2} +! +! and the stencil looks like this +! +! i-1 i i+1 i+2 +! ..--o------o------o------o------o--.. +! i-1/2 i+1/2 i+3/2 +! +! In this routine, the coefficients \alpha, \beta, a, b, c and d are +! computed, the tridiagonal system is built, boundary conditions are +! prescribed and the system is solved to yield edge-value estimates. +! +! Note that the centered stencil only applies to edges 3 to N-1 (edges are +! numbered 1 to n+1), which yields N-3 equations for N+1 unknowns. Two other +! equations are written by using a right-biased stencil for edge 2 and a +! left-biased stencil for edge N. The prescription of boundary conditions +! (using sixth-order polynomials) closes the system. +! +! CAUTION: For each edge, in order to determine the coefficients of the +! implicit expression, a 6x6 linear system is solved. This may +! become computationally expensive if regridding is carried out +! often. Figuring out closed-form expressions for these coefficients +! on nonuniform meshes turned out to be intractable. +! ----------------------------------------------------------------------------- + + ! Local variables + real :: h0, h1, h2, h3 ! cell widths [H] + real :: hMin ! The minimum thickness used in these calculations [H] + real :: h01, h01_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: h23, h23_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: hNeglect ! A negligible thickness [H]. + real :: h1_2, h2_2 ! Squares of thicknesses [H2] + real :: h1_3, h2_3 ! Cubes of thicknesses [H3] + real :: h1_4, h2_4 ! Fourth powers of thicknesses [H4] + real :: h1_5, h2_5 ! Fifth powers of thicknesses [H5] + real :: alpha, beta ! stencil coefficients [nondim] + real, dimension(7) :: x ! Coordinate system with 0 at edges in the same units as h [H] + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational parameter [nondim] + real, parameter :: C5_6 = 5.0 / 6.0 ! A rational parameter [nondim] + real :: dx, xavg ! Differences and averages of successive values of x [same units as h] + real, dimension(6,6) :: Asys ! The matrix that is being inverted for a solution, + ! in units that might vary with the second (j) index as [H^j] + real, dimension(6) :: Bsys ! The right hand side of the system to solve for C in various + ! units that sometimes vary with the intex (j) as [H^(j-1)] or [H^j] + ! or might be [A] + real, dimension(6) :: Csys ! The solution to a matrix equation usually [nondim] in this routine. + real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) [nondim] + tri_d, & ! trid. system (middle diagonal) [nondim] + tri_u, & ! trid. system (upper diagonal) [nondim] + tri_b, & ! trid. system (rhs) [A H-1] + tri_x ! trid. system (unknowns vector) [A H-1] + real :: h_Min_Frac = 1.0e-4 ! A minimum fractional thickness [nondim] + integer :: i, k ! loop indexes + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + ! Loop on cells (except the first and last ones) + do k = 2,N-2 + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) + h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) + h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) + + ! Auxiliary calculations + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + + ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009). The last 4 rows are + ! Asys(1:6,n) = (/ -n*(n-1)*(-h1)**(n-2), -n*(n-1)*h1**(n-2), (-1)**(n-1) * ((h0+h1)**n - h0**n) / h0, & + ! (-h1)**(n-1), h2**(n-1), ((h2+h3)**n - h2**n) / h3 /) + + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 6.0*h1, -6.0* h2, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -12.0*h1_2, -12.0*h2_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 20.0*h1_3, -20.0*h2_3, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -30.0*h1_4, -30.0*h2_4, & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) + + call linear_solver( 6, Asys, Bsys, Csys ) + + alpha = Csys(1) + beta = Csys(2) + + tri_l(k+1) = alpha + tri_d(k+1) = 1.0 + tri_u(k+1) = beta + tri_b(k+1) = Csys(3) * u(k-1) + Csys(4) * u(k) + Csys(5) * u(k+1) + Csys(6) * u(k+2) + + enddo ! end loop on cells + + ! Use a right-biased stencil for the second row, as described in Eq. (53) of White and Adcroft (2009). + + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) + h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) + h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) + + ! Auxiliary calculations + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + h01 = h0 + h1 ; h01_2 = h01 * h01 + + ! Compute matrix entries + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 6.0*h01, 0.0, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -12.0*h01_2, 0.0, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 20.0*(h01*h01_2), 0.0, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -30.0*(h01_2*h01_2), 0.0, & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) + + call linear_solver( 6, Asys, Bsys, Csys ) + + alpha = Csys(1) + beta = Csys(2) + + tri_l(2) = alpha + tri_d(2) = 1.0 + tri_u(2) = beta + tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) + + ! Boundary conditions: left boundary + x(1) = 0.0 + do i = 1,6 + dx = h(i) + xavg = x(i) + 0.5 * dx + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) + Bsys(i) = u(i) + x(i+1) = x(i) + dx + enddo + + call linear_solver( 6, Asys, Bsys, Csys ) + + tri_d(1) = 0.0 + tri_d(1) = 1.0 + tri_u(1) = 0.0 + tri_b(1) = Csys(2) ! first edge value + + ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). + + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) + h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) + h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) + + ! Auxiliary calculations + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + + h23 = h2 + h3 ; h23_2 = h23 * h23 + + ! Compute matrix entries + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 0.0, -6.0*h23, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ 0.0, -12.0*h23_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 0.0, -20.0*(h23*h23_2), (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ 0.0, -30.0*(h23_2*h23_2), & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) + + call linear_solver( 6, Asys, Bsys, Csys ) + + alpha = Csys(1) + beta = Csys(2) + + tri_l(N) = alpha + tri_d(N) = 1.0 + tri_u(N) = beta + tri_b(N) = Csys(3) * u(N-3) + Csys(4) * u(N-2) + Csys(5) * u(N-1) + Csys(6) * u(N) + + ! Boundary conditions: right boundary + x(1) = 0.0 + do i = 1,6 + dx = h(N+1-i) + xavg = x(i) + 0.5*dx + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) + Bsys(i) = u(N+1-i) + x(i+1) = x(i) + dx + enddo + + call linear_solver( 6, Asys, Bsys, Csys ) + + tri_l(N+1) = 0.0 + tri_d(N+1) = 1.0 + tri_u(N+1) = 0.0 + tri_b(N+1) = -Csys(2) + + ! Solve tridiagonal system and assign edge values + call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) + + do i = 2,N + edge_slopes(i,1) = tri_x(i) + edge_slopes(i-1,2) = tri_x(i) + enddo + edge_slopes(1,1) = tri_x(1) + edge_slopes(N,2) = tri_x(N+1) + +end subroutine edge_slopes_implicit_h5 + + +!> Compute ih6 edge values (implicit sixth order accurate) in the same units as u. +!! +!! Sixth-order implicit estimates of edge values are based on a four-cell, +!! three-edge stencil. A tridiagonal system is set up and is based on +!! expressing the edge values in terms of neighboring cell averages. +!! +!! The generic relationship is +!! +!! \f[ +!! \alpha u_{i-1/2} + u_{i+1/2} + \beta u_{i+3/2} = +!! a \bar{u}_{i-1} + b \bar{u}_i + c \bar{u}_{i+1} + d \bar{u}_{i+2} +!! \f] +!! +!! and the stencil looks like this +!! +!! i-1 i i+1 i+2 +!! ..--o------o------o------o------o--.. +!! i-1/2 i+1/2 i+3/2 +!! +!! In this routine, the coefficients \f$\alpha\f$, \f$\beta\f$, a, b, c and d are +!! computed, the tridiagonal system is built, boundary conditions are prescribed and +!! the system is solved to yield edge-value estimates. This scheme is described in detail +!! by White and Adcroft, 2009, J. Comp. Phys, https://doi.org/10.1016/j.jcp.2008.04.026 +!! +!! Note that the centered stencil only applies to edges 3 to N-1 (edges are +!! numbered 1 to n+1), which yields N-3 equations for N+1 unknowns. Two other +!! equations are written by using a right-biased stencil for edge 2 and a +!! left-biased stencil for edge N. The prescription of boundary conditions +!! (using sixth-order polynomials) closes the system. +!! +!! CAUTION: For each edge, in order to determine the coefficients of the +!! implicit expression, a 6x6 linear system is solved. This may +!! become computationally expensive if regridding is carried out +!! often. Figuring out closed-form expressions for these coefficients +!! on nonuniform meshes turned out to be intractable. +subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index + !! is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Local variables + real :: h0, h1, h2, h3 ! cell widths [H] + real :: hMin ! The minimum thickness used in these calculations [H] + real :: h01, h01_2, h01_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: h23, h23_2, h23_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: hNeglect ! A negligible thickness [H]. + real :: h1_2, h2_2, h1_3, h2_3 ! Cell widths raised to the 2nd and 3rd powers [H2] or [H3] + real :: h1_4, h2_4, h1_5, h2_5 ! Cell widths raised to the 4th and 5th powers [H4] or [H5] + real :: alpha, beta ! stencil coefficients [nondim] + real, dimension(7) :: x ! Coordinate system with 0 at edges in the same units as h [H] + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational parameter [nondim] + real, parameter :: C5_6 = 5.0 / 6.0 ! A rational parameter [nondim] + real :: dx, xavg ! Differences and averages of successive values of x [H] + real, dimension(6,6) :: Asys ! The matrix that is being inverted for a solution, + ! in units that might vary with the second (j) index as [H^j] + real, dimension(6) :: Bsys ! The right hand side of the system to solve for C in various + ! units that sometimes vary with the intex (j) as [H^(j-1)] or [H^j] + ! or might be [A] + real, dimension(6) :: Csys ! The solution to a matrix equation, which might be [nondim] or the + ! coefficients of a fit polynomial in units that vary with the + ! index (j) as [A H^(j-1)] + real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) [nondim] + tri_d, & ! trid. system (middle diagonal) [nondim] + tri_u, & ! trid. system (upper diagonal) [nondim] + tri_b, & ! trid. system (rhs) [A] + tri_x ! trid. system (unknowns vector) [A] + integer :: i, k ! loop indexes + + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + ! Loop on interior cells + do k = 2,N-2 + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, hMinFrac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) + h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) + h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) + + ! Auxiliary calculations + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + + ! Compute matrix entries as described in Eq. (48) of White and Adcroft (2009) + Asys(1:6,1) = (/ 1.0, 1.0, -1.0, -1.0, -1.0, -1.0 /) + Asys(1:6,2) = (/ -2.0*h1, 2.0*h2, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 3.0*h1_2, 3.0*h2_2, -(3.0*h1_2 + h0*(3.0*h1 + h0)), & ! = -((h0+h1)**3 - h1**3) / h0 + -h1_2, -h2_2, -(3.0*h2_2 + h3*(3.0*h2 + h3)) /) ! = -((h2+h3)**3 - h2**3) / h3 + Asys(1:6,4) = (/ -4.0*h1_3, 4.0*h2_3, (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + h1_3, -h2_3, -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 5.0*h1_4, 5.0*h2_4, -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + -h1_4, -h2_4, -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -6.0*h1_5, 6.0*h2_5, & + (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + h1_5, -h2_5, & + -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) + + call linear_solver( 6, Asys, Bsys, Csys ) + + alpha = Csys(1) + beta = Csys(2) + + tri_l(k+1) = alpha + tri_d(k+1) = 1.0 + tri_u(k+1) = beta + tri_b(k+1) = Csys(3) * u(k-1) + Csys(4) * u(k) + Csys(5) * u(k+1) + Csys(6) * u(k+2) + + enddo ! end loop on cells + + ! Use a right-biased stencil for the second row, as described in Eq. (49) of White and Adcroft (2009). + + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, hMinFrac*((h(1) + h(2)) + (h(3) + h(4)))) + h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) + h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) + + ! Auxiliary calculations + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + h01 = h0 + h1 ; h01_2 = h01 * h01 ; h01_3 = h01 * h01_2 + + ! Compute matrix entries + Asys(1:6,1) = (/ 1.0, 1.0, -1.0, -1.0, -1.0, -1.0 /) + Asys(1:6,2) = (/ -2.0*h01, 0.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 3.0*h01_2, 0.0, -(3.0*h1_2 + h0*(3.0*h1 + h0)), & + -h1_2, -h2_2, -(3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -4.0*h01_3, 0.0, (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + h1_3, -h2_3, -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 5.0*(h01_2*h01_2), 0.0, -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + -h1_4, -h2_4, -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -6.0*(h01_3*h01_2), 0.0, & + (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + h1_5, - h2_5, & + -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ -1.0, 2.0*h1, -3.0*h1_2, 4.0*h1_3, -5.0*h1_4, 6.0*h1_5 /) + + call linear_solver( 6, Asys, Bsys, Csys ) + + alpha = Csys(1) + beta = Csys(2) + + tri_l(2) = alpha + tri_d(2) = 1.0 + tri_u(2) = beta + tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) + + ! Boundary conditions: left boundary + hMin = max( hNeglect, hMinFrac*((h(1)+h(2)) + (h(5)+h(6)) + (h(3)+h(4))) ) + x(1) = 0.0 + do i = 1,6 + dx = max( hMin, h(i) ) + xavg = x(i) + 0.5*dx + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) + Bsys(i) = u(i) + x(i+1) = x(i) + dx + enddo + + call linear_solver( 6, Asys, Bsys, Csys ) + + tri_l(1) = 0.0 + tri_d(1) = 1.0 + tri_u(1) = 0.0 + tri_b(1) = evaluation_polynomial( Csys, 6, x(1) ) ! first edge value + + ! Use a left-biased stencil for the second to last row, as described in Eq. (50) of White and Adcroft (2009). + + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, hMinFrac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) + h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) + h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) + + ! Auxiliary calculations + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + h23 = h2 + h3 ; h23_2 = h23 * h23 ; h23_3 = h23 * h23_2 + + ! Compute matrix entries + Asys(1:6,1) = (/ 1.0, 1.0, -1.0, -1.0, -1.0, -1.0 /) + Asys(1:6,2) = (/ 0.0, 2.0*h23, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 0.0, 3.0*h23_2, -(3.0*h1_2 + h0*(3.0*h1 + h0)), & + -h1_2, -h2_2, -(3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ 0.0, 4.0*h23_3, (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + h1_3, -h2_3, -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 0.0, 5.0*(h23_2*h23_2), -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + -h1_4, -h2_4, -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ 0.0, 6.0*(h23_3*h23_2), & + (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + h1_5, -h2_5, & + -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ -1.0, -2.0*h2, -3.0*h2_2, -4.0*h2_3, -5.0*h2_4, -6.0*h2_5 /) + + call linear_solver( 6, Asys, Bsys, Csys ) + + alpha = Csys(1) + beta = Csys(2) + + tri_l(N) = alpha + tri_d(N) = 1.0 + tri_u(N) = beta + tri_b(N) = Csys(3) * u(N-3) + Csys(4) * u(N-2) + Csys(5) * u(N-1) + Csys(6) * u(N) + + ! Boundary conditions: right boundary + hMin = max( hNeglect, hMinFrac*(h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) ) + x(1) = 0.0 + do i = 1,6 + dx = max( hMin, h(N+1-i) ) + xavg = x(i) + 0.5 * dx + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) + Bsys(i) = u(N+1-i) + x(i+1) = x(i) + dx + enddo + + call linear_solver( 6, Asys, Bsys, Csys ) + + tri_l(N+1) = 0.0 + tri_d(N+1) = 1.0 + tri_u(N+1) = 0.0 + tri_b(N+1) = Csys(1) + + ! Solve tridiagonal system and assign edge values + call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) + + do i = 2,N + edge_val(i,1) = tri_x(i) + edge_val(i-1,2) = tri_x(i) + enddo + edge_val(1,1) = tri_x(1) + edge_val(N,2) = tri_x(N+1) + +end subroutine edge_values_implicit_h6 + + +!> Test that A*C = R to within a tolerance, issuing a fatal error with an explanatory message if they do not. +subroutine test_line(msg, N, A, C, R, mag, tol) + character(len=*), intent(in) :: msg !< An identifying message for this test + integer, intent(in) :: N !< The number of points in the system + real, dimension(4), intent(in) :: A !< One of the two vectors being multiplied in arbitrary units [A] + real, dimension(4), intent(in) :: C !< One of the two vectors being multiplied in arbitrary units [B] + real, intent(in) :: R !< The expected solution of the equation [A B] + real, intent(in) :: mag !< The magnitude of leading order terms in this line [A B] + real, optional, intent(in) :: tol !< The fractional tolerance for the sums [nondim] + + real :: sum, sum_mag ! The sum of the products and their magnitude in arbitrary units [A B] + real :: tolerance ! The fractional tolerance for the sums [nondim] + character(len=128) :: mesg2 + integer :: i + + tolerance = 1.0e-12 ; if (present(tol)) tolerance = tol + + sum = 0.0 ; sum_mag = max(0.0,mag) + do i=1,N + sum = sum + A(i) * C(i) + sum_mag = sum_mag + abs(A(i) * C(i)) + enddo + + if (abs(sum - R) > tolerance * (sum_mag + abs(R))) then + write(mesg2, '(", Fractional error = ", es12.4,", sum = ", es12.4)') (sum - R) / (sum_mag + abs(R)), sum + call MOM_error(FATAL, "Failed line test: "//trim(msg)//trim(mesg2)) + endif + +end subroutine test_line + +end module regrid_edge_values diff --git a/ALE/regrid_interp.F90 b/ALE/regrid_interp.F90 new file mode 100644 index 0000000000..641ae7e6c2 --- /dev/null +++ b/ALE/regrid_interp.F90 @@ -0,0 +1,557 @@ +!> Vertical interpolation for regridding +module regrid_interp + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_string_functions, only : uppercase + +use regrid_edge_values, only : edge_values_explicit_h2, edge_values_explicit_h4 +use regrid_edge_values, only : edge_values_explicit_h4cw +use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 +use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 + +use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation +use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use PPM_functions, only : PPM_monotonicity +use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 + +use P1M_functions, only : P1M_interpolation, P1M_boundary_extrapolation +use P3M_functions, only : P3M_interpolation, P3M_boundary_extrapolation + +implicit none ; private + +!> Control structure for regrid_interp module +type, public :: interp_CS_type ; private + + !> The following parameter is only relevant when used with the target + !! interface densities regridding scheme. It indicates which interpolation + !! to use to determine the grid. + integer :: interpolation_scheme = -1 + + !> Indicate whether high-order boundary extrapolation should be used within + !! boundary cells + logical :: boundary_extrapolation + + !> The vintage of the expressions to use for regridding + integer :: answer_date = 99991231 +end type interp_CS_type + +public regridding_set_ppolys, build_and_interpolate_grid +public set_interp_scheme, set_interp_extrap, set_interp_answer_date + +! List of interpolation schemes +integer, parameter :: INTERPOLATION_P1M_H2 = 0 !< O(h^2) +integer, parameter :: INTERPOLATION_P1M_H4 = 1 !< O(h^2) +integer, parameter :: INTERPOLATION_P1M_IH4 = 2 !< O(h^2) +integer, parameter :: INTERPOLATION_PLM = 3 !< O(h^2) +integer, parameter :: INTERPOLATION_PPM_CW =10 !< O(h^3) +integer, parameter :: INTERPOLATION_PPM_H4 = 4 !< O(h^3) +integer, parameter :: INTERPOLATION_PPM_IH4 = 5 !< O(h^3) +integer, parameter :: INTERPOLATION_P3M_IH4IH3 = 6 !< O(h^4) +integer, parameter :: INTERPOLATION_P3M_IH6IH5 = 7 !< O(h^4) +integer, parameter :: INTERPOLATION_PQM_IH4IH3 = 8 !< O(h^4) +integer, parameter :: INTERPOLATION_PQM_IH6IH5 = 9 !< O(h^5) + +!>@{ Interpolant degrees +integer, parameter :: DEGREE_1 = 1, DEGREE_2 = 2, DEGREE_3 = 3, DEGREE_4 = 4 +integer, public, parameter :: DEGREE_MAX = 5 +!>@} + +!> When the N-R algorithm produces an estimate that lies outside [0,1], the +!! estimate is set to be equal to the boundary location, 0 or 1, plus or minus +!! an offset, respectively, when the derivative is zero at the boundary [nondim]. +real, public, parameter :: NR_OFFSET = 1e-6 +!> Maximum number of Newton-Raphson iterations. Newton-Raphson iterations are +!! used to build the new grid by finding the coordinates associated with +!! target densities and interpolations of degree larger than 1. +integer, public, parameter :: NR_ITERATIONS = 8 +!> Tolerance for Newton-Raphson iterations (stop when increment falls below this) [nondim] +real, public, parameter :: NR_TOLERANCE = 1e-12 + +contains + +!> Builds an interpolated profile for the densities within each grid cell. +!! +!! It may happen that, given a high-order interpolator, the number of +!! available layers is insufficient (e.g., there are two available layers for +!! a third-order PPM ih4 scheme). In these cases, we resort to the simplest +!! continuous linear scheme (P1M h2). +subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & + ppoly0_coefs, degree, h_neglect, h_neglect_edge) + type(interp_CS_type), intent(in) :: CS !< Interpolation control structure + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: densities !< Actual cell densities [A] + real, dimension(n0), intent(in) :: h0 !< cell widths on source grid [H] + real, dimension(n0,2), intent(inout) :: ppoly0_E !< Edge value of polynomial [A] + real, dimension(n0,2), intent(inout) :: ppoly0_S !< Edge slope of polynomial [A H-1] + real, dimension(n0,DEGREE_MAX+1), intent(inout) :: ppoly0_coefs !< Coefficients of polynomial [A] + integer, intent(inout) :: degree !< The degree of the polynomials + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions [H] + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations [H] + !! in the same units as h0. + ! Local variables + logical :: extrapolate + + ! Reset piecewise polynomials + ppoly0_E(:,:) = 0.0 + ppoly0_S(:,:) = 0.0 + ppoly0_coefs(:,:) = 0.0 + + extrapolate = CS%boundary_extrapolation + + ! Compute the interpolated profile of the density field and build grid + select case (CS%interpolation_scheme) + + case ( INTERPOLATION_P1M_H2 ) + degree = DEGREE_1 + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + + case ( INTERPOLATION_P1M_H4 ) + degree = DEGREE_1 + if ( n0 >= 4 ) then + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + else + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + endif + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + + case ( INTERPOLATION_P1M_IH4 ) + degree = DEGREE_1 + if ( n0 >= 4 ) then + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + else + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + endif + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + + case ( INTERPOLATION_PLM ) + degree = DEGREE_1 + call PLM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) + if (extrapolate) then + call PLM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) + endif + + case ( INTERPOLATION_PPM_CW ) + if ( n0 >= 4 ) then + degree = DEGREE_2 + call edge_values_explicit_h4cw( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call PPM_monotonicity( n0, densities, ppoly0_E ) + call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & + ppoly0_coefs, h_neglect ) + endif + else + degree = DEGREE_1 + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + endif + + case ( INTERPOLATION_PPM_H4 ) + if ( n0 >= 4 ) then + degree = DEGREE_2 + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & + ppoly0_coefs, h_neglect ) + endif + else + degree = DEGREE_1 + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + endif + + case ( INTERPOLATION_PPM_IH4 ) + if ( n0 >= 4 ) then + degree = DEGREE_2 + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & + ppoly0_coefs, h_neglect ) + endif + else + degree = DEGREE_1 + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + endif + + case ( INTERPOLATION_P3M_IH4IH3 ) + if ( n0 >= 4 ) then + degree = DEGREE_3 + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answer_date=CS%answer_date ) + call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect, h_neglect_edge ) + endif + else + degree = DEGREE_1 + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + endif + + case ( INTERPOLATION_P3M_IH6IH5 ) + if ( n0 >= 6 ) then + degree = DEGREE_3 + call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answer_date=CS%answer_date ) + call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect, h_neglect_edge ) + endif + else + degree = DEGREE_1 + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + endif + + case ( INTERPOLATION_PQM_IH4IH3 ) + if ( n0 >= 4 ) then + degree = DEGREE_4 + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answer_date=CS%answer_date ) + call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) + endif + else + degree = DEGREE_1 + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + endif + + case ( INTERPOLATION_PQM_IH6IH5 ) + if ( n0 >= 6 ) then + degree = DEGREE_4 + call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge, answer_date=CS%answer_date ) + call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answer_date=CS%answer_date ) + call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) + endif + else + degree = DEGREE_1 + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + endif + end select + +end subroutine regridding_set_ppolys + +!> Given target values (e.g., density), build new grid based on polynomial +!! +!! Given the grid 'grid0' and the piecewise polynomial interpolant +!! 'ppoly0' (possibly discontinuous), the coordinates of the new grid 'grid1' +!! are determined by finding the corresponding target interface densities. +subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & + target_values, degree, n1, h1, x1, answer_date ) + integer, intent(in) :: n0 !< Number of points on source grid + integer, intent(in) :: n1 !< Number of points on target grid + real, dimension(n0), intent(in) :: h0 !< Thicknesses of source grid cells [H] + real, dimension(n0+1), intent(in) :: x0 !< Source interface positions [H] + real, dimension(n0,2), intent(in) :: ppoly0_E !< Edge values of interpolating polynomials [A] + real, dimension(n0,DEGREE_MAX+1), & + intent(in) :: ppoly0_coefs !< Coefficients of interpolating polynomials [A] + real, dimension(n1+1), intent(in) :: target_values !< Target values of interfaces [A] + integer, intent(in) :: degree !< Degree of interpolating polynomials + real, dimension(n1), intent(inout) :: h1 !< Thicknesses of target grid cells [H] + real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + ! Local variables + integer :: k ! loop index + real :: t ! current interface target density + + ! Make sure boundary coordinates of new grid coincide with boundary + ! coordinates of previous grid + x1(1) = x0(1) + x1(n1+1) = x0(n0+1) + + ! Find coordinates for interior target values + do k = 2,n1 + t = target_values(k) + x1(k) = get_polynomial_coordinate ( n0, h0, x0, ppoly0_E, ppoly0_coefs, t, degree, & + answer_date=answer_date ) + h1(k-1) = x1(k) - x1(k-1) + enddo + h1(n1) = x1(n1+1) - x1(n1) + +end subroutine interpolate_grid + +!> Build a grid by interpolating for target values +subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, & + n1, h1, x1, h_neglect, h_neglect_edge) + type(interp_CS_type), intent(in) :: CS !< A control structure for regrid_interp + integer, intent(in) :: n0 !< The number of points on the input grid + integer, intent(in) :: n1 !< The number of points on the output grid + real, dimension(n0), intent(in) :: densities !< Input cell densities [R ~> kg m-3] + real, dimension(n1+1), intent(in) :: target_values !< Target values of interfaces [R ~> kg m-3] + real, dimension(n0), intent(in) :: h0 !< Initial cell widths [H] + real, dimension(n0+1), intent(in) :: x0 !< Source interface positions [H] + real, dimension(n1), intent(inout) :: h1 !< Output cell widths [H] + real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions [H] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions [H] + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations [H] + !! in the same units as h0. + + real, dimension(n0,2) :: ppoly0_E ! Polynomial edge values [R ~> kg m-3] + real, dimension(n0,2) :: ppoly0_S ! Polynomial edge slopes [R H-1] + real, dimension(n0,DEGREE_MAX+1) :: ppoly0_C ! Polynomial interpolant coeficients on the local 0-1 grid [R ~> kg m-3] + integer :: degree + + call regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, ppoly0_C, & + degree, h_neglect, h_neglect_edge) + call interpolate_grid(n0, h0, x0, ppoly0_E, ppoly0_C, target_values, degree, & + n1, h1, x1, answer_date=CS%answer_date) +end subroutine build_and_interpolate_grid + +!> Given a target value, find corresponding coordinate for given polynomial +!! +!! Here, 'ppoly' is assumed to be a piecewise discontinuous polynomial of degree +!! 'degree' throughout the domain defined by 'grid'. A target value is given +!! and we need to determine the corresponding grid coordinate to define the +!! new grid. +!! +!! If the target value is out of range, the grid coordinate is simply set to +!! be equal to one of the boundary coordinates, which results in vanished layers +!! near the boundaries. +!! +!! IT IS ASSUMED THAT THE PIECEWISE POLYNOMIAL IS MONOTONICALLY INCREASING. +!! IF THIS IS NOT THE CASE, THE NEW GRID MAY BE ILL-DEFINED. +!! +!! It is assumed that the number of cells defining 'grid' and 'ppoly' are the +!! same. +function get_polynomial_coordinate( N, h, x_g, edge_values, ppoly_coefs, & + target_value, degree, answer_date ) result ( x_tgt ) + ! Arguments + integer, intent(in) :: N !< Number of grid cells + real, dimension(N), intent(in) :: h !< Grid cell thicknesses [H] + real, dimension(N+1), intent(in) :: x_g !< Grid interface locations [H] + real, dimension(N,2), intent(in) :: edge_values !< Edge values of interpolating polynomials [A] + real, dimension(N,DEGREE_MAX+1), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials [A] + real, intent(in) :: target_value !< Target value to find position for [A] + integer, intent(in) :: degree !< Degree of the interpolating polynomials + integer, intent(in) :: answer_date !< The vintage of the expressions to use + real :: x_tgt !< The position of x_g at which target_value is found [H] + + ! Local variables + real :: xi0 ! normalized target coordinate [nondim] + real, dimension(DEGREE_MAX) :: a ! polynomial coefficients [A] + real :: numerator + real :: denominator + real :: delta ! Newton-Raphson increment [nondim] +! real :: x ! global target coordinate + real :: eps ! offset used to get away from boundaries [nondim] + real :: grad ! gradient during N-R iterations [A] + integer :: i, k, iter ! loop indices + integer :: k_found ! index of target cell + character(len=320) :: mesg + logical :: use_2018_answers ! If true use older, less accurate expressions. + + eps = NR_OFFSET + k_found = -1 + use_2018_answers = (answer_date < 20190101) + + ! If the target value is outside the range of all values, we + ! force the target coordinate to be equal to the lowest or + ! largest value, depending on which bound is overtaken + if ( target_value <= edge_values(1,1) ) then + x_tgt = x_g(1) + return ! return because there is no need to look further + endif + + ! Since discontinuous edge values are allowed, we check whether the target + ! value lies between two discontinuous edge values at interior interfaces + do k = 2,N + if ( ( target_value >= edge_values(k-1,2) ) .AND. ( target_value <= edge_values(k,1) ) ) then + x_tgt = x_g(k) + return ! return because there is no need to look further + endif + enddo + + ! If the target value is outside the range of all values, we + ! force the target coordinate to be equal to the lowest or + ! largest value, depending on which bound is overtaken + if ( target_value >= edge_values(N,2) ) then + x_tgt = x_g(N+1) + return ! return because there is no need to look further + endif + + ! At this point, we know that the target value is bounded and does not + ! lie between discontinuous, monotonic edge values. Therefore, + ! there is a unique solution. We loop on all cells and find which one + ! contains the target value. The variable k_found holds the index value + ! of the cell where the taregt value lies. + do k = 1,N + if ( ( target_value > edge_values(k,1) ) .AND. ( target_value < edge_values(k,2) ) ) then + k_found = k + exit + endif + enddo + + ! At this point, 'k_found' should be strictly positive. If not, this is + ! a major failure because it means we could not find any target cell + ! despite the fact that the target value lies between the extremes. It + ! means there is a major problem with the interpolant. This needs to be + ! reported. + if ( k_found == -1 ) then + write(mesg,*) 'Could not find target coordinate', target_value, 'in get_polynomial_coordinate. This is '//& + 'caused by an inconsistent interpolant (perhaps not monotonically increasing):', & + target_value, edge_values(1,1), edge_values(N,2) + call MOM_error( FATAL, mesg ) + endif + + ! Reset all polynomial coefficients to 0 and copy those pertaining to + ! the found cell + a(:) = 0.0 + do i = 1,degree+1 + a(i) = ppoly_coefs(k_found,i) + enddo + + ! Guess the middle of the cell to start Newton-Raphson iterations + xi0 = 0.5 + + ! Newton-Raphson iterations + do iter = 1,NR_ITERATIONS + + if (use_2018_answers) then + numerator = a(1) + a(2)*xi0 + a(3)*xi0*xi0 + a(4)*xi0*xi0*xi0 + & + a(5)*xi0*xi0*xi0*xi0 - target_value + denominator = a(2) + 2*a(3)*xi0 + 3*a(4)*xi0*xi0 + 4*a(5)*xi0*xi0*xi0 + else ! These expressions are mathematicaly equivalent but more accurate. + numerator = (a(1) - target_value) + xi0*(a(2) + xi0*(a(3) + xi0*(a(4) + a(5)*xi0))) + denominator = a(2) + xi0*(2.*a(3) + xi0*(3.*a(4) + 4.*a(5)*xi0)) + endif + + delta = -numerator / denominator + + xi0 = xi0 + delta + + ! Check whether new estimate is out of bounds. If the new estimate is + ! indeed out of bounds, we manually set it to be equal to the overtaken + ! bound with a small offset towards the interior when the gradient of + ! the function at the boundary is zero (in which case, the Newton-Raphson + ! algorithm does not converge). + if ( xi0 < 0.0 ) then + xi0 = 0.0 + grad = a(2) + if ( grad == 0.0 ) xi0 = xi0 + eps + endif + + if ( xi0 > 1.0 ) then + xi0 = 1.0 + if (use_2018_answers) then + grad = a(2) + 2*a(3) + 3*a(4) + 4*a(5) + else ! These expressions are mathematicaly equivalent but more accurate. + grad = a(2) + (2.*a(3) + (3.*a(4) + 4.*a(5))) + endif + if ( grad == 0.0 ) xi0 = xi0 - eps + endif + + ! break if converged or too many iterations taken + if ( abs(delta) < NR_TOLERANCE ) exit + enddo ! end Newton-Raphson iterations + + x_tgt = x_g(k_found) + xi0 * h(k_found) +end function get_polynomial_coordinate + +!> Numeric value of interpolation_scheme corresponding to scheme name +integer function interpolation_scheme(interp_scheme) + character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_CW", "PPM_H4", + !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" + + select case ( uppercase(trim(interp_scheme)) ) + case ("P1M_H2"); interpolation_scheme = INTERPOLATION_P1M_H2 + case ("P1M_H4"); interpolation_scheme = INTERPOLATION_P1M_H4 + case ("P1M_IH2"); interpolation_scheme = INTERPOLATION_P1M_IH4 + case ("PLM"); interpolation_scheme = INTERPOLATION_PLM + case ("PPM_CW"); interpolation_scheme = INTERPOLATION_PPM_CW + case ("PPM_H4"); interpolation_scheme = INTERPOLATION_PPM_H4 + case ("PPM_IH4"); interpolation_scheme = INTERPOLATION_PPM_IH4 + case ("P3M_IH4IH3"); interpolation_scheme = INTERPOLATION_P3M_IH4IH3 + case ("P3M_IH6IH5"); interpolation_scheme = INTERPOLATION_P3M_IH6IH5 + case ("PQM_IH4IH3"); interpolation_scheme = INTERPOLATION_PQM_IH4IH3 + case ("PQM_IH6IH5"); interpolation_scheme = INTERPOLATION_PQM_IH6IH5 + case default ; call MOM_error(FATAL, "regrid_interp: "//& + "Unrecognized choice for INTERPOLATION_SCHEME ("//trim(interp_scheme)//").") + end select +end function interpolation_scheme + +!> Store the interpolation_scheme value in the interp_CS based on the input string. +subroutine set_interp_scheme(CS, interp_scheme) + type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp + character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_CW", "PPM_H4", + !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" + + CS%interpolation_scheme = interpolation_scheme(interp_scheme) +end subroutine set_interp_scheme + +!> Store the boundary_extrapolation value in the interp_CS +subroutine set_interp_extrap(CS, extrap) + type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp + logical, intent(in) :: extrap !< Indicate whether high-order boundary + !! extrapolation should be used in boundary cells + + CS%boundary_extrapolation = extrap +end subroutine set_interp_extrap + +!> Store the value of the answer_date in the interp_CS +subroutine set_interp_answer_date(CS, answer_date) + type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp + integer, intent(in) :: answer_date !< An integer encoding the vintage of + !! the expressions to use for regridding + + CS%answer_date = answer_date +end subroutine set_interp_answer_date + +end module regrid_interp diff --git a/ALE/regrid_solvers.F90 b/ALE/regrid_solvers.F90 new file mode 100644 index 0000000000..6e5b3a0cb0 --- /dev/null +++ b/ALE/regrid_solvers.F90 @@ -0,0 +1,291 @@ +!> Solvers of linear systems. +module regrid_solvers + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, FATAL + +implicit none ; private + +public :: solve_linear_system, linear_solver, solve_tridiagonal_system, solve_diag_dominant_tridiag + +contains + +!> Solve the linear system AX = R by Gaussian elimination +!! +!! This routine uses Gauss's algorithm to transform the system's original +!! matrix into an upper triangular matrix. Back substitution yields the answer. +!! The matrix A must be square, with the first index varing down the column. +subroutine solve_linear_system( A, R, X, N, answer_date ) + integer, intent(in) :: N !< The size of the system + real, dimension(N,N), intent(inout) :: A !< The matrix being inverted in arbitrary units [A] on + !! input, but internally modified to become nondimensional + !! during the solver. + real, dimension(N), intent(inout) :: R !< system right-hand side in arbitrary units [A B] on + !! input, but internally modified to have units of [B] + !! during the solver + real, dimension(N), intent(inout) :: X !< solution vector in arbitrary units [B] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + ! Local variables + real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed [A] + real :: factor ! The factor that eliminates the leading nonzero element in a row [A-1] + real :: pivot, I_pivot ! The pivot value and its reciprocal, in [A] and [A-1] + real :: swap_a, swap_b ! Swap space in various units [various] + logical :: found_pivot ! If true, a pivot has been found + logical :: old_answers ! If true, use expressions that give the original (2008 through 2018) MOM6 answers + integer :: i, j, k + + old_answers = .true. ; if (present(answer_date)) old_answers = (answer_date < 20190101) + + ! Loop on rows to transform the problem into multiplication by an upper-right matrix. + do i = 1,N-1 + + + ! Start to look for a pivot in the current row, i. If the pivot in row i is not valid, + ! keep looking for a valid pivot by searching the entries of column i in rows below row i. + ! Once a valid pivot is found (say in row k), rows i and k are swaped. + found_pivot = .false. + k = i + do while ( ( .NOT. found_pivot ) .AND. ( k <= N ) ) + if ( abs( A(k,i) ) > eps ) then ! A valid pivot has been found + found_pivot = .true. + else ! Seek a valid pivot in the next row + k = k + 1 + endif + enddo ! end loop to find pivot + + ! If no pivot could be found, the system is singular. + if ( .NOT. found_pivot ) then + write(0,*) ' A=',A + call MOM_error( FATAL, 'The linear system is singular !' ) + endif + + ! If the pivot is in a row that is different than row i, that is if + ! k is different than i, we need to swap those two rows + if ( k /= i ) then + do j = 1,N + swap_a = A(i,j) ; A(i,j) = A(k,j) ; A(k,j) = swap_a + enddo + swap_b = R(i) ; R(i) = R(k) ; R(k) = swap_b + endif + + ! Transform pivot to 1 by dividing the entire row (right-hand side included) by the pivot + if (old_answers) then + pivot = A(i,i) + do j = i,N ; A(i,j) = A(i,j) / pivot ; enddo + R(i) = R(i) / pivot + else + I_pivot = 1.0 / A(i,i) + A(i,i) = 1.0 + do j = i+1,N ; A(i,j) = A(i,j) * I_pivot ; enddo + R(i) = R(i) * I_pivot + endif + + ! #INV: At this point, A(i,i) is a suitable pivot and it is equal to 1 + + ! Put zeros in column for all rows below that contain the pivot (which is row i) + do k = i+1,N ! k is the row index + factor = A(k,i) + ! A(k,i) = 0.0 ! These elements are not used again, so this line can be skipped for speed. + do j = i+1,N ! j is the column index + A(k,j) = A(k,j) - factor * A(i,j) + enddo + R(k) = R(k) - factor * R(i) + enddo + + enddo ! end loop on i + + ! Solve system by back substituting in what is now an upper-right matrix. + X(N) = R(N) / A(N,N) ! The last row is now trivially solved. + do i = N-1,1,-1 ! loop on rows, starting from second to last row + X(i) = R(i) + do j = i+1,N + X(i) = X(i) - A(i,j) * X(j) + enddo + if (old_answers) X(i) = X(i) / A(i,i) + enddo + +end subroutine solve_linear_system + +!> Solve the linear system AX = R by Gaussian elimination +!! +!! This routine uses Gauss's algorithm to transform the system's original +!! matrix into an upper triangular matrix. Back substitution then yields the answer. +!! The matrix A must be square, with the first index varing along the row. +subroutine linear_solver( N, A, R, X ) + integer, intent(in) :: N !< The size of the system + real, dimension(N,N), intent(inout) :: A !< The matrix being inverted in arbitrary units [A] on + !! input, but internally modified to become nondimensional + !! during the solver. + real, dimension(N), intent(inout) :: R !< system right-hand side in [A B] on input, but internally + !! modified to have units of [B] during the solver + real, dimension(N), intent(inout) :: X !< solution vector [B] + + ! Local variables + real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed [A] + real :: factor ! The factor that eliminates the leading nonzero element in a row [A-1]. + real :: I_pivot ! The reciprocal of the pivot value [A-1] + real :: swap ! Swap space used in various units [various] + integer :: i, j, k + + ! Loop on rows to transform the problem into multiplication by an upper-right matrix. + do i=1,N-1 + ! Seek a pivot for column i starting in row i, and continuing into the remaining rows. If the + ! pivot is in a row other than i, swap them. If no valid pivot is found, i = N+1 after this loop. + do k=i,N ; if ( abs( A(i,k) ) > eps ) exit ; enddo ! end loop to find pivot + if ( k > N ) then ! No pivot could be found and the system is singular. + write(0,*) ' A=',A + call MOM_error( FATAL, 'The linear system is singular !' ) + endif + + ! If the pivot is in a row that is different than row i, swap those two rows, noting that both + ! rows start with i-1 zero values. + if ( k /= i ) then + do j=i,N ; swap = A(j,i) ; A(j,i) = A(j,k) ; A(j,k) = swap ; enddo + swap = R(i) ; R(i) = R(k) ; R(k) = swap + endif + + ! Transform the pivot to 1 by dividing the entire row (right-hand side included) by the pivot + I_pivot = 1.0 / A(i,i) + A(i,i) = 1.0 + do j=i+1,N ; A(j,i) = A(j,i) * I_pivot ; enddo + R(i) = R(i) * I_pivot + + ! Put zeros in column for all rows below that contain the pivot (which is row i) + do k=i+1,N ! k is the row index + factor = A(i,k) + ! A(i,k) = 0.0 ! These elements are not used again, so this line can be skipped for speed. + do j=i+1,N ; A(j,k) = A(j,k) - factor * A(j,i) ; enddo + R(k) = R(k) - factor * R(i) + enddo + + enddo ! end loop on i + + if (A(N,N) == 0.0) then + ! no pivot could be found, and the sytem is singular + call MOM_error(FATAL, 'The final pivot in linear_solver is zero.') + end if + + ! Solve the system by back substituting into what is now an upper-right matrix. + X(N) = R(N) / A(N,N) ! The last row is now trivially solved. + do i=N-1,1,-1 ! loop on rows, starting from second to last row + X(i) = R(i) + do j=i+1,N ; X(i) = X(i) - A(j,i) * X(j) ; enddo + enddo + +end subroutine linear_solver + + +!> Solve the tridiagonal system AX = R +!! +!! This routine uses Thomas's algorithm to solve the tridiagonal system AX = R. +!! (A is made up of lower, middle and upper diagonals) +subroutine solve_tridiagonal_system( Al, Ad, Au, R, X, N, answer_date ) + integer, intent(in) :: N !< The size of the system + real, dimension(N), intent(in) :: Ad !< Matrix center diagonal in arbitrary units [A] + real, dimension(N), intent(in) :: Al !< Matrix lower diagonal [A] + real, dimension(N), intent(in) :: Au !< Matrix upper diagonal [A] + real, dimension(N), intent(in) :: R !< system right-hand side in arbitrary units [A B] + real, dimension(N), intent(out) :: X !< solution vector in arbitrary units [B] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + ! Local variables + real, dimension(N) :: pivot ! The pivot value [A] + real, dimension(N) :: Al_piv ! The lower diagonal divided by the pivot value [nondim] + real, dimension(N) :: c1 ! Au / pivot for the backward sweep [nondim] + real :: I_pivot ! The inverse of the most recent pivot [A-1] + integer :: k ! Loop index + logical :: old_answers ! If true, use expressions that give the original (2008 through 2018) MOM6 answers + + old_answers = .true. ; if (present(answer_date)) old_answers = (answer_date < 20190101) + + if (old_answers) then + ! This version gives the same answers as the original (2008 through 2018) MOM6 code + ! Factorization and forward sweep + pivot(1) = Ad(1) + X(1) = R(1) + do k = 2,N + Al_piv(k) = Al(k) / pivot(k-1) + pivot(k) = Ad(k) - Al_piv(k) * Au(k-1) + X(k) = R(k) - Al_piv(k) * X(k-1) + enddo + + ! Backward sweep + X(N) = R(N) / pivot(N) ! This should be X(N) / pivot(N), but is OK if Al(N) = 0. + do k = N-1,1,-1 + X(k) = ( X(k) - Au(k)*X(k+1) ) / pivot(k) + enddo + else + ! This is a more typical implementation of a tridiagonal solver than the one above. + ! It is mathematically equivalent but differs at roundoff, which can cascade up to larger values. + + ! Factorization and forward sweep + I_pivot = 1.0 / Ad(1) + X(1) = R(1) * I_pivot + do k = 2,N + c1(K-1) = Au(k-1) * I_pivot + I_pivot = 1.0 / (Ad(k) - Al(k) * c1(K-1)) + X(k) = (R(k) - Al(k) * X(k-1)) * I_pivot + enddo + ! Backward sweep + do k = N-1,1,-1 + X(k) = X(k) - c1(K) * X(k+1) + enddo + + endif + +end subroutine solve_tridiagonal_system + + +!> Solve the tridiagonal system AX = R +!! +!! This routine uses a variant of Thomas's algorithm to solve the tridiagonal system AX = R, in +!! a form that is guaranteed to avoid dividing by a zero pivot. The matrix A is made up of +!! lower (Al) and upper diagonals (Au) and a central diagonal Ad = Ac+Al+Au, where +!! Al, Au, and Ac are all positive (or negative) definite. However when Ac is smaller than +!! roundoff compared with (Al+Au), the answers are prone to inaccuracy. +subroutine solve_diag_dominant_tridiag( Al, Ac, Au, R, X, N ) + integer, intent(in) :: N !< The size of the system + real, dimension(N), intent(in) :: Ac !< Matrix center diagonal offset from Al + Au in arbitrary units [A] + real, dimension(N), intent(in) :: Al !< Matrix lower diagonal [A] + real, dimension(N), intent(in) :: Au !< Matrix upper diagonal [A] + real, dimension(N), intent(in) :: R !< system right-hand side in arbitrary units [A B] + real, dimension(N), intent(out) :: X !< solution vector in arbitrary units [B] + ! Local variables + real, dimension(N) :: c1 ! Au / pivot for the backward sweep [nondim] + real :: d1 ! The next value of 1.0 - c1 [nondim] + real :: I_pivot ! The inverse of the most recent pivot [A-1] + real :: denom_t1 ! The first term in the denominator of the inverse of the pivot [A] + integer :: k ! Loop index + + ! Factorization and forward sweep, in a form that will never give a division by a + ! zero pivot for positive definite Ac, Al, and Au. + I_pivot = 1.0 / (Ac(1) + Au(1)) + d1 = Ac(1) * I_pivot + c1(1) = Au(1) * I_pivot + X(1) = R(1) * I_pivot + do k=2,N-1 + denom_t1 = Ac(k) + d1 * Al(k) + I_pivot = 1.0 / (denom_t1 + Au(k)) + d1 = denom_t1 * I_pivot + c1(k) = Au(k) * I_pivot + X(k) = (R(k) - Al(k) * X(k-1)) * I_pivot + enddo + I_pivot = 1.0 / (Ac(N) + d1 * Al(N)) + X(N) = (R(N) - Al(N) * X(N-1)) * I_pivot + ! Backward sweep + do k=N-1,1,-1 + X(k) = X(k) - c1(k) * X(k+1) + enddo + +end subroutine solve_diag_dominant_tridiag + + +!> \namespace regrid_solvers +!! +!! Date of creation: 2008.06.12 +!! L. White +!! +!! This module contains solvers of linear systems. +!! These routines have now been updated for greater efficiency, especially in special cases. + +end module regrid_solvers diff --git a/ALE/remapping_attic.F90 b/ALE/remapping_attic.F90 new file mode 100644 index 0000000000..be20a27466 --- /dev/null +++ b/ALE/remapping_attic.F90 @@ -0,0 +1,661 @@ +!> Retains older versions of column-wise vertical remapping functions that are +!! no longer used in MOM6, but may be useful later for documenting the development +!! of the schemes that are used in MOM6. +module remapping_attic + +! This file is part of MOM6. See LICENSE.md for the license. +! Original module written by Laurent White, 2008.06.09 + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_io, only : stdout +use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use regrid_edge_values, only : edge_values_explicit_h4 + +implicit none ; private + +! The following routines are visible to the outside world +public remapping_attic_unit_tests, remapByProjection, remapByDeltaZ +public isPosSumErrSignificant + +! The following are private parameter constants +integer, parameter :: INTEGRATION_PCM = 0 !< Piecewise Constant Method +integer, parameter :: INTEGRATION_PLM = 1 !< Piecewise Linear Method +integer, parameter :: INTEGRATION_PPM = 3 !< Piecewise Parabolic Method +integer, parameter :: INTEGRATION_PQM = 5 !< Piecewise Quartic Method + +! This CPP macro turns on/off bounding of integrations limits so that they are +! always within the cell. Roundoff can lead to the non-dimensional bounds being +! outside of the range 0 to 1. +#define __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ + +real, parameter :: hNeglect_dflt = 1.E-30 !< A thickness [H ~> m or kg m-2] that can be + !! added to thicknesses in a denominator without + !! changing the numerical result, except where + !! a division by zero would otherwise occur. + +contains + +!> Compare two summation estimates of positive data and judge if due to more +!! than round-off. +!! When two sums are calculated from different vectors that should add up to +!! the same value, the results can differ by round off. The round off error +!! can be bounded to be proportional to the number of operations. +!! This function returns true if the difference between sum1 and sum2 is +!! larger than than the estimated round off bound. +!! \note This estimate/function is only valid for summation of positive data. +function isPosSumErrSignificant(n1, sum1, n2, sum2) + integer, intent(in) :: n1 !< Number of values in sum1 + integer, intent(in) :: n2 !< Number of values in sum2 + real, intent(in) :: sum1 !< Sum of n1 values in arbitrary units [A] + real, intent(in) :: sum2 !< Sum of n2 values [A] + logical :: isPosSumErrSignificant !< True if difference in sums is large + ! Local variables + real :: sumErr ! The absolutde difference in the sums [A] + real :: allowedErr ! The tolerance for the integrated reconstruction [A] + real :: eps ! A tiny fractional error [nondim] + + if (sum1<0.) call MOM_error(FATAL,'isPosSumErrSignificant: sum1<0 is not allowed!') + if (sum2<0.) call MOM_error(FATAL,'isPosSumErrSignificant: sum2<0 is not allowed!') + sumErr = abs(sum1-sum2) + eps = epsilon(sum1) + allowedErr = eps*0.5*(real(n1-1)*sum1+real(n2-1)*sum2) + if (sumErr>allowedErr) then + write(0,*) 'isPosSumErrSignificant: sum1,sum2=',sum1,sum2 + write(0,*) 'isPosSumErrSignificant: eps=',eps + write(0,*) 'isPosSumErrSignificant: err,n*eps=',sumErr,allowedErr + write(0,*) 'isPosSumErrSignificant: err/eps,n1,n2,n1+n2=',sumErr/eps,n1,n2,n1+n2 + isPosSumErrSignificant = .true. + else + isPosSumErrSignificant = .false. + endif +end function isPosSumErrSignificant + +!> Remaps column of values u0 on grid h0 to grid h1 by integrating +!! over the projection of each h1 cell onto the h0 grid. +subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h1, method, u1, h_neglect ) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(:) !< Source grid widths (size n0) in thickness units [H] + real, intent(in) :: u0(:) !< Source cell averages (size n0) in arbitrary units [A] + real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(:) !< Target grid widths (size n1) [H] + integer, intent(in) :: method !< Remapping scheme to use + real, intent(out) :: u1(:) !< Target cell averages (size n1) [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h [H]. + ! Local variables + integer :: iTarget + real :: xL, xR ! coordinates of target cell edges [H] + integer :: jStart ! Used by integrateReconOnInterval() + real :: xStart ! Used by integrateReconOnInterval() [H] + + ! Loop on cells in target grid (grid1). For each target cell, we need to find + ! in which source cells the target cell edges lie. The associated indexes are + ! noted j0 and j1. + xR = 0. ! Left boundary is at x=0 + jStart = 1 + xStart = 0. + do iTarget = 1,n1 + ! Determine the coordinates of the target cell edges + xL = xR + xR = xL + h1(iTarget) + + call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & + xL, xR, h1(iTarget), u1(iTarget), jStart, xStart, h_neglect ) + + enddo ! end iTarget loop on target grid cells + +end subroutine remapByProjection + +!> Remaps column of values u0 on grid h0 to implied grid h1 +!! where the interfaces of h1 differ from those of h0 by dx. +!! The new grid is defined relative to the original grid by change +!! dx1(:) = xNew(:) - xOld(:) +!! and the remapping calculated so that +!! hNew(k) qNew(k) = hOld(k) qOld(k) + F(k+1) - F(k) +!! where +!! F(k) = dx1(k) qAverage +!! and where qAverage is the average qOld in the region zOld(k) to zNew(k). +subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & + method, u1, h1, h_neglect ) + integer, intent(in) :: n0 !< Number of cells in source grid + real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) in thickness units [H] + real, dimension(:), intent(in) :: u0 !< Source cell averages (size n0) in arbitrary units [A] + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial [A] + integer, intent(in) :: n1 !< Number of cells in target grid + real, dimension(:), intent(in) :: dx1 !< Target grid edge positions (size n1+1) [H] + integer, intent(in) :: method !< Remapping scheme to use + real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) [A] + real, dimension(:), & + optional, intent(out) :: h1 !< Target grid widths (size n1) [H] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h [H]. + ! Local variables + integer :: iTarget + real :: xL, xR ! Coordinates of target cell edges [H] + real :: xOld, xNew ! Edge positions on the old and new grids [H] + real :: hOld, hNew ! Cell thicknesses on the old and new grids [H] + real :: uOld ! A source cell average of u [A] + real :: h_err ! An estimate of the error in the reconstructed thicknesses [H] + real :: uhNew ! Cell integrated u on the new grid [A H] + real :: hFlux ! Width of the remapped volume [H] + real :: uAve ! Target cell average of u [A] + real :: fluxL, fluxR ! Fluxes of u through the two cell faces [A H] + integer :: jStart ! Used by integrateReconOnInterval() + real :: xStart ! Used by integrateReconOnInterval() [H] + + ! Loop on cells in target grid. For each cell, iTarget, the left flux is + ! the right flux of the cell to the left, iTarget-1. + ! The left flux is initialized by started at iTarget=0 to calculate the + ! right flux which can take into account the target left boundary being + ! in the interior of the source domain. + fluxR = 0. + h_err = 0. ! For measuring round-off error + jStart = 1 + xStart = 0. + do iTarget = 0,n1 + fluxL = fluxR ! This does nothing for iTarget=0 + + if (iTarget == 0) then + xOld = 0. ! Left boundary is at x=0 + hOld = -1.E30 ! Should not be used for iTarget = 0 + uOld = -1.E30 ! Should not be used for iTarget = 0 + elseif (iTarget <= n0) then + xOld = xOld + h0(iTarget) ! Position of right edge of cell + hOld = h0(iTarget) + uOld = u0(iTarget) + h_err = h_err + epsilon(hOld) * max(hOld, xOld) + else + hOld = 0. ! as if for layers>n0, they were vanished + uOld = 1.E30 ! and the initial value should not matter + endif + xNew = xOld + dx1(iTarget+1) + xL = min( xOld, xNew ) + xR = max( xOld, xNew ) + + ! hFlux is the positive width of the remapped volume + hFlux = abs(dx1(iTarget+1)) + call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & + xL, xR, hFlux, uAve, jStart, xStart ) + ! uAve is the average value of u, independent of sign of dx1 + fluxR = dx1(iTarget+1)*uAve ! Includes sign of dx1 + + if (iTarget>0) then + hNew = hOld + ( dx1(iTarget+1) - dx1(iTarget) ) + hNew = max( 0., hNew ) + uhNew = ( uOld * hOld ) + ( fluxR - fluxL ) + if (hNew>0.) then + u1(iTarget) = uhNew / hNew + else + u1(iTarget) = uAve + endif + if (present(h1)) h1(iTarget) = hNew + endif + + enddo ! end iTarget loop on target grid cells + +end subroutine remapByDeltaZ + +!> Integrate the reconstructed column profile over a single cell +subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & + xL, xR, hC, uAve, jStart, xStart, h_neglect ) + integer, intent(in) :: n0 !< Number of cells in source grid + real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) in thickness units [H] + real, dimension(:), intent(in) :: u0 !< Source cell averages in arbitrary units [A] + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial [A] + integer, intent(in) :: method !< Remapping scheme to use + real, intent(in) :: xL !< Left edges of target cell [H] + real, intent(in) :: xR !< Right edges of target cell [H] + real, intent(in) :: hC !< Cell width hC = xR - xL [H] + real, intent(out) :: uAve !< Average value on target cell [A] + integer, intent(inout) :: jStart !< The index of the cell to start searching from + !< On exit, contains index of last cell used + real, intent(inout) :: xStart !< The left edge position of cell jStart [H] + !< On first entry should be 0. + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h [H] + ! Local variables + integer :: j, k + integer :: jL, jR ! indexes of source cells containing target cell edges + real :: q ! complete integration [A H] + real :: xi0, xi1 ! interval of integration (local -- normalized -- coordinates) [nondim] + real :: x0jLl, x0jLr ! Left/right position of cell jL [H] + real :: x0jRl, x0jRr ! Left/right position of cell jR [H] + real :: hAct ! The distance actually used in the integration + ! (notionally xR - xL) which differs due to roundoff [H]. + real :: x0_2, x1_2 ! Squares of normalized positions used to evaluate polynomials [nondim] + real :: x0px1, x02px12 ! Sums of normalized positions and their squares [nondim] + real :: hNeglect ! A negligible thickness in the same units as h [H] + real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials [nondim] + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + q = -1.E30 + x0jLl = -1.E30 + x0jRl = -1.E30 + + ! Find the left most cell in source grid spanned by the target cell + jL = -1 + x0jLr = xStart + do j = jStart, n0 + x0jLl = x0jLr + x0jLr = x0jLl + h0(j) + ! Left edge is found in cell j + if ( ( xL >= x0jLl ) .AND. ( xL <= x0jLr ) ) then + jL = j + exit ! once target grid cell is found, exit loop + endif + enddo + jStart = jL + xStart = x0jLl + +! ! HACK to handle round-off problems. Need only at j=n0. +! ! This moves the effective cell boundary outwards a smidgen. +! if (xL>x0jLr) x0jLr = xL + + ! If, at this point, jL is equal to -1, it means the vanished + ! cell lies outside the source grid. In other words, it means that + ! the source and target grids do not cover the same physical domain + ! and there is something very wrong ! + if ( jL == -1 ) call MOM_error(FATAL, & + 'MOM_remapping, integrateReconOnInterval: '//& + 'The location of the left-most cell could not be found') + + + ! ============================================================ + ! Check whether target cell is vanished. If it is, the cell + ! average is simply the interpolated value at the location + ! of the vanished cell. If it isn't, we need to integrate the + ! quantity within the cell and divide by the cell width to + ! determine the cell average. + ! ============================================================ + ! 1. Cell is vanished + !if ( abs(xR - xL) <= epsilon(xR)*max(abs(xR),abs(xL)) ) then + if ( abs(xR - xL) == 0.0 ) then + + ! We check whether the source cell (i.e. the cell in which the + ! vanished target cell lies) is vanished. If it is, the interpolated + ! value is set to be mean of the edge values (which should be the same). + ! If it isn't, we simply interpolate. + if ( h0(jL) == 0.0 ) then + uAve = 0.5 * ( ppoly0_E(jL,1) + ppoly0_E(jL,2) ) + else + ! WHY IS THIS NOT WRITTEN AS xi0 = ( xL - x0jLl ) / h0(jL) ---AJA + xi0 = xL / ( h0(jL) + hNeglect ) - x0jLl / ( h0(jL) + hNeglect ) + + select case ( method ) + case ( INTEGRATION_PCM ) + uAve = ppoly0_coefs(jL,1) + case ( INTEGRATION_PLM ) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ppoly0_coefs(jL,2) + case ( INTEGRATION_PPM ) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ( ppoly0_coefs(jL,2) & + + xi0 * ppoly0_coefs(jL,3) ) + case ( INTEGRATION_PQM ) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ( ppoly0_coefs(jL,2) & + + xi0 * ( ppoly0_coefs(jL,3) & + + xi0 * ( ppoly0_coefs(jL,4) & + + xi0 * ppoly0_coefs(jL,5) ) ) ) + case default + call MOM_error( FATAL,'The selected integration method is invalid' ) + end select + + endif ! end checking whether source cell is vanished + + ! 2. Cell is not vanished + else + + ! Find the right most cell in source grid spanned by the target cell + jR = -1 + x0jRr = xStart + do j = jStart,n0 + x0jRl = x0jRr + x0jRr = x0jRl + h0(j) + ! Right edge is found in cell j + if ( ( xR >= x0jRl ) .AND. ( xR <= x0jRr ) ) then + jR = j + exit ! once target grid cell is found, exit loop + endif + enddo ! end loop on source grid cells + + ! If xR>x0jRr then the previous loop reached j=n0 and the target + ! position, xR, was beyond the right edge of the source grid (h0). + ! This can happen due to roundoff, in which case we set jR=n0. + if (xR>x0jRr) jR = n0 + + ! To integrate, two cases must be considered: (1) the target cell is + ! entirely contained within a cell of the source grid and (2) the target + ! cell spans at least two cells of the source grid. + + if ( jL == jR ) then + ! The target cell is entirely contained within a cell of the source + ! grid. This situation is represented by the following schematic, where + ! the cell in which xL and xR are located has index jL=jR : + ! + ! ----|-----o--------o----------|------------- + ! xL xR + ! + ! Determine normalized coordinates +#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ + xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) + xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + hNeglect ) ) ) +#else + xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) + xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) +#endif + + hAct = h0(jL) * ( xi1 - xi0 ) + + ! Depending on which polynomial is used, integrate quantity + ! between xi0 and xi1. Integration is carried out in normalized + ! coordinates, hence: \int_xL^xR p(x) dx = h \int_xi0^xi1 p(xi) dxi + select case ( method ) + case ( INTEGRATION_PCM ) + q = ( xR - xL ) * ppoly0_coefs(jL,1) + case ( INTEGRATION_PLM ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) + case ( INTEGRATION_PPM ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + case ( INTEGRATION_PQM ) + x0_2 = xi0*xi0 + x1_2 = xi1*xi1 + x02px12 = x0_2 + x1_2 + x0px1 = xi1 + xi0 + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + case default + call MOM_error( FATAL,'The selected integration method is invalid' ) + end select + + else + ! The target cell spans at least two cells of the source grid. + ! This situation is represented by the following schematic, where + ! the cells in which xL and xR are located have indexes jL and jR, + ! respectively : + ! + ! ----|-----o---|--- ... --|---o----------|------------- + ! xL xR + ! + ! We first integrate from xL up to the right boundary of cell jL, then + ! add the integrated amounts of cells located between jL and jR and then + ! integrate from the left boundary of cell jR up to xR + + q = 0.0 + + ! Integrate from xL up to right boundary of cell jL +#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ + xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) +#else + xi0 = (xL - x0jLl) / ( h0(jL) + hNeglect ) +#endif + xi1 = 1.0 + + hAct = h0(jL) * ( xi1 - xi0 ) + + select case ( method ) + case ( INTEGRATION_PCM ) + q = q + ( x0jLr - xL ) * ppoly0_coefs(jL,1) + case ( INTEGRATION_PLM ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) + case ( INTEGRATION_PPM ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + case ( INTEGRATION_PQM ) + x0_2 = xi0*xi0 + x1_2 = xi1*xi1 + x02px12 = x0_2 + x1_2 + x0px1 = xi1 + xi0 + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + case default + call MOM_error( FATAL, 'The selected integration method is invalid' ) + end select + + ! Integrate contents within cells strictly comprised between jL and jR + if ( jR > (jL+1) ) then + do k = jL+1,jR-1 + q = q + h0(k) * u0(k) + hAct = hAct + h0(k) + enddo + endif + + ! Integrate from left boundary of cell jR up to xR + xi0 = 0.0 +#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ + xi1 = max( 0., min( 1., ( xR - x0jRl ) / ( h0(jR) + hNeglect ) ) ) +#else + xi1 = (xR - x0jRl) / ( h0(jR) + hNeglect ) +#endif + + hAct = hAct + h0(jR) * ( xi1 - xi0 ) + + select case ( method ) + case ( INTEGRATION_PCM ) + q = q + ( xR - x0jRl ) * ppoly0_coefs(jR,1) + case ( INTEGRATION_PLM ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) ) + case ( INTEGRATION_PPM ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jR,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + case ( INTEGRATION_PQM ) + x0_2 = xi0*xi0 + x1_2 = xi1*xi1 + x02px12 = x0_2 + x1_2 + x0px1 = xi1 + xi0 + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jR,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jR,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jR,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + case default + call MOM_error( FATAL,'The selected integration method is invalid' ) + end select + + endif ! end integration for non-vanished cells + + ! The cell average is the integrated value divided by the cell width +#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ +if (hAct==0.) then + uAve = ppoly0_coefs(jL,1) +else + uAve = q / hAct +endif +#else + uAve = q / hC +#endif + + endif ! endif clause to check if cell is vanished + +end subroutine integrateReconOnInterval + +!> Calculates the change in interface positions based on h1 and h2 +subroutine dzFromH1H2( n1, h1, n2, h2, dx ) + integer, intent(in) :: n1 !< Number of cells on source grid + real, dimension(:), intent(in) :: h1 !< Cell widths of source grid (size n1) [H] + integer, intent(in) :: n2 !< Number of cells on target grid + real, dimension(:), intent(in) :: h2 !< Cell widths of target grid (size n2) [H] + real, dimension(:), intent(out) :: dx !< Change in interface position (size n2+1) [H] + ! Local variables + integer :: k + real :: x1, x2 ! Interface positions [H] + + x1 = 0. + x2 = 0. + dx(1) = 0. + do K = 1, max(n1,n2) + if (k <= n1) x1 = x1 + h1(k) ! Interface k+1, right of source cell k + if (k <= n2) then + x2 = x2 + h2(k) ! Interface k+1, right of target cell k + dx(K+1) = x2 - x1 ! Change of interface k+1, target - source + endif + enddo + +end subroutine dzFromH1H2 + +!> Calculate edge coordinate x from cell width h +subroutine buildGridFromH(nz, h, x) + integer, intent(in) :: nz !< Number of cells + real, dimension(nz), intent(in) :: h !< Cell widths [H] + real, dimension(nz+1), intent(inout) :: x !< Edge coordinates starting at x(1)=0 [H] + ! Local variables + integer :: k + + x(1) = 0.0 + do k = 1,nz + x(k+1) = x(k) + h(k) + enddo + +end subroutine buildGridFromH + +!> Runs unit tests on archaic remapping functions. +!! Should only be called from a single/root thread +!! Returns True if a test fails, otherwise False +logical function remapping_attic_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + integer, parameter :: n0 = 4, n1 = 3, n2 = 6 + real :: h0(n0), x0(n0+1) ! Test cell widths and edge coordinates [H] + real :: u0(n0) ! Test values for remapping in arbitrary units [A] + real :: h1(n1), x1(n1+1) ! Test cell widths and edge coordinates [H] + real :: u1(n1) ! Test values for remapping [A] + real :: h2(n2), x2(n2+1) ! Test cell widths and edge coordinates [H] + real :: u2(n2) ! Test values for remapping [A] + real :: hn1(n1), hn2(n2) ! Updated grid thicknesses [H] + real :: dx1(n1+1), dx2(n2+1) ! Differences in interface positions [H] + data u0 /9., 3., -3., -9./ ! Linear profile, 4 at surface to -4 at bottom + data h0 /4*0.75/ ! 4 uniform layers with total depth of 3 + data h1 /3*1./ ! 3 uniform layers with total depth of 3 + data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 + real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S ! Polynomial edge values [A] + real, allocatable, dimension(:,:) :: ppoly0_coefs ! Polynomial reconstruction coefficients [A] + integer :: answer_date ! The vintage of the expressions to test + integer :: i, degree + real :: err ! Difference between a remapped value and its expected value [A] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses used in remapping [H] + logical :: thisTest, v + + v = verbose + answer_date = 20190101 ! 20181231 + h_neglect = hNeglect_dflt + h_neglect_edge = hNeglect_dflt ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 + + write(stdout,*) '==== remapping_attic: remapping_attic_unit_tests =================' + remapping_attic_unit_tests = .false. ! Normally return false + + call buildGridFromH(n0, h0, x0) + call buildGridFromH(n1, h1, x1) + + thisTest = .false. + degree = 2 + if (verbose) write(stdout,*) 'h0 (test data)' + if (verbose) call dumpGrid(n0,h0,x0,u0) + + call dzFromH1H2( n0, h0, n1, h1, dx1 ) + + thisTest = .false. + allocate(ppoly0_E(n0,2)) + allocate(ppoly0_S(n0,2)) + allocate(ppoly0_coefs(n0,degree+1)) + + ppoly0_E(:,:) = 0.0 + ppoly0_S(:,:) = 0.0 + ppoly0_coefs(:,:) = 0.0 + + call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10, answer_date=answer_date ) + call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=answer_date ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + u1(:) = 0. + call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h1, INTEGRATION_PPM, u1, h_neglect ) + do i=1,n1 + err = u1(i)-8.*(0.5*real(1+n1)-real(i)) + if (abs(err)>2.*epsilon(err)) thisTest = .true. + enddo + if (thisTest) write(stdout,*) 'remapping_attic_unit_tests: Failed remapByProjection()' + remapping_attic_unit_tests = remapping_attic_unit_tests .or. thisTest + + thisTest = .false. + u1(:) = 0. + call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, x1-x0(1:n1+1), & + INTEGRATION_PPM, u1, hn1, h_neglect ) + if (verbose) write(stdout,*) 'h1 (by delta)' + if (verbose) call dumpGrid(n1,h1,x1,u1) + hn1 = hn1-h1 + do i=1,n1 + err = u1(i)-8.*(0.5*real(1+n1)-real(i)) + if (abs(err)>2.*epsilon(err)) thisTest = .true. + enddo + if (thisTest) write(stdout,*) 'remapping_attic_unit_tests: Failed remapByDeltaZ() 1' + remapping_attic_unit_tests = remapping_attic_unit_tests .or. thisTest + + thisTest = .false. + call buildGridFromH(n2, h2, x2) + dx2(1:n0+1) = x2(1:n0+1) - x0 + dx2(n0+2:n2+1) = x2(n0+2:n2+1) - x0(n0+1) + call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n2, dx2, & + INTEGRATION_PPM, u2, hn2, h_neglect ) + if (verbose) write(stdout,*) 'h2' + if (verbose) call dumpGrid(n2,h2,x2,u2) + if (verbose) write(stdout,*) 'hn2' + if (verbose) call dumpGrid(n2,hn2,x2,u2) + + do i=1,n2 + err = u2(i)-8./2.*(0.5*real(1+n2)-real(i)) + if (abs(err)>2.*epsilon(err)) thisTest = .true. + enddo + if (thisTest) write(stdout,*) 'remapping_attic_unit_tests: Failed remapByDeltaZ() 2' + remapping_attic_unit_tests = remapping_attic_unit_tests .or. thisTest + + if (.not. remapping_attic_unit_tests) write(stdout,*) 'Pass' + +end function remapping_attic_unit_tests + +!> Convenience function for printing grid to screen +subroutine dumpGrid(n,h,x,u) + integer, intent(in) :: n !< Number of cells + real, dimension(:), intent(in) :: h !< Cell thickness [H] + real, dimension(:), intent(in) :: x !< Interface delta [H] + real, dimension(:), intent(in) :: u !< Cell average values [A] + integer :: i + write(stdout,'("i=",20i10)') (i,i=1,n+1) + write(stdout,'("x=",20es10.2)') (x(i),i=1,n+1) + write(stdout,'("i=",5x,20i10)') (i,i=1,n) + write(stdout,'("h=",5x,20es10.2)') (h(i),i=1,n) + write(stdout,'("u=",5x,20es10.2)') (u(i),i=1,n) +end subroutine dumpGrid + +end module remapping_attic diff --git a/core/MOM.F90 b/core/MOM.F90 new file mode 100644 index 0000000000..2b452d71da --- /dev/null +++ b/core/MOM.F90 @@ -0,0 +1,4650 @@ +!> The central module of the MOM6 ocean model +module MOM + +! This file is part of MOM6. See LICENSE.md for the license. + +! Infrastructure modules +use MOM_array_transform, only : rotate_array, rotate_vector +use MOM_debugging, only : MOM_debugging_init, hchksum, uvchksum +use MOM_debugging, only : check_redundant +use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum +use MOM_checksum_packages, only : MOM_accel_chksum, MOM_surface_chksum +use MOM_coms, only : num_PEs +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : diag_mediator_init, enable_averaging, enable_averages +use MOM_diag_mediator, only : diag_mediator_infrastructure_init +use MOM_diag_mediator, only : diag_set_state_ptrs, diag_update_remap_grids +use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr +use MOM_diag_mediator, only : register_diag_field, register_cell_measure +use MOM_diag_mediator, only : set_axes_info, diag_ctrl, diag_masks_set +use MOM_diag_mediator, only : set_masks_for_axes +use MOM_diag_mediator, only : diag_grid_storage, diag_grid_storage_init +use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids +use MOM_diag_mediator, only : diag_copy_storage_to_diag, diag_copy_diag_to_storage +use MOM_domains, only : MOM_domains_init +use MOM_domains, only : sum_across_PEs, pass_var, pass_vector +use MOM_domains, only : clone_MOM_domain, deallocate_MOM_domain +use MOM_domains, only : To_North, To_East, To_South, To_West +use MOM_domains, only : To_All, Omit_corners, CGRID_NE, SCALAR_PAIR +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : start_group_pass, complete_group_pass, Omit_Corners +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : read_param, get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing, mech_forcing, find_ustar +use MOM_forcing_type, only : MOM_forcing_chksum, MOM_mech_forcing_chksum +use MOM_get_input, only : Get_MOM_Input, directories +use MOM_io, only : MOM_io_init, vardesc, var_desc +use MOM_io, only : slasher, file_exists, MOM_read_data +use MOM_obsolete_params, only : find_obsolete_params +use MOM_restart, only : register_restart_field, register_restart_pair, save_restart +use MOM_restart, only : query_initialized, set_initialized, restart_registry_lock +use MOM_restart, only : restart_init, is_new_run, determine_is_new_run, MOM_restart_CS +use MOM_spatial_means, only : global_mass_integral +use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, operator(+) +use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) +use MOM_time_manager, only : operator(>=), operator(==), increment_date +use MOM_unit_tests, only : unit_tests + +! MOM core modules +use MOM_ALE, only : ALE_init, ALE_end, ALE_regrid, ALE_CS, adjustGridForIntegrity +use MOM_ALE, only : ALE_getCoordinate, ALE_getCoordinateUnits, ALE_writeCoordinateFile +use MOM_ALE, only : ALE_updateVerticalGridType, ALE_remap_init_conds, pre_ALE_adjustments +use MOM_ALE, only : ALE_remap_tracers, ALE_remap_velocities +use MOM_ALE, only : ALE_remap_set_h_vel, ALE_remap_set_h_vel_via_dz +use MOM_ALE, only : ALE_update_regrid_weights, pre_ALE_diagnostics, ALE_register_diags +use MOM_ALE_sponge, only : rotate_ALE_sponge, update_ALE_sponge_field +use MOM_barotropic, only : Barotropic_CS +use MOM_boundary_update, only : call_OBC_register, OBC_register_end, update_OBC_CS +use MOM_check_scaling, only : check_MOM6_scaling_factors +use MOM_coord_initialization, only : MOM_initialize_coord, write_vertgrid_file +use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS, extract_diabatic_member +use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end +use MOM_diabatic_driver, only : register_diabatic_restarts +use MOM_stochastics, only : stochastics_init, update_stochastics, stochastic_CS +use MOM_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init +use MOM_diagnostics, only : register_transport_diags, post_transport_diagnostics +use MOM_diagnostics, only : register_surface_diags, write_static_fields +use MOM_diagnostics, only : post_surface_dyn_diags, post_surface_thermo_diags +use MOM_diagnostics, only : diagnostics_CS, surface_diag_IDs, transport_diag_IDs +use MOM_diagnostics, only : MOM_diagnostics_end +use MOM_dynamics_unsplit, only : step_MOM_dyn_unsplit, register_restarts_dyn_unsplit +use MOM_dynamics_unsplit, only : initialize_dyn_unsplit, end_dyn_unsplit +use MOM_dynamics_unsplit, only : MOM_dyn_unsplit_CS +use MOM_dynamics_split_RK2, only : step_MOM_dyn_split_RK2, register_restarts_dyn_split_RK2 +use MOM_dynamics_split_RK2, only : initialize_dyn_split_RK2, end_dyn_split_RK2 +use MOM_dynamics_split_RK2, only : MOM_dyn_split_RK2_CS, remap_dyn_split_rk2_aux_vars +use MOM_dynamics_split_RK2b, only : step_MOM_dyn_split_RK2b, register_restarts_dyn_split_RK2b +use MOM_dynamics_split_RK2b, only : initialize_dyn_split_RK2b, end_dyn_split_RK2b +use MOM_dynamics_split_RK2b, only : MOM_dyn_split_RK2b_CS, remap_dyn_split_RK2b_aux_vars +use MOM_dynamics_unsplit_RK2, only : step_MOM_dyn_unsplit_RK2, register_restarts_dyn_unsplit_RK2 +use MOM_dynamics_unsplit_RK2, only : initialize_dyn_unsplit_RK2, end_dyn_unsplit_RK2 +use MOM_dynamics_unsplit_RK2, only : MOM_dyn_unsplit_RK2_CS +use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid +use MOM_dyn_horgrid, only : rotate_dyn_horgrid +use MOM_EOS, only : EOS_init, calculate_density, calculate_TFreeze, EOS_domain +use MOM_fixed_initialization, only : MOM_initialize_fixed +use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing +use MOM_forcing_type, only : deallocate_mech_forcing, deallocate_forcing_type +use MOM_forcing_type, only : rotate_forcing, rotate_mech_forcing +use MOM_forcing_type, only : copy_common_forcing_fields, set_derived_forcing_fields +use MOM_forcing_type, only : homogenize_forcing, homogenize_mech_forcing +use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end +use MOM_grid, only : set_first_direction +use MOM_hor_index, only : hor_index_type, hor_index_init +use MOM_hor_index, only : rotate_hor_index +use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz +use MOM_interface_filter, only : interface_filter, interface_filter_init, interface_filter_end +use MOM_interface_filter, only : interface_filter_CS +use MOM_internal_tides, only : int_tide_CS +use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init, VarMix_end +use MOM_lateral_mixing_coeffs, only : calc_resoln_function, calc_depth_function, VarMix_CS +use MOM_MEKE, only : MEKE_alloc_register_restart, step_forward_MEKE +use MOM_MEKE, only : MEKE_CS, MEKE_init, MEKE_end +use MOM_MEKE_types, only : MEKE_type +use MOM_mixed_layer_restrat, only : mixedlayer_restrat, mixedlayer_restrat_init, mixedlayer_restrat_CS +use MOM_mixed_layer_restrat, only : mixedlayer_restrat_register_restarts +use MOM_obsolete_diagnostics, only : register_obsolete_diagnostics +use MOM_open_boundary, only : ocean_OBC_type, OBC_registry_type +use MOM_open_boundary, only : register_temp_salt_segments, update_segment_tracer_reservoirs +use MOM_open_boundary, only : open_boundary_register_restarts, remap_OBC_fields +use MOM_open_boundary, only : rotate_OBC_config, rotate_OBC_init +use MOM_porous_barriers, only : porous_widths_layer, porous_widths_interface, porous_barriers_init +use MOM_porous_barriers, only : porous_barrier_CS +use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_CS +use MOM_set_visc, only : set_visc_register_restarts, remap_vertvisc_aux_vars +use MOM_set_visc, only : set_visc_init, set_visc_end +use MOM_shared_initialization, only : write_ocean_geometry_file +use MOM_sponge, only : init_sponge_diags, sponge_CS +use MOM_state_initialization, only : MOM_initialize_state +use MOM_stoch_eos, only : MOM_stoch_eos_init, MOM_stoch_eos_run, MOM_stoch_eos_CS +use MOM_stoch_eos, only : stoch_EOS_register_restarts, post_stoch_EOS_diags, mom_calc_varT +use MOM_sum_output, only : write_energy, accumulate_net_input +use MOM_sum_output, only : MOM_sum_output_init, MOM_sum_output_end +use MOM_sum_output, only : sum_output_CS +use MOM_ALE_sponge, only : init_ALE_sponge_diags, ALE_sponge_CS +use MOM_thickness_diffuse, only : thickness_diffuse, thickness_diffuse_init +use MOM_thickness_diffuse, only : thickness_diffuse_end, thickness_diffuse_CS +use MOM_tracer_advect, only : advect_tracer, tracer_advect_init +use MOM_tracer_advect, only : tracer_advect_end, tracer_advect_CS +use MOM_tracer_hor_diff, only : tracer_hordiff, tracer_hor_diff_init +use MOM_tracer_hor_diff, only : tracer_hor_diff_end, tracer_hor_diff_CS +use MOM_tracer_registry, only : tracer_registry_type, register_tracer, tracer_registry_init +use MOM_tracer_registry, only : register_tracer_diagnostics, post_tracer_diagnostics_at_sync +use MOM_tracer_registry, only : post_tracer_transport_diagnostics, MOM_tracer_chksum +use MOM_tracer_registry, only : preALE_tracer_diagnostics, postALE_tracer_diagnostics +use MOM_tracer_registry, only : lock_tracer_registry, tracer_registry_end +use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_CS +use MOM_tracer_flow_control, only : tracer_flow_control_init, call_tracer_surface_state +use MOM_tracer_flow_control, only : tracer_flow_control_end, call_tracer_register_obc_segments +use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid +use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, unit_scaling_end +use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state +use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_type +use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, ocean_internal_state +use MOM_variables, only : rotate_surface_state +use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd +use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units +use MOM_wave_interface, only : wave_parameters_CS, waves_end, waves_register_restarts +use MOM_wave_interface, only : Update_Stokes_Drift + +! Database client used for machine-learning interface +use MOM_database_comms, only : dbcomms_CS_type, database_comms_init, dbclient_type + +! ODA modules +use MOM_oda_driver_mod, only : ODA_CS, oda, init_oda, oda_end +use MOM_oda_driver_mod, only : set_prior_tracer, set_analysis_time, apply_oda_tracer_increments +use MOM_oda_incupd, only : oda_incupd_CS, init_oda_incupd_diags + +! Offline modules +use MOM_offline_main, only : offline_transport_CS, offline_transport_init, update_offline_fields +use MOM_offline_main, only : insert_offline_main, extract_offline_main, post_offline_convergence_diags +use MOM_offline_main, only : register_diags_offline_transport, offline_advection_ale +use MOM_offline_main, only : offline_redistribute_residual, offline_diabatic_ale +use MOM_offline_main, only : offline_fw_fluxes_into_ocean, offline_fw_fluxes_out_ocean +use MOM_offline_main, only : offline_advection_layer, offline_transport_end +use MOM_ice_shelf, only : ice_shelf_CS, ice_shelf_query, initialize_ice_shelf +use MOM_particles_mod, only : particles, particles_init, particles_run, particles_save_restart, particles_end +use MOM_particles_mod, only : particles_to_k_space, particles_to_z_space +implicit none ; private + +#include + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> A structure with diagnostic IDs of the state variables +type MOM_diag_IDs + !>@{ 3-d state field diagnostic IDs + integer :: id_u = -1, id_v = -1, id_h = -1 + !>@} + !> 2-d state field diagnostic ID + integer :: id_ssh_inst = -1 +end type MOM_diag_IDs + +!> Control structure for the MOM module, including the variables that describe +!! the state of the ocean. +type, public :: MOM_control_struct ; private + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: & + h, & !< layer thickness [H ~> m or kg m-2] + T, & !< potential temperature [C ~> degC] + S !< salinity [S ~> ppt] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & + u, & !< zonal velocity component [L T-1 ~> m s-1] + uh, & !< uh = u * h * dy at u grid points [H L2 T-1 ~> m3 s-1 or kg s-1] + uhtr !< accumulated zonal thickness fluxes to advect tracers [H L2 ~> m3 or kg] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & + v, & !< meridional velocity [L T-1 ~> m s-1] + vh, & !< vh = v * h * dx at v grid points [H L2 T-1 ~> m3 s-1 or kg s-1] + vhtr !< accumulated meridional thickness fluxes to advect tracers [H L2 ~> m3 or kg] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: ssh_rint + !< A running time integral of the sea surface height [T Z ~> s m]. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: ave_ssh_ibc + !< time-averaged (over a forcing time step) sea surface height + !! with a correction for the inverse barometer [Z ~> m] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_av_bc + !< free surface height or column mass time averaged over the last + !! baroclinic dynamics time step [H ~> m or kg m-2] + real, dimension(:,:), pointer :: & + Hml => NULL() !< active mixed layer depth [Z ~> m] + real :: time_in_cycle !< The running time of the current time-stepping cycle + !! in calls that step the dynamics, and also the length of + !! the time integral of ssh_rint [T ~> s]. + real :: time_in_thermo_cycle !< The running time of the current time-stepping + !! cycle in calls that step the thermodynamics [T ~> s]. + + type(ocean_grid_type) :: G_in !< Input grid metric + type(ocean_grid_type), pointer :: G => NULL() !< Model grid metric + logical :: rotate_index = .false. !< True if index map is rotated + logical :: homogenize_forcings = .false. !< True if all inputs are homogenized + logical :: update_ustar = .false. !< True to update ustar from homogenized tau + + type(verticalGrid_type), pointer :: & + GV => NULL() !< structure containing vertical grid info + type(unit_scale_type), pointer :: & + US => NULL() !< structure containing various unit conversion factors + type(thermo_var_ptrs) :: tv !< structure containing pointers to available thermodynamic fields + real :: t_dyn_rel_adv !< The time of the dynamics relative to tracer advection and lateral mixing + !! [T ~> s], or equivalently the elapsed time since advectively updating the + !! tracers. t_dyn_rel_adv is invariably positive and may span multiple coupling timesteps. + integer :: n_dyn_steps_in_adv !< The number of dynamics time steps that contributed to uhtr + !! and vhtr since the last time tracer advection occured. + real :: t_dyn_rel_thermo !< The time of the dynamics relative to diabatic processes and remapping + !! [T ~> s]. t_dyn_rel_thermo can be negative or positive depending on whether + !! the diabatic processes are applied before or after the dynamics and may span + !! multiple coupling timesteps. + real :: t_dyn_rel_diag !< The time of the diagnostics relative to diabatic processes and remapping + !! [T ~> s]. t_dyn_rel_diag is always positive, since the diagnostics must lag. + logical :: preadv_h_stored = .false. !< If true, the thicknesses from before the advective cycle + !! have been stored for use in diagnostics. + + type(diag_ctrl) :: diag !< structure to regulate diagnostic output timing + type(vertvisc_type) :: visc !< structure containing vertical viscosities, + !! bottom drag viscosities, and related fields + type(MEKE_type) :: MEKE !< Fields related to the Mesoscale Eddy Kinetic Energy + logical :: adiabatic !< If true, there are no diapycnal mass fluxes, and no calls + !! to routines to calculate or apply diapycnal fluxes. + logical :: diabatic_first !< If true, apply diabatic and thermodynamic processes before time + !! stepping the dynamics. + logical :: use_ALE_algorithm !< If true, use the ALE algorithm rather than layered + !! isopycnal/stacked shallow water mode. This logical is set by calling the + !! function useRegridding() from the MOM_regridding module. + logical :: remap_aux_vars !< If true, apply ALE remapping to all of the auxiliary 3-D + !! variables that are needed to reproduce across restarts, + !! similarly to what is done with the primary state variables. + logical :: remap_uv_using_old_alg !< If true, use the old "remapping via a delta z" method for + !! velocities. If false, remap between two grids described by thicknesses. + + type(MOM_stoch_eos_CS) :: stoch_eos_CS !< structure containing random pattern for stoch EOS + logical :: alternate_first_direction !< If true, alternate whether the x- or y-direction + !! updates occur first in directionally split parts of the calculation. + real :: first_dir_restart = -1.0 !< A real copy of G%first_direction for use in restart files [nondim] + logical :: offline_tracer_mode = .false. + !< If true, step_offline() is called instead of step_MOM(). + !! This is intended for running MOM6 in offline tracer mode + logical :: MEKE_in_dynamics !< If .true. (default), MEKE is called in the dynamics routine otherwise + !! it is called during the tracer dynamics + + type(time_type), pointer :: Time !< pointer to the ocean clock + real :: dt !< (baroclinic) dynamics time step [T ~> s] + real :: dt_therm !< thermodynamics time step [T ~> s] + logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time + !! steps can span multiple coupled time steps. + integer :: nstep_tot = 0 !< The total number of dynamic timesteps taken + !! so far in this run segment + logical :: count_calls = .false. !< If true, count the calls to step_MOM, rather than the + !! number of dynamics steps in nstep_tot + logical :: debug !< If true, write verbose checksums for debugging purposes. + integer :: ntrunc !< number u,v truncations since last call to write_energy + + integer :: cont_stencil !< The stencil for thickness from the continuity solver. + ! These elements are used to control the dynamics updates. + logical :: do_dynamics !< If false, does not call step_MOM_dyn_*. This is an + !! undocumented run-time flag that is fragile. + logical :: split !< If true, use the split time stepping scheme. + logical :: use_alt_split !< If true, use a version of the split explicit time stepping + !! scheme that exchanges velocities with step_MOM that have the + !! average barotropic phase over a baroclinic timestep rather + !! than the instantaneous barotropic phase. + logical :: use_RK2 !< If true, use RK2 instead of RK3 in unsplit mode + !! (i.e., no split between barotropic and baroclinic). + logical :: interface_filter !< If true, apply an interface height filter immediately + !! after any calls to thickness_diffuse. + logical :: thickness_diffuse !< If true, diffuse interface height w/ a diffusivity KHTH. + logical :: thickness_diffuse_first !< If true, diffuse thickness before dynamics. + logical :: mixedlayer_restrat !< If true, use submesoscale mixed layer restratifying scheme. + logical :: useMEKE !< If true, call the MEKE parameterization. + logical :: use_stochastic_EOS !< If true, use the stochastic EOS parameterizations. + logical :: useWaves !< If true, update Stokes drift + logical :: use_diabatic_time_bug !< If true, uses the wrong calendar time for diabatic processes, + !! as was done in MOM6 versions prior to February 2018. + real :: dtbt_reset_period !< The time interval between dynamic recalculation of the + !! barotropic time step [T ~> s]. If this is negative dtbt is never + !! calculated, and if it is 0, dtbt is calculated every step. + type(time_type) :: dtbt_reset_interval !< A time_time representation of dtbt_reset_period. + type(time_type) :: dtbt_reset_time !< The next time DTBT should be calculated. + real :: dt_obc_seg_period !< The time interval between OBC segment updates for OBGC + !! tracers [T ~> s], or a negative value if the segment + !! data are time-invarant, or zero to update the OBGC + !! segment data with every call to update_OBC_segment_data. + type(time_type) :: dt_obc_seg_interval !< A time_time representation of dt_obc_seg_period. + type(time_type) :: dt_obc_seg_time !< The next time OBC segment update is applied to OBGC tracers. + + real, dimension(:,:), pointer :: frac_shelf_h => NULL() !< fraction of total area occupied + !! by ice shelf [nondim] + real, dimension(:,:), pointer :: mass_shelf => NULL() !< Mass of ice shelf [R Z ~> kg m-2] + type(accel_diag_ptrs) :: ADp !< structure containing pointers to accelerations, + !! for derived diagnostics (e.g., energy budgets) + type(cont_diag_ptrs) :: CDp !< structure containing pointers to continuity equation + !! terms, for derived diagnostics (e.g., energy budgets) + real, dimension(:,:,:), pointer :: & + u_prev => NULL(), & !< previous value of u stored for diagnostics [L T-1 ~> m s-1] + v_prev => NULL() !< previous value of v stored for diagnostics [L T-1 ~> m s-1] + + logical :: interp_p_surf !< If true, linearly interpolate surface pressure + !! over the coupling time step, using specified value + !! at the end of the coupling step. False by default. + logical :: p_surf_prev_set !< If true, p_surf_prev has been properly set from + !! a previous time-step or the ocean restart file. + !! This is only valid when interp_p_surf is true. + real, dimension(:,:), pointer :: & + p_surf_prev => NULL(), & !< surface pressure [R L2 T-2 ~> Pa] at end previous call to step_MOM + p_surf_begin => NULL(), & !< surface pressure [R L2 T-2 ~> Pa] at start of step_MOM_dyn_... + p_surf_end => NULL() !< surface pressure [R L2 T-2 ~> Pa] at end of step_MOM_dyn_... + + ! Variables needed to reach between start and finish phases of initialization + logical :: write_IC !< If true, then the initial conditions will be written to file + character(len=120) :: IC_file !< A file into which the initial conditions are + !! written in a new run if SAVE_INITIAL_CONDS is true. + + logical :: calc_rho_for_sea_lev !< If true, calculate rho to convert pressure to sea level + + ! These elements are used to control the calculation and error checking of the surface state + real :: Hmix !< Diagnostic mixed layer thickness over which to + !! average surface tracer properties when a bulk + !! mixed layer is not used [H ~> m or kg m-2], or a negative value + !! if a bulk mixed layer is being used. + real :: HFrz !< If HFrz > 0, the nominal depth over which melt potential is computed + !! [H ~> m or kg m-2]. The actual depth over which melt potential is + !! computed is min(HFrz, OBLD), where OBLD is the boundary layer depth. + !! If HFrz <= 0 (default), melt potential will not be computed. + real :: Hmix_UV !< Depth scale over which to average surface flow to + !! feedback to the coupler/driver [H ~> m or kg m-2] when + !! bulk mixed layer is not used, or a negative value + !! if a bulk mixed layer is being used. + logical :: check_bad_sfc_vals !< If true, scan surface state for ridiculous values. + real :: bad_val_ssh_max !< Maximum SSH before triggering bad value message [Z ~> m] + real :: bad_val_sst_max !< Maximum SST before triggering bad value message [C ~> degC] + real :: bad_val_sst_min !< Minimum SST before triggering bad value message [C ~> degC] + real :: bad_val_sss_max !< Maximum SSS before triggering bad value message [S ~> ppt] + real :: bad_val_col_thick !< Minimum column thickness before triggering bad value message [Z ~> m] + integer :: answer_date !< The vintage of the expressions for the surface properties. Values + !! below 20190101 recover the answers from the end of 2018, while + !! higher values use more appropriate expressions that differ at + !! roundoff for non-Boussinesq cases. + logical :: use_particles !< Turns on the particles package + logical :: use_uh_particles !< particles are advected by uh/h + logical :: use_dbclient !< Turns on the database client used for ML inference/analysis + character(len=10) :: particle_type !< Particle types include: surface(default), profiling and sail drone. + + type(MOM_diag_IDs) :: IDs !< Handles used for diagnostics. + type(transport_diag_IDs) :: transport_IDs !< Handles used for transport diagnostics. + type(surface_diag_IDs) :: sfc_IDs !< Handles used for surface diagnostics. + type(diag_grid_storage) :: diag_pre_sync !< The grid (thicknesses) before remapping + type(diag_grid_storage) :: diag_pre_dyn !< The grid (thicknesses) before dynamics + + ! The remainder of this type provides pointers to child module control structures. + + type(MOM_dyn_unsplit_CS), pointer :: dyn_unsplit_CSp => NULL() + !< Pointer to the control structure used for the unsplit dynamics + type(MOM_dyn_unsplit_RK2_CS), pointer :: dyn_unsplit_RK2_CSp => NULL() + !< Pointer to the control structure used for the unsplit RK2 dynamics + type(MOM_dyn_split_RK2_CS), pointer :: dyn_split_RK2_CSp => NULL() + !< Pointer to the control structure used for the mode-split RK2 dynamics + type(MOM_dyn_split_RK2b_CS), pointer :: dyn_split_RK2b_CSp => NULL() + !< Pointer to the control structure used for an alternate version of the mode-split RK2 dynamics + type(thickness_diffuse_CS) :: thickness_diffuse_CSp + !< Pointer to the control structure used for the isopycnal height diffusive transport. + !! This is also common referred to as Gent-McWilliams diffusion + type(interface_filter_CS) :: interface_filter_CSp + !< Control structure used for the interface height smoothing operator. + type(mixedlayer_restrat_CS) :: mixedlayer_restrat_CSp + !< Pointer to the control structure used for the mixed layer restratification + type(set_visc_CS) :: set_visc_CSp + !< Pointer to the control structure used to set viscosities + type(diabatic_CS), pointer :: diabatic_CSp => NULL() + !< Pointer to the control structure for the diabatic driver + type(MEKE_CS) :: MEKE_CSp + !< Pointer to the control structure for the MEKE updates + type(VarMix_CS) :: VarMix + !< Control structure for the variable mixing module + type(tracer_registry_type), pointer :: tracer_Reg => NULL() + !< Pointer to the MOM tracer registry + type(tracer_advect_CS), pointer :: tracer_adv_CSp => NULL() + !< Pointer to the MOM tracer advection control structure + type(tracer_hor_diff_CS), pointer :: tracer_diff_CSp => NULL() + !< Pointer to the MOM along-isopycnal tracer diffusion control structure + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() + !< Pointer to the control structure that orchestrates the calling of tracer packages + ! Although update_OBC_CS is not used directly outside of initialization, other modules + ! set pointers to this type, so it should be kept for the duration of the run. + type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() + !< Pointer to the control structure for updating open boundary condition properties + type(ocean_OBC_type), pointer :: OBC => NULL() + !< Pointer to the MOM open boundary condition type + type(sponge_CS), pointer :: sponge_CSp => NULL() + !< Pointer to the layered-mode sponge control structure + type(ALE_sponge_CS), pointer :: ALE_sponge_CSp => NULL() + !< Pointer to the ALE-mode sponge control structure + type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() + !< Pointer to the oda incremental update control structure + type(int_tide_CS), pointer :: int_tide_CSp => NULL() + !< Pointer to the internal tides control structure + type(ALE_CS), pointer :: ALE_CSp => NULL() + !< Pointer to the Arbitrary Lagrangian Eulerian (ALE) vertical coordinate control structure + + ! Pointers to control structures used for diagnostics + type(sum_output_CS), pointer :: sum_output_CSp => NULL() + !< Pointer to the globally summed output control structure + type(diagnostics_CS) :: diagnostics_CSp + !< Pointer to the MOM diagnostics control structure + type(offline_transport_CS), pointer :: offline_CSp => NULL() + !< Pointer to the offline tracer transport control structure + type(porous_barrier_CS) :: por_bar_CS + !< Control structure for porous barrier + + logical :: ensemble_ocean !< if true, this run is part of a + !! larger ensemble for the purpose of data assimilation + !! or statistical analysis. + type(ODA_CS), pointer :: odaCS => NULL() !< a pointer to the control structure for handling + !! ensemble model state vectors and data assimilation + !! increments and priors + type(dbcomms_CS_type) :: dbcomms_CS !< Control structure for database client used for online ML/AI + logical :: use_porbar !< If true, use porous barrier to constrain the widths and face areas + !! at the edges of the grid cells. + type(porous_barrier_type) :: pbv !< porous barrier fractional cell metrics + type(particles), pointer :: particles => NULL() ! NULL() !< a pointer to the stochastics control structure + type(MOM_restart_CS), pointer :: restart_CS => NULL() + !< Pointer to MOM's restart control structure +end type MOM_control_struct + +public initialize_MOM, finish_MOM_initialization, MOM_end +public step_MOM, step_offline +public extract_surface_state, get_ocean_stocks +public get_MOM_state_elements, MOM_state_is_synchronized +public allocate_surface_state, deallocate_surface_state +public save_MOM_restart + +!>@{ CPU time clock IDs +integer :: id_clock_ocean +integer :: id_clock_dynamics +integer :: id_clock_thermo +integer :: id_clock_tracer +integer :: id_clock_diabatic +integer :: id_clock_adiabatic +integer :: id_clock_continuity ! also in dynamics s/r +integer :: id_clock_thick_diff +integer :: id_clock_int_filter +integer :: id_clock_BBL_visc +integer :: id_clock_ml_restrat +integer :: id_clock_diagnostics +integer :: id_clock_Z_diag +integer :: id_clock_init +integer :: id_clock_MOM_init +integer :: id_clock_pass ! also in dynamics d/r +integer :: id_clock_pass_init ! also in dynamics d/r +integer :: id_clock_ALE +integer :: id_clock_other +integer :: id_clock_offline_tracer +integer :: id_clock_unit_tests +integer :: id_clock_stoch +integer :: id_clock_varT +!>@} + +contains + +!> This subroutine orchestrates the time stepping of MOM. The adiabatic +!! dynamics are stepped by calls to one of the step_MOM_dyn_...routines. +!! The action of lateral processes on tracers occur in calls to +!! advect_tracer and tracer_hordiff. Vertical mixing and possibly remapping +!! occur inside of diabatic. +subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS, & + Waves, do_dynamics, do_thermodynamics, start_cycle, & + end_cycle, cycle_length, reset_therm) + type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces + type(forcing), target, intent(inout) :: fluxes_in !< A structure with pointers to themodynamic, + !! tracer and mass exchange forcing fields + type(surface), target, intent(inout) :: sfc_state !< surface ocean state + type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type + real, intent(in) :: time_int_in !< time interval covered by this run segment [T ~> s]. + type(MOM_control_struct), intent(inout), target :: CS !< control structure from initialize_MOM + type(Wave_parameters_CS), & + optional, pointer :: Waves !< An optional pointer to a wave property CS + logical, optional, intent(in) :: do_dynamics !< Present and false, do not do updates due + !! to the dynamics. + logical, optional, intent(in) :: do_thermodynamics !< Present and false, do not do updates due + !! to the thermodynamics or remapping. + logical, optional, intent(in) :: start_cycle !< This indicates whether this call is to be + !! treated as the first call to step_MOM in a + !! time-stepping cycle; missing is like true. + logical, optional, intent(in) :: end_cycle !< This indicates whether this call is to be + !! treated as the last call to step_MOM in a + !! time-stepping cycle; missing is like true. + real, optional, intent(in) :: cycle_length !< The amount of time in a coupled time + !! stepping cycle [T ~> s]. + logical, optional, intent(in) :: reset_therm !< This indicates whether the running sums of + !! thermodynamic quantities should be reset. + !! If missing, this is like start_cycle. + + ! local variables + type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing + ! metrics and related information + type(ocean_grid_type), pointer :: G_in => NULL() ! Input grid metric + type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the vertical grid structure + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors + integer :: ntstep ! time steps between tracer updates or diabatic forcing + integer :: n_max ! number of steps to take in this call + integer :: halo_sz, dynamics_stencil + + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + real :: time_interval ! time interval covered by this run segment [T ~> s]. + real :: dt ! baroclinic time step [T ~> s] + real :: dtdia ! time step for diabatic processes [T ~> s] + real :: dt_therm ! a limited and quantized version of CS%dt_therm [T ~> s] + real :: dt_therm_here ! a further limited value of dt_therm [T ~> s] + + real :: wt_end, wt_beg ! Fractional weights of the future pressure at the end + ! and beginning of the current time step [nondim] + real :: bbl_time_int ! The amount of time over which the calculated BBL + ! properties will apply, for use in diagnostics, or 0 + ! if it is not to be calculated anew [T ~> s]. + real :: rel_time = 0.0 ! relative time since start of this call [T ~> s]. + + logical :: do_advection ! If true, it is time to advect tracers. + logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans + ! multiple dynamic timesteps. + logical :: do_dyn ! If true, dynamics are updated with this call. + logical :: do_thermo ! If true, thermodynamics and remapping may be applied with this call. + logical :: nonblocking_p_surf_update ! A flag to indicate whether surface properties + ! can use nonblocking halo updates + logical :: cycle_start ! If true, do calculations that are only done at the start of + ! a stepping cycle (whatever that may mean). + logical :: cycle_end ! If true, do calculations and diagnostics that are only done at + ! the end of a stepping cycle (whatever that may mean). + logical :: therm_reset ! If true, reset running sums of thermodynamic quantities. + real :: cycle_time ! The length of the coupled time-stepping cycle [T ~> s]. + real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & + U_star ! The wind friction velocity, calculated using the Boussinesq reference density or + ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] + real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & + ssh ! sea surface height, which may be based on eta_av [Z ~> m] + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & + dz ! Vertical distance across layers [Z ~> m] + + real, dimension(:,:,:), pointer :: & + u => NULL(), & ! u : zonal velocity component [L T-1 ~> m s-1] + v => NULL(), & ! v : meridional velocity component [L T-1 ~> m s-1] + h => NULL() ! h : layer thickness [H ~> m or kg m-2] + real, dimension(:,:), pointer :: & + p_surf => NULL() ! A pointer to the ocean surface pressure [R L2 T-2 ~> Pa]. + real :: I_wt_ssh ! The inverse of the time weights [T-1 ~> s-1] + + type(time_type) :: Time_local, end_time_thermo + type(group_pass_type) :: pass_tau_ustar_psurf + logical :: showCallTree + + ! External forcing fields on the model index map + type(mech_forcing), pointer :: forces ! Mechanical forcing + type(forcing), pointer :: fluxes ! Boundary fluxes + type(surface), pointer :: sfc_state_diag ! Surface boundary fields + integer :: turns ! Number of quarter turns from input to model indexing + + G => CS%G ; G_in => CS%G_in ; GV => CS%GV ; US => CS%US + 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 + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + u => CS%u ; v => CS%v ; h => CS%h + + time_interval = time_int_in + do_dyn = .true. ; if (present(do_dynamics)) do_dyn = do_dynamics + do_thermo = .true. ; if (present(do_thermodynamics)) do_thermo = do_thermodynamics + if (.not.(do_dyn .or. do_thermo)) call MOM_error(FATAL,"Step_MOM: "//& + "Both do_dynamics and do_thermodynamics are false, which makes no sense.") + cycle_start = .true. ; if (present(start_cycle)) cycle_start = start_cycle + cycle_end = .true. ; if (present(end_cycle)) cycle_end = end_cycle + cycle_time = time_interval ; if (present(cycle_length)) cycle_time = cycle_length + therm_reset = cycle_start ; if (present(reset_therm)) therm_reset = reset_therm + + call cpu_clock_begin(id_clock_ocean) + call cpu_clock_begin(id_clock_other) + + if (CS%debug) then + call MOM_state_chksum("Beginning of step_MOM ", u, v, h, CS%uh, CS%vh, G, GV, US) + endif + + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("step_MOM(), MOM.F90") + + ! Rotate the forces from G_in to G + if (CS%rotate_index) then + turns = G%HI%turns + allocate(forces) + call allocate_mech_forcing(forces_in, G, forces) + call rotate_mech_forcing(forces_in, turns, forces) + + allocate(fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes) + call rotate_forcing(fluxes_in, fluxes, turns) + else + forces => forces_in + fluxes => fluxes_in + endif + + ! Homogenize the forces + if (CS%homogenize_forcings) then + ! Homogenize all forcing and fluxes fields. + call homogenize_mech_forcing(forces, G, US, GV%Rho0, CS%update_ustar) + ! Note the following computes the mean ustar as the mean of ustar rather than + ! ustar of the mean of tau. + call homogenize_forcing(fluxes, G, GV, US) + if (CS%update_ustar) then + ! These calls corrects the ustar values + call copy_common_forcing_fields(forces, fluxes, G) + call set_derived_forcing_fields(forces, fluxes, G, US, GV%Rho0) + endif + endif + + ! This will be replaced later with the pressures from forces or fluxes if they are available. + if (associated(CS%tv%p_surf)) CS%tv%p_surf(:,:) = 0.0 + + ! First determine the time step that is consistent with this call and an + ! integer fraction of time_interval. + if (do_dyn) then + n_max = 1 + if (time_interval > CS%dt) n_max = ceiling(time_interval/CS%dt - 0.001) + dt = time_interval / real(n_max) + thermo_does_span_coupling = (CS%thermo_spans_coupling .and. & + (CS%dt_therm > 1.5*cycle_time)) + if (thermo_does_span_coupling) then + ! Set dt_therm to be an integer multiple of the coupling time step. + dt_therm = cycle_time * floor(CS%dt_therm / cycle_time + 0.001) + ntstep = floor(dt_therm/dt + 0.001) + elseif (.not.do_thermo) then + dt_therm = CS%dt_therm + if (present(cycle_length)) dt_therm = min(CS%dt_therm, cycle_length) + ! ntstep is not used. + else + ntstep = MAX(1, MIN(n_max, floor(CS%dt_therm/dt + 0.001))) + dt_therm = dt*ntstep + endif + + !---------- Initiate group halo pass of the forcing fields + call cpu_clock_begin(id_clock_pass) + ! Halo updates for surface pressure need to be completed before calling calc_resoln_function + ! among other routines if the surface pressure is used in the equation of state. + nonblocking_p_surf_update = G%nonblocking_updates .and. & + .not.(associated(CS%tv%p_surf) .and. associated(forces%p_surf) .and. & + allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) + if (.not.associated(forces%taux) .or. .not.associated(forces%tauy)) & + call MOM_error(FATAL,'step_MOM:forces%taux,tauy not associated') + call create_group_pass(pass_tau_ustar_psurf, forces%taux, forces%tauy, G%Domain) + if (associated(forces%ustar)) & + call create_group_pass(pass_tau_ustar_psurf, forces%ustar, G%Domain) + if (associated(forces%tau_mag)) & + call create_group_pass(pass_tau_ustar_psurf, forces%tau_mag, G%Domain) + if (associated(forces%p_surf)) & + call create_group_pass(pass_tau_ustar_psurf, forces%p_surf, G%Domain) + if (nonblocking_p_surf_update) then + call start_group_pass(pass_tau_ustar_psurf, G%Domain) + else + call do_group_pass(pass_tau_ustar_psurf, G%Domain) + endif + call cpu_clock_end(id_clock_pass) + + if (associated(forces%p_surf)) p_surf => forces%p_surf + if (.not.associated(forces%p_surf)) CS%interp_p_surf = .false. + if (associated(CS%tv%p_surf) .and. associated(forces%p_surf)) then + do j=jsd,jed ; do i=isd,ied ; CS%tv%p_surf(i,j) = forces%p_surf(i,j) ; enddo ; enddo + + if (allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) then + ! The internal ocean state depends on the surface pressues, so update SpV_avg. + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) + endif + endif + + else + ! This step only updates the thermodynamics so setting timesteps is simpler. + n_max = 1 + if ((time_interval > CS%dt_therm) .and. (CS%dt_therm > 0.0)) & + n_max = ceiling(time_interval/CS%dt_therm - 0.001) + + dt = time_interval / real(n_max) + dt_therm = dt ; ntstep = 1 + + if (CS%UseWaves .and. associated(fluxes%ustar)) & + call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass, halo=1) + if (CS%UseWaves .and. associated(fluxes%tau_mag)) & + call pass_var(fluxes%tau_mag, G%Domain, clock=id_clock_pass, halo=1) + + if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf + if (associated(CS%tv%p_surf) .and. associated(fluxes%p_surf)) then + do j=js,je ; do i=is,ie ; CS%tv%p_surf(i,j) = fluxes%p_surf(i,j) ; enddo ; enddo + if (allocated(CS%tv%SpV_avg)) then + call pass_var(CS%tv%p_surf, G%Domain, clock=id_clock_pass) + ! The internal ocean state depends on the surface pressues, so update SpV_avg. + call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + halo_sz = max(halo_sz, 1) + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=halo_sz, debug=CS%debug) + endif + endif + endif + + if (therm_reset) then + CS%time_in_thermo_cycle = 0.0 + if (associated(CS%tv%frazil)) CS%tv%frazil(:,:) = 0.0 + if (associated(CS%tv%salt_deficit)) CS%tv%salt_deficit(:,:) = 0.0 + if (associated(CS%tv%TempxPmE)) CS%tv%TempxPmE(:,:) = 0.0 + if (associated(CS%tv%internal_heat)) CS%tv%internal_heat(:,:) = 0.0 + endif + + if (cycle_start) then + CS%time_in_cycle = 0.0 + do j=js,je ; do i=is,ie ; CS%ssh_rint(i,j) = 0.0 ; enddo ; enddo + + if (CS%VarMix%use_variable_mixing) then + call enable_averages(cycle_time, Time_start + real_to_time(US%T_to_s*cycle_time), CS%diag) + call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix) + call calc_depth_function(G, CS%VarMix) + call disable_averaging(CS%diag) + endif + endif + ! advance the random pattern if stochastic physics is active + if (CS%stoch_CS%do_sppt .OR. CS%stoch_CS%pert_epbl) call update_stochastics(CS%stoch_CS) + + if (do_dyn) then + if (nonblocking_p_surf_update) & + call complete_group_pass(pass_tau_ustar_psurf, G%Domain, clock=id_clock_pass) + + if (CS%interp_p_surf) then + if (.not.associated(CS%p_surf_end)) allocate(CS%p_surf_end(isd:ied,jsd:jed)) + if (.not.associated(CS%p_surf_begin)) allocate(CS%p_surf_begin(isd:ied,jsd:jed)) + if (.not.CS%p_surf_prev_set) then + do j=jsd,jed ; do i=isd,ied + CS%p_surf_prev(i,j) = forces%p_surf(i,j) + enddo ; enddo + CS%p_surf_prev_set = .true. + endif + else + CS%p_surf_end => forces%p_surf + endif + if (CS%UseWaves) then + ! Update wave information, which is presently kept static over each call to step_mom + call enable_averages(time_interval, Time_start + real_to_time(US%T_to_s*time_interval), CS%diag) + call find_ustar(forces, CS%tv, U_star, G, GV, US, halo=1) + call thickness_to_dz(h, CS%tv, dz, G, GV, US, halo_size=1) + call Update_Stokes_Drift(G, GV, US, Waves, dz, U_star, time_interval, do_dyn) + call disable_averaging(CS%diag) + endif + else ! not do_dyn. + if (CS%UseWaves) then ! Diagnostics are not enabled in this call. + call find_ustar(fluxes, CS%tv, U_star, G, GV, US, halo=1) + call thickness_to_dz(h, CS%tv, dz, G, GV, US, halo_size=1) + call Update_Stokes_Drift(G, GV, US, Waves, dz, U_star, time_interval, do_dyn) + endif + endif + + if (CS%debug) then + if (cycle_start) & + call MOM_state_chksum("Before steps ", u, v, h, CS%uh, CS%vh, G, GV, US) + if (cycle_start) call check_redundant("Before steps ", u, v, G, unscale=US%L_T_to_m_s) + if (do_dyn) call MOM_mech_forcing_chksum("Before steps", forces, G, US, haloshift=0) + if (do_dyn) call check_redundant("Before steps ", forces%taux, forces%tauy, G, & + unscale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + endif + call cpu_clock_end(id_clock_other) + + rel_time = 0.0 + do n=1,n_max + if (CS%use_diabatic_time_bug) then + ! This wrong form of update was used until Feb 2018, recovered with CS%use_diabatic_time_bug=T. + CS%Time = Time_start + real_to_time(US%T_to_s*int(floor(rel_time+0.5*dt+0.5))) + rel_time = rel_time + dt + else + rel_time = rel_time + dt ! The relative time at the end of the step. + ! Set the universally visible time to the middle of the time step. + CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) + endif + ! Set the local time to the end of the time step. + Time_local = Time_start + real_to_time(US%T_to_s*rel_time) + + if (showCallTree) call callTree_enter("DT cycles (step_MOM) n=",n) + + ! Update the vertically extensive diagnostic grids so that they are + ! referenced to the beginning timestep + call diag_update_remap_grids(CS%diag, update_intensive = .false., update_extensive = .true. ) + + !=========================================================================== + ! This is the first place where the diabatic processes and remapping could occur. + if (CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0) .and. do_thermo) then ! do thermodynamics. + + if (.not.do_dyn) then + dtdia = dt + elseif (thermo_does_span_coupling) then + dtdia = dt_therm + if ((fluxes%dt_buoy_accum > 0.0) .and. (dtdia > time_interval) .and. & + (abs(fluxes%dt_buoy_accum - dtdia) > 1e-6*dtdia)) then + call MOM_error(FATAL, "step_MOM: Mismatch between long thermodynamic "//& + "timestep and time over which buoyancy fluxes have been accumulated.") + endif + call MOM_error(FATAL, "MOM is not yet set up to have restarts that work "//& + "with THERMO_SPANS_COUPLING and DIABATIC_FIRST.") + else + dtdia = dt*min(ntstep,n_max-(n-1)) + endif + + end_time_thermo = Time_local + if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) then + ! If necessary, temporarily reset CS%Time to the center of the period covered + ! by the call to step_MOM_thermo, noting that they begin at the same time. + ! This step was missing prior to Feb 2018, and is skipped with CS%use_diabatic_time_bug=T. + CS%Time = CS%Time + real_to_time(0.5*US%T_to_s*(dtdia-dt)) + endif + if (dtdia > dt .or. CS%use_diabatic_time_bug) then + ! The end-time of the diagnostic interval needs to be set ahead if there + ! are multiple dynamic time steps worth of thermodynamics applied here. + ! This line was not conditional prior to Feb 2018, recovered with CS%use_diabatic_time_bug=T. + end_time_thermo = Time_local + real_to_time(US%T_to_s*(dtdia-dt)) + endif + + ! Apply diabatic forcing, do mixing, and regrid. + call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & + end_time_thermo, .true., Waves=Waves) + CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia + + ! The diabatic processes are now ahead of the dynamics by dtdia. + CS%t_dyn_rel_thermo = -dtdia + if (showCallTree) call callTree_waypoint("finished diabatic_first (step_MOM)") + + if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) & ! Reset CS%Time to its previous value. + ! This step was missing prior to Feb 2018, recovered with CS%use_diabatic_time_bug=T. + CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) + endif ! end of block "(CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0))" + + if (do_dyn) then + ! Store pre-dynamics thicknesses for proper diagnostic remapping for transports or + ! advective tendencies. If there are more than one dynamics steps per advective + ! step (i.e DT_THERM > DT), this needs to be stored at the first dynamics call. + if (.not.CS%preadv_h_stored .and. (CS%t_dyn_rel_adv == 0.)) then + call diag_copy_diag_to_storage(CS%diag_pre_dyn, h, CS%diag) + CS%preadv_h_stored = .true. + endif + + ! The pre-dynamics velocities might be stored for debugging truncations. + if (associated(CS%u_prev) .and. associated(CS%v_prev)) then + do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB + CS%u_prev(I,j,k) = u(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied + CS%v_prev(I,j,k) = v(i,J,k) + enddo ; enddo ; enddo + endif + + dt_therm_here = dt_therm + if (do_thermo .and. do_dyn .and. .not.thermo_does_span_coupling) & + dt_therm_here = dt*min(ntstep, n_max-n+1) + + ! Indicate whether the bottom boundary layer properties need to be + ! recalculated, and if so for how long an interval they are valid. + bbl_time_int = 0.0 + if (do_thermo) then + if ((CS%t_dyn_rel_adv == 0.0) .or. (n==1)) & + bbl_time_int = max(dt, min(dt_therm - CS%t_dyn_rel_adv, dt*(1+n_max-n)) ) + else + if ((CS%t_dyn_rel_adv == 0.0) .or. ((n==1) .and. cycle_start)) & + bbl_time_int = min(dt_therm, cycle_time) + endif + + if (CS%interp_p_surf) then + wt_end = real(n) / real(n_max) + wt_beg = real(n-1) / real(n_max) + do j=jsd,jed ; do i=isd,ied + CS%p_surf_end(i,j) = wt_end * forces%p_surf(i,j) + & + (1.0-wt_end) * CS%p_surf_prev(i,j) + CS%p_surf_begin(i,j) = wt_beg * forces%p_surf(i,j) + & + (1.0-wt_beg) * CS%p_surf_prev(i,j) + enddo ; enddo + endif + + + call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & + dt_therm_here, bbl_time_int, CS, & + Time_local, Waves=Waves) + + !=========================================================================== + ! This is the start of the tracer advection part of the algorithm. + + if (thermo_does_span_coupling .or. .not.do_thermo) then + do_advection = (CS%t_dyn_rel_adv + 0.5*dt > dt_therm) + else + do_advection = ((MOD(n,ntstep) == 0) .or. (n==n_max)) + endif + + if (do_advection) then ! Do advective transport and lateral tracer mixing. + call step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) + if (CS%diabatic_first .and. abs(CS%t_dyn_rel_thermo) > 1e-6*dt) call MOM_error(FATAL, & + "step_MOM: Mismatch between the dynamics and diabatic times "//& + "with DIABATIC_FIRST.") + endif + endif ! end of (do_dyn) + + !=========================================================================== + ! This is the second place where the diabatic processes and remapping could occur. + if ((CS%t_dyn_rel_adv==0.0) .and. do_thermo .and. (.not.CS%diabatic_first)) then + + dtdia = CS%t_dyn_rel_thermo + ! If the MOM6 dynamic and thermodynamic time stepping is being orchestrated + ! by the coupler, the value of diabatic_first does not matter. + if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) dtdia = dt + + if (CS%thermo_spans_coupling .and. (CS%dt_therm > 1.5*cycle_time) .and. & + (abs(dt_therm - dtdia) > 1e-6*dt_therm)) then + call MOM_error(FATAL, "step_MOM: Mismatch between dt_therm and dtdia "//& + "before call to diabatic.") + endif + + ! If necessary, temporarily reset CS%Time to the center of the period covered + ! by the call to step_MOM_thermo, noting that they end at the same time. + ! This step was missing prior to Feb 2018, and is skipped with CS%use_diabatic_time_bug=T. + if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) & + CS%Time = CS%Time - real_to_time(0.5*US%T_to_s*(dtdia-dt)) + + ! Apply diabatic forcing, do mixing, and regrid. + call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & + Time_local, .false., Waves=Waves) + CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia + + if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) then + ! The diabatic processes are now ahead of the dynamics by dtdia. + CS%t_dyn_rel_thermo = -dtdia + else ! The diabatic processes and the dynamics are synchronized. + CS%t_dyn_rel_thermo = 0.0 + endif + + ! Reset CS%Time to its previous value. + ! This step was missing prior to Feb 2018, and is skipped with CS%use_diabatic_time_bug=T. + if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) & + CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) + endif + + if (do_dyn) then + call cpu_clock_begin(id_clock_dynamics) + ! Determining the time-average sea surface height is part of the algorithm. + ! This may be eta_av if Boussinesq, or need to be diagnosed if not. + CS%time_in_cycle = CS%time_in_cycle + dt + call find_eta(h, CS%tv, G, GV, US, ssh, CS%eta_av_bc, dZref=G%Z_ref) + do j=js,je ; do i=is,ie + CS%ssh_rint(i,j) = CS%ssh_rint(i,j) + dt*ssh(i,j) + enddo ; enddo + if (CS%IDs%id_ssh_inst > 0) call post_data(CS%IDs%id_ssh_inst, ssh, CS%diag) + call cpu_clock_end(id_clock_dynamics) + endif + + !=========================================================================== + ! Calculate diagnostics at the end of the time step if the state is self-consistent. + if (MOM_state_is_synchronized(CS)) then + !### Perhaps this should be if (CS%t_dyn_rel_thermo == 0.0) + call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) + ! Diagnostics that require the complete state to be up-to-date can be calculated. + + call enable_averages(CS%t_dyn_rel_diag, Time_local, CS%diag) + call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & + CS%CDp, p_surf, CS%t_dyn_rel_diag, CS%diag_pre_sync,& + G, GV, US, CS%diagnostics_CSp) + call post_tracer_diagnostics_at_sync(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, CS%t_dyn_rel_diag) + call diag_copy_diag_to_storage(CS%diag_pre_sync, h, CS%diag) + if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") + call disable_averaging(CS%diag) + CS%t_dyn_rel_diag = 0.0 + + call cpu_clock_end(id_clock_diagnostics) ; call cpu_clock_end(id_clock_other) + endif + + if (do_dyn .and. .not.CS%count_calls) CS%nstep_tot = CS%nstep_tot + 1 + if (showCallTree) call callTree_leave("DT cycles (step_MOM)") + + enddo ! complete the n loop + + if (CS%count_calls .and. cycle_start) CS%nstep_tot = CS%nstep_tot + 1 + + call cpu_clock_begin(id_clock_other) + + if (CS%time_in_cycle > 0.0) then + I_wt_ssh = 1.0/CS%time_in_cycle + do j=js,je ; do i=is,ie + ssh(i,j) = CS%ssh_rint(i,j)*I_wt_ssh + CS%ave_ssh_ibc(i,j) = ssh(i,j) + enddo ; enddo + if (do_dyn) then + call adjust_ssh_for_p_atm(CS%tv, G, GV, US, CS%ave_ssh_ibc, forces%p_surf_SSH, & + CS%calc_rho_for_sea_lev) + elseif (do_thermo) then + call adjust_ssh_for_p_atm(CS%tv, G, GV, US, CS%ave_ssh_ibc, fluxes%p_surf_SSH, & + CS%calc_rho_for_sea_lev) + endif + endif + + if (do_dyn .and. CS%interp_p_surf) then ; do j=jsd,jed ; do i=isd,ied + CS%p_surf_prev(i,j) = forces%p_surf(i,j) + enddo ; enddo ; endif + + if (CS%ensemble_ocean) then + ! store ensemble vector in odaCS + call set_prior_tracer(CS%Time, G, GV, CS%h, CS%tv, CS%odaCS) + ! call DA interface + call oda(CS%Time,CS%odaCS) + ! update the time for the next analysis step if needed + call set_analysis_time(CS%Time,CS%odaCS) + endif + + if (showCallTree) call callTree_waypoint("calling extract_surface_state (step_MOM)") + ! NOTE: sfc_state uses input indexing, since it is also used by drivers. + call extract_surface_state(CS, sfc_state) + + ! Do diagnostics that only occur at the end of a complete forcing step. + if (cycle_end) then + if (CS%rotate_index) then + allocate(sfc_state_diag) + call rotate_surface_state(sfc_state, sfc_state_diag, G, turns) + else + sfc_state_diag => sfc_state + endif + + call cpu_clock_begin(id_clock_diagnostics) + if (CS%time_in_cycle > 0.0) then + call enable_averages(CS%time_in_cycle, Time_local, CS%diag) + call post_surface_dyn_diags(CS%sfc_IDs, G, CS%diag, sfc_state_diag, ssh) + endif + if (CS%time_in_thermo_cycle > 0.0) then + call enable_averages(CS%time_in_thermo_cycle, Time_local, CS%diag) + call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, CS%time_in_thermo_cycle, & + sfc_state_diag, CS%tv, ssh, CS%ave_ssh_ibc) + endif + call disable_averaging(CS%diag) + call cpu_clock_end(id_clock_diagnostics) + endif + + ! Accumulate the surface fluxes for assessing conservation + if (do_thermo .and. fluxes%fluxes_used) & + call accumulate_net_input(fluxes, sfc_state, CS%tv, fluxes%dt_buoy_accum, & + G, US, CS%sum_output_CSp) + + if (MOM_state_is_synchronized(CS)) & + call write_energy(CS%u, CS%v, CS%h, CS%tv, Time_local, CS%nstep_tot, & + G, GV, US, CS%sum_output_CSp, CS%tracer_flow_CSp, & + dt_forcing=real_to_time(US%T_to_s*time_interval) ) + + call cpu_clock_end(id_clock_other) + + ! De-rotate fluxes and copy back to the input, since they can be changed. + if (CS%rotate_index) then + call rotate_forcing(fluxes, fluxes_in, -turns) + call rotate_mech_forcing(forces, -turns, forces_in) + call deallocate_mech_forcing(forces) + deallocate(forces) + call deallocate_forcing_type(fluxes) + deallocate(fluxes) + endif + + if (showCallTree) call callTree_leave("step_MOM()") + call cpu_clock_end(id_clock_ocean) + +end subroutine step_MOM + +!> Time step the ocean dynamics, including the momentum and continuity equations +subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & + bbl_time_int, CS, Time_local, Waves) + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the surface + !! pressure at the beginning of this dynamic + !! step, intent in [R L2 T-2 ~> Pa]. + real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to the surface + !! pressure at the end of this dynamic step, + !! intent in [R L2 T-2 ~> Pa]. + real, intent(in) :: dt !< time interval covered by this call [T ~> s]. + real, intent(in) :: dt_thermo !< time interval covered by any updates that may + !! span multiple dynamics steps [T ~> s]. + real, intent(in) :: bbl_time_int !< time interval over which updates to the + !! bottom boundary layer properties will apply [T ~> s], + !! or zero not to update the properties. + type(MOM_control_struct), intent(inout), target :: CS !< control structure from initialize_MOM + type(time_type), intent(in) :: Time_local !< End time of a segment, as a time type + type(wave_parameters_CS), & + optional, pointer :: Waves !< Container for wave related parameters; the + !! fields in Waves are intent in here. + + ! local variables + type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing + ! metrics and related information + type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the vertical grid structure + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors + type(MOM_diag_IDs), pointer :: IDs => NULL() ! A structure with the diagnostic IDs. + real, dimension(:,:,:), pointer :: & + u => NULL(), & ! u : zonal velocity component [L T-1 ~> m s-1] + v => NULL(), & ! v : meridional velocity component [L T-1 ~> m s-1] + h => NULL(), & ! h : layer thickness [H ~> m or kg m-2] + uh => NULL(), & ! uh : layer thickness times u [UH ~> m2 s-1 or kg m-1 s-1] + vh => NULL() ! vh : layer thickness times v [VH ~> m2 s-1 or kg m-1 s-1] + + logical :: calc_dtbt ! Indicates whether the dynamically adjusted + ! barotropic time step needs to be updated. + logical :: showCallTree + + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + G => CS%G ; GV => CS%GV ; US => CS%US ; IDs => CS%IDs + 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 + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + u => CS%u ; v => CS%v ; h => CS%h ; uh => CS%uh ; vh => CS%vh + showCallTree = callTree_showQuery() + + call cpu_clock_begin(id_clock_dynamics) + call cpu_clock_begin(id_clock_stoch) + if (CS%use_stochastic_EOS) call MOM_stoch_eos_run(G, u, v, dt, Time_local, CS%stoch_eos_CS) + call cpu_clock_end(id_clock_stoch) + call cpu_clock_begin(id_clock_varT) + if (CS%use_stochastic_EOS) then + call MOM_calc_varT(G, GV, US, h, CS%tv, CS%stoch_eos_CS, dt) + if (associated(CS%tv%varT)) call pass_var(CS%tv%varT, G%Domain, clock=id_clock_pass, halo=1) + endif + call cpu_clock_end(id_clock_varT) + + if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse_first .and. & + (CS%thickness_diffuse .or. CS%interface_filter)) then + + call enable_averages(dt_thermo, Time_local+real_to_time(US%T_to_s*(dt_thermo-dt)), CS%diag) + if (CS%thickness_diffuse) then + call cpu_clock_begin(id_clock_thick_diff) + if (CS%VarMix%use_variable_mixing) & + call calc_slope_functions(h, uh, vh, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) + call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & + CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) + call cpu_clock_end(id_clock_thick_diff) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) + if (showCallTree) call callTree_waypoint("finished thickness_diffuse_first (step_MOM)") + endif + + if (CS%interface_filter) then + if (allocated(CS%tv%SpV_avg)) call pass_var(CS%tv%SpV_avg, G%Domain, clock=id_clock_pass) + CS%tv%valid_SpV_halo = min(G%Domain%nihalo, G%Domain%njhalo) + call cpu_clock_begin(id_clock_int_filter) + call interface_filter(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & + CS%CDp, CS%interface_filter_CSp) + call cpu_clock_end(id_clock_int_filter) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) + if (showCallTree) call callTree_waypoint("finished interface_filter_first (step_MOM)") + endif + + call disable_averaging(CS%diag) + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + endif + + ! Update porous barrier fractional cell metrics + if (CS%use_porbar) then + call enable_averages(dt, Time_local, CS%diag) + call porous_widths_layer(h, CS%tv, G, GV, US, CS%pbv, CS%por_bar_CS) + call disable_averaging(CS%diag) + call pass_vector(CS%pbv%por_face_areaU, CS%pbv%por_face_areaV, & + G%Domain, direction=To_All+SCALAR_PAIR, clock=id_clock_pass, halo=CS%cont_stencil) + endif + + ! The bottom boundary layer properties need to be recalculated. + if (bbl_time_int > 0.0) then + call enable_averages(bbl_time_int, & + Time_local + real_to_time(US%T_to_s*(bbl_time_int-dt)), CS%diag) + ! Calculate the BBL properties and store them inside visc (u,h). + call cpu_clock_begin(id_clock_BBL_visc) + call set_viscous_BBL(CS%u, CS%v, CS%h, CS%tv, CS%visc, G, GV, US, CS%set_visc_CSp, CS%pbv) + call cpu_clock_end(id_clock_BBL_visc) + if (showCallTree) call callTree_wayPoint("done with set_viscous_BBL (step_MOM)") + call disable_averaging(CS%diag) + endif + + !OBC segment data update for some fields can be less frequent than others + if (associated(CS%OBC)) then + CS%OBC%update_OBC_seg_data = .false. + if (CS%dt_obc_seg_period == 0.0) CS%OBC%update_OBC_seg_data = .true. + if (CS%dt_obc_seg_period > 0.0) then + if (Time_local >= CS%dt_obc_seg_time) then + CS%OBC%update_OBC_seg_data = .true. + CS%dt_obc_seg_time = CS%dt_obc_seg_time + CS%dt_obc_seg_interval + endif + endif + endif + + if (CS%do_dynamics .and. CS%split) then !--------------------------- start SPLIT + ! This section uses a split time stepping scheme for the dynamic equations, + ! basically the stacked shallow water equations with viscosity. + + calc_dtbt = .false. + if (CS%dtbt_reset_period == 0.0) calc_dtbt = .true. + if (CS%dtbt_reset_period > 0.0) then + if (Time_local >= CS%dtbt_reset_time) then !### Change >= to > here. + calc_dtbt = .true. + CS%dtbt_reset_time = CS%dtbt_reset_time + CS%dtbt_reset_interval + endif + endif + + if (CS%use_alt_split) then + call step_MOM_dyn_split_RK2b(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & + CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2b_CSp, calc_dtbt, CS%VarMix, & + CS%MEKE, CS%thickness_diffuse_CSp, CS%pbv, waves=waves) + else + call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & + CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, & + CS%MEKE, CS%thickness_diffuse_CSp, CS%pbv, waves=waves) + endif + if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_split (step_MOM)") + + elseif (CS%do_dynamics) then ! ------------------------------------ not SPLIT + ! This section uses an unsplit stepping scheme for the dynamic + ! equations; basically the stacked shallow water equations with viscosity. + ! Because the time step is limited by CFL restrictions on the external + ! gravity waves, the unsplit is usually much less efficient that the split + ! approaches. But because of its simplicity, the unsplit method is very + ! useful for debugging purposes. + + if (CS%use_RK2) then + call step_MOM_dyn_unsplit_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & + CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_RK2_CSp, CS%VarMix, CS%MEKE, CS%pbv) + else + call step_MOM_dyn_unsplit(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & + CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, CS%pbv, Waves=Waves) + endif + if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_unsplit (step_MOM)") + + endif ! -------------------------------------------------- end SPLIT + + ! Update the model's current to reflect wind-wave growth + if (Waves%Stokes_DDT .and. (.not.Waves%Passive_Stokes_DDT)) then + do J=jsq,jeq ; do i=is,ie + v(i,J,:) = v(i,J,:) + Waves%ddt_us_y(i,J,:)*dt + enddo; enddo + do j=js,je ; do I=isq,ieq + u(I,j,:) = u(I,j,:) + Waves%ddt_us_x(I,j,:)*dt + enddo; enddo + call pass_vector(u,v,G%Domain) + endif + ! Added an additional output to track Stokes drift time tendency. + ! It is mostly for debugging, and perhaps doesn't need to hang + ! around permanently. + if (Waves%Stokes_DDT .and. (Waves%id_3dstokes_y_from_ddt>0)) then + do J=jsq,jeq ; do i=is,ie + Waves%us_y_from_ddt(i,J,:) = Waves%us_y_from_ddt(i,J,:) + Waves%ddt_us_y(i,J,:)*dt + enddo; enddo + endif + if (Waves%Stokes_DDT .and. (Waves%id_3dstokes_x_from_ddt>0)) then + do j=js,je ; do I=isq,ieq + Waves%us_x_from_ddt(I,j,:) = Waves%us_x_from_ddt(I,j,:) + Waves%ddt_us_x(I,j,:)*dt + enddo; enddo + endif + + + if ((CS%thickness_diffuse .or. CS%interface_filter) .and. & + .not.CS%thickness_diffuse_first) then + + if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_MKS) + + if (CS%thickness_diffuse) then + call cpu_clock_begin(id_clock_thick_diff) + if (CS%VarMix%use_variable_mixing) & + call calc_slope_functions(h, uh, vh, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) + call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & + CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) + + if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call cpu_clock_end(id_clock_thick_diff) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) + if (showCallTree) call callTree_waypoint("finished thickness_diffuse (step_MOM)") + endif + + if (CS%interface_filter) then + if (allocated(CS%tv%SpV_avg)) call pass_var(CS%tv%SpV_avg, G%Domain, clock=id_clock_pass) + CS%tv%valid_SpV_halo = min(G%Domain%nihalo, G%Domain%njhalo) + call cpu_clock_begin(id_clock_int_filter) + call interface_filter(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & + CS%CDp, CS%interface_filter_CSp) + call cpu_clock_end(id_clock_int_filter) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) + if (showCallTree) call callTree_waypoint("finished interface_filter (step_MOM)") + endif + endif + + ! apply the submesoscale mixed layer restratification parameterization + if (CS%mixedlayer_restrat) then + if (CS%debug) then + call hchksum(h,"Pre-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Pre-mixedlayer_restrat uhtr", & + CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + endif + call cpu_clock_begin(id_clock_ml_restrat) + call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, & + CS%visc%sfc_buoy_flx, CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp) + call cpu_clock_end(id_clock_ml_restrat) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) + if (CS%debug) then + call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Post-mixedlayer_restrat [uv]htr", & + CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + endif + endif + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + if (CS%useMEKE .and. CS%MEKE_in_dynamics) then + call step_forward_MEKE(CS%MEKE, h, CS%VarMix%SN_u, CS%VarMix%SN_v, & + CS%visc, dt, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr, & + CS%u, CS%v, CS%tv, Time_local) + endif + call disable_averaging(CS%diag) + + if (CS%use_particles .and. CS%do_dynamics .and. CS%use_uh_particles) then + !Run particles using thickness-weighted velocity + call particles_run(CS%particles, Time_local, CS%uhtr, CS%vhtr, CS%h, & + CS%tv, CS%use_uh_particles) + elseif (CS%use_particles .and. CS%do_dynamics) then + !Run particles using unweighted velocity + call particles_run(CS%particles, Time_local, CS%u, CS%v, CS%h, & + CS%tv, CS%use_uh_particles) + endif + + + ! Advance the dynamics time by dt. + CS%t_dyn_rel_adv = CS%t_dyn_rel_adv + dt + CS%n_dyn_steps_in_adv = CS%n_dyn_steps_in_adv + 1 + if (CS%alternate_first_direction) then + call set_first_direction(G, MODULO(G%first_direction+1,2)) + CS%first_dir_restart = real(G%first_direction) + endif + CS%t_dyn_rel_thermo = CS%t_dyn_rel_thermo + dt + if (abs(CS%t_dyn_rel_thermo) < 1e-6*dt) CS%t_dyn_rel_thermo = 0.0 + CS%t_dyn_rel_diag = CS%t_dyn_rel_diag + dt + + call cpu_clock_end(id_clock_dynamics) + + call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) + call enable_averages(dt, Time_local, CS%diag) + ! These diagnostics are available after every time dynamics step. + if (IDs%id_u > 0) call post_data(IDs%id_u, u, CS%diag) + if (IDs%id_v > 0) call post_data(IDs%id_v, v, CS%diag) + if (IDs%id_h > 0) call post_data(IDs%id_h, h, CS%diag) + if (CS%use_stochastic_EOS) call post_stoch_EOS_diags(CS%stoch_eos_CS, CS%tv, CS%diag) + call disable_averaging(CS%diag) + call cpu_clock_end(id_clock_diagnostics) ; call cpu_clock_end(id_clock_other) + +end subroutine step_MOM_dynamics + +!> step_MOM_tracer_dyn does tracer advection and lateral diffusion, bringing the +!! tracers up to date with the changes in state due to the dynamics. Surface +!! sources and sinks and remapping are handled via step_MOM_thermo. +subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) + type(MOM_control_struct), intent(inout) :: CS !< control structure + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< layer thicknesses after the transports [H ~> m or kg m-2] + type(time_type), intent(in) :: Time_local !< The model time at the end + !! of the time step. + type(group_pass_type) :: pass_T_S + integer :: halo_sz ! The size of a halo where data must be valid. + logical :: x_first ! If true, advect tracers first in the x-direction, then y. + logical :: showCallTree + showCallTree = callTree_showQuery() + + if (CS%debug) then + call cpu_clock_begin(id_clock_other) + call hchksum(h,"Pre-advection h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Pre-advection uhtr", CS%uhtr, CS%vhtr, G%HI, & + haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + if (associated(CS%tv%T)) call hchksum(CS%tv%T, "Pre-advection T", G%HI, haloshift=1, scale=US%C_to_degC) + if (associated(CS%tv%S)) call hchksum(CS%tv%S, "Pre-advection S", G%HI, haloshift=1, scale=US%S_to_ppt) + if (associated(CS%tv%frazil)) call hchksum(CS%tv%frazil, "Pre-advection frazil", G%HI, haloshift=0, & + scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + if (associated(CS%tv%salt_deficit)) call hchksum(CS%tv%salt_deficit, & + "Pre-advection salt deficit", G%HI, haloshift=0, scale=US%S_to_ppt*US%RZ_to_kg_m2) + ! call MOM_thermo_chksum("Pre-advection ", CS%tv, G, US) + call cpu_clock_end(id_clock_other) + endif + + call cpu_clock_begin(id_clock_thermo) ; call cpu_clock_begin(id_clock_tracer) + call enable_averages(CS%t_dyn_rel_adv, Time_local, CS%diag) + + if (CS%alternate_first_direction) then + ! This calculation of the value of G%first_direction from the start of the accumulation of + ! mass transports for use by the tracers is the equivalent to adding 2*n_dyn_steps before + ! subtracting n_dyn_steps so that the mod will be taken of a non-negative number. + x_first = (MODULO(G%first_direction+CS%n_dyn_steps_in_adv,2) == 0) + else + x_first = (MODULO(G%first_direction,2) == 0) + endif + if (CS%debug) call MOM_tracer_chksum("Pre-advect ", CS%tracer_Reg, G) + call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, US, & + CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_first) + if (CS%debug) call MOM_tracer_chksum("Post-advect ", CS%tracer_Reg, G) + call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, US, & + CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) + if (CS%debug) call MOM_tracer_chksum("Post-diffuse ", CS%tracer_Reg, G) + if (showCallTree) call callTree_waypoint("finished tracer advection/diffusion (step_MOM)") + if (associated(CS%OBC)) then + call pass_vector(CS%uhtr, CS%vhtr, G%Domain) + call update_segment_tracer_reservoirs(G, GV, CS%uhtr, CS%vhtr, h, CS%OBC, & + CS%t_dyn_rel_adv, CS%tracer_Reg) + endif + call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) + + call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) + call post_transport_diagnostics(G, GV, US, CS%uhtr, CS%vhtr, h, CS%transport_IDs, & + CS%diag_pre_dyn, CS%diag, CS%t_dyn_rel_adv, CS%tracer_reg) + ! Rebuild the remap grids now that we've posted the fields which rely on thicknesses + ! from before the dynamics calls + call diag_update_remap_grids(CS%diag) + + call disable_averaging(CS%diag) + call cpu_clock_end(id_clock_diagnostics) ; call cpu_clock_end(id_clock_other) + + ! Reset the accumulated transports to 0 and record that the dynamics + ! and advective times now agree. + call cpu_clock_begin(id_clock_thermo) ; call cpu_clock_begin(id_clock_tracer) + CS%uhtr(:,:,:) = 0.0 + CS%vhtr(:,:,:) = 0.0 + CS%n_dyn_steps_in_adv = 0 + CS%t_dyn_rel_adv = 0.0 + call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) + + if (CS%useMEKE .and. (.not. CS%MEKE_in_dynamics)) then + call step_forward_MEKE(CS%MEKE, h, CS%VarMix%SN_u, CS%VarMix%SN_v, & + CS%visc, CS%t_dyn_rel_adv, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr, & + CS%u, CS%v, CS%tv, Time_local) + endif + + if (associated(CS%tv%T)) then + call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + ! The bottom boundary layer calculation may need halo values of SpV_avg, including the corners. + if (allocated(CS%tv%SpV_avg)) halo_sz = max(halo_sz, 1) + if (halo_sz > 0) then + call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All, halo=halo_sz) + call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All, halo=halo_sz) + call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) + elseif (CS%diabatic_first) then + ! Temperature and salinity need halo updates because they will be used + ! in the dynamics before they are changed again. + call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All+Omit_Corners, halo=1) + call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All+Omit_Corners, halo=1) + call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) + halo_sz = 1 + endif + + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=halo_sz, debug=CS%debug) + endif + endif + + CS%preadv_h_stored = .false. + +end subroutine step_MOM_tracer_dyn + +!> MOM_step_thermo orchestrates the thermodynamic time stepping and vertical +!! remapping, via calls to diabatic (or adiabatic) and ALE_regrid. +subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & + Time_end_thermo, update_BBL, Waves) + type(MOM_control_struct), intent(inout) :: CS !< Master MOM control structure + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables + type(forcing), intent(inout) :: fluxes !< pointers to forcing fields + real, intent(in) :: dtdia !< The time interval over which to advance [T ~> s] + type(time_type), intent(in) :: Time_end_thermo !< End of averaging interval for thermo diags + logical, intent(in) :: update_BBL !< If true, calculate the bottom boundary layer properties. + type(wave_parameters_CS), & + optional, pointer :: Waves !< Container for wave related parameters + !! the fields in Waves are intent in here. + + real :: h_new(SZI_(G),SZJ_(G),SZK_(GV)) ! Layer thicknesses after regridding [H ~> m or kg m-2] + real :: dzRegrid(SZI_(G),SZJ_(G),SZK_(GV)+1) ! The change in grid interface positions due to regridding, + ! in the same units as thicknesses [H ~> m or kg m-2] + real :: h_old_u(SZIB_(G),SZJ_(G),SZK_(GV)) ! Source grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real :: h_old_v(SZI_(G),SZJB_(G),SZK_(GV)) ! Source grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + real :: h_new_u(SZIB_(G),SZJ_(G),SZK_(GV)) ! Destination grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real :: h_new_v(SZI_(G),SZJB_(G),SZK_(GV)) ! Destination grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + logical :: PCM_cell(SZI_(G),SZJ_(G),SZK_(GV)) ! If true, PCM remapping should be used in a cell. + logical :: use_ice_shelf ! Needed for selecting the right ALE interface. + logical :: showCallTree + type(group_pass_type) :: pass_T_S, pass_T_S_h, pass_uv_T_S_h + integer :: dynamics_stencil ! The computational stencil for the calculations + ! in the dynamic core. + integer :: halo_sz ! The size of a halo where data must be valid. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("step_MOM_thermo(), MOM.F90") + + use_ice_shelf = .false. + if (associated(CS%frac_shelf_h)) use_ice_shelf = .true. + + call enable_averages(dtdia, Time_end_thermo, CS%diag) + + if (associated(CS%odaCS)) then + if (CS%debug) then + call MOM_thermo_chksum("Pre-oda ", tv, G, US, haloshift=0) + endif + call apply_oda_tracer_increments(dtdia, Time_end_thermo, G, GV, tv, h, CS%odaCS) + if (CS%debug) then + call MOM_thermo_chksum("Post-oda ", tv, G, US, haloshift=0) + endif + endif + + if (associated(fluxes%p_surf) .or. associated(fluxes%p_surf_full)) then + call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + if (halo_sz > 0) then + if (associated(fluxes%p_surf_full)) & + call pass_var(fluxes%p_surf_full, G%Domain, & + clock=id_clock_pass, halo=halo_sz, complete=.not.associated(fluxes%p_surf)) + call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass, halo=halo_sz, complete=.true.) + endif + endif + + if (update_BBL) then + ! Calculate the BBL properties and store them inside visc (u,h). + ! This is here so that CS%visc is updated before diabatic() when + ! DIABATIC_FIRST=True. Otherwise diabatic() is called after the dynamics + ! and set_viscous_BBL is called as a part of the dynamic stepping. + call cpu_clock_begin(id_clock_BBL_visc) + !update porous barrier fractional cell metrics + if (CS%use_porbar) then + call porous_widths_interface(h, CS%tv, G, GV, US, CS%pbv, CS%por_bar_CS) + call pass_vector(CS%pbv%por_layer_widthU, CS%pbv%por_layer_widthV, & + G%Domain, direction=To_ALL+SCALAR_PAIR, clock=id_clock_pass, halo=CS%cont_stencil) + endif + call set_viscous_BBL(u, v, h, tv, CS%visc, G, GV, US, CS%set_visc_CSp, CS%pbv) + call cpu_clock_end(id_clock_BBL_visc) + if (showCallTree) call callTree_wayPoint("done with set_viscous_BBL (step_MOM_thermo)") + endif + + call cpu_clock_begin(id_clock_thermo) + if (.not.CS%adiabatic) then + if (CS%debug) then + call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) + call hchksum(h,"Pre-diabatic h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Pre-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & + haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + ! call MOM_state_chksum("Pre-diabatic ", u, v, h, CS%uhtr, CS%vhtr, G, GV, vel_scale=1.0) + call MOM_thermo_chksum("Pre-diabatic ", tv, G, US, haloshift=0) + call check_redundant("Pre-diabatic ", u, v, G, unscale=US%L_T_to_m_s) + call MOM_forcing_chksum("Pre-diabatic", fluxes, G, US, haloshift=0) + endif + + call cpu_clock_begin(id_clock_diabatic) + + call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, & + Time_end_thermo, G, GV, US, CS%diabatic_CSp, CS%stoch_CS, CS%OBC, Waves) + fluxes%fluxes_used = .true. + + if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") + + ! Regridding/remapping is done here, at end of thermodynamics time step + ! (that may comprise several dynamical time steps) + ! The routine 'ALE_regrid' can be found in 'MOM_ALE.F90'. + if ( CS%use_ALE_algorithm ) then + call enable_averages(dtdia, Time_end_thermo, CS%diag) +! call pass_vector(u, v, G%Domain) + call cpu_clock_begin(id_clock_pass) + if (associated(tv%T)) & + call create_group_pass(pass_T_S_h, tv%T, G%Domain, To_All+Omit_Corners, halo=1) + if (associated(tv%S)) & + call create_group_pass(pass_T_S_h, tv%S, G%Domain, To_All+Omit_Corners, halo=1) + call create_group_pass(pass_T_S_h, h, G%Domain, To_All+Omit_Corners, halo=1) + call do_group_pass(pass_T_S_h, G%Domain) + call cpu_clock_end(id_clock_pass) + + call preAle_tracer_diagnostics(CS%tracer_Reg, G, GV) + + if (CS%use_particles) then + call particles_to_z_space(CS%particles, h) + endif + + if (CS%debug) then + call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US, omit_corners=.true.) + call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1, omit_corners=.true., scale=US%C_to_degC) + call hchksum(tv%S,"Pre-ALE S", G%HI, haloshift=1, omit_corners=.true., scale=US%S_to_ppt) + call check_redundant("Pre-ALE ", u, v, G, unscale=US%L_T_to_m_s) + endif + call cpu_clock_begin(id_clock_ALE) + + call pre_ALE_diagnostics(G, GV, US, h, u, v, tv, CS%ALE_CSp) + call ALE_update_regrid_weights(dtdia, CS%ALE_CSp) + ! Do any necessary adjustments ot the state prior to remapping. + call pre_ALE_adjustments(G, GV, US, h, tv, CS%tracer_Reg, CS%ALE_CSp, u, v) + ! Adjust the target grids for diagnostics, in case there have been thickness adjustments. + call diag_update_remap_grids(CS%diag) + + if (use_ice_shelf) then + call ALE_regrid(G, GV, US, h, h_new, dzRegrid, tv, CS%ALE_CSp, CS%frac_shelf_h, PCM_cell) + else + call ALE_regrid(G, GV, US, h, h_new, dzRegrid, tv, CS%ALE_CSp, PCM_cell=PCM_cell) + endif + + if (showCallTree) call callTree_waypoint("new grid generated") + ! Remap all variables from the old grid h onto the new grid h_new + call ALE_remap_tracers(CS%ALE_CSp, G, GV, h, h_new, CS%tracer_Reg, showCallTree, dtdia, PCM_cell) + + ! Determine the old and new grid thicknesses at velocity points. + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, h, h_old_u, h_old_v, CS%OBC, debug=showCallTree) + if (CS%remap_uv_using_old_alg) then + call ALE_remap_set_h_vel_via_dz(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, h, dzRegrid, showCallTree) + else + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, debug=showCallTree) + endif + + ! Remap the velocity components. + call ALE_remap_velocities(CS%ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v, showCallTree) + + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + + if (CS%remap_aux_vars) then + if (CS%split .and. CS%use_alt_split) then + call remap_dyn_split_RK2b_aux_vars(G, GV, CS%dyn_split_RK2b_CSp, h_old_u, h_old_v, & + h_new_u, h_new_v, CS%ALE_CSp) + elseif (CS%split) then + call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h_old_u, h_old_v, h_new_u, h_new_v, CS%ALE_CSp) + endif + + if (associated(CS%OBC)) then + call pass_var(h, G%Domain, complete=.false.) + call pass_var(h_new, G%Domain, complete=.true.) + call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) + endif + + call remap_vertvisc_aux_vars(G, GV, CS%visc, h, h_new, CS%ALE_CSp, CS%OBC) + if (associated(CS%visc%Kv_shear)) & + call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, clock=id_clock_pass, halo=1) + endif + + ! Replace the old grid with new one. All remapping must be done by this point in the code. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + h(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + if (showCallTree) call callTree_waypoint("finished ALE_regrid (step_MOM_thermo)") + call cpu_clock_end(id_clock_ALE) + endif ! endif for the block "if ( CS%use_ALE_algorithm )" + + + if (CS%use_particles) then + call particles_to_k_space(CS%particles, h) + endif + + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call create_group_pass(pass_uv_T_S_h, u, v, G%Domain, halo=dynamics_stencil) + if (associated(tv%T)) & + call create_group_pass(pass_uv_T_S_h, tv%T, G%Domain, halo=dynamics_stencil) + if (associated(tv%S)) & + call create_group_pass(pass_uv_T_S_h, tv%S, G%Domain, halo=dynamics_stencil) + call create_group_pass(pass_uv_T_S_h, h, G%Domain, halo=dynamics_stencil) + call do_group_pass(pass_uv_T_S_h, G%Domain, clock=id_clock_pass) + + ! Update derived thermodynamic quantities. + if (allocated(tv%SpV_avg)) then + call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) + endif + + if (CS%debug .and. CS%use_ALE_algorithm) then + call MOM_state_chksum("Post-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US) + call hchksum(tv%T, "Post-ALE T", G%HI, haloshift=1, scale=US%C_to_degC) + call hchksum(tv%S, "Post-ALE S", G%HI, haloshift=1, scale=US%S_to_ppt) + call check_redundant("Post-ALE ", u, v, G, unscale=US%L_T_to_m_s) + endif + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. This needs to + ! happen after the H update and before the next post_data. + call diag_update_remap_grids(CS%diag) + + !### Consider moving this up into the if ALE block. + call postALE_tracer_diagnostics(CS%tracer_Reg, G, GV, CS%diag, dtdia) + + if (CS%debug) then + call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) + call hchksum(h, "Post-diabatic h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Post-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & + haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) + ! call MOM_state_chksum("Post-diabatic ", u, v, & + ! h, CS%uhtr, CS%vhtr, G, GV, haloshift=1) + if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, scale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, scale=US%S_to_ppt) + if (associated(tv%frazil)) call hchksum(tv%frazil, "Post-diabatic frazil", G%HI, haloshift=0, & + scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, & + "Post-diabatic salt deficit", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) + ! call MOM_thermo_chksum("Post-diabatic ", tv, G, US) + call check_redundant("Post-diabatic ", u, v, G, unscale=US%L_T_to_m_s) + endif + call disable_averaging(CS%diag) + + call cpu_clock_end(id_clock_diabatic) + else ! complement of "if (.not.CS%adiabatic)" + + call cpu_clock_begin(id_clock_adiabatic) + call adiabatic(h, tv, fluxes, dtdia, G, GV, US, CS%diabatic_CSp) + fluxes%fluxes_used = .true. + call cpu_clock_end(id_clock_adiabatic) + + if (associated(tv%T)) then + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call create_group_pass(pass_T_S, tv%T, G%Domain, To_All+Omit_Corners, halo=dynamics_stencil) + call create_group_pass(pass_T_S, tv%S, G%Domain, To_All+Omit_Corners, halo=dynamics_stencil) + call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) + if (CS%debug) then + if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, scale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, scale=US%S_to_ppt) + endif + + ! Update derived thermodynamic quantities. + if (allocated(tv%SpV_avg)) then + call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) + endif + endif + + endif ! endif for the block "if (.not.CS%adiabatic)" + call cpu_clock_end(id_clock_thermo) + + call disable_averaging(CS%diag) + + if (showCallTree) call callTree_leave("step_MOM_thermo(), MOM.F90") + +end subroutine step_MOM_thermo + + +!> step_offline is the main driver for running tracers offline in MOM6. This has been primarily +!! developed with ALE configurations in mind. Some work has been done in isopycnal configuration, but +!! the work is very preliminary. Some more detail about this capability along with some of the subroutines +!! called here can be found in tracers/MOM_offline_control.F90 +subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS) + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(forcing), intent(inout) :: fluxes !< pointers to forcing fields + type(surface), intent(inout) :: sfc_state !< surface ocean state + type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type + real, intent(in) :: time_interval !< time interval [T ~> s] + type(MOM_control_struct), intent(inout) :: CS !< control structure from initialize_MOM + + ! Local pointers + type(ocean_grid_type), pointer :: G => NULL() ! Pointer to a structure containing + ! metrics and related information + type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to structure containing information + ! about the vertical grid + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors + + logical :: first_iter !< True if this is the first time step_offline has been called in a given interval + logical :: last_iter !< True if this is the last time step_tracer is to be called in an offline interval + logical :: do_vertical !< If enough time has elapsed, do the diabatic tracer sources/sinks + logical :: adv_converged !< True if all the horizontal fluxes have been used + + real, allocatable, dimension(:,:,:) :: h_new ! Layer thicknesses after regridding [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: dzRegrid ! The change in grid interface positions due to regridding, + ! in the same units as thicknesses [H ~> m or kg m-2] + real :: dt_offline ! The offline timestep for advection [T ~> s] + real :: dt_offline_vertical ! The offline timestep for vertical fluxes and remapping [T ~> s] + logical :: skip_diffusion + + type(time_type), pointer :: accumulated_time => NULL() + type(time_type), pointer :: vertical_time => NULL() + integer :: dynamics_stencil ! The computational stencil for the calculations + ! in the dynamic core. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + + ! 3D pointers + real, dimension(:,:,:), pointer :: & + uhtr => NULL(), & ! Accumulated zonal thickness fluxes to advect tracers [H L2 ~> m3 or kg] + vhtr => NULL(), & ! Accumulated meridional thickness fluxes to advect tracers [H L2 ~> m3 or kg] + eatr => NULL(), & ! Layer entrainment rates across the interface above [H ~> m or kg m-2] + ebtr => NULL(), & ! Layer entrainment rates across the interface below [H ~> m or kg m-2] + h_end => NULL() ! Layer thicknesses at the end of a step [H ~> m or kg m-2] + + type(time_type) :: Time_end ! End time of a segment, as a time type + + ! Grid-related pointer assignments + G => CS%G ; GV => CS%GV ; US => CS%US + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + call cpu_clock_begin(id_clock_offline_tracer) + call extract_offline_main(CS%offline_CSp, uhtr, vhtr, eatr, ebtr, h_end, accumulated_time, & + vertical_time, dt_offline, dt_offline_vertical, skip_diffusion) + Time_end = increment_date(Time_start, seconds=floor(US%T_to_s*time_interval+0.001)) + + call enable_averages(time_interval, Time_end, CS%diag) + + ! Check to see if this is the first iteration of the offline interval + first_iter = (accumulated_time == real_to_time(0.0)) + + ! Check to see if vertical tracer functions should be done + do_vertical = (first_iter .or. (accumulated_time >= vertical_time)) + if (do_vertical) vertical_time = accumulated_time + real_to_time(US%T_to_s*dt_offline_vertical) + + ! Increment the amount of time elapsed since last read and check if it's time to roll around + accumulated_time = accumulated_time + real_to_time(US%T_to_s*time_interval) + + last_iter = (accumulated_time >= real_to_time(US%T_to_s*dt_offline)) + + if (CS%use_ALE_algorithm) then + ! If this is the first iteration in the offline timestep, then we need to read in fields and + ! perform the main advection. + if (first_iter) then + call MOM_mesg("Reading in new offline fields") + ! Read in new transport and other fields + ! call update_transport_from_files(G, GV, CS%offline_CSp, h_end, eatr, ebtr, uhtr, vhtr, & + ! CS%tv%T, CS%tv%S, fluxes, CS%use_ALE_algorithm) + ! call update_transport_from_arrays(CS%offline_CSp) + call update_offline_fields(CS%offline_CSp, G, GV, US, CS%h, fluxes, CS%use_ALE_algorithm) + + ! Apply any fluxes into the ocean + call offline_fw_fluxes_into_ocean(G, GV, CS%offline_CSp, fluxes, CS%h) + + if (.not.CS%diabatic_first) then + call offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, CS%offline_CSp, & + id_clock_ALE, CS%h, uhtr, vhtr, converged=adv_converged) + + ! Redistribute any remaining transport + call offline_redistribute_residual(CS%offline_CSp, G, GV, US, CS%h, uhtr, vhtr, adv_converged) + + ! Perform offline diffusion if requested + if (.not. skip_diffusion) then + if (CS%VarMix%use_variable_mixing) then + call pass_var(CS%h, G%Domain) + call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) + call calc_depth_function(G, CS%VarMix) + call calc_slope_functions(CS%h, CS%uh, CS%vh, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) + endif + call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & + CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) + endif + endif + endif + ! The functions related to column physics of tracers is performed separately in ALE mode + if (do_vertical) then + call offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS%offline_CSp, & + CS%h, CS%tv, eatr, ebtr) + endif + + ! Last thing that needs to be done is the final ALE remapping + if (last_iter) then + if (CS%diabatic_first) then + call offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, CS%offline_CSp, & + id_clock_ALE, CS%h, uhtr, vhtr, converged=adv_converged) + + ! Redistribute any remaining transport and perform the remaining advection + call offline_redistribute_residual(CS%offline_CSp, G, GV, US, CS%h, uhtr, vhtr, adv_converged) + ! Perform offline diffusion if requested + if (.not. skip_diffusion) then + if (CS%VarMix%use_variable_mixing) then + call pass_var(CS%h, G%Domain) + call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) + call calc_depth_function(G, CS%VarMix) + call calc_slope_functions(CS%h, CS%uh, CS%vh, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) + endif + call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & + CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) + endif + endif + + call MOM_mesg("Last iteration of offline interval") + + ! Apply freshwater fluxes out of the ocean + call offline_fw_fluxes_out_ocean(G, GV, CS%offline_CSp, fluxes, CS%h) + ! These diagnostic can be used to identify which grid points did not converge within + ! the specified number of advection sub iterations + call post_offline_convergence_diags(G, GV, CS%offline_CSp, CS%h, h_end, uhtr, vhtr) + + ! Call ALE one last time to make sure that tracers are remapped onto the layer thicknesses + ! stored from the forward run + call cpu_clock_begin(id_clock_ALE) + + ! Do any necessary adjustments ot the state prior to remapping. + call pre_ALE_adjustments(G, GV, US, h_end, CS%tv, CS%tracer_Reg, CS%ALE_CSp) + + allocate(h_new(isd:ied, jsd:jed, nz), source=0.0) + allocate(dzRegrid(isd:ied, jsd:jed, nz+1), source=0.0) + + ! Generate the new grid based on the tracer grid at the end of the interval. + call ALE_regrid(G, GV, US, h_end, h_new, dzRegrid, CS%tv, CS%ALE_CSp) + + ! Remap the tracers from the previous tracer grid onto the new grid. The thicknesses that + ! are used are intended to ensure that in the case where transports don't quite conserve, + ! the offline layer thicknesses do not drift too far away from the online model. + call ALE_remap_tracers(CS%ALE_CSp, G, GV, CS%h, h_new, CS%tracer_Reg, debug=CS%debug) + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + + ! Update the tracer grid. + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + CS%h(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + deallocate(h_new, dzRegrid) + + call cpu_clock_end(id_clock_ALE) + call pass_var(CS%h, G%Domain) + endif + else ! NON-ALE MODE...NOT WELL TESTED + call MOM_error(WARNING, & + "Offline tracer mode in non-ALE configuration has not been thoroughly tested") + ! Note that for the layer mode case, the calls to tracer sources and sinks is embedded in + ! main_offline_advection_layer. Warning: this may not be appropriate for tracers that + ! exchange with the atmosphere + if (abs(time_interval - dt_offline) > 1.0e-6*US%s_to_T) then + call MOM_error(FATAL, & + "For offline tracer mode in a non-ALE configuration, dt_offline must equal time_interval") + endif + call update_offline_fields(CS%offline_CSp, G, GV, US, CS%h, fluxes, CS%use_ALE_algorithm) + call offline_advection_layer(fluxes, Time_start, time_interval, G, GV, US, CS%offline_CSp, & + CS%h, eatr, ebtr, uhtr, vhtr) + ! Perform offline diffusion if requested + if (.not. skip_diffusion) then + call tracer_hordiff(h_end, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & + CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) + endif + + CS%h = h_end + + call pass_var(CS%tv%T, G%Domain) + call pass_var(CS%tv%S, G%Domain) + call pass_var(CS%h, G%Domain) + + endif + + call adjust_ssh_for_p_atm(CS%tv, G, GV, US, CS%ave_ssh_ibc, forces%p_surf_SSH, & + CS%calc_rho_for_sea_lev) + call extract_surface_state(CS, sfc_state) + + call disable_averaging(CS%diag) + call pass_var(CS%tv%T, G%Domain) + call pass_var(CS%tv%S, G%Domain) + call pass_var(CS%h, G%Domain) + + fluxes%fluxes_used = .true. + + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil) + endif + + if (last_iter) then + accumulated_time = real_to_time(0.0) + endif + + call cpu_clock_end(id_clock_offline_tracer) + +end subroutine step_offline + +!> Initialize MOM, including memory allocation, setting up parameters and diagnostics, +!! initializing the ocean state variables, and initializing subsidiary modules +subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & + Time_in, offline_tracer_mode, input_restart_file, diag_ptr, & + count_calls, tracer_flow_CSp, ice_shelf_CSp, waves_CSp, ensemble_num) + type(time_type), target, intent(inout) :: Time !< model time, set in this routine + type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar + type(param_file_type), intent(out) :: param_file !< structure indicating parameter file to parse + type(directories), intent(out) :: dirs !< structure with directory paths + type(MOM_control_struct), intent(inout), target :: CS !< pointer set in this routine to MOM control structure + type(time_type), optional, intent(in) :: Time_in !< time passed to MOM_initialize_state when + !! model is not being started from a restart file + logical, optional, intent(out) :: offline_tracer_mode !< True is returned if tracers are being run offline + character(len=*),optional, intent(in) :: input_restart_file !< If present, name of restart file to read + type(diag_ctrl), optional, pointer :: diag_ptr !< A pointer set in this routine to the diagnostic + !! regulatory structure + type(tracer_flow_control_CS), & + optional, pointer :: tracer_flow_CSp !< A pointer set in this routine to + !! the tracer flow control structure. + logical, optional, intent(in) :: count_calls !< If true, nstep_tot counts the number of + !! calls to step_MOM instead of the number of + !! dynamics timesteps. + type(ice_shelf_CS), optional, pointer :: ice_shelf_CSp !< A pointer to an ice shelf control structure + type(Wave_parameters_CS), & + optional, pointer :: Waves_CSp !< An optional pointer to a wave property CS + integer, optional :: ensemble_num !< Ensemble index provided by the cap (instead of FMS + !! ensemble manager) + ! local variables + type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the metric grid use for the run + type(ocean_grid_type), pointer :: G_in => NULL() ! Pointer to the input grid + type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents + type(hor_index_type), target :: HI_in ! HI on the input grid + type(verticalGrid_type), pointer :: GV => NULL() + type(dyn_horgrid_type), pointer :: dG => NULL(), test_dG => NULL() + type(dyn_horgrid_type), pointer :: dG_in => NULL() + type(diag_ctrl), pointer :: diag => NULL() + type(unit_scale_type), pointer :: US => NULL() + type(MOM_restart_CS), pointer :: restart_CSp => NULL() + character(len=4), parameter :: vers_num = 'v2.0' + integer :: turns ! Number of grid quarter-turns + + ! Initial state on the input index map + real, allocatable :: u_in(:,:,:) ! Initial zonal velocities [L T-1 ~> m s-1] + real, allocatable :: v_in(:,:,:) ! Initial meridional velocities [L T-1 ~> m s-1] + real, allocatable :: h_in(:,:,:) ! Initial layer thicknesses [H ~> m or kg m-2] + real, allocatable, target :: frac_shelf_in(:,:) ! Initial fraction of the total cell area occupied + ! by an ice shelf [nondim] + real, allocatable, target :: mass_shelf_in(:,:) ! Initial mass of ice shelf contained within a grid cell + ! [R Z ~> kg m-2] + real, allocatable, target :: T_in(:,:,:) ! Initial temperatures [C ~> degC] + real, allocatable, target :: S_in(:,:,:) ! Initial salinities [S ~> ppt] + + type(ocean_OBC_type), pointer :: OBC_in => NULL() + type(sponge_CS), pointer :: sponge_in_CSp => NULL() + type(ALE_sponge_CS), pointer :: ALE_sponge_in_CSp => NULL() + type(oda_incupd_CS),pointer :: oda_incupd_in_CSp => NULL() + ! This include declares and sets the variable "version". +# include "version_variable.h" + + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + real :: dtbt ! If negative, this specifies the barotropic timestep as a fraction + ! of the maximum stable value [nondim]. + + real, allocatable, dimension(:,:) :: eta ! free surface height or column mass [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_new ! Layer thicknesses after regridding [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: dzRegrid ! The change in grid interface positions due to regridding, + ! in the same units as thicknesses [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_old_u ! Source grid thickness at zonal velocity points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_old_v ! Source grid thickness at meridional velocity + ! points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_new_u ! Destination grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_new_v ! Destination grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + logical, allocatable, dimension(:,:,:) :: PCM_cell ! If true, PCM remapping should be used in a cell. + type(group_pass_type) :: tmp_pass_uv_T_S_h, pass_uv_T_S_h + + real :: Hmix_z, Hmix_UV_z ! Temporary variables with averaging depths [Z ~> m] + real :: HFrz_z ! Temporary variable with the melt potential depth [Z ~> m] + real :: default_val ! The default value for DTBT_RESET_PERIOD [s] + logical :: write_geom_files ! If true, write out the grid geometry files. + logical :: new_sim ! If true, this has been determined to be a new simulation + logical :: use_geothermal ! If true, apply geothermal heating. + logical :: use_EOS ! If true, density calculated from T & S using an equation of state. + logical :: symmetric ! If true, use symmetric memory allocation. + logical :: save_IC ! If true, save the initial conditions. + logical :: do_unit_tests ! If true, call unit tests. + logical :: test_grid_copy = .false. + + logical :: bulkmixedlayer ! If true, a refined bulk mixed layer scheme is used + ! with nkml sublayers and nkbl buffer layer. + logical :: use_temperature ! If true, temperature and salinity used as state variables. + logical :: use_p_surf_in_EOS ! If true, always include the surface pressure contributions + ! in equation of state calculations. + logical :: use_frazil ! If true, liquid seawater freezes if temp below freezing, + ! with accumulated heat deficit returned to surface ocean. + logical :: bound_salinity ! If true, salt is added to keep salinity above + ! a minimum value, and the deficit is reported. + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: use_conT_absS ! If true, the prognostics T & S are conservative temperature + ! and absolute salinity. Care should be taken to convert them + ! to potential temperature and practical salinity before + ! exchanging them with the coupler and/or reporting T&S diagnostics. + logical :: advect_TS ! If false, then no horizontal advection of temperature + ! and salnity is performed + logical :: use_ice_shelf ! Needed for ALE + logical :: global_indexing ! If true use global horizontal index values instead + ! of having the data domain on each processor start at 1. + logical :: bathy_at_vel ! If true, also define bathymetric fields at the + ! the velocity points. + logical :: calc_dtbt ! Indicates whether the dynamically adjusted barotropic + ! time step needs to be updated before it is used. + logical :: debug_truncations ! If true, turn on diagnostics useful for debugging truncations. + integer :: first_direction ! An integer that indicates which direction is to be + ! updated first in directionally split parts of the + ! calculation. + logical :: non_Bous ! If true, this run is fully non-Boussinesq + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq + logical :: use_KPP ! If true, diabatic is using KPP vertical mixing + integer :: nkml, nkbl, verbosity, write_geom + integer :: dynamics_stencil ! The computational stencil for the calculations + ! in the dynamic core. + real :: salin_underflow ! A tiny value of salinity below which the it is set to 0 [S ~> ppt] + real :: temp_underflow ! A tiny magnitude of temperatures below which they are set to 0 [C ~> degC] + real :: conv2watt ! A conversion factor from temperature fluxes to heat + ! fluxes [J m-2 H-1 C-1 ~> J m-3 degC-1 or J kg-1 degC-1] + real :: conv2salt ! A conversion factor for salt fluxes [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] + character(len=48) :: S_flux_units + + type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. + type(time_type) :: Start_time + type(ocean_internal_state) :: MOM_internal_state + + CS%Time => Time + + id_clock_init = cpu_clock_id('Ocean Initialization', grain=CLOCK_SUBCOMPONENT) + call cpu_clock_begin(id_clock_init) + + Start_time = Time ; if (present(Time_in)) Start_time = Time_in + + ! Read paths and filenames from namelist and store in "dirs". + ! Also open the parsed input parameter file(s) and setup param_file. + call get_MOM_input(param_file, dirs, default_input_filename=input_restart_file, ensemble_num=ensemble_num) + + verbosity = 2 ; call read_param(param_file, "VERBOSITY", verbosity) + call MOM_set_verbosity(verbosity) + call callTree_enter("initialize_MOM(), MOM.F90") + + call find_obsolete_params(param_file) + + ! Determining the internal unit scaling factors for this run. + call unit_scaling_init(param_file, CS%US) + US => CS%US + + ! Read relevant parameters and write them to the model log. + call log_version(param_file, "MOM", version, "", log_to_all=.true., layout=.true., debugging=.true.) + call get_param(param_file, "MOM", "VERBOSITY", verbosity, & + "Integer controlling level of messaging\n" // & + "\t0 = Only FATAL messages\n" // & + "\t2 = Only FATAL, WARNING, NOTE [default]\n" // & + "\t9 = All)", default=2, debuggingParam=.true.) + call get_param(param_file, "MOM", "DO_UNIT_TESTS", do_unit_tests, & + "If True, exercises unit tests at model start up.", & + default=.false., debuggingParam=.true.) + if (do_unit_tests) then + id_clock_unit_tests = cpu_clock_id('(Ocean unit tests)', grain=CLOCK_MODULE) + call cpu_clock_begin(id_clock_unit_tests) + call unit_tests(verbosity) + call cpu_clock_end(id_clock_unit_tests) + endif + + call get_param(param_file, "MOM", "SPLIT", CS%split, & + "Use the split time stepping if true.", default=.true.) + call get_param(param_file, "MOM", "SPLIT_RK2B", CS%use_alt_split, & + "If true, use a version of the split explicit time stepping scheme that "//& + "exchanges velocities with step_MOM that have the average barotropic phase over "//& + "a baroclinic timestep rather than the instantaneous barotropic phase.", & + default=.false., do_not_log=.not.CS%split) + if (CS%split) then + CS%use_RK2 = .false. + else + call get_param(param_file, "MOM", "USE_RK2", CS%use_RK2, & + "If true, use RK2 instead of RK3 in the unsplit time stepping.", & + default=.false.) + endif + + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + non_Bous = .not.(Boussinesq .or. semi_Boussinesq) + call get_param(param_file, "MOM", "CALC_RHO_FOR_SEA_LEVEL", CS%calc_rho_for_sea_lev, & + "If true, the in-situ density is used to calculate the "//& + "effective sea level that is returned to the coupler. If false, "//& + "the Boussinesq parameter RHO_0 is used.", default=non_Bous) + call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, & + "If true, Temperature and salinity are used as state "//& + "variables.", default=.true.) + call get_param(param_file, "MOM", "USE_EOS", use_EOS, & + "If true, density is calculated from temperature and "//& + "salinity with an equation of state. If USE_EOS is "//& + "true, ENABLE_THERMODYNAMICS must be true as well.", & + default=use_temperature) + call get_param(param_file, "MOM", "DIABATIC_FIRST", CS%diabatic_first, & + "If true, apply diabatic and thermodynamic processes, "//& + "including buoyancy forcing and mass gain or loss, "//& + "before stepping the dynamics forward.", default=.false.) + call get_param(param_file, "MOM", "USE_CONTEMP_ABSSAL", use_conT_absS, & + "If true, the prognostics T&S are the conservative temperature "//& + "and absolute salinity. Care should be taken to convert them "//& + "to potential temperature and practical salinity before "//& + "exchanging them with the coupler and/or reporting T&S diagnostics.", & + default=.false.) + CS%tv%T_is_conT = use_conT_absS ; CS%tv%S_is_absS = use_conT_absS + call get_param(param_file, "MOM", "ADIABATIC", CS%adiabatic, & + "There are no diapycnal mass fluxes if ADIABATIC is true. "//& + "This assumes that KD = 0.0 and that there is no buoyancy forcing, "//& + "but makes the model faster by eliminating subroutine calls.", default=.false.) + call get_param(param_file, "MOM", "DO_DYNAMICS", CS%do_dynamics, & + "If False, skips the dynamics calls that update u & v, as well as "//& + "the gravity wave adjustment to h. This may be a fragile feature, "//& + "but can be useful during development", default=.true.) + call get_param(param_file, "MOM", "ADVECT_TS", advect_TS, & + "If True, advect temperature and salinity horizontally "//& + "If False, T/S are registered for advection. "//& + "This is intended only to be used in offline tracer mode "//& + "and is by default false in that case.", & + do_not_log=.true., default=.true.) + if (present(offline_tracer_mode)) then ! Only read this parameter in enabled modes + call get_param(param_file, "MOM", "OFFLINE_TRACER_MODE", CS%offline_tracer_mode, & + "If true, barotropic and baroclinic dynamics, thermodynamics "//& + "are all bypassed with all the fields necessary to integrate "//& + "the tracer advection and diffusion equation are read in from "//& + "files stored from a previous integration of the prognostic model. "//& + "NOTE: This option only used in the ocean_solo_driver.", default=.false.) + if (CS%offline_tracer_mode) then + call get_param(param_file, "MOM", "ADVECT_TS", advect_TS, & + "If True, advect temperature and salinity horizontally "//& + "If False, T/S are registered for advection. "//& + "This is intended only to be used in offline tracer mode."//& + "and is by default false in that case", & + default=.false. ) + endif + endif + call get_param(param_file, "MOM", "USE_REGRIDDING", CS%use_ALE_algorithm, & + "If True, use the ALE algorithm (regridding/remapping). "//& + "If False, use the layered isopycnal algorithm.", default=.false. ) + call get_param(param_file, "MOM", "REMAP_UV_USING_OLD_ALG", CS%remap_uv_using_old_alg, & + "If true, uses the old remapping-via-a-delta-z method for "//& + "remapping u and v. If false, uses the new method that remaps "//& + "between grids described by an old and new thickness.", & + default=.false., do_not_log=.not.CS%use_ALE_algorithm) + call get_param(param_file, "MOM", "REMAP_AUXILIARY_VARS", CS%remap_aux_vars, & + "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& + "variables that are needed to reproduce across restarts, similarly to "//& + "what is already being done with the primary state variables. "//& + "The default should be changed to true.", default=.false., & + do_not_log=.not.CS%use_ALE_algorithm) + call get_param(param_file, "MOM", "BULKMIXEDLAYER", bulkmixedlayer, & + "If true, use a Kraus-Turner-like bulk mixed layer "//& + "with transitional buffer layers. Layers 1 through "//& + "NKML+NKBL have variable densities. There must be at "//& + "least NKML+NKBL+1 layers if BULKMIXEDLAYER is true. "//& + "BULKMIXEDLAYER can not be used with USE_REGRIDDING. "//& + "The default is influenced by ENABLE_THERMODYNAMICS.", & + default=use_temperature .and. .not.CS%use_ALE_algorithm) + call get_param(param_file, "MOM", "THICKNESSDIFFUSE", CS%thickness_diffuse, & + "If true, isopycnal surfaces are diffused with a Laplacian "//& + "coefficient of KHTH.", default=.false.) + call get_param(param_file, "MOM", "APPLY_INTERFACE_FILTER", CS%interface_filter, & + "If true, model interface heights are subjected to a grid-scale "//& + "dependent spatial smoothing, often with biharmonic filter.", default=.false.) + call get_param(param_file, "MOM", "THICKNESSDIFFUSE_FIRST", CS%thickness_diffuse_first, & + "If true, do thickness diffusion or interface height smoothing before dynamics. "//& + "This is only used if THICKNESSDIFFUSE or APPLY_INTERFACE_FILTER is true.", & + default=.false., do_not_log=.not.(CS%thickness_diffuse.or.CS%interface_filter)) + call get_param(param_file, "MOM", "USE_POROUS_BARRIER", CS%use_porbar, & + "If true, use porous barrier to constrain the widths "//& + "and face areas at the edges of the grid cells. ", & + default=.true.) ! The default should be false after tests. + call get_param(param_file, "MOM", "BATHYMETRY_AT_VEL", bathy_at_vel, & + "If true, there are separate values for the basin depths "//& + "at velocity points. Otherwise the effects of topography "//& + "are entirely determined from thickness points.", & + default=.false.) + call get_param(param_file, "MOM", "USE_WAVES", CS%UseWaves, default=.false., & + do_not_log=.true.) + + call get_param(param_file, "MOM", "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, "MOM", "DEBUG_TRUNCATIONS", debug_truncations, & + "If true, calculate all diagnostics that are useful for "//& + "debugging truncations.", default=.false., debuggingParam=.true.) + + call get_param(param_file, "MOM", "DT", CS%dt, & + "The (baroclinic) dynamics time step. The time-step that "//& + "is actually used will be an integer fraction of the "//& + "forcing time-step (DT_FORCING in ocean-only mode or the "//& + "coupling timestep in coupled mode.)", units="s", scale=US%s_to_T, & + fail_if_missing=.true.) + call get_param(param_file, "MOM", "DT_THERM", CS%dt_therm, & + "The thermodynamic and tracer advection time step. "//& + "Ideally DT_THERM should be an integer multiple of DT "//& + "and less than the forcing or coupling time-step, unless "//& + "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& + "can be an integer multiple of the coupling timestep. By "//& + "default DT_THERM is set to DT.", & + units="s", scale=US%s_to_T, default=US%T_to_s*CS%dt) + call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", CS%thermo_spans_coupling, & + "If true, the MOM will take thermodynamic and tracer "//& + "timesteps that can be longer than the coupling timestep. "//& + "The actual thermodynamic timestep that is used in this "//& + "case is the largest integer multiple of the coupling "//& + "timestep that is less than or equal to DT_THERM.", default=.false.) + + if (bulkmixedlayer) then + CS%Hmix = -1.0 ; CS%Hmix_UV = -1.0 + else + call get_param(param_file, "MOM", "HMIX_SFC_PROP", Hmix_z, & + "If BULKMIXEDLAYER is false, HMIX_SFC_PROP is the depth "//& + "over which to average to find surface properties like "//& + "SST and SSS or density (but not surface velocities).", & + units="m", default=1.0, scale=US%m_to_Z) + call get_param(param_file, "MOM", "HMIX_UV_SFC_PROP", Hmix_UV_z, & + "If BULKMIXEDLAYER is false, HMIX_UV_SFC_PROP is the depth "//& + "over which to average to find surface flow properties, "//& + "SSU, SSV. A non-positive value indicates no averaging.", & + units="m", default=0.0, scale=US%m_to_Z) + endif + call get_param(param_file, "MOM", "HFREEZE", HFrz_z, & + "If HFREEZE > 0, melt potential will be computed. The actual depth "//& + "over which melt potential is computed will be min(HFREEZE, OBLD), "//& + "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), "//& + "melt potential will not be computed.", & + units="m", default=-1.0, scale=US%m_to_Z) + call get_param(param_file, "MOM", "INTERPOLATE_P_SURF", CS%interp_p_surf, & + "If true, linearly interpolate the surface pressure "//& + "over the coupling time step, using the specified value "//& + "at the end of the step.", default=.false.) + + if (CS%split) then + call get_param(param_file, "MOM", "DTBT", dtbt, units="s or nondim", default=-0.98) + default_val = US%T_to_s*CS%dt_therm ; if (dtbt > 0.0) default_val = -1.0 + CS%dtbt_reset_period = -1.0 + call get_param(param_file, "MOM", "DTBT_RESET_PERIOD", CS%dtbt_reset_period, & + "The period between recalculations of DTBT (if DTBT <= 0). "//& + "If DTBT_RESET_PERIOD is negative, DTBT is set based "//& + "only on information available at initialization. If 0, "//& + "DTBT will be set every dynamics time step. The default "//& + "is set by DT_THERM. This is only used if SPLIT is true.", & + units="s", default=default_val, scale=US%s_to_T, do_not_read=(dtbt > 0.0)) + endif + + call get_param(param_file, "MOM", "DT_OBC_SEG_UPDATE_OBGC", CS%dt_obc_seg_period, & + "The time between OBC segment data updates for OBGC tracers. "//& + "This must be an integer multiple of DT and DT_THERM. "//& + "The default is set to DT.", & + units="s", default=US%T_to_s*CS%dt, scale=US%s_to_T, do_not_log=.not.associated(CS%OBC)) + + ! This is here in case these values are used inappropriately. + use_frazil = .false. ; bound_salinity = .false. ; use_p_surf_in_EOS = .false. + CS%tv%P_Ref = 2.0e7*US%Pa_to_RL2_T2 + if (use_temperature) then + call get_param(param_file, "MOM", "FRAZIL", use_frazil, & + "If true, water freezes if it gets too cold, and the "//& + "accumulated heat deficit is returned in the "//& + "surface state. FRAZIL is only used if "//& + "ENABLE_THERMODYNAMICS is true.", default=.false.) + call get_param(param_file, "MOM", "DO_GEOTHERMAL", use_geothermal, & + "If true, apply geothermal heating.", default=.false.) + call get_param(param_file, "MOM", "BOUND_SALINITY", bound_salinity, & + "If true, limit salinity to being positive. (The sea-ice "//& + "model may ask for more salt than is available and "//& + "drive the salinity negative otherwise.)", default=.false.) + call get_param(param_file, "MOM", "MIN_SALINITY", CS%tv%min_salinity, & + "The minimum value of salinity when BOUND_SALINITY=True.", & + units="PPT", default=0.0, scale=US%ppt_to_S, do_not_log=.not.bound_salinity) + call get_param(param_file, "MOM", "SALINITY_UNDERFLOW", salin_underflow, & + "A tiny value of salinity below which the it is set to 0. For reference, "//& + "one molecule of salt per square meter of ocean is of order 1e-29 ppt.", & + units="PPT", default=0.0, scale=US%ppt_to_S) + call get_param(param_file, "MOM", "TEMPERATURE_UNDERFLOW", temp_underflow, & + "A tiny magnitude of temperatures below which they are set to 0.", & + units="degC", default=0.0, scale=US%degC_to_C) + call get_param(param_file, "MOM", "C_P", CS%tv%C_p, & + "The heat capacity of sea water, approximated as a constant. "//& + "This is only used if ENABLE_THERMODYNAMICS is true. The default "//& + "value is from the TEOS-10 definition of conservative temperature.", & + units="J kg-1 K-1", default=3991.86795711963, scale=US%J_kg_to_Q*US%C_to_degC) + call get_param(param_file, "MOM", "USE_PSURF_IN_EOS", use_p_surf_in_EOS, & + "If true, always include the surface pressure contributions "//& + "in equation of state calculations.", default=.true.) + endif + if (use_EOS) call get_param(param_file, "MOM", "P_REF", CS%tv%P_Ref, & + "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%Pa_to_RL2_T2) + + if (bulkmixedlayer) then + call get_param(param_file, "MOM", "NKML", nkml, & + "The number of sublayers within the mixed layer if "//& + "BULKMIXEDLAYER is true.", units="nondim", default=2) + call get_param(param_file, "MOM", "NKBL", nkbl, & + "The number of layers that are used as variable density buffer "//& + "layers if BULKMIXEDLAYER is true.", units="nondim", default=2) + endif + + call get_param(param_file, "MOM", "GLOBAL_INDEXING", global_indexing, & + "If true, use a global lateral indexing convention, so "//& + "that corresponding points on different processors have "//& + "the same index. This does not work with static memory.", & + default=.false., layoutParam=.true.) +#ifdef STATIC_MEMORY_ + if (global_indexing) call MOM_error(FATAL, "initialize_MOM: "//& + "GLOBAL_INDEXING can not be true with STATIC_MEMORY.") +#endif + call get_param(param_file, "MOM", "FIRST_DIRECTION", first_direction, & + "An integer that indicates which direction goes first "//& + "in parts of the code that use directionally split "//& + "updates, with even numbers (or 0) used for x- first "//& + "and odd numbers used for y-first.", default=0) + call get_param(param_file, "MOM", "ALTERNATE_FIRST_DIRECTION", CS%alternate_first_direction, & + "If true, after every dynamic timestep alternate whether the x- or y- "//& + "direction updates occur first in directionally split parts of the calculation. "//& + "If this is true, FIRST_DIRECTION applies at the start of a new run or if "//& + "the next first direction can not be found in the restart file.", default=.false.) + call get_param(param_file, "MOM", "CHECK_BAD_SURFACE_VALS", CS%check_bad_sfc_vals, & + "If true, check the surface state for ridiculous values.", & + default=.false.) + if (CS%check_bad_sfc_vals) then + call get_param(param_file, "MOM", "BAD_VAL_SSH_MAX", CS%bad_val_ssh_max, & + "The value of SSH above which a bad value message is "//& + "triggered, if CHECK_BAD_SURFACE_VALS is true.", & + units="m", default=20.0, scale=US%m_to_Z) + call get_param(param_file, "MOM", "BAD_VAL_SSS_MAX", CS%bad_val_sss_max, & + "The value of SSS above which a bad value message is "//& + "triggered, if CHECK_BAD_SURFACE_VALS is true.", & + units="PPT", default=45.0, scale=US%ppt_to_S) + call get_param(param_file, "MOM", "BAD_VAL_SST_MAX", CS%bad_val_sst_max, & + "The value of SST above which a bad value message is "//& + "triggered, if CHECK_BAD_SURFACE_VALS is true.", & + units="deg C", default=45.0, scale=US%degC_to_C) + call get_param(param_file, "MOM", "BAD_VAL_SST_MIN", CS%bad_val_sst_min, & + "The value of SST below which a bad value message is "//& + "triggered, if CHECK_BAD_SURFACE_VALS is true.", & + units="deg C", default=-2.1, scale=US%degC_to_C) + call get_param(param_file, "MOM", "BAD_VAL_COLUMN_THICKNESS", CS%bad_val_col_thick, & + "The value of column thickness below which a bad value message is "//& + "triggered, if CHECK_BAD_SURFACE_VALS is true.", & + units="m", default=0.0, scale=US%m_to_Z) + endif + call get_param(param_file, "MOM", "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, "MOM", "SURFACE_ANSWER_DATE", CS%answer_date, & + "The vintage of the expressions for the surface properties. Values below "//& + "20190101 recover the answers from the end of 2018, while higher values "//& + "use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=non_Bous) + if (non_Bous) CS%answer_date = 99991231 + + call get_param(param_file, "MOM", "USE_DIABATIC_TIME_BUG", CS%use_diabatic_time_bug, & + "If true, uses the wrong calendar time for diabatic processes, as was "//& + "done in MOM6 versions prior to February 2018. This is not recommended.", & + default=.false.) + + call get_param(param_file, "MOM", "SAVE_INITIAL_CONDS", save_IC, & + "If true, write the initial conditions to a file given "//& + "by IC_OUTPUT_FILE.", default=.false.) + call get_param(param_file, "MOM", "IC_OUTPUT_FILE", CS%IC_file, & + "The file into which to write the initial conditions.", & + default="MOM_IC") + call get_param(param_file, "MOM", "WRITE_GEOM", write_geom, & + "If =0, never write the geometry and vertical grid files. "//& + "If =1, write the geometry and vertical grid files only for "//& + "a new simulation. If =2, always write the geometry and "//& + "vertical grid files. Other values are invalid.", default=1) + if (write_geom<0 .or. write_geom>2) call MOM_error(FATAL,"MOM: "//& + "WRITE_GEOM must be equal to 0, 1 or 2.") + call get_param(param_file, "MOM", "USE_DBCLIENT", CS%use_dbclient, & + "If true, initialize a client to a remote database that can "//& + "be used for online analysis and machine-learning inference.",& + default=.false.) + + ! Check for inconsistent parameter settings. + if (CS%use_ALE_algorithm .and. bulkmixedlayer) call MOM_error(FATAL, & + "MOM: BULKMIXEDLAYER can not currently be used with the ALE algorithm.") + if (CS%use_ALE_algorithm .and. .not.use_temperature) call MOM_error(FATAL, & + "MOM: At this time, USE_EOS should be True when using the ALE algorithm.") + if (CS%adiabatic .and. use_temperature) call MOM_error(WARNING, & + "MOM: ADIABATIC and ENABLE_THERMODYNAMICS both defined is usually unwise.") + if (use_EOS .and. .not.use_temperature) call MOM_error(FATAL, & + "MOM: ENABLE_THERMODYNAMICS must be defined to use USE_EOS.") + if (CS%adiabatic .and. bulkmixedlayer) call MOM_error(FATAL, & + "MOM: ADIABATIC and BULKMIXEDLAYER can not both be defined.") + if (bulkmixedlayer .and. .not.use_EOS) call MOM_error(FATAL, & + "initialize_MOM: A bulk mixed layer can only be used with T & S as "//& + "state variables. Add USE_EOS = True to MOM_input.") + + use_ice_shelf = .false. + if (present(ice_shelf_CSp)) then + call get_param(param_file, "MOM", "ICE_SHELF", use_ice_shelf, & + "If true, enables the ice shelf model.", default=.false.) + endif + + call get_param(param_file, "MOM", "USE_PARTICLES", CS%use_particles, & + "If true, use the particles package.", default=.false.) + call get_param(param_file, "MOM", "USE_UH_PARTICLES", CS%use_uh_particles, & + "If true, use the uh velocity in the particles package.",default=.false.) + CS%ensemble_ocean=.false. + call get_param(param_file, "MOM", "ENSEMBLE_OCEAN", CS%ensemble_ocean, & + "If False, The model is being run in serial mode as a single realization. "//& + "If True, The current model realization is part of a larger ensemble "//& + "and at the end of step MOM, we will perform a gather of the ensemble "//& + "members for statistical evaluation and/or data assimilation.", default=.false.) + + call callTree_waypoint("MOM parameters read (initialize_MOM)") + + call get_param(param_file, "MOM", "HOMOGENIZE_FORCINGS", CS%homogenize_forcings, & + "If True, homogenize the forces and fluxes.", default=.false.) + call get_param(param_file, "MOM", "UPDATE_USTAR",CS%update_ustar, & + "If True, update ustar from homogenized tau when using the "//& + "HOMOGENIZE_FORCINGS option. Note that this will not work "//& + "with a non-zero gustiness factor.", default=.false., & + do_not_log=.not.CS%homogenize_forcings) + + ! Grid rotation test + call get_param(param_file, "MOM", "ROTATE_INDEX", CS%rotate_index, & + "Enable rotation of the horizontal indices.", default=.false., & + debuggingParam=.true.) + if (CS%rotate_index) then + ! TODO: Index rotation currently only works when index rotation does not + ! change the MPI rank of each domain. Resolving this will require a + ! modification to FMS PE assignment. + ! For now, we only permit single-core runs. + + if (num_PEs() /= 1) & + call MOM_error(FATAL, "Index rotation is only supported on one PE.") + + ! Alternate_first_direction is not permitted with index rotation. + ! This feature can be added later in the future if needed. + if (CS%alternate_first_direction) & + call MOM_error(FATAL, "Alternating_first_direction is not compatible with index rotation.") + + call get_param(param_file, "MOM", "INDEX_TURNS", turns, & + "Number of counterclockwise quarter-turn index rotations.", & + default=1, debuggingParam=.true.) + endif + + ! Set up the model domain and grids. +#ifdef SYMMETRIC_MEMORY_ + symmetric = .true. +#else + symmetric = .false. +#endif + G_in => CS%G_in +#ifdef STATIC_MEMORY_ + call MOM_domains_init(G_in%domain, param_file, symmetric=symmetric, & + static_memory=.true., NIHALO=NIHALO_, NJHALO=NJHALO_, & + NIGLOBAL=NIGLOBAL_, NJGLOBAL=NJGLOBAL_, NIPROC=NIPROC_, & + NJPROC=NJPROC_) +#else + call MOM_domains_init(G_in%domain, param_file, symmetric=symmetric, & + domain_name="MOM_in") +#endif + + ! Copy input grid (G_in) domain to active grid G + ! Swap axes for quarter and 3-quarter turns + if (CS%rotate_index) then + allocate(CS%G) + call clone_MOM_domain(G_in%Domain, CS%G%Domain, turns=turns, domain_name="MOM_rot") + else + CS%G => G_in + endif + + ! TODO: It is unlikely that test_grid_copy and rotate_index would work at the + ! same time. It may be possible to enable both but for now we prevent it. + if (test_grid_copy .and. CS%rotate_index) & + call MOM_error(FATAL, "Grid cannot be copied during index rotation.") + + if (test_grid_copy) then ; allocate(G) + else ; G => CS%G ; endif + + call callTree_waypoint("domains initialized (initialize_MOM)") + + call MOM_debugging_init(param_file) + call diag_mediator_infrastructure_init() + call MOM_io_init(param_file) + + ! Create HI and dG on the input index map. + call hor_index_init(G_in%Domain, HI_in, param_file, & + local_indexing=.not.global_indexing) + call create_dyn_horgrid(dG_in, HI_in, bathymetry_at_vel=bathy_at_vel) + call clone_MOM_domain(G_in%Domain, dG_in%Domain) + ! Also allocate the input ocean_grid_type type at this point based on the same information. + call MOM_grid_init(G_in, param_file, US, HI_in, bathymetry_at_vel=bathy_at_vel) + + ! Allocate initialize time-invariant MOM variables. + call MOM_initialize_fixed(dG_in, US, OBC_in, param_file, .false., dirs%output_directory) + + ! Copy the grid metrics and bathymetry to the ocean_grid_type + call copy_dyngrid_to_MOM_grid(dG_in, G_in, US) + + call callTree_waypoint("returned from MOM_initialize_fixed() (initialize_MOM)") + + call verticalGridInit( param_file, CS%GV, US ) + GV => CS%GV + + ! Now that the vertical grid has been initialized, rescale parameters that depend on factors + ! that are set with the vertical grid to their desired units. This added rescaling step would + ! be unnecessary if the vertical grid were initialized earlier in this routine. + if (.not.bulkmixedlayer) then + CS%Hmix = (US%Z_to_m * GV%m_to_H) * Hmix_z + CS%Hmix_UV = (US%Z_to_m * GV%m_to_H) * Hmix_UV_z + endif + CS%HFrz = (US%Z_to_m * GV%m_to_H) * HFrz_z + + ! Shift from using the temporary dynamic grid type to using the final (potentially static) + ! and properly rotated ocean-specific grid type and horizontal index type. + if (CS%rotate_index) then + allocate(HI) + call rotate_hor_index(HI_in, turns, HI) + ! NOTE: If indices are rotated, then G and G_in must both be initialized separately, and + ! the dynamic grid must be created to handle the grid rotation. G%domain has already been + ! initialized above. + call MOM_grid_init(G, param_file, US, HI, bathymetry_at_vel=bathy_at_vel) + call create_dyn_horgrid(dG, HI, bathymetry_at_vel=bathy_at_vel) + call clone_MOM_domain(G%Domain, dG%Domain) + call rotate_dyn_horgrid(dG_in, dG, US, turns) + call copy_dyngrid_to_MOM_grid(dG, G, US) + + if (associated(OBC_in)) then + ! TODO: General OBC index rotations is not yet supported. + if (modulo(turns, 4) /= 1) & + call MOM_error(FATAL, "OBC index rotation of 180 and 270 degrees is not yet supported.") + allocate(CS%OBC) + call rotate_OBC_config(OBC_in, dG_in, CS%OBC, dG, turns) + endif + + call destroy_dyn_horgrid(dG) + else + ! If not rotated, then G_in and G are the same grid. + HI => HI_in + G => G_in + CS%OBC => OBC_in + endif + ! dG_in is retained for now so that it can be used with write_ocean_geometry_file() below. + + if (is_root_PE()) call check_MOM6_scaling_factors(CS%GV, US) + + call callTree_waypoint("grids initialized (initialize_MOM)") + + call MOM_timing_init(CS) + + call tracer_registry_init(param_file, CS%tracer_Reg) + + ! Allocate and initialize space for the primary time-varying MOM variables. + is = HI%isc ; ie = HI%iec ; js = HI%jsc ; je = HI%jec ; nz = GV%ke + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed + IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB + ALLOC_(CS%u(IsdB:IedB,jsd:jed,nz)) ; CS%u(:,:,:) = 0.0 + ALLOC_(CS%v(isd:ied,JsdB:JedB,nz)) ; CS%v(:,:,:) = 0.0 + ALLOC_(CS%h(isd:ied,jsd:jed,nz)) ; CS%h(:,:,:) = GV%Angstrom_H + ALLOC_(CS%uh(IsdB:IedB,jsd:jed,nz)) ; CS%uh(:,:,:) = 0.0 + ALLOC_(CS%vh(isd:ied,JsdB:JedB,nz)) ; CS%vh(:,:,:) = 0.0 + if (use_temperature) then + ALLOC_(CS%T(isd:ied,jsd:jed,nz)) ; CS%T(:,:,:) = 0.0 + ALLOC_(CS%S(isd:ied,jsd:jed,nz)) ; CS%S(:,:,:) = 0.0 + CS%tv%T => CS%T ; CS%tv%S => CS%S + if (CS%tv%T_is_conT) then + vd_T = var_desc(name="contemp", units="Celsius", longname="Conservative Temperature", & + cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & + conversion=US%Q_to_J_kg*CS%tv%C_p) + else + vd_T = var_desc(name="temp", units="degC", longname="Potential Temperature", & + cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & + conversion=US%Q_to_J_kg*CS%tv%C_p) + endif + if (CS%tv%S_is_absS) then + vd_S = var_desc(name="abssalt", units="g kg-1", longname="Absolute Salinity", & + cmor_field_name="so", cmor_longname="Sea Water Salinity", & + conversion=0.001*US%S_to_ppt) + else + vd_S = var_desc(name="salt", units="psu", longname="Salinity", & + cmor_field_name="so", cmor_longname="Sea Water Salinity", & + conversion=0.001*US%S_to_ppt) + endif + + if (advect_TS) then + S_flux_units = get_tr_flux_units(GV, "psu") ! Could change to "kg m-2 s-1"? + conv2watt = GV%H_to_kg_m2 * US%Q_to_J_kg*CS%tv%C_p + if (GV%Boussinesq) then + conv2salt = US%S_to_ppt*GV%H_to_m ! Could change to US%S_to_ppt*GV%H_to_kg_m2 * 0.001? + else + conv2salt = US%S_to_ppt*GV%H_to_kg_m2 + endif + call register_tracer(CS%tv%T, CS%tracer_Reg, param_file, HI, GV, & + tr_desc=vd_T, registry_diags=.true., conc_scale=US%C_to_degC, & + flux_nameroot='T', flux_units='W', flux_longname='Heat', & + net_surfflux_name='KPP_QminusSW', NLT_budget_name='KPP_NLT_temp_budget', & + net_surfflux_longname='Net temperature flux ignoring short-wave, as used by [CVMix] KPP', & + flux_scale=conv2watt, convergence_units='W m-2', & + convergence_scale=conv2watt, CMOR_tendprefix="opottemp", & + diag_form=2, underflow_conc=temp_underflow, Tr_out=CS%tv%tr_T) + call register_tracer(CS%tv%S, CS%tracer_Reg, param_file, HI, GV, & + tr_desc=vd_S, registry_diags=.true., conc_scale=US%S_to_ppt, & + flux_nameroot='S', flux_units=S_flux_units, flux_longname='Salt', & + net_surfflux_name='KPP_netSalt', NLT_budget_name='KPP_NLT_saln_budget', & + flux_scale=conv2salt, convergence_units='kg m-2 s-1', & + convergence_scale=0.001*US%S_to_ppt*GV%H_to_kg_m2, CMOR_tendprefix="osalt", & + diag_form=2, underflow_conc=salin_underflow, Tr_out=CS%tv%tr_S) + endif + endif + + if (use_p_surf_in_EOS) allocate(CS%tv%p_surf(isd:ied,jsd:jed), source=0.0) + if (use_frazil) allocate(CS%tv%frazil(isd:ied,jsd:jed), source=0.0) + if (bound_salinity) allocate(CS%tv%salt_deficit(isd:ied,jsd:jed), source=0.0) + + if (bulkmixedlayer .or. use_temperature) allocate(CS%Hml(isd:ied,jsd:jed), source=0.0) + + if (bulkmixedlayer) then + GV%nkml = nkml ; GV%nk_rho_varies = nkml + nkbl + else + GV%nkml = 0 ; GV%nk_rho_varies = 0 + endif + if (CS%use_ALE_algorithm) then + call get_param(param_file, "MOM", "NK_RHO_VARIES", GV%nk_rho_varies, default=0) ! Will default to nz later... -AJA + endif + + ALLOC_(CS%uhtr(IsdB:IedB,jsd:jed,nz)) ; CS%uhtr(:,:,:) = 0.0 + ALLOC_(CS%vhtr(isd:ied,JsdB:JedB,nz)) ; CS%vhtr(:,:,:) = 0.0 + CS%t_dyn_rel_adv = 0.0 ; CS%t_dyn_rel_thermo = 0.0 ; CS%t_dyn_rel_diag = 0.0 + CS%n_dyn_steps_in_adv = 0 + + if (debug_truncations) then + allocate(CS%u_prev(IsdB:IedB,jsd:jed,nz), source=0.0) + allocate(CS%v_prev(isd:ied,JsdB:JedB,nz), source=0.0) + MOM_internal_state%u_prev => CS%u_prev + MOM_internal_state%v_prev => CS%v_prev + call safe_alloc_ptr(CS%ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(CS%ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + if (.not.CS%adiabatic) then + call safe_alloc_ptr(CS%ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(CS%ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) + endif + endif + + MOM_internal_state%u => CS%u ; MOM_internal_state%v => CS%v + MOM_internal_state%h => CS%h + MOM_internal_state%uh => CS%uh ; MOM_internal_state%vh => CS%vh + if (use_temperature) then + MOM_internal_state%T => CS%T ; MOM_internal_state%S => CS%S + endif + + CS%CDp%uh => CS%uh ; CS%CDp%vh => CS%vh + + if (CS%interp_p_surf) allocate(CS%p_surf_prev(isd:ied,jsd:jed), source=0.0) + + ALLOC_(CS%ssh_rint(isd:ied,jsd:jed)) ; CS%ssh_rint(:,:) = 0.0 + ALLOC_(CS%ave_ssh_ibc(isd:ied,jsd:jed)) ; CS%ave_ssh_ibc(:,:) = 0.0 + ALLOC_(CS%eta_av_bc(isd:ied,jsd:jed)) ; CS%eta_av_bc(:,:) = 0.0 ! -G%Z_ref + CS%time_in_cycle = 0.0 ; CS%time_in_thermo_cycle = 0.0 + + !allocate porous topography variables + allocate(CS%pbv%por_face_areaU(IsdB:IedB,jsd:jed,nz)) ; CS%pbv%por_face_areaU(:,:,:) = 1.0 + allocate(CS%pbv%por_face_areaV(isd:ied,JsdB:JedB,nz)) ; CS%pbv%por_face_areaV(:,:,:) = 1.0 + allocate(CS%pbv%por_layer_widthU(IsdB:IedB,jsd:jed,nz+1)) ; CS%pbv%por_layer_widthU(:,:,:) = 1.0 + allocate(CS%pbv%por_layer_widthV(isd:ied,JsdB:JedB,nz+1)) ; CS%pbv%por_layer_widthV(:,:,:) = 1.0 + + ! Use the Wright equation of state by default, unless otherwise specified + ! Note: this line and the following block ought to be in a separate + ! initialization routine for tv. + if (use_EOS) then + allocate(CS%tv%eqn_of_state) + call EOS_init(param_file, CS%tv%eqn_of_state, US) + endif + if (use_temperature) then + allocate(CS%tv%TempxPmE(isd:ied,jsd:jed), source=0.0) + if (use_geothermal) then + allocate(CS%tv%internal_heat(isd:ied,jsd:jed), source=0.0) + endif + endif + call callTree_waypoint("state variables allocated (initialize_MOM)") + + ! Set the fields that are needed for bitwise identical restarting + ! the time stepping scheme. + call restart_init(param_file, CS%restart_CS) + restart_CSp => CS%restart_CS + + call set_restart_fields(GV, US, param_file, CS, restart_CSp) + if (CS%split .and. CS%use_alt_split) then + call register_restarts_dyn_split_RK2b(HI, GV, US, param_file, & + CS%dyn_split_RK2b_CSp, restart_CSp, CS%uh, CS%vh) + elseif (CS%split) then + call register_restarts_dyn_split_RK2(HI, GV, US, param_file, & + CS%dyn_split_RK2_CSp, restart_CSp, CS%uh, CS%vh) + elseif (CS%use_RK2) then + call register_restarts_dyn_unsplit_RK2(HI, GV, param_file, & + CS%dyn_unsplit_RK2_CSp) + else + call register_restarts_dyn_unsplit(HI, GV, param_file, & + CS%dyn_unsplit_CSp) + endif + + ! This subroutine calls user-specified tracer registration routines. + ! Additional calls can be added to MOM_tracer_flow_control.F90. + call call_tracer_register(G, GV, US, param_file, CS%tracer_flow_CSp, & + CS%tracer_Reg, restart_CSp) + + call MEKE_alloc_register_restart(HI, US, param_file, CS%MEKE, restart_CSp) + call set_visc_register_restarts(HI, G, GV, US, param_file, CS%visc, restart_CSp, use_ice_shelf) + call mixedlayer_restrat_register_restarts(HI, GV, US, param_file, & + CS%mixedlayer_restrat_CSp, restart_CSp) + + if (CS%rotate_index .and. associated(OBC_in) .and. use_temperature) then + ! NOTE: register_temp_salt_segments includes allocation of tracer fields + ! along segments. Bit reproducibility requires that MOM_initialize_state + ! be called on the input index map, so we must setup both OBC and OBC_in. + ! + ! XXX: This call on OBC_in allocates the tracer fields on the unrotated + ! grid, but also incorrectly stores a pointer to a tracer_type for the + ! rotated registry (e.g. segment%tr_reg%Tr(n)%Tr) from CS%tracer_reg. + ! + ! While incorrect and potentially dangerous, it does not seem that this + ! pointer is used during initialization, so we leave it for now. + call register_temp_salt_segments(GV, US, OBC_in, CS%tracer_Reg, param_file) + endif + + if (associated(CS%OBC)) then + ! Set up remaining information about open boundary conditions that is needed for OBCs. + call call_OBC_register(G, GV, US, param_file, CS%update_OBC_CSp, CS%OBC, CS%tracer_Reg) + !### Package specific changes to OBCs need to go here? + + ! This is the equivalent to 2 calls to register_segment_tracer (per segment), which + ! could occur with the call to update_OBC_data or after the main initialization. + if (use_temperature) & + call register_temp_salt_segments(GV, US, CS%OBC, CS%tracer_Reg, param_file) + !This is the equivalent call to register_temp_salt_segments for external tracers with OBC + call call_tracer_register_obc_segments(GV, param_file, CS%tracer_flow_CSp, CS%tracer_Reg, CS%OBC) + + ! This needs the number of tracers and to have called any code that sets whether + ! reservoirs are used. + call open_boundary_register_restarts(HI, GV, US, CS%OBC, CS%tracer_Reg, & + param_file, restart_CSp, use_temperature) + endif + + if (present(waves_CSp)) then + call waves_register_restarts(waves_CSp, HI, GV, US, param_file, restart_CSp) + endif + + if (use_temperature) then + call stoch_EOS_register_restarts(HI, param_file, CS%stoch_eos_CS, restart_CSp) + endif + + if (.not. CS%adiabatic) then + call register_diabatic_restarts(G, US, param_file, CS%int_tide_CSp, restart_CSp) + endif + + call callTree_waypoint("restart registration complete (initialize_MOM)") + call restart_registry_lock(restart_CSp) + + ! Write out all of the grid data used by this run. + new_sim = determine_is_new_run(dirs%input_filename, dirs%restart_input_dir, G_in, restart_CSp) + write_geom_files = ((write_geom==2) .or. ((write_geom==1) .and. new_sim)) + if (write_geom_files) call write_ocean_geometry_file(dG_in, param_file, dirs%output_directory, US=US) + + call destroy_dyn_horgrid(dG_in) + + ! Initialize dynamically evolving fields, perhaps from restart files. + call cpu_clock_begin(id_clock_MOM_init) + call MOM_initialize_coord(GV, US, param_file, CS%tv, G%max_depth) + call callTree_waypoint("returned from MOM_initialize_coord() (initialize_MOM)") + + if (CS%use_ALE_algorithm) then + call ALE_init(param_file, GV, US, G%max_depth, CS%ALE_CSp) + call callTree_waypoint("returned from ALE_init() (initialize_MOM)") + endif + + ! Set a few remaining fields that are specific to the ocean grid type. + if (CS%rotate_index) then + call set_first_direction(G, modulo(first_direction + turns, 2)) + else + call set_first_direction(G, modulo(first_direction, 2)) + endif + ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. + if (CS%debug .or. G%symmetric) then + call clone_MOM_domain(G%Domain, G%Domain_aux, symmetric=.false.) + else ; G%Domain_aux => G%Domain ; endif + ! Copy common variables from the vertical grid to the horizontal grid. + ! Consider removing this later? + G%ke = GV%ke + + if (CS%rotate_index) then + G_in%ke = GV%ke + + allocate(u_in(G_in%IsdB:G_in%IedB, G_in%jsd:G_in%jed, nz), source=0.0) + allocate(v_in(G_in%isd:G_in%ied, G_in%JsdB:G_in%JedB, nz), source=0.0) + allocate(h_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz), source=GV%Angstrom_H) + + if (use_temperature) then + allocate(T_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz), source=0.0) + allocate(S_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz), source=0.0) + + CS%tv%T => T_in + CS%tv%S => S_in + endif + + if (use_ice_shelf) then + ! These arrays are not initialized in most solo cases, but are needed + ! when using an ice shelf. Passing the ice shelf diagnostics CS from MOM + ! for legacy reasons. The actual ice shelf diag CS is internal to the ice shelf + call initialize_ice_shelf(param_file, G_in, Time, ice_shelf_CSp, diag_ptr, & + Time_init, dirs%output_directory) + allocate(frac_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) + allocate(mass_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) + allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) + allocate(CS%mass_shelf(isd:ied, jsd:jed), source=0.0) + call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h, CS%mass_shelf) + ! MOM_initialize_state is using the unrotated metric + call rotate_array(CS%frac_shelf_h, -turns, frac_shelf_in) + call rotate_array(CS%mass_shelf, -turns, mass_shelf_in) + call MOM_initialize_state(u_in, v_in, h_in, CS%tv, Time, G_in, GV, US, & + param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & + sponge_in_CSp, ALE_sponge_in_CSp, oda_incupd_in_CSp, OBC_in, Time_in, & + frac_shelf_h=frac_shelf_in, mass_shelf = mass_shelf_in) + else + call MOM_initialize_state(u_in, v_in, h_in, CS%tv, Time, G_in, GV, US, & + param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & + sponge_in_CSp, ALE_sponge_in_CSp, oda_incupd_in_CSp, OBC_in, Time_in) + endif + + if (use_temperature) then + CS%tv%T => CS%T + CS%tv%S => CS%S + endif + + ! Reset the first direction if it was found in a restart file + if (CS%first_dir_restart > -1.0) then + call set_first_direction(G, modulo(NINT(CS%first_dir_restart) + turns, 2)) + else + CS%first_dir_restart = real(modulo(first_direction, 2)) + endif + + call rotate_initial_state(u_in, v_in, h_in, T_in, S_in, use_temperature, & + turns, CS%u, CS%v, CS%h, CS%T, CS%S) + + if (associated(sponge_in_CSp)) then + ! TODO: Implementation and testing of non-ALE sponge rotation + call MOM_error(FATAL, "Index rotation of non-ALE sponge is not yet implemented.") + endif + + if (associated(ALE_sponge_in_CSp)) then + call rotate_ALE_sponge(ALE_sponge_in_CSp, G_in, CS%ALE_sponge_CSp, G, GV, US, turns, param_file) + call update_ALE_sponge_field(CS%ALE_sponge_CSp, T_in, G, GV, CS%T) + call update_ALE_sponge_field(CS%ALE_sponge_CSp, S_in, G, GV, CS%S) + endif + + if (associated(OBC_in)) & + call rotate_OBC_init(OBC_in, G, GV, US, param_file, CS%tv, restart_CSp, CS%OBC) + + deallocate(u_in) + deallocate(v_in) + deallocate(h_in) + if (use_temperature) then + deallocate(T_in) + deallocate(S_in) + endif + if (use_ice_shelf) & + deallocate(frac_shelf_in,mass_shelf_in) + else + if (use_ice_shelf) then + call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, Time_init, dirs%output_directory) + allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) + allocate(CS%mass_shelf(isd:ied, jsd:jed), source=0.0) + call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h, CS%mass_shelf) + call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, & + param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & + CS%sponge_CSp, CS%ALE_sponge_CSp,CS%oda_incupd_CSp, CS%OBC, Time_in, & + frac_shelf_h=CS%frac_shelf_h, mass_shelf=CS%mass_shelf) + else + call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, & + param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & + CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%OBC, Time_in) + endif + + ! Reset the first direction if it was found in a restart file. + if (CS%first_dir_restart > -1.0) then + call set_first_direction(G, NINT(CS%first_dir_restart)) + else + CS%first_dir_restart = real(modulo(first_direction, 2)) + endif + endif + + ! Allocate any derived densities or other equation of state derived fields. + if (.not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then + allocate(CS%tv%SpV_avg(isd:ied,jsd:jed,nz), source=0.0) + CS%tv%valid_SpV_halo = -1 ! This array does not yet have any valid data. + endif + + if (use_ice_shelf .and. CS%debug) then + call hchksum(CS%frac_shelf_h, "MOM:frac_shelf_h", G%HI, haloshift=0) + call hchksum(CS%mass_shelf, "MOM:mass_shelf", G%HI, haloshift=0,scale=US%RZ_to_kg_m2) + endif + + call cpu_clock_end(id_clock_MOM_init) + call callTree_waypoint("returned from MOM_initialize_state() (initialize_MOM)") + + ! From this point, there may be pointers being set, so the final grid type + ! that will persist throughout the run has to be used. + + if (test_grid_copy) then + ! Copy the data from the temporary grid to the dyn_hor_grid to CS%G. + call create_dyn_horgrid(test_dG, G%HI) + call clone_MOM_domain(G%Domain, test_dG%Domain) + + call clone_MOM_domain(G%Domain, CS%G%Domain) + call MOM_grid_init(CS%G, param_file, US) + + call copy_MOM_grid_to_dyngrid(G, test_dG, US) + call copy_dyngrid_to_MOM_grid(test_dG, CS%G, US) + + call destroy_dyn_horgrid(test_dG) + call MOM_grid_end(G) ; deallocate(G) + + G => CS%G + if (CS%debug .or. CS%G%symmetric) then + call clone_MOM_domain(CS%G%Domain, CS%G%Domain_aux, symmetric=.false.) + else ; CS%G%Domain_aux => CS%G%Domain ; endif + G%ke = GV%ke + endif + + ! At this point, all user-modified initialization code has been called. The + ! remainder of this subroutine is controlled by the parameters that have + ! have already been set. + + if (ALE_remap_init_conds(CS%ALE_CSp) .and. .not. query_initialized(CS%h,"h",restart_CSp)) then + ! This block is controlled by the ALE parameter REMAP_AFTER_INITIALIZATION. + ! \todo This block exists for legacy reasons and we should phase it out of + ! all examples. !### + if (CS%debug) then + call uvchksum("Pre ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1) + call hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_MKS) + endif + call callTree_waypoint("Calling adjustGridForIntegrity() to remap initial conditions (initialize_MOM)") + call adjustGridForIntegrity(CS%ALE_CSp, G, GV, CS%h ) + if (allocated(CS%tv%SpV_avg)) call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=1) + call pre_ALE_adjustments(G, GV, US, CS%h, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%u, CS%v) + + call callTree_waypoint("Calling ALE_regrid() to remap initial conditions (initialize_MOM)") + allocate(h_new(isd:ied, jsd:jed, nz), source=0.0) + allocate(dzRegrid(isd:ied, jsd:jed, nz+1), source=0.0) + allocate(PCM_cell(isd:ied, jsd:jed, nz), source=.false.) + allocate(h_old_u(IsdB:IedB, jsd:jed, nz), source=0.0) + allocate(h_new_u(IsdB:IedB, jsd:jed, nz), source=0.0) + allocate(h_old_v(isd:ied, JsdB:JedB, nz), source=0.0) + allocate(h_new_v(isd:ied, JsdB:JedB, nz), source=0.0) + if (use_ice_shelf) then + call ALE_regrid(G, GV, US, CS%h, h_new, dzRegrid, CS%tv, CS%ALE_CSp, CS%frac_shelf_h, PCM_cell) + else + call ALE_regrid(G, GV, US, CS%h, h_new, dzRegrid, CS%tv, CS%ALE_CSp, PCM_cell=PCM_cell) + endif + + if (callTree_showQuery()) call callTree_waypoint("new grid generated") + ! Remap all variables from the old grid h onto the new grid h_new + call ALE_remap_tracers(CS%ALE_CSp, G, GV, CS%h, h_new, CS%tracer_Reg, CS%debug, PCM_cell=PCM_cell) + + ! Determine the old and new grid thicknesses at velocity points. + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, CS%h, h_old_u, h_old_v, CS%OBC, debug=CS%debug) + if (CS%remap_uv_using_old_alg) then + call ALE_remap_set_h_vel_via_dz(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, CS%h, dzRegrid, CS%debug) + else + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, debug=CS%debug) + endif + + ! Remap the velocity components. + call ALE_remap_velocities(CS%ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%u, CS%v, CS%debug) + + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + + ! Replace the old grid with new one. All remapping must be done at this point. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + CS%h(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + deallocate(h_new, dzRegrid, PCM_cell, h_old_u, h_new_u, h_old_v, h_new_v) + + call cpu_clock_begin(id_clock_pass_init) + call create_group_pass(tmp_pass_uv_T_S_h, CS%u, CS%v, G%Domain) + if (use_temperature) then + call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%T, G%Domain) + call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%S, G%Domain) + endif + call create_group_pass(tmp_pass_uv_T_S_h, CS%h, G%Domain) + call do_group_pass(tmp_pass_uv_T_S_h, G%Domain) + call cpu_clock_end(id_clock_pass_init) + + if (CS%debug) then + call uvchksum("Post ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1) + call hchksum(CS%h, "Post ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_MKS) + if (use_temperature) then + call hchksum(CS%tv%T, "Post ALE adjust init cond T", G%HI, haloshift=1, scale=US%C_to_degC) + call hchksum(CS%tv%S, "Post ALE adjust init cond S", G%HI, haloshift=1, scale=US%S_to_ppt) + endif + endif + endif + if ( CS%use_ALE_algorithm ) call ALE_updateVerticalGridType( CS%ALE_CSp, GV ) + + ! The basic state variables have now been fully initialized, so update their halos and + ! calculate any derived thermodynmics quantities. + + !--- set up group pass for u,v,T,S and h. pass_uv_T_S_h also is used in step_MOM + call cpu_clock_begin(id_clock_pass_init) + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call create_group_pass(pass_uv_T_S_h, CS%u, CS%v, G%Domain, halo=dynamics_stencil) + if (use_temperature) then + call create_group_pass(pass_uv_T_S_h, CS%tv%T, G%Domain, halo=dynamics_stencil) + call create_group_pass(pass_uv_T_S_h, CS%tv%S, G%Domain, halo=dynamics_stencil) + endif + call create_group_pass(pass_uv_T_S_h, CS%h, G%Domain, halo=dynamics_stencil) + + call do_group_pass(pass_uv_T_S_h, G%Domain) + if (associated(CS%tv%p_surf)) call pass_var(CS%tv%p_surf, G%Domain, halo=dynamics_stencil) + call cpu_clock_end(id_clock_pass_init) + + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) + endif + + + diag => CS%diag + ! Initialize the diag mediator. + call diag_mediator_init(G, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) + if (present(diag_ptr)) diag_ptr => CS%diag + + ! Initialize the diagnostics masks for native arrays. + ! This step has to be done after call to MOM_initialize_state + ! and before MOM_diagnostics_init + call diag_masks_set(G, GV%ke, diag) + + ! Set up pointers within diag mediator control structure, + ! this needs to occur _after_ CS%h etc. have been allocated. + call diag_set_state_ptrs(CS%h, CS%tv, diag) + + ! This call sets up the diagnostic axes. These are needed, + ! e.g. to generate the target grids below. + call set_axes_info(G, GV, US, param_file, diag) + + ! Whenever thickness/T/S changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. In non-Boussinesq mode, + ! calc_derived_thermo needs to be called before diag_update_remap_grids. + call diag_update_remap_grids(diag) + + ! Setup the diagnostic grid storage types + call diag_grid_storage_init(CS%diag_pre_sync, G, GV, diag) + call diag_grid_storage_init(CS%diag_pre_dyn, G, GV, diag) + + ! Calculate masks for diagnostics arrays in non-native coordinates + ! This step has to be done after set_axes_info() because the axes needed + ! to be configured, and after diag_update_remap_grids() because the grids + ! must be defined. + call set_masks_for_axes(G, diag) + + ! Register the volume cell measure (must be one of first diagnostics) + call register_cell_measure(G, CS%diag, Time) + + call cpu_clock_begin(id_clock_MOM_init) + ! Diagnose static fields AND associate areas/volumes with axes + call write_static_fields(G, GV, US, CS%tv, CS%diag) + call callTree_waypoint("static fields written (initialize_MOM)") + + if (CS%use_ALE_algorithm) then + call ALE_writeCoordinateFile( CS%ALE_CSp, GV, dirs%output_directory ) + call callTree_waypoint("ALE initialized (initialize_MOM)") + elseif (write_geom_files) then + call write_vertgrid_file(GV, US, param_file, dirs%output_directory) + endif + call cpu_clock_end(id_clock_MOM_init) + + if (CS%use_dbclient) call database_comms_init(param_file, CS%dbcomms_CS) + CS%useMEKE = MEKE_init(Time, G, GV, US, param_file, diag, CS%dbcomms_CS, CS%MEKE_CSp, CS%MEKE, & + restart_CSp, CS%MEKE_in_dynamics) + + call VarMix_init(Time, G, GV, US, param_file, diag, CS%VarMix) + call set_visc_init(Time, G, GV, US, param_file, diag, CS%visc, CS%set_visc_CSp, restart_CSp, CS%OBC) + call thickness_diffuse_init(Time, G, GV, US, param_file, diag, CS%CDp, CS%thickness_diffuse_CSp) + if (CS%interface_filter) & + call interface_filter_init(Time, G, GV, US, param_file, diag, CS%CDp, CS%interface_filter_CSp) + + new_sim = is_new_run(restart_CSp) + if (use_temperature) then + CS%use_stochastic_EOS = MOM_stoch_eos_init(Time, G, GV, US, param_file, diag, CS%stoch_eos_CS, restart_CSp) + else + CS%use_stochastic_EOS = .false. + endif + + if (CS%use_porbar) & + call porous_barriers_init(Time, GV, US, param_file, diag, CS%por_bar_CS) + + if (CS%split) then + allocate(eta(SZI_(G),SZJ_(G)), source=0.0) + if (CS%use_alt_split) then + call initialize_dyn_split_RK2b(CS%u, CS%v, CS%h, CS%uh, CS%vh, eta, Time, & + G, GV, US, param_file, diag, CS%dyn_split_RK2b_CSp, restart_CSp, & + CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & + CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & + CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) + else + call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%uh, CS%vh, eta, Time, & + G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, restart_CSp, & + CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & + CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & + CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) + endif + if (CS%dtbt_reset_period > 0.0) then + CS%dtbt_reset_interval = real_to_time(US%T_to_s*CS%dtbt_reset_period) + ! Set dtbt_reset_time to be the next even multiple of dtbt_reset_interval. + CS%dtbt_reset_time = Time_init + CS%dtbt_reset_interval * & + ((Time - Time_init) / CS%dtbt_reset_interval) + if ((CS%dtbt_reset_time > Time) .and. calc_dtbt) then + ! Back up dtbt_reset_time one interval to force dtbt to be calculated, + ! because the restart was not aligned with the interval to recalculate + ! dtbt, and dtbt was not read from a restart file. + CS%dtbt_reset_time = CS%dtbt_reset_time - CS%dtbt_reset_interval + endif + endif + elseif (CS%use_RK2) then + call initialize_dyn_unsplit_RK2(CS%u, CS%v, CS%h, Time, G, GV, US, & + param_file, diag, CS%dyn_unsplit_RK2_CSp, & + CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, & + CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, & + CS%ntrunc, cont_stencil=CS%cont_stencil) + else + call initialize_dyn_unsplit(CS%u, CS%v, CS%h, Time, G, GV, US, & + param_file, diag, CS%dyn_unsplit_CSp, & + CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, & + CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, & + CS%ntrunc, cont_stencil=CS%cont_stencil) + endif + + !Set OBC segment data update period + if (associated(CS%OBC) .and. CS%dt_obc_seg_period > 0.0) then + CS%dt_obc_seg_interval = real_to_time(US%T_to_s*CS%dt_obc_seg_period) + CS%dt_obc_seg_time = Time + CS%dt_obc_seg_interval + endif + + call callTree_waypoint("dynamics initialized (initialize_MOM)") + + CS%mixedlayer_restrat = mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, & + CS%mixedlayer_restrat_CSp, restart_CSp) + if (CS%mixedlayer_restrat) then + if (.not.(bulkmixedlayer .or. CS%use_ALE_algorithm)) & + call MOM_error(FATAL, "MOM: MIXEDLAYER_RESTRAT true requires a boundary layer scheme.") + ! When DIABATIC_FIRST=False and using CS%visc%ML in mixedlayer_restrat we need to update after a restart + if (.not. CS%diabatic_first .and. associated(CS%visc%MLD)) & + call pass_var(CS%visc%MLD, G%domain, halo=1) + endif + + call MOM_diagnostics_init(MOM_internal_state, CS%ADp, CS%CDp, Time, G, GV, US, & + param_file, diag, CS%diagnostics_CSp, CS%tv) + call diag_copy_diag_to_storage(CS%diag_pre_sync, CS%h, CS%diag) + + + if (CS%adiabatic) then + call adiabatic_driver_init(Time, G, param_file, diag, CS%diabatic_CSp, & + CS%tracer_flow_CSp) + else + call diabatic_driver_init(Time, G, GV, US, param_file, CS%use_ALE_algorithm, diag, & + CS%ADp, CS%CDp, CS%diabatic_CSp, CS%tracer_flow_CSp, & + CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%int_tide_CSp) + endif + + if (associated(CS%sponge_CSp)) & + call init_sponge_diags(Time, G, GV, US, diag, CS%sponge_CSp) + + if (associated(CS%ALE_sponge_CSp)) & + call init_ALE_sponge_diags(Time, G, diag, CS%ALE_sponge_CSp, US) + + if (associated(CS%oda_incupd_CSp)) & + call init_oda_incupd_diags(Time, G, GV, diag, CS%oda_incupd_CSp, US) + + + call tracer_advect_init(Time, G, US, param_file, diag, CS%tracer_adv_CSp) + call tracer_hor_diff_init(Time, G, GV, US, param_file, diag, CS%tv%eqn_of_state, CS%diabatic_CSp, & + CS%tracer_diff_CSp) + + call lock_tracer_registry(CS%tracer_Reg) + call callTree_waypoint("tracer registry now locked (initialize_MOM)") + + ! now register some diagnostics since the tracer registry is now locked + call register_surface_diags(Time, G, US, CS%sfc_IDs, CS%diag, CS%tv) + call register_diags(Time, G, GV, US, CS%IDs, CS%diag) + call register_transport_diags(Time, G, GV, US, CS%transport_IDs, CS%diag) + call extract_diabatic_member(CS%diabatic_CSp, use_KPP=use_KPP) + call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV, US, & + CS%use_ALE_algorithm, use_KPP) + if (CS%use_ALE_algorithm) then + call ALE_register_diags(Time, G, GV, US, diag, CS%ALE_CSp) + endif + + ! Do any necessary halo updates on any auxiliary variables that have been initialized. + call cpu_clock_begin(id_clock_pass_init) + if (associated(CS%visc%Kv_shear)) & + call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) + + if (associated(CS%visc%Kv_slow)) & + call pass_var(CS%visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) + call cpu_clock_end(id_clock_pass_init) + + ! This subroutine initializes any tracer packages. + call tracer_flow_control_init(.not.new_sim, Time, G, GV, US, CS%h, param_file, & + CS%diag, CS%OBC, CS%tracer_flow_CSp, CS%sponge_CSp, & + CS%ALE_sponge_CSp, CS%tv) + if (present(tracer_flow_CSp)) tracer_flow_CSp => CS%tracer_flow_CSp + + ! If running in offline tracer mode, initialize the necessary control structure and + ! parameters + if (present(offline_tracer_mode)) offline_tracer_mode=CS%offline_tracer_mode + + if (CS%offline_tracer_mode) then + ! Setup some initial parameterizations and also assign some of the subtypes + call offline_transport_init(param_file, CS%offline_CSp, CS%diabatic_CSp, G, GV, US) + call insert_offline_main( CS=CS%offline_CSp, ALE_CSp=CS%ALE_CSp, diabatic_CSp=CS%diabatic_CSp, & + diag=CS%diag, OBC=CS%OBC, tracer_adv_CSp=CS%tracer_adv_CSp, & + tracer_flow_CSp=CS%tracer_flow_CSp, tracer_Reg=CS%tracer_Reg, & + tv=CS%tv, x_before_y=(MODULO(first_direction,2)==0), debug=CS%debug ) + call register_diags_offline_transport(Time, CS%diag, CS%offline_CSp, GV, US) + endif + + call register_obsolete_diagnostics(param_file, CS%diag) + + if (use_frazil) then + if (.not.query_initialized(CS%tv%frazil, "frazil", restart_CSp)) then + CS%tv%frazil(:,:) = 0.0 + call set_initialized(CS%tv%frazil, "frazil", restart_CSp) + endif + endif + + if (CS%interp_p_surf) then + CS%p_surf_prev_set = query_initialized(CS%p_surf_prev, "p_surf_prev", restart_CSp) + + if (CS%p_surf_prev_set) then + call pass_var(CS%p_surf_prev, G%domain) + endif + endif + + if (.not.query_initialized(CS%ave_ssh_ibc, "ave_ssh", restart_CSp)) then + if (CS%split) then + call find_eta(CS%h, CS%tv, G, GV, US, CS%ave_ssh_ibc, eta, dZref=G%Z_ref) + else + call find_eta(CS%h, CS%tv, G, GV, US, CS%ave_ssh_ibc, dZref=G%Z_ref) + endif + call set_initialized(CS%ave_ssh_ibc, "ave_ssh", restart_CSp) + endif + if (CS%split) deallocate(eta) + + CS%nstep_tot = 0 + if (present(count_calls)) CS%count_calls = count_calls + call MOM_sum_output_init(G_in, GV, US, param_file, dirs%output_directory, & + CS%ntrunc, Time_init, CS%sum_output_CSp) + + ! Flag whether to save initial conditions in finish_MOM_initialization() or not. + CS%write_IC = save_IC .and. & + .not.((dirs%input_filename(1:1) == 'r') .and. & + (LEN_TRIM(dirs%input_filename) == 1)) + + if (CS%ensemble_ocean) then + call init_oda(Time, G, GV, US, CS%diag, CS%odaCS) + endif + + ! initialize stochastic physics + call stochastics_init(CS%dt_therm, CS%G, CS%GV, CS%stoch_CS, param_file, diag, Time) + + call callTree_leave("initialize_MOM()") + call cpu_clock_end(id_clock_init) + +end subroutine initialize_MOM + +!> Finishes initializing MOM and writes out the initial conditions. +subroutine finish_MOM_initialization(Time, dirs, CS) + type(time_type), intent(in) :: Time !< model time, used in this routine + type(directories), intent(in) :: dirs !< structure with directory paths + type(MOM_control_struct), intent(inout) :: CS !< MOM control structure + + type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing + ! metrics and related information + type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the vertical grid structure + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors + type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() + real, allocatable :: z_interface(:,:,:) ! Interface heights [Z ~> m] + + call cpu_clock_begin(id_clock_init) + call callTree_enter("finish_MOM_initialization()") + + ! Pointers for convenience + G => CS%G ; GV => CS%GV ; US => CS%US + + if (CS%use_particles) then + call particles_init(CS%particles, G, CS%Time, CS%dt_therm, CS%u, CS%v, CS%h) + endif + + ! Write initial conditions + if (CS%write_IC) then + allocate(restart_CSp_tmp) + restart_CSp_tmp = CS%restart_CS + call restart_registry_lock(restart_CSp_tmp, unlocked=.true.) + allocate(z_interface(SZI_(G),SZJ_(G),SZK_(GV)+1)) + call find_eta(CS%h, CS%tv, G, GV, US, z_interface, dZref=G%Z_ref) + call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & + "Interface heights", "meter", z_grid='i', conversion=US%Z_to_m) + ! NOTE: write_ic=.true. routes routine to fms2 IO write_initial_conditions interface + call save_restart(dirs%output_directory, Time, CS%G_in, & + restart_CSp_tmp, filename=CS%IC_file, GV=GV, write_ic=.true.) + deallocate(z_interface) + deallocate(restart_CSp_tmp) + endif + + call write_energy(CS%u, CS%v, CS%h, CS%tv, Time, 0, G, GV, US, & + CS%sum_output_CSp, CS%tracer_flow_CSp) + + call callTree_leave("finish_MOM_initialization()") + call cpu_clock_end(id_clock_init) + +end subroutine finish_MOM_initialization + +!> Register certain diagnostics +subroutine register_diags(Time, G, GV, US, IDs, diag) + type(time_type), intent(in) :: Time !< current model time + 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(inout) :: US !< A dimensional unit scaling type + type(MOM_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. + type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output + + character(len=48) :: thickness_units + + thickness_units = get_thickness_units(GV) + + ! Diagnostics of the rapidly varying dynamic state + IDs%id_u = register_diag_field('ocean_model', 'u_dyn', diag%axesCuL, Time, & + 'Zonal velocity after the dynamics update', 'm s-1', conversion=US%L_T_to_m_s) + IDs%id_v = register_diag_field('ocean_model', 'v_dyn', diag%axesCvL, Time, & + 'Meridional velocity after the dynamics update', 'm s-1', conversion=US%L_T_to_m_s) + IDs%id_h = register_diag_field('ocean_model', 'h_dyn', diag%axesTL, Time, & + 'Layer Thickness after the dynamics update', thickness_units, conversion=GV%H_to_MKS, & + v_extensive=.true.) + IDs%id_ssh_inst = register_diag_field('ocean_model', 'SSH_inst', diag%axesT1, & + Time, 'Instantaneous Sea Surface Height', 'm', conversion=US%Z_to_m) + +end subroutine register_diags + +!> Set up CPU clock IDs for timing various subroutines. +subroutine MOM_timing_init(CS) + type(MOM_control_struct), intent(in) :: CS !< control structure set up by initialize_MOM. + + id_clock_ocean = cpu_clock_id('Ocean', grain=CLOCK_COMPONENT) + id_clock_dynamics = cpu_clock_id('Ocean dynamics', grain=CLOCK_SUBCOMPONENT) + id_clock_thermo = cpu_clock_id('Ocean thermodynamics and tracers', grain=CLOCK_SUBCOMPONENT) + id_clock_other = cpu_clock_id('Ocean Other', grain=CLOCK_SUBCOMPONENT) + id_clock_tracer = cpu_clock_id('(Ocean tracer advection)', grain=CLOCK_MODULE_DRIVER) + if (.not.CS%adiabatic) then + id_clock_diabatic = cpu_clock_id('(Ocean diabatic driver)', grain=CLOCK_MODULE_DRIVER) + else + id_clock_adiabatic = cpu_clock_id('(Ocean adiabatic driver)', grain=CLOCK_MODULE_DRIVER) + endif + + id_clock_continuity = cpu_clock_id('(Ocean continuity equation *)', grain=CLOCK_MODULE) + id_clock_BBL_visc = cpu_clock_id('(Ocean set BBL viscosity)', grain=CLOCK_MODULE) + id_clock_pass = cpu_clock_id('(Ocean message passing *)', grain=CLOCK_MODULE) + id_clock_MOM_init = cpu_clock_id('(Ocean MOM_initialize_state)', grain=CLOCK_MODULE) + id_clock_pass_init = cpu_clock_id('(Ocean init message passing *)', grain=CLOCK_ROUTINE) + if (CS%thickness_diffuse) & + id_clock_thick_diff = cpu_clock_id('(Ocean thickness diffusion *)', grain=CLOCK_MODULE) + if (CS%interface_filter) & + id_clock_int_filter = cpu_clock_id('(Ocean interface height filter *)', grain=CLOCK_MODULE) + !if (CS%mixedlayer_restrat) & + id_clock_ml_restrat = cpu_clock_id('(Ocean mixed layer restrat)', grain=CLOCK_MODULE) + id_clock_diagnostics = cpu_clock_id('(Ocean collective diagnostics)', grain=CLOCK_MODULE) + id_clock_Z_diag = cpu_clock_id('(Ocean Z-space diagnostics)', grain=CLOCK_MODULE) + id_clock_ALE = cpu_clock_id('(Ocean ALE)', grain=CLOCK_MODULE) + if (CS%offline_tracer_mode) then + id_clock_offline_tracer = cpu_clock_id('Ocean offline tracers', grain=CLOCK_SUBCOMPONENT) + endif + id_clock_stoch = cpu_clock_id('(Stochastic EOS)', grain=CLOCK_MODULE) + id_clock_varT = cpu_clock_id('(SGS Temperature Variance)', grain=CLOCK_MODULE) + +end subroutine MOM_timing_init + +!> Set the fields that are needed for bitwise identical restarting +!! the time stepping scheme. In addition to those specified here +!! directly, there may be fields related to the forcing or to the +!! barotropic solver that are needed; these are specified in sub- +!! routines that are called from this one. +!! +!! This routine should be altered if there are any changes to the +!! time stepping scheme. The CHECK_RESTART facility may be used to +!! confirm that all needed restart fields have been included. +subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) + type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(inout) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< opened file for parsing to get parameters + type(MOM_control_struct), intent(in) :: CS !< control structure set up by initialize_MOM + type(MOM_restart_CS), pointer :: restart_CSp !< pointer to the restart control + !! structure that will be used for MOM. + ! Local variables + logical :: use_ice_shelf ! Needed to determine whether to add CS%Hml to restarts + character(len=48) :: thickness_units, flux_units + type(vardesc) :: u_desc, v_desc + + thickness_units = get_thickness_units(GV) + flux_units = get_flux_units(GV) + + if (associated(CS%tv%T)) & + call register_restart_field(CS%tv%T, "Temp", .true., restart_CSp, & + "Potential Temperature", "degC", conversion=US%C_to_degC) + if (associated(CS%tv%S)) & + call register_restart_field(CS%tv%S, "Salt", .true., restart_CSp, & + "Salinity", "PPT", conversion=US%S_to_ppt) + + call register_restart_field(CS%h, "h", .true., restart_CSp, & + "Layer Thickness", thickness_units, conversion=GV%H_to_MKS) + + u_desc = var_desc("u", "m s-1", "Zonal velocity", hor_grid='Cu') + v_desc = var_desc("v", "m s-1", "Meridional velocity", hor_grid='Cv') + call register_restart_pair(CS%u, CS%v, u_desc, v_desc, .true., restart_CSp, conversion=US%L_T_to_m_s) + + if (associated(CS%tv%frazil)) & + call register_restart_field(CS%tv%frazil, "frazil", .false., restart_CSp, & + "Frazil heat flux into ocean", & + "J m-2", conversion=US%Q_to_J_kg*US%RZ_to_kg_m2) + + if (CS%interp_p_surf) then + call register_restart_field(CS%p_surf_prev, "p_surf_prev", .false., restart_CSp, & + "Previous ocean surface pressure", "Pa", conversion=US%RL2_T2_to_Pa) + endif + + if (associated(CS%tv%p_surf)) & + call register_restart_field(CS%tv%p_surf, "p_surf_EOS", .false., restart_CSp, & + "Ocean surface pressure used in EoS", "Pa", conversion=US%RL2_T2_to_Pa) + + call register_restart_field(CS%ave_ssh_ibc, "ave_ssh", .false., restart_CSp, & + "Time average sea surface height", "meter", conversion=US%Z_to_m) + + ! hML is needed when using the ice shelf module + call get_param(param_file, '', "ICE_SHELF", use_ice_shelf, default=.false., & + do_not_log=.true.) + if (use_ice_shelf .and. associated(CS%Hml)) then + call register_restart_field(CS%Hml, "hML", .false., restart_CSp, & + "Mixed layer thickness", "m", conversion=US%Z_to_m) + endif + + ! Register scalar unit conversion factors. + call register_restart_field(CS%first_dir_restart, "First_direction", .false., restart_CSp, & + "Indicator of the first direction in split calculations.", "nondim") + +end subroutine set_restart_fields + +!> Apply a correction to the sea surface height to compensate +!! for the atmospheric pressure (the inverse barometer). +subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + 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)), intent(inout) :: ssh !< time mean surface height [Z ~> m] + real, dimension(:,:), pointer :: p_atm !< Ocean surface pressure [R L2 T-2 ~> Pa] + logical, intent(in) :: use_EOS !< If true, calculate the density for + !! the SSH correction using the equation of state. + + real :: Rho_conv(SZI_(G)) ! The density used to convert surface pressure to + ! a corrected effective SSH [R ~> kg m-3]. + real :: IgR0 ! The SSH conversion factor from R L2 T-2 to Z [Z T2 R-1 L-2 ~> m Pa-1]. + logical :: calc_rho + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + EOSdom(:) = EOS_domain(G%HI) + if (associated(p_atm)) then + calc_rho = use_EOS .and. associated(tv%eqn_of_state) + ! Correct the output sea surface height for the contribution from the ice pressure. + do j=js,je + if (calc_rho) then + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), 0.5*p_atm(:,j), Rho_conv, & + tv%eqn_of_state, EOSdom) + do i=is,ie + IgR0 = 1.0 / (Rho_conv(i) * GV%g_Earth) + ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 + enddo + else + IgR0 = 1.0 / (GV%Rho0 * GV%g_Earth) + do i=is,ie + ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 + enddo + endif + enddo + endif + +end subroutine adjust_ssh_for_p_atm + +!> Set the surface (return) properties of the ocean model by +!! setting the appropriate fields in sfc_state. Unused fields +!! are set to NULL or are unallocated. +subroutine extract_surface_state(CS, sfc_state_in) + type(MOM_control_struct), intent(inout), target :: CS !< Master MOM control structure + type(surface), target, intent(inout) :: sfc_state_in !< transparent ocean surface state + !! structure shared with the calling routine + !! data in this structure is intent out. + + ! Local variables + real :: hu, hv ! Thicknesses interpolated to velocity points [H ~> m or kg m-2] + type(ocean_grid_type), pointer :: G => NULL() !< pointer to a structure containing + !! metrics and related information + type(ocean_grid_type), pointer :: G_in => NULL() !< Input grid metric + type(verticalGrid_type), pointer :: GV => NULL() !< structure containing vertical grid info + type(unit_scale_type), pointer :: US => NULL() !< structure containing various unit conversion factors + type(surface), pointer :: sfc_state => NULL() ! surface state on the model grid + real, dimension(:,:,:), pointer :: h => NULL() !< h : layer thickness [H ~> m or kg m-2] + real :: depth(SZI_(CS%G)) !< Distance from the surface in depth units [Z ~> m] or [H ~> m or kg m-2] + real :: depth_ml !< Depth over which to average to determine mixed + !! layer properties [Z ~> m] or [H ~> m or kg m-2] + real :: dh !< Thickness of a layer within the mixed layer [Z ~> m] or [H ~> m or kg m-2] + real :: mass !< Mass per unit area of a layer [R Z ~> kg m-2] + real :: I_depth !< The inverse of depth [Z-1 ~> m-1] or [H-1 ~> m-1 or m2 kg-1] + real :: missing_depth !< The portion of depth_ml that can not be found in a column [H ~> m or kg m-2] + real :: H_rescale !< A conversion factor from thickness units to the units used in the + !! calculation of properties of the uppermost ocean [nondim] or [Z H-1 ~> 1 or m3 kg-1] + ! After the ANSWERS_2018 flag has been obsoleted, H_rescale will be 1. + real :: T_freeze(SZI_(CS%G)) !< freezing temperature [C ~> degC] + real :: pres(SZI_(CS%G)) !< Pressure to use for the freezing temperature calculation [R L2 T-2 ~> Pa] + real :: delT(SZI_(CS%G)) !< Depth integral of T-T_freeze [H C ~> m degC or degC kg m-2] + logical :: use_temperature !< If true, temperature and salinity are used as state variables. + integer :: i, j, k, is, ie, js, je, nz, numberOfErrors, ig, jg + integer :: isd, ied, jsd, jed + integer :: iscB, iecB, jscB, jecB, isdB, iedB, jsdB, jedB + logical :: localError + logical :: use_iceshelves + character(240) :: msg + integer :: turns ! Number of quarter turns + + call callTree_enter("extract_surface_state(), MOM.F90") + G => CS%G ; G_in => CS%G_in ; GV => CS%GV ; US => CS%US + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + iscB = G%iscB ; iecB = G%iecB; jscB = G%jscB ; jecB = G%jecB + isdB = G%isdB ; iedB = G%iedB; jsdB = G%jsdB ; jedB = G%jedB + h => CS%h + + use_temperature = associated(CS%tv%T) + + use_iceshelves=.false. + if (associated(CS%frac_shelf_h)) use_iceshelves = .true. + + turns = 0 + if (CS%rotate_index) & + turns = G%HI%turns + + if (.not.sfc_state_in%arrays_allocated) then + ! Consider using a run-time flag to determine whether to do the vertical + ! integrals, since the 3-d sums are not negligible in cost. + call allocate_surface_state(sfc_state_in, G_in, use_temperature, & + do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil),& + use_iceshelves=use_iceshelves) + endif + + if (CS%rotate_index) then + allocate(sfc_state) + call allocate_surface_state(sfc_state, G, use_temperature, & + do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil),& + use_iceshelves=use_iceshelves) + else + sfc_state => sfc_state_in + endif + + sfc_state%T_is_conT = CS%tv%T_is_conT + sfc_state%S_is_absS = CS%tv%S_is_absS + + do j=js,je ; do i=is,ie + sfc_state%sea_lev(i,j) = CS%ave_ssh_ibc(i,j) + enddo ; enddo + + if (allocated(sfc_state%frazil) .and. associated(CS%tv%frazil)) then ; do j=js,je ; do i=is,ie + sfc_state%frazil(i,j) = CS%tv%frazil(i,j) + enddo ; enddo ; endif + + ! copy Hml into sfc_state, so that caps can access it + if (associated(CS%Hml)) then + do j=js,je ; do i=is,ie + sfc_state%Hml(i,j) = CS%Hml(i,j) + enddo ; enddo + endif + + if (CS%Hmix < 0.0) then ! A bulk mixed layer is in use, so layer 1 has the properties + if (use_temperature) then ; do j=js,je ; do i=is,ie + sfc_state%SST(i,j) = CS%tv%T(i,j,1) + sfc_state%SSS(i,j) = CS%tv%S(i,j,1) + enddo ; enddo ; endif + do j=js,je ; do I=is-1,ie + sfc_state%u(I,j) = CS%u(I,j,1) + enddo ; enddo + do J=js-1,je ; do i=is,ie + sfc_state%v(i,J) = CS%v(i,J,1) + enddo ; enddo + + else ! (CS%Hmix >= 0.0) + H_rescale = 1.0 + depth_ml = CS%Hmix + if (CS%answer_date < 20190101) then + H_rescale = GV%H_to_Z + depth_ml = GV%H_to_Z*CS%Hmix + endif + ! Determine the mean tracer properties of the uppermost depth_ml fluid. + + !$OMP parallel do default(shared) private(depth,dh) + do j=js,je + do i=is,ie + depth(i) = 0.0 + if (use_temperature) then + sfc_state%SST(i,j) = 0.0 ; sfc_state%SSS(i,j) = 0.0 + else + sfc_state%sfc_density(i,j) = 0.0 + endif + enddo + + do k=1,nz ; do i=is,ie + if (depth(i) + h(i,j,k)*H_rescale < depth_ml) then + dh = h(i,j,k)*H_rescale + elseif (depth(i) < depth_ml) then + dh = depth_ml - depth(i) + else + dh = 0.0 + endif + if (use_temperature) then + sfc_state%SST(i,j) = sfc_state%SST(i,j) + dh * CS%tv%T(i,j,k) + sfc_state%SSS(i,j) = sfc_state%SSS(i,j) + dh * CS%tv%S(i,j,k) + else + sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) + dh * GV%Rlay(k) + endif + depth(i) = depth(i) + dh + enddo ; enddo + ! Calculate the average properties of the mixed layer depth. + do i=is,ie + if (CS%answer_date < 20190101) then + if (depth(i) < GV%H_subroundoff*H_rescale) & + depth(i) = GV%H_subroundoff*H_rescale + if (use_temperature) then + sfc_state%SST(i,j) = sfc_state%SST(i,j) / depth(i) + sfc_state%SSS(i,j) = sfc_state%SSS(i,j) / depth(i) + else + sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) / depth(i) + endif + else + if (depth(i) < GV%H_subroundoff*H_rescale) then + I_depth = 1.0 / (GV%H_subroundoff*H_rescale) + missing_depth = GV%H_subroundoff*H_rescale - depth(i) + if (use_temperature) then + sfc_state%SST(i,j) = (sfc_state%SST(i,j) + missing_depth*CS%tv%T(i,j,1)) * I_depth + sfc_state%SSS(i,j) = (sfc_state%SSS(i,j) + missing_depth*CS%tv%S(i,j,1)) * I_depth + else + sfc_state%sfc_density(i,j) = (sfc_state%sfc_density(i,j) + & + missing_depth*GV%Rlay(1)) * I_depth + endif + else + I_depth = 1.0 / depth(i) + if (use_temperature) then + sfc_state%SST(i,j) = sfc_state%SST(i,j) * I_depth + sfc_state%SSS(i,j) = sfc_state%SSS(i,j) * I_depth + else + sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) * I_depth + endif + endif + endif + enddo + enddo ! end of j loop + +! Determine the mean velocities in the uppermost depth_ml fluid. + ! NOTE: Velocity loops start on `[ij]s-1` in order to update halo values + ! required by the speed diagnostic on the non-symmetric grid. + ! This assumes that u and v halos have already been updated. + if (CS%Hmix_UV>0.) then + depth_ml = CS%Hmix_UV + if (CS%answer_date < 20190101) depth_ml = GV%H_to_Z*CS%Hmix_UV + !$OMP parallel do default(shared) private(depth,dh,hv) + do J=js-1,ie + do i=is,ie + depth(i) = 0.0 + sfc_state%v(i,J) = 0.0 + enddo + do k=1,nz ; do i=is,ie + hv = 0.5 * (h(i,j,k) + h(i,j+1,k)) * H_rescale + if (depth(i) + hv < depth_ml) then + dh = hv + elseif (depth(i) < depth_ml) then + dh = depth_ml - depth(i) + else + dh = 0.0 + endif + sfc_state%v(i,J) = sfc_state%v(i,J) + dh * CS%v(i,J,k) + depth(i) = depth(i) + dh + enddo ; enddo + ! Calculate the average properties of the mixed layer depth. + do i=is,ie + sfc_state%v(i,J) = sfc_state%v(i,J) / max(depth(i), GV%H_subroundoff*H_rescale) + enddo + enddo ! end of j loop + + !$OMP parallel do default(shared) private(depth,dh,hu) + do j=js,je + do I=is-1,ie + depth(I) = 0.0 + sfc_state%u(I,j) = 0.0 + enddo + do k=1,nz ; do I=is-1,ie + hu = 0.5 * (h(i,j,k) + h(i+1,j,k)) * H_rescale + if (depth(i) + hu < depth_ml) then + dh = hu + elseif (depth(I) < depth_ml) then + dh = depth_ml - depth(I) + else + dh = 0.0 + endif + sfc_state%u(I,j) = sfc_state%u(I,j) + dh * CS%u(I,j,k) + depth(I) = depth(I) + dh + enddo ; enddo + ! Calculate the average properties of the mixed layer depth. + do I=is-1,ie + sfc_state%u(I,j) = sfc_state%u(I,j) / max(depth(I), GV%H_subroundoff*H_rescale) + enddo + enddo ! end of j loop + else ! Hmix_UV<=0. + do j=js,je ; do I=is-1,ie + sfc_state%u(I,j) = CS%u(I,j,1) + enddo ; enddo + do J=js-1,je ; do i=is,ie + sfc_state%v(i,J) = CS%v(i,J,1) + enddo ; enddo + endif + endif ! (CS%Hmix >= 0.0) + + + if (allocated(sfc_state%melt_potential)) then + !$OMP parallel do default(shared) private(depth_ml, dh, T_freeze, depth, pres, delT) + do j=js,je + do i=is,ie + depth(i) = 0.0 + delT(i) = 0.0 + pres(i) = 0.0 + ! Here it is assumed that p=0 is OK, since HFrz ~ 10 to 20m, but under ice-shelves this + ! can be a very bad assumption. ###To fix this, uncomment the following... + ! pres(i) = p_surface(i) + 0.5*(GV%g_Earth*GV%H_to_RZ)*h(i,j,1) + enddo + + do k=1,nz + call calculate_TFreeze(CS%tv%S(is:ie,j,k), pres(is:ie), T_freeze(is:ie), CS%tv%eqn_of_state) + do i=is,ie + depth_ml = min(CS%HFrz, (US%Z_to_m*GV%m_to_H)*CS%visc%MLD(i,j)) + if (depth(i) + h(i,j,k) < depth_ml) then + dh = h(i,j,k) + elseif (depth(i) < depth_ml) then + dh = depth_ml - depth(i) + else + dh = 0.0 + endif + + depth(i) = depth(i) + dh + delT(i) = delT(i) + dh * (CS%tv%T(i,j,k) - T_freeze(i)) + enddo + ! If there is a pressure-dependent freezing point calculation uncomment the following. + ! if (k0.) then + ! instantaneous melt_potential [Q R Z ~> J m-2] + sfc_state%melt_potential(i,j) = CS%tv%C_p * GV%H_to_RZ * delT(i) + endif + enddo + enddo ! end of j loop + endif ! melt_potential + + if (allocated(sfc_state%taux_shelf) .and. allocated(CS%visc%taux_shelf)) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + sfc_state%taux_shelf(I,j) = CS%visc%taux_shelf(I,j) + enddo ; enddo + endif + if (allocated(sfc_state%tauy_shelf) .and. allocated(CS%visc%tauy_shelf)) then + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + sfc_state%tauy_shelf(i,J) = CS%visc%tauy_shelf(i,J) + enddo ; enddo + endif + + if (allocated(sfc_state%ocean_mass) .and. allocated(sfc_state%ocean_heat) .and. & + allocated(sfc_state%ocean_salt)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + sfc_state%ocean_mass(i,j) = 0.0 + sfc_state%ocean_heat(i,j) = 0.0 ; sfc_state%ocean_salt(i,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) private(mass) + do j=js,je ; do k=1,nz ; do i=is,ie + mass = GV%H_to_RZ*h(i,j,k) + sfc_state%ocean_mass(i,j) = sfc_state%ocean_mass(i,j) + mass + sfc_state%ocean_heat(i,j) = sfc_state%ocean_heat(i,j) + mass * CS%tv%T(i,j,k) + sfc_state%ocean_salt(i,j) = sfc_state%ocean_salt(i,j) + mass * (1.0e-3*CS%tv%S(i,j,k)) + enddo ; enddo ; enddo + else + if (allocated(sfc_state%ocean_mass)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie ; sfc_state%ocean_mass(i,j) = 0.0 ; enddo ; enddo + !$OMP parallel do default(shared) + do j=js,je ; do k=1,nz ; do i=is,ie + sfc_state%ocean_mass(i,j) = sfc_state%ocean_mass(i,j) + GV%H_to_RZ*h(i,j,k) + enddo ; enddo ; enddo + endif + if (allocated(sfc_state%ocean_heat)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie ; sfc_state%ocean_heat(i,j) = 0.0 ; enddo ; enddo + !$OMP parallel do default(shared) private(mass) + do j=js,je ; do k=1,nz ; do i=is,ie + mass = GV%H_to_RZ*h(i,j,k) + sfc_state%ocean_heat(i,j) = sfc_state%ocean_heat(i,j) + mass * CS%tv%T(i,j,k) + enddo ; enddo ; enddo + endif + if (allocated(sfc_state%ocean_salt)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie ; sfc_state%ocean_salt(i,j) = 0.0 ; enddo ; enddo + !$OMP parallel do default(shared) private(mass) + do j=js,je ; do k=1,nz ; do i=is,ie + mass = GV%H_to_RZ*h(i,j,k) + sfc_state%ocean_salt(i,j) = sfc_state%ocean_salt(i,j) + mass * (1.0e-3*CS%tv%S(i,j,k)) + enddo ; enddo ; enddo + endif + endif + + if (associated(CS%tracer_flow_CSp)) then + call call_tracer_surface_state(sfc_state, h, G, GV, US, CS%tracer_flow_CSp) + endif + + if (CS%check_bad_sfc_vals) then + numberOfErrors=0 ! count number of errors + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j)>0.) then + localError = sfc_state%sea_lev(i,j) <= -G%bathyT(i,j) - G%Z_ref & + .or. sfc_state%sea_lev(i,j) >= CS%bad_val_ssh_max & + .or. sfc_state%sea_lev(i,j) <= -CS%bad_val_ssh_max & + .or. sfc_state%sea_lev(i,j) + G%bathyT(i,j) + G%Z_ref < CS%bad_val_col_thick + if (use_temperature) localError = localError & + .or. sfc_state%SSS(i,j)<0. & + .or. sfc_state%SSS(i,j)>=CS%bad_val_sss_max & + .or. sfc_state%SST(i,j)< CS%bad_val_sst_min & + .or. sfc_state%SST(i,j)>=CS%bad_val_sst_max + if (localError) then + numberOfErrors=numberOfErrors+1 + if (numberOfErrors<9) then ! Only report details for the first few errors + ig = i + G%HI%idg_offset ! Global i-index + jg = j + G%HI%jdg_offset ! Global j-index + if (use_temperature) then + write(msg(1:240),'(2(a,i4,1x),4(a,f8.3,1x),8(a,es11.4,1x))') & + 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & + 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & + 'x=',G%gridLonT(ig), 'y=',G%gridLatT(jg), & + 'D=',US%Z_to_m*(G%bathyT(i,j)+G%Z_ref), 'SSH=',US%Z_to_m*sfc_state%sea_lev(i,j), & + 'SST=',US%C_to_degC*sfc_state%SST(i,j), 'SSS=',US%S_to_ppt*sfc_state%SSS(i,j), & + 'U-=',US%L_T_to_m_s*sfc_state%u(I-1,j), 'U+=',US%L_T_to_m_s*sfc_state%u(I,j), & + 'V-=',US%L_T_to_m_s*sfc_state%v(i,J-1), 'V+=',US%L_T_to_m_s*sfc_state%v(i,J) + else + write(msg(1:240),'(2(a,i4,1x),4(a,f8.3,1x),6(a,es11.4))') & + 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & + 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & + 'x=',G%gridLonT(i), 'y=',G%gridLatT(j), & + 'D=',US%Z_to_m*(G%bathyT(i,j)+G%Z_ref), 'SSH=',US%Z_to_m*sfc_state%sea_lev(i,j), & + 'U-=',US%L_T_to_m_s*sfc_state%u(I-1,j), 'U+=',US%L_T_to_m_s*sfc_state%u(I,j), & + 'V-=',US%L_T_to_m_s*sfc_state%v(i,J-1), 'V+=',US%L_T_to_m_s*sfc_state%v(i,J) + endif + call MOM_error(WARNING, trim(msg), all_print=.true.) + elseif (numberOfErrors==9) then ! Indicate once that there are more errors + call MOM_error(WARNING, 'There were more unreported extreme events!', all_print=.true.) + endif ! numberOfErrors + endif ! localError + endif ! mask2dT + enddo ; enddo + call sum_across_PEs(numberOfErrors) + if (numberOfErrors>0) then + write(msg(1:240),'(3(a,i9,1x))') 'There were a total of ',numberOfErrors, & + 'locations detected with extreme surface values!' + call MOM_error(FATAL, trim(msg)) + endif + endif + + if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G, US, haloshift=0) + + ! Rotate sfc_state back onto the input grid, sfc_state_in + if (CS%rotate_index) then + call rotate_surface_state(sfc_state, sfc_state_in, G_in, -turns) + call deallocate_surface_state(sfc_state) + endif + + call callTree_leave("extract_surface_sfc_state()") +end subroutine extract_surface_state + +!> Rotate initialization fields from input to rotated arrays. +subroutine rotate_initial_state(u_in, v_in, h_in, T_in, S_in, & + use_temperature, turns, u, v, h, T, S) + real, dimension(:,:,:), intent(in) :: u_in !< Zonal velocity on the initial grid [L T-1 ~> m s-1] + real, dimension(:,:,:), intent(in) :: v_in !< Meridional velocity on the initial grid [L T-1 ~> m s-1] + real, dimension(:,:,:), intent(in) :: h_in !< Layer thickness on the initial grid [H ~> m or kg m-2] + real, dimension(:,:,:), intent(in) :: T_in !< Temperature on the initial grid [C ~> degC] + real, dimension(:,:,:), intent(in) :: S_in !< Salinity on the initial grid [S ~> ppt] + logical, intent(in) :: use_temperature !< If true, temperature and salinity are active + integer, intent(in) :: turns !< The number quarter-turns to apply + real, dimension(:,:,:), intent(out) :: u !< Zonal velocity on the rotated grid [L T-1 ~> m s-1] + real, dimension(:,:,:), intent(out) :: v !< Meridional velocity on the rotated grid [L T-1 ~> m s-1] + real, dimension(:,:,:), intent(out) :: h !< Layer thickness on the rotated grid [H ~> m or kg m-2] + real, dimension(:,:,:), intent(out) :: T !< Temperature on the rotated grid [C ~> degC] + real, dimension(:,:,:), intent(out) :: S !< Salinity on the rotated grid [S ~> ppt] + + call rotate_vector(u_in, v_in, turns, u, v) + call rotate_array(h_in, turns, h) + if (use_temperature) then + call rotate_array(T_in, turns, T) + call rotate_array(S_in, turns, S) + endif +end subroutine rotate_initial_state + +!> Return true if all phases of step_MOM are at the same point in time. +function MOM_state_is_synchronized(CS, adv_dyn) result(in_synch) + type(MOM_control_struct), intent(inout) :: CS !< MOM control structure + logical, optional, intent(in) :: adv_dyn !< If present and true, only check + !! whether the advection is up-to-date with + !! the dynamics. + logical :: in_synch !< True if all phases of the update are synchronized. + + logical :: adv_only + + adv_only = .false. ; if (present(adv_dyn)) adv_only = adv_dyn + + if (adv_only) then + in_synch = (CS%t_dyn_rel_adv == 0.0) + else + in_synch = ((CS%t_dyn_rel_adv == 0.0) .and. (CS%t_dyn_rel_thermo == 0.0)) + endif + +end function MOM_state_is_synchronized + +!> This subroutine offers access to values or pointers to other types from within +!! the MOM_control_struct, allowing the MOM_control_struct to be opaque. +subroutine get_MOM_state_elements(CS, G, GV, US, C_p, C_p_scaled, use_temp) + type(MOM_control_struct), intent(inout), target :: CS !< MOM control structure + type(ocean_grid_type), optional, pointer :: G !< structure containing metrics and grid info + type(verticalGrid_type), optional, pointer :: GV !< structure containing vertical grid info + type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type + real, optional, intent(out) :: C_p !< The heat capacity [J kg degC-1] + real, optional, intent(out) :: C_p_scaled !< The heat capacity in scaled + !! units [Q C-1 ~> J kg-1 degC-1] + logical, optional, intent(out) :: use_temp !< True if temperature is a state variable + + if (present(G)) G => CS%G_in + if (present(GV)) GV => CS%GV + if (present(US)) US => CS%US + if (present(C_p)) C_p = CS%US%Q_to_J_kg*US%degC_to_C * CS%tv%C_p + if (present(C_p_scaled)) C_p_scaled = CS%tv%C_p + if (present(use_temp)) use_temp = associated(CS%tv%T) +end subroutine get_MOM_state_elements + +!> Find the global integrals of various quantities. +subroutine get_ocean_stocks(CS, mass, heat, salt, on_PE_only) + type(MOM_control_struct), intent(inout) :: CS !< MOM control structure + real, optional, intent(out) :: heat !< The globally integrated integrated ocean heat [J]. + real, optional, intent(out) :: salt !< The globally integrated integrated ocean salt [kg]. + real, optional, intent(out) :: mass !< The globally integrated integrated ocean mass [kg]. + logical, optional, intent(in) :: on_PE_only !< If present and true, only sum on the local PE. + + if (present(mass)) & + mass = global_mass_integral(CS%h, CS%G, CS%GV, on_PE_only=on_PE_only) + if (present(heat)) & + heat = CS%US%Q_to_J_kg*CS%tv%C_p * & + global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%T, on_PE_only=on_PE_only, tmp_scale=CS%US%C_to_degC) + if (present(salt)) & + salt = 1.0e-3 * global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%S, on_PE_only=on_PE_only, scale=CS%US%S_to_ppt) + +end subroutine get_ocean_stocks + + +!> Save restart/pickup files required to initialize the MOM6 internal state. +subroutine save_MOM_restart(CS, directory, time, G, time_stamped, filename, & + GV, num_rest_files, write_IC) + type(MOM_control_struct), intent(inout) :: CS + !< MOM control structure + character(len=*), intent(in) :: directory + !< The directory where the restart files are to be written + type(time_type), intent(in) :: time + !< The current model time + type(ocean_grid_type), intent(inout) :: G + !< The ocean's grid structure + logical, optional, intent(in) :: time_stamped + !< If present and true, add time-stamp to the restart file names + character(len=*), optional, intent(in) :: filename + !< A filename that overrides the name in CS%restartfile + type(verticalGrid_type), optional, intent(in) :: GV + !< The ocean's vertical grid structure + integer, optional, intent(out) :: num_rest_files + !< number of restart files written + logical, optional, intent(in) :: write_IC + !< If present and true, initial conditions are being written + + call save_restart(directory, time, G, CS%restart_CS, & + time_stamped=time_stamped, filename=filename, GV=GV, & + num_rest_files=num_rest_files, write_IC=write_IC) + + if (CS%use_particles) call particles_save_restart(CS%particles, CS%h, directory, time, time_stamped) +end subroutine save_MOM_restart + + +!> End of ocean model, including memory deallocation +subroutine MOM_end(CS) + type(MOM_control_struct), intent(inout) :: CS !< MOM control structure + + call MOM_sum_output_end(CS%sum_output_CSp) + + if (CS%use_ALE_algorithm) call ALE_end(CS%ALE_CSp) + + !deallocate porous topography variables + deallocate(CS%pbv%por_face_areaU) ; deallocate(CS%pbv%por_face_areaV) + deallocate(CS%pbv%por_layer_widthU) ; deallocate(CS%pbv%por_layer_widthV) + + ! NOTE: Allocated in PressureForce_FV_Bouss + if (associated(CS%tv%varT)) deallocate(CS%tv%varT) + + call tracer_advect_end(CS%tracer_adv_CSp) + call tracer_hor_diff_end(CS%tracer_diff_CSp) + call tracer_registry_end(CS%tracer_Reg) + call tracer_flow_control_end(CS%tracer_flow_CSp) + + if (.not. CS%adiabatic) then + call diabatic_driver_end(CS%diabatic_CSp) + deallocate(CS%diabatic_CSp) + endif + + call MOM_diagnostics_end(CS%diagnostics_CSp, CS%ADp, CS%CDp) + + if (CS%offline_tracer_mode) call offline_transport_end(CS%offline_CSp) + + if (CS%split .and. CS%use_alt_split) then + call end_dyn_split_RK2b(CS%dyn_split_RK2b_CSp) + elseif (CS%split) then + call end_dyn_split_RK2(CS%dyn_split_RK2_CSp) + elseif (CS%use_RK2) then + call end_dyn_unsplit_RK2(CS%dyn_unsplit_RK2_CSp) + else + call end_dyn_unsplit(CS%dyn_unsplit_CSp) + endif + + if (CS%use_particles) then + call particles_end(CS%particles, CS%h) + deallocate(CS%particles) + endif + + call thickness_diffuse_end(CS%thickness_diffuse_CSp, CS%CDp) + if (CS%interface_filter) call interface_filter_end(CS%interface_filter_CSp, CS%CDp) + call VarMix_end(CS%VarMix) + call set_visc_end(CS%visc, CS%set_visc_CSp) + call MEKE_end(CS%MEKE) + + if (associated(CS%tv%internal_heat)) deallocate(CS%tv%internal_heat) + if (associated(CS%tv%TempxPmE)) deallocate(CS%tv%TempxPmE) + + DEALLOC_(CS%ave_ssh_ibc) ; DEALLOC_(CS%ssh_rint) + + ! TODO: debug_truncations deallocation + + DEALLOC_(CS%uhtr) ; DEALLOC_(CS%vhtr) + + if (associated(CS%Hml)) deallocate(CS%Hml) + if (associated(CS%tv%salt_deficit)) deallocate(CS%tv%salt_deficit) + if (associated(CS%tv%frazil)) deallocate(CS%tv%frazil) + if (allocated(CS%tv%SpV_avg)) deallocate(CS%tv%SpV_avg) + + if (associated(CS%tv%T)) then + DEALLOC_(CS%T) ; CS%tv%T => NULL() ; DEALLOC_(CS%S) ; CS%tv%S => NULL() + endif + + DEALLOC_(CS%u) ; DEALLOC_(CS%v) ; DEALLOC_(CS%h) + DEALLOC_(CS%uh) ; DEALLOC_(CS%vh) + + if (associated(CS%update_OBC_CSp)) call OBC_register_end(CS%update_OBC_CSp) + + call verticalGridEnd(CS%GV) + call MOM_grid_end(CS%G) + + if (CS%debug .or. CS%G%symmetric) & + call deallocate_MOM_domain(CS%G%Domain_aux) + + if (CS%rotate_index) & + call deallocate_MOM_domain(CS%G%Domain) + + ! The MPP domains may be needed by an external coupler, so use `cursory`. + ! TODO: This may create a domain memory leak, and needs investigation. + call deallocate_MOM_domain(CS%G_in%domain, cursory=.true.) + + call unit_scaling_end(CS%US) +end subroutine MOM_end + +!> \namespace mom +!! +!! Modular Ocean Model (MOM) Version 6.0 (MOM6) +!! +!! \authors Alistair Adcroft, Robert Hallberg, and Stephen Griffies +!! +!! Additional contributions from: +!! * Whit Anderson +!! * Brian Arbic +!! * Will Cooke +!! * Anand Gnanadesikan +!! * Matthew Harrison +!! * Mehmet Ilicak +!! * Laura Jackson +!! * Jasmine John +!! * John Krasting +!! * Zhi Liang +!! * Bonnie Samuels +!! * Harper Simmons +!! * Laurent White +!! * Niki Zadeh +!! +!! MOM ice-shelf code was developed by +!! * Daniel Goldberg +!! * Robert Hallberg +!! * Chris Little +!! * Olga Sergienko +!! +!! \section section_overview Overview of MOM +!! +!! This program (MOM) simulates the ocean by numerically solving +!! the hydrostatic primitive equations in generalized Lagrangian +!! vertical coordinates, typically tracking stretched pressure (p*) +!! surfaces or following isopycnals in the ocean's interior, and +!! general orthogonal horizontal coordinates. Unlike earlier versions +!! of MOM, in MOM6 these equations are horizontally discretized on an +!! Arakawa C-grid. (It remains to be seen whether a B-grid dynamic +!! core will be revived in MOM6 at a later date; for now applications +!! requiring a B-grid discretization should use MOM5.1.) MOM6 offers +!! a range of options for the physical parameterizations, from those +!! most appropriate to highly idealized models for geophysical fluid +!! dynamics studies to a rich suite of processes appropriate for +!! realistic ocean simulations. The thermodynamic options typically +!! use conservative temperature and preformed salinity as conservative +!! state variables and a full nonlinear equation of state, but there +!! are also idealized adiabatic configurations of the model that use +!! fixed density layers. Version 6.0 of MOM continues in the long +!! tradition of a commitment to climate-quality ocean simulations +!! embodied in previous versions of MOM, even as it draws extensively +!! on the lessons learned in the development of the Generalized Ocean +!! Layered Dynamics (GOLD) ocean model, which was also primarily +!! developed at NOAA/GFDL. MOM has also benefited tremendously from +!! the FMS infrastructure, which it utilizes and shares with other +!! component models developed at NOAA/GFDL. +!! +!! When run is isopycnal-coordinate mode, the uppermost few layers +!! are often used to describe a bulk mixed layer, including the +!! effects of penetrating shortwave radiation. Either a split- +!! explicit time stepping scheme or a non-split scheme may be used +!! for the dynamics, while the time stepping may be split (and use +!! different numbers of steps to cover the same interval) for the +!! forcing, the thermodynamics, and for the dynamics. Most of the +!! numerics are second order accurate in space. MOM can run with an +!! absurdly thin minimum layer thickness. A variety of non-isopycnal +!! vertical coordinate options are under development, but all exploit +!! the advantages of a Lagrangian vertical coordinate, as discussed +!! in detail by Adcroft and Hallberg (Ocean Modelling, 2006). +!! +!! Details of the numerics and physical parameterizations are +!! provided in the appropriate source files. All of the available +!! options are selected at run-time by parsing the input files, +!! usually MOM_input and MOM_override, and the options choices are +!! then documented for each run in MOM_param_docs. +!! +!! MOM6 integrates the equations forward in time in three distinct +!! phases. In one phase, the dynamic equations for the velocities +!! and layer thicknesses are advanced, capturing the propagation of +!! external and internal inertia-gravity waves, Rossby waves, and +!! other strictly adiabatic processes, including lateral stresses, +!! vertical viscosity and momentum forcing, and interface height +!! diffusion (commonly called Gent-McWilliams diffusion in depth- +!! coordinate models). In the second phase, all tracers are advected +!! and diffused along the layers. The third phase applies diabatic +!! processes, vertical mixing of water properties, and perhaps +!! vertical remapping to cause the layers to track the desired +!! vertical coordinate. +!! +!! The present file (MOM.F90) orchestrates the main time stepping +!! loops. One time integration option for the dynamics uses a split +!! explicit time stepping scheme to rapidly step the barotropic +!! pressure and velocity fields. The barotropic velocities are +!! averaged over the baroclinic time step before they are used to +!! advect thickness and determine the baroclinic accelerations. As +!! described in Hallberg and Adcroft (2009), a barotropic correction +!! is applied to the time-mean layer velocities to ensure that the +!! sum of the layer transports agrees with the time-mean barotropic +!! transport, thereby ensuring that the estimates of the free surface +!! from the sum of the layer thicknesses agrees with the final free +!! surface height as calculated by the barotropic solver. The +!! barotropic and baroclinic velocities are kept consistent by +!! recalculating the barotropic velocities from the baroclinic +!! transports each time step. This scheme is described in Hallberg, +!! 1997, J. Comp. Phys. 135, 54-65 and in Hallberg and Adcroft, 2009, +!! Ocean Modelling, 29, 15-26. +!! +!! The other time integration options use non-split time stepping +!! schemes based on the 3-step third order Runge-Kutta scheme +!! described in Matsuno, 1966, J. Met. Soc. Japan, 44, 85-88, or on +!! a two-step quasi-2nd order Runge-Kutta scheme. These are much +!! slower than the split time-stepping scheme, but they are useful +!! for providing a more robust solution for debugging cases where the +!! more complicated split time-stepping scheme may be giving suspect +!! solutions. +!! +!! There are a range of closure options available. Horizontal +!! velocities are subject to a combination of horizontal biharmonic +!! and Laplacian friction (based on a stress tensor formalism) and a +!! vertical Fickian viscosity (perhaps using the kinematic viscosity +!! of water). The horizontal viscosities may be constant, spatially +!! varying or may be dynamically calculated using Smagorinsky's +!! approach. A diapycnal diffusion of density and thermodynamic +!! quantities is also allowed, but not required, as is horizontal +!! diffusion of interface heights (akin to the Gent-McWilliams +!! closure of geopotential coordinate models). The diapycnal mixing +!! may use a fixed diffusivity or it may use the shear Richardson +!! number dependent closure, like that described in Jackson et al. +!! (JPO, 2008). When there is diapycnal diffusion, it applies to +!! momentum as well. As this is in addition to the vertical viscosity, +!! the vertical Prandtl always exceeds 1. A refined bulk-mixed layer +!! is often used to describe the planetary boundary layer in realistic +!! ocean simulations. +!! +!! MOM has a number of noteworthy debugging capabilities. +!! Excessively large velocities are truncated and MOM will stop +!! itself after a number of such instances to keep the model from +!! crashing altogether. This is useful in diagnosing failures, +!! or (by accepting some truncations) it may be useful for getting +!! the model past the adjustment from an ill-balanced initial +!! condition. In addition, all of the accelerations in the columns +!! with excessively large velocities may be directed to a text file. +!! Parallelization errors may be diagnosed using the DEBUG option, +!! which causes extensive checksums to be written out along with +!! comments indicating where in the algorithm the sums originate and +!! what variable is being summed. The point where these checksums +!! differ between runs is usually a good indication of where in the +!! code the problem lies. All of the test cases provided with MOM +!! are routinely tested to ensure that they give bitwise identical +!! results regardless of the domain decomposition, or whether they +!! use static or dynamic memory allocation. +!! +!! \section section_structure Structure of MOM +!! +!! About 115 other files of source code and 4 header files comprise +!! the MOM code, although there are several hundred more files that +!! make up the FMS infrastructure upon which MOM is built. Each of +!! the MOM files contains comments documenting what it does, and +!! most of the file names are fairly self-evident. In addition, all +!! subroutines and data types are referenced via a module use, only +!! statement, and the module names are consistent with the file names, +!! so it is not too hard to find the source file for a subroutine. +!! +!! The typical MOM directory tree is as follows: +!! +!! \verbatim +!! ../MOM +!! |-- ac +!! |-- config_src +!! | |-- drivers +!! | ! |-- FMS_cap +!! | ! |-- ice_solo_driver +!! | ! |-- mct_cap +!! | ! |-- nuopc_cap +!! | ! |-- solo_driver +!! | ! `-- unit_drivers +!! | |-- external +!! | ! |-- drifters +!! | ! |-- GFDL_ocean_BGC +!! | ! `-- ODA_hooks +!! | |-- infra +!! | ! |-- FMS1 +!! | ! `-- FMS2 +!! | `-- memory +!! | ! |-- dynamic_nonsymmetric +!! | ! `-- dynamic_symmetric +!! |-- docs +!! |-- pkg +!! | |-- CVMix-src +!! | |-- ... +!! | `-- MOM6_DA_hooks +!! `-- src +!! |-- ALE +!! |-- core +!! |-- diagnostics +!! |-- equation_of_state +!! |-- framework +!! |-- ice_shelf +!! |-- initialization +!! |-- ocean_data_assim +!! |-- parameterizations +!! | |-- CVMix +!! | |-- lateral +!! | `-- vertical +!! |-- tracer +!! `-- user +!! \endverbatim +!! +!! Rather than describing each file here, selected directory contents +!! will be described to give a broad overview of the MOM code +!! structure. +!! +!! The directories under config_src contain files that are used for +!! configuring the code, for instance for coupled or ocean-only runs. +!! Only one or two of these directories are used in compiling any, +!! particular run. +!! +!! * config_src/drivers/FMS-cap: +!! The files here are used to couple MOM as a component in a larger +!! run driven by the FMS coupler. This includes code that converts +!! various forcing fields into the code structures and flux and unit +!! conventions used by MOM, and converts the MOM surface fields +!! back to the forms used by other FMS components. +!! +!! * config_src/drivers/nuopc-cap: +!! The files here are used to couple MOM as a component in a larger +!! run driven by the NUOPC coupler. This includes code that converts +!! various forcing fields into the code structures and flux and unit +!! conventions used by MOM, and converts the MOM surface fields +!! back to the forms used by other NUOPC components. +!! +!! * config_src/drivers/solo_driver: +!! The files here are include the _main driver that is used when +!! MOM is configured as an ocean-only model, as well as the files +!! that specify the surface forcing in this configuration. +!! +!! * config_src/external: +!! The files here are mostly just stubs, so that MOM6 can compile +!! with calls to the public interfaces external packages, but +!! without actually requiring those packages themselves. In more +!! elaborate configurations, would be linked to the actual code for +!! those external packages rather than these simple stubs. +!! +!! * config_src/memory/dynamic-symmetric: +!! The only file here is the version of MOM_memory.h that is used +!! for dynamic memory configurations of MOM. +!! +!! The directories under src contain most of the MOM files. These +!! files are used in every configuration using MOM. +!! +!! * src/core: +!! The files here constitute the MOM dynamic core. This directory +!! also includes files with the types that describe the model's +!! lateral grid and have defined types that are shared across +!! various MOM modules to allow for more succinct and flexible +!! subroutine argument lists. +!! +!! * src/diagnostics: +!! The files here calculate various diagnostics that are ancilliary +!! to the model itself. While most of these diagnostics do not +!! directly affect the model's solution, there are some, like the +!! calculation of the deformation radius, that are used in some +!! of the process parameterizations. +!! +!! * src/equation_of_state: +!! These files describe the physical properties of sea-water, +!! including both the equation of state and when it freezes. +!! +!! * src/framework: +!! These files provide infrastructure utilities for MOM. Many are +!! simply wrappers for capabilities provided by FMS, although others +!! provide capabilities (like the file_parser) that are unique to +!! MOM. When MOM is adapted to use a modeling infrastructure +!! distinct from FMS, most of the required changes are in this +!! directory. +!! +!! * src/initialization: +!! These are the files that are used to initialize the MOM grid +!! or provide the initial physical state for MOM. These files are +!! not intended to be modified, but provide a means for calling +!! user-specific initialization code like the examples in src/user. +!! +!! * src/parameterizations/lateral: +!! These files implement a number of quasi-lateral (along-layer) +!! process parameterizations, including lateral viscosities, +!! parameterizations of eddy effects, and the calculation of tidal +!! forcing. +!! +!! * src/parameterizations/vertical: +!! These files implement a number of vertical mixing or diabatic +!! processes, including the effects of vertical viscosity and +!! code to parameterize the planetary boundary layer. There is a +!! separate driver that orchestrates this portion of the algorithm, +!! and there is a diversity of parameterizations to be found here. +!! +!! * src/tracer: +!! These files handle the lateral transport and diffusion of +!! tracers, or are the code to implement various passive tracer +!! packages. Additional tracer packages are readily accommodated. +!! +!! * src/user: +!! These are either stub routines that a user could use to change +!! the model's initial conditions or forcing, or are examples that +!! implement specific test cases. These files can easily be hand +!! edited to create new analytically specified configurations. +!! +!! +!! Most simulations can be set up by modifying only the files +!! MOM_input, and possibly one or two of the files in src/user. +!! In addition, the diag_table (MOM_diag_table) will commonly be +!! modified to tailor the output to the needs of the question at +!! hand. The FMS utility mkmf works with a file called path_names +!! to build an appropriate makefile, and path_names should be edited +!! to reflect the actual location of the desired source code. +!! +!! The separate MOM-examples git repository provides a large number +!! of working configurations of MOM, along with reference solutions for several +!! different compilers on GFDL's latest large computer. The versions +!! of MOM_memory.h in these directories need not be used if dynamic +!! memory allocation is desired, and the answers should be unchanged. +!! +!! +!! There are 3 publicly visible subroutines in this file (MOM.F90). +!! * step_MOM steps MOM over a specified interval of time. +!! * MOM_initialize calls initialize and does other initialization +!! that does not warrant user modification. +!! * extract_surface_state determines the surface (bulk mixed layer +!! if traditional isopycnal vertical coordinate) properties of the +!! current model state and packages pointers to these fields into an +!! exported structure. +!! +!! The remaining subroutines in this file (src/core/MOM.F90) are: +!! * find_total_transport determines the barotropic mass transport. +!! * register_diags registers many diagnostic fields for the dynamic +!! solver, or of the main model variables. +!! * MOM_timing_init initializes various CPU time clocks. +!! * write_static_fields writes out various time-invariant fields. +!! * set_restart_fields is used to specify those fields that are +!! written to and read from the restart file. +!! +!! \section section_heat_budget Diagnosing MOM heat budget +!! +!! Here are some example heat budgets for the ALE version of MOM6. +!! +!! \subsection subsection_2d_heat_budget Depth integrated heat budget +!! +!! Depth integrated heat budget diagnostic for MOM. +!! +!! * OPOTTEMPTEND_2d = T_ADVECTION_XY_2d + OPOTTEMPPMDIFF_2d + HFDS + HFGEOU +!! +!! * T_ADVECTION_XY_2d = horizontal advection +!! * OPOTTEMPPMDIFF_2d = neutral diffusion +!! * HFDS = net surface boundary heat flux +!! * HFGEOU = geothermal heat flux +!! +!! * HFDS = net surface boundary heat flux entering the ocean +!! = rsntds + rlntds + hfls + hfss + heat_pme + hfsifrazil +!! +!! * More heat flux cross-checks +!! * hfds = net_heat_coupler + hfsifrazil + heat_pme +!! * heat_pme = heat_content_surfwater +!! = heat_content_massin + heat_content_massout +!! = heat_content_fprec + heat_content_cond + heat_content_vprec +!! + hfrunoffds + hfevapds + hfrainds +!! +!! \subsection subsection_3d_heat_budget Depth integrated heat budget +!! +!! Here is an example 3d heat budget diagnostic for MOM. +!! +!! * OPOTTEMPTEND = T_ADVECTION_XY + TH_TENDENCY_VERT_REMAP + OPOTTEMPDIFF + OPOTTEMPPMDIFF +!! + BOUNDARY_FORCING_HEAT_TENDENCY + FRAZIL_HEAT_TENDENCY +!! +!! * OPOTTEMPTEND = net tendency of heat as diagnosed in MOM.F90 +!! * T_ADVECTION_XY = heating of a cell from lateral advection +!! * TH_TENDENCY_VERT_REMAP = heating of a cell from vertical remapping +!! * OPOTTEMPDIFF = heating of a cell from diabatic diffusion +!! * OPOTTEMPPMDIFF = heating of a cell from neutral diffusion +!! * BOUNDARY_FORCING_HEAT_TENDENCY = heating of cell from boundary fluxes +!! * FRAZIL_HEAT_TENDENCY = heating of cell from frazil +!! +!! * TH_TENDENCY_VERT_REMAP has zero vertical sum, as it redistributes heat in vertical. +!! +!! * OPOTTEMPDIFF has zero vertical sum, as it redistributes heat in the vertical. +!! +!! * BOUNDARY_FORCING_HEAT_TENDENCY generally has 3d structure, with k > 1 contributions from +!! penetrative shortwave, and from other fluxes for the case when layers are tiny, in which +!! case MOM6 partitions tendencies into k > 1 layers. +!! +!! * FRAZIL_HEAT_TENDENCY generally has 3d structure, since MOM6 frazil calculation checks the +!! full ocean column. +!! +!! * FRAZIL_HEAT_TENDENCY[k=\@sum] = HFSIFRAZIL = column integrated frazil heating. +!! +!! * HFDS = FRAZIL_HEAT_TENDENCY[k=\@sum] + BOUNDARY_FORCING_HEAT_TENDENCY[k=\@sum] +!! +!! Here is an example 2d heat budget (depth summed) diagnostic for MOM. +!! +!! * OPOTTEMPTEND_2d = T_ADVECTION_XY_2d + OPOTTEMPPMDIFF_2d + HFDS +!! +!! +!! Here is an example 3d salt budget diagnostic for MOM. +!! +!! * OSALTTEND = S_ADVECTION_XY + SH_TENDENCY_VERT_REMAP + OSALTDIFF + OSALTPMDIFF +!! + BOUNDARY_FORCING_SALT_TENDENCY +!! +!! * OSALTTEND = net tendency of salt as diagnosed in MOM.F90 +!! * S_ADVECTION_XY = salt convergence to cell from lateral advection +!! * SH_TENDENCY_VERT_REMAP = salt convergence to cell from vertical remapping +!! * OSALTDIFF = salt convergence to cell from diabatic diffusion +!! * OSALTPMDIFF = salt convergence to cell from neutral diffusion +!! * BOUNDARY_FORCING_SALT_TENDENCY = salt convergence to cell from boundary fluxes +!! +!! * SH_TENDENCY_VERT_REMAP has zero vertical sum, as it redistributes salt in vertical. +!! +!! * OSALTDIFF has zero vertical sum, as it redistributes salt in the vertical. +!! +!! * BOUNDARY_FORCING_SALT_TENDENCY generally has 3d structure, with k > 1 contributions from +!! the case when layers are tiny, in which case MOM6 partitions tendencies into k > 1 layers. +!! +!! * SFDSI = BOUNDARY_FORCING_SALT_TENDENCY[k=\@sum] +!! +!! Here is an example 2d salt budget (depth summed) diagnostic for MOM. +!! +!! * OSALTTEND_2d = S_ADVECTION_XY_2d + OSALTPMDIFF_2d + SFDSI (+ SALT_FLUX_RESTORE) +!! +!! +!! +end module MOM diff --git a/core/MOM_CoriolisAdv.F90 b/core/MOM_CoriolisAdv.F90 new file mode 100644 index 0000000000..056b171ba8 --- /dev/null +++ b/core/MOM_CoriolisAdv.F90 @@ -0,0 +1,1355 @@ +!> Accelerations due to the Coriolis force and momentum advection +module MOM_CoriolisAdv + +! This file is part of MOM6. See LICENSE.md for the license. + +!> \author Robert Hallberg, April 1994 - June 2002 + +use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl +use MOM_diag_mediator, only : post_product_u, post_product_sum_u +use MOM_diag_mediator, only : post_product_v, post_product_sum_v +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W +use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S +use MOM_string_functions, only : uppercase +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : accel_diag_ptrs, porous_barrier_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_wave_interface, only : wave_parameters_CS + +implicit none ; private + +public CorAdCalc, CoriolisAdv_init, CoriolisAdv_end + +#include + +!> Control structure for mom_coriolisadv +type, public :: CoriolisAdv_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + integer :: Coriolis_Scheme !< Selects the discretization for the Coriolis terms. + !! Valid values are: + !! - SADOURNY75_ENERGY - Sadourny, 1975 + !! - ARAKAWA_HSU90 - Arakawa & Hsu, 1990, Energy & non-div. Enstrophy + !! - ROBUST_ENSTRO - Pseudo-enstrophy scheme + !! - SADOURNY75_ENSTRO - Sadourny, JAS 1975, Enstrophy + !! - ARAKAWA_LAMB81 - Arakawa & Lamb, MWR 1981, Energy & Enstrophy + !! - ARAKAWA_LAMB_BLEND - A blend of Arakawa & Lamb with Arakawa & Hsu and Sadourny energy. + !! The default, SADOURNY75_ENERGY, is the safest choice then the + !! deformation radius is poorly resolved. + integer :: KE_Scheme !< KE_SCHEME selects the discretization for + !! the kinetic energy. Valid values are: + !! KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV + integer :: PV_Adv_Scheme !< PV_ADV_SCHEME selects the discretization for PV advection + !! Valid values are: + !! - PV_ADV_CENTERED - centered (aka Sadourny, 75) + !! - PV_ADV_UPWIND1 - upwind, first order + real :: F_eff_max_blend !< The factor by which the maximum effective Coriolis + !! acceleration from any point can be increased when + !! blending different discretizations with the + !! ARAKAWA_LAMB_BLEND Coriolis scheme [nondim]. + !! This must be greater than 2.0, and is 4.0 by default. + real :: wt_lin_blend !< A weighting value beyond which the blending between + !! Sadourny and Arakawa & Hsu goes linearly to 0 [nondim]. + !! This must be between 1 and 1e-15, often 1/8. + logical :: no_slip !< If true, no slip boundary conditions are used. + !! Otherwise free slip boundary conditions are assumed. + !! The implementation of the free slip boundary + !! conditions on a C-grid is much cleaner than the + !! no slip boundary conditions. The use of free slip + !! b.c.s is strongly encouraged. The no slip b.c.s + !! are not implemented with the biharmonic viscosity. + logical :: bound_Coriolis !< If true, the Coriolis terms at u points are + !! bounded by the four estimates of (f+rv)v from the + !! four neighboring v points, and similarly at v + !! points. This option would have no effect on the + !! SADOURNY75_ENERGY scheme if it were possible to + !! use centered difference thickness fluxes. + logical :: Coriolis_En_Dis !< If CORIOLIS_EN_DIS is defined, two estimates of + !! the thickness fluxes are used to estimate the + !! Coriolis term, and the one that dissipates energy + !! relative to the other one is used. This is only + !! available at present if Coriolis scheme is + !! SADOURNY75_ENERGY. + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output. + !>@{ Diagnostic IDs + integer :: id_rv = -1, id_PV = -1, id_gKEu = -1, id_gKEv = -1 + integer :: id_rvxu = -1, id_rvxv = -1 + ! integer :: id_hf_gKEu = -1, id_hf_gKEv = -1 + integer :: id_hf_gKEu_2d = -1, id_hf_gKEv_2d = -1 + integer :: id_intz_gKEu_2d = -1, id_intz_gKEv_2d = -1 + ! integer :: id_hf_rvxu = -1, id_hf_rvxv = -1 + integer :: id_hf_rvxu_2d = -1, id_hf_rvxv_2d = -1 + integer :: id_h_gKEu = -1, id_h_gKEv = -1 + integer :: id_h_rvxu = -1, id_h_rvxv = -1 + integer :: id_intz_rvxu_2d = -1, id_intz_rvxv_2d = -1 + integer :: id_CAuS = -1, id_CAvS = -1 + !>@} +end type CoriolisAdv_CS + +!>@{ Enumeration values for Coriolis_Scheme +integer, parameter :: SADOURNY75_ENERGY = 1 +integer, parameter :: ARAKAWA_HSU90 = 2 +integer, parameter :: ROBUST_ENSTRO = 3 +integer, parameter :: SADOURNY75_ENSTRO = 4 +integer, parameter :: ARAKAWA_LAMB81 = 5 +integer, parameter :: AL_BLEND = 6 +character*(20), parameter :: SADOURNY75_ENERGY_STRING = "SADOURNY75_ENERGY" +character*(20), parameter :: ARAKAWA_HSU_STRING = "ARAKAWA_HSU90" +character*(20), parameter :: ROBUST_ENSTRO_STRING = "ROBUST_ENSTRO" +character*(20), parameter :: SADOURNY75_ENSTRO_STRING = "SADOURNY75_ENSTRO" +character*(20), parameter :: ARAKAWA_LAMB_STRING = "ARAKAWA_LAMB81" +character*(20), parameter :: AL_BLEND_STRING = "ARAKAWA_LAMB_BLEND" +!>@} +!>@{ Enumeration values for KE_Scheme +integer, parameter :: KE_ARAKAWA = 10 +integer, parameter :: KE_SIMPLE_GUDONOV = 11 +integer, parameter :: KE_GUDONOV = 12 +character*(20), parameter :: KE_ARAKAWA_STRING = "KE_ARAKAWA" +character*(20), parameter :: KE_SIMPLE_GUDONOV_STRING = "KE_SIMPLE_GUDONOV" +character*(20), parameter :: KE_GUDONOV_STRING = "KE_GUDONOV" +!>@} +!>@{ Enumeration values for PV_Adv_Scheme +integer, parameter :: PV_ADV_CENTERED = 21 +integer, parameter :: PV_ADV_UPWIND1 = 22 +character*(20), parameter :: PV_ADV_CENTERED_STRING = "PV_ADV_CENTERED" +character*(20), parameter :: PV_ADV_UPWIND1_STRING = "PV_ADV_UPWIND1" +!>@} + +contains + +!> Calculates the Coriolis and momentum advection contributions to the acceleration. +subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Waves) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uh !< Zonal transport u*h*dy + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vh !< Meridional transport v*h*dx + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: CAu !< Zonal acceleration due to Coriolis + !! and momentum advection [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: CAv !< Meridional acceleration due to Coriolis + !! and momentum advection [L T-2 ~> m s-2]. + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(accel_diag_ptrs), intent(inout) :: AD !< Storage for acceleration diagnostics + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(CoriolisAdv_CS), intent(in) :: CS !< Control structure for MOM_CoriolisAdv + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(Wave_parameters_CS), optional, pointer :: Waves !< An optional pointer to Stokes drift CS + + ! Local variables + real, dimension(SZIB_(G),SZJB_(G)) :: & + q, & ! Layer potential vorticity [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. + qS, & ! Layer Stokes vorticity [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. + Ih_q, & ! The inverse of thickness interpolated to q points [H-1 ~> m-1 or m2 kg-1]. + Area_q ! The sum of the ocean areas at the 4 adjacent thickness points [L2 ~> m2]. + + real, dimension(SZIB_(G),SZJ_(G)) :: & + a, b, c, d ! a, b, c, & d are combinations of the potential vorticities + ! surrounding an h grid point. At small scales, a = q/4, + ! b = q/4, etc. All are in [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1], + ! and use the indexing of the corresponding u point. + + real, dimension(SZI_(G),SZJ_(G)) :: & + Area_h, & ! The ocean area at h points [L2 ~> m2]. Area_h is used to find the + ! average thickness in the denominator of q. 0 for land points. + KE ! Kinetic energy per unit mass [L2 T-2 ~> m2 s-2], KE = (u^2 + v^2)/2. + real, dimension(SZIB_(G),SZJ_(G)) :: & + hArea_u, & ! The cell area weighted thickness interpolated to u points + ! times the effective areas [H L2 ~> m3 or kg]. + KEx, & ! The zonal gradient of Kinetic energy per unit mass [L T-2 ~> m s-2], + ! KEx = d/dx KE. + uh_center ! Transport based on arithmetic mean h at u-points [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G)) :: & + hArea_v, & ! The cell area weighted thickness interpolated to v points + ! times the effective areas [H L2 ~> m3 or kg]. + KEy, & ! The meridional gradient of Kinetic energy per unit mass [L T-2 ~> m s-2], + ! KEy = d/dy KE. + vh_center ! Transport based on arithmetic mean h at v-points [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJ_(G)) :: & + uh_min, uh_max, & ! The smallest and largest estimates of the zonal volume fluxes through + ! the faces (i.e. u*h*dy) [H L2 T-1 ~> m3 s-1 or kg s-1] + vh_min, vh_max, & ! The smallest and largest estimates of the meridional volume fluxes through + ! the faces (i.e. v*h*dx) [H L2 T-1 ~> m3 s-1 or kg s-1] + ep_u, ep_v ! Additional pseudo-Coriolis terms in the Arakawa and Lamb + ! discretization [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. + real, dimension(SZIB_(G),SZJB_(G)) :: & + dvdx, dudy, & ! Contributions to the circulation around q-points [L2 T-1 ~> m2 s-1] + dvSdx, duSdy, & ! idem. for Stokes drift [L2 T-1 ~> m2 s-1] + rel_vort, & ! Relative vorticity at q-points [T-1 ~> s-1]. + abs_vort, & ! Absolute vorticity at q-points [T-1 ~> s-1]. + stk_vort, & ! Stokes vorticity at q-points [T-1 ~> s-1]. + q2 ! Relative vorticity over thickness [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & + PV, & ! A diagnostic array of the potential vorticities [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. + RV ! A diagnostic array of the relative vorticities [T-1 ~> s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: CAuS ! Stokes contribution to CAu [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: CAvS ! Stokes contribution to CAv [L T-2 ~> m s-2] + real :: fv1, fv2, fv3, fv4 ! (f+rv)*v at the 4 points surrounding a u points[L T-2 ~> m s-2] + real :: fu1, fu2, fu3, fu4 ! -(f+rv)*u at the 4 points surrounding a v point [L T-2 ~> m s-2] + real :: max_fv, max_fu ! The maximum of the neighboring Coriolis accelerations [L T-2 ~> m s-2] + real :: min_fv, min_fu ! The minimum of the neighboring Coriolis accelerations [L T-2 ~> m s-2] + + real, parameter :: C1_12 = 1.0 / 12.0 ! C1_12 = 1/12 [nondim] + real, parameter :: C1_24 = 1.0 / 24.0 ! C1_24 = 1/24 [nondim] + real :: max_Ihq, min_Ihq ! The maximum and minimum of the nearby Ihq [H-1 ~> m-1 or m2 kg-1]. + real :: hArea_q ! The sum of area times thickness of the cells + ! surrounding a q point [H L2 ~> m3 or kg]. + real :: vol_neglect ! A volume so small that is expected to be + ! lost in roundoff [H L2 ~> m3 or kg]. + real :: temp1, temp2 ! Temporary variables [L2 T-2 ~> m2 s-2]. + real :: eps_vel ! A tiny, positive velocity [L T-1 ~> m s-1]. + + real :: uhc, vhc ! Centered estimates of uh and vh [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: uhm, vhm ! The input estimates of uh and vh [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: c1, c2, c3, slope ! Nondimensional parameters for the Coriolis limiter scheme [nondim] + + real :: Fe_m2 ! Temporary variable associated with the ARAKAWA_LAMB_BLEND scheme [nondim] + real :: rat_lin ! Temporary variable associated with the ARAKAWA_LAMB_BLEND scheme [nondim] + real :: rat_m1 ! The ratio of the maximum neighboring inverse thickness + ! to the minimum inverse thickness minus 1 [nondim]. rat_m1 >= 0. + real :: AL_wt ! The relative weight of the Arakawa & Lamb scheme to the + ! Arakawa & Hsu scheme [nondim], between 0 and 1. + real :: Sad_wt ! The relative weight of the Sadourny energy scheme to + ! the other two with the ARAKAWA_LAMB_BLEND scheme [nondim], + ! between 0 and 1. + + real :: Heff1, Heff2 ! Temporary effective H at U or V points [H ~> m or kg m-2]. + real :: Heff3, Heff4 ! Temporary effective H at U or V points [H ~> m or kg m-2]. + real :: h_tiny ! A very small thickness [H ~> m or kg m-2]. + real :: UHeff, VHeff ! More temporary variables [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: QUHeff,QVHeff ! More temporary variables [H L2 T-2 ~> m3 s-2 or kg s-2]. + integer :: i, j, k, n, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + logical :: Stokes_VF + +! To work, the following fields must be set outside of the usual +! is to ie range before this subroutine is called: +! v(is-1:ie+2,js-1:je+1), u(is-1:ie+1,js-1:je+2), h(is-1:ie+2,js-1:je+2), +! uh(is-1,ie,js:je+1) and vh(is:ie+1,js-1:je). + + if (.not.CS%initialized) call MOM_error(FATAL, & + "MOM_CoriolisAdv: Module must be initialized before it is used.") + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke + vol_neglect = GV%H_subroundoff * (1e-4 * US%m_to_L)**2 + eps_vel = 1.0e-10*US%m_s_to_L_T + h_tiny = GV%Angstrom_H ! Perhaps this should be set to h_neglect instead. + + !$OMP parallel do default(private) shared(Isq,Ieq,Jsq,Jeq,G,Area_h) + do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+2 + Area_h(i,j) = G%mask2dT(i,j) * G%areaT(i,j) + enddo ; enddo + if (associated(OBC)) then ; do n=1,OBC%number_of_segments + if (.not. OBC%segment(n)%on_pe) cycle + I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB + if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then + do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied) + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + Area_h(i,j+1) = Area_h(i,j) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + Area_h(i,j) = Area_h(i,j+1) + endif + enddo + elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then + do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed) + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + Area_h(i+1,j) = Area_h(i,j) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + Area_h(i,j) = Area_h(i+1,j) + endif + enddo + endif + enddo ; endif + !$OMP parallel do default(private) shared(Isq,Ieq,Jsq,Jeq,G,Area_h,Area_q) + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + Area_q(i,j) = (Area_h(i,j) + Area_h(i+1,j+1)) + & + (Area_h(i+1,j) + Area_h(i,j+1)) + enddo ; enddo + + Stokes_VF = .false. + if (present(Waves)) then ; if (associated(Waves)) then + Stokes_VF = Waves%Stokes_VF + endif ; endif + + !$OMP parallel do default(private) shared(u,v,h,uh,vh,CAu,CAv,G,GV,CS,AD,Area_h,Area_q,& + !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,vol_neglect,h_tiny,OBC,eps_vel, & + !$OMP pbv, Stokes_VF) + do k=1,nz + + ! Here the second order accurate layer potential vorticities, q, + ! are calculated. hq is second order accurate in space. Relative + ! vorticity is second order accurate everywhere with free slip b.c.s, + ! but only first order accurate at boundaries with no slip b.c.s. + ! First calculate the contributions to the circulation around the q-point. + if (Stokes_VF) then + if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + dvSdx(I,J) = ((-Waves%us_y(i+1,J,k))*G%dyCv(i+1,J) - & + (-Waves%us_y(i,J,k))*G%dyCv(i,J)) + duSdy(I,J) = ((-Waves%us_x(I,j+1,k))*G%dxCu(I,j+1) - & + (-Waves%us_x(I,j,k))*G%dxCu(I,j)) + enddo; enddo + endif + if (.not. Waves%Passive_Stokes_VF) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + dvdx(I,J) = ((v(i+1,J,k)-Waves%us_y(i+1,J,k))*G%dyCv(i+1,J) - & + (v(i,J,k)-Waves%us_y(i,J,k))*G%dyCv(i,J)) + dudy(I,J) = ((u(I,j+1,k)-Waves%us_x(I,j+1,k))*G%dxCu(I,j+1) - & + (u(I,j,k)-Waves%us_x(I,j,k))*G%dxCu(I,j)) + enddo; enddo + else + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J) - v(i,J,k)*G%dyCv(i,J)) + dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1) - u(I,j,k)*G%dxCu(I,j)) + enddo; enddo + endif + else + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J) - v(i,J,k)*G%dyCv(i,J)) + dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1) - u(I,j,k)*G%dxCu(I,j)) + enddo; enddo + endif + do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + hArea_v(i,J) = 0.5*(Area_h(i,j) * h(i,j,k) + Area_h(i,j+1) * h(i,j+1,k)) + enddo ; enddo + do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 + hArea_u(I,j) = 0.5*(Area_h(i,j) * h(i,j,k) + Area_h(i+1,j) * h(i+1,j,k)) + enddo ; enddo + + if (CS%Coriolis_En_Dis) then + do j=Jsq,Jeq+1 ; do I=is-1,ie + uh_center(I,j) = 0.5 * ((G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k)) * u(I,j,k)) * (h(i,j,k) + h(i+1,j,k)) + enddo ; enddo + do J=js-1,je ; do i=Isq,Ieq+1 + vh_center(i,J) = 0.5 * ((G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k)) * v(i,J,k)) * (h(i,j,k) + h(i,j+1,k)) + enddo ; enddo + endif + + ! Adjust circulation components to relative vorticity and thickness projected onto + ! velocity points on open boundaries. + if (associated(OBC)) then ; do n=1,OBC%number_of_segments + if (.not. OBC%segment(n)%on_pe) cycle + I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB + if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then + if (OBC%zero_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + dvdx(I,J) = 0. ; dudy(I,J) = 0. + enddo ; endif + if (OBC%freeslip_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + dudy(I,J) = 0. + enddo ; endif + if (OBC%computed_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%dxCu(I,j) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + dudy(I,J) = 2.0*(u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dxCu(I,j+1) + endif + enddo ; endif + if (OBC%specified_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j)*G%dyBu(I,J) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j+1)*G%dyBu(I,J) + endif + enddo ; endif + + ! Project thicknesses across OBC points with a no-gradient condition. + do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied) + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + hArea_v(i,J) = 0.5 * (Area_h(i,j) + Area_h(i,j+1)) * h(i,j,k) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + hArea_v(i,J) = 0.5 * (Area_h(i,j) + Area_h(i,j+1)) * h(i,j+1,k) + endif + enddo + + if (CS%Coriolis_En_Dis) then + do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied) + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + vh_center(i,J) = (G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k)) * v(i,J,k) * h(i,j,k) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + vh_center(i,J) = (G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k)) * v(i,J,k) * h(i,j+1,k) + endif + enddo + endif + elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then + if (OBC%zero_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + dvdx(I,J) = 0. ; dudy(I,J) = 0. + enddo ; endif + if (OBC%freeslip_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + dvdx(I,J) = 0. + enddo ; endif + if (OBC%computed_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%dyCv(i,J) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + dvdx(I,J) = 2.0*(v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dyCv(i+1,J) + endif + enddo ; endif + if (OBC%specified_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i,J)*G%dxBu(I,J) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i+1,J)*G%dxBu(I,J) + endif + enddo ; endif + + ! Project thicknesses across OBC points with a no-gradient condition. + do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed) + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + hArea_u(I,j) = 0.5*(Area_h(i,j) + Area_h(i+1,j)) * h(i,j,k) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + hArea_u(I,j) = 0.5*(Area_h(i,j) + Area_h(i+1,j)) * h(i+1,j,k) + endif + enddo + if (CS%Coriolis_En_Dis) then + do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed) + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + uh_center(I,j) = (G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k)) * u(I,j,k) * h(i,j,k) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + uh_center(I,j) = (G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k)) * u(I,j,k) * h(i+1,j,k) + endif + enddo + endif + endif + enddo ; endif + + if (associated(OBC)) then ; do n=1,OBC%number_of_segments + if (.not. OBC%segment(n)%on_pe) cycle + ! Now project thicknesses across cell-corner points in the OBCs. The two + ! projections have to occur in sequence and can not be combined easily. + I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB + if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then + do I = max(Isq-1,OBC%segment(n)%HI%IsdB), min(Ieq+1,OBC%segment(n)%HI%IedB) + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + if (Area_h(i,j) + Area_h(i+1,j) > 0.0) then + hArea_u(I,j+1) = hArea_u(I,j) * ((Area_h(i,j+1) + Area_h(i+1,j+1)) / & + (Area_h(i,j) + Area_h(i+1,j))) + else ; hArea_u(I,j+1) = 0.0 ; endif + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + if (Area_h(i,j+1) + Area_h(i+1,j+1) > 0.0) then + hArea_u(I,j) = hArea_u(I,j+1) * ((Area_h(i,j) + Area_h(i+1,j)) / & + (Area_h(i,j+1) + Area_h(i+1,j+1))) + else ; hArea_u(I,j) = 0.0 ; endif + endif + enddo + elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then + do J = max(Jsq-1,OBC%segment(n)%HI%JsdB), min(Jeq+1,OBC%segment(n)%HI%JedB) + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + if (Area_h(i,j) + Area_h(i,j+1) > 0.0) then + hArea_v(i+1,J) = hArea_v(i,J) * ((Area_h(i+1,j) + Area_h(i+1,j+1)) / & + (Area_h(i,j) + Area_h(i,j+1))) + else ; hArea_v(i+1,J) = 0.0 ; endif + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + hArea_v(i,J) = 0.5 * (Area_h(i,j) + Area_h(i,j+1)) * h(i,j+1,k) + if (Area_h(i+1,j) + Area_h(i+1,j+1) > 0.0) then + hArea_v(i,J) = hArea_v(i+1,J) * ((Area_h(i,j) + Area_h(i,j+1)) / & + (Area_h(i+1,j) + Area_h(i+1,j+1))) + else ; hArea_v(i,J) = 0.0 ; endif + endif + enddo + endif + enddo ; endif + + if (CS%no_slip) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + rel_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) + enddo; enddo + if (Stokes_VF) then + if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + stk_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvSdx(I,J) - duSdy(I,J)) * G%IareaBu(I,J) + enddo; enddo + endif + endif + else + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + rel_vort(I,J) = G%mask2dBu(I,J) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) + enddo; enddo + if (Stokes_VF) then + if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + stk_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvSdx(I,J) - duSdy(I,J)) * G%IareaBu(I,J) + enddo; enddo + endif + endif + endif + + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + abs_vort(I,J) = G%CoriolisBu(I,J) + rel_vort(I,J) + enddo ; enddo + + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + hArea_q = (hArea_u(I,j) + hArea_u(I,j+1)) + (hArea_v(i,J) + hArea_v(i+1,J)) + Ih_q(I,J) = Area_q(I,J) / (hArea_q + vol_neglect) + q(I,J) = abs_vort(I,J) * Ih_q(I,J) + enddo; enddo + + if (Stokes_VF) then + if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + qS(I,J) = stk_vort(I,J) * Ih_q(I,J) + enddo; enddo + endif + endif + + if (CS%id_rv > 0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + RV(I,J,k) = rel_vort(I,J) + enddo ; enddo + endif + + if (CS%id_PV > 0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + PV(I,J,k) = q(I,J) + enddo ; enddo + endif + + if (associated(AD%rv_x_v) .or. associated(AD%rv_x_u)) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + q2(I,J) = rel_vort(I,J) * Ih_q(I,J) + enddo ; enddo + endif + + ! a, b, c, and d are combinations of neighboring potential + ! vorticities which form the Arakawa and Hsu vorticity advection + ! scheme. All are defined at u grid points. + + if (CS%Coriolis_Scheme == ARAKAWA_HSU90) then + do j=Jsq,Jeq+1 + do I=is-1,Ieq + a(I,j) = (q(I,J) + (q(I+1,J) + q(I,J-1))) * C1_12 + d(I,j) = ((q(I,J) + q(I+1,J-1)) + q(I,J-1)) * C1_12 + enddo + do I=Isq,Ieq + b(I,j) = (q(I,J) + (q(I-1,J) + q(I,J-1))) * C1_12 + c(I,j) = ((q(I,J) + q(I-1,J-1)) + q(I,J-1)) * C1_12 + enddo + enddo + elseif (CS%Coriolis_Scheme == ARAKAWA_LAMB81) then + do j=Jsq,Jeq+1 ; do I=Isq,Ieq+1 + a(I-1,j) = (2.0*(q(I,J) + q(I-1,J-1)) + (q(I-1,J) + q(I,J-1))) * C1_24 + d(I-1,j) = ((q(I,j) + q(I-1,J-1)) + 2.0*(q(I-1,J) + q(I,J-1))) * C1_24 + b(I,j) = ((q(I,J) + q(I-1,J-1)) + 2.0*(q(I-1,J) + q(I,J-1))) * C1_24 + c(I,j) = (2.0*(q(I,J) + q(I-1,J-1)) + (q(I-1,J) + q(I,J-1))) * C1_24 + ep_u(i,j) = ((q(I,J) - q(I-1,J-1)) + (q(I-1,J) - q(I,J-1))) * C1_24 + ep_v(i,j) = (-(q(I,J) - q(I-1,J-1)) + (q(I-1,J) - q(I,J-1))) * C1_24 + enddo ; enddo + elseif (CS%Coriolis_Scheme == AL_BLEND) then + Fe_m2 = CS%F_eff_max_blend - 2.0 + rat_lin = 1.5 * Fe_m2 / max(CS%wt_lin_blend, 1.0e-16) + + ! This allows the code to always give Sadourny Energy + if (CS%F_eff_max_blend <= 2.0) then ; Fe_m2 = -1. ; rat_lin = -1.0 ; endif + + do j=Jsq,Jeq+1 ; do I=Isq,Ieq+1 + min_Ihq = MIN(Ih_q(I-1,J-1), Ih_q(I,J-1), Ih_q(I-1,J), Ih_q(I,J)) + max_Ihq = MAX(Ih_q(I-1,J-1), Ih_q(I,J-1), Ih_q(I-1,J), Ih_q(I,J)) + rat_m1 = 1.0e15 + if (max_Ihq < 1.0e15*min_Ihq) rat_m1 = max_Ihq / min_Ihq - 1.0 + ! The weights used here are designed to keep the effective Coriolis + ! acceleration from any one point on its neighbors within a factor + ! of F_eff_max. The minimum permitted value is 2 (the factor for + ! Sadourny's energy conserving scheme). + + ! Determine the relative weights of Arakawa & Lamb vs. Arakawa and Hsu. + if (rat_m1 <= Fe_m2) then ; AL_wt = 1.0 + elseif (rat_m1 < 1.5*Fe_m2) then ; AL_wt = 3.0*Fe_m2 / rat_m1 - 2.0 + else ; AL_wt = 0.0 ; endif + + ! Determine the relative weights of Sadourny Energy vs. the other two. + if (rat_m1 <= 1.5*Fe_m2) then ; Sad_wt = 0.0 + elseif (rat_m1 <= rat_lin) then + Sad_wt = 1.0 - (1.5*Fe_m2) / rat_m1 + elseif (rat_m1 < 2.0*rat_lin) then + Sad_wt = 1.0 - (CS%wt_lin_blend / rat_lin) * (rat_m1 - 2.0*rat_lin) + else ; Sad_wt = 1.0 ; endif + + a(I-1,j) = Sad_wt * 0.25 * q(I-1,J) + (1.0 - Sad_wt) * & + ( ((2.0-AL_wt)* q(I-1,J) + AL_wt*q(I,J-1)) + & + 2.0 * (q(I,J) + q(I-1,J-1)) ) * C1_24 + d(I-1,j) = Sad_wt * 0.25 * q(I-1,J-1) + (1.0 - Sad_wt) * & + ( ((2.0-AL_wt)* q(I-1,J-1) + AL_wt*q(I,J)) + & + 2.0 * (q(I-1,J) + q(I,J-1)) ) * C1_24 + b(I,j) = Sad_wt * 0.25 * q(I,J) + (1.0 - Sad_wt) * & + ( ((2.0-AL_wt)* q(I,J) + AL_wt*q(I-1,J-1)) + & + 2.0 * (q(I-1,J) + q(I,J-1)) ) * C1_24 + c(I,j) = Sad_wt * 0.25 * q(I,J-1) + (1.0 - Sad_wt) * & + ( ((2.0-AL_wt)* q(I,J-1) + AL_wt*q(I-1,J)) + & + 2.0 * (q(I,J) + q(I-1,J-1)) ) * C1_24 + ep_u(i,j) = AL_wt * ((q(I,J) - q(I-1,J-1)) + (q(I-1,J) - q(I,J-1))) * C1_24 + ep_v(i,j) = AL_wt * (-(q(I,J) - q(I-1,J-1)) + (q(I-1,J) - q(I,J-1))) * C1_24 + enddo ; enddo + endif + + if (CS%Coriolis_En_Dis) then + ! c1 = 1.0-1.5*RANGE ; c2 = 1.0-RANGE ; c3 = 2.0 ; slope = 0.5 + c1 = 1.0-1.5*0.5 ; c2 = 1.0-0.5 ; c3 = 2.0 ; slope = 0.5 + + do j=Jsq,Jeq+1 ; do I=is-1,ie + uhc = uh_center(I,j) + uhm = uh(I,j,k) + ! This sometimes matters with some types of open boundary conditions. + if (G%dy_Cu(I,j) == 0.0) uhc = uhm + + if (abs(uhc) < 0.1*abs(uhm)) then + uhm = 10.0*uhc + elseif (abs(uhc) > c1*abs(uhm)) then + if (abs(uhc) < c2*abs(uhm)) then ; uhc = (3.0*uhc+(1.0-c2*3.0)*uhm) + elseif (abs(uhc) <= c3*abs(uhm)) then ; uhc = uhm + else ; uhc = slope*uhc+(1.0-c3*slope)*uhm + endif + endif + + if (uhc > uhm) then + uh_min(I,j) = uhm ; uh_max(I,j) = uhc + else + uh_max(I,j) = uhm ; uh_min(I,j) = uhc + endif + enddo ; enddo + do J=js-1,je ; do i=Isq,Ieq+1 + vhc = vh_center(i,J) + vhm = vh(i,J,k) + ! This sometimes matters with some types of open boundary conditions. + if (G%dx_Cv(i,J) == 0.0) vhc = vhm + + if (abs(vhc) < 0.1*abs(vhm)) then + vhm = 10.0*vhc + elseif (abs(vhc) > c1*abs(vhm)) then + if (abs(vhc) < c2*abs(vhm)) then ; vhc = (3.0*vhc+(1.0-c2*3.0)*vhm) + elseif (abs(vhc) <= c3*abs(vhm)) then ; vhc = vhm + else ; vhc = slope*vhc+(1.0-c3*slope)*vhm + endif + endif + + if (vhc > vhm) then + vh_min(i,J) = vhm ; vh_max(i,J) = vhc + else + vh_max(i,J) = vhm ; vh_min(i,J) = vhc + endif + enddo ; enddo + endif + + ! Calculate KE and the gradient of KE + call gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) + + ! Calculate the tendencies of zonal velocity due to the Coriolis + ! force and momentum advection. On a Cartesian grid, this is + ! CAu = q * vh - d(KE)/dx. + if (CS%Coriolis_Scheme == SADOURNY75_ENERGY) then + if (CS%Coriolis_En_Dis) then + ! Energy dissipating biased scheme, Hallberg 200x + do j=js,je ; do I=Isq,Ieq + if (q(I,J)*u(I,j,k) == 0.0) then + temp1 = q(I,J) * ( (vh_max(i,j)+vh_max(i+1,j)) & + + (vh_min(i,j)+vh_min(i+1,j)) )*0.5 + elseif (q(I,J)*u(I,j,k) < 0.0) then + temp1 = q(I,J) * (vh_max(i,j)+vh_max(i+1,j)) + else + temp1 = q(I,J) * (vh_min(i,j)+vh_min(i+1,j)) + endif + if (q(I,J-1)*u(I,j,k) == 0.0) then + temp2 = q(I,J-1) * ( (vh_max(i,j-1)+vh_max(i+1,j-1)) & + + (vh_min(i,j-1)+vh_min(i+1,j-1)) )*0.5 + elseif (q(I,J-1)*u(I,j,k) < 0.0) then + temp2 = q(I,J-1) * (vh_max(i,j-1)+vh_max(i+1,j-1)) + else + temp2 = q(I,J-1) * (vh_min(i,j-1)+vh_min(i+1,j-1)) + endif + CAu(I,j,k) = 0.25 * G%IdxCu(I,j) * (temp1 + temp2) + enddo ; enddo + else + ! Energy conserving scheme, Sadourny 1975 + do j=js,je ; do I=Isq,Ieq + CAu(I,j,k) = 0.25 * & + (q(I,J) * (vh(i+1,J,k) + vh(i,J,k)) + & + q(I,J-1) * (vh(i,J-1,k) + vh(i+1,J-1,k))) * G%IdxCu(I,j) + enddo ; enddo + endif + elseif (CS%Coriolis_Scheme == SADOURNY75_ENSTRO) then + do j=js,je ; do I=Isq,Ieq + CAu(I,j,k) = 0.125 * (G%IdxCu(I,j) * (q(I,J) + q(I,J-1))) * & + ((vh(i+1,J,k) + vh(i,J,k)) + (vh(i,J-1,k) + vh(i+1,J-1,k))) + enddo ; enddo + elseif ((CS%Coriolis_Scheme == ARAKAWA_HSU90) .or. & + (CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. & + (CS%Coriolis_Scheme == AL_BLEND)) then + ! (Global) Energy and (Local) Enstrophy conserving, Arakawa & Hsu 1990 + do j=js,je ; do I=Isq,Ieq + CAu(I,j,k) = ((a(I,j) * vh(i+1,J,k) + c(I,j) * vh(i,J-1,k)) + & + (b(I,j) * vh(i,J,k) + d(I,j) * vh(i+1,J-1,k))) * G%IdxCu(I,j) + enddo ; enddo + elseif (CS%Coriolis_Scheme == ROBUST_ENSTRO) then + ! An enstrophy conserving scheme robust to vanishing layers + ! Note: Heffs are in lieu of h_at_v that should be returned by the + ! continuity solver. AJA + do j=js,je ; do I=Isq,Ieq + Heff1 = abs(vh(i,J,k) * G%IdxCv(i,J)) / (eps_vel+abs(v(i,J,k))) + Heff1 = max(Heff1, min(h(i,j,k),h(i,j+1,k))) + Heff1 = min(Heff1, max(h(i,j,k),h(i,j+1,k))) + Heff2 = abs(vh(i,J-1,k) * G%IdxCv(i,J-1)) / (eps_vel+abs(v(i,J-1,k))) + Heff2 = max(Heff2, min(h(i,j-1,k),h(i,j,k))) + Heff2 = min(Heff2, max(h(i,j-1,k),h(i,j,k))) + Heff3 = abs(vh(i+1,J,k) * G%IdxCv(i+1,J)) / (eps_vel+abs(v(i+1,J,k))) + Heff3 = max(Heff3, min(h(i+1,j,k),h(i+1,j+1,k))) + Heff3 = min(Heff3, max(h(i+1,j,k),h(i+1,j+1,k))) + Heff4 = abs(vh(i+1,J-1,k) * G%IdxCv(i+1,J-1)) / (eps_vel+abs(v(i+1,J-1,k))) + Heff4 = max(Heff4, min(h(i+1,j-1,k),h(i+1,j,k))) + Heff4 = min(Heff4, max(h(i+1,j-1,k),h(i+1,j,k))) + if (CS%PV_Adv_Scheme == PV_ADV_CENTERED) then + CAu(I,j,k) = 0.5*(abs_vort(I,J)+abs_vort(I,J-1)) * & + ((vh(i,J,k) + vh(i+1,J-1,k)) + (vh(i,J-1,k) + vh(i+1,J,k)) ) / & + (h_tiny + ((Heff1+Heff4) + (Heff2+Heff3)) ) * G%IdxCu(I,j) + elseif (CS%PV_Adv_Scheme == PV_ADV_UPWIND1) then + VHeff = ((vh(i,J,k) + vh(i+1,J-1,k)) + (vh(i,J-1,k) + vh(i+1,J,k)) ) + QVHeff = 0.5*( (abs_vort(I,J)+abs_vort(I,J-1))*VHeff & + -(abs_vort(I,J)-abs_vort(I,J-1))*abs(VHeff) ) + CAu(I,j,k) = (QVHeff / ( h_tiny + ((Heff1+Heff4) + (Heff2+Heff3)) ) ) * G%IdxCu(I,j) + endif + enddo ; enddo + endif + ! Add in the additional terms with Arakawa & Lamb. + if ((CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. & + (CS%Coriolis_Scheme == AL_BLEND)) then ; do j=js,je ; do I=Isq,Ieq + CAu(I,j,k) = CAu(I,j,k) + & + (ep_u(i,j)*uh(I-1,j,k) - ep_u(i+1,j)*uh(I+1,j,k)) * G%IdxCu(I,j) + enddo ; enddo ; endif + + if (Stokes_VF) then + if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then + ! Computing the diagnostic Stokes contribution to CAu + do j=js,je ; do I=Isq,Ieq + CAuS(I,j,k) = 0.25 * & + (qS(I,J) * (vh(i+1,J,k) + vh(i,J,k)) + & + qS(I,J-1) * (vh(i,J-1,k) + vh(i+1,J-1,k))) * G%IdxCu(I,j) + enddo ; enddo + endif + endif + + if (CS%bound_Coriolis) then + do j=js,je ; do I=Isq,Ieq + fv1 = abs_vort(I,J) * v(i+1,J,k) + fv2 = abs_vort(I,J) * v(i,J,k) + fv3 = abs_vort(I,J-1) * v(i+1,J-1,k) + fv4 = abs_vort(I,J-1) * v(i,J-1,k) + + max_fv = max(fv1, fv2, fv3, fv4) + min_fv = min(fv1, fv2, fv3, fv4) + + CAu(I,j,k) = min(CAu(I,j,k), max_fv) + CAu(I,j,k) = max(CAu(I,j,k), min_fv) + enddo ; enddo + endif + + ! Term - d(KE)/dx. + do j=js,je ; do I=Isq,Ieq + CAu(I,j,k) = CAu(I,j,k) - KEx(I,j) + enddo ; enddo + + if (associated(AD%gradKEu)) then + do j=js,je ; do I=Isq,Ieq + AD%gradKEu(I,j,k) = -KEx(I,j) + enddo ; enddo + endif + + ! Calculate the tendencies of meridional velocity due to the Coriolis + ! force and momentum advection. On a Cartesian grid, this is + ! CAv = - q * uh - d(KE)/dy. + if (CS%Coriolis_Scheme == SADOURNY75_ENERGY) then + if (CS%Coriolis_En_Dis) then + ! Energy dissipating biased scheme, Hallberg 200x + do J=Jsq,Jeq ; do i=is,ie + if (q(I-1,J)*v(i,J,k) == 0.0) then + temp1 = q(I-1,J) * ( (uh_max(i-1,j)+uh_max(i-1,j+1)) & + + (uh_min(i-1,j)+uh_min(i-1,j+1)) )*0.5 + elseif (q(I-1,J)*v(i,J,k) > 0.0) then + temp1 = q(I-1,J) * (uh_max(i-1,j)+uh_max(i-1,j+1)) + else + temp1 = q(I-1,J) * (uh_min(i-1,j)+uh_min(i-1,j+1)) + endif + if (q(I,J)*v(i,J,k) == 0.0) then + temp2 = q(I,J) * ( (uh_max(i,j)+uh_max(i,j+1)) & + + (uh_min(i,j)+uh_min(i,j+1)) )*0.5 + elseif (q(I,J)*v(i,J,k) > 0.0) then + temp2 = q(I,J) * (uh_max(i,j)+uh_max(i,j+1)) + else + temp2 = q(I,J) * (uh_min(i,j)+uh_min(i,j+1)) + endif + CAv(i,J,k) = -0.25 * G%IdyCv(i,J) * (temp1 + temp2) + enddo ; enddo + else + ! Energy conserving scheme, Sadourny 1975 + do J=Jsq,Jeq ; do i=is,ie + CAv(i,J,k) = - 0.25* & + (q(I-1,J)*(uh(I-1,j,k) + uh(I-1,j+1,k)) + & + q(I,J)*(uh(I,j,k) + uh(I,j+1,k))) * G%IdyCv(i,J) + enddo ; enddo + endif + elseif (CS%Coriolis_Scheme == SADOURNY75_ENSTRO) then + do J=Jsq,Jeq ; do i=is,ie + CAv(i,J,k) = -0.125 * (G%IdyCv(i,J) * (q(I-1,J) + q(I,J))) * & + ((uh(I-1,j,k) + uh(I-1,j+1,k)) + (uh(I,j,k) + uh(I,j+1,k))) + enddo ; enddo + elseif ((CS%Coriolis_Scheme == ARAKAWA_HSU90) .or. & + (CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. & + (CS%Coriolis_Scheme == AL_BLEND)) then + ! (Global) Energy and (Local) Enstrophy conserving, Arakawa & Hsu 1990 + do J=Jsq,Jeq ; do i=is,ie + CAv(i,J,k) = - ((a(I-1,j) * uh(I-1,j,k) + & + c(I,j+1) * uh(I,j+1,k)) & + + (b(I,j) * uh(I,j,k) + & + d(I-1,j+1) * uh(I-1,j+1,k))) * G%IdyCv(i,J) + enddo ; enddo + elseif (CS%Coriolis_Scheme == ROBUST_ENSTRO) then + ! An enstrophy conserving scheme robust to vanishing layers + ! Note: Heffs are in lieu of h_at_u that should be returned by the + ! continuity solver. AJA + do J=Jsq,Jeq ; do i=is,ie + Heff1 = abs(uh(I,j,k) * G%IdyCu(I,j)) / (eps_vel+abs(u(I,j,k))) + Heff1 = max(Heff1, min(h(i,j,k),h(i+1,j,k))) + Heff1 = min(Heff1, max(h(i,j,k),h(i+1,j,k))) + Heff2 = abs(uh(I-1,j,k) * G%IdyCu(I-1,j)) / (eps_vel+abs(u(I-1,j,k))) + Heff2 = max(Heff2, min(h(i-1,j,k),h(i,j,k))) + Heff2 = min(Heff2, max(h(i-1,j,k),h(i,j,k))) + Heff3 = abs(uh(I,j+1,k) * G%IdyCu(I,j+1)) / (eps_vel+abs(u(I,j+1,k))) + Heff3 = max(Heff3, min(h(i,j+1,k),h(i+1,j+1,k))) + Heff3 = min(Heff3, max(h(i,j+1,k),h(i+1,j+1,k))) + Heff4 = abs(uh(I-1,j+1,k) * G%IdyCu(I-1,j+1)) / (eps_vel+abs(u(I-1,j+1,k))) + Heff4 = max(Heff4, min(h(i-1,j+1,k),h(i,j+1,k))) + Heff4 = min(Heff4, max(h(i-1,j+1,k),h(i,j+1,k))) + if (CS%PV_Adv_Scheme == PV_ADV_CENTERED) then + CAv(i,J,k) = - 0.5*(abs_vort(I,J)+abs_vort(I-1,J)) * & + ((uh(I ,j ,k)+uh(I-1,j+1,k)) + & + (uh(I-1,j ,k)+uh(I ,j+1,k)) ) / & + (h_tiny + ((Heff1+Heff4) +(Heff2+Heff3)) ) * G%IdyCv(i,J) + elseif (CS%PV_Adv_Scheme == PV_ADV_UPWIND1) then + UHeff = ((uh(I ,j ,k)+uh(I-1,j+1,k)) + & + (uh(I-1,j ,k)+uh(I ,j+1,k)) ) + QUHeff = 0.5*( (abs_vort(I,J)+abs_vort(I-1,J))*UHeff & + -(abs_vort(I,J)-abs_vort(I-1,J))*abs(UHeff) ) + CAv(i,J,k) = - QUHeff / & + (h_tiny + ((Heff1+Heff4) +(Heff2+Heff3)) ) * G%IdyCv(i,J) + endif + enddo ; enddo + endif + ! Add in the additonal terms with Arakawa & Lamb. + if ((CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. & + (CS%Coriolis_Scheme == AL_BLEND)) then ; do J=Jsq,Jeq ; do i=is,ie + CAv(i,J,k) = CAv(i,J,k) + & + (ep_v(i,j)*vh(i,J-1,k) - ep_v(i,j+1)*vh(i,J+1,k)) * G%IdyCv(i,J) + enddo ; enddo ; endif + + if (Stokes_VF) then + if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then + ! Computing the diagnostic Stokes contribution to CAv + do J=Jsq,Jeq ; do i=is,ie + CAvS(I,j,k) = 0.25 * & + (qS(I,J) * (uh(I,j+1,k) + uh(I,j,k)) + & + qS(I,J-1) * (uh(I-1,j,k) + uh(I-1,j+1,k))) * G%IdyCv(i,J) + enddo; enddo + endif + endif + + if (CS%bound_Coriolis) then + do J=Jsq,Jeq ; do i=is,ie + fu1 = -abs_vort(I,J) * u(I,j+1,k) + fu2 = -abs_vort(I,J) * u(I,j,k) + fu3 = -abs_vort(I-1,J) * u(I-1,j+1,k) + fu4 = -abs_vort(I-1,J) * u(I-1,j,k) + + max_fu = max(fu1, fu2, fu3, fu4) + min_fu = min(fu1, fu2, fu3, fu4) + + CAv(I,j,k) = min(CAv(I,j,k), max_fu) + CAv(I,j,k) = max(CAv(I,j,k), min_fu) + enddo ; enddo + endif + + ! Term - d(KE)/dy. + do J=Jsq,Jeq ; do i=is,ie + CAv(i,J,k) = CAv(i,J,k) - KEy(i,J) + enddo ; enddo + if (associated(AD%gradKEv)) then + do J=Jsq,Jeq ; do i=is,ie + AD%gradKEv(i,J,k) = -KEy(i,J) + enddo ; enddo + endif + + if (associated(AD%rv_x_u) .or. associated(AD%rv_x_v)) then + ! Calculate the Coriolis-like acceleration due to relative vorticity. + if (CS%Coriolis_Scheme == SADOURNY75_ENERGY) then + if (associated(AD%rv_x_u)) then + do J=Jsq,Jeq ; do i=is,ie + AD%rv_x_u(i,J,k) = - 0.25* & + (q2(I-1,j)*(uh(I-1,j,k) + uh(I-1,j+1,k)) + & + q2(I,j)*(uh(I,j,k) + uh(I,j+1,k))) * G%IdyCv(i,J) + enddo ; enddo + endif + + if (associated(AD%rv_x_v)) then + do j=js,je ; do I=Isq,Ieq + AD%rv_x_v(I,j,k) = 0.25 * & + (q2(I,j) * (vh(i+1,J,k) + vh(i,J,k)) + & + q2(I,j-1) * (vh(i,J-1,k) + vh(i+1,J-1,k))) * G%IdxCu(I,j) + enddo ; enddo + endif + else + if (associated(AD%rv_x_u)) then + do J=Jsq,Jeq ; do i=is,ie + AD%rv_x_u(i,J,k) = -G%IdyCv(i,J) * C1_12 * & + ((q2(I,J) + q2(I-1,J) + q2(I-1,J-1)) * uh(I-1,j,k) + & + (q2(I-1,J) + q2(I,J) + q2(I,J-1)) * uh(I,j,k) + & + (q2(I-1,J) + q2(I,J+1) + q2(I,J)) * uh(I,j+1,k) + & + (q2(I,J) + q2(I-1,J+1) + q2(I-1,J)) * uh(I-1,j+1,k)) + enddo ; enddo + endif + + if (associated(AD%rv_x_v)) then + do j=js,je ; do I=Isq,Ieq + AD%rv_x_v(I,j,k) = G%IdxCu(I,j) * C1_12 * & + ((q2(I+1,J) + q2(I,J) + q2(I,J-1)) * vh(i+1,J,k) + & + (q2(I-1,J) + q2(I,J) + q2(I,J-1)) * vh(i,J,k) + & + (q2(I-1,J-1) + q2(I,J) + q2(I,J-1)) * vh(i,J-1,k) + & + (q2(I+1,J-1) + q2(I,J) + q2(I,J-1)) * vh(i+1,J-1,k)) + enddo ; enddo + endif + endif + endif + + enddo ! k-loop. + + ! Here the various Coriolis-related derived quantities are offered for averaging. + if (query_averaging_enabled(CS%diag)) then + if (CS%id_rv > 0) call post_data(CS%id_rv, RV, CS%diag) + if (CS%id_PV > 0) call post_data(CS%id_PV, PV, CS%diag) + if (CS%id_gKEu>0) call post_data(CS%id_gKEu, AD%gradKEu, CS%diag) + if (CS%id_gKEv>0) call post_data(CS%id_gKEv, AD%gradKEv, CS%diag) + if (CS%id_rvxu > 0) call post_data(CS%id_rvxu, AD%rv_x_u, CS%diag) + if (CS%id_rvxv > 0) call post_data(CS%id_rvxv, AD%rv_x_v, CS%diag) + if (Stokes_VF) then + if (CS%id_CAuS > 0) call post_data(CS%id_CAuS, CAuS, CS%diag) + if (CS%id_CAvS > 0) call post_data(CS%id_CAvS, CAvS, CS%diag) + endif + + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for debugging purposes in the future. + ! if (CS%id_hf_gKEu > 0) call post_product_u(CS%id_hf_gKEu, AD%gradKEu, AD%diag_hfrac_u, G, nz, CS%diag) + ! if (CS%id_hf_gKEv > 0) call post_product_v(CS%id_hf_gKEv, AD%gradKEv, AD%diag_hfrac_v, G, nz, CS%diag) + ! if (CS%id_hf_rvxv > 0) call post_product_u(CS%id_hf_rvxv, AD%rv_x_v, AD%diag_hfrac_u, G, nz, CS%diag) + ! if (CS%id_hf_rvxu > 0) call post_product_v(CS%id_hf_rvxu, AD%rv_x_u, AD%diag_hfrac_v, G, nz, CS%diag) + + if (CS%id_hf_gKEu_2d > 0) call post_product_sum_u(CS%id_hf_gKEu_2d, AD%gradKEu, AD%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_gKEv_2d > 0) call post_product_sum_v(CS%id_hf_gKEv_2d, AD%gradKEv, AD%diag_hfrac_v, G, nz, CS%diag) + if (CS%id_intz_gKEu_2d > 0) call post_product_sum_u(CS%id_intz_gKEu_2d, AD%gradKEu, AD%diag_hu, G, nz, CS%diag) + if (CS%id_intz_gKEv_2d > 0) call post_product_sum_v(CS%id_intz_gKEv_2d, AD%gradKEv, AD%diag_hv, G, nz, CS%diag) + + if (CS%id_hf_rvxv_2d > 0) call post_product_sum_u(CS%id_hf_rvxv_2d, AD%rv_x_v, AD%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_rvxu_2d > 0) call post_product_sum_v(CS%id_hf_rvxu_2d, AD%rv_x_u, AD%diag_hfrac_v, G, nz, CS%diag) + + if (CS%id_h_gKEu > 0) call post_product_u(CS%id_h_gKEu, AD%gradKEu, AD%diag_hu, G, nz, CS%diag) + if (CS%id_h_gKEv > 0) call post_product_v(CS%id_h_gKEv, AD%gradKEv, AD%diag_hv, G, nz, CS%diag) + if (CS%id_h_rvxv > 0) call post_product_u(CS%id_h_rvxv, AD%rv_x_v, AD%diag_hu, G, nz, CS%diag) + if (CS%id_h_rvxu > 0) call post_product_v(CS%id_h_rvxu, AD%rv_x_u, AD%diag_hv, G, nz, CS%diag) + + if (CS%id_intz_rvxv_2d > 0) call post_product_sum_u(CS%id_intz_rvxv_2d, AD%rv_x_v, AD%diag_hu, G, nz, CS%diag) + if (CS%id_intz_rvxu_2d > 0) call post_product_sum_v(CS%id_intz_rvxu_2d, AD%rv_x_u, AD%diag_hv, G, nz, CS%diag) + endif + +end subroutine CorAdCalc + + +!> Calculates the acceleration due to the gradient of kinetic energy. +subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G) ,SZJ_(G) ), intent(out) :: KE !< Kinetic energy per unit mass [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G) ), intent(out) :: KEx !< Zonal acceleration due to kinetic + !! energy gradient [L T-2 ~> m s-2] + real, dimension(SZI_(G) ,SZJB_(G)), intent(out) :: KEy !< Meridional acceleration due to kinetic + !! energy gradient [L T-2 ~> m s-2] + integer, intent(in) :: k !< Layer number to calculate for + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(CoriolisAdv_CS), intent(in) :: CS !< Control structure for MOM_CoriolisAdv + ! Local variables + real :: um, up, vm, vp ! Temporary variables [L T-1 ~> m s-1]. + real :: um2, up2, vm2, vp2 ! Temporary variables [L2 T-2 ~> m2 s-2]. + real :: um2a, up2a, vm2a, vp2a ! Temporary variables [L4 T-2 ~> m4 s-2]. + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n + + 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 + + + ! Calculate KE (Kinetic energy for use in the -grad(KE) acceleration term). + if (CS%KE_Scheme == KE_ARAKAWA) then + ! The following calculation of Kinetic energy includes the metric terms + ! identified in Arakawa & Lamb 1982 as important for KE conservation. It + ! also includes the possibility of partially-blocked tracer cell faces. + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + KE(i,j) = ( ( G%areaCu( I ,j)*(u( I ,j,k)*u( I ,j,k)) + & + G%areaCu(I-1,j)*(u(I-1,j,k)*u(I-1,j,k)) ) + & + ( G%areaCv(i, J )*(v(i, J ,k)*v(i, J ,k)) + & + G%areaCv(i,J-1)*(v(i,J-1,k)*v(i,J-1,k)) ) )*0.25*G%IareaT(i,j) + enddo ; enddo + elseif (CS%KE_Scheme == KE_SIMPLE_GUDONOV) then + ! The following discretization of KE is based on the one-dimensional Gudonov + ! scheme which does not take into account any geometric factors + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + up = 0.5*( u(I-1,j,k) + ABS( u(I-1,j,k) ) ) ; up2 = up*up + um = 0.5*( u( I ,j,k) - ABS( u( I ,j,k) ) ) ; um2 = um*um + vp = 0.5*( v(i,J-1,k) + ABS( v(i,J-1,k) ) ) ; vp2 = vp*vp + vm = 0.5*( v(i, J ,k) - ABS( v(i, J ,k) ) ) ; vm2 = vm*vm + KE(i,j) = ( max(up2,um2) + max(vp2,vm2) ) *0.5 + enddo ; enddo + elseif (CS%KE_Scheme == KE_GUDONOV) then + ! The following discretization of KE is based on the one-dimensional Gudonov + ! scheme but has been adapted to take horizontal grid factors into account + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + up = 0.5*( u(I-1,j,k) + ABS( u(I-1,j,k) ) ) ; up2a = up*up*G%areaCu(I-1,j) + um = 0.5*( u( I ,j,k) - ABS( u( I ,j,k) ) ) ; um2a = um*um*G%areaCu( I ,j) + vp = 0.5*( v(i,J-1,k) + ABS( v(i,J-1,k) ) ) ; vp2a = vp*vp*G%areaCv(i,J-1) + vm = 0.5*( v(i, J ,k) - ABS( v(i, J ,k) ) ) ; vm2a = vm*vm*G%areaCv(i, J ) + KE(i,j) = ( max(um2a,up2a) + max(vm2a,vp2a) )*0.5*G%IareaT(i,j) + enddo ; enddo + endif + + ! Term - d(KE)/dx. + do j=js,je ; do I=Isq,Ieq + KEx(I,j) = (KE(i+1,j) - KE(i,j)) * G%IdxCu(I,j) + enddo ; enddo + + ! Term - d(KE)/dy. + do J=Jsq,Jeq ; do i=is,ie + KEy(i,J) = (KE(i,j+1) - KE(i,j)) * G%IdyCv(i,J) + enddo ; enddo + + if (associated(OBC)) then + do n=1,OBC%number_of_segments + if (OBC%segment(n)%is_N_or_S) then + do i=OBC%segment(n)%HI%isd,OBC%segment(n)%HI%ied + KEy(i,OBC%segment(n)%HI%JsdB) = 0. + enddo + elseif (OBC%segment(n)%is_E_or_W) then + do j=OBC%segment(n)%HI%jsd,OBC%segment(n)%HI%jed + KEx(OBC%segment(n)%HI%IsdB,j) = 0. + enddo + endif + enddo + endif + +end subroutine gradKE + +!> Initializes the control structure for MOM_CoriolisAdv +subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Runtime parameter handles + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(accel_diag_ptrs), target, intent(inout) :: AD !< Storage for acceleration diagnostics + type(CoriolisAdv_CS), intent(inout) :: CS !< Control structure for MOM_CoriolisAdv + ! Local variables +! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mdl = "MOM_CoriolisAdv" ! This module's name. + character(len=20) :: tmpstr + character(len=400) :: mesg + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + CS%initialized = .true. + CS%diag => diag ; CS%Time => Time + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "NOSLIP", CS%no_slip, & + "If true, no slip boundary conditions are used; otherwise "//& + "free slip boundary conditions are assumed. The "//& + "implementation of the free slip BCs on a C-grid is much "//& + "cleaner than the no slip BCs. The use of free slip BCs "//& + "is strongly encouraged, and no slip BCs are not used with "//& + "the biharmonic viscosity.", default=.false.) + + call get_param(param_file, mdl, "CORIOLIS_EN_DIS", CS%Coriolis_En_Dis, & + "If true, two estimates of the thickness fluxes are used "//& + "to estimate the Coriolis term, and the one that "//& + "dissipates energy relative to the other one is used.", & + default=.false.) + + ! Set %Coriolis_Scheme + ! (Select the baseline discretization for the Coriolis term) + call get_param(param_file, mdl, "CORIOLIS_SCHEME", tmpstr, & + "CORIOLIS_SCHEME selects the discretization for the "//& + "Coriolis terms. Valid values are: \n"//& + "\t SADOURNY75_ENERGY - Sadourny, 1975; energy cons. \n"//& + "\t ARAKAWA_HSU90 - Arakawa & Hsu, 1990 \n"//& + "\t SADOURNY75_ENSTRO - Sadourny, 1975; enstrophy cons. \n"//& + "\t ARAKAWA_LAMB81 - Arakawa & Lamb, 1981; En. + Enst.\n"//& + "\t ARAKAWA_LAMB_BLEND - A blend of Arakawa & Lamb with \n"//& + "\t Arakawa & Hsu and Sadourny energy", & + default=SADOURNY75_ENERGY_STRING) + tmpstr = uppercase(tmpstr) + select case (tmpstr) + case (SADOURNY75_ENERGY_STRING) + CS%Coriolis_Scheme = SADOURNY75_ENERGY + case (ARAKAWA_HSU_STRING) + CS%Coriolis_Scheme = ARAKAWA_HSU90 + case (SADOURNY75_ENSTRO_STRING) + CS%Coriolis_Scheme = SADOURNY75_ENSTRO + case (ARAKAWA_LAMB_STRING) + CS%Coriolis_Scheme = ARAKAWA_LAMB81 + case (AL_BLEND_STRING) + CS%Coriolis_Scheme = AL_BLEND + case (ROBUST_ENSTRO_STRING) + CS%Coriolis_Scheme = ROBUST_ENSTRO + CS%Coriolis_En_Dis = .false. + case default + call MOM_mesg('CoriolisAdv_init: Coriolis_Scheme ="'//trim(tmpstr)//'"', 0) + call MOM_error(FATAL, "CoriolisAdv_init: Unrecognized setting "// & + "#define CORIOLIS_SCHEME "//trim(tmpstr)//" found in input file.") + end select + if (CS%Coriolis_Scheme == AL_BLEND) then + call get_param(param_file, mdl, "CORIOLIS_BLEND_WT_LIN", CS%wt_lin_blend, & + "A weighting value for the ratio of inverse thicknesses, "//& + "beyond which the blending between Sadourny Energy and "//& + "Arakawa & Hsu goes linearly to 0 when CORIOLIS_SCHEME "//& + "is ARAWAKA_LAMB_BLEND. This must be between 1 and 1e-16.", & + units="nondim", default=0.125) + call get_param(param_file, mdl, "CORIOLIS_BLEND_F_EFF_MAX", CS%F_eff_max_blend, & + "The factor by which the maximum effective Coriolis "//& + "acceleration from any point can be increased when "//& + "blending different discretizations with the "//& + "ARAKAWA_LAMB_BLEND Coriolis scheme. This must be "//& + "greater than 2.0 (the max value for Sadourny energy).", & + units="nondim", default=4.0) + CS%wt_lin_blend = min(1.0, max(CS%wt_lin_blend,1e-16)) + if (CS%F_eff_max_blend < 2.0) call MOM_error(WARNING, "CoriolisAdv_init: "//& + "CORIOLIS_BLEND_F_EFF_MAX should be at least 2.") + endif + + mesg = "If true, the Coriolis terms at u-points are bounded by "//& + "the four estimates of (f+rv)v from the four neighboring "//& + "v-points, and similarly at v-points." + if (CS%Coriolis_En_Dis .and. (CS%Coriolis_Scheme == SADOURNY75_ENERGY)) then + mesg = trim(mesg)//" This option is "//& + "always effectively false with CORIOLIS_EN_DIS defined and "//& + "CORIOLIS_SCHEME set to "//trim(SADOURNY75_ENERGY_STRING)//"." + else + mesg = trim(mesg)//" This option would "//& + "have no effect on the SADOURNY Coriolis scheme if it "//& + "were possible to use centered difference thickness fluxes." + endif + call get_param(param_file, mdl, "BOUND_CORIOLIS", CS%bound_Coriolis, mesg, & + default=.false.) + if ((CS%Coriolis_En_Dis .and. (CS%Coriolis_Scheme == SADOURNY75_ENERGY)) .or. & + (CS%Coriolis_Scheme == ROBUST_ENSTRO)) CS%bound_Coriolis = .false. + + ! Set KE_Scheme (selects discretization of KE) + call get_param(param_file, mdl, "KE_SCHEME", tmpstr, & + "KE_SCHEME selects the discretization for acceleration "//& + "due to the kinetic energy gradient. Valid values are: \n"//& + "\t KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV", & + default=KE_ARAKAWA_STRING) + tmpstr = uppercase(tmpstr) + select case (tmpstr) + case (KE_ARAKAWA_STRING); CS%KE_Scheme = KE_ARAKAWA + case (KE_SIMPLE_GUDONOV_STRING); CS%KE_Scheme = KE_SIMPLE_GUDONOV + case (KE_GUDONOV_STRING); CS%KE_Scheme = KE_GUDONOV + case default + call MOM_mesg('CoriolisAdv_init: KE_Scheme ="'//trim(tmpstr)//'"', 0) + call MOM_error(FATAL, "CoriolisAdv_init: "// & + "#define KE_SCHEME "//trim(tmpstr)//" in input file is invalid.") + end select + + ! Set PV_Adv_Scheme (selects discretization of PV advection) + call get_param(param_file, mdl, "PV_ADV_SCHEME", tmpstr, & + "PV_ADV_SCHEME selects the discretization for PV "//& + "advection. Valid values are: \n"//& + "\t PV_ADV_CENTERED - centered (aka Sadourny, 75) \n"//& + "\t PV_ADV_UPWIND1 - upwind, first order", & + default=PV_ADV_CENTERED_STRING) + select case (uppercase(tmpstr)) + case (PV_ADV_CENTERED_STRING) + CS%PV_Adv_Scheme = PV_ADV_CENTERED + case (PV_ADV_UPWIND1_STRING) + CS%PV_Adv_Scheme = PV_ADV_UPWIND1 + case default + call MOM_mesg('CoriolisAdv_init: PV_Adv_Scheme ="'//trim(tmpstr)//'"', 0) + call MOM_error(FATAL, "CoriolisAdv_init: "// & + "#DEFINE PV_ADV_SCHEME in input file is invalid.") + end select + + CS%id_rv = register_diag_field('ocean_model', 'RV', diag%axesBL, Time, & + 'Relative Vorticity', 's-1', conversion=US%s_to_T) + + CS%id_PV = register_diag_field('ocean_model', 'PV', diag%axesBL, Time, & + 'Potential Vorticity', 'm-1 s-1', conversion=GV%m_to_H*US%s_to_T) + + CS%id_gKEu = register_diag_field('ocean_model', 'gKEu', diag%axesCuL, Time, & + 'Zonal Acceleration from Grad. Kinetic Energy', 'm s-2', conversion=US%L_T2_to_m_s2) + + CS%id_gKEv = register_diag_field('ocean_model', 'gKEv', diag%axesCvL, Time, & + 'Meridional Acceleration from Grad. Kinetic Energy', 'm s-2', conversion=US%L_T2_to_m_s2) + + CS%id_rvxu = register_diag_field('ocean_model', 'rvxu', diag%axesCvL, Time, & + 'Meridional Acceleration from Relative Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) + + CS%id_rvxv = register_diag_field('ocean_model', 'rvxv', diag%axesCuL, Time, & + 'Zonal Acceleration from Relative Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) + + CS%id_CAuS = register_diag_field('ocean_model', 'CAu_Stokes', diag%axesCuL, Time, & + 'Zonal Acceleration from Stokes Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) + ! add to AD + + CS%id_CAvS = register_diag_field('ocean_model', 'CAv_Stokes', diag%axesCvL, Time, & + 'Meridional Acceleration from Stokes Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) + ! add to AD + + !CS%id_hf_gKEu = register_diag_field('ocean_model', 'hf_gKEu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + CS%id_hf_gKEu_2d = register_diag_field('ocean_model', 'hf_gKEu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & + 'm s-2', conversion=US%L_T2_to_m_s2) + + !CS%id_hf_gKEv = register_diag_field('ocean_model', 'hf_gKEv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + CS%id_hf_gKEv_2d = register_diag_field('ocean_model', 'hf_gKEv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & + 'm s-2', conversion=US%L_T2_to_m_s2) + + CS%id_h_gKEu = register_diag_field('ocean_model', 'h_gKEu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Grad. Kinetic Energy', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + CS%id_intz_gKEu_2d = register_diag_field('ocean_model', 'intz_gKEu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Acceleration from Grad. Kinetic Energy', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + + CS%id_h_gKEv = register_diag_field('ocean_model', 'h_gKEv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Grad. Kinetic Energy', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + CS%id_intz_gKEv_2d = register_diag_field('ocean_model', 'intz_gKEv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Acceleration from Grad. Kinetic Energy', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + + !CS%id_hf_rvxu = register_diag_field('ocean_model', 'hf_rvxu', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + CS%id_hf_rvxu_2d = register_diag_field('ocean_model', 'hf_rvxu_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & + 'm s-2', conversion=US%L_T2_to_m_s2) + + !CS%id_hf_rvxv = register_diag_field('ocean_model', 'hf_rvxv', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + CS%id_hf_rvxv_2d = register_diag_field('ocean_model', 'hf_rvxv_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + 'm s-2', conversion=US%L_T2_to_m_s2) + + CS%id_h_rvxu = register_diag_field('ocean_model', 'h_rvxu', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Relative Vorticity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + CS%id_intz_rvxu_2d = register_diag_field('ocean_model', 'intz_rvxu_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Acceleration from Relative Vorticity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + + CS%id_h_rvxv = register_diag_field('ocean_model', 'h_rvxv', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Relative Vorticity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + CS%id_intz_rvxv_2d = register_diag_field('ocean_model', 'intz_rvxv_2d', diag%axesCu1, Time, & + 'Depth-integral of Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + + ! Allocate memory needed for the diagnostics that have been enabled. + if ((CS%id_gKEu > 0) .or. (CS%id_hf_gKEu_2d > 0) .or. & + ! (CS%id_hf_gKEu > 0) .or. & + (CS%id_h_gKEu > 0) .or. (CS%id_intz_gKEu_2d > 0)) then + call safe_alloc_ptr(AD%gradKEu, IsdB, IedB, jsd, jed, nz) + endif + if ((CS%id_gKEv > 0) .or. (CS%id_hf_gKEv_2d > 0) .or. & + ! (CS%id_hf_gKEv > 0) .or. & + (CS%id_h_gKEv > 0) .or. (CS%id_intz_gKEv_2d > 0)) then + call safe_alloc_ptr(AD%gradKEv, isd, ied, JsdB, JedB, nz) + endif + if ((CS%id_rvxu > 0) .or. (CS%id_hf_rvxu_2d > 0) .or. & + ! (CS%id_hf_rvxu > 0) .or. & + (CS%id_h_rvxu > 0) .or. (CS%id_intz_rvxu_2d > 0)) then + call safe_alloc_ptr(AD%rv_x_u, isd, ied, JsdB, JedB, nz) + endif + if ((CS%id_rvxv > 0) .or. (CS%id_hf_rvxv_2d > 0) .or. & + ! (CS%id_hf_rvxv > 0) .or. & + (CS%id_h_rvxv > 0) .or. (CS%id_intz_rvxv_2d > 0)) then + call safe_alloc_ptr(AD%rv_x_v, IsdB, IedB, jsd, jed, nz) + endif + + if ((CS%id_hf_gKEv_2d > 0) .or. & + ! (CS%id_hf_gKEv > 0) .or. (CS%id_hf_rvxu > 0) .or. & + (CS%id_hf_rvxu_2d > 0)) then + call safe_alloc_ptr(AD%diag_hfrac_v, isd, ied, JsdB, JedB, nz) + endif + if ((CS%id_hf_gKEu_2d > 0) .or. & + ! (CS%id_hf_gKEu > 0) .or. (CS%id_hf_rvxv > 0) .or. & + (CS%id_hf_rvxv_2d > 0)) then + call safe_alloc_ptr(AD%diag_hfrac_u, IsdB, IedB, jsd, jed, nz) + endif + if ((CS%id_h_gKEu > 0) .or. (CS%id_intz_gKEu_2d > 0) .or. & + (CS%id_h_rvxv > 0) .or. (CS%id_intz_rvxv_2d > 0)) then + call safe_alloc_ptr(AD%diag_hu, IsdB, IedB, jsd, jed, nz) + endif + if ((CS%id_h_gKEv > 0) .or. (CS%id_intz_gKEv_2d > 0) .or. & + (CS%id_h_rvxu > 0) .or. (CS%id_intz_rvxu_2d > 0)) then + call safe_alloc_ptr(AD%diag_hv, isd, ied, JsdB, JedB, nz) + endif + +end subroutine CoriolisAdv_init + +!> Destructor for coriolisadv_cs +subroutine CoriolisAdv_end(CS) + type(CoriolisAdv_CS), intent(inout) :: CS !< Control structure for MOM_CoriolisAdv +end subroutine CoriolisAdv_end + +!> \namespace mom_coriolisadv +!! +!! This file contains the subroutine that calculates the time +!! derivatives of the velocities due to Coriolis acceleration and +!! momentum advection. This subroutine uses either a vorticity +!! advection scheme from Arakawa and Hsu, Mon. Wea. Rev. 1990, or +!! Sadourny's (JAS 1975) energy conserving scheme. Both have been +!! modified to use general orthogonal coordinates as described in +!! Arakawa and Lamb, Mon. Wea. Rev. 1981. Both schemes are second +!! order accurate, and allow for vanishingly small layer thicknesses. +!! The Arakawa and Hsu scheme globally conserves both total energy +!! and potential enstrophy in the limit of nondivergent flow. +!! Sadourny's energy conserving scheme conserves energy if the flow +!! is nondivergent or centered difference thickness fluxes are used. +!! +!! A small fragment of the grid is shown below: +!! \verbatim +!! +!! j+1 x ^ x ^ x At x: q, CoriolisBu +!! j+1 > o > o > At ^: v, CAv, vh +!! j x ^ x ^ x At >: u, CAu, uh, a, b, c, d +!! j > o > o > At o: h, KE +!! j-1 x ^ x ^ x +!! i-1 i i+1 At x & ^: +!! i i+1 At > & o: +!! \endverbatim +!! +!! The boundaries always run through q grid points (x). + +end module MOM_CoriolisAdv diff --git a/core/MOM_PressureForce.F90 b/core/MOM_PressureForce.F90 new file mode 100644 index 0000000000..ad76a9a9f5 --- /dev/null +++ b/core/MOM_PressureForce.F90 @@ -0,0 +1,122 @@ +!> A thin wrapper for Boussinesq/non-Boussinesq forms of the pressure force calculation. +module MOM_PressureForce + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_PressureForce_FV, only : PressureForce_FV_Bouss, PressureForce_FV_nonBouss +use MOM_PressureForce_FV, only : PressureForce_FV_init +use MOM_PressureForce_FV, only : PressureForce_FV_CS +use MOM_PressureForce_Mont, only : PressureForce_Mont_Bouss, PressureForce_Mont_nonBouss +use MOM_PressureForce_Mont, only : PressureForce_Mont_init +use MOM_PressureForce_Mont, only : PressureForce_Mont_CS +use MOM_self_attr_load, only : SAL_CS +use MOM_tidal_forcing, only : tidal_forcing_CS +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_ALE, only: ALE_CS +implicit none ; private + +#include + +public PressureForce, PressureForce_init + +!> Pressure force control structure +type, public :: PressureForce_CS ; private + logical :: Analytic_FV_PGF !< If true, use the analytic finite volume form + !! (Adcroft et al., Ocean Mod. 2008) of the PGF. + !> Control structure for the analytically integrated finite volume pressure force + type(PressureForce_FV_CS) :: PressureForce_FV + !> Control structure for the Montgomery potential form of pressure force + type(PressureForce_Mont_CS) :: PressureForce_Mont +end type PressureForce_CS + +contains + +!> A thin layer between the model and the Boussinesq and non-Boussinesq pressure force routines. +subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: PFu !< Zonal pressure force acceleration [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: PFv !< Meridional pressure force acceleration [L T-2 ~> m s-2] + type(PressureForce_CS), intent(inout) :: CS !< Pressure force control structure + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure + real, dimension(:,:), pointer :: p_atm !< The pressure at the ice-ocean or + !! atmosphere-ocean interface [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: pbce !< The baroclinic pressure anomaly in each layer + !! due to eta anomalies [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: eta !< The bottom mass used to calculate PFu and PFv, + !! [H ~> m or kg m-2], with any tidal contributions. + + if (CS%Analytic_FV_PGF) then + if (GV%Boussinesq) then + call PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_FV, & + ALE_CSp, p_atm, pbce, eta) + else + call PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_FV, & + ALE_CSp, p_atm, pbce, eta) + endif + else + if (GV%Boussinesq) then + call PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_Mont, & + p_atm, pbce, eta) + else + call PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_Mont, & + p_atm, pbce, eta) + endif + endif + +end subroutine Pressureforce + +!> Initialize the pressure force control structure +subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, tides_CSp) + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handles + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(PressureForce_CS), intent(inout) :: CS !< Pressure force control structure + type(SAL_CS), intent(in), optional :: SAL_CSp !< SAL control structure + type(tidal_forcing_CS), intent(in), optional :: tides_CSp !< Tide control structure +#include "version_variable.h" + character(len=40) :: mdl = "MOM_PressureForce" ! This module's name. + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "ANALYTIC_FV_PGF", CS%Analytic_FV_PGF, & + "If true the pressure gradient forces are calculated "//& + "with a finite volume form that analytically integrates "//& + "the equations of state in pressure to avoid any "//& + "possibility of numerical thermobaric instability, as "//& + "described in Adcroft et al., O. Mod. (2008).", default=.true.) + + if (CS%Analytic_FV_PGF) then + call PressureForce_FV_init(Time, G, GV, US, param_file, diag, & + CS%PressureForce_FV, SAL_CSp, tides_CSp) + else + call PressureForce_Mont_init(Time, G, GV, US, param_file, diag, & + CS%PressureForce_Mont, SAL_CSp, tides_CSp) + endif +end subroutine PressureForce_init + +!> \namespace mom_pressureforce +!! +!! This thin module provides a branch to two forms of the horizontal accelerations +!! due to pressure gradients. The two options currently available are a +!! Montgomery potential form (used in traditional isopycnal layer models), and the +!! analytic finite volume form. + +end module MOM_PressureForce diff --git a/core/MOM_PressureForce_FV.F90 b/core/MOM_PressureForce_FV.F90 new file mode 100644 index 0000000000..5fb3ade634 --- /dev/null +++ b/core/MOM_PressureForce_FV.F90 @@ -0,0 +1,1053 @@ +!> Finite volume pressure gradient (integrated by quadrature or analytically) +module MOM_PressureForce_FV + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, time_type +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_PressureForce_Mont, only : set_pbce_Bouss, set_pbce_nonBouss +use MOM_self_attr_load, only : calc_SAL, SAL_CS +use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS +use MOM_tidal_forcing, only : calc_tidal_forcing_legacy +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_density_integrals, only : int_density_dz, int_specific_vol_dp +use MOM_density_integrals, only : int_density_dz_generic_plm, int_density_dz_generic_ppm +use MOM_density_integrals, only : int_spec_vol_dp_generic_plm +use MOM_density_integrals, only : int_density_dz_generic_pcm, int_spec_vol_dp_generic_pcm +use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, ALE_CS + +implicit none ; private + +#include + +public PressureForce_FV_init +public PressureForce_FV_Bouss, PressureForce_FV_nonBouss + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Finite volume pressure gradient control structure +type, public :: PressureForce_FV_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: tides !< If true, apply tidal momentum forcing. + real :: Rho0 !< The density used in the Boussinesq + !! approximation [R ~> kg m-3]. + real :: GFS_scale !< A scaling of the surface pressure gradients to + !! allow the use of a reduced gravity model [nondim]. + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. + logical :: useMassWghtInterp !< Use mass weighting in T/S interpolation + logical :: use_inaccurate_pgf_rho_anom !< If true, uses the older and less accurate + !! method to calculate density anomalies, as used prior to + !! March 2018. + logical :: boundary_extrap !< Indicate whether high-order boundary + !! extrapolation should be used within boundary cells + + logical :: reconstruct !< If true, polynomial profiles of T & S will be + !! reconstructed and used in the integrals for the + !! finite volume pressure gradient calculation. + !! The default depends on whether regridding is being used. + + integer :: Recon_Scheme !< Order of the polynomial of the reconstruction of T & S + !! for the finite volume pressure gradient calculation. + !! By the default (1) is for a piecewise linear method + + logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF + integer :: tides_answer_date !< Recover old answers with tides in Boussinesq mode + integer :: id_e_tide = -1 !< Diagnostic identifier + integer :: id_e_tide_eq = -1 !< Diagnostic identifier + integer :: id_e_tide_sal = -1 !< Diagnostic identifier + integer :: id_e_sal = -1 !< Diagnostic identifier + integer :: id_rho_pgf = -1 !< Diagnostic identifier + integer :: id_rho_stanley_pgf = -1 !< Diagnostic identifier + integer :: id_p_stanley = -1 !< Diagnostic identifier + type(SAL_CS), pointer :: SAL_CSp => NULL() !< SAL control structure + type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure +end type PressureForce_FV_CS + +contains + +!> \brief Non-Boussinesq analytically-integrated finite volume form of pressure gradient +!! +!! Determines the acceleration due to hydrostatic pressure forces, using +!! the analytic finite volume form of the Pressure gradient, and does not +!! make the Boussinesq approximation. +!! +!! To work, the following fields must be set outside of the usual (is:ie,js:je) +!! range before this subroutine is called: +!! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). +subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] + type(PressureForce_FV_CS), intent(in) :: CS !< Finite volume PGF control structure + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure + real, dimension(:,:), pointer :: p_atm !< The pressure at the ice-ocean + !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(out) :: pbce !< The baroclinic pressure + !! anomaly in each layer due to eta anomalies + !! [L2 T-2 H-1 ~> m4 s-2 kg-1]. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The total column mass used to + !! calculate PFu and PFv [H ~> kg m-2]. + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: p ! Interface pressure [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & + T_tmp, & ! Temporary array of temperatures where layers that are lighter + ! than the mixed layer have the mixed layer's properties [C ~> degC]. + S_tmp ! Temporary array of salinities where layers that are lighter + ! than the mixed layer have the mixed layer's properties [S ~> ppt]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + S_t, S_b, & ! Top and bottom edge values for linear reconstructions + ! of salinity within each layer [S ~> ppt]. + T_t, T_b ! Top and bottom edge values for linear reconstructions + ! of temperature within each layer [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + dza, & ! The change in geopotential anomaly between the top and bottom + ! of a layer [L2 T-2 ~> m2 s-2]. + intp_dza ! The vertical integral in depth of the pressure anomaly less + ! the pressure anomaly at the top of the layer [R L4 T-4 ~> Pa m2 s-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + dp, & ! The (positive) change in pressure across a layer [R L2 T-2 ~> Pa]. + SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. + e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_tide_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources [Z ~> m]. + e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides [Z ~> m]. + e_sal_tide, & ! The summation of self-attraction and loading and tidal forcing [Z ~> m]. + dM, & ! The barotropic adjustment to the Montgomery potential to + ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. + za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the + ! interface atop a layer [L2 T-2 ~> m2 s-2]. + + real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable + ! density near-surface layer [R ~> kg m-3]. + real, dimension(SZIB_(G),SZJ_(G)) :: & + intx_za ! The zonal integral of the geopotential anomaly along the + ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + intx_dza ! The change in intx_za through a layer [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJB_(G)) :: & + inty_za ! The meridional integral of the geopotential anomaly along the + ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. + real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate + ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). + + real :: dp_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. + real :: I_gEarth ! The inverse of GV%g_Earth [T2 Z L-2 ~> s2 m-1] + real :: alpha_anom ! The in-situ specific volume, averaged over a + ! layer, less alpha_ref [R-1 ~> m3 kg-1]. + logical :: use_p_atm ! If true, use the atmospheric pressure. + logical :: use_ALE ! If true, use an ALE pressure reconstruction. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. + + real :: alpha_ref ! A reference specific volume [R-1 ~> m3 kg-1] that is used + ! to reduce the impact of truncation errors. + real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. + real :: Pa_to_H ! A factor to convert from Pa to the thickness units (H) + ! [H T2 R-1 L-2 ~> m Pa-1 or kg m-2 Pa-1]. + real :: H_to_RL2_T2 ! A factor to convert from thickness units (H) to pressure + ! units [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]. +! real :: oneatm ! 1 standard atmosphere of pressure in [R L2 T-2 ~> Pa] + real, parameter :: C1_6 = 1.0/6.0 ! [nondim] + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + nkmb=GV%nk_rho_varies + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + + if (.not.CS%initialized) call MOM_error(FATAL, & + "MOM_PressureForce_FV_nonBouss: Module must be initialized before it is used.") + + if (CS%use_stanley_pgf) call MOM_error(FATAL, & + "MOM_PressureForce_FV_nonBouss: The Stanley parameterization is not yet"//& + "implemented in non-Boussinesq mode.") + + use_p_atm = associated(p_atm) + use_EOS = associated(tv%eqn_of_state) + use_ALE = .false. + if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS + + H_to_RL2_T2 = GV%g_Earth*GV%H_to_RZ + dp_neglect = GV%g_Earth*GV%H_to_RZ * GV%H_subroundoff + alpha_ref = 1.0 / CS%Rho0 + I_gEarth = 1.0 / GV%g_Earth + + if (use_p_atm) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + p(i,j,1) = p_atm(i,j) + enddo ; enddo + else + ! oneatm = 101325.0 * US%Pa_to_RL2_T2 ! 1 atm scaled to [R L2 T-2 ~> Pa] + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + p(i,j,1) = 0.0 ! or oneatm + enddo ; enddo + endif + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do k=2,nz+1 ; do i=Isq,Ieq+1 + p(i,j,K) = p(i,j,K-1) + H_to_RL2_T2 * h(i,j,k-1) + enddo ; enddo ; enddo + + if (use_EOS) then + ! With a bulk mixed layer, replace the T & S of any layers that are + ! lighter than the buffer layer with the properties of the buffer + ! layer. These layers will be massless anyway, and it avoids any + ! formal calculations with hydrostatically unstable profiles. + if (nkmb>0) then + tv_tmp%T => T_tmp ; tv_tmp%S => S_tmp + tv_tmp%eqn_of_state => tv%eqn_of_state + do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo + !$OMP parallel do default(shared) private(Rho_cv_BL) + do j=Jsq,Jeq+1 + do k=1,nkmb ; do i=Isq,Ieq+1 + tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) + enddo ; enddo + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), & + tv%eqn_of_state, EOSdom) + do k=nkmb+1,nz ; do i=Isq,Ieq+1 + if (GV%Rlay(k) < Rho_cv_BL(i)) then + tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) + else + tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) + endif + enddo ; enddo + enddo + else + tv_tmp%T => tv%T ; tv_tmp%S => tv%S + tv_tmp%eqn_of_state => tv%eqn_of_state + endif + endif + + ! If regridding is activated, do a linear reconstruction of salinity + ! and temperature across each layer. The subscripts 't' and 'b' refer + ! to top and bottom values within each layer (these are the only degrees + ! of freedom needed to know the linear profile). + if ( use_ALE ) then + if ( CS%Recon_Scheme == 1 ) then + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + elseif ( CS%Recon_Scheme == 2) then + call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + endif + endif + + !$OMP parallel do default(shared) private(alpha_anom,dp) + do k=1,nz + ! Calculate 4 integrals through the layer that are required in the + ! subsequent calculation. + if (use_EOS) then + if ( use_ALE .and. CS%Recon_Scheme > 0 ) then + if ( CS%Recon_Scheme == 1 ) then + call int_spec_vol_dp_generic_plm( T_t(:,:,k), T_b(:,:,k), S_t(:,:,k), S_b(:,:,k), & + p(:,:,K), p(:,:,K+1), alpha_ref, dp_neglect, p(:,:,nz+1), G%HI, & + tv%eqn_of_state, US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & + useMassWghtInterp=CS%useMassWghtInterp) + elseif ( CS%Recon_Scheme == 2 ) then + call MOM_error(FATAL, "PressureForce_FV_nonBouss: "//& + "int_spec_vol_dp_generic_ppm does not exist yet.") + ! call int_spec_vol_dp_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & + ! tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), p(:,:,K), p(:,:,K+1), & + ! alpha_ref, G%HI, tv%eqn_of_state, dza(:,:,k), intp_dza(:,:,k), & + ! intx_dza(:,:,k), inty_dza(:,:,k)) + endif + else + call int_specific_vol_dp(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), p(:,:,K), & + p(:,:,K+1), alpha_ref, G%HI, tv%eqn_of_state, & + US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & + inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & + useMassWghtInterp=CS%useMassWghtInterp) + endif + else + alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dp(i,j) = H_to_RL2_T2 * h(i,j,k) + dza(i,j,k) = alpha_anom * dp(i,j) + intp_dza(i,j,k) = 0.5 * alpha_anom * dp(i,j)**2 + enddo ; enddo + do j=js,je ; do I=Isq,Ieq + intx_dza(i,j,k) = 0.5 * alpha_anom * (dp(i,j)+dp(i+1,j)) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + inty_dza(i,j,k) = 0.5 * alpha_anom * (dp(i,j)+dp(i,j+1)) + enddo ; enddo + endif + enddo + + ! The bottom geopotential anomaly is calculated first so that the increments + ! to the geopotential anomalies can be reused. Alternately, the surface + ! geopotential could be calculated directly with separate calls to + ! int_specific_vol_dp with alpha_ref=0, and the anomalies used going + ! downward, which would relieve the need for dza, intp_dza, intx_dza, and + ! inty_dza to be 3-D arrays. + + ! Sum vertically to determine the surface geopotential anomaly. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + za(i,j) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) + enddo + do k=nz,1,-1 ; do i=Isq,Ieq+1 + za(i,j) = za(i,j) + dza(i,j,k) + enddo ; enddo + enddo + + ! Calculate and add the self-attraction and loading geopotential anomaly. + if (CS%calculate_SAL) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & + - max(-G%bathyT(i,j)-G%Z_ref, 0.0) + enddo ; enddo + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) + + if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq) .or. (.not.CS%tides)) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) + enddo ; enddo + endif + endif + + ! Calculate and add the tidal geopotential anomaly. + if (CS%tides) then + if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq)) then + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j) = za(i,j) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) + enddo ; enddo + else ! This block recreates older answers with tides. + if (.not.CS%calculate_SAL) e_sal(:,:) = 0.0 + call calc_tidal_forcing_legacy(CS%Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, & + G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j) = za(i,j) - GV%g_Earth * e_sal_tide(i,j) + enddo ; enddo + endif + endif + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + if (use_EOS) then + !$OMP parallel do default(shared) private(rho_in_situ) + do j=Jsq,Jeq+1 + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, & + tv%eqn_of_state, EOSdom) + + do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j)) + enddo + enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j)) + enddo ; enddo + endif +! else +! do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; dM(i,j) = 0.0 ; enddo ; enddo + endif + + ! This order of integrating upward and then downward again is necessary with + ! a nonlinear equation of state, so that the surface geopotentials will go + ! linearly between the values at thickness points, but the bottom + ! geopotentials will not now be linear at the sub-grid-scale. Doing this + ! ensures no motion with flat isopycnals, even with a nonlinear equation of state. + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_za(I,j) = 0.5*(za(i,j) + za(i+1,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J) = 0.5*(za(i,j) + za(i,j+1)) + enddo ; enddo + do k=1,nz + ! These expressions for the acceleration have been carefully checked in + ! a set of idealized cases, and should be bug-free. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dp(i,j) = H_to_RL2_T2 * h(i,j,k) + za(i,j) = za(i,j) - dza(i,j,k) + enddo ; enddo + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_za(I,j) = intx_za(I,j) - intx_dza(I,j,k) + PFu(I,j,k) = ( ((za(i,j)*dp(i,j) + intp_dza(i,j,k)) - & + (za(i+1,j)*dp(i+1,j) + intp_dza(i+1,j,k))) + & + ((dp(i+1,j) - dp(i,j)) * intx_za(I,j) - & + (p(i+1,j,K) - p(i,j,K)) * intx_dza(I,j,k)) ) * & + (2.0*G%IdxCu(I,j) / ((dp(i,j) + dp(i+1,j)) + dp_neglect)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J) = inty_za(i,J) - inty_dza(i,J,k) + PFv(i,J,k) = (((za(i,j)*dp(i,j) + intp_dza(i,j,k)) - & + (za(i,j+1)*dp(i,j+1) + intp_dza(i,j+1,k))) + & + ((dp(i,j+1) - dp(i,j)) * inty_za(i,J) - & + (p(i,j+1,K) - p(i,j,K)) * inty_dza(i,J,k))) * & + (2.0*G%IdyCv(i,J) / ((dp(i,j) + dp(i,j+1)) + dp_neglect)) + enddo ; enddo + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) + enddo ; enddo + endif + enddo + + if (present(pbce)) then + call set_pbce_nonBouss(p, tv_tmp, G, GV, US, CS%GFS_scale, pbce) + endif + + if (present(eta)) then + Pa_to_H = 1.0 / (GV%g_Earth * GV%H_to_RZ) + if (use_p_atm) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = (p(i,j,nz+1) - p_atm(i,j))*Pa_to_H ! eta has the same units as h. + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = p(i,j,nz+1)*Pa_to_H ! eta has the same units as h. + enddo ; enddo + endif + endif + + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) + +end subroutine PressureForce_FV_nonBouss + +!> \brief Boussinesq analytically-integrated finite volume form of pressure gradient +!! +!! Determines the acceleration due to hydrostatic pressure forces, using +!! the finite volume form of the terms and analytic integrals in depth. +!! +!! To work, the following fields must be set outside of the usual (is:ie,js:je) +!! range before this subroutine is called: +!! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). +subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] + type(PressureForce_FV_CS), intent(in) :: CS !< Finite volume PGF control structure + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure + real, dimension(:,:), pointer :: p_atm !< The pressure at the ice-ocean + !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(out) :: pbce !< The baroclinic pressure + !! anomaly in each layer due to eta anomalies + !! [L2 T-2 H-1 ~> m s-2]. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The sea-surface height used to + !! calculate PFu and PFv [H ~> m], with any + !! tidal contributions. + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! Interface height in depth units [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)) :: & + e_sal_tide, & ! The summation of self-attraction and loading and tidal forcing [Z ~> m]. + e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_tide_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources + ! [Z ~> m]. + e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides [Z ~> m]. + SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. + dM ! The barotropic adjustment to the Montgomery potential to + ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G)) :: & + Rho_cv_BL ! The coordinate potential density in the deepest variable + ! density near-surface layer [R ~> kg m-3]. + real, dimension(SZI_(G),SZJ_(G)) :: & + dz_geo, & ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. + pa, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the + ! the interface atop a layer [R L2 T-2 ~> Pa]. + dpa, & ! The change in pressure anomaly between the top and bottom + ! of a layer [R L2 T-2 ~> Pa]. + intz_dpa ! The vertical integral in depth of the pressure anomaly less the + ! pressure anomaly at the top of the layer [H R L2 T-2 ~> m Pa]. + real, dimension(SZIB_(G),SZJ_(G)) :: & + intx_pa, & ! The zonal integral of the pressure anomaly along the interface + ! atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + intx_dpa ! The change in intx_pa through a layer [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJB_(G)) :: & + inty_pa, & ! The meridional integral of the pressure anomaly along the + ! interface atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + inty_dpa ! The change in inty_pa through a layer [R L2 T-2 ~> Pa]. + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & + T_tmp, & ! Temporary array of temperatures where layers that are lighter + ! than the mixed layer have the mixed layer's properties [C ~> degC]. + S_tmp ! Temporary array of salinities where layers that are lighter + ! than the mixed layer have the mixed layer's properties [S ~> ppt]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + S_t, S_b, & ! Top and bottom edge values for linear reconstructions + ! of salinity within each layer [S ~> ppt]. + T_t, T_b ! Top and bottom edge values for linear reconstructions + ! of temperature within each layer [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + rho_pgf, rho_stanley_pgf ! Density [R ~> kg m-3] from EOS with and without SGS T variance + ! in Stanley parameterization. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + p_stanley ! Pressure [R L2 T-2 ~> Pa] estimated with Rho_0 + real :: zeros(SZI_(G)) ! An array of zero values that can be used as an argument [various] + real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. + real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate + ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). + real :: p0(SZI_(G)) ! An array of zeros to use for pressure [R L2 T-2 ~> Pa]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m]. + real :: I_Rho0 ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1]. + real :: G_Rho0 ! G_Earth / Rho0 in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. + real :: rho_ref ! The reference density [R ~> kg m-3]. + real :: dz_neglect ! A minimal thickness [Z ~> m], like e. + real :: H_to_RL2_T2 ! A factor to convert from thickness units (H) to pressure + ! units [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]. + logical :: use_p_atm ! If true, use the atmospheric pressure. + logical :: use_ALE ! If true, use an ALE pressure reconstruction. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. + real, parameter :: C1_6 = 1.0/6.0 ! [nondim] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h ! The i-computational domain for the equation of state at tracer points + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb + integer :: i, j, k + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + nkmb=GV%nk_rho_varies + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + + if (.not.CS%initialized) call MOM_error(FATAL, & + "MOM_PressureForce_FV_Bouss: Module must be initialized before it is used.") + + use_p_atm = associated(p_atm) + use_EOS = associated(tv%eqn_of_state) + do i=Isq,Ieq+1 ; p0(i) = 0.0 ; enddo + use_ALE = .false. + if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS + + h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff + I_Rho0 = 1.0 / GV%Rho0 + G_Rho0 = GV%g_Earth / GV%Rho0 + rho_ref = CS%Rho0 + + if (CS%tides_answer_date>20230630) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -G%bathyT(i,j) + enddo ; enddo + + ! Calculate and add the self-attraction and loading geopotential anomaly. + if (CS%calculate_SAL) then + ! Determine the surface height anomaly for calculating self attraction + ! and loading. This should really be based on bottom pressure anomalies, + ! but that is not yet implemented, and the current form is correct for + ! barotropic tides. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) + enddo + do k=1,nz ; do i=Isq,Ieq+1 + SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z + enddo ; enddo + enddo + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) + enddo ; enddo + endif + + ! Calculate and add the tidal geopotential anomaly. + if (CS%tides) then + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = e(i,j,nz+1) - (e_tide_eq(i,j) + e_tide_sal(i,j)) + enddo ; enddo + endif + else ! Old answers + ! Calculate and add the self-attraction and loading geopotential anomaly. + if (CS%calculate_SAL) then + ! Determine the surface height anomaly for calculating self attraction + ! and loading. This should really be based on bottom pressure anomalies, + ! but that is not yet implemented, and the current form is correct for + ! barotropic tides. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) + enddo + do k=1,nz ; do i=Isq,Ieq+1 + SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z + enddo ; enddo + enddo + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = 0.0 + enddo ; enddo + endif + + ! Calculate and add the tidal geopotential anomaly. + if (CS%tides) then + call calc_tidal_forcing_legacy(CS%Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, & + G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal_tide(i,j)) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal(i,j)) + enddo ; enddo + endif + endif + + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do k=nz,1,-1 ; do i=Isq,Ieq+1 + e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z + enddo ; enddo ; enddo + + if (use_EOS) then +! With a bulk mixed layer, replace the T & S of any layers that are +! lighter than the buffer layer with the properties of the buffer +! layer. These layers will be massless anyway, and it avoids any +! formal calculations with hydrostatically unstable profiles. + + if (nkmb>0) then + tv_tmp%T => T_tmp ; tv_tmp%S => S_tmp + tv_tmp%eqn_of_state => tv%eqn_of_state + + do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo + !$OMP parallel do default(shared) private(Rho_cv_BL) + do j=Jsq,Jeq+1 + do k=1,nkmb ; do i=Isq,Ieq+1 + tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) + enddo ; enddo + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), & + tv%eqn_of_state, EOSdom) + + do k=nkmb+1,nz ; do i=Isq,Ieq+1 + if (GV%Rlay(k) < Rho_cv_BL(i)) then + tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) + else + tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) + endif + enddo ; enddo + enddo + else + tv_tmp%T => tv%T ; tv_tmp%S => tv%S + tv_tmp%eqn_of_state => tv%eqn_of_state + endif + endif + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + if (use_EOS) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + if (use_p_atm) then + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, & + tv%eqn_of_state, EOSdom) + else + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & + tv%eqn_of_state, EOSdom) + endif + do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * (e(i,j,1) - G%Z_ref) + enddo + enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * (e(i,j,1) - G%Z_ref) + enddo ; enddo + endif + endif + ! I have checked that rho_0 drops out and that the 1-layer case is right. RWH. + + ! If regridding is activated, do a linear reconstruction of salinity + ! and temperature across each layer. The subscripts 't' and 'b' refer + ! to top and bottom values within each layer (these are the only degrees + ! of freedom needed to know the linear profile). + if ( use_ALE ) then + if ( CS%Recon_Scheme == 1 ) then + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + elseif ( CS%Recon_Scheme == 2 ) then + call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + endif + endif + + ! Set the surface boundary conditions on pressure anomaly and its horizontal + ! integrals, assuming that the surface pressure anomaly varies linearly + ! in x and y. + if (use_p_atm) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pa(i,j) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p_atm(i,j) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pa(i,j) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + enddo ; enddo + endif + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_pa(I,j) = 0.5*(pa(i,j) + pa(i+1,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_pa(i,J) = 0.5*(pa(i,j) + pa(i,j+1)) + enddo ; enddo + + do k=1,nz + ! Calculate 4 integrals through the layer that are required in the + ! subsequent calculation. + if (use_EOS) then + ! The following routine computes the integrals that are needed to + ! calculate the pressure gradient force. Linear profiles for T and S are + ! assumed when regridding is activated. Otherwise, the previous version + ! is used, whereby densities within each layer are constant no matter + ! where the layers are located. + if ( use_ALE .and. CS%Recon_Scheme > 0 ) then + if ( CS%Recon_Scheme == 1 ) then + call int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & + G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa, intz_dpa, intx_dpa, inty_dpa, & + useMassWghtInterp=CS%useMassWghtInterp, & + use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom, Z_0p=G%Z_ref) + elseif ( CS%Recon_Scheme == 2 ) then + call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & + G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa, intz_dpa, intx_dpa, inty_dpa, & + useMassWghtInterp=CS%useMassWghtInterp, Z_0p=G%Z_ref) + endif + else + call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & + rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp, Z_0p=G%Z_ref) + endif + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + intz_dpa(i,j) = intz_dpa(i,j)*GV%Z_to_H + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dz_geo(i,j) = GV%g_Earth * GV%H_to_Z*h(i,j,k) + dpa(i,j) = (GV%Rlay(k) - rho_ref) * dz_geo(i,j) + intz_dpa(i,j) = 0.5*(GV%Rlay(k) - rho_ref) * dz_geo(i,j)*h(i,j,k) + enddo ; enddo + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_dpa(I,j) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i+1,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_dpa(i,J) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i,j+1)) + enddo ; enddo + endif + + ! Compute pressure gradient in x direction + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & + (pa(i+1,j)*h(i+1,j,k) + intz_dpa(i+1,j))) + & + ((h(i+1,j,k) - h(i,j,k)) * intx_pa(I,j) - & + (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j) * GV%Z_to_H)) * & + ((2.0*I_Rho0*G%IdxCu(I,j)) / & + ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) + intx_pa(I,j) = intx_pa(I,j) + intx_dpa(I,j) + enddo ; enddo + ! Compute pressure gradient in y direction + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & + (pa(i,j+1)*h(i,j+1,k) + intz_dpa(i,j+1))) + & + ((h(i,j+1,k) - h(i,j,k)) * inty_pa(i,J) - & + (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J) * GV%Z_to_H)) * & + ((2.0*I_Rho0*G%IdyCv(i,J)) / & + ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) + inty_pa(i,J) = inty_pa(i,J) + inty_dpa(i,J) + enddo ; enddo + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pa(i,j) = pa(i,j) + dpa(i,j) + enddo ; enddo + enddo + + if (CS%GFS_scale < 1.0) then + do k=1,nz + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) + enddo ; enddo + enddo + endif + + if (present(pbce)) then + call set_pbce_Bouss(e, tv_tmp, G, GV, US, CS%Rho0, CS%GFS_scale, pbce) + endif + + if (present(eta)) then + ! eta is the sea surface height relative to a time-invariant geoid, for comparison with + ! what is used for eta in btstep. See how e was calculated about 200 lines above. + if (CS%tides_answer_date>20230630) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = e(i,j,1)*GV%Z_to_H + enddo ; enddo + if (CS%tides) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = eta(i,j) + (e_tide_eq(i,j)+e_tide_sal(i,j))*GV%Z_to_H + enddo ; enddo + endif + if (CS%calculate_SAL) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = eta(i,j) + e_sal(i,j)*GV%Z_to_H + enddo ; enddo + endif + else ! Old answers + if (CS%tides) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal_tide(i,j))*GV%Z_to_H + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = (e(i,j,1) + e_sal(i,j))*GV%Z_to_H + enddo ; enddo + endif + endif + endif + + if (CS%use_stanley_pgf) then + ! Calculated diagnostics related to the Stanley parameterization + zeros(:) = 0.0 + EOSdom_h(:) = EOS_domain(G%HI) + if ((CS%id_p_stanley>0) .or. (CS%id_rho_pgf>0) .or. (CS%id_rho_stanley_pgf>0)) then + ! Find the pressure at the mid-point of each layer. + H_to_RL2_T2 = GV%g_Earth*GV%H_to_RZ + if (use_p_atm) then + do j=js,je ; do i=is,ie + p_stanley(i,j,1) = 0.5*h(i,j,1) * H_to_RL2_T2 + p_atm(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + p_stanley(i,j,1) = 0.5*h(i,j,1) * H_to_RL2_T2 + enddo ; enddo + endif + do k=2,nz ; do j=js,je ; do i=is,ie + p_stanley(i,j,k) = p_stanley(i,j,k-1) + 0.5*(h(i,j,k-1) + h(i,j,k)) * H_to_RL2_T2 + enddo ; enddo ; enddo + endif + if (CS%id_p_stanley>0) call post_data(CS%id_p_stanley, p_stanley, CS%diag) + if (CS%id_rho_pgf>0) then + do k=1,nz ; do j=js,je + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_stanley(:,j,k), zeros, & + zeros, zeros, rho_pgf(:,j,k), tv%eqn_of_state, EOSdom_h) + enddo ; enddo + call post_data(CS%id_rho_pgf, rho_pgf, CS%diag) + endif + if (CS%id_rho_stanley_pgf>0) then + do k=1,nz ; do j=js,je + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_stanley(:,j,k), tv%varT(:,j,k), & + zeros, zeros, rho_stanley_pgf(:,j,k), tv%eqn_of_state, EOSdom_h) + enddo ; enddo + call post_data(CS%id_rho_stanley_pgf, rho_stanley_pgf, CS%diag) + endif + endif + + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal_tide, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) + + if (CS%id_rho_pgf>0) call post_data(CS%id_rho_pgf, rho_pgf, CS%diag) + if (CS%id_rho_stanley_pgf>0) call post_data(CS%id_rho_stanley_pgf, rho_stanley_pgf, CS%diag) + if (CS%id_p_stanley>0) call post_data(CS%id_p_stanley, p_stanley, CS%diag) + +end subroutine PressureForce_FV_Bouss + +!> Initializes the finite volume pressure gradient control structure +subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, tides_CSp) + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handles + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(PressureForce_FV_CS), intent(inout) :: CS !< Finite volume PGF control structure + type(SAL_CS), intent(in), target, optional :: SAL_CSp !< SAL control structure + type(tidal_forcing_CS), intent(in), target, optional :: tides_CSp !< Tides control structure + + ! Local variables + real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale + ! temperature variance [nondim] + integer :: default_answer_date ! Global answer date + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl ! This module's name. + logical :: use_ALE ! If true, use the Vertical Lagrangian Remap algorithm + + CS%initialized = .true. + CS%diag => diag ; CS%Time => Time + if (present(tides_CSp)) & + CS%tides_CSp => tides_CSp + if (present(SAL_CSp)) & + CS%SAL_CSp => SAL_CSp + + mdl = "MOM_PressureForce_FV" + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "RHO_PGF_REF", CS%Rho0, & + "The reference density that is subtracted off when calculating pressure "//& + "gradient forces. Its inverse is subtracted off of specific volumes when "//& + "in non-Boussinesq mode. The default is RHO_0.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "TIDES", CS%tides, & + "If true, apply tidal momentum forcing.", default=.false.) + if (CS%tides) then + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "TIDES_ANSWER_DATE", CS%tides_answer_date, & + "The vintage of self-attraction and loading (SAL) and tidal forcing calculations in "//& + "Boussinesq mode. Values below 20230701 recover the old answers in which the SAL is "//& + "part of the tidal forcing calculation. The change is due to a reordered summation "//& + "and the difference is only at bit level.", default=20230630) + endif + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%tides) + call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & + "If True, use the ALE algorithm (regridding/remapping). "//& + "If False, use the layered isopycnal algorithm.", default=.false. ) + call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & + "If true, use mass weighting when interpolating T/S for "//& + "integrals near the bathymetry in FV pressure gradient "//& + "calculations.", default=.false.) + call get_param(param_file, mdl, "USE_INACCURATE_PGF_RHO_ANOM", CS%use_inaccurate_pgf_rho_anom, & + "If true, use a form of the PGF that uses the reference density "//& + "in an inaccurate way. This is not recommended.", default=.false.) + call get_param(param_file, mdl, "RECONSTRUCT_FOR_PRESSURE", CS%reconstruct, & + "If True, use vertical reconstruction of T & S within "//& + "the integrals of the FV pressure gradient calculation. "//& + "If False, use the constant-by-layer algorithm. "//& + "The default is set by USE_REGRIDDING.", & + default=use_ALE ) + call get_param(param_file, mdl, "PRESSURE_RECONSTRUCTION_SCHEME", CS%Recon_Scheme, & + "Order of vertical reconstruction of T/S to use in the "//& + "integrals within the FV pressure gradient calculation.\n"//& + " 0: PCM or no reconstruction.\n"//& + " 1: PLM reconstruction.\n"//& + " 2: PPM reconstruction.", default=1) + call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION_PRESSURE", CS%boundary_extrap, & + "If true, the reconstruction of T & S for pressure in "//& + "boundary cells is extrapolated, rather than using PCM "//& + "in these cells. If true, the same order polynomial is "//& + "used as is used for the interior cells.", default=.true.) + call get_param(param_file, mdl, "USE_STANLEY_PGF", CS%use_stanley_pgf, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in PGF code.", default=.false.) + if (CS%use_stanley_pgf) then + call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & + "Coefficient correlating the temperature gradient and SGS T variance.", & + units="nondim", default=-1.0, do_not_log=.true.) + if (Stanley_coeff < 0.0) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if USE_STANLEY_PGF is true.") + + CS%id_rho_pgf = register_diag_field('ocean_model', 'rho_pgf', diag%axesTL, & + Time, 'rho in PGF', 'kg m-3', conversion=US%R_to_kg_m3) + CS%id_rho_stanley_pgf = register_diag_field('ocean_model', 'rho_stanley_pgf', diag%axesTL, & + Time, 'rho in PGF with Stanley correction', 'kg m-3', conversion=US%R_to_kg_m3) + CS%id_p_stanley = register_diag_field('ocean_model', 'p_stanley', diag%axesTL, & + Time, 'p in PGF with Stanley correction', 'Pa', conversion=US%RL2_T2_to_Pa) + endif + if (CS%calculate_SAL) then + CS%id_e_sal = register_diag_field('ocean_model', 'e_sal', diag%axesT1, & + Time, 'Self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) + endif + if (CS%tides) then + CS%id_e_tide = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, Time, & + 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_eq = register_diag_field('ocean_model', 'e_tide_eq', diag%axesT1, Time, & + 'Equilibrium tides height anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_sal = register_diag_field('ocean_model', 'e_tide_sal', diag%axesT1, Time, & + 'Read-in tidal self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) + endif + + CS%GFS_scale = 1.0 + if (GV%g_prime(1) /= GV%g_Earth) CS%GFS_scale = GV%g_prime(1) / GV%g_Earth + + call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale, units="nondim") + +end subroutine PressureForce_FV_init + +!> \namespace mom_pressureforce_fv +!! +!! Provides the Boussinesq and non-Boussinesq forms of horizontal accelerations +!! due to pressure gradients using a vertically integrated finite volume form, +!! as described by Adcroft et al., 2008. Integration in the vertical is made +!! either by quadrature or analytically. +!! +!! This form eliminates the thermobaric instabilities that had been a problem with +!! previous forms of the pressure gradient force calculation, as described by +!! Hallberg, 2005. +!! +!! Adcroft, A., R. Hallberg, and M. Harrison, 2008: A finite volume discretization +!! of the pressure gradient force using analytic integration. Ocean Modelling, 22, +!! 106-113. http://doi.org/10.1016/j.ocemod.2008.02.001 +!! +!! Hallberg, 2005: A thermobaric instability of Lagrangian vertical coordinate +!! ocean models. Ocean Modelling, 8, 279-300. +!! http://dx.doi.org/10.1016/j.ocemod.2004.01.001 + +end module MOM_PressureForce_FV diff --git a/core/MOM_PressureForce_Montgomery.F90 b/core/MOM_PressureForce_Montgomery.F90 new file mode 100644 index 0000000000..6d982bc7e3 --- /dev/null +++ b/core/MOM_PressureForce_Montgomery.F90 @@ -0,0 +1,945 @@ +!> Provides the Montgomery potential form of pressure gradient +module MOM_PressureForce_Mont + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_density_integrals, only : int_specific_vol_dp +use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, time_type +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_self_attr_load, only : calc_SAL, SAL_CS +use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : query_compressible + +implicit none ; private + +#include + +public PressureForce_Mont_Bouss, PressureForce_Mont_nonBouss, Set_pbce_Bouss +public Set_pbce_nonBouss, PressureForce_Mont_init + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure for the Montgomery potential form of pressure gradient +type, public :: PressureForce_Mont_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: tides !< If true, apply tidal momentum forcing. + real :: Rho0 !< The density used in the Boussinesq + !! approximation [R ~> kg m-3]. + real :: GFS_scale !< Ratio between gravity applied to top interface and the + !! gravitational acceleration of the planet [nondim]. + !! Usually this ratio is 1. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate + !! the timing of diagnostic output. + real, allocatable :: PFu_bc(:,:,:) !< Zonal accelerations due to pressure gradients + !! deriving from density gradients within layers [L T-2 ~> m s-2]. + real, allocatable :: PFv_bc(:,:,:) !< Meridional accelerations due to pressure gradients + !! deriving from density gradients within layers [L T-2 ~> m s-2]. + !>@{ Diagnostic IDs + integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_sal = -1 + integer :: id_e_tide = -1, id_e_tide_eq = -1, id_e_tide_sal = -1 + !>@} + type(SAL_CS), pointer :: SAL_CSp => NULL() !< SAL control structure + type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< The tidal forcing control structure +end type PressureForce_Mont_CS + +contains + +!> \brief Non-Boussinesq Montgomery-potential form of pressure gradient +!! +!! Determines the acceleration due to pressure forces in a +!! non-Boussinesq fluid using the compressibility compensated (if appropriate) +!! Montgomery-potential form described in Hallberg (Ocean Mod., 2005). +!! +!! To work, the following fields must be set outside of the usual (is:ie,js:je) +!! range before this subroutine is called: +!! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). +subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, eta) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness, [H ~> kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: PFu !< Zonal acceleration due to pressure gradients + !! (equal to -dM/dx) [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: PFv !< Meridional acceleration due to pressure gradients + !! (equal to -dM/dy) [L T-2 ~> m s-2]. + type(PressureForce_Mont_CS), intent(inout) :: CS !< Control structure for Montgomery potential PGF + real, dimension(:,:), pointer :: p_atm !< The pressure at the ice-ocean or + !! atmosphere-ocean [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: pbce !< The baroclinic pressure anomaly in + !! each layer due to free surface height anomalies, + !! [L2 T-2 H-1 ~> m s-2 or m4 kg-1 s-2]. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The total column mass used to calculate + !! PFu and PFv [H ~> kg m-2]. + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + M, & ! The Montgomery potential, M = (p/rho + gz) [L2 T-2 ~> m2 s-2]. + alpha_star, & ! Compression adjusted specific volume [R-1 ~> m3 kg-1]. + dz_geo ! The change in geopotential across a layer [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: p ! Interface pressure [R L2 T-2 ~> Pa]. + ! p may be adjusted (with a nonlinear equation of state) so that + ! its derivative compensates for the adiabatic compressibility + ! in seawater, but p will still be close to the pressure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & + T_tmp, & ! Temporary array of temperatures where layers that are lighter + ! than the mixed layer have the mixed layer's properties [C ~> degC]. + S_tmp ! Temporary array of salinities where layers that are lighter + ! than the mixed layer have the mixed layer's properties [S ~> ppt]. + + real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the + ! deepest variable density near-surface layer [R ~> kg m-3]. + + real, dimension(SZI_(G),SZJ_(G)) :: & + dM, & ! A barotropic correction to the Montgomery potentials to enable the use + ! of a reduced gravity form of the equations [L2 T-2 ~> m2 s-2]. + dp_star, & ! Layer thickness after compensation for compressibility [R L2 T-2 ~> Pa]. + SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. + e_sal, & ! Bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_tide_eq, & ! Bottom geopotential anomaly due to tidal forces from astronomical sources [Z ~> m]. + e_tide_sal, & ! Bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides [Z ~> m]. + geopot_bot ! Bottom geopotential relative to a temporally fixed reference value, + ! including any tidal contributions [L2 T-2 ~> m2 s-2]. + real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate + ! density [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). + real :: rho_in_situ(SZI_(G)) !In-situ density of a layer [R ~> kg m-3]. + real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer + ! compensated density gradients [L T-2 ~> m s-2] + real :: dp_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. + logical :: use_p_atm ! If true, use the atmospheric pressure. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: is_split ! A flag indicating whether the pressure gradient terms are to be + ! split into barotropic and baroclinic pieces. + type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. + + real :: I_gEarth ! The inverse of g_Earth [T2 Z L-2 ~> s2 m-1] +! real :: dalpha + real :: Pa_to_H ! A factor to convert from R L2 T-2 to the thickness units (H) + ! [H T2 R-1 L-2 ~> m2 s2 kg-1 or s2 m-1]. + real :: alpha_Lay(SZK_(GV)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. + real :: dalpha_int(SZK_(GV)+1) ! The change in specific volume across each + ! interface [R-1 ~> m3 kg-1]. + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb + integer :: i, j, k + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + nkmb=GV%nk_rho_varies + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + + use_p_atm = associated(p_atm) + is_split = present(pbce) + use_EOS = associated(tv%eqn_of_state) + + if (.not.CS%initialized) call MOM_error(FATAL, & + "MOM_PressureForce_Mont: Module must be initialized before it is used.") + + if (use_EOS) then + if (query_compressible(tv%eqn_of_state)) call MOM_error(FATAL, & + "PressureForce_Mont_nonBouss: The Montgomery form of the pressure force "//& + "can no longer be used with a compressible EOS. Use #define ANALYTIC_FV_PGF.") + endif + + I_gEarth = 1.0 / GV%g_Earth + dp_neglect = GV%g_Earth * GV%H_to_RZ * GV%H_subroundoff + do k=1,nz ; alpha_Lay(k) = 1.0 / (GV%Rlay(k)) ; enddo + do k=2,nz ; dalpha_int(K) = alpha_Lay(k-1) - alpha_Lay(k) ; enddo + + if (use_p_atm) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; p(i,j,1) = p_atm(i,j) ; enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; p(i,j,1) = 0.0 ; enddo ; enddo + endif + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 + p(i,j,K+1) = p(i,j,K) + GV%g_Earth * GV%H_to_RZ * h(i,j,k) + enddo ; enddo ; enddo + + if (present(eta)) then + Pa_to_H = 1.0 / (GV%g_Earth * GV%H_to_RZ) + if (use_p_atm) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = (p(i,j,nz+1) - p_atm(i,j)) * Pa_to_H ! eta has the same units as h. + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = p(i,j,nz+1) * Pa_to_H ! eta has the same units as h. + enddo ; enddo + endif + endif + + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + geopot_bot(i,j) = -GV%g_Earth * G%bathyT(i,j) + enddo ; enddo + + ! Calculate and add the self-attraction and loading geopotential anomaly. + if (CS%calculate_SAL) then + ! Determine the sea surface height anomalies, to enable the calculation + ! of self-attraction and loading. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) + enddo ; enddo + if (use_EOS) then + !$OMP parallel do default(shared) + do k=1,nz + call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), & + 0.0, G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=1) + enddo + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 + SSH(i,j) = SSH(i,j) + I_gEarth * dz_geo(i,j,k) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 + SSH(i,j) = SSH(i,j) + GV%H_to_RZ * h(i,j,k) * alpha_Lay(k) + enddo ; enddo ; enddo + endif + + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + geopot_bot(i,j) = geopot_bot(i,j) - GV%g_Earth*e_sal(i,j) + enddo ; enddo + endif + + ! Calculate and add the tidal geopotential anomaly. + if (CS%tides) then + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + geopot_bot(i,j) = geopot_bot(i,j) - GV%g_Earth*(e_tide_eq(i,j) + e_tide_sal(i,j)) + enddo ; enddo + endif + + if (use_EOS) then + ! Calculate in-situ specific volumes (alpha_star). + + ! With a bulk mixed layer, replace the T & S of any layers that are + ! lighter than the buffer layer with the properties of the buffer + ! layer. These layers will be massless anyway, and it avoids any + ! formal calculations with hydrostatically unstable profiles. + if (nkmb>0) then + tv_tmp%T => T_tmp ; tv_tmp%S => S_tmp + tv_tmp%eqn_of_state => tv%eqn_of_state + do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo + !$OMP parallel do default(shared) private(Rho_cv_BL) + do j=Jsq,Jeq+1 + do k=1,nkmb ; do i=Isq,Ieq+1 + tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) + enddo ; enddo + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), & + tv%eqn_of_state, EOSdom) + do k=nkmb+1,nz ; do i=Isq,Ieq+1 + if (GV%Rlay(k) < Rho_cv_BL(i)) then + tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) + else + tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) + endif + enddo ; enddo + enddo + else + tv_tmp%T => tv%T ; tv_tmp%S => tv%S + tv_tmp%eqn_of_state => tv%eqn_of_state + do i=Isq,Ieq+1 ; p_ref(i) = 0 ; enddo + endif + !$OMP parallel do default(shared) private(rho_in_situ) + do k=1,nz ; do j=Jsq,Jeq+1 + call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_in_situ, & + tv%eqn_of_state, EOSdom) + do i=Isq,Ieq+1 ; alpha_star(i,j,k) = 1.0 / rho_in_situ(i) ; enddo + enddo ; enddo + endif ! use_EOS + + if (use_EOS) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + M(i,j,nz) = geopot_bot(i,j) + p(i,j,nz+1) * alpha_star(i,j,nz) + enddo + do k=nz-1,1,-1 ; do i=Isq,Ieq+1 + M(i,j,k) = M(i,j,k+1) + p(i,j,K+1) * (alpha_star(i,j,k) - alpha_star(i,j,k+1)) + enddo ; enddo + enddo + else ! not use_EOS + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + M(i,j,nz) = geopot_bot(i,j) + p(i,j,nz+1) * alpha_Lay(nz) + enddo + do k=nz-1,1,-1 ; do i=Isq,Ieq+1 + M(i,j,k) = M(i,j,k+1) + p(i,j,K+1) * dalpha_int(K+1) + enddo ; enddo + enddo + endif ! use_EOS + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * M(i,j,1) + enddo ; enddo + !$OMP parallel do default(shared) + do k=1,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + M(i,j,k) = M(i,j,k) + dM(i,j) + enddo ; enddo ; enddo + + ! Could instead do the following, to avoid taking small differences + ! of large numbers... +! do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 +! M(i,j,1) = CS%GFS_scale * M(i,j,1) +! enddo ; enddo +! if (use_EOS) then +! do k=2,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 +! M(i,j,k) = M(i,j,k-1) - p(i,j,K) * (alpha_star(i,j,k-1) - alpha_star(i,j,k)) +! enddo ; enddo ; enddo +! else ! not use_EOS +! do k=2,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 +! M(i,j,k) = M(i,j,k-1) - p(i,j,K) * dalpha_int(K) +! enddo ; enddo ; enddo +! endif ! use_EOS + + endif + + ! Note that ddM/dPb = alpha_star(i,j,1) + if (present(pbce)) then + call Set_pbce_nonBouss(p, tv_tmp, G, GV, US, CS%GFS_scale, pbce, alpha_star) + endif + +! Calculate the pressure force. On a Cartesian grid, +! PFu = - dM/dx and PFv = - dM/dy. + if (use_EOS) then + !$OMP parallel do default(shared) private(dp_star,PFu_bc,PFv_bc) + do k=1,nz + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dp_star(i,j) = (p(i,j,K+1) - p(i,j,K)) + dp_neglect + enddo ; enddo + do j=js,je ; do I=Isq,Ieq + ! PFu_bc = p* grad alpha* + PFu_bc = (alpha_star(i+1,j,k) - alpha_star(i,j,k)) * (G%IdxCu(I,j) * & + ((dp_star(i,j)*dp_star(i+1,j) + (p(i,j,K)*dp_star(i+1,j) + p(i+1,j,K)*dp_star(i,j))) / & + (dp_star(i,j) + dp_star(i+1,j)))) + PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) + PFu_bc + if (allocated(CS%PFu_bc)) CS%PFu_bc(i,j,k) = PFu_bc + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + PFv_bc = (alpha_star(i,j+1,k) - alpha_star(i,j,k)) * (G%IdyCv(i,J) * & + ((dp_star(i,j)*dp_star(i,j+1) + (p(i,j,K)*dp_star(i,j+1) + p(i,j+1,K)*dp_star(i,j))) / & + (dp_star(i,j) + dp_star(i,j+1)))) + PFv(i,J,k) = -(M(i,j+1,k) - M(i,j,k)) * G%IdyCv(i,J) + PFv_bc + if (allocated(CS%PFv_bc)) CS%PFv_bc(i,j,k) = PFv_bc + enddo ; enddo + enddo ! k-loop + else ! .not. use_EOS + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = -(M(i,j+1,k) - M(i,j,k)) * G%IdyCv(i,J) + enddo ; enddo + enddo + endif ! use_EOS + + if (CS%id_PFu_bc>0) call post_data(CS%id_PFu_bc, CS%PFu_bc, CS%diag) + if (CS%id_PFv_bc>0) call post_data(CS%id_PFv_bc, CS%PFv_bc, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) + +end subroutine PressureForce_Mont_nonBouss + +!> \brief Boussinesq Montgomery-potential form of pressure gradient +!! +!! Determines the acceleration due to pressure forces. +!! +!! To work, the following fields must be set outside of the usual (is:ie,js:je) +!! range before this subroutine is called: +!! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). +subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, eta) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m]. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: PFu !< Zonal acceleration due to pressure gradients + !! (equal to -dM/dx) [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: PFv !< Meridional acceleration due to pressure gradients + !! (equal to -dM/dy) [L T-2 ~> m s-2]. + type(PressureForce_Mont_CS), intent(inout) :: CS !< Control structure for Montgomery potential PGF + real, dimension(:,:), pointer :: p_atm !< The pressure at the ice-ocean or + !! atmosphere-ocean [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(out) :: pbce !< The baroclinic pressure anomaly in + !! each layer due to free surface height anomalies + !! [L2 T-2 H-1 ~> m s-2]. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< Free surface height [H ~> m]. + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + M, & ! The Montgomery potential, M = (p/rho + gz) [L2 T-2 ~> m2 s-2]. + rho_star ! In-situ density divided by the derivative with depth of the + ! corrected e times (G_Earth/Rho0) [L2 Z-1 T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! Interface height [Z ~> m]. + ! e may be adjusted (with a nonlinear equation of state) so that + ! its derivative compensates for the adiabatic compressibility + ! in seawater, but e will still be close to the interface depth. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & + T_tmp, & ! Temporary array of temperatures where layers that are lighter + ! than the mixed layer have the mixed layer's properties [C ~> degC]. + S_tmp ! Temporary array of salinities where layers that are lighter + ! than the mixed layer have the mixed layer's properties [S ~> ppt]. + + real :: Rho_cv_BL(SZI_(G)) ! The coordinate potential density in + ! the deepest variable density near-surface layer [R ~> kg m-3]. + real :: h_star(SZI_(G),SZJ_(G)) ! Layer thickness after compensation + ! for compressibility [Z ~> m]. + real :: SSH(SZI_(G),SZJ_(G)) ! The sea surface height anomaly, in depth units [Z ~> m]. + real :: e_sal(SZI_(G),SZJ_(G)) ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + real :: e_tide_eq(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal forces from astronomical sources + ! [Z ~> m]. + real :: e_tide_sal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides, in depth units [Z ~> m]. + real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate + ! density [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). + real :: I_Rho0 ! 1/Rho0 [R-1 ~> m3 kg-1]. + real :: G_Rho0 ! G_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. + real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer + ! compensated density gradients [L T-2 ~> m s-2] + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + logical :: use_p_atm ! If true, use the atmospheric pressure. + logical :: use_EOS ! If true, density is calculated from T & S using + ! an equation of state. + logical :: is_split ! A flag indicating whether the pressure + ! gradient terms are to be split into + ! barotropic and baroclinic pieces. + type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb + integer :: i, j, k + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + nkmb=GV%nk_rho_varies + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + + use_p_atm = associated(p_atm) + is_split = present(pbce) + use_EOS = associated(tv%eqn_of_state) + + if (.not.CS%initialized) call MOM_error(FATAL, & + "MOM_PressureForce_Mont: Module must be initialized before it is used.") + + if (use_EOS) then + if (query_compressible(tv%eqn_of_state)) call MOM_error(FATAL, & + "PressureForce_Mont_Bouss: The Montgomery form of the pressure force "//& + "can no longer be used with a compressible EOS. Use #define ANALYTIC_FV_PGF.") + endif + + dz_neglect = GV%dZ_subroundoff + I_Rho0 = 1.0/CS%Rho0 + G_Rho0 = GV%g_Earth / GV%Rho0 + + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -G%bathyT(i,j) + enddo ; enddo + + ! Calculate and add the self-attraction and loading geopotential anomaly. + if (CS%calculate_SAL) then + ! Determine the surface height anomaly for calculating self attraction + ! and loading. This should really be based on bottom pressure anomalies, + ! but that is not yet implemented, and the current form is correct for + ! barotropic tides. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 ; SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) ; enddo + do k=1,nz ; do i=Isq,Ieq+1 + SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z + enddo ; enddo + enddo + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) + enddo ; enddo + endif + + ! Calculate and add the tidal geopotential anomaly. + if (CS%tides) then + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = e(i,j,nz+1) - (e_tide_eq(i,j) + e_tide_sal(i,j)) + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do k=nz,1,-1 ; do i=Isq,Ieq+1 + e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z + enddo ; enddo ; enddo + + if (use_EOS) then +! Calculate in-situ densities (rho_star). + +! With a bulk mixed layer, replace the T & S of any layers that are +! lighter than the buffer layer with the properties of the buffer +! layer. These layers will be massless anyway, and it avoids any +! formal calculations with hydrostatically unstable profiles. + + if (nkmb>0) then + tv_tmp%T => T_tmp ; tv_tmp%S => S_tmp + tv_tmp%eqn_of_state => tv%eqn_of_state + + do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo + !$OMP parallel do default(shared) private(Rho_cv_BL) + do j=Jsq,Jeq+1 + do k=1,nkmb ; do i=Isq,Ieq+1 + tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) + enddo ; enddo + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), & + tv%eqn_of_state, EOSdom) + + do k=nkmb+1,nz ; do i=Isq,Ieq+1 + if (GV%Rlay(k) < Rho_cv_BL(i)) then + tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) + else + tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) + endif + enddo ; enddo + enddo + else + tv_tmp%T => tv%T ; tv_tmp%S => tv%S + tv_tmp%eqn_of_state => tv%eqn_of_state + do i=Isq,Ieq+1 ; p_ref(i) = 0.0 ; enddo + endif + + ! This no longer includes any pressure dependency, since this routine + ! will come down with a fatal error if there is any compressibility. + !$OMP parallel do default(shared) + do k=1,nz ; do j=Jsq,Jeq+1 + call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), & + tv%eqn_of_state, EOSdom) + do i=Isq,Ieq+1 ; rho_star(i,j,k) = G_Rho0*rho_star(i,j,k) ; enddo + enddo ; enddo + endif ! use_EOS + +! Here the layer Montgomery potentials, M, are calculated. + if (use_EOS) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + M(i,j,1) = CS%GFS_scale * (rho_star(i,j,1) * e(i,j,1)) + if (use_p_atm) M(i,j,1) = M(i,j,1) + p_atm(i,j) * I_Rho0 + enddo + do k=2,nz ; do i=Isq,Ieq+1 + M(i,j,k) = M(i,j,k-1) + (rho_star(i,j,k) - rho_star(i,j,k-1)) * e(i,j,K) + enddo ; enddo + enddo + else ! not use_EOS + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + M(i,j,1) = GV%g_prime(1) * e(i,j,1) + if (use_p_atm) M(i,j,1) = M(i,j,1) + p_atm(i,j) * I_Rho0 + enddo + do k=2,nz ; do i=Isq,Ieq+1 + M(i,j,k) = M(i,j,k-1) + GV%g_prime(K) * e(i,j,K) + enddo ; enddo + enddo + endif ! use_EOS + + if (present(pbce)) then + call Set_pbce_Bouss(e, tv_tmp, G, GV, US, CS%Rho0, CS%GFS_scale, pbce, rho_star) + endif + +! Calculate the pressure force. On a Cartesian grid, +! PFu = - dM/dx and PFv = - dM/dy. + if (use_EOS) then + !$OMP parallel do default(shared) private(h_star,PFu_bc,PFv_bc) + do k=1,nz + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + h_star(i,j) = (e(i,j,K) - e(i,j,K+1)) + dz_neglect + enddo ; enddo + do j=js,je ; do I=Isq,Ieq + PFu_bc = -1.0*(rho_star(i+1,j,k) - rho_star(i,j,k)) * (G%IdxCu(I,j) * & + ((h_star(i,j) * h_star(i+1,j) - (e(i,j,K) * h_star(i+1,j) + & + e(i+1,j,K) * h_star(i,j))) / (h_star(i,j) + h_star(i+1,j)))) + PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) + PFu_bc + if (allocated(CS%PFu_bc)) CS%PFu_bc(i,j,k) = PFu_bc + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + PFv_bc = -1.0*(rho_star(i,j+1,k) - rho_star(i,j,k)) * (G%IdyCv(i,J) * & + ((h_star(i,j) * h_star(i,j+1) - (e(i,j,K) * h_star(i,j+1) + & + e(i,j+1,K) * h_star(i,j))) / (h_star(i,j) + h_star(i,j+1)))) + PFv(i,J,k) = -(M(i,j+1,k) - M(i,j,k)) * G%IdyCv(i,J) + PFv_bc + if (allocated(CS%PFv_bc)) CS%PFv_bc(i,j,k) = PFv_bc + enddo ; enddo + enddo ! k-loop + else ! .not. use_EOS + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = -(M(i,j+1,k) - M(i,j,k)) * G%IdyCv(i,J) + enddo ; enddo + enddo + endif ! use_EOS + + if (present(eta)) then + ! eta is the sea surface height relative to a time-invariant geoid, for + ! comparison with what is used for eta in btstep. See how e was calculated + ! about 200 lines above. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = e(i,j,1)*GV%Z_to_H + enddo ; enddo + if (CS%tides) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = eta(i,j) + (e_tide_eq(i,j)+e_tide_sal(i,j))*GV%Z_to_H + enddo ; enddo + endif + if (CS%calculate_SAL) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = eta(i,j) + e_sal(i,j)*GV%Z_to_H + enddo ; enddo + endif + endif + + if (CS%id_PFu_bc>0) call post_data(CS%id_PFu_bc, CS%PFu_bc, CS%diag) + if (CS%id_PFv_bc>0) call post_data(CS%id_PFv_bc, CS%PFv_bc, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) + +end subroutine PressureForce_Mont_Bouss + +!> Determines the partial derivative of the acceleration due +!! to pressure forces with the free surface height. +subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface height [Z ~> m]. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< The "Boussinesq" ocean density [R ~> kg m-3]. + real, intent(in) :: GFS_scale !< Ratio between gravity applied to top + !! interface and the gravitational acceleration of + !! the planet [nondim]. Usually this ratio is 1. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: pbce !< The baroclinic pressure anomaly in each layer due + !! to free surface height anomalies + !! [L2 T-2 H-1 ~> m s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: rho_star !< The layer densities (maybe compressibility + !! compensated), times g/rho_0 [L2 Z-1 T-2 ~> m s-2]. + + ! Local variables + real :: Ihtot(SZI_(G)) ! The inverse of the sum of the layer thicknesses [H-1 ~> m-1 or m2 kg-1]. + real :: press(SZI_(G)) ! Interface pressure [R L2 T-2 ~> Pa]. + real :: T_int(SZI_(G)) ! Interface temperature [C ~> degC] + real :: S_int(SZI_(G)) ! Interface salinity [S ~> ppt] + real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + real :: rho_in_situ(SZI_(G)) ! In-situ density at the top of a layer [R ~> kg m-3]. + real :: G_Rho0 ! A scaled version of g_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + real :: Rho0xG ! g_Earth * Rho0 [R L2 Z-1 T-2 ~> kg s-2 m-2] + logical :: use_EOS ! If true, density is calculated from T & S using + ! an equation of state. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k + + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + + Rho0xG = Rho0 * GV%g_Earth + G_Rho0 = GV%g_Earth / GV%Rho0 + use_EOS = associated(tv%eqn_of_state) + dz_neglect = GV%dZ_subroundoff + + if (use_EOS) then + if (present(rho_star)) then + !$OMP parallel do default(shared) private(Ihtot) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect) + pbce(i,j,1) = GFS_scale * rho_star(i,j,1) * GV%H_to_Z + enddo + do k=2,nz ; do i=Isq,Ieq+1 + pbce(i,j,k) = pbce(i,j,k-1) + (rho_star(i,j,k)-rho_star(i,j,k-1)) * & + ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) + enddo ; enddo + enddo ! end of j loop + else + !$OMP parallel do default(shared) private(Ihtot,press,rho_in_situ,T_int,S_int,dR_dT,dR_dS) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect) + press(i) = -Rho0xG*(e(i,j,1) - G%Z_ref) + enddo + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, & + tv%eqn_of_state, EOSdom) + do i=Isq,Ieq+1 + pbce(i,j,1) = G_Rho0*(GFS_scale * rho_in_situ(i)) * GV%H_to_Z + enddo + do k=2,nz + do i=Isq,Ieq+1 + press(i) = -Rho0xG*(e(i,j,K) - G%Z_ref) + T_int(i) = 0.5*(tv%T(i,j,k-1)+tv%T(i,j,k)) + S_int(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) + enddo + call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, & + tv%eqn_of_state, EOSdom) + do i=Isq,Ieq+1 + pbce(i,j,k) = pbce(i,j,k-1) + G_Rho0 * & + ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) * & + (dR_dT(i)*(tv%T(i,j,k)-tv%T(i,j,k-1)) + & + dR_dS(i)*(tv%S(i,j,k)-tv%S(i,j,k-1))) + enddo + enddo + enddo ! end of j loop + endif + else ! not use_EOS + !$OMP parallel do default(shared) private(Ihtot) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + Ihtot(i) = 1.0 / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect) + pbce(i,j,1) = GV%g_prime(1) * GV%H_to_Z + enddo + do k=2,nz ; do i=Isq,Ieq+1 + pbce(i,j,k) = pbce(i,j,k-1) + & + (GV%g_prime(K)*GV%H_to_Z) * ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) + enddo ; enddo + enddo ! end of j loop + endif ! use_EOS + +end subroutine Set_pbce_Bouss + +!> Determines the partial derivative of the acceleration due +!! to pressure forces with the column mass. +subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: p !< Interface pressures [R L2 T-2 ~> Pa]. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: GFS_scale !< Ratio between gravity applied to top + !! interface and the gravitational acceleration of + !! the planet [nondim]. Usually this ratio is 1. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: pbce !< The baroclinic pressure anomaly in each + !! layer due to free surface height anomalies + !! [L2 H-1 T-2 ~> m4 kg-1 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: alpha_star !< The layer specific volumes + !! (maybe compressibility compensated) [R-1 ~> m3 kg-1]. + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + dpbce, & ! A barotropic correction to the pbce to enable the use of + ! a reduced gravity form of the equations [L2 H-1 T-2 ~> m4 kg-1 s-2]. + C_htot ! dP_dH divided by the total ocean pressure [H-1 ~> m2 kg-1]. + real :: T_int(SZI_(G)) ! Interface temperature [C ~> degC] + real :: S_int(SZI_(G)) ! Interface salinity [S ~> ppt] + real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + real :: rho_in_situ(SZI_(G)) ! In-situ density at an interface [R ~> kg m-3]. + real :: alpha_Lay(SZK_(GV)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. + real :: dalpha_int(SZK_(GV)+1) ! The change in specific volume across each interface [R-1 ~> m3 kg-1]. + real :: dP_dH ! A factor that converts from thickness to pressure times other dimensional + ! conversion factors [R L2 T-2 H-1 ~> Pa m2 kg-1]. + real :: dp_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k + + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + + use_EOS = associated(tv%eqn_of_state) + + dP_dH = GV%g_Earth * GV%H_to_RZ + dp_neglect = GV%g_Earth * GV%H_to_RZ * GV%H_subroundoff + + if (use_EOS) then + if (present(alpha_star)) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) + pbce(i,j,nz) = dP_dH * alpha_star(i,j,nz) + enddo + do k=nz-1,1,-1 ; do i=Isq,Ieq+1 + pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1)) * C_htot(i,j)) * & + (alpha_star(i,j,k) - alpha_star(i,j,k+1)) + enddo ; enddo + enddo + else + !$OMP parallel do default(shared) private(T_int,S_int,dR_dT,dR_dS,rho_in_situ) + do j=Jsq,Jeq+1 + call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), rho_in_situ, & + tv%eqn_of_state, EOSdom) + do i=Isq,Ieq+1 + C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) + pbce(i,j,nz) = dP_dH / (rho_in_situ(i)) + enddo + do k=nz-1,1,-1 + do i=Isq,Ieq+1 + T_int(i) = 0.5*(tv%T(i,j,k)+tv%T(i,j,k+1)) + S_int(i) = 0.5*(tv%S(i,j,k)+tv%S(i,j,k+1)) + enddo + call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, tv%eqn_of_state, EOSdom) + call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, & + tv%eqn_of_state, EOSdom) + do i=Isq,Ieq+1 + pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * & + ((dR_dT(i)*(tv%T(i,j,k+1)-tv%T(i,j,k)) + & + dR_dS(i)*(tv%S(i,j,k+1)-tv%S(i,j,k))) / (rho_in_situ(i)**2)) + enddo + enddo + enddo + endif + else ! not use_EOS + + do k=1,nz ; alpha_Lay(k) = 1.0 / (GV%Rlay(k)) ; enddo + do k=2,nz ; dalpha_int(K) = alpha_Lay(k-1) - alpha_Lay(k) ; enddo + + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) + pbce(i,j,nz) = dP_dH * alpha_Lay(nz) + enddo + do k=nz-1,1,-1 ; do i=Isq,Ieq+1 + pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * dalpha_int(K+1) + enddo ; enddo + enddo + endif ! use_EOS + + if (GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dpbce(i,j) = (GFS_scale - 1.0) * pbce(i,j,1) + enddo ; enddo + !$OMP parallel do default(shared) + do k=1,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pbce(i,j,k) = pbce(i,j,k) + dpbce(i,j) + enddo ; enddo ; enddo + endif + +end subroutine Set_pbce_nonBouss + +!> Initialize the Montgomery-potential form of PGF control structure +subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, tides_CSp) + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handles + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(PressureForce_Mont_CS), intent(inout) :: CS !< Montgomery PGF control structure + type(SAL_CS), intent(in), target, optional :: SAL_CSp !< SAL control structure + type(tidal_forcing_CS), intent(in), target, optional :: tides_CSp !< Tides control structure + + ! Local variables + logical :: use_EOS + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl ! This module's name. + + CS%initialized = .true. + CS%diag => diag ; CS%Time => Time + if (present(tides_CSp)) & + CS%tides_CSp => tides_CSp + if (present(SAL_CSp)) & + CS%SAL_CSp => SAL_CSp + + mdl = "MOM_PressureForce_Mont" + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) + call get_param(param_file, mdl, "TIDES", CS%tides, & + "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%tides) + call get_param(param_file, mdl, "USE_EOS", use_EOS, default=.true., & + do_not_log=.true.) ! Input for diagnostic use only. + + if (use_EOS) then + CS%id_PFu_bc = register_diag_field('ocean_model', 'PFu_bc', diag%axesCuL, Time, & + 'Density Gradient Zonal Pressure Force Accel.', "meter second-2", conversion=US%L_T2_to_m_s2) + CS%id_PFv_bc = register_diag_field('ocean_model', 'PFv_bc', diag%axesCvL, Time, & + 'Density Gradient Meridional Pressure Force Accel.', "meter second-2", conversion=US%L_T2_to_m_s2) + if (CS%id_PFu_bc > 0) & + allocate(CS%PFu_bc(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.) + if (CS%id_PFv_bc > 0) & + allocate(CS%PFv_bc(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.) + endif + + if (CS%calculate_SAL) then + CS%id_e_sal = register_diag_field('ocean_model', 'e_sal', diag%axesT1, Time, & + 'Self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) + endif + if (CS%tides) then + CS%id_e_tide = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, Time, & + 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_eq = register_diag_field('ocean_model', 'e_tide_eq', diag%axesT1, Time, & + 'Equilibrium tides height anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_sal = register_diag_field('ocean_model', 'e_tide_sal', diag%axesT1, Time, & + 'Read-in tidal self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) + endif + + CS%GFS_scale = 1.0 + if (GV%g_prime(1) /= GV%g_Earth) CS%GFS_scale = GV%g_prime(1) / GV%g_Earth + + call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale, units="nondim") + +end subroutine PressureForce_Mont_init + +!>\namespace mom_pressureforce_mont +!! +!! Provides the Boussunesq and non-Boussinesq forms of the horizontal +!! accelerations due to pressure gradients using the Montgomery potential. A +!! second-order accurate, centered scheme is used. If a split time stepping +!! scheme is used, the vertical decomposition into barotropic and baroclinic +!! contributions described by Hallberg (J Comp Phys 1997) is used. With a +!! nonlinear equation of state, compressibility is added along the lines proposed +!! by Sun et al. (JPO 1999), but with compressibility coefficients based on a fit +!! to a user-provided reference profile. + +end module MOM_PressureForce_Mont diff --git a/core/MOM_barotropic.F90 b/core/MOM_barotropic.F90 new file mode 100644 index 0000000000..83bfab0820 --- /dev/null +++ b/core/MOM_barotropic.F90 @@ -0,0 +1,5277 @@ +!> Barotropic solver +module MOM_barotropic + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_checksums, only : chksum0 +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_debugging, only : hchksum, uvchksum +use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field +use MOM_diag_mediator, only : diag_ctrl, enable_averaging, enable_averages +use MOM_domains, only : min_across_PEs, clone_MOM_domain, deallocate_MOM_domain +use MOM_domains, only : To_All, Scalar_Pair, AGRID, CORNER, MOM_domain_type +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : start_group_pass, complete_group_pass, pass_var, pass_vector +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : mech_forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : vardesc, var_desc, MOM_read_data, slasher +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, open_boundary_query +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W +use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_segment_type +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_self_attr_load, only : scalar_SAL_sensitivity +use MOM_self_attr_load, only : SAL_CS +use MOM_time_manager, only : time_type, real_to_time, operator(+), operator(-) +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : BT_cont_type, alloc_bt_cont_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_variables, only : accel_diag_ptrs + +implicit none ; private + +#include +#ifdef STATIC_MEMORY_ +# ifndef BTHALO_ +# define BTHALO_ 0 +# endif +# define WHALOI_ MAX(BTHALO_-NIHALO_,0) +# define WHALOJ_ MAX(BTHALO_-NJHALO_,0) +# define NIMEMW_ 1-WHALOI_:NIMEM_+WHALOI_ +# define NJMEMW_ 1-WHALOJ_:NJMEM_+WHALOJ_ +# define NIMEMBW_ -WHALOI_:NIMEM_+WHALOI_ +# define NJMEMBW_ -WHALOJ_:NJMEM_+WHALOJ_ +# define SZIW_(G) NIMEMW_ +# define SZJW_(G) NJMEMW_ +# define SZIBW_(G) NIMEMBW_ +# define SZJBW_(G) NJMEMBW_ +#else +# define NIMEMW_ : +# define NJMEMW_ : +# define NIMEMBW_ : +# define NJMEMBW_ : +# define SZIW_(G) G%isdw:G%iedw +# define SZJW_(G) G%jsdw:G%jedw +# define SZIBW_(G) G%isdw-1:G%iedw +# define SZJBW_(G) G%jsdw-1:G%jedw +#endif + +public btcalc, bt_mass_source, btstep, barotropic_init, barotropic_end +public register_barotropic_restarts, set_dtbt, barotropic_get_tav + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> The barotropic stepping open boundary condition type +type, private :: BT_OBC_type + real, allocatable :: Cg_u(:,:) !< The external wave speed at u-points [L T-1 ~> m s-1]. + real, allocatable :: Cg_v(:,:) !< The external wave speed at u-points [L T-1 ~> m s-1]. + real, allocatable :: dZ_u(:,:) !< The total vertical column extent at the u-points [Z ~> m]. + real, allocatable :: dZ_v(:,:) !< The total vertical column extent at the v-points [Z ~> m]. + real, allocatable :: uhbt(:,:) !< The zonal barotropic thickness fluxes specified + !! for open boundary conditions (if any) [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, allocatable :: vhbt(:,:) !< The meridional barotropic thickness fluxes specified + !! for open boundary conditions (if any) [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, allocatable :: ubt_outer(:,:) !< The zonal velocities just outside the domain, + !! as set by the open boundary conditions [L T-1 ~> m s-1]. + real, allocatable :: vbt_outer(:,:) !< The meridional velocities just outside the domain, + !! as set by the open boundary conditions [L T-1 ~> m s-1]. + real, allocatable :: SSH_outer_u(:,:) !< The surface height outside of the domain + !! at a u-point with an open boundary condition [Z ~> m]. + real, allocatable :: SSH_outer_v(:,:) !< The surface height outside of the domain + !! at a v-point with an open boundary condition [Z ~> m]. + logical :: apply_u_OBCs !< True if this PE has an open boundary at a u-point. + logical :: apply_v_OBCs !< True if this PE has an open boundary at a v-point. + !>@{ Index ranges for the open boundary conditions + integer :: is_u_obc, ie_u_obc, js_u_obc, je_u_obc + integer :: is_v_obc, ie_v_obc, js_v_obc, je_v_obc + !>@} + logical :: is_alloced = .false. !< True if BT_OBC is in use and has been allocated + + type(group_pass_type) :: pass_uv !< Structure for group halo pass + type(group_pass_type) :: pass_uhvh !< Structure for group halo pass + type(group_pass_type) :: pass_h !< Structure for group halo pass + type(group_pass_type) :: pass_cg !< Structure for group halo pass + type(group_pass_type) :: pass_eta_outer !< Structure for group halo pass +end type BT_OBC_type + +!> The barotropic stepping control structure +type, public :: barotropic_CS ; private + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: frhatu + !< The fraction of the total column thickness interpolated to u grid points in each layer [nondim]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: frhatv + !< The fraction of the total column thickness interpolated to v grid points in each layer [nondim]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: IDatu + !< Inverse of the total thickness at u grid points [H-1 ~> m-1 or m2 kg-1]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: lin_drag_u + !< A spatially varying linear drag coefficient acting on the zonal barotropic flow + !! [H T-1 ~> m s-1 or kg m-2 s-1]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: ubt_IC + !< The barotropic solvers estimate of the zonal velocity that will be the initial + !! condition for the next call to btstep [L T-1 ~> m s-1]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: ubtav + !< The barotropic zonal velocity averaged over the baroclinic time step [L T-1 ~> m s-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: IDatv + !< Inverse of the basin depth at v grid points [Z-1 ~> m-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: lin_drag_v + !< A spatially varying linear drag coefficient acting on the zonal barotropic flow + !! [H T-1 ~> m s-1 or kg m-2 s-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vbt_IC + !< The barotropic solvers estimate of the zonal velocity that will be the initial + !! condition for the next call to btstep [L T-1 ~> m s-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vbtav + !< The barotropic meridional velocity averaged over the baroclinic time step [L T-1 ~> m s-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_cor + !< The difference between the free surface height from the barotropic calculation and the sum + !! of the layer thicknesses. This difference is imposed as a forcing term in the barotropic + !! calculation over a baroclinic timestep [H ~> m or kg m-2]. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_cor_bound + !< A limit on the rate at which eta_cor can be applied while avoiding instability + !! [H T-1 ~> m s-1 or kg m-2 s-1]. This is only used if CS%bound_BT_corr is true. + real ALLOCABLE_, dimension(NIMEMW_,NJMEMW_) :: & + ua_polarity, & !< Test vector components for checking grid polarity [nondim] + va_polarity, & !< Test vector components for checking grid polarity [nondim] + bathyT !< A copy of bathyT (ocean bottom depth) with wide halos [Z ~> m] + real ALLOCABLE_, dimension(NIMEMW_,NJMEMW_) :: IareaT + !< This is a copy of G%IareaT with wide halos, but will + !! still utilize the macro IareaT when referenced, [L-2 ~> m-2]. + real ALLOCABLE_, dimension(NIMEMBW_,NJMEMW_) :: & + D_u_Cor, & !< A simply averaged depth at u points recast as a thickness [H ~> m or kg m-2] + dy_Cu, & !< A copy of G%dy_Cu with wide halos [L ~> m]. + IdxCu !< A copy of G%IdxCu with wide halos [L-1 ~> m-1]. + real ALLOCABLE_, dimension(NIMEMW_,NJMEMBW_) :: & + D_v_Cor, & !< A simply averaged depth at v points recast as a thickness [H ~> m or kg m-2] + dx_Cv, & !< A copy of G%dx_Cv with wide halos [L ~> m]. + IdyCv !< A copy of G%IdyCv with wide halos [L-1 ~> m-1]. + real ALLOCABLE_, dimension(NIMEMBW_,NJMEMBW_) :: & + q_D !< f / D at PV points [Z-1 T-1 ~> m-1 s-1]. + + real, allocatable :: frhatu1(:,:,:) !< Predictor step values of frhatu stored for diagnostics [nondim] + real, allocatable :: frhatv1(:,:,:) !< Predictor step values of frhatv stored for diagnostics [nondim] + + type(BT_OBC_type) :: BT_OBC !< A structure with all of this modules fields + !! for applying open boundary conditions. + + real :: dtbt !< The barotropic time step [T ~> s]. + real :: dtbt_fraction !< The fraction of the maximum time-step that + !! should used [nondim]. The default is 0.98. + real :: dtbt_max !< The maximum stable barotropic time step [T ~> s]. + real :: dt_bt_filter !< The time-scale over which the barotropic mode solutions are + !! filtered [T ~> s] if positive, or as a fraction of DT if + !! negative [nondim]. This can never be taken to be longer than 2*dt. + !! Set this to 0 to apply no filtering. + integer :: nstep_last = 0 !< The number of barotropic timesteps per baroclinic + !! time step the last time btstep was called. + real :: bebt !< A nondimensional number, from 0 to 1, that + !! determines the gravity wave time stepping scheme [nondim]. + !! 0.0 gives a forward-backward scheme, while 1.0 + !! give backward Euler. In practice, bebt should be + !! of order 0.2 or greater. + real :: Rho_BT_lin !< A density that is used to convert total water column thicknesses + !! into mass in non-Boussinesq mode with linearized options in the + !! barotropic solver or when estimating the stable barotropic timestep + !! without access to the full baroclinic model state [R ~> kg m-3] + logical :: split !< If true, use the split time stepping scheme. + logical :: bound_BT_corr !< If true, the magnitude of the fake mass source + !! in the barotropic equation that drives the two + !! estimates of the free surface height toward each + !! other is bounded to avoid driving corrective + !! velocities that exceed MAXCFL_BT_CONT. + logical :: gradual_BT_ICs !< If true, adjust the initial conditions for the + !! barotropic solver to the values from the layered + !! solution over a whole timestep instead of + !! instantly. This is a decent approximation to the + !! inclusion of sum(u dh_dt) while also correcting + !! for truncation errors. + logical :: Sadourny !< If true, the Coriolis terms are discretized + !! with Sadourny's energy conserving scheme, + !! otherwise the Arakawa & Hsu scheme is used. If + !! the deformation radius is not resolved Sadourny's + !! scheme should probably be used. + logical :: integral_bt_cont !< If true, use the time-integrated velocity over the barotropic steps + !! to determine the integrated transports used to update the continuity + !! equation. Otherwise the transports are the sum of the transports + !! based on a series of instantaneous velocities and the BT_CONT_TYPE + !! for transports. This is only valid if a BT_CONT_TYPE is used. + logical :: Nonlinear_continuity !< If true, the barotropic continuity equation + !! uses the full ocean thickness for transport. + integer :: Nonlin_cont_update_period !< The number of barotropic time steps + !! between updates to the face area, or 0 only to + !! update at the start of a call to btstep. The + !! default is 1. + logical :: BT_project_velocity !< If true, step the barotropic velocity first + !! and project out the velocity tendency by 1+BEBT + !! when calculating the transport. The default + !! (false) is to use a predictor continuity step to + !! find the pressure field, and then do a corrector + !! continuity step using a weighted average of the + !! old and new velocities, with weights of (1-BEBT) and BEBT. + logical :: nonlin_stress !< If true, use the full depth of the ocean at the start of the + !! barotropic step when calculating the surface stress contribution to + !! the barotropic acclerations. Otherwise use the depth based on bathyT. + real :: BT_Coriolis_scale !< A factor by which the barotropic Coriolis acceleration anomaly + !! terms are scaled [nondim]. + integer :: answer_date !< The vintage of the expressions in the barotropic solver. + !! Values below 20190101 recover the answers from the end of 2018, + !! while higher values use more efficient or general expressions. + + logical :: dynamic_psurf !< If true, add a dynamic pressure due to a viscous + !! ice shelf, for instance. + real :: Dmin_dyn_psurf !< The minimum total thickness to use in limiting the size + !! of the dynamic surface pressure for stability [H ~> m or kg m-2]. + real :: ice_strength_length !< The length scale at which the damping rate + !! due to the ice strength should be the same as if + !! a Laplacian were applied [L ~> m]. + real :: const_dyn_psurf !< The constant that scales the dynamic surface + !! pressure [nondim]. Stable values are < ~1.0. + !! The default is 0.9. + logical :: calculate_SAL !< If true, calculate self-attration and loading. + logical :: tidal_sal_bug !< If true, the tidal self-attraction and loading anomaly in the + !! barotropic solver has the wrong sign, replicating a long-standing + !! bug. + real :: G_extra !< A nondimensional factor by which gtot is enhanced [nondim]. + integer :: hvel_scheme !< An integer indicating how the thicknesses at + !! velocity points are calculated. Valid values are + !! given by the parameters defined below: + !! HARMONIC, ARITHMETIC, HYBRID, and FROM_BT_CONT + logical :: strong_drag !< If true, use a stronger estimate of the retarding + !! effects of strong bottom drag. + logical :: linear_wave_drag !< If true, apply a linear drag to the barotropic + !! velocities, using rates set by lin_drag_u & _v + !! divided by the depth of the ocean. + logical :: linearized_BT_PV !< If true, the PV and interface thicknesses used + !! in the barotropic Coriolis calculation is time + !! invariant and linearized. + logical :: use_wide_halos !< If true, use wide halos and march in during the + !! barotropic time stepping for efficiency. + logical :: clip_velocity !< If true, limit any velocity components that are + !! are large enough for a CFL number to exceed + !! CFL_trunc. This should only be used as a + !! desperate debugging measure. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: debug_bt !< If true, write verbose checksums for debugging purposes. + real :: vel_underflow !< Velocity components smaller than vel_underflow + !! are set to 0 [L T-1 ~> m s-1]. + real :: maxvel !< Velocity components greater than maxvel are + !! truncated to maxvel [L T-1 ~> m s-1]. + real :: CFL_trunc !< If clip_velocity is true, velocity components will + !! be truncated when they are large enough that the + !! corresponding CFL number exceeds this value [nondim]. + real :: maxCFL_BT_cont !< The maximum permitted CFL number associated with the + !! barotropic accelerations from the summed velocities + !! times the time-derivatives of thicknesses [nondim]. The + !! default is 0.1, and there will probably be real + !! problems if this were set close to 1. + logical :: BT_cont_bounds !< If true, use the BT_cont_type variables to set limits + !! on the magnitude of the corrective mass fluxes. + logical :: visc_rem_u_uh0 !< If true, use the viscous remnants when estimating + !! the barotropic velocities that were used to + !! calculate uh0 and vh0. False is probably the + !! better choice. + logical :: adjust_BT_cont !< If true, adjust the curve fit to the BT_cont type + !! that is used by the barotropic solver to match the + !! transport about which the flow is being linearized. + logical :: use_old_coriolis_bracket_bug !< If True, use an order of operations + !! that is not bitwise rotationally symmetric in the + !! meridional Coriolis term of the barotropic solver. + logical :: tidal_sal_flather !< Apply adjustment to external gravity wave speed + !! consistent with tidal self-attraction and loading + !! used within the barotropic solver + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean models clock. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate + !! the timing of diagnostic output. + type(MOM_domain_type), pointer :: BT_Domain => NULL() !< Barotropic MOM domain + type(hor_index_type), pointer :: debug_BT_HI => NULL() !< debugging copy of horizontal index_type + type(SAL_CS), pointer :: SAL_CSp => NULL() !< Control structure for SAL + logical :: module_is_initialized = .false. !< If true, module has been initialized + + integer :: isdw !< The lower i-memory limit for the wide halo arrays. + integer :: iedw !< The upper i-memory limit for the wide halo arrays. + integer :: jsdw !< The lower j-memory limit for the wide halo arrays. + integer :: jedw !< The upper j-memory limit for the wide halo arrays. + + type(group_pass_type) :: pass_q_DCor !< Handle for a group halo pass + type(group_pass_type) :: pass_gtot !< Handle for a group halo pass + type(group_pass_type) :: pass_tmp_uv !< Handle for a group halo pass + type(group_pass_type) :: pass_eta_bt_rem !< Handle for a group halo pass + type(group_pass_type) :: pass_force_hbt0_Cor_ref !< Handle for a group halo pass + type(group_pass_type) :: pass_Dat_uv !< Handle for a group halo pass + type(group_pass_type) :: pass_eta_ubt !< Handle for a group halo pass + type(group_pass_type) :: pass_etaav !< Handle for a group halo pass + type(group_pass_type) :: pass_ubt_Cor !< Handle for a group halo pass + type(group_pass_type) :: pass_ubta_uhbta !< Handle for a group halo pass + type(group_pass_type) :: pass_e_anom !< Handle for a group halo pass + type(group_pass_type) :: pass_SpV_avg !< Handle for a group halo pass + + !>@{ Diagnostic IDs + integer :: id_PFu_bt = -1, id_PFv_bt = -1, id_Coru_bt = -1, id_Corv_bt = -1 + integer :: id_ubtforce = -1, id_vbtforce = -1, id_uaccel = -1, id_vaccel = -1 + integer :: id_visc_rem_u = -1, id_visc_rem_v = -1, id_eta_cor = -1 + integer :: id_ubt = -1, id_vbt = -1, id_eta_bt = -1, id_ubtav = -1, id_vbtav = -1 + integer :: id_ubt_st = -1, id_vbt_st = -1, id_eta_st = -1 + integer :: id_ubtdt = -1, id_vbtdt = -1 + integer :: id_ubt_hifreq = -1, id_vbt_hifreq = -1, id_eta_hifreq = -1 + integer :: id_uhbt_hifreq = -1, id_vhbt_hifreq = -1, id_eta_pred_hifreq = -1 + integer :: id_gtotn = -1, id_gtots = -1, id_gtote = -1, id_gtotw = -1 + integer :: id_uhbt = -1, id_frhatu = -1, id_vhbt = -1, id_frhatv = -1 + integer :: id_frhatu1 = -1, id_frhatv1 = -1 + + integer :: id_BTC_FA_u_EE = -1, id_BTC_FA_u_E0 = -1, id_BTC_FA_u_W0 = -1, id_BTC_FA_u_WW = -1 + integer :: id_BTC_ubt_EE = -1, id_BTC_ubt_WW = -1 + integer :: id_BTC_FA_v_NN = -1, id_BTC_FA_v_N0 = -1, id_BTC_FA_v_S0 = -1, id_BTC_FA_v_SS = -1 + integer :: id_BTC_vbt_NN = -1, id_BTC_vbt_SS = -1 + integer :: id_BTC_FA_u_rat0 = -1, id_BTC_FA_v_rat0 = -1, id_BTC_FA_h_rat0 = -1 + integer :: id_uhbt0 = -1, id_vhbt0 = -1 + !>@} + +end type barotropic_CS + +!> A description of the functional dependence of transport at a u-point +type, private :: local_BT_cont_u_type + real :: FA_u_EE !< The effective open face area for zonal barotropic transport + !! drawing from locations far to the east [H L ~> m2 or kg m-1]. + real :: FA_u_E0 !< The effective open face area for zonal barotropic transport + !! drawing from nearby to the east [H L ~> m2 or kg m-1]. + real :: FA_u_W0 !< The effective open face area for zonal barotropic transport + !! drawing from nearby to the west [H L ~> m2 or kg m-1]. + real :: FA_u_WW !< The effective open face area for zonal barotropic transport + !! drawing from locations far to the west [H L ~> m2 or kg m-1]. + real :: uBT_WW !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal + !! open face area is FA_u_WW. uBT_WW must be non-negative. + real :: uBT_EE !< uBT_EE is a barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal + !! open face area is FA_u_EE. uBT_EE must be non-positive. + real :: uh_crvW !< The curvature of face area with velocity for flow from the west [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> nondim or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: uh_crvE !< The curvature of face area with velocity for flow from the east [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> nondim or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: uh_WW !< The zonal transport when ubt=ubt_WW [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. + real :: uh_EE !< The zonal transport when ubt=ubt_EE [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. +end type local_BT_cont_u_type + +!> A description of the functional dependence of transport at a v-point +type, private :: local_BT_cont_v_type + real :: FA_v_NN !< The effective open face area for meridional barotropic transport + !! drawing from locations far to the north [H L ~> m2 or kg m-1]. + real :: FA_v_N0 !< The effective open face area for meridional barotropic transport + !! drawing from nearby to the north [H L ~> m2 or kg m-1]. + real :: FA_v_S0 !< The effective open face area for meridional barotropic transport + !! drawing from nearby to the south [H L ~> m2 or kg m-1]. + real :: FA_v_SS !< The effective open face area for meridional barotropic transport + !! drawing from locations far to the south [H L ~> m2 or kg m-1]. + real :: vBT_SS !< vBT_SS is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal + !! open face area is FA_v_SS. vBT_SS must be non-negative. + real :: vBT_NN !< vBT_NN is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal + !! open face area is FA_v_NN. vBT_NN must be non-positive. + real :: vh_crvS !< The curvature of face area with velocity for flow from the south [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> nondim or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: vh_crvN !< The curvature of face area with velocity for flow from the north [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> nondim or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: vh_SS !< The meridional transport when vbt=vbt_SS [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. + real :: vh_NN !< The meridional transport when vbt=vbt_NN [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. +end type local_BT_cont_v_type + +!> A container for passing around active tracer point memory limits +type, private :: memory_size_type + !>@{ Currently active memory limits + integer :: isdw, iedw, jsdw, jedw ! The memory limits of the wide halo arrays. + !>@} +end type memory_size_type + +!>@{ CPU time clock IDs +integer :: id_clock_sync=-1, id_clock_calc=-1 +integer :: id_clock_calc_pre=-1, id_clock_calc_post=-1 +integer :: id_clock_pass_step=-1, id_clock_pass_pre=-1, id_clock_pass_post=-1 +!>@} + +!>@{ Enumeration values for various schemes +integer, parameter :: HARMONIC = 1 +integer, parameter :: ARITHMETIC = 2 +integer, parameter :: HYBRID = 3 +integer, parameter :: FROM_BT_CONT = 4 +integer, parameter :: HYBRID_BT_CONT = 5 +character*(20), parameter :: HYBRID_STRING = "HYBRID" +character*(20), parameter :: HARMONIC_STRING = "HARMONIC" +character*(20), parameter :: ARITHMETIC_STRING = "ARITHMETIC" +character*(20), parameter :: BT_CONT_STRING = "FROM_BT_CONT" +!>@} + +!> A negligible parameter which avoids division by zero, but is too small to +!! modify physical values [nondim]. +real, parameter :: subroundoff = 1e-30 + +contains + +!> This subroutine time steps the barotropic equations explicitly. +!! For gravity waves, anything between a forwards-backwards scheme +!! and a simulated backwards Euler scheme is used, with bebt between +!! 0.0 and 1.0 determining the scheme. In practice, bebt must be of +!! order 0.2 or greater. A forwards-backwards treatment of the +!! Coriolis terms is always used. +subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, & + eta_PF_in, U_Cor, V_Cor, accel_layer_u, accel_layer_v, & + eta_out, uhbtav, vhbtav, G, GV, US, CS, & + visc_rem_u, visc_rem_v, SpV_avg, ADp, OBC, BT_cont, eta_PF_start, & + taux_bot, tauy_bot, uh0, vh0, u_uh0, v_vh0, etaav) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: U_in !< The initial (3-D) zonal + !! velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: V_in !< The initial (3-D) meridional + !! velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta_in !< The initial barotropic free surface height + !! anomaly or column mass anomaly [H ~> m or kg m-2]. + real, intent(in) :: dt !< The time increment to integrate over [T ~> s]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: bc_accel_u !< The zonal baroclinic accelerations, + !! [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: bc_accel_v !< The meridional baroclinic accelerations, + !! [L T-2 ~> m s-2]. + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: pbce !< The baroclinic pressure anomaly in each layer + !! due to free surface height anomalies + !! [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta_PF_in !< The 2-D eta field (either SSH anomaly or + !! column mass anomaly) that was used to calculate the input + !! pressure gradient accelerations (or its final value if + !! eta_PF_start is provided [H ~> m or kg m-2]. + !! Note: eta_in, pbce, and eta_PF_in must have up-to-date + !! values in the first point of their halos. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: U_Cor !< The (3-D) zonal velocities used to + !! calculate the Coriolis terms in bc_accel_u [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: V_Cor !< The (3-D) meridional velocities used to + !! calculate the Coriolis terms in bc_accel_u [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: accel_layer_u !< The zonal acceleration of each layer due + !! to the barotropic calculation [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: accel_layer_v !< The meridional acceleration of each layer + !! due to the barotropic calculation [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_out !< The final barotropic free surface + !! height anomaly or column mass anomaly [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: uhbtav !< the barotropic zonal volume or mass + !! fluxes averaged through the barotropic steps + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), intent(out) :: vhbtav !< the barotropic meridional volume or mass + !! fluxes averaged through the barotropic steps + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: visc_rem_u !< Both the fraction of the momentum + !! originally in a layer that remains after a time-step of + !! viscosity, and the fraction of a time-step's worth of a + !! barotropic acceleration that a layer experiences after + !! viscosity is applied, in the zonal direction [nondim]. + !! Visc_rem_u is between 0 (at the bottom) and 1 (far above). + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: visc_rem_v !< Ditto for meridional direction [nondim]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SpV_avg !< The column average specific volume, used + !! in non-Boussinesq OBC calculations [R-1 ~> m3 kg-1] + type(accel_diag_ptrs), pointer :: ADp !< Acceleration diagnostic pointers + type(ocean_OBC_type), pointer :: OBC !< The open boundary condition structure. + type(BT_cont_type), pointer :: BT_cont !< A structure with elements that describe + !! the effective open face areas as a function of barotropic + !! flow. + real, dimension(:,:), pointer :: eta_PF_start !< The eta field consistent with the pressure + !! gradient at the start of the barotropic stepping + !! [H ~> m or kg m-2]. + real, dimension(:,:), pointer :: taux_bot !< The zonal bottom frictional stress from + !! ocean to the seafloor [R L Z T-2 ~> Pa]. + real, dimension(:,:), pointer :: tauy_bot !< The meridional bottom frictional stress + !! from ocean to the seafloor [R L Z T-2 ~> Pa]. + real, dimension(:,:,:), pointer :: uh0 !< The zonal layer transports at reference + !! velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(:,:,:), pointer :: u_uh0 !< The velocities used to calculate + !! uh0 [L T-1 ~> m s-1] + real, dimension(:,:,:), pointer :: vh0 !< The zonal layer transports at reference + !! velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(:,:,:), pointer :: v_vh0 !< The velocities used to calculate + !! vh0 [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: etaav !< The free surface height or column mass + !! averaged over the barotropic integration [H ~> m or kg m-2]. + + ! Local variables + real :: ubt_Cor(SZIB_(G),SZJ_(G)) ! The barotropic velocities that had been + real :: vbt_Cor(SZI_(G),SZJB_(G)) ! used to calculate the input Coriolis + ! terms [L T-1 ~> m s-1]. + real :: wt_u(SZIB_(G),SZJ_(G),SZK_(GV)) ! wt_u and wt_v are the + real :: wt_v(SZI_(G),SZJB_(G),SZK_(GV)) ! normalized weights to + ! be used in calculating barotropic velocities, possibly with + ! sums less than one due to viscous losses [nondim] + real, dimension(SZIB_(G),SZJ_(G)) :: & + av_rem_u, & ! The weighted average of visc_rem_u [nondim] + tmp_u, & ! A temporary array at u points [L T-2 ~> m s-2] or [nondim] + ubt_st, & ! The zonal barotropic velocity at the start of timestep [L T-1 ~> m s-1]. + ubt_dt ! The zonal barotropic velocity tendency [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G)) :: & + av_rem_v, & ! The weighted average of visc_rem_v [nondim] + tmp_v, & ! A temporary array at v points [L T-2 ~> m s-2] or [nondim] + vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1]. + vbt_dt ! The meridional barotropic velocity tendency [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + tmp_h, & ! A temporary array at h points [nondim] + e_anom ! The anomaly in the sea surface height or column mass + ! averaged between the beginning and end of the time step, + ! relative to eta_PF, with SAL effects included [H ~> m or kg m-2]. + + ! These are always allocated with symmetric memory and wide halos. + real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1] + real, dimension(SZIBW_(CS),SZJW_(CS)) :: & + ubt, & ! The zonal barotropic velocity [L T-1 ~> m s-1]. + bt_rem_u, & ! The fraction of the barotropic zonal velocity that remains + ! after a time step, the remainder being lost to bottom drag [nondim]. + ! bt_rem_u is between 0 and 1. + BT_force_u, & ! The vertical average of all of the u-accelerations that are + ! not explicitly included in the barotropic equation [L T-2 ~> m s-2]. + u_accel_bt, & ! The difference between the zonal acceleration from the + ! barotropic calculation and BT_force_u [L T-2 ~> m s-2]. + uhbt, & ! The zonal barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1]. + uhbt0, & ! The difference between the sum of the layer zonal thickness + ! fluxes and the barotropic thickness flux using the same + ! velocity [H L2 T-1 ~> m3 s-1 or kg s-1]. + ubt_old, & ! The starting value of ubt in a barotropic step [L T-1 ~> m s-1]. + ubt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1]. + ubt_sum, & ! The sum of ubt over the time steps [L T-1 ~> m s-1]. + ubt_int, & ! The running time integral of ubt over the time steps [L ~> m]. + uhbt_sum, & ! The sum of uhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1]. + uhbt_int, & ! The running time integral of uhbt over the time steps [H L2 ~> m3]. + ubt_wtd, & ! A weighted sum used to find the filtered final ubt [L T-1 ~> m s-1]. + ubt_trans, & ! The latest value of ubt used for a transport [L T-1 ~> m s-1]. + azon, bzon, & ! _zon and _mer are the values of the Coriolis force which + czon, dzon, & ! are applied to the neighboring values of vbtav and ubtav, + amer, bmer, & ! respectively to get the barotropic inertial rotation + cmer, dmer, & ! [T-1 ~> s-1]. + Cor_u, & ! The zonal Coriolis acceleration [L T-2 ~> m s-2]. + Cor_ref_u, & ! The zonal barotropic Coriolis acceleration due + ! to the reference velocities [L T-2 ~> m s-2]. + PFu, & ! The zonal pressure force acceleration [L T-2 ~> m s-2]. + Rayleigh_u, & ! A Rayleigh drag timescale operating at u-points [T-1 ~> s-1]. + PFu_bt_sum, & ! The summed zonal barotropic pressure gradient force [L T-2 ~> m s-2]. + Coru_bt_sum, & ! The summed zonal barotropic Coriolis acceleration [L T-2 ~> m s-2]. + DCor_u, & ! An averaged total thickness at u points [H ~> m or kg m-2]. + Datu ! Basin depth at u-velocity grid points times the y-grid + ! spacing [H L ~> m2 or kg m-1]. + real, dimension(SZIW_(CS),SZJBW_(CS)) :: & + vbt, & ! The meridional barotropic velocity [L T-1 ~> m s-1]. + bt_rem_v, & ! The fraction of the barotropic meridional velocity that + ! remains after a time step, the rest being lost to bottom + ! drag [nondim]. bt_rem_v is between 0 and 1. + BT_force_v, & ! The vertical average of all of the v-accelerations that are + ! not explicitly included in the barotropic equation [L T-2 ~> m s-2]. + v_accel_bt, & ! The difference between the meridional acceleration from the + ! barotropic calculation and BT_force_v [L T-2 ~> m s-2]. + vhbt, & ! The meridional barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1]. + vhbt0, & ! The difference between the sum of the layer meridional + ! thickness fluxes and the barotropic thickness flux using + ! the same velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. + vbt_old, & ! The starting value of vbt in a barotropic step [L T-1 ~> m s-1]. + vbt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1]. + vbt_sum, & ! The sum of vbt over the time steps [L T-1 ~> m s-1]. + vbt_int, & ! The running time integral of vbt over the time steps [L ~> m]. + vhbt_sum, & ! The sum of vhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1]. + vhbt_int, & ! The running time integral of vhbt over the time steps [H L2 ~> m3]. + vbt_wtd, & ! A weighted sum used to find the filtered final vbt [L T-1 ~> m s-1]. + vbt_trans, & ! The latest value of vbt used for a transport [L T-1 ~> m s-1]. + Cor_v, & ! The meridional Coriolis acceleration [L T-2 ~> m s-2]. + Cor_ref_v, & ! The meridional barotropic Coriolis acceleration due + ! to the reference velocities [L T-2 ~> m s-2]. + PFv, & ! The meridional pressure force acceleration [L T-2 ~> m s-2]. + Rayleigh_v, & ! A Rayleigh drag timescale operating at v-points [T-1 ~> s-1]. + PFv_bt_sum, & ! The summed meridional barotropic pressure gradient force, + ! [L T-2 ~> m s-2]. + Corv_bt_sum, & ! The summed meridional barotropic Coriolis acceleration, + ! [L T-2 ~> m s-2]. + DCor_v, & ! An averaged total thickness at v points [H ~> m or kg m-2]. + Datv ! Basin depth at v-velocity grid points times the x-grid + ! spacing [H L ~> m2 or kg m-1]. + real, target, dimension(SZIW_(CS),SZJW_(CS)) :: & + eta, & ! The barotropic free surface height anomaly or column mass + ! anomaly [H ~> m or kg m-2] + eta_pred ! A predictor value of eta [H ~> m or kg m-2] like eta. + real, dimension(:,:), pointer :: & + eta_PF_BT ! A pointer to the eta array (either eta or eta_pred) that + ! determines the barotropic pressure force [H ~> m or kg m-2] + real, dimension(SZIW_(CS),SZJW_(CS)) :: & + eta_sum, & ! eta summed across the timesteps [H ~> m or kg m-2]. + eta_wtd, & ! A weighted estimate used to calculate eta_out [H ~> m or kg m-2]. + eta_IC, & ! A local copy of the initial 2-D eta field (eta_in) [H ~> m or kg m-2] + eta_PF, & ! A local copy of the 2-D eta field (either SSH anomaly or + ! column mass anomaly) that was used to calculate the input + ! pressure gradient accelerations [H ~> m or kg m-2]. + eta_PF_1, & ! The initial value of eta_PF, when interp_eta_PF is + ! true [H ~> m or kg m-2]. + d_eta_PF, & ! The change in eta_PF over the barotropic time stepping when + ! interp_eta_PF is true [H ~> m or kg m-2]. + gtot_E, & ! gtot_X is the effective total reduced gravity used to relate + gtot_W, & ! free surface height deviations to pressure forces (including + gtot_N, & ! GFS and baroclinic contributions) in the barotropic momentum + gtot_S, & ! equations half a grid-point in the X-direction (X is N, S, E, or W) + ! from the thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + ! (See Hallberg, J Comp Phys 1997 for a discussion.) + eta_src, & ! The source of eta per barotropic timestep [H ~> m or kg m-2]. + SpV_col_avg, & ! The column average specific volume [R-1 ~> m3 kg-1] + dyn_coef_eta, & ! The coefficient relating the changes in eta to the + ! dynamic surface pressure under rigid ice + ! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + p_surf_dyn ! A dynamic surface pressure under rigid ice [L2 T-2 ~> m2 s-2]. + type(local_BT_cont_u_type), dimension(SZIBW_(CS),SZJW_(CS)) :: & + BTCL_u ! A repackaged version of the u-point information in BT_cont. + type(local_BT_cont_v_type), dimension(SZIW_(CS),SZJBW_(CS)) :: & + BTCL_v ! A repackaged version of the v-point information in BT_cont. + ! End of wide-sized variables. + + real, dimension(SZIBW_(CS),SZJW_(CS)) :: & + ubt_prev, ubt_sum_prev, ubt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] + uhbt_prev, uhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + ubt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] + uhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] + real, dimension(SZIW_(CS),SZJBW_(CS)) :: & + vbt_prev, vbt_sum_prev, vbt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] + vhbt_prev, vhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + vbt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] + vhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] + real :: visc_rem ! A work variable that may equal visc_rem_[uv] [nondim] + real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. + real :: dtbt ! The barotropic time step [T ~> s]. + real :: dtbt_diag ! The nominal barotropic time step used in hifreq diagnostics [T ~> s]. + ! dtbt_diag = dt/(nstep+nfilter) + real :: bebt ! A copy of CS%bebt [nondim]. + real :: be_proj ! The fractional amount by which velocities are projected + ! when project_velocity is true [nondim]. For now be_proj is set + ! to equal bebt, as they have similar roles and meanings. + real :: Idt ! The inverse of dt [T-1 ~> s-1]. + real :: det_de ! The partial derivative due to self-attraction and loading + ! of the reference geopotential with the sea surface height [nondim]. + ! This is typically ~0.09 or less. + real :: dgeo_de ! The constant of proportionality between geopotential and + ! sea surface height [nondim]. It is of order 1, but for + ! stability this may be made larger than the physical + ! problem would suggest. + real :: Instep ! The inverse of the number of barotropic time steps to take [nondim]. + real :: wt_end ! The weighting of the final value of eta_PF [nondim] + integer :: nstep ! The number of barotropic time steps to take. + type(time_type) :: & + time_bt_start, & ! The starting time of the barotropic steps. + time_step_end, & ! The end time of a barotropic step. + time_end_in ! The end time for diagnostics when this routine started. + real :: time_int_in ! The diagnostics' time interval when this routine started [s] + real :: Htot_avg ! The average total thickness of the tracer columns adjacent to a + ! velocity point [H ~> m or kg m-2] + logical :: do_hifreq_output ! If true, output occurs every barotropic step. + logical :: use_BT_cont, do_ave, find_etaav, find_PF, find_Cor + logical :: integral_BT_cont ! If true, update the barotropic continuity equation directly + ! from the initial condition using the time-integrated barotropic velocity. + logical :: ice_is_rigid, nonblock_setup, interp_eta_PF + logical :: project_velocity, add_uh0 + + real :: dyn_coef_max ! The maximum stable value of dyn_coef_eta + ! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + real :: ice_strength = 0.0 ! The effective strength of the ice [L2 Z-1 T-2 ~> m s-2]. + real :: H_to_Z ! A local unit conversion factor used with rigid ice [Z H-1 ~> nondim or m3 kg-1] + real :: Idt_max2 ! The squared inverse of the local maximum stable + ! barotropic time step [T-2 ~> s-2]. + real :: H_min_dyn ! The minimum depth to use in limiting the size of the + ! dynamic surface pressure for stability [H ~> m or kg m-2]. + real :: H_eff_dx2 ! The effective total thickness divided by the grid spacing + ! squared [H L-2 ~> m-1 or kg m-4]. + real :: u_max_cor, v_max_cor ! The maximum corrective velocities [L T-1 ~> m s-1]. + real :: uint_cor, vint_cor ! The maximum time-integrated corrective velocities [L ~> m]. + real :: Htot ! The total thickness [H ~> m or kg m-2]. + real :: eta_cor_max ! The maximum fluid that can be added as a correction to eta [H ~> m or kg m-2]. + real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] + + real, allocatable :: wt_vel(:) ! The raw or relative weights of each of the barotropic timesteps + ! in determining the average velocities [nondim] + real, allocatable :: wt_eta(:) ! The raw or relative weights of each of the barotropic timesteps + ! in determining the average eta [nondim] + real, allocatable :: wt_accel(:) ! The raw or relative weights of each of the barotropic timesteps + ! in determining the average accelerations [nondim] + real, allocatable :: wt_trans(:) ! The raw or relative weights of each of the barotropic timesteps + ! in determining the average transports [nondim] + real, allocatable :: wt_accel2(:) ! A potentially un-normalized copy of wt_accel [nondim] + real :: sum_wt_vel ! The sum of the raw weights used to find average velocities [nondim] + real :: sum_wt_eta ! The sum of the raw weights used to find average eta [nondim] + real :: sum_wt_accel ! The sum of the raw weights used to find average accelerations [nondim] + real :: sum_wt_trans ! The sum of the raw weights used to find average transports [nondim] + real :: I_sum_wt_vel ! The inverse of the sum of the raw weights used to find average velocities [nondim] + real :: I_sum_wt_eta ! The inverse of the sum of the raw weights used to find eta [nondim] + real :: I_sum_wt_accel ! The inverse of the sum of the raw weights used to find average accelerations [nondim] + real :: I_sum_wt_trans ! The inverse of the sum of the raw weights used to find average transports [nondim] + real :: dt_filt ! The half-width of the barotropic filter [T ~> s]. + real :: trans_wt1, trans_wt2 ! The weights used to compute ubt_trans and vbt_trans [nondim] + integer :: nfilter + + logical :: apply_OBCs, apply_OBC_flather, apply_OBC_open + type(memory_size_type) :: MS + character(len=200) :: mesg + integer :: isv, iev, jsv, jev ! The valid array size at the end of a step. + integer :: stencil ! The stencil size of the algorithm, often 1 or 2. + integer :: isvf, ievf, jsvf, jevf, num_cycles + integer :: err_count ! A counter to limit the volume of error messages written to stdout. + integer :: i, j, k, n + integer :: is, ie, js, je, nz, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer :: ioff, joff + integer :: l_seg + + if (.not.CS%module_is_initialized) call MOM_error(FATAL, & + "btstep: Module MOM_barotropic must be initialized before it is used.") + + if (.not.CS%split) return + 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 + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + MS%isdw = CS%isdw ; MS%iedw = CS%iedw ; MS%jsdw = CS%jsdw ; MS%jedw = CS%jedw + h_neglect = GV%H_subroundoff + err_count = 0 + + Idt = 1.0 / dt + accel_underflow = CS%vel_underflow * Idt + + use_BT_cont = associated(BT_cont) + integral_BT_cont = use_BT_cont .and. CS%integral_BT_cont + + interp_eta_PF = associated(eta_PF_start) + + project_velocity = CS%BT_project_velocity + + ! Figure out the fullest arrays that could be updated. + stencil = 1 + if ((.not.use_BT_cont) .and. CS%Nonlinear_continuity .and. & + (CS%Nonlin_cont_update_period > 0)) stencil = 2 + + do_ave = query_averaging_enabled(CS%diag) + find_etaav = present(etaav) + find_PF = (do_ave .and. ((CS%id_PFu_bt > 0) .or. (CS%id_PFv_bt > 0))) + find_Cor = (do_ave .and. ((CS%id_Coru_bt > 0) .or. (CS%id_Corv_bt > 0))) + + add_uh0 = associated(uh0) + if (add_uh0 .and. .not.(associated(vh0) .and. associated(u_uh0) .and. & + associated(v_vh0))) call MOM_error(FATAL, & + "btstep: vh0, u_uh0, and v_vh0 must be associated if uh0 is used.") + + ! This can be changed to try to optimize the performance. + nonblock_setup = G%nonblocking_updates + + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + + apply_OBCs = .false. ; CS%BT_OBC%apply_u_OBCs = .false. ; CS%BT_OBC%apply_v_OBCs = .false. + apply_OBC_open = .false. + apply_OBC_flather = .false. + if (associated(OBC)) then + CS%BT_OBC%apply_u_OBCs = OBC%open_u_BCs_exist_globally .or. OBC%specified_u_BCs_exist_globally + CS%BT_OBC%apply_v_OBCs = OBC%open_v_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally + apply_OBC_flather = open_boundary_query(OBC, apply_Flather_OBC=.true.) + apply_OBC_open = open_boundary_query(OBC, apply_open_OBC=.true.) + apply_OBCs = open_boundary_query(OBC, apply_specified_OBC=.true.) .or. & + apply_OBC_flather .or. apply_OBC_open + endif + + num_cycles = 1 + if (CS%use_wide_halos) & + num_cycles = min((is-CS%isdw) / stencil, (js-CS%jsdw) / stencil) + isvf = is - (num_cycles-1)*stencil ; ievf = ie + (num_cycles-1)*stencil + jsvf = js - (num_cycles-1)*stencil ; jevf = je + (num_cycles-1)*stencil + + nstep = CEILING(dt/CS%dtbt - 0.0001) + if (is_root_PE() .and. ((nstep /= CS%nstep_last) .or. CS%debug)) then + write(mesg,'("btstep is using a dynamic barotropic timestep of ", ES12.6, & + & " seconds, max ", ES12.6, ".")') (US%T_to_s*dt/nstep), US%T_to_s*CS%dtbt_max + call MOM_mesg(mesg, 3) + endif + CS%nstep_last = nstep + + ! Set the actual barotropic time step. + Instep = 1.0 / real(nstep) + dtbt = dt * Instep + Idtbt = 1.0 / dtbt + bebt = CS%bebt + be_proj = CS%bebt + + !--- setup the weight when computing vbt_trans and ubt_trans + if (project_velocity) then + trans_wt1 = (1.0 + be_proj); trans_wt2 = -be_proj + else + trans_wt1 = bebt ; trans_wt2 = (1.0-bebt) + endif + + do_hifreq_output = .false. + if ((CS%id_ubt_hifreq > 0) .or. (CS%id_vbt_hifreq > 0) .or. & + (CS%id_eta_hifreq > 0) .or. (CS%id_eta_pred_hifreq > 0) .or. & + (CS%id_uhbt_hifreq > 0) .or. (CS%id_vhbt_hifreq > 0)) then + do_hifreq_output = query_averaging_enabled(CS%diag, time_int_in, time_end_in) + if (do_hifreq_output) & + time_bt_start = time_end_in - real_to_time(US%T_to_s*dt) + endif + +!--- begin setup for group halo update + if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) + if (.not. CS%linearized_BT_PV) then + call create_group_pass(CS%pass_q_DCor, q, CS%BT_Domain, To_All, position=CORNER) + call create_group_pass(CS%pass_q_DCor, DCor_u, DCor_v, CS%BT_Domain, & + To_All+Scalar_Pair) + endif + if ((Isq > is-1) .or. (Jsq > js-1)) & + call create_group_pass(CS%pass_tmp_uv, tmp_u, tmp_v, G%Domain) + call create_group_pass(CS%pass_gtot, gtot_E, gtot_N, CS%BT_Domain, & + To_All+Scalar_Pair, AGRID) + call create_group_pass(CS%pass_gtot, gtot_W, gtot_S, CS%BT_Domain, & + To_All+Scalar_Pair, AGRID) + + if (CS%dynamic_psurf) & + call create_group_pass(CS%pass_eta_bt_rem, dyn_coef_eta, CS%BT_Domain) + if (interp_eta_PF) then + call create_group_pass(CS%pass_eta_bt_rem, eta_PF_1, CS%BT_Domain) + call create_group_pass(CS%pass_eta_bt_rem, d_eta_PF, CS%BT_Domain) + else + call create_group_pass(CS%pass_eta_bt_rem, eta_PF, CS%BT_Domain) + endif + if (integral_BT_cont) & + call create_group_pass(CS%pass_eta_bt_rem, eta_IC, CS%BT_Domain) + call create_group_pass(CS%pass_eta_bt_rem, eta_src, CS%BT_Domain) + ! The following halo updates are not needed without wide halos. RWH + ! We do need them after all. +! if (ievf > ie) then + call create_group_pass(CS%pass_eta_bt_rem, bt_rem_u, bt_rem_v, & + CS%BT_Domain, To_All+Scalar_Pair) + if (CS%linear_wave_drag) & + call create_group_pass(CS%pass_eta_bt_rem, Rayleigh_u, Rayleigh_v, & + CS%BT_Domain, To_All+Scalar_Pair) +! endif + ! The following halo update is not needed without wide halos. RWH + if (((G%isd > CS%isdw) .or. (G%jsd > CS%jsdw)) .or. (Isq <= is-1) .or. (Jsq <= js-1)) & + call create_group_pass(CS%pass_force_hbt0_Cor_ref, BT_force_u, BT_force_v, CS%BT_Domain) + if (add_uh0) call create_group_pass(CS%pass_force_hbt0_Cor_ref, uhbt0, vhbt0, CS%BT_Domain) + call create_group_pass(CS%pass_force_hbt0_Cor_ref, Cor_ref_u, Cor_ref_v, CS%BT_Domain) + if (.not. use_BT_cont) then + call create_group_pass(CS%pass_Dat_uv, Datu, Datv, CS%BT_Domain, To_All+Scalar_Pair) + endif + call create_group_pass(CS%pass_eta_ubt, eta, CS%BT_Domain) + call create_group_pass(CS%pass_eta_ubt, ubt, vbt, CS%BT_Domain) + if (integral_BT_cont) then + call create_group_pass(CS%pass_eta_ubt, ubt_int, vbt_int, CS%BT_Domain) + ! This is only needed with integral_BT_cont, OBCs and multiple barotropic steps between halo updates. + if (apply_OBC_open) & + call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) + endif + if (apply_OBC_flather .and. .not.GV%Boussinesq) & + call create_group_pass(CS%pass_SpV_avg, SpV_col_avg, CS%BT_domain) + + call create_group_pass(CS%pass_ubt_Cor, ubt_Cor, vbt_Cor, G%Domain) + ! These passes occur at the end of the routine, as data is being readied to + ! share with the main part of the MOM6 code. + if (find_etaav) then + call create_group_pass(CS%pass_etaav, etaav, G%Domain) + endif + call create_group_pass(CS%pass_e_anom, e_anom, G%Domain) + call create_group_pass(CS%pass_ubta_uhbta, CS%ubtav, CS%vbtav, G%Domain) + call create_group_pass(CS%pass_ubta_uhbta, uhbtav, vhbtav, G%Domain) + + if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) +!--- end setup for group halo update + +! Calculate the constant coefficients for the Coriolis force terms in the +! barotropic momentum equations. This has to be done quite early to start +! the halo update that needs to be completed before the next calculations. + if (CS%linearized_BT_PV) then + !$OMP parallel do default(shared) + do J=jsvf-2,jevf+1 ; do I=isvf-2,ievf+1 + q(I,J) = CS%q_D(I,j) + enddo ; enddo + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 + DCor_u(I,j) = CS%D_u_Cor(I,j) + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 + DCor_v(i,J) = CS%D_v_Cor(i,J) + enddo ; enddo + else + q(:,:) = 0.0 ; DCor_u(:,:) = 0.0 ; DCor_v(:,:) = 0.0 + if (GV%Boussinesq) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + DCor_u(I,j) = 0.5 * (max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + & + max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) ) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + DCor_v(i,J) = 0.5 * (max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i+1,j), 0.0) + & + max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) ) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do I=is-1,ie + q(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & + ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & + (max((G%areaT(i,j) * max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) + & + G%areaT(i+1,j+1) * max(GV%Z_to_H*G%bathyT(i+1,j+1) + eta_in(i+1,j+1), 0.0)) + & + (G%areaT(i+1,j) * max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + & + G%areaT(i,j+1) * max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0)), h_neglect) ) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + DCor_u(I,j) = 0.5 * (eta_in(i+1,j) + eta_in(i,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + DCor_v(i,J) = 0.5 * (eta_in(i,j+1) + eta_in(i,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do I=is-1,ie + q(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & + ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & + (max((G%areaT(i,j) * eta_in(i,j) + G%areaT(i+1,j+1) * eta_in(i+1,j+1)) + & + (G%areaT(i+1,j) * eta_in(i+1,j) + G%areaT(i,j+1) * eta_in(i,j+1)), h_neglect) ) + enddo ; enddo + endif + + ! With very wide halos, q and D need to be calculated on the available data + ! domain and then updated onto the full computational domain. + ! These calculations can be done almost immediately, but the halo updates + ! must be done before the [abcd]mer and [abcd]zon are calculated. + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + if (nonblock_setup) then + call start_group_pass(CS%pass_q_DCor, CS%BT_Domain, clock=id_clock_pass_pre) + else + call do_group_pass(CS%pass_q_DCor, CS%BT_Domain, clock=id_clock_pass_pre) + endif + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + endif + + ! Zero out various wide-halo arrays. + !$OMP parallel do default(shared) + do j=CS%jsdw,CS%jedw ; do i=CS%isdw,CS%iedw + gtot_E(i,j) = 0.0 ; gtot_W(i,j) = 0.0 + gtot_N(i,j) = 0.0 ; gtot_S(i,j) = 0.0 + eta(i,j) = 0.0 + eta_PF(i,j) = 0.0 + if (interp_eta_PF) then + eta_PF_1(i,j) = 0.0 ; d_eta_PF(i,j) = 0.0 + endif + if (integral_BT_cont) then + eta_IC(i,j) = 0.0 + endif + p_surf_dyn(i,j) = 0.0 + if (CS%dynamic_psurf) dyn_coef_eta(i,j) = 0.0 + enddo ; enddo + ! The halo regions of various arrays need to be initialized to + ! non-NaNs in case the neighboring domains are not part of the ocean. + ! Otherwise a halo update later on fills in the correct values. + !$OMP parallel do default(shared) + do j=CS%jsdw,CS%jedw ; do I=CS%isdw-1,CS%iedw + Cor_ref_u(I,j) = 0.0 ; BT_force_u(I,j) = 0.0 ; ubt(I,j) = 0.0 + Datu(I,j) = 0.0 ; bt_rem_u(I,j) = 0.0 ; uhbt0(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=CS%jsdw-1,CS%jedw ; do i=CS%isdw,CS%iedw + Cor_ref_v(i,J) = 0.0 ; BT_force_v(i,J) = 0.0 ; vbt(i,J) = 0.0 + Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(i,J) = 0.0 + enddo ; enddo + + if (apply_OBCs) then + SpV_col_avg(:,:) = 0.0 + if (apply_OBC_flather .and. .not.GV%Boussinesq) then + ! Copy the column average specific volumes into a wide halo array + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + SpV_col_avg(i,j) = Spv_avg(i,j) + enddo ; enddo + if (nonblock_setup) then + call start_group_pass(CS%pass_SpV_avg, CS%BT_domain) + else + call do_group_pass(CS%pass_SpV_avg, CS%BT_domain) + endif + endif + endif + + if (CS%linear_wave_drag) then + !$OMP parallel do default(shared) + do j=CS%jsdw,CS%jedw ; do I=CS%isdw-1,CS%iedw + Rayleigh_u(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=CS%jsdw-1,CS%jedw ; do i=CS%isdw,CS%iedw + Rayleigh_v(i,J) = 0.0 + enddo ; enddo + endif + + ! Copy input arrays into their wide-halo counterparts. + if (interp_eta_PF) then + !$OMP parallel do default(shared) + do j=G%jsd,G%jed ; do i=G%isd,G%ied ! Was "do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1" but doing so breaks OBC. Not sure why? + eta(i,j) = eta_in(i,j) + eta_PF_1(i,j) = eta_PF_start(i,j) + d_eta_PF(i,j) = eta_PF_in(i,j) - eta_PF_start(i,j) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=G%jsd,G%jed ; do i=G%isd,G%ied !: Was "do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1" but doing so breaks OBC. Not sure why? + eta(i,j) = eta_in(i,j) + eta_PF(i,j) = eta_PF_in(i,j) + enddo ; enddo + endif + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=G%jsd,G%jed ; do i=G%isd,G%ied + eta_IC(i,j) = eta_in(i,j) + enddo ; enddo + endif + + !$OMP parallel do default(shared) private(visc_rem) + do k=1,nz ; do j=js,je ; do I=is-1,ie + ! rem needs to be greater than visc_rem_u and 1-Instep/visc_rem_u. + ! The 0.5 below is just for safety. + ! NOTE: subroundoff is a neglible value used to prevent division by zero. + ! When 1-0.5*Instep/visc_rem exceeds visc_rem, the subroundoff is too small + ! to modify the significand. When visc_rem is small, the max() operators + ! select visc_rem or 0. So subroundoff cannot impact the final value. + visc_rem = min(visc_rem_u(I,j,k), 1.) + visc_rem = max(visc_rem, 1. - 0.5 * Instep / (visc_rem + subroundoff)) + visc_rem = max(visc_rem, 0.) + wt_u(I,j,k) = CS%frhatu(I,j,k) * visc_rem + enddo ; enddo ; enddo + !$OMP parallel do default(shared) private(visc_rem) + do k=1,nz ; do J=js-1,je ; do i=is,ie + ! As above, rem must be greater than visc_rem_v and 1-Instep/visc_rem_v. + visc_rem = min(visc_rem_v(I,j,k), 1.) + visc_rem = max(visc_rem, 1. - 0.5 * Instep / (visc_rem + subroundoff)) + visc_rem = max(visc_rem, 0.) + wt_v(i,J,k) = CS%frhatv(i,J,k) * visc_rem + enddo ; enddo ; enddo + + ! Use u_Cor and v_Cor as the reference values for the Coriolis terms, + ! including the viscous remnant. + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do I=is-1,ie ; ubt_Cor(I,j) = 0.0 ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is-1,ie+1 ; vbt_Cor(i,J) = 0.0 ; enddo ; enddo + !$OMP parallel do default(shared) + do j=js,je ; do k=1,nz ; do I=is-1,ie + ubt_Cor(I,j) = ubt_Cor(I,j) + wt_u(I,j,k) * U_Cor(I,j,k) + enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do k=1,nz ; do i=is,ie + vbt_Cor(i,J) = vbt_Cor(i,J) + wt_v(i,J,k) * V_Cor(i,J,k) + enddo ; enddo ; enddo + + ! The gtot arrays are the effective layer-weighted reduced gravities for + ! accelerations across the various faces, with names for the relative + ! locations of the faces to the pressure point. They will have their halos + ! updated later on. + !$OMP parallel do default(shared) + do j=js,je + do k=1,nz ; do I=is-1,ie + gtot_E(i,j) = gtot_E(i,j) + pbce(i,j,k) * wt_u(I,j,k) + gtot_W(i+1,j) = gtot_W(i+1,j) + pbce(i+1,j,k) * wt_u(I,j,k) + enddo ; enddo + enddo + !$OMP parallel do default(shared) + do J=js-1,je + do k=1,nz ; do i=is,ie + gtot_N(i,j) = gtot_N(i,j) + pbce(i,j,k) * wt_v(i,J,k) + gtot_S(i,j+1) = gtot_S(i,j+1) + pbce(i,j+1,k) * wt_v(i,J,k) + enddo ; enddo + enddo + + if (apply_OBCs) then + do n=1,OBC%number_of_segments + if (.not. OBC%segment(n)%on_pe) cycle + I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB + if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then + do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied) + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + gtot_S(i,j+1) = gtot_S(i,j) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + gtot_N(i,j) = gtot_N(i,j+1) + endif + enddo + elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then + do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed) + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + gtot_W(i+1,j) = gtot_W(i,j) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + gtot_E(i,j) = gtot_E(i+1,j) + endif + enddo + endif + enddo + endif + + if (CS%calculate_SAL) then + call scalar_SAL_sensitivity(CS%SAL_CSp, det_de) + if (CS%tidal_sal_bug) then + dgeo_de = 1.0 + det_de + CS%G_extra + else + dgeo_de = (1.0 - det_de) + CS%G_extra + endif + else + dgeo_de = 1.0 + CS%G_extra + endif + + if (nonblock_setup .and. .not.CS%linearized_BT_PV) then + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + call complete_group_pass(CS%pass_q_DCor, CS%BT_Domain, clock=id_clock_pass_pre) + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + endif + + ! Calculate the open areas at the velocity points. + ! The halo updates are needed before Datu is first used, either in set_up_BT_OBC or ubt_Cor. + if (integral_BT_cont) then + call set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, CS%BT_Domain, 1+ievf-ie, dt_baroclinic=dt) + elseif (use_BT_cont) then + call set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, CS%BT_Domain, 1+ievf-ie) + else + if (CS%Nonlinear_continuity) then + call find_face_areas(Datu, Datv, G, GV, US, CS, MS, 1, eta) + else + call find_face_areas(Datu, Datv, G, GV, US, CS, MS, 1) + endif + endif + + ! Set up fields related to the open boundary conditions. + if (apply_OBCs) then + if (nonblock_setup .and. apply_OBC_flather .and. .not.GV%Boussinesq) & + call complete_group_pass(CS%pass_SpV_avg, CS%BT_domain) + + if (CS%TIDAL_SAL_FLATHER) then + call set_up_BT_OBC(OBC, eta, SpV_col_avg, CS%BT_OBC, CS%BT_Domain, G, GV, US, CS, MS, ievf-ie, & + use_BT_cont, integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) + else + call set_up_BT_OBC(OBC, eta, SpV_col_avg, CS%BT_OBC, CS%BT_Domain, G, GV, US, CS, MS, ievf-ie, & + use_BT_cont, integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) + endif + endif + + ! Determine the difference between the sum of the layer fluxes and the + ! barotropic fluxes found from the same input velocities. + if (add_uh0) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie ; uhbt(I,j) = 0.0 ; ubt(I,j) = 0.0 ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie ; vhbt(i,J) = 0.0 ; vbt(i,J) = 0.0 ; enddo ; enddo + if (CS%visc_rem_u_uh0) then + !$OMP parallel do default(shared) + do j=js,je ; do k=1,nz ; do I=is-1,ie + uhbt(I,j) = uhbt(I,j) + uh0(I,j,k) + ubt(I,j) = ubt(I,j) + wt_u(I,j,k) * u_uh0(I,j,k) + enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do k=1,nz ; do i=is,ie + vhbt(i,J) = vhbt(i,J) + vh0(i,J,k) + vbt(i,J) = vbt(i,J) + wt_v(i,J,k) * v_vh0(i,J,k) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do k=1,nz ; do I=is-1,ie + uhbt(I,j) = uhbt(I,j) + uh0(I,j,k) + ubt(I,j) = ubt(I,j) + CS%frhatu(I,j,k) * u_uh0(I,j,k) + enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do k=1,nz ; do i=is,ie + vhbt(i,J) = vhbt(i,J) + vh0(i,J,k) + vbt(i,J) = vbt(i,J) + CS%frhatv(i,J,k) * v_vh0(i,J,k) + enddo ; enddo ; enddo + endif + if ((use_BT_cont .or. integral_BT_cont) .and. CS%adjust_BT_cont) then + ! Use the additional input transports to broaden the fits + ! over which the bt_cont_type applies. + + ! Fill in the halo data for ubt, vbt, uhbt, and vhbt. + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) + call pass_vector(ubt, vbt, CS%BT_Domain, complete=.false., halo=1+ievf-ie) + call pass_vector(uhbt, vhbt, CS%BT_Domain, complete=.true., halo=1+ievf-ie) + if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + + if (integral_BT_cont) then + call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & + G, US, MS, 1+ievf-ie, dt_baroclinic=dt) + else + call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & + G, US, MS, 1+ievf-ie) + endif + endif + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + uhbt0(I,j) = uhbt(I,j) - find_uhbt(dt*ubt(I,j), BTCL_u(I,j)) * Idt + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + vhbt0(i,J) = vhbt(i,J) - find_vhbt(dt*vbt(i,J), BTCL_v(i,J)) * Idt + enddo ; enddo + elseif (use_BT_cont) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + uhbt0(I,j) = uhbt(I,j) - find_uhbt(ubt(I,j), BTCL_u(I,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + vhbt0(i,J) = vhbt(i,J) - find_vhbt(vbt(i,J), BTCL_v(i,J)) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + uhbt0(I,j) = uhbt(I,j) - Datu(I,j)*ubt(I,j) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + vhbt0(i,J) = vhbt(i,J) - Datv(i,J)*vbt(i,J) + enddo ; enddo + endif + if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + uhbt0(I,j) = 0.0 + endif ; enddo ; enddo + endif + if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + vhbt0(i,J) = 0.0 + endif ; enddo ; enddo + endif + endif + +! Calculate the initial barotropic velocities from the layer's velocities. + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 + ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 + ubt_int(I,j) = 0.0 ; uhbt_int(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 + vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 + vbt_int(i,J) = 0.0 ; vhbt_int(i,J) = 0.0 + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 + ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 + vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 + enddo ; enddo + endif + !$OMP parallel do default(shared) + do j=js,je ; do k=1,nz ; do I=is-1,ie + ubt(I,j) = ubt(I,j) + wt_u(I,j,k) * U_in(I,j,k) + enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do k=1,nz ; do i=is,ie + vbt(i,J) = vbt(i,J) + wt_v(i,J,k) * V_in(i,J,k) + enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 + enddo ; enddo + + if (apply_OBCs) then + ubt_first(:,:) = ubt(:,:) ; vbt_first(:,:) = vbt(:,:) + endif + +! Here the vertical average accelerations due to the Coriolis, advective, +! pressure gradient and horizontal viscous terms in the layer momentum +! equations are calculated. These will be used to determine the difference +! between the accelerations due to the average of the layer equations and the +! barotropic calculation. + + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then + if (CS%nonlin_stress) then + if (GV%Boussinesq) then + Htot_avg = 0.5*(max(CS%bathyT(i,j)*GV%Z_to_H + eta(i,j), 0.0) + & + max(CS%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j), 0.0)) + else + Htot_avg = 0.5*(eta(i,j) + eta(i+1,j)) + endif + if (Htot_avg*CS%dy_Cu(I,j) <= 0.0) then + CS%IDatu(I,j) = 0.0 + elseif (integral_BT_cont) then + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & + CS%dy_Cu(I,j)*Htot_avg) ) + elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & + CS%dy_Cu(I,j)*Htot_avg) ) + else + CS%IDatu(I,j) = 1.0 / Htot_avg + endif + endif + + BT_force_u(I,j) = forces%taux(I,j) * GV%RZ_to_H * CS%IDatu(I,j)*visc_rem_u(I,j,1) + else + BT_force_u(I,j) = 0.0 + endif ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then + if (CS%nonlin_stress) then + if (GV%Boussinesq) then + Htot_avg = 0.5*(max(CS%bathyT(i,j)*GV%Z_to_H + eta(i,j), 0.0) + & + max(CS%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1), 0.0)) + else + Htot_avg = 0.5*(eta(i,j) + eta(i,j+1)) + endif + if (Htot_avg*CS%dx_Cv(i,J) <= 0.0) then + CS%IDatv(i,J) = 0.0 + elseif (integral_BT_cont) then + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & + CS%dx_Cv(i,J)*Htot_avg) ) + elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & + CS%dx_Cv(i,J)*Htot_avg) ) + else + CS%IDatv(i,J) = 1.0 / Htot_avg + endif + endif + + BT_force_v(i,J) = forces%tauy(i,J) * GV%RZ_to_H * CS%IDatv(i,J)*visc_rem_v(i,J,1) + else + BT_force_v(i,J) = 0.0 + endif ; enddo ; enddo + if (associated(taux_bot) .and. associated(tauy_bot)) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then + BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * GV%RZ_to_H * CS%IDatu(I,j) + endif ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then + BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * GV%RZ_to_H * CS%IDatv(i,J) + endif ; enddo ; enddo + endif + + ! bc_accel_u & bc_accel_v are only available on the potentially + ! non-symmetric computational domain. + !$OMP parallel do default(shared) + do j=js,je ; do k=1,nz ; do I=Isq,Ieq + BT_force_u(I,j) = BT_force_u(I,j) + wt_u(I,j,k) * bc_accel_u(I,j,k) + enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do k=1,nz ; do i=is,ie + BT_force_v(i,J) = BT_force_v(i,J) + wt_v(i,J,k) * bc_accel_v(i,J,k) + enddo ; enddo ; enddo + + if (CS%gradual_BT_ICs) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + BT_force_u(I,j) = BT_force_u(I,j) + (ubt(I,j) - CS%ubt_IC(I,j)) * Idt + ubt(I,j) = CS%ubt_IC(I,j) + if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + BT_force_v(i,J) = BT_force_v(i,J) + (vbt(i,J) - CS%vbt_IC(i,J)) * Idt + vbt(i,J) = CS%vbt_IC(i,J) + if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 + enddo ; enddo + endif + + if ((Isq > is-1) .or. (Jsq > js-1)) then + ! Non-symmetric memory is being used, so the edge values need to be + ! filled in with a halo update of a non-symmetric array. + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) + tmp_u(:,:) = 0.0 ; tmp_v(:,:) = 0.0 + do j=js,je ; do I=Isq,Ieq ; tmp_u(I,j) = BT_force_u(I,j) ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; tmp_v(i,J) = BT_force_v(i,J) ; enddo ; enddo + if (nonblock_setup) then + call start_group_pass(CS%pass_tmp_uv, G%Domain) + else + call do_group_pass(CS%pass_tmp_uv, G%Domain) + do j=jsd,jed ; do I=IsdB,IedB ; BT_force_u(I,j) = tmp_u(I,j) ; enddo ; enddo + do J=JsdB,JedB ; do i=isd,ied ; BT_force_v(i,J) = tmp_v(i,J) ; enddo ; enddo + endif + if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + endif + + if (nonblock_setup) then + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) + call start_group_pass(CS%pass_gtot, CS%BT_Domain) + call start_group_pass(CS%pass_ubt_Cor, G%Domain) + if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + endif + + ! Determine the weighted Coriolis parameters for the neighboring velocities. + !$OMP parallel do default(shared) + do J=jsvf-1,jevf ; do i=isvf-1,ievf+1 + if (CS%Sadourny) then + amer(I-1,j) = DCor_u(I-1,j) * q(I-1,J) + bmer(I,j) = DCor_u(I,j) * q(I,J) + cmer(I,j+1) = DCor_u(I,j+1) * q(I,J) + dmer(I-1,j+1) = DCor_u(I-1,j+1) * q(I-1,J) + else + amer(I-1,j) = DCor_u(I-1,j) * & + ((q(I,J) + q(I-1,J-1)) + q(I-1,J)) / 3.0 + bmer(I,j) = DCor_u(I,j) * & + (q(I,J) + (q(I-1,J) + q(I,J-1))) / 3.0 + cmer(I,j+1) = DCor_u(I,j+1) * & + (q(I,J) + (q(I-1,J) + q(I,J+1))) / 3.0 + dmer(I-1,j+1) = DCor_u(I-1,j+1) * & + ((q(I,J) + q(I-1,J+1)) + q(I-1,J)) / 3.0 + endif + enddo ; enddo + + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf + if (CS%Sadourny) then + azon(I,j) = DCor_v(i+1,J) * q(I,J) + bzon(I,j) = DCor_v(i,J) * q(I,J) + czon(I,j) = DCor_v(i,J-1) * q(I,J-1) + dzon(I,j) = DCor_v(i+1,J-1) * q(I,J-1) + else + azon(I,j) = DCor_v(i+1,J) * & + (q(I,J) + (q(I+1,J) + q(I,J-1))) / 3.0 + bzon(I,j) = DCor_v(i,J) * & + (q(I,J) + (q(I-1,J) + q(I,J-1))) / 3.0 + czon(I,j) = DCor_v(i,J-1) * & + ((q(I,J) + q(I-1,J-1)) + q(I,J-1)) / 3.0 + dzon(I,j) = DCor_v(i+1,J-1) * & + ((q(I,J) + q(I+1,J-1)) + q(I,J-1)) / 3.0 + endif + enddo ; enddo + +! Complete the previously initiated message passing. + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) + if (nonblock_setup) then + if ((Isq > is-1) .or. (Jsq > js-1)) then + call complete_group_pass(CS%pass_tmp_uv, G%Domain) + do j=jsd,jed ; do I=IsdB,IedB ; BT_force_u(I,j) = tmp_u(I,j) ; enddo ; enddo + do J=JsdB,JedB ; do i=isd,ied ; BT_force_v(i,J) = tmp_v(i,J) ; enddo ; enddo + endif + call complete_group_pass(CS%pass_gtot, CS%BT_Domain) + call complete_group_pass(CS%pass_ubt_Cor, G%Domain) + else + call do_group_pass(CS%pass_gtot, CS%BT_Domain) + call do_group_pass(CS%pass_ubt_Cor, G%Domain) + endif + ! The various elements of gtot are positive definite but directional, so use + ! the polarity arrays to sort out when the directions have shifted. + do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 + if (CS%ua_polarity(i,j) < 0.0) call swap(gtot_E(i,j), gtot_W(i,j)) + if (CS%va_polarity(i,j) < 0.0) call swap(gtot_N(i,j), gtot_S(i,j)) + enddo ; enddo + + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + Cor_ref_u(I,j) = & + ((azon(I,j) * vbt_Cor(i+1,j) + czon(I,j) * vbt_Cor(i ,j-1)) + & + (bzon(I,j) * vbt_Cor(i ,j) + dzon(I,j) * vbt_Cor(i+1,j-1))) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + Cor_ref_v(i,J) = -1.0 * & + ((amer(I-1,j) * ubt_Cor(I-1,j) + cmer(I ,j+1) * ubt_Cor(I ,j+1)) + & + (bmer(I ,j) * ubt_Cor(I ,j) + dmer(I-1,j+1) * ubt_Cor(I-1,j+1))) + enddo ; enddo + + ! Now start new halo updates. + if (nonblock_setup) then + if (.not.use_BT_cont) & + call start_group_pass(CS%pass_Dat_uv, CS%BT_Domain) + + ! The following halo update is not needed without wide halos. RWH + call start_group_pass(CS%pass_force_hbt0_Cor_ref, CS%BT_Domain) + endif + if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + !$OMP parallel default(shared) private(u_max_cor,uint_cor,v_max_cor,vint_cor,eta_cor_max,Htot) + !$OMP do + do j=js-1,je+1 ; do I=is-1,ie ; av_rem_u(I,j) = 0.0 ; enddo ; enddo + !$OMP do + do J=js-1,je ; do i=is-1,ie+1 ; av_rem_v(i,J) = 0.0 ; enddo ; enddo + !$OMP do + do j=js,je ; do k=1,nz ; do I=is-1,ie + av_rem_u(I,j) = av_rem_u(I,j) + CS%frhatu(I,j,k) * visc_rem_u(I,j,k) + enddo ; enddo ; enddo + !$OMP do + do J=js-1,je ; do k=1,nz ; do i=is,ie + av_rem_v(i,J) = av_rem_v(i,J) + CS%frhatv(i,J,k) * visc_rem_v(i,J,k) + enddo ; enddo ; enddo + if (CS%strong_drag) then + !$OMP do + do j=js,je ; do I=is-1,ie + bt_rem_u(I,j) = G%mask2dCu(I,j) * & + ((nstep * av_rem_u(I,j)) / (1.0 + (nstep-1)*av_rem_u(I,j))) + enddo ; enddo + !$OMP do + do J=js-1,je ; do i=is,ie + bt_rem_v(i,J) = G%mask2dCv(i,J) * & + ((nstep * av_rem_v(i,J)) / (1.0 + (nstep-1)*av_rem_v(i,J))) + enddo ; enddo + else + !$OMP do + do j=js,je ; do I=is-1,ie + bt_rem_u(I,j) = 0.0 + if (G%mask2dCu(I,j) * av_rem_u(I,j) > 0.0) & + bt_rem_u(I,j) = G%mask2dCu(I,j) * (av_rem_u(I,j)**Instep) + enddo ; enddo + !$OMP do + do J=js-1,je ; do i=is,ie + bt_rem_v(i,J) = 0.0 + if (G%mask2dCv(i,J) * av_rem_v(i,J) > 0.0) & + bt_rem_v(i,J) = G%mask2dCv(i,J) * (av_rem_v(i,J)**Instep) + enddo ; enddo + endif + if (CS%linear_wave_drag) then + !$OMP do + do j=js,je ; do I=is-1,ie ; if (CS%lin_drag_u(I,j) > 0.0) then + Htot = 0.5 * (eta(i,j) + eta(i+1,j)) + if (GV%Boussinesq) & + Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i+1,j)) + bt_rem_u(I,j) = bt_rem_u(I,j) * (Htot / (Htot + CS%lin_drag_u(I,j) * dtbt)) + + Rayleigh_u(I,j) = CS%lin_drag_u(I,j) / Htot + endif ; enddo ; enddo + !$OMP do + do J=js-1,je ; do i=is,ie ; if (CS%lin_drag_v(i,J) > 0.0) then + Htot = 0.5 * (eta(i,j) + eta(i,j+1)) + if (GV%Boussinesq) & + Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i,j+1)) + bt_rem_v(i,J) = bt_rem_v(i,J) * (Htot / (Htot + CS%lin_drag_v(i,J) * dtbt)) + + Rayleigh_v(i,J) = CS%lin_drag_v(i,J) / Htot + endif ; enddo ; enddo + endif + + ! Zero out the arrays for various time-averaged quantities. + if (find_etaav) then + !$OMP do + do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 + eta_sum(i,j) = 0.0 ; eta_wtd(i,j) = 0.0 + enddo ; enddo + else + !$OMP do + do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 + eta_wtd(i,j) = 0.0 + enddo ; enddo + endif + !$OMP do + do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf + ubt_sum(I,j) = 0.0 ; uhbt_sum(I,j) = 0.0 + PFu_bt_sum(I,j) = 0.0 ; Coru_bt_sum(I,j) = 0.0 + ubt_wtd(I,j) = 0.0 ; ubt_trans(I,j) = 0.0 + enddo ; enddo + !$OMP do + do J=jsvf-1,jevf ; do i=isvf-1,ievf+1 + vbt_sum(i,J) = 0.0 ; vhbt_sum(i,J) = 0.0 + PFv_bt_sum(i,J) = 0.0 ; Corv_bt_sum(i,J) = 0.0 + vbt_wtd(i,J) = 0.0 ; vbt_trans(i,J) = 0.0 + enddo ; enddo + + ! Set the mass source, after first initializing the halos to 0. + !$OMP do + do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 ; eta_src(i,j) = 0.0 ; enddo ; enddo + if (CS%bound_BT_corr) then ; if ((use_BT_Cont.or.integral_BT_cont) .and. CS%BT_cont_bounds) then + do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + if (CS%eta_cor(i,j) > 0.0) then + ! Limit the source (outward) correction to be a fraction the mass that + ! can be transported out of the cell by velocities with a CFL number of CFL_cor. + if (integral_BT_cont) then + uint_cor = G%dxT(i,j) * CS%maxCFL_BT_cont + vint_cor = G%dyT(i,j) * CS%maxCFL_BT_cont + eta_cor_max = (CS%IareaT(i,j) * & + (((find_uhbt(uint_cor, BTCL_u(I,j)) + dt*uhbt0(I,j)) - & + (find_uhbt(-uint_cor, BTCL_u(I-1,j)) + dt*uhbt0(I-1,j))) + & + ((find_vhbt(vint_cor, BTCL_v(i,J)) + dt*vhbt0(i,J)) - & + (find_vhbt(-vint_cor, BTCL_v(i,J-1)) + dt*vhbt0(i,J-1))) )) + else ! (use_BT_Cont) then + u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) + v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) + eta_cor_max = dt * (CS%IareaT(i,j) * & + (((find_uhbt(u_max_cor, BTCL_u(I,j)) + uhbt0(I,j)) - & + (find_uhbt(-u_max_cor, BTCL_u(I-1,j)) + uhbt0(I-1,j))) + & + ((find_vhbt(v_max_cor, BTCL_v(i,J)) + vhbt0(i,J)) - & + (find_vhbt(-v_max_cor, BTCL_v(i,J-1)) + vhbt0(i,J-1))) )) + endif + CS%eta_cor(i,j) = min(CS%eta_cor(i,j), max(0.0, eta_cor_max)) + else + ! Limit the sink (inward) correction to the amount of mass that is already inside the cell. + Htot = eta(i,j) + if (GV%Boussinesq) Htot = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) + + CS%eta_cor(i,j) = max(CS%eta_cor(i,j), -max(0.0,Htot)) + endif + endif ; enddo ; enddo + else ; do j=js,je ; do i=is,ie + if (abs(CS%eta_cor(i,j)) > dt*CS%eta_cor_bound(i,j)) & + CS%eta_cor(i,j) = sign(dt*CS%eta_cor_bound(i,j), CS%eta_cor(i,j)) + enddo ; enddo ; endif ; endif + !$OMP do + do j=js,je ; do i=is,ie + eta_src(i,j) = G%mask2dT(i,j) * (Instep * CS%eta_cor(i,j)) + enddo ; enddo +!$OMP end parallel + + if (CS%dynamic_psurf) then + ice_is_rigid = (associated(forces%rigidity_ice_u) .and. & + associated(forces%rigidity_ice_v)) + H_min_dyn = CS%Dmin_dyn_psurf + if (ice_is_rigid .and. use_BT_cont) & + call BT_cont_to_face_areas(BT_cont, Datu, Datv, G, US, MS, halo=0) + if (ice_is_rigid) then + if (GV%Boussinesq) then + H_to_Z = GV%H_to_Z + else + H_to_Z = GV%H_to_RZ / CS%Rho_BT_lin + endif + !$OMP parallel do default(shared) private(Idt_max2,H_eff_dx2,dyn_coef_max,ice_strength) + do j=js,je ; do i=is,ie + ! First determine the maximum stable value for dyn_coef_eta. + + ! This estimate of the maximum stable time step is pretty accurate for + ! gravity waves, but it is a conservative estimate since it ignores the + ! stabilizing effect of the bottom drag. + Idt_max2 = 0.5 * (dgeo_de * (1.0 + 2.0*bebt)) * (G%IareaT(i,j) * & + ((gtot_E(i,j) * (Datu(I,j)*G%IdxCu(I,j)) + & + gtot_W(i,j) * (Datu(I-1,j)*G%IdxCu(I-1,j))) + & + (gtot_N(i,j) * (Datv(i,J)*G%IdyCv(i,J)) + & + gtot_S(i,j) * (Datv(i,J-1)*G%IdyCv(i,J-1)))) + & + ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) * CS%BT_Coriolis_scale**2 ) + H_eff_dx2 = max(H_min_dyn * ((G%IdxT(i,j))**2 + (G%IdyT(i,j))**2), & + G%IareaT(i,j) * & + ((Datu(I,j)*G%IdxCu(I,j) + Datu(I-1,j)*G%IdxCu(I-1,j)) + & + (Datv(i,J)*G%IdyCv(i,J) + Datv(i,J-1)*G%IdyCv(i,J-1)) ) ) + dyn_coef_max = CS%const_dyn_psurf * max(0.0, 1.0 - dtbt**2 * Idt_max2) / & + (dtbt**2 * H_eff_dx2) + + ! ice_strength has units of [L2 Z-1 T-2 ~> m s-2]. rigidity_ice_[uv] has units of [L4 Z-1 T-1 ~> m3 s-1]. + ice_strength = ((forces%rigidity_ice_u(I,j) + forces%rigidity_ice_u(I-1,j)) + & + (forces%rigidity_ice_v(i,J) + forces%rigidity_ice_v(i,J-1))) / & + (CS%ice_strength_length**2 * dtbt) + + ! Units of dyn_coef: [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1] + dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * H_to_Z) + enddo ; enddo ; endif + endif + + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) + if (nonblock_setup) then + call start_group_pass(CS%pass_eta_bt_rem, CS%BT_Domain) + ! The following halo update is not needed without wide halos. RWH + else + call do_group_pass(CS%pass_eta_bt_rem, CS%BT_Domain) + if (.not.use_BT_cont) & + call do_group_pass(CS%pass_Dat_uv, CS%BT_Domain) + call do_group_pass(CS%pass_force_hbt0_Cor_ref, CS%BT_Domain) + endif + if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + + ! Complete all of the outstanding halo updates. + if (nonblock_setup) then + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) + + if (.not.use_BT_cont) call complete_group_pass(CS%pass_Dat_uv, CS%BT_Domain) + call complete_group_pass(CS%pass_force_hbt0_Cor_ref, CS%BT_Domain) + call complete_group_pass(CS%pass_eta_bt_rem, CS%BT_Domain) + + if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + endif + + if (CS%debug) then + call uvchksum("BT [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=0, & + scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + call uvchksum("BT Initial [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=0, scale=US%L_T_to_m_s) + call hchksum(eta, "BT Initial eta", CS%debug_BT_HI, haloshift=0, scale=GV%H_to_MKS) + call uvchksum("BT BT_force_[uv]", BT_force_u, BT_force_v, & + CS%debug_BT_HI, haloshift=0, scale=US%L_T2_to_m_s2) + if (interp_eta_PF) then + call hchksum(eta_PF_1, "BT eta_PF_1",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_MKS) + call hchksum(d_eta_PF, "BT d_eta_PF",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_MKS) + else + call hchksum(eta_PF, "BT eta_PF",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_MKS) + call hchksum(eta_PF_in, "BT eta_PF_in",G%HI,haloshift=0, scale=GV%H_to_MKS) + endif + call uvchksum("BT Cor_ref_[uv]", Cor_ref_u, Cor_ref_v, CS%debug_BT_HI, haloshift=0, scale=US%L_T2_to_m_s2) + call uvchksum("BT [uv]hbt0", uhbt0, vhbt0, CS%debug_BT_HI, haloshift=0, & + scale=US%L_to_m**2*US%s_to_T*GV%H_to_m) + if (.not. use_BT_cont) then + call uvchksum("BT Dat[uv]", Datu, Datv, CS%debug_BT_HI, haloshift=1, scale=US%L_to_m*GV%H_to_m) + endif + call uvchksum("BT wt_[uv]", wt_u, wt_v, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scalar_pair=.true.) + call uvchksum("BT frhat[uv]", CS%frhatu, CS%frhatv, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scalar_pair=.true.) + call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scalar_pair=.true.) + call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, G%HI, haloshift=0, scale=US%L_T2_to_m_s2) + call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0, & + scale=GV%m_to_H, scalar_pair=.true.) + call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, & + haloshift=1, scalar_pair=.true.) + endif + + if (CS%id_ubtdt > 0) then + do j=js-1,je+1 ; do I=is-1,ie + ubt_st(I,j) = ubt(I,j) + enddo ; enddo + endif + if (CS%id_vbtdt > 0) then + do J=js-1,je ; do i=is-1,ie+1 + vbt_st(i,J) = vbt(i,J) + enddo ; enddo + endif + + if (query_averaging_enabled(CS%diag)) then + if (CS%id_eta_st > 0) call post_data(CS%id_eta_st, eta(isd:ied,jsd:jed), CS%diag) + if (CS%id_ubt_st > 0) call post_data(CS%id_ubt_st, ubt(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vbt_st > 0) call post_data(CS%id_vbt_st, vbt(isd:ied,JsdB:JedB), CS%diag) + endif + + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + if (id_clock_calc > 0) call cpu_clock_begin(id_clock_calc) + + if (project_velocity) then ; eta_PF_BT => eta ; else ; eta_PF_BT => eta_pred ; endif + + if (CS%dt_bt_filter >= 0.0) then + dt_filt = 0.5 * max(0.0, min(CS%dt_bt_filter, 2.0*dt)) + else + dt_filt = 0.5 * max(0.0, dt * min(-CS%dt_bt_filter, 2.0)) + endif + nfilter = ceiling(dt_filt / dtbt) + + if (nstep+nfilter==0 ) call MOM_error(FATAL, & + "btstep: number of barotropic step (nstep+nfilter) is 0") + + dtbt_diag = dt/(nstep+nfilter) + + ! Set up the normalized weights for the filtered velocity. + sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_accel = 0.0 ; sum_wt_trans = 0.0 + allocate(wt_vel(nstep+nfilter)) ; allocate(wt_eta(nstep+nfilter)) + allocate(wt_trans(nstep+nfilter+1)) ; allocate(wt_accel(nstep+nfilter+1)) + allocate(wt_accel2(nstep+nfilter+1)) + do n=1,nstep+nfilter + ! Modify this to use a different filter... + + ! This is a filter that ramps down linearly over a time dt_filt. + if ( (n==nstep) .or. (dt_filt - abs(n-nstep)*dtbt >= 0.0)) then + wt_vel(n) = 1.0 ; wt_eta(n) = 1.0 + elseif (dtbt + dt_filt - abs(n-nstep)*dtbt > 0.0) then + wt_vel(n) = 1.0 + (dt_filt / dtbt) - abs(n-nstep) ; wt_eta(n) = wt_vel(n) + else + wt_vel(n) = 0.0 ; wt_eta(n) = 0.0 + endif + ! This is a simple stepfunction filter. + ! if (n < nstep-nfilter) then ; wt_vel(n) = 0.0 ; else ; wt_vel(n) = 1.0 ; endif + ! wt_eta(n) = wt_vel(n) + + ! The rest should not be changed. + sum_wt_vel = sum_wt_vel + wt_vel(n) ; sum_wt_eta = sum_wt_eta + wt_eta(n) + enddo + wt_trans(nstep+nfilter+1) = 0.0 ; wt_accel(nstep+nfilter+1) = 0.0 + do n=nstep+nfilter,1,-1 + wt_trans(n) = wt_trans(n+1) + wt_eta(n) + wt_accel(n) = wt_accel(n+1) + wt_vel(n) + sum_wt_accel = sum_wt_accel + wt_accel(n) ; sum_wt_trans = sum_wt_trans + wt_trans(n) + enddo + ! Normalize the weights. + I_sum_wt_vel = 1.0 / sum_wt_vel ; I_sum_wt_accel = 1.0 / sum_wt_accel + I_sum_wt_eta = 1.0 / sum_wt_eta ; I_sum_wt_trans = 1.0 / sum_wt_trans + do n=1,nstep+nfilter + wt_vel(n) = wt_vel(n) * I_sum_wt_vel + if (CS%answer_date < 20190101) then + wt_accel2(n) = wt_accel(n) + ! wt_trans(n) = wt_trans(n) * I_sum_wt_trans + else + wt_accel2(n) = wt_accel(n) * I_sum_wt_accel + wt_trans(n) = wt_trans(n) * I_sum_wt_trans + endif + wt_accel(n) = wt_accel(n) * I_sum_wt_accel + wt_eta(n) = wt_eta(n) * I_sum_wt_eta + enddo + + sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_accel = 0.0 ; sum_wt_trans = 0.0 + + ! The following loop contains all of the time steps. + isv=is ; iev=ie ; jsv=js ; jev=je + do n=1,nstep+nfilter + + sum_wt_vel = sum_wt_vel + wt_vel(n) + sum_wt_eta = sum_wt_eta + wt_eta(n) + sum_wt_accel = sum_wt_accel + wt_accel2(n) + sum_wt_trans = sum_wt_trans + wt_trans(n) + + if (CS%clip_velocity) then + do j=jsv,jev ; do I=isv-1,iev + if ((ubt(I,j) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then + ! Add some error reporting later. + ubt(I,j) = (-0.95*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) + elseif ((ubt(I,j) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then + ! Add some error reporting later. + ubt(I,j) = (0.95*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) + endif + enddo ; enddo + do J=jsv-1,jev ; do i=isv,iev + if ((vbt(i,J) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then + ! Add some error reporting later. + vbt(i,J) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) + elseif ((vbt(i,J) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then + ! Add some error reporting later. + vbt(i,J) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) + endif + enddo ; enddo + endif + + if ((iev - stencil < ie) .or. (jev - stencil < je)) then + if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc) + call do_group_pass(CS%pass_eta_ubt, CS%BT_Domain, clock=id_clock_pass_step) + isv = isvf ; iev = ievf ; jsv = jsvf ; jev = jevf + if (id_clock_calc > 0) call cpu_clock_begin(id_clock_calc) + else + isv = isv+stencil ; iev = iev-stencil + jsv = jsv+stencil ; jev = jev-stencil + endif + + if ((.not.use_BT_cont) .and. CS%Nonlinear_continuity .and. & + (CS%Nonlin_cont_update_period > 0)) then + if ((n>1) .and. (mod(n-1,CS%Nonlin_cont_update_period) == 0)) & + call find_face_areas(Datu, Datv, G, GV, US, CS, MS, 1+iev-ie, eta) + endif + + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=jsv-1,jev+1 ; do I=isv-2,iev+1 + ubt_int_prev(I,j) = ubt_int(I,j) ; uhbt_int_prev(I,j) = uhbt_int(I,j) + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsv-2,jev+1 ; do i=isv-1,iev+1 + vbt_int_prev(i,J) = vbt_int(i,J) ; vhbt_int_prev(i,J) = vhbt_int(i,J) + enddo ; enddo + endif + + !$OMP parallel default(shared) private(vel_prev, ioff, joff) + if (CS%dynamic_psurf .or. .not.project_velocity) then + if (integral_BT_cont) then + !$OMP do + do j=jsv-1,jev+1 ; do I=isv-2,iev+1 + uhbt_int(I,j) = find_uhbt(ubt_int(I,j) + dtbt*ubt(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + enddo ; enddo + !$OMP end do nowait + !$OMP do + do J=jsv-2,jev+1 ; do i=isv-1,iev+1 + vhbt_int(i,J) = find_vhbt(vbt_int(i,J) + dtbt*vbt(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + enddo ; enddo + !$OMP do + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + eta_pred(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT(i,j) * & + ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) + enddo ; enddo + elseif (use_BT_cont) then + !$OMP do + do j=jsv-1,jev+1 ; do I=isv-2,iev+1 + uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j)) + uhbt0(I,j) + enddo ; enddo + !$OMP do + do J=jsv-2,jev+1 ; do i=isv-1,iev+1 + vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J)) + vhbt0(i,J) + enddo ; enddo + !$OMP do + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & + ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) + enddo ; enddo + else + !$OMP do + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & + (((Datu(I-1,j)*ubt(I-1,j) + uhbt0(I-1,j)) - & + (Datu(I,j)*ubt(I,j) + uhbt0(I,j))) + & + ((Datv(i,J-1)*vbt(i,J-1) + vhbt0(i,J-1)) - & + (Datv(i,J)*vbt(i,J) + vhbt0(i,J)))) + enddo ; enddo + endif + + if (CS%dynamic_psurf) then + !$OMP do + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + p_surf_dyn(i,j) = dyn_coef_eta(i,j) * (eta_pred(i,j) - eta(i,j)) + enddo ; enddo + endif + endif + + ! Recall that just outside the do n loop, there is code like... + ! eta_PF_BT => eta_pred ; if (project_velocity) eta_PF_BT => eta + + if (find_etaav) then + !$OMP do + do j=js,je ; do i=is,ie + eta_sum(i,j) = eta_sum(i,j) + wt_accel2(n) * eta_PF_BT(i,j) + enddo ; enddo + !$OMP end do nowait + endif + + if (interp_eta_PF) then + wt_end = n*Instep ! This could be (n-0.5)*Instep. + !$OMP do + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + eta_PF(i,j) = eta_PF_1(i,j) + wt_end*d_eta_PF(i,j) + enddo ; enddo + endif + + if (apply_OBC_flather .or. apply_OBC_open) then + !$OMP do + do j=jsv,jev ; do I=isv-2,iev+1 + ubt_old(I,j) = ubt(I,j) + enddo ; enddo + !$OMP do + do J=jsv-2,jev+1 ; do i=isv,iev + vbt_old(i,J) = vbt(i,J) + enddo ; enddo + endif + + if (apply_OBCs) then + if (MOD(n+G%first_direction,2)==1) then + ioff = 1; joff = 0 + else + ioff = 0; joff = 1 + endif + + if (CS%BT_OBC%apply_u_OBCs) then ! save the old value of ubt and uhbt + !$OMP do + do j=jsv-joff,jev+joff ; do I=isv-1,iev + ubt_prev(I,j) = ubt(I,j) ; uhbt_prev(I,j) = uhbt(I,j) + ubt_sum_prev(I,j) = ubt_sum(I,j) ; uhbt_sum_prev(I,j) = uhbt_sum(I,j) ; ubt_wtd_prev(I,j) = ubt_wtd(I,j) + enddo ; enddo + endif + + if (CS%BT_OBC%apply_v_OBCs) then ! save the old value of vbt and vhbt + !$OMP do + do J=jsv-1,jev ; do i=isv-ioff,iev+ioff + vbt_prev(i,J) = vbt(i,J) ; vhbt_prev(i,J) = vhbt(i,J) + vbt_sum_prev(i,J) = vbt_sum(i,J) ; vhbt_sum_prev(i,J) = vhbt_sum(i,J) ; vbt_wtd_prev(i,J) = vbt_wtd(i,J) + enddo ; enddo + endif + endif + + if (MOD(n+G%first_direction,2)==1) then + ! On odd-steps, update v first. + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 + Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + & + (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) + PFv(i,J) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j) - & + (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * & + dgeo_de * CS%IdyCv(i,J) + enddo ; enddo + !$OMP end do nowait + if (CS%dynamic_psurf) then + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 + PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) + enddo ; enddo + !$OMP end do nowait + endif + + if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + PFv(i,J) = 0.0 + endif ; enddo ; enddo + !$OMP end do nowait + endif + + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 + vel_prev = vbt(i,J) + vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & + dtbt * ((BT_force_v(i,J) + Cor_v(i,J)) + PFv(i,J))) + if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 + vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev + enddo ; enddo + + if (CS%linear_wave_drag) then + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & + ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) + enddo ; enddo + else + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) + enddo ; enddo + endif + + if (integral_BT_cont) then + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 + vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + ! Estimate the mass flux within a single timestep to take the filtered average. + vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 + vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) + enddo ; enddo + !$OMP end do nowait + else + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 + vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) + enddo ; enddo + !$OMP end do nowait + endif + if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + vbt(i,J) = vbt_prev(i,J) ; vhbt(i,J) = vhbt_prev(i,J) + endif ; enddo ; enddo + endif + ! Now update the zonal velocity. + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev + Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + & + (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - & + Cor_ref_u(I,j) + PFu(I,j) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_E(i,j) - & + (eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j)) * & + dgeo_de * CS%IdxCu(I,j) + enddo ; enddo + !$OMP end do nowait + + if (CS%dynamic_psurf) then + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev + PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) + enddo ; enddo + !$OMP end do nowait + endif + + if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + PFu(I,j) = 0.0 + endif ; enddo ; enddo + !$OMP end do nowait + endif + + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev + vel_prev = ubt(I,j) + ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & + dtbt * ((BT_force_u(I,j) + Cor_u(I,j)) + PFu(I,j))) + if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 + ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*vel_prev + enddo ; enddo + !$OMP end do nowait + + if (CS%linear_wave_drag) then + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev + u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * & + ((Cor_u(I,j) + PFu(I,j)) - ubt(I,j)*Rayleigh_u(I,j)) + enddo ; enddo + !$OMP end do nowait + else + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev + u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * (Cor_u(I,j) + PFu(I,j)) + enddo ; enddo + !$OMP end do nowait + endif + + if (integral_BT_cont) then + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev + ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) + uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + ! Estimate the mass flux within a single timestep to take the filtered average. + uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) + enddo ; enddo + else + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev + uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) + enddo ; enddo + endif + if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + ubt(I,j) = ubt_prev(I,j) ; uhbt(I,j) = uhbt_prev(I,j) + endif ; enddo ; enddo + endif + else + ! On even steps, update u first. + !$OMP do schedule(static) + do j=jsv-1,jev+1 ; do I=isv-1,iev + Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + & + (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - & + Cor_ref_u(I,j) + PFu(I,j) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_E(i,j) - & + (eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j)) * & + dgeo_de * CS%IdxCu(I,j) + enddo ; enddo + !$OMP end do nowait + + if (CS%dynamic_psurf) then + !$OMP do schedule(static) + do j=jsv-1,jev+1 ; do I=isv-1,iev + PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) + enddo ; enddo + !$OMP end do nowait + endif + + if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + PFu(I,j) = 0.0 + endif ; enddo ; enddo + endif + + !$OMP do schedule(static) + do j=jsv-1,jev+1 ; do I=isv-1,iev + vel_prev = ubt(I,j) + ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & + dtbt * ((BT_force_u(I,j) + Cor_u(I,j)) + PFu(I,j))) + if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 + ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*vel_prev + enddo ; enddo + + if (CS%linear_wave_drag) then + !$OMP do schedule(static) + do j=jsv-1,jev+1 ; do I=isv-1,iev + u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * & + ((Cor_u(I,j) + PFu(I,j)) - ubt(I,j)*Rayleigh_u(I,j)) + enddo ; enddo + else + !$OMP do schedule(static) + do j=jsv-1,jev+1 ; do I=isv-1,iev + u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * (Cor_u(I,j) + PFu(I,j)) + enddo ; enddo + endif + + if (integral_BT_cont) then + !$OMP do schedule(static) + do j=jsv-1,jev+1 ; do I=isv-1,iev + ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) + uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + ! Estimate the mass flux within a single timestep to take the filtered average. + uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then + !$OMP do schedule(static) + do j=jsv-1,jev+1 ; do I=isv-1,iev + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) + enddo ; enddo + !$OMP end do nowait + else + !$OMP do schedule(static) + do j=jsv-1,jev+1 ; do I=isv-1,iev + uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) + enddo ; enddo + !$OMP end do nowait + endif + if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. + !$OMP do schedule(static) + do j=jsv-1,jev+1 ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + ubt(I,j) = ubt_prev(I,j) ; uhbt(I,j) = uhbt_prev(I,j) + endif ; enddo ; enddo + endif + + ! Now update the meridional velocity. + if (CS%use_old_coriolis_bracket_bug) then + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev + Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + bmer(I,j) * ubt(I,j)) + & + (cmer(I,j+1) * ubt(I,j+1) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) + PFv(i,J) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j) - & + (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * & + dgeo_de * CS%IdyCv(i,J) + enddo ; enddo + !$OMP end do nowait + else + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev + Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + & + (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) + PFv(i,J) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j) - & + (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * & + dgeo_de * CS%IdyCv(i,J) + enddo ; enddo + !$OMP end do nowait + endif + + if (CS%dynamic_psurf) then + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev + PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) + enddo ; enddo + !$OMP end do nowait + endif + + if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + PFv(i,J) = 0.0 + endif ; enddo ; enddo + endif + + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev + vel_prev = vbt(i,J) + vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & + dtbt * ((BT_force_v(i,J) + Cor_v(i,J)) + PFv(i,J))) + if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 + vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev + enddo ; enddo + !$OMP end do nowait + + if (CS%linear_wave_drag) then + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & + ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) + enddo ; enddo + !$OMP end do nowait + else + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) + enddo ; enddo + !$OMP end do nowait + endif + + if (integral_BT_cont) then + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev + vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + ! Estimate the mass flux within a single timestep to take the filtered average. + vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev + vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) + enddo ; enddo + else + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev + vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) + enddo ; enddo + endif + if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + vbt(i,J) = vbt_prev(i,J); vhbt(i,J) = vhbt_prev(i,J) + endif ; enddo ; enddo + endif + endif + + ! This might need to be moved outside of the OMP do loop directives. + if (CS%debug_bt) then + write(mesg,'("BT vel update ",I4)') n + call uvchksum(trim(mesg)//" PF[uv]", PFu, PFv, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" Cor_[uv]", Cor_u, Cor_v, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_force_[uv]", BT_force_u, BT_force_v, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_rem_[uv]", BT_rem_u, BT_rem_v, CS%debug_BT_HI, & + haloshift=iev-ie, scalar_pair=.true.) + call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + if (integral_BT_cont) & + call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_to_m**2*GV%H_to_m) + endif + + if (find_PF) then + !$OMP do + do j=js,je ; do I=is-1,ie + PFu_bt_sum(I,j) = PFu_bt_sum(I,j) + wt_accel2(n) * PFu(I,j) + enddo ; enddo + !$OMP end do nowait + !$OMP do + do J=js-1,je ; do i=is,ie + PFv_bt_sum(i,J) = PFv_bt_sum(i,J) + wt_accel2(n) * PFv(i,J) + enddo ; enddo + !$OMP end do nowait + endif + if (find_Cor) then + !$OMP do + do j=js,je ; do I=is-1,ie + Coru_bt_sum(I,j) = Coru_bt_sum(I,j) + wt_accel2(n) * Cor_u(I,j) + enddo ; enddo + !$OMP end do nowait + !$OMP do + do J=js-1,je ; do i=is,ie + Corv_bt_sum(i,J) = Corv_bt_sum(i,J) + wt_accel2(n) * Cor_v(i,J) + enddo ; enddo + !$OMP end do nowait + endif + + !$OMP do + do j=js,je ; do I=is-1,ie + ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) + uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) + ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) + enddo ; enddo + !$OMP end do nowait + !$OMP do + do J=js-1,je ; do i=is,ie + vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) + vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) + vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) + enddo ; enddo + !$OMP end do nowait + + if (apply_OBCs) then + + !$OMP single + call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & + ubt_trans, vbt_trans, eta, SpV_col_avg, ubt_old, vbt_old, CS%BT_OBC, & + G, MS, GV, US, CS, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & + n*dtbt, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0, & + ubt_int_prev, vbt_int_prev, uhbt_int_prev, vhbt_int_prev) + !$OMP end single + + if (CS%BT_OBC%apply_u_OBCs) then + !$OMP do + do j=js,je ; do I=is-1,ie + if (OBC%segnum_u(I,j) /= OBC_NONE) then + ! Update the summed and integrated quantities from the saved previous values. + ubt_sum(I,j) = ubt_sum_prev(I,j) + wt_trans(n) * ubt_trans(I,j) + uhbt_sum(I,j) = uhbt_sum_prev(I,j) + wt_trans(n) * uhbt(I,j) + ubt_wtd(I,j) = ubt_wtd_prev(I,j) + wt_vel(n) * ubt(I,j) + if (integral_BT_cont) then + uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) + ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) + endif + endif + enddo ; enddo + endif + if (CS%BT_OBC%apply_v_OBCs) then + !$OMP do + do J=js-1,je ; do i=is,ie + if (OBC%segnum_v(i,J) /= OBC_NONE) then + ! Update the summed and integrated quantities from the saved previous values. + vbt_sum(i,J) = vbt_sum_prev(i,J) + wt_trans(n) * vbt_trans(i,J) + vhbt_sum(i,J) = vhbt_sum_prev(i,J) + wt_trans(n) * vhbt(i,J) + vbt_wtd(i,J) = vbt_wtd_prev(i,J) + wt_vel(n) * vbt(i,J) + if (integral_BT_cont) then + vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) + endif + endif + enddo ; enddo + endif + endif + + if (CS%debug_bt) then + call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + if (integral_BT_cont) & + call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, CS%debug_BT_HI, & + haloshift=iev-ie, scale=US%L_to_m**2*GV%H_to_m) + endif + + if (integral_BT_cont) then + !$OMP do + do j=jsv,jev ; do i=isv,iev + eta(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT(i,j) * & + ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) + eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) + enddo ; enddo + else + !$OMP do + do j=jsv,jev ; do i=isv,iev + eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & + ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) + eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) + enddo ; enddo + endif + !$OMP end parallel + + if (do_hifreq_output) then + time_step_end = time_bt_start + real_to_time(n*US%T_to_s*dtbt_diag) + call enable_averages(dtbt, time_step_end, CS%diag) + if (CS%id_ubt_hifreq > 0) call post_data(CS%id_ubt_hifreq, ubt(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vbt_hifreq > 0) call post_data(CS%id_vbt_hifreq, vbt(isd:ied,JsdB:JedB), CS%diag) + if (CS%id_eta_hifreq > 0) call post_data(CS%id_eta_hifreq, eta(isd:ied,jsd:jed), CS%diag) + if (CS%id_uhbt_hifreq > 0) call post_data(CS%id_uhbt_hifreq, uhbt(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vhbt_hifreq > 0) call post_data(CS%id_vhbt_hifreq, vhbt(isd:ied,JsdB:JedB), CS%diag) + if (CS%id_eta_pred_hifreq > 0) call post_data(CS%id_eta_pred_hifreq, eta_PF_BT(isd:ied,jsd:jed), CS%diag) + endif + + if (CS%debug_bt) then + write(mesg,'("BT step ",I4)') n + call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s) + call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=iev-ie, scale=GV%H_to_MKS) + endif + + if (GV%Boussinesq) then + do j=js,je ; do i=is,ie + if ((eta(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then + write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') GV%H_to_m*eta(i,j), & + -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%isd_global, j + G%jsd_global + if (err_count < 2) & + call MOM_error(WARNING, "btstep: eta has dropped below bathyT: "//trim(mesg), all_print=.true.) + err_count = err_count + 1 + endif + enddo ; enddo + else + do j=js,je ; do i=is,ie + if (eta(i,j) < 0.0) then + if (err_count < 2) & + call MOM_error(WARNING, "btstep: negative eta in a non-Boussinesq barotropic solver.", all_print=.true.) + err_count = err_count + 1 + endif + enddo ; enddo + endif + + enddo ! end of do n=1,ntimestep + if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc) + if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post) + + ! Reset the time information in the diag type. + if (do_hifreq_output) call enable_averaging(time_int_in, time_end_in, CS%diag) + + if (CS%answer_date < 20190101) then + I_sum_wt_vel = 1.0 / sum_wt_vel ; I_sum_wt_eta = 1.0 / sum_wt_eta + I_sum_wt_accel = 1.0 / sum_wt_accel ; I_sum_wt_trans = 1.0 / sum_wt_trans + else + I_sum_wt_vel = 1.0 ; I_sum_wt_eta = 1.0 ; I_sum_wt_accel = 1.0 ; I_sum_wt_trans = 1.0 + endif + + if (find_etaav) then ; do j=js,je ; do i=is,ie + etaav(i,j) = eta_sum(i,j) * I_sum_wt_accel + enddo ; enddo ; endif + do j=js-1,je+1 ; do i=is-1,ie+1 ; e_anom(i,j) = 0.0 ; enddo ; enddo + if (interp_eta_PF) then + do j=js,je ; do i=is,ie + e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - & + (eta_PF_1(i,j) + 0.5*d_eta_PF(i,j))) + enddo ; enddo + else + do j=js,je ; do i=is,ie + e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - eta_PF(i,j)) + enddo ; enddo + endif + if (apply_OBCs) then + !!! Not safe for wide halos... + if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. + !GOMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + e_anom(i+1,j) = e_anom(i,j) + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then + e_anom(i,j) = e_anom(i+1,j) + endif + enddo ; enddo + endif + + if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. + !GOMP parallel do default(shared) + do J=js-1,je ; do I=is,ie + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + e_anom(i,j+1) = e_anom(i,j) + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then + e_anom(i,j) = e_anom(i,j+1) + endif + enddo ; enddo + endif + endif + + ! It is possible that eta_out and eta_in are the same. + do j=js,je ; do i=is,ie + eta_out(i,j) = eta_wtd(i,j) * I_sum_wt_eta + enddo ; enddo + + if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) + if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post) + if (G%nonblocking_updates) then + call start_group_pass(CS%pass_e_anom, G%Domain) + else + if (find_etaav) call do_group_pass(CS%pass_etaav, G%Domain) + call do_group_pass(CS%pass_e_anom, G%Domain) + endif + if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post) + if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post) + + if (CS%answer_date < 20190101) then + do j=js,je ; do I=is-1,ie + CS%ubtav(I,j) = ubt_sum(I,j) * I_sum_wt_trans + uhbtav(I,j) = uhbt_sum(I,j) * I_sum_wt_trans + ubt_wtd(I,j) = ubt_wtd(I,j) * I_sum_wt_vel + enddo ; enddo + + do J=js-1,je ; do i=is,ie + CS%vbtav(i,J) = vbt_sum(i,J) * I_sum_wt_trans + vhbtav(i,J) = vhbt_sum(i,J) * I_sum_wt_trans + vbt_wtd(i,J) = vbt_wtd(i,J) * I_sum_wt_vel + enddo ; enddo + else + do j=js,je ; do I=is-1,ie + CS%ubtav(I,j) = ubt_sum(I,j) + uhbtav(I,j) = uhbt_sum(I,j) + enddo ; enddo + + do J=js-1,je ; do i=is,ie + CS%vbtav(i,J) = vbt_sum(i,J) + vhbtav(i,J) = vhbt_sum(i,J) + enddo ; enddo + endif + + + if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) + if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_e_anom, G%Domain) + if (find_etaav) call start_group_pass(CS%pass_etaav, G%Domain) + call start_group_pass(CS%pass_ubta_uhbta, G%DoMain) + else + call do_group_pass(CS%pass_ubta_uhbta, G%Domain) + endif + if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post) + if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post) + + ! Now calculate each layer's accelerations. + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=is-1,ie + accel_layer_u(I,j,k) = (u_accel_bt(I,j) - & + ((pbce(i+1,j,k) - gtot_W(i+1,j)) * e_anom(i+1,j) - & + (pbce(i,j,k) - gtot_E(i,j)) * e_anom(i,j)) * CS%IdxCu(I,j) ) + if (abs(accel_layer_u(I,j,k)) < accel_underflow) accel_layer_u(I,j,k) = 0.0 + enddo ; enddo + do J=js-1,je ; do i=is,ie + accel_layer_v(i,J,k) = (v_accel_bt(i,J) - & + ((pbce(i,j+1,k) - gtot_S(i,j+1)) * e_anom(i,j+1) - & + (pbce(i,j,k) - gtot_N(i,j)) * e_anom(i,j)) * CS%IdyCv(i,J) ) + if (abs(accel_layer_v(i,J,k)) < accel_underflow) accel_layer_v(i,J,k) = 0.0 + enddo ; enddo + enddo + + if (apply_OBCs) then + ! Correct the accelerations at OBC velocity points, but only in the + ! symmetric-memory computational domain, not in the wide halo regions. + if (CS%BT_OBC%apply_u_OBCs) then ; do j=js,je ; do I=is-1,ie + if (OBC%segnum_u(I,j) /= OBC_NONE) then + u_accel_bt(I,j) = (ubt_wtd(I,j) - ubt_first(I,j)) / dt + do k=1,nz ; accel_layer_u(I,j,k) = u_accel_bt(I,j) ; enddo + endif + enddo ; enddo ; endif + if (CS%BT_OBC%apply_v_OBCs) then ; do J=js-1,je ; do i=is,ie + if (OBC%segnum_v(i,J) /= OBC_NONE) then + v_accel_bt(i,J) = (vbt_wtd(i,J) - vbt_first(i,J)) / dt + do k=1,nz ; accel_layer_v(i,J,k) = v_accel_bt(i,J) ; enddo + endif + enddo ; enddo ; endif + endif + + if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) + + ! Calculate diagnostic quantities. + if (query_averaging_enabled(CS%diag)) then + + if (CS%gradual_BT_ICs) then + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = ubt_wtd(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vbt_wtd(i,J) ; enddo ; enddo + endif + +! Offer various barotropic terms for averaging. + if (CS%id_PFu_bt > 0) then + do j=js,je ; do I=is-1,ie + PFu_bt_sum(I,j) = PFu_bt_sum(I,j) * I_sum_wt_accel + enddo ; enddo + call post_data(CS%id_PFu_bt, PFu_bt_sum(IsdB:IedB,jsd:jed), CS%diag) + endif + if (CS%id_PFv_bt > 0) then + do J=js-1,je ; do i=is,ie + PFv_bt_sum(i,J) = PFv_bt_sum(i,J) * I_sum_wt_accel + enddo ; enddo + call post_data(CS%id_PFv_bt, PFv_bt_sum(isd:ied,JsdB:JedB), CS%diag) + endif + if (CS%id_Coru_bt > 0) then + do j=js,je ; do I=is-1,ie + Coru_bt_sum(I,j) = Coru_bt_sum(I,j) * I_sum_wt_accel + enddo ; enddo + call post_data(CS%id_Coru_bt, Coru_bt_sum(IsdB:IedB,jsd:jed), CS%diag) + endif + if (CS%id_Corv_bt > 0) then + do J=js-1,je ; do i=is,ie + Corv_bt_sum(i,J) = Corv_bt_sum(i,J) * I_sum_wt_accel + enddo ; enddo + call post_data(CS%id_Corv_bt, Corv_bt_sum(isd:ied,JsdB:JedB), CS%diag) + endif + if (CS%id_ubtdt > 0) then + do j=js,je ; do I=is-1,ie + ubt_dt(I,j) = (ubt_wtd(I,j) - ubt_st(I,j))*Idt + enddo ; enddo + call post_data(CS%id_ubtdt, ubt_dt(IsdB:IedB,jsd:jed), CS%diag) + endif + if (CS%id_vbtdt > 0) then + do J=js-1,je ; do i=is,ie + vbt_dt(i,J) = (vbt_wtd(i,J) - vbt_st(i,J))*Idt + enddo ; enddo + call post_data(CS%id_vbtdt, vbt_dt(isd:ied,JsdB:JedB), CS%diag) + endif + + if (CS%id_ubtforce > 0) call post_data(CS%id_ubtforce, BT_force_u(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vbtforce > 0) call post_data(CS%id_vbtforce, BT_force_v(isd:ied,JsdB:JedB), CS%diag) + if (CS%id_uaccel > 0) call post_data(CS%id_uaccel, u_accel_bt(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vaccel > 0) call post_data(CS%id_vaccel, v_accel_bt(isd:ied,JsdB:JedB), CS%diag) + + if (CS%id_eta_cor > 0) call post_data(CS%id_eta_cor, CS%eta_cor, CS%diag) + if (CS%id_eta_bt > 0) call post_data(CS%id_eta_bt, eta_out, CS%diag) ! - G%Z_ref? + if (CS%id_gtotn > 0) call post_data(CS%id_gtotn, gtot_N(isd:ied,jsd:jed), CS%diag) + if (CS%id_gtots > 0) call post_data(CS%id_gtots, gtot_S(isd:ied,jsd:jed), CS%diag) + if (CS%id_gtote > 0) call post_data(CS%id_gtote, gtot_E(isd:ied,jsd:jed), CS%diag) + if (CS%id_gtotw > 0) call post_data(CS%id_gtotw, gtot_W(isd:ied,jsd:jed), CS%diag) + if (CS%id_ubt > 0) call post_data(CS%id_ubt, ubt_wtd(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vbt > 0) call post_data(CS%id_vbt, vbt_wtd(isd:ied,JsdB:JedB), CS%diag) + if (CS%id_ubtav > 0) call post_data(CS%id_ubtav, CS%ubtav, CS%diag) + if (CS%id_vbtav > 0) call post_data(CS%id_vbtav, CS%vbtav, CS%diag) + if (CS%id_visc_rem_u > 0) call post_data(CS%id_visc_rem_u, visc_rem_u, CS%diag) + if (CS%id_visc_rem_v > 0) call post_data(CS%id_visc_rem_v, visc_rem_v, CS%diag) + + if (CS%id_frhatu > 0) call post_data(CS%id_frhatu, CS%frhatu, CS%diag) + if (CS%id_uhbt > 0) call post_data(CS%id_uhbt, uhbtav, CS%diag) + if (CS%id_frhatv > 0) call post_data(CS%id_frhatv, CS%frhatv, CS%diag) + if (CS%id_vhbt > 0) call post_data(CS%id_vhbt, vhbtav, CS%diag) + if (CS%id_uhbt0 > 0) call post_data(CS%id_uhbt0, uhbt0(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vhbt0 > 0) call post_data(CS%id_vhbt0, vhbt0(isd:ied,JsdB:JedB), CS%diag) + + if (CS%id_frhatu1 > 0) call post_data(CS%id_frhatu1, CS%frhatu1, CS%diag) + if (CS%id_frhatv1 > 0) call post_data(CS%id_frhatv1, CS%frhatv1, CS%diag) + + if (use_BT_cont) then + if (CS%id_BTC_FA_u_EE > 0) call post_data(CS%id_BTC_FA_u_EE, BT_cont%FA_u_EE, CS%diag) + if (CS%id_BTC_FA_u_E0 > 0) call post_data(CS%id_BTC_FA_u_E0, BT_cont%FA_u_E0, CS%diag) + if (CS%id_BTC_FA_u_W0 > 0) call post_data(CS%id_BTC_FA_u_W0, BT_cont%FA_u_W0, CS%diag) + if (CS%id_BTC_FA_u_WW > 0) call post_data(CS%id_BTC_FA_u_WW, BT_cont%FA_u_WW, CS%diag) + if (CS%id_BTC_uBT_EE > 0) call post_data(CS%id_BTC_uBT_EE, BT_cont%uBT_EE, CS%diag) + if (CS%id_BTC_uBT_WW > 0) call post_data(CS%id_BTC_uBT_WW, BT_cont%uBT_WW, CS%diag) + if (CS%id_BTC_FA_u_rat0 > 0) then + tmp_u(:,:) = 0.0 + do j=js,je ; do I=is-1,ie + if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0)) then + tmp_u(I,j) = (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j)) + else + tmp_u(I,j) = 1.0 + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_u_rat0, tmp_u, CS%diag) + endif + if (CS%id_BTC_FA_v_NN > 0) call post_data(CS%id_BTC_FA_v_NN, BT_cont%FA_v_NN, CS%diag) + if (CS%id_BTC_FA_v_N0 > 0) call post_data(CS%id_BTC_FA_v_N0, BT_cont%FA_v_N0, CS%diag) + if (CS%id_BTC_FA_v_S0 > 0) call post_data(CS%id_BTC_FA_v_S0, BT_cont%FA_v_S0, CS%diag) + if (CS%id_BTC_FA_v_SS > 0) call post_data(CS%id_BTC_FA_v_SS, BT_cont%FA_v_SS, CS%diag) + if (CS%id_BTC_vBT_NN > 0) call post_data(CS%id_BTC_vBT_NN, BT_cont%vBT_NN, CS%diag) + if (CS%id_BTC_vBT_SS > 0) call post_data(CS%id_BTC_vBT_SS, BT_cont%vBT_SS, CS%diag) + if (CS%id_BTC_FA_v_rat0 > 0) then + tmp_v(:,:) = 0.0 + do J=js-1,je ; do i=is,ie + if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0)) then + tmp_v(i,J) = (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J)) + else + tmp_v(i,J) = 1.0 + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_v_rat0, tmp_v, CS%diag) + endif + if (CS%id_BTC_FA_h_rat0 > 0) then + tmp_h(:,:) = 0.0 + do j=js,je ; do i=is,ie + tmp_h(i,j) = 1.0 + if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0) .and. (BT_cont%FA_u_E0(I,j) > 0.0)) then + if (BT_cont%FA_u_W0(I,j) > BT_cont%FA_u_E0(I,j)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I,j)/ BT_cont%FA_u_E0(I,j))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j))) + endif + endif + if ((G%mask2dCu(I-1,j) > 0.0) .and. (BT_cont%FA_u_W0(I-1,j) > 0.0) .and. (BT_cont%FA_u_E0(I-1,j) > 0.0)) then + if (BT_cont%FA_u_W0(I-1,j) > BT_cont%FA_u_E0(I-1,j)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I-1,j)/ BT_cont%FA_u_E0(I-1,j))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I-1,j)/ BT_cont%FA_u_W0(I-1,j))) + endif + endif + if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0) .and. (BT_cont%FA_v_N0(i,J) > 0.0)) then + if (BT_cont%FA_v_S0(i,J) > BT_cont%FA_v_N0(i,J)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J)/ BT_cont%FA_v_N0(i,J))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J))) + endif + endif + if ((G%mask2dCv(i,J-1) > 0.0) .and. (BT_cont%FA_v_S0(i,J-1) > 0.0) .and. (BT_cont%FA_v_N0(i,J-1) > 0.0)) then + if (BT_cont%FA_v_S0(i,J-1) > BT_cont%FA_v_N0(i,J-1)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J-1)/ BT_cont%FA_v_N0(i,J-1))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J-1)/ BT_cont%FA_v_S0(i,J-1))) + endif + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_h_rat0, tmp_h, CS%diag) + endif + endif + else + if (CS%id_frhatu1 > 0) CS%frhatu1(:,:,:) = CS%frhatu(:,:,:) + if (CS%id_frhatv1 > 0) CS%frhatv1(:,:,:) = CS%frhatv(:,:,:) + endif + + if (associated(ADp%diag_hfrac_u)) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + ADp%diag_hfrac_u(I,j,k) = CS%frhatu(I,j,k) + enddo ; enddo ; enddo + endif + if (associated(ADp%diag_hfrac_v)) then + do k=1,nz ; do J=js-1,je ; do i=is,ie + ADp%diag_hfrac_v(i,J,k) = CS%frhatv(i,J,k) + enddo ; enddo ; enddo + endif + + if (use_BT_cont .and. associated(ADp%diag_hu)) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + ADp%diag_hu(I,j,k) = BT_cont%h_u(I,j,k) + enddo ; enddo ; enddo + endif + if (use_BT_cont .and. associated(ADp%diag_hv)) then + do k=1,nz ; do J=js-1,je ; do i=is,ie + ADp%diag_hv(i,J,k) = BT_cont%h_v(i,J,k) + enddo ; enddo ; enddo + endif + if (associated(ADp%visc_rem_u)) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + ADp%visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + enddo ; enddo ; enddo + endif + if (associated(ADp%visc_rem_v)) then + do k=1,nz ; do J=js-1,je ; do i=is,ie + ADp%visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + enddo ; enddo ; enddo + endif + + if (G%nonblocking_updates) then + if (find_etaav) call complete_group_pass(CS%pass_etaav, G%Domain) + call complete_group_pass(CS%pass_ubta_uhbta, G%Domain) + endif + +end subroutine btstep + +!> This subroutine automatically determines an optimal value for dtbt based +!! on some state of the ocean. +subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta !< The barotropic free surface + !! height anomaly or column mass anomaly [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: pbce !< The baroclinic pressure + !! anomaly in each layer due to free surface + !! height anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe + !! the effective open face areas as a + !! function of barotropic flow. + real, optional, intent(in) :: gtot_est !< An estimate of the total gravitational + !! acceleration [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real, optional, intent(in) :: SSH_add !< An additional contribution to SSH to + !! provide a margin of error when + !! calculating the external wave speed [Z ~> m]. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + gtot_E, & ! gtot_X is the effective total reduced gravity used to relate + gtot_W, & ! free surface height deviations to pressure forces (including + gtot_N, & ! GFS and baroclinic contributions) in the barotropic momentum + gtot_S ! equations half a grid-point in the X-direction (X is N, S, E, or W) + ! from the thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + ! (See Hallberg, J Comp Phys 1997 for a discussion.) + real, dimension(SZIBS_(G),SZJ_(G)) :: & + Datu ! Basin depth at u-velocity grid points times the y-grid + ! spacing [H L ~> m2 or kg m-1]. + real, dimension(SZI_(G),SZJBS_(G)) :: & + Datv ! Basin depth at v-velocity grid points times the x-grid + ! spacing [H L ~> m2 or kg m-1]. + real :: det_de ! The partial derivative due to self-attraction and loading + ! of the reference geopotential with the sea surface height [nondim]. + ! This is typically ~0.09 or less. + real :: dgeo_de ! The constant of proportionality between geopotential and + ! sea surface height [nondim]. It is a nondimensional number of + ! order 1. For stability, this may be made larger + ! than physical problem would suggest. + real :: add_SSH ! An additional contribution to SSH to provide a margin of error + ! when calculating the external wave speed [Z ~> m]. + real :: min_max_dt2 ! The square of the minimum value of the largest stable barotropic + ! timesteps [T2 ~> s2] + real :: dtbt_max ! The maximum barotropic timestep [T ~> s] + real :: Idt_max2 ! The squared inverse of the local maximum stable + ! barotropic time step [T-2 ~> s-2]. + logical :: use_BT_cont + type(memory_size_type) :: MS + + integer :: i, j, k, is, ie, js, je, nz + + if (.not.CS%module_is_initialized) call MOM_error(FATAL, & + "set_dtbt: Module MOM_barotropic must be initialized before it is used.") + + if (.not.CS%split) return + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + MS%isdw = G%isd ; MS%iedw = G%ied ; MS%jsdw = G%jsd ; MS%jedw = G%jed + + + if (.not.(present(pbce) .or. present(gtot_est))) call MOM_error(FATAL, & + "set_dtbt: Either pbce or gtot_est must be present.") + + add_SSH = 0.0 ; if (present(SSH_add)) add_SSH = SSH_add + + use_BT_cont = .false. + if (present(BT_cont)) use_BT_cont = (associated(BT_cont)) + + if (use_BT_cont) then + call BT_cont_to_face_areas(BT_cont, Datu, Datv, G, US, MS, halo=0) + elseif (CS%Nonlinear_continuity .and. present(eta)) then + call find_face_areas(Datu, Datv, G, GV, US, CS, MS, 0, eta=eta) + else + call find_face_areas(Datu, Datv, G, GV, US, CS, MS, 0, add_max=add_SSH) + endif + + det_de = 0.0 + if (CS%calculate_SAL) call scalar_SAL_sensitivity(CS%SAL_CSp, det_de) + if (CS%tidal_sal_bug) then + dgeo_de = 1.0 + max(0.0, det_de + CS%G_extra) + else + dgeo_de = 1.0 + max(0.0, CS%G_extra - det_de) + endif + if (present(pbce)) then + do j=js,je ; do i=is,ie + gtot_E(i,j) = 0.0 ; gtot_W(i,j) = 0.0 + gtot_N(i,j) = 0.0 ; gtot_S(i,j) = 0.0 + enddo ; enddo + do k=1,nz ; do j=js,je ; do i=is,ie + gtot_E(i,j) = gtot_E(i,j) + pbce(i,j,k) * CS%frhatu(I,j,k) + gtot_W(i,j) = gtot_W(i,j) + pbce(i,j,k) * CS%frhatu(I-1,j,k) + gtot_N(i,j) = gtot_N(i,j) + pbce(i,j,k) * CS%frhatv(i,J,k) + gtot_S(i,j) = gtot_S(i,j) + pbce(i,j,k) * CS%frhatv(i,J-1,k) + enddo ; enddo ; enddo + else + do j=js,je ; do i=is,ie + gtot_E(i,j) = gtot_est ; gtot_W(i,j) = gtot_est + gtot_N(i,j) = gtot_est ; gtot_S(i,j) = gtot_est + enddo ; enddo + endif + + min_max_dt2 = 1.0e38*US%s_to_T**2 ! A huge value for the permissible timestep squared. + do j=js,je ; do i=is,ie + ! This is pretty accurate for gravity waves, but it is a conservative + ! estimate since it ignores the stabilizing effect of the bottom drag. + Idt_max2 = 0.5 * (1.0 + 2.0*CS%bebt) * (G%IareaT(i,j) * & + ((gtot_E(i,j)*Datu(I,j)*G%IdxCu(I,j) + gtot_W(i,j)*Datu(I-1,j)*G%IdxCu(I-1,j)) + & + (gtot_N(i,j)*Datv(i,J)*G%IdyCv(i,J) + gtot_S(i,j)*Datv(i,J-1)*G%IdyCv(i,J-1))) + & + ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) * CS%BT_Coriolis_scale**2 ) + if (Idt_max2 * min_max_dt2 > 1.0) min_max_dt2 = 1.0 / Idt_max2 + enddo ; enddo + dtbt_max = sqrt(min_max_dt2 / dgeo_de) + if (id_clock_sync > 0) call cpu_clock_begin(id_clock_sync) + call min_across_PEs(dtbt_max) + if (id_clock_sync > 0) call cpu_clock_end(id_clock_sync) + + CS%dtbt = CS%dtbt_fraction * dtbt_max + CS%dtbt_max = dtbt_max + + if (CS%debug) then + call chksum0(CS%dtbt, "End set_dtbt dtbt", scale=US%T_to_s) + call chksum0(CS%dtbt_max, "End set_dtbt dtbt_max", scale=US%T_to_s) + endif + +end subroutine set_dtbt + +!> The following 4 subroutines apply the open boundary conditions. +!! This subroutine applies the open boundary conditions on barotropic +!! velocities and mass transports, as developed by Mehmet Ilicak. +subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, SpV_avg, & + ubt_old, vbt_old, BT_OBC, G, MS, GV, US, CS, halo, dtbt, bebt, & + use_BT_cont, integral_BT_cont, dt_elapsed, Datu, Datv, & + BTCL_u, BTCL_v, uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int, vhbt_int) + type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of + !! the argument arrays. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt !< the zonal barotropic velocity [L T-1 ~> m s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: uhbt !< the zonal barotropic transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt_trans !< The zonal barotropic velocity used in + !! transport [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt !< The meridional barotropic velocity + !! [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vhbt !< the meridional barotropic transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt_trans !< the meridional BT velocity used in + !! transports [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or + !! column mass anomaly [H ~> m or kg m-2]. + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: SpV_avg !< The column average specific volume [R-1 ~> m3 kg-1] + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_old !< The starting value of ubt in a barotropic + !! step [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_old !< The starting value of vbt in a barotropic + !! step [L T-1 ~> m s-1]. + type(BT_OBC_type), intent(in) :: BT_OBC !< A structure with the private barotropic arrays + !! related to the open boundary conditions, + !! set by set_up_BT_OBC. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(barotropic_CS), intent(in) :: CS !< Barotropic control structure + integer, intent(in) :: halo !< The extra halo size to use here. + real, intent(in) :: dtbt !< The time step [T ~> s]. + real, intent(in) :: bebt !< The fractional weighting of the future velocity + !! in determining the transport [nondim] + logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate + !! transports. + logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity + !! equation directly from the initial condition + !! using the time-integrated barotropic velocity. + real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping + !! that will have elapsed [T ~> s]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points + !! [H L ~> m2 or kg m-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points + !! [H L ~> m2 or kg m-1]. + type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: BTCL_u !< Structure of information used + !! for a dynamic estimate of the face areas at + !! u-points. + type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used + !! for a dynamic estimate of the face areas at + !! v-points. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt0 !< A correction to the zonal transport so that + !! the barotropic functions agree with the sum + !! of the layer transports + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt0 !< A correction to the meridional transport so that + !! the barotropic functions agree with the sum + !! of the layer transports + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_int !< The time-integrated zonal barotropic + !! velocity before this update [L T-1 ~> m s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int !< The time-integrated zonal barotropic + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_int !< The time-integrated meridional barotropic + !! velocity before this update [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int !< The time-integrated meridional barotropic + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. + + ! Local variables + real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. + real :: vel_trans ! The combination of the previous and current velocity + ! that does the mass transport [L T-1 ~> m s-1]. + real :: cfl ! The CFL number at the point in question [nondim] + real :: u_inlet ! The zonal inflow velocity [L T-1 ~> m s-1] + real :: v_inlet ! The meridional inflow velocity [L T-1 ~> m s-1] + real :: uhbt_int_new ! The updated time-integrated zonal transport [H L2 ~> m3] + real :: vhbt_int_new ! The updated time-integrated meridional transport [H L2 ~> m3] + real :: ssh_in ! The inflow sea surface height [Z ~> m] + real :: ssh_1 ! The sea surface height in the interior cell adjacent to the an OBC face [Z ~> m] + real :: ssh_2 ! The sea surface height in the next cell inward from the OBC face [Z ~> m] + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] + integer :: i, j, is, ie, js, je + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + + if (.not.(BT_OBC%apply_u_OBCs .or. BT_OBC%apply_v_OBCs)) return + + Idtbt = 1.0 / dtbt + + if (BT_OBC%apply_u_OBCs) then + do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_u(I,j))%specified) then + uhbt(I,j) = BT_OBC%uhbt(I,j) + ubt(I,j) = BT_OBC%ubt_outer(I,j) + vel_trans = ubt(I,j) + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + if (OBC%segment(OBC%segnum_u(I,j))%Flather) then + cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL + u_inlet = cfl*ubt_old(I-1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 + if (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) - (CS%bathyT(i,j) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i-1,j) * SpV_avg(i-1,j) - (CS%bathyT(i-1,j) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif + if (BT_OBC%dZ_u(I,j) > 0.0) then + vel_prev = ubt(I,j) + ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & + (BT_OBC%Cg_u(I,j)/BT_OBC%dZ_u(I,j)) * (ssh_in-BT_OBC%SSH_outer_u(I,j))) + vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) + else ! This point is now dry. + ubt(I,j) = 0.0 + vel_trans = 0.0 + endif + elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then + ubt(I,j) = ubt(I-1,j) + vel_trans = ubt(I,j) + endif + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + if (OBC%segment(OBC%segnum_u(I,j))%Flather) then + cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL + u_inlet = cfl*ubt_old(I+1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 + if (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i+1,j) * SpV_avg(i+1,j) - (CS%bathyT(i+1,j) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i+2,j) * SpV_avg(i+2,j) - (CS%bathyT(i+2,j) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif + + if (BT_OBC%dZ_u(I,j) > 0.0) then + vel_prev = ubt(I,j) + ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & + (BT_OBC%Cg_u(I,j)/BT_OBC%dZ_u(I,j)) * (BT_OBC%SSH_outer_u(I,j)-ssh_in)) + vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) + else ! This point is now dry. + ubt(I,j) = 0.0 + vel_trans = 0.0 + endif + elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then + ubt(I,j) = ubt(I+1,j) + vel_trans = ubt(I,j) + endif + endif + + if (.not. OBC%segment(OBC%segnum_u(I,j))%specified) then + if (integral_BT_cont) then + uhbt_int_new = find_uhbt(ubt_int(I,j) + dtbt*vel_trans, BTCL_u(I,j)) + & + dt_elapsed*uhbt0(I,j) + uhbt(I,j) = (uhbt_int_new - uhbt_int(I,j)) * Idtbt + elseif (use_BT_cont) then + uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j)) + uhbt0(I,j) + else + uhbt(I,j) = Datu(I,j)*vel_trans + uhbt0(I,j) + endif + endif + + ubt_trans(I,j) = vel_trans + endif ; enddo ; enddo + endif + + if (BT_OBC%apply_v_OBCs) then + do J=js-1,je ; do i=is,ie ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%specified) then + vhbt(i,J) = BT_OBC%vhbt(i,J) + vbt(i,J) = BT_OBC%vbt_outer(i,J) + vel_trans = vbt(i,J) + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + if (OBC%segment(OBC%segnum_v(i,J))%Flather) then + cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL + v_inlet = cfl*vbt_old(i,J-1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl<1 + if (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) - (CS%bathyT(i,j) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i,j-1) * SpV_avg(i,j-1) - (CS%bathyT(i,j-1) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif + + if (BT_OBC%dZ_v(i,J) > 0.0) then + vel_prev = vbt(i,J) + vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & + (BT_OBC%Cg_v(i,J)/BT_OBC%dZ_v(i,J)) * (ssh_in-BT_OBC%SSH_outer_v(i,J))) + vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) + else ! This point is now dry + vbt(i,J) = 0.0 + vel_trans = 0.0 + endif + elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then + vbt(i,J) = vbt(i,J-1) + vel_trans = vbt(i,J) + endif + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + if (OBC%segment(OBC%segnum_v(i,J))%Flather) then + cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL + v_inlet = cfl*vbt_old(i,J+1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl <1 + if (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i,j+1) * SpV_avg(i,j+1) - (CS%bathyT(i,j+1) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i,j+2) * SpV_avg(i,j+2) - (CS%bathyT(i,j+2) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif + + if (BT_OBC%dZ_v(i,J) > 0.0) then + vel_prev = vbt(i,J) + vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & + (BT_OBC%Cg_v(i,J)/BT_OBC%dZ_v(i,J)) * (BT_OBC%SSH_outer_v(i,J)-ssh_in)) + vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) + else ! This point is now dry + vbt(i,J) = 0.0 + vel_trans = 0.0 + endif + elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then + vbt(i,J) = vbt(i,J+1) + vel_trans = vbt(i,J) + endif + endif + + if (.not. OBC%segment(OBC%segnum_v(i,J))%specified) then + if (integral_BT_cont) then + vhbt_int_new = find_vhbt(vbt_int(i,J) + dtbt*vel_trans, BTCL_v(i,J)) + & + dt_elapsed*vhbt0(i,J) + vhbt(i,J) = (vhbt_int_new - vhbt_int(i,J)) * Idtbt + elseif (use_BT_cont) then + vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J)) + vhbt0(i,J) + else + vhbt(i,J) = vel_trans*Datv(i,J) + vhbt0(i,J) + endif + endif + + vbt_trans(i,J) = vel_trans + endif ; enddo ; enddo + endif + +end subroutine apply_velocity_OBCs + +!> This subroutine sets up the private structure used to apply the open +!! boundary conditions, as developed by Mehmet Ilicak. +subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS, halo, use_BT_cont, & + integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) + type(ocean_OBC_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type. + type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the + !! argument arrays. + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or + !! column mass anomaly [H ~> m or kg m-2]. + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: SpV_avg !< The column average specific volume [R-1 ~> m3 kg-1] + type(BT_OBC_type), intent(inout) :: BT_OBC !< A structure with the private barotropic arrays + !! related to the open boundary conditions, + !! set by set_up_BT_OBC. + type(MOM_domain_type), intent(inout) :: BT_Domain !< MOM_domain_type associated with wide arrays + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(barotropic_CS), intent(in) :: CS !< Barotropic control structure + integer, intent(in) :: halo !< The extra halo size to use here. + logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate + !! transports. + logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity + !! equation directly from the initial condition + !! using the time-integrated barotropic velocity. + real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of + !! updates to the barotropic solver [T ~> s] + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points + !! [H L ~> m2 or kg m-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points + !! [H L ~> m2 or kg m-1]. + type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: BTCL_u !< Structure of information used + !! for a dynamic estimate of the face areas at + !! u-points. + type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used + !! for a dynamic estimate of the face areas at + !! v-points. + real, optional, intent(in) :: dgeo_de !< The constant of proportionality between + !! geopotential and sea surface height [nondim]. + ! Local variables + real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1]. + real :: dgeo_de_in !< The constant of proportionality between geopotential and sea surface height [nondim]. + integer :: i, j, k, is, ie, js, je, n, nz + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer :: isdw, iedw, jsdw, jedw + type(OBC_segment_type), pointer :: segment !< Open boundary segment + + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + isdw = MS%isdw ; iedw = MS%iedw ; jsdw = MS%jsdw ; jedw = MS%jedw + + I_dt = 1.0 / dt_baroclinic + + if ((isdw < isd) .or. (jsdw < jsd)) then + call MOM_error(FATAL, "set_up_BT_OBC: Open boundary conditions are not "//& + "yet fully implemented with wide barotropic halos.") + endif + + dgeo_de_in = 1.0 + if (PRESENT(dgeo_de)) dgeo_de_in = dgeo_de + + if (.not. BT_OBC%is_alloced) then + allocate(BT_OBC%Cg_u(isdw-1:iedw,jsdw:jedw), source=0.0) + allocate(BT_OBC%dZ_u(isdw-1:iedw,jsdw:jedw), source=0.0) + allocate(BT_OBC%uhbt(isdw-1:iedw,jsdw:jedw), source=0.0) + allocate(BT_OBC%ubt_outer(isdw-1:iedw,jsdw:jedw), source=0.0) + allocate(BT_OBC%SSH_outer_u(isdw-1:iedw,jsdw:jedw), source=0.0) + + allocate(BT_OBC%Cg_v(isdw:iedw,jsdw-1:jedw), source=0.0) + allocate(BT_OBC%dZ_v(isdw:iedw,jsdw-1:jedw), source=0.0) + allocate(BT_OBC%vhbt(isdw:iedw,jsdw-1:jedw), source=0.0) + allocate(BT_OBC%vbt_outer(isdw:iedw,jsdw-1:jedw), source=0.0) + allocate(BT_OBC%SSH_outer_v(isdw:iedw,jsdw-1:jedw), source=0.0) + BT_OBC%is_alloced = .true. + call create_group_pass(BT_OBC%pass_uv, BT_OBC%ubt_outer, BT_OBC%vbt_outer, BT_Domain) + call create_group_pass(BT_OBC%pass_uhvh, BT_OBC%uhbt, BT_OBC%vhbt, BT_Domain) + call create_group_pass(BT_OBC%pass_eta_outer, BT_OBC%SSH_outer_u, BT_OBC%SSH_outer_v, BT_Domain,To_All+Scalar_Pair) + call create_group_pass(BT_OBC%pass_h, BT_OBC%dZ_u, BT_OBC%dZ_v, BT_Domain,To_All+Scalar_Pair) + call create_group_pass(BT_OBC%pass_cg, BT_OBC%Cg_u, BT_OBC%Cg_v, BT_Domain,To_All+Scalar_Pair) + endif + + if (BT_OBC%apply_u_OBCs) then + if (OBC%specified_u_BCs_exist_globally) then + do n = 1, OBC%number_of_segments + segment => OBC%segment(n) + if (segment%is_E_or_W .and. segment%specified) then + do j=segment%HI%jsd,segment%HI%jed ; do I=segment%HI%IsdB,segment%HI%IedB + BT_OBC%uhbt(I,j) = 0. + enddo ; enddo + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed ; do I=segment%HI%IsdB,segment%HI%IedB + BT_OBC%uhbt(I,j) = BT_OBC%uhbt(I,j) + segment%normal_trans(I,j,k) + enddo ; enddo ; enddo + endif + enddo + endif + do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + ! Can this go in segment loop above? Is loop above wrong for wide halos?? + if (OBC%segment(OBC%segnum_u(I,j))%specified) then + if (integral_BT_cont) then + BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j)*dt_baroclinic, BTCL_u(I,j)) * I_dt + elseif (use_BT_cont) then + BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j), BTCL_u(I,j)) + else + if (Datu(I,j) > 0.0) BT_OBC%ubt_outer(I,j) = BT_OBC%uhbt(I,j) / Datu(I,j) + endif + else ! This is assuming Flather as only other option + if (GV%Boussinesq) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + BT_OBC%dZ_u(I,j) = CS%bathyT(i,j) + GV%H_to_Z*eta(i,j) + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + BT_OBC%dZ_u(I,j) = CS%bathyT(i+1,j) + GV%H_to_Z*eta(i+1,j) + endif + else + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + BT_OBC%dZ_u(I,j) = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + BT_OBC%dZ_u(I,j) = GV%H_to_RZ * eta(i+1,j) * SpV_avg(i+1,j) + endif + endif + BT_OBC%Cg_u(I,j) = SQRT(dgeo_de_in * GV%g_prime(1) * BT_OBC%dZ_u(i,j)) + endif + endif ; enddo ; enddo + if (OBC%Flather_u_BCs_exist_globally) then + do n = 1, OBC%number_of_segments + segment => OBC%segment(n) + if (segment%is_E_or_W .and. segment%Flather) then + do j=segment%HI%jsd,segment%HI%jed ; do I=segment%HI%IsdB,segment%HI%IedB + BT_OBC%ubt_outer(I,j) = segment%normal_vel_bt(I,j) + BT_OBC%SSH_outer_u(I,j) = segment%SSH(I,j) + G%Z_ref + enddo ; enddo + endif + enddo + endif + endif + + if (BT_OBC%apply_v_OBCs) then + if (OBC%specified_v_BCs_exist_globally) then + do n = 1, OBC%number_of_segments + segment => OBC%segment(n) + if (segment%is_N_or_S .and. segment%specified) then + do J=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied + BT_OBC%vhbt(i,J) = 0. + enddo ; enddo + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied + BT_OBC%vhbt(i,J) = BT_OBC%vhbt(i,J) + segment%normal_trans(i,J,k) + enddo ; enddo ; enddo + endif + enddo + endif + do J=js-1,je ; do i=is,ie ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + ! Can this go in segment loop above? Is loop above wrong for wide halos?? + if (OBC%segment(OBC%segnum_v(i,J))%specified) then + if (integral_BT_cont) then + BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J)*dt_baroclinic, BTCL_v(i,J)) * I_dt + elseif (use_BT_cont) then + BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J), BTCL_v(i,J)) + else + if (Datv(i,J) > 0.0) BT_OBC%vbt_outer(i,J) = BT_OBC%vhbt(i,J) / Datv(i,J) + endif + else ! This is assuming Flather as only other option + if (GV%Boussinesq) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + BT_OBC%dZ_v(i,J) = CS%bathyT(i,j) + GV%H_to_Z*eta(i,j) + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + BT_OBC%dZ_v(i,J) = CS%bathyT(i,j+1) + GV%H_to_Z*eta(i,j+1) + endif + else + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + BT_OBC%dZ_v(i,J) = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + BT_OBC%dZ_v(i,J) = GV%H_to_RZ * eta(i,j+1) * SpV_avg(i,j+1) + endif + endif + BT_OBC%Cg_v(i,J) = SQRT(dgeo_de_in * GV%g_prime(1) * BT_OBC%dZ_v(i,J)) + endif + endif ; enddo ; enddo + if (OBC%Flather_v_BCs_exist_globally) then + do n = 1, OBC%number_of_segments + segment => OBC%segment(n) + if (segment%is_N_or_S .and. segment%Flather) then + do J=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied + BT_OBC%vbt_outer(i,J) = segment%normal_vel_bt(i,J) + BT_OBC%SSH_outer_v(i,J) = segment%SSH(i,J) + G%Z_ref + enddo ; enddo + endif + enddo + endif + endif + + call do_group_pass(BT_OBC%pass_uv, BT_Domain) + call do_group_pass(BT_OBC%pass_uhvh, BT_Domain) + call do_group_pass(BT_OBC%pass_eta_outer, BT_Domain) + call do_group_pass(BT_OBC%pass_h, BT_Domain) + call do_group_pass(BT_OBC%pass_cg, BT_Domain) + +end subroutine set_up_BT_OBC + +!> Clean up the BT_OBC memory. +subroutine destroy_BT_OBC(BT_OBC) + type(BT_OBC_type), intent(inout) :: BT_OBC !< A structure with the private barotropic arrays + !! related to the open boundary conditions, + !! set by set_up_BT_OBC. + + if (BT_OBC%is_alloced) then + deallocate(BT_OBC%Cg_u) + deallocate(BT_OBC%dZ_u) + deallocate(BT_OBC%uhbt) + deallocate(BT_OBC%ubt_outer) + deallocate(BT_OBC%SSH_outer_u) + + deallocate(BT_OBC%Cg_v) + deallocate(BT_OBC%dZ_v) + deallocate(BT_OBC%vhbt) + deallocate(BT_OBC%vbt_outer) + deallocate(BT_OBC%SSH_outer_v) + BT_OBC%is_alloced = .false. + endif +end subroutine destroy_BT_OBC + +!> btcalc calculates the barotropic velocities from the full velocity and +!! thickness fields, determines the fraction of the total water column in each +!! layer at velocity points, and determines a corrective fictitious mass source +!! that will drive the barotropic estimate of the free surface height toward the +!! baroclinic estimate. +subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: h_u !< The specified effective thicknesses at u-points, + !! perhaps scaled down to account for viscosity and + !! fractional open areas [H ~> m or kg m-2]. These + !! are used here as non-normalized weights for each + !! layer that are converted the normalized weights + !! for determining the barotropic accelerations. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(in) :: h_v !< The specified effective thicknesses at v-points, + !! perhaps scaled down to account for viscosity and + !! fractional open areas [H ~> m or kg m-2]. These + !! are used here as non-normalized weights for each + !! layer that are converted the normalized weights + !! for determining the barotropic accelerations. + logical, optional, intent(in) :: may_use_default !< An optional logical argument + !! to indicate that the default velocity point + !! thicknesses may be used for this particular + !! calculation, even though the setting of + !! CS%hvel_scheme would usually require that h_u + !! and h_v be passed in. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundary control structure. + + ! Local variables + real :: hatutot(SZIB_(G)) ! The sum of the layer thicknesses interpolated to u points [H ~> m or kg m-2]. + real :: hatvtot(SZI_(G)) ! The sum of the layer thicknesses interpolated to v points [H ~> m or kg m-2]. + real :: Ihatutot(SZIB_(G)) ! Ihatutot is the inverse of hatutot [H-1 ~> m-1 or m2 kg-1]. + real :: Ihatvtot(SZI_(G)) ! Ihatvtot is the inverse of hatvtot [H-1 ~> m-1 or m2 kg-1]. + real :: h_arith ! The arithmetic mean thickness [H ~> m or kg m-2]. + real :: h_harm ! The harmonic mean thicknesses [H ~> m or kg m-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: wt_arith ! The weight for the arithmetic mean thickness [nondim]. + ! The harmonic mean uses a weight of (1 - wt_arith). + real :: e_u(SZIB_(G),SZK_(GV)+1) ! The interface heights at u-velocity points [H ~> m or kg m-2] + real :: e_v(SZI_(G),SZK_(GV)+1) ! The interface heights at v-velocity points [H ~> m or kg m-2] + real :: D_shallow_u(SZI_(G)) ! The height of the shallower of the adjacent bathymetric depths + ! around a u-point (positive upward) [H ~> m or kg m-2] + real :: D_shallow_v(SZIB_(G))! The height of the shallower of the adjacent bathymetric depths + ! around a v-point (positive upward) [H ~> m or kg m-2] + real :: Z_to_H ! A local conversion factor [H Z-1 ~> nondim or kg m-3] + real :: htot ! The sum of the layer thicknesses [H ~> m or kg m-2]. + real :: Ihtot ! The inverse of htot [H-1 ~> m-1 or m2 kg-1]. + + logical :: use_default, test_dflt, apply_OBCs + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, i, j, k + integer :: iss, ies, n + +! This section interpolates thicknesses onto u & v grid points with the +! second order accurate estimate h = 2*(h+ * h-)/(h+ + h-). + if (.not.CS%module_is_initialized) call MOM_error(FATAL, & + "btcalc: Module MOM_barotropic must be initialized before it is used.") + + if (.not.CS%split) return + + use_default = .false. + test_dflt = .false. ; if (present(may_use_default)) test_dflt = may_use_default + + if (test_dflt) then + if (.not.((present(h_u) .and. present(h_v)) .or. & + (CS%hvel_scheme == HARMONIC) .or. (CS%hvel_scheme == HYBRID) .or.& + (CS%hvel_scheme == ARITHMETIC))) use_default = .true. + else + if (.not.((present(h_u) .and. present(h_v)) .or. & + (CS%hvel_scheme == HARMONIC) .or. (CS%hvel_scheme == HYBRID) .or.& + (CS%hvel_scheme == ARITHMETIC))) call MOM_error(FATAL, & + "btcalc: Inconsistent settings of optional arguments and hvel_scheme.") + endif + + apply_OBCs = .false. + if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then + ! Some open boundary condition points might be in this processor's symmetric + ! computational domain. + apply_OBCs = (OBC%number_of_segments > 0) + endif ; endif ; endif + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + h_neglect = GV%H_subroundoff + + ! This estimates the fractional thickness of each layer at the velocity + ! points, using a harmonic mean estimate. + + !$OMP parallel do default(none) shared(is,ie,js,je,nz,h_u,CS,h_neglect,h,use_default,G,GV) & + !$OMP private(hatutot,Ihatutot,e_u,D_shallow_u,h_arith,h_harm,wt_arith,Z_to_H) + do j=js,je + if (present(h_u)) then + do I=is-1,ie ; hatutot(I) = h_u(I,j,1) ; enddo + do k=2,nz ; do I=is-1,ie + hatutot(I) = hatutot(I) + h_u(I,j,k) + enddo ; enddo + do I=is-1,ie ; Ihatutot(I) = G%mask2dCu(I,j) / (hatutot(I) + h_neglect) ; enddo + do k=1,nz ; do I=is-1,ie + CS%frhatu(I,j,k) = h_u(I,j,k) * Ihatutot(I) + enddo ; enddo + else + if (CS%hvel_scheme == ARITHMETIC) then + do I=is-1,ie + CS%frhatu(I,j,1) = 0.5 * (h(i+1,j,1) + h(i,j,1)) + hatutot(I) = CS%frhatu(I,j,1) + enddo + do k=2,nz ; do I=is-1,ie + CS%frhatu(I,j,k) = 0.5 * (h(i+1,j,k) + h(i,j,k)) + hatutot(I) = hatutot(I) + CS%frhatu(I,j,k) + enddo ; enddo + elseif (CS%hvel_scheme == HYBRID .or. use_default) then + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + do I=is-1,ie + e_u(I,nz+1) = -0.5 * Z_to_H * (G%bathyT(i+1,j) + G%bathyT(i,j)) + D_shallow_u(I) = -Z_to_H * min(G%bathyT(i+1,j), G%bathyT(i,j)) + hatutot(I) = 0.0 + enddo + do k=nz,1,-1 ; do I=is-1,ie + e_u(I,K) = e_u(I,K+1) + 0.5 * (h(i+1,j,k) + h(i,j,k)) + h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k)) + if (e_u(I,K+1) >= D_shallow_u(I)) then + CS%frhatu(I,j,k) = h_arith + else + h_harm = (h(i+1,j,k) * h(i,j,k)) / (h_arith + h_neglect) + if (e_u(I,K) <= D_shallow_u(I)) then + CS%frhatu(I,j,k) = h_harm + else + wt_arith = (e_u(I,K) - D_shallow_u(I)) / (h_arith + h_neglect) + CS%frhatu(I,j,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm + endif + endif + hatutot(I) = hatutot(I) + CS%frhatu(I,j,k) + enddo ; enddo + elseif (CS%hvel_scheme == HARMONIC) then + do I=is-1,ie + CS%frhatu(I,j,1) = 2.0*(h(i+1,j,1) * h(i,j,1)) / & + ((h(i+1,j,1) + h(i,j,1)) + h_neglect) + hatutot(I) = CS%frhatu(I,j,1) + enddo + do k=2,nz ; do I=is-1,ie + CS%frhatu(I,j,k) = 2.0*(h(i+1,j,k) * h(i,j,k)) / & + ((h(i+1,j,k) + h(i,j,k)) + h_neglect) + hatutot(I) = hatutot(I) + CS%frhatu(I,j,k) + enddo ; enddo + endif + do I=is-1,ie ; Ihatutot(I) = G%mask2dCu(I,j) / (hatutot(I) + h_neglect) ; enddo + do k=1,nz ; do I=is-1,ie + CS%frhatu(I,j,k) = CS%frhatu(I,j,k) * Ihatutot(I) + enddo ; enddo + endif + enddo + + !$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,G,GV,h_v,h_neglect,h,use_default) & + !$OMP private(hatvtot,Ihatvtot,e_v,D_shallow_v,h_arith,h_harm,wt_arith,Z_to_H) + do J=js-1,je + if (present(h_v)) then + do i=is,ie ; hatvtot(i) = h_v(i,J,1) ; enddo + do k=2,nz ; do i=is,ie + hatvtot(i) = hatvtot(i) + h_v(i,J,k) + enddo ; enddo + do i=is,ie ; Ihatvtot(i) = G%mask2dCv(i,J) / (hatvtot(i) + h_neglect) ; enddo + do k=1,nz ; do i=is,ie + CS%frhatv(i,J,k) = h_v(i,J,k) * Ihatvtot(i) + enddo ; enddo + else + if (CS%hvel_scheme == ARITHMETIC) then + do i=is,ie + CS%frhatv(i,J,1) = 0.5 * (h(i,j+1,1) + h(i,j,1)) + hatvtot(i) = CS%frhatv(i,J,1) + enddo + do k=2,nz ; do i=is,ie + CS%frhatv(i,J,k) = 0.5 * (h(i,j+1,k) + h(i,j,k)) + hatvtot(i) = hatvtot(i) + CS%frhatv(i,J,k) + enddo ; enddo + elseif (CS%hvel_scheme == HYBRID .or. use_default) then + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + do i=is,ie + e_v(i,nz+1) = -0.5 * Z_to_H * (G%bathyT(i,j+1) + G%bathyT(i,j)) + D_shallow_v(I) = -Z_to_H * min(G%bathyT(i,j+1), G%bathyT(i,j)) + hatvtot(I) = 0.0 + enddo + do k=nz,1,-1 ; do i=is,ie + e_v(i,K) = e_v(i,K+1) + 0.5 * (h(i,j+1,k) + h(i,j,k)) + h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k)) + if (e_v(i,K+1) >= D_shallow_v(i)) then + CS%frhatv(i,J,k) = h_arith + else + h_harm = (h(i,j+1,k) * h(i,j,k)) / (h_arith + h_neglect) + if (e_v(i,K) <= D_shallow_v(i)) then + CS%frhatv(i,J,k) = h_harm + else + wt_arith = (e_v(i,K) - D_shallow_v(i)) / (h_arith + h_neglect) + CS%frhatv(i,J,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm + endif + endif + hatvtot(i) = hatvtot(i) + CS%frhatv(i,J,k) + enddo ; enddo + elseif (CS%hvel_scheme == HARMONIC) then + do i=is,ie + CS%frhatv(i,J,1) = 2.0*(h(i,j+1,1) * h(i,j,1)) / & + ((h(i,j+1,1) + h(i,j,1)) + h_neglect) + hatvtot(i) = CS%frhatv(i,J,1) + enddo + do k=2,nz ; do i=is,ie + CS%frhatv(i,J,k) = 2.0*(h(i,j+1,k) * h(i,j,k)) / & + ((h(i,j+1,k) + h(i,j,k)) + h_neglect) + hatvtot(i) = hatvtot(i) + CS%frhatv(i,J,k) + enddo ; enddo + endif + do i=is,ie ; Ihatvtot(i) = G%mask2dCv(i,J) / (hatvtot(i) + h_neglect) ; enddo + do k=1,nz ; do i=is,ie + CS%frhatv(i,J,k) = CS%frhatv(i,J,k) * Ihatvtot(i) + enddo ; enddo + endif + enddo + + if (apply_OBCs) then ; do n=1,OBC%number_of_segments ! Test for segment type? + if (.not. OBC%segment(n)%on_pe) cycle + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + J = OBC%segment(n)%HI%JsdB + if ((J >= js-1) .and. (J <= je)) then + iss = max(is,OBC%segment(n)%HI%isd) ; ies = min(ie,OBC%segment(n)%HI%ied) + do i=iss,ies ; hatvtot(i) = h(i,j,1) ; enddo + do k=2,nz ; do i=iss,ies + hatvtot(i) = hatvtot(i) + h(i,j,k) + enddo ; enddo + do i=iss,ies + Ihatvtot(i) = G%mask2dCv(i,J) / (hatvtot(i) + h_neglect) + enddo + do k=1,nz ; do i=iss,ies + CS%frhatv(i,J,k) = h(i,j,k) * Ihatvtot(i) + enddo ; enddo + endif + elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then + J = OBC%segment(n)%HI%JsdB + if ((J >= js-1) .and. (J <= je)) then + iss = max(is,OBC%segment(n)%HI%isd) ; ies = min(ie,OBC%segment(n)%HI%ied) + do i=iss,ies ; hatvtot(i) = h(i,j+1,1) ; enddo + do k=2,nz ; do i=iss,ies + hatvtot(i) = hatvtot(i) + h(i,j+1,k) + enddo ; enddo + do i=iss,ies + Ihatvtot(i) = G%mask2dCv(i,J) / (hatvtot(i) + h_neglect) + enddo + do k=1,nz ; do i=iss,ies + CS%frhatv(i,J,k) = h(i,j+1,k) * Ihatvtot(i) + enddo ; enddo + endif + elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then + I = OBC%segment(n)%HI%IsdB + if ((I >= is-1) .and. (I <= ie)) then + do j = max(js,OBC%segment(n)%HI%jsd), min(je,OBC%segment(n)%HI%jed) + htot = h(i,j,1) + do k=2,nz ; htot = htot + h(i,j,k) ; enddo + Ihtot = G%mask2dCu(I,j) / (htot + h_neglect) + do k=1,nz ; CS%frhatu(I,j,k) = h(i,j,k) * Ihtot ; enddo + enddo + endif + elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then + I = OBC%segment(n)%HI%IsdB + if ((I >= is-1) .and. (I <= ie)) then + do j = max(js,OBC%segment(n)%HI%jsd), min(je,OBC%segment(n)%HI%jed) + htot = h(i+1,j,1) + do k=2,nz ; htot = htot + h(i+1,j,k) ; enddo + Ihtot = G%mask2dCu(I,j) / (htot + h_neglect) + do k=1,nz ; CS%frhatu(I,j,k) = h(i+1,j,k) * Ihtot ; enddo + enddo + endif + else + call MOM_error(fatal, "btcalc encountered and OBC segment of indeterminate direction.") + endif + enddo ; endif + + if (CS%debug) then + call uvchksum("btcalc frhat[uv]", CS%frhatu, CS%frhatv, G%HI, & + haloshift=0, symmetric=.true., omit_corners=.true., & + scalar_pair=.true.) + if (present(h_u) .and. present(h_v)) & + call uvchksum("btcalc h_[uv]", h_u, h_v, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scale=GV%H_to_MKS, & + scalar_pair=.true.) + call hchksum(h, "btcalc h",G%HI, haloshift=1, scale=GV%H_to_MKS) + endif + +end subroutine btcalc + +!> The function find_uhbt determines the zonal transport for a given velocity, or with +!! INTEGRAL_BT_CONT=True it determines the time-integrated zonal transport for a given +!! time-integrated velocity. +function find_uhbt(u, BTC) result(uhbt) + real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] + type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that + !! allow the barotropic transports to be calculated consistently + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + + real :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3] + + if (u == 0.0) then + uhbt = 0.0 + elseif (u < BTC%uBT_EE) then + uhbt = (u - BTC%uBT_EE) * BTC%FA_u_EE + BTC%uh_EE + elseif (u < 0.0) then + uhbt = u * (BTC%FA_u_E0 + BTC%uh_crvE * u**2) + elseif (u <= BTC%uBT_WW) then + uhbt = u * (BTC%FA_u_W0 + BTC%uh_crvW * u**2) + else ! (u > BTC%uBT_WW) + uhbt = (u - BTC%uBT_WW) * BTC%FA_u_WW + BTC%uh_WW + endif + +end function find_uhbt + +!> The function find_duhbt_du determines the marginal zonal face area for a given velocity, or +!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity. +function find_duhbt_du(u, BTC) result(duhbt_du) + real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] + type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that + !! allow the barotropic transports to be calculated consistently + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real :: duhbt_du !< The zonal barotropic face area [L H ~> m2 or kg m-1] + + if (u == 0.0) then + duhbt_du = 0.5*(BTC%FA_u_E0 + BTC%FA_u_W0) ! Note the potential discontinuity here. + elseif (u < BTC%uBT_EE) then + duhbt_du = BTC%FA_u_EE + elseif (u < 0.0) then + duhbt_du = (BTC%FA_u_E0 + 3.0*BTC%uh_crvE * u**2) + elseif (u <= BTC%uBT_WW) then + duhbt_du = (BTC%FA_u_W0 + 3.0*BTC%uh_crvW * u**2) + else ! (u > BTC%uBT_WW) + duhbt_du = BTC%FA_u_WW + endif + +end function find_duhbt_du + +!> This function inverts the transport function to determine the barotopic +!! velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True +!! this finds the time-integrated velocity that is consistent with a time-integrated transport. +function uhbt_to_ubt(uhbt, BTC) result(ubt) + real, intent(in) :: uhbt !< The barotropic zonal transport that should be inverted for, + !! [H L2 T-1 ~> m3 s-1 or kg s-1] or the time-integrated + !! transport [H L2 ~> m3 or kg]. + type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that allow the + !! barotropic transports to be calculated consistently with the + !! layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real :: ubt !< The result - The velocity that gives uhbt transport [L T-1 ~> m s-1] + !! or the time-integrated velocity [L ~> m]. + + ! Local variables + real :: ubt_min, ubt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m] + real :: uhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg]. + real :: derr_du ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1]. + real :: uherr_min, uherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] + ! or [H L2 ~> m3 or kg]. + real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] + real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting + real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the + ! maximum increase of vs2, both [nondim]. + integer :: itt, max_itt = 20 + + ! Find the value of ubt that gives uhbt. + if (uhbt == 0.0) then + ubt = 0.0 + elseif (uhbt < BTC%uh_EE) then + ubt = BTC%uBT_EE + (uhbt - BTC%uh_EE) / BTC%FA_u_EE + elseif (uhbt < 0.0) then + ! Iterate to convergence with Newton's method (when bounded) and the + ! false position method otherwise. ubt will be negative. + ubt_min = BTC%uBT_EE ; uherr_min = BTC%uh_EE - uhbt + ubt_max = 0.0 ; uherr_max = -uhbt + ! Use a false-position method first guess. + ubt = BTC%uBT_EE * (uhbt / BTC%uh_EE) + do itt = 1, max_itt + uhbt_err = ubt * (BTC%FA_u_E0 + BTC%uh_crvE * ubt**2) - uhbt + + if (abs(uhbt_err) < tol*abs(uhbt)) exit + if (uhbt_err > 0.0) then ; ubt_max = ubt ; uherr_max = uhbt_err ; endif + if (uhbt_err < 0.0) then ; ubt_min = ubt ; uherr_min = uhbt_err ; endif + + derr_du = BTC%FA_u_E0 + 3.0 * BTC%uh_crvE * ubt**2 + if ((uhbt_err >= derr_du*(ubt - ubt_min)) .or. & + (-uhbt_err >= derr_du*(ubt_max - ubt)) .or. (derr_du <= 0.0)) then + ! Use a false-position method guess. + ubt = ubt_max + (ubt_min-ubt_max) * (uherr_max / (uherr_max-uherr_min)) + else ! Use Newton's method. + ubt = ubt - uhbt_err / derr_du + if (abs(uhbt_err) < (0.01*tol)*abs(ubt_min*derr_du)) exit + endif + enddo + elseif (uhbt <= BTC%uh_WW) then + ! Iterate to convergence with Newton's method. ubt will be positive. + ubt_min = 0.0 ; uherr_min = -uhbt + ubt_max = BTC%uBT_WW ; uherr_max = BTC%uh_WW - uhbt + ! Use a false-position method first guess. + ubt = BTC%uBT_WW * (uhbt / BTC%uh_WW) + do itt = 1, max_itt + uhbt_err = ubt * (BTC%FA_u_W0 + BTC%uh_crvW * ubt**2) - uhbt + + if (abs(uhbt_err) < tol*abs(uhbt)) exit + if (uhbt_err > 0.0) then ; ubt_max = ubt ; uherr_max = uhbt_err ; endif + if (uhbt_err < 0.0) then ; ubt_min = ubt ; uherr_min = uhbt_err ; endif + + derr_du = BTC%FA_u_W0 + 3.0 * BTC%uh_crvW * ubt**2 + if ((uhbt_err >= derr_du*(ubt - ubt_min)) .or. & + (-uhbt_err >= derr_du*(ubt_max - ubt)) .or. (derr_du <= 0.0)) then + ! Use a false-position method guess. + ubt = ubt_min + (ubt_max-ubt_min) * (-uherr_min / (uherr_max-uherr_min)) + else ! Use Newton's method. + ubt = ubt - uhbt_err / derr_du + if (abs(uhbt_err) < (0.01*tol)*(ubt_max*derr_du)) exit + endif + enddo + else ! (uhbt > BTC%uh_WW) + ubt = BTC%uBT_WW + (uhbt - BTC%uh_WW) / BTC%FA_u_WW + endif + +end function uhbt_to_ubt + +!> The function find_vhbt determines the meridional transport for a given velocity, or with +!! INTEGRAL_BT_CONT=True it determines the time-integrated meridional transport for a given +!! time-integrated velocity. +function find_vhbt(v, BTC) result(vhbt) + real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] + type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that + !! allow the barotropic transports to be calculated consistently + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real :: vhbt !< The meridional barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3] + + if (v == 0.0) then + vhbt = 0.0 + elseif (v < BTC%vBT_NN) then + vhbt = (v - BTC%vBT_NN) * BTC%FA_v_NN + BTC%vh_NN + elseif (v < 0.0) then + vhbt = v * (BTC%FA_v_N0 + BTC%vh_crvN * v**2) + elseif (v <= BTC%vBT_SS) then + vhbt = v * (BTC%FA_v_S0 + BTC%vh_crvS * v**2) + else ! (v > BTC%vBT_SS) + vhbt = (v - BTC%vBT_SS) * BTC%FA_v_SS + BTC%vh_SS + endif + +end function find_vhbt + +!> The function find_dvhbt_dv determines the marginal meridional face area for a given velocity, or +!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity. +function find_dvhbt_dv(v, BTC) result(dvhbt_dv) + real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] + type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that + !! allow the barotropic transports to be calculated consistently + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real :: dvhbt_dv !< The meridional barotropic face area [L H ~> m2 or kg m-1] + + if (v == 0.0) then + dvhbt_dv = 0.5*(BTC%FA_v_N0 + BTC%FA_v_S0) ! Note the potential discontinuity here. + elseif (v < BTC%vBT_NN) then + dvhbt_dv = BTC%FA_v_NN + elseif (v < 0.0) then + dvhbt_dv = BTC%FA_v_N0 + 3.0*BTC%vh_crvN * v**2 + elseif (v <= BTC%vBT_SS) then + dvhbt_dv = BTC%FA_v_S0 + 3.0*BTC%vh_crvS * v**2 + else ! (v > BTC%vBT_SS) + dvhbt_dv = BTC%FA_v_SS + endif + +end function find_dvhbt_dv + +!> This function inverts the transport function to determine the barotopic +!! velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True +!! this finds the time-integrated velocity that is consistent with a time-integrated transport. +function vhbt_to_vbt(vhbt, BTC) result(vbt) + real, intent(in) :: vhbt !< The barotropic meridional transport that should be + !! inverted for [H L2 T-1 ~> m3 s-1 or kg s-1] or the + !! time-integrated transport [H L2 ~> m3 or kg]. + type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that allow the + !! barotropic transports to be calculated consistently + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real :: vbt !< The result - The velocity that gives vhbt transport [L T-1 ~> m s-1] + !! or the time-integrated velocity [L ~> m]. + + ! Local variables + real :: vbt_min, vbt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m] + real :: vhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg]. + real :: derr_dv ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1]. + real :: vherr_min, vherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] + ! or [H L2 ~> m3 or kg]. + real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] + real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting + real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the + ! maximum increase of vs2, both [nondim]. + integer :: itt, max_itt = 20 + + ! Find the value of vbt that gives vhbt. + if (vhbt == 0.0) then + vbt = 0.0 + elseif (vhbt < BTC%vh_NN) then + vbt = BTC%vBT_NN + (vhbt - BTC%vh_NN) / BTC%FA_v_NN + elseif (vhbt < 0.0) then + ! Iterate to convergence with Newton's method (when bounded) and the + ! false position method otherwise. vbt will be negative. + vbt_min = BTC%vBT_NN ; vherr_min = BTC%vh_NN - vhbt + vbt_max = 0.0 ; vherr_max = -vhbt + ! Use a false-position method first guess. + vbt = BTC%vBT_NN * (vhbt / BTC%vh_NN) + do itt = 1, max_itt + vhbt_err = vbt * (BTC%FA_v_N0 + BTC%vh_crvN * vbt**2) - vhbt + + if (abs(vhbt_err) < tol*abs(vhbt)) exit + if (vhbt_err > 0.0) then ; vbt_max = vbt ; vherr_max = vhbt_err ; endif + if (vhbt_err < 0.0) then ; vbt_min = vbt ; vherr_min = vhbt_err ; endif + + derr_dv = BTC%FA_v_N0 + 3.0 * BTC%vh_crvN * vbt**2 + if ((vhbt_err >= derr_dv*(vbt - vbt_min)) .or. & + (-vhbt_err >= derr_dv*(vbt_max - vbt)) .or. (derr_dv <= 0.0)) then + ! Use a false-position method guess. + vbt = vbt_max + (vbt_min-vbt_max) * (vherr_max / (vherr_max-vherr_min)) + else ! Use Newton's method. + vbt = vbt - vhbt_err / derr_dv + if (abs(vhbt_err) < (0.01*tol)*abs(derr_dv*vbt_min)) exit + endif + enddo + elseif (vhbt <= BTC%vh_SS) then + ! Iterate to convergence with Newton's method. vbt will be positive. + vbt_min = 0.0 ; vherr_min = -vhbt + vbt_max = BTC%vBT_SS ; vherr_max = BTC%vh_SS - vhbt + ! Use a false-position method first guess. + vbt = BTC%vBT_SS * (vhbt / BTC%vh_SS) + do itt = 1, max_itt + vhbt_err = vbt * (BTC%FA_v_S0 + BTC%vh_crvS * vbt**2) - vhbt + + if (abs(vhbt_err) < tol*abs(vhbt)) exit + if (vhbt_err > 0.0) then ; vbt_max = vbt ; vherr_max = vhbt_err ; endif + if (vhbt_err < 0.0) then ; vbt_min = vbt ; vherr_min = vhbt_err ; endif + + derr_dv = BTC%FA_v_S0 + 3.0 * BTC%vh_crvS * vbt**2 + if ((vhbt_err >= derr_dv*(vbt - vbt_min)) .or. & + (-vhbt_err >= derr_dv*(vbt_max - vbt)) .or. (derr_dv <= 0.0)) then + ! Use a false-position method guess. + vbt = vbt_min + (vbt_max-vbt_min) * (-vherr_min / (vherr_max-vherr_min)) + else ! Use Newton's method. + vbt = vbt - vhbt_err / derr_dv + if (abs(vhbt_err) < (0.01*tol)*(vbt_max*derr_dv)) exit + endif + enddo + else ! (vhbt > BTC%vh_SS) + vbt = BTC%vBT_SS + (vhbt - BTC%vh_SS) / BTC%FA_v_SS + endif + +end function vhbt_to_vbt + +!> This subroutine sets up reordered versions of the BT_cont type in the +!! local_BT_cont types, which have wide halos properly filled in. +subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain, halo, dt_baroclinic) + type(BT_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the barotropic solver + type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of + !! the argument arrays + type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), & + intent(out) :: BTCL_u !< A structure with the u information from BT_cont + type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), & + intent(out) :: BTCL_v !< A structure with the v information from BT_cont + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MOM_domain_type), intent(inout) :: BT_Domain !< The domain to use for updating the halos + !! of wide arrays + integer, intent(in) :: halo !< The extra halo size to use here + real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step [T ~> s], which + !! is provided if INTEGRAL_BT_CONTINUITY is true. + + ! Local variables + real, dimension(SZIBW_(MS),SZJW_(MS)) :: & + u_polarity, & ! An array used to test for halo update polarity [nondim] + uBT_EE, uBT_WW, & ! Zonal velocities at which the form of the fit changes [L T-1 ~> m s-1] + FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW ! Zonal face areas [H L ~> m2 or kg m-1] + real, dimension(SZIW_(MS),SZJBW_(MS)) :: & + v_polarity, & ! An array used to test for halo update polarity [nondim] + vBT_NN, vBT_SS, & ! Meridional velocities at which the form of the fit changes [L T-1 ~> m s-1] + FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS ! Meridional face areas [H L ~> m2 or kg m-1] + real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] + real, parameter :: C1_3 = 1.0/3.0 ! [nondim] + integer :: i, j, is, ie, js, je, hs + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + hs = max(halo,0) + dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic + + ! Copy the BT_cont arrays into symmetric, potentially wide haloed arrays. +!$OMP parallel default(none) shared(is,ie,js,je,hs,u_polarity,uBT_EE,uBT_WW,FA_u_EE, & +!$OMP FA_u_E0,FA_u_W0,FA_u_WW,v_polarity,vBT_NN,vBT_SS,& +!$OMP FA_v_NN,FA_v_N0,FA_v_S0,FA_v_SS,BT_cont ) +!$OMP do + do j=js-hs,je+hs ; do i=is-hs-1,ie+hs + u_polarity(i,j) = 1.0 + uBT_EE(i,j) = 0.0 ; uBT_WW(i,j) = 0.0 + FA_u_EE(i,j) = 0.0 ; FA_u_E0(i,j) = 0.0 ; FA_u_W0(i,j) = 0.0 ; FA_u_WW(i,j) = 0.0 + enddo ; enddo +!$OMP do + do j=js-hs-1,je+hs ; do i=is-hs,ie+hs + v_polarity(i,j) = 1.0 + vBT_NN(i,j) = 0.0 ; vBT_SS(i,j) = 0.0 + FA_v_NN(i,j) = 0.0 ; FA_v_N0(i,j) = 0.0 ; FA_v_S0(i,j) = 0.0 ; FA_v_SS(i,j) = 0.0 + enddo ; enddo +!$OMP do + do j=js,je ; do I=is-1,ie + uBT_EE(I,j) = BT_cont%uBT_EE(I,j) ; uBT_WW(I,j) = BT_cont%uBT_WW(I,j) + FA_u_EE(I,j) = BT_cont%FA_u_EE(I,j) ; FA_u_E0(I,j) = BT_cont%FA_u_E0(I,j) + FA_u_W0(I,j) = BT_cont%FA_u_W0(I,j) ; FA_u_WW(I,j) = BT_cont%FA_u_WW(I,j) + enddo ; enddo +!$OMP do + do J=js-1,je ; do i=is,ie + vBT_NN(i,J) = BT_cont%vBT_NN(i,J) ; vBT_SS(i,J) = BT_cont%vBT_SS(i,J) + FA_v_NN(i,J) = BT_cont%FA_v_NN(i,J) ; FA_v_N0(i,J) = BT_cont%FA_v_N0(i,J) + FA_v_S0(i,J) = BT_cont%FA_v_S0(i,J) ; FA_v_SS(i,J) = BT_cont%FA_v_SS(i,J) + enddo ; enddo +!$OMP end parallel + + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) +!--- begin setup for group halo update + call create_group_pass(BT_cont%pass_polarity_BT, u_polarity, v_polarity, BT_Domain) + call create_group_pass(BT_cont%pass_polarity_BT, uBT_EE, vBT_NN, BT_Domain) + call create_group_pass(BT_cont%pass_polarity_BT, uBT_WW, vBT_SS, BT_Domain) + + call create_group_pass(BT_cont%pass_FA_uv, FA_u_EE, FA_v_NN, BT_Domain, To_All+Scalar_Pair) + call create_group_pass(BT_cont%pass_FA_uv, FA_u_E0, FA_v_N0, BT_Domain, To_All+Scalar_Pair) + call create_group_pass(BT_cont%pass_FA_uv, FA_u_W0, FA_v_S0, BT_Domain, To_All+Scalar_Pair) + call create_group_pass(BT_cont%pass_FA_uv, FA_u_WW, FA_v_SS, BT_Domain, To_All+Scalar_Pair) +!--- end setup for group halo update + ! Do halo updates on BT_cont. + call do_group_pass(BT_cont%pass_polarity_BT, BT_Domain) + call do_group_pass(BT_cont%pass_FA_uv, BT_Domain) + if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + + !$OMP parallel default(shared) + !$OMP do + do j=js-hs,je+hs ; do I=is-hs-1,ie+hs + BTCL_u(I,j)%FA_u_EE = FA_u_EE(I,j) ; BTCL_u(I,j)%FA_u_E0 = FA_u_E0(I,j) + BTCL_u(I,j)%FA_u_W0 = FA_u_W0(I,j) ; BTCL_u(I,j)%FA_u_WW = FA_u_WW(I,j) + BTCL_u(I,j)%uBT_EE = dt*uBT_EE(I,j) ; BTCL_u(I,j)%uBT_WW = dt*uBT_WW(I,j) + ! Check for reversed polarity in the tripolar halo regions. + if (u_polarity(I,j) < 0.0) then + call swap(BTCL_u(I,j)%FA_u_EE, BTCL_u(I,j)%FA_u_WW) + call swap(BTCL_u(I,j)%FA_u_E0, BTCL_u(I,j)%FA_u_W0) + call swap(BTCL_u(I,j)%uBT_EE, BTCL_u(I,j)%uBT_WW) + endif + + BTCL_u(I,j)%uh_EE = BTCL_u(I,j)%uBT_EE * & + (C1_3 * (2.0*BTCL_u(I,j)%FA_u_E0 + BTCL_u(I,j)%FA_u_EE)) + BTCL_u(I,j)%uh_WW = BTCL_u(I,j)%uBT_WW * & + (C1_3 * (2.0*BTCL_u(I,j)%FA_u_W0 + BTCL_u(I,j)%FA_u_WW)) + + BTCL_u(I,j)%uh_crvE = 0.0 ; BTCL_u(I,j)%uh_crvW = 0.0 + if (abs(BTCL_u(I,j)%uBT_WW) > 0.0) BTCL_u(I,j)%uh_crvW = & + (C1_3 * (BTCL_u(I,j)%FA_u_WW - BTCL_u(I,j)%FA_u_W0)) / BTCL_u(I,j)%uBT_WW**2 + if (abs(BTCL_u(I,j)%uBT_EE) > 0.0) BTCL_u(I,j)%uh_crvE = & + (C1_3 * (BTCL_u(I,j)%FA_u_EE - BTCL_u(I,j)%FA_u_E0)) / BTCL_u(I,j)%uBT_EE**2 + enddo ; enddo + !$OMP do + do J=js-hs-1,je+hs ; do i=is-hs,ie+hs + BTCL_v(i,J)%FA_v_NN = FA_v_NN(i,J) ; BTCL_v(i,J)%FA_v_N0 = FA_v_N0(i,J) + BTCL_v(i,J)%FA_v_S0 = FA_v_S0(i,J) ; BTCL_v(i,J)%FA_v_SS = FA_v_SS(i,J) + BTCL_v(i,J)%vBT_NN = dt*vBT_NN(i,J) ; BTCL_v(i,J)%vBT_SS = dt*vBT_SS(i,J) + ! Check for reversed polarity in the tripolar halo regions. + if (v_polarity(i,J) < 0.0) then + call swap(BTCL_v(i,J)%FA_v_NN, BTCL_v(i,J)%FA_v_SS) + call swap(BTCL_v(i,J)%FA_v_N0, BTCL_v(i,J)%FA_v_S0) + call swap(BTCL_v(i,J)%vBT_NN, BTCL_v(i,J)%vBT_SS) + endif + + BTCL_v(i,J)%vh_NN = BTCL_v(i,J)%vBT_NN * & + (C1_3 * (2.0*BTCL_v(i,J)%FA_v_N0 + BTCL_v(i,J)%FA_v_NN)) + BTCL_v(i,J)%vh_SS = BTCL_v(i,J)%vBT_SS * & + (C1_3 * (2.0*BTCL_v(i,J)%FA_v_S0 + BTCL_v(i,J)%FA_v_SS)) + + BTCL_v(i,J)%vh_crvN = 0.0 ; BTCL_v(i,J)%vh_crvS = 0.0 + if (abs(BTCL_v(i,J)%vBT_SS) > 0.0) BTCL_v(i,J)%vh_crvS = & + (C1_3 * (BTCL_v(i,J)%FA_v_SS - BTCL_v(i,J)%FA_v_S0)) / BTCL_v(i,J)%vBT_SS**2 + if (abs(BTCL_v(i,J)%vBT_NN) > 0.0) BTCL_v(i,J)%vh_crvN = & + (C1_3 * (BTCL_v(i,J)%FA_v_NN - BTCL_v(i,J)%FA_v_N0)) / BTCL_v(i,J)%vBT_NN**2 + enddo ; enddo + !$OMP end parallel +end subroutine set_local_BT_cont_types + + +!> Adjust_local_BT_cont_types expands the range of velocities with a cubic curve +!! translating velocities into transports to match the initial values of velocities and +!! summed transports when the velocities are larger than the first guesses of the cubic +!! transition velocities used to set up the local_BT_cont types. +subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & + G, US, MS, halo, dt_baroclinic) + type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays. + real, dimension(SZIBW_(MS),SZJW_(MS)), & + intent(in) :: ubt !< The linearization zonal barotropic velocity [L T-1 ~> m s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), & + intent(in) :: uhbt !< The linearization zonal barotropic transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), & + intent(in) :: vbt !< The linearization meridional barotropic velocity [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), & + intent(in) :: vhbt !< The linearization meridional barotropic transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), & + intent(out) :: BTCL_u !< A structure with the u information from BT_cont. + type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), & + intent(out) :: BTCL_v !< A structure with the v information from BT_cont. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: halo !< The extra halo size to use here. + real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step [T ~> s], which is + !! provided if INTEGRAL_BT_CONTINUITY is true. + + ! Local variables + real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] + real, parameter :: C1_3 = 1.0/3.0 ! [nondim] + integer :: i, j, is, ie, js, je, hs + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + hs = max(halo,0) + dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic + + !$OMP parallel do default(shared) + do j=js-hs,je+hs ; do I=is-hs-1,ie+hs + if ((dt*ubt(I,j) > BTCL_u(I,j)%uBT_WW) .and. (dt*uhbt(I,j) > BTCL_u(I,j)%uh_WW)) then + ! Expand the cubic fit to use this new point. ubt is negative. + BTCL_u(I,j)%ubt_WW = dt * ubt(I,j) + if (3.0*uhbt(I,j) < 2.0*ubt(I,j) * BTCL_u(I,j)%FA_u_W0) then + ! No further bounding is needed. + BTCL_u(I,j)%uh_crvW = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_W0) / (dt**2 * ubt(I,j)**3) + else ! This should not happen often! + BTCL_u(I,j)%FA_u_W0 = 1.5*uhbt(I,j) / ubt(I,j) + BTCL_u(I,j)%uh_crvW = -0.5*uhbt(I,j) / (dt**2 * ubt(I,j)**3) + endif + BTCL_u(I,j)%uh_WW = dt * uhbt(I,j) + ! I don't know whether this is helpful. +! BTCL_u(I,j)%FA_u_WW = min(BTCL_u(I,j)%FA_u_WW, uhbt(I,j) / ubt(I,j)) + elseif ((dt*ubt(I,j) < BTCL_u(I,j)%uBT_EE) .and. (dt*uhbt(I,j) < BTCL_u(I,j)%uh_EE)) then + ! Expand the cubic fit to use this new point. ubt is negative. + BTCL_u(I,j)%ubt_EE = dt * ubt(I,j) + if (3.0*uhbt(I,j) < 2.0*ubt(I,j) * BTCL_u(I,j)%FA_u_E0) then + ! No further bounding is needed. + BTCL_u(I,j)%uh_crvE = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_E0) / (dt**2 * ubt(I,j)**3) + else ! This should not happen often! + BTCL_u(I,j)%FA_u_E0 = 1.5*uhbt(I,j) / ubt(I,j) + BTCL_u(I,j)%uh_crvE = -0.5*uhbt(I,j) / (dt**2 * ubt(I,j)**3) + endif + BTCL_u(I,j)%uh_EE = dt * uhbt(I,j) + ! I don't know whether this is helpful. +! BTCL_u(I,j)%FA_u_EE = min(BTCL_u(I,j)%FA_u_EE, uhbt(I,j) / ubt(I,j)) + endif + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-hs-1,je+hs ; do i=is-hs,ie+hs + if ((dt*vbt(i,J) > BTCL_v(i,J)%vBT_SS) .and. (dt*vhbt(i,J) > BTCL_v(i,J)%vh_SS)) then + ! Expand the cubic fit to use this new point. vbt is negative. + BTCL_v(i,J)%vbt_SS = dt * vbt(i,J) + if (3.0*vhbt(i,J) < 2.0*vbt(i,J) * BTCL_v(i,J)%FA_v_S0) then + ! No further bounding is needed. + BTCL_v(i,J)%vh_crvS = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_S0) / (dt**2 * vbt(i,J)**3) + else ! This should not happen often! + BTCL_v(i,J)%FA_v_S0 = 1.5*vhbt(i,J) / (vbt(i,J)) + BTCL_v(i,J)%vh_crvS = -0.5*vhbt(i,J) / (dt**2 * vbt(i,J)**3) + endif + BTCL_v(i,J)%vh_SS = dt * vhbt(i,J) + ! I don't know whether this is helpful. +! BTCL_v(i,J)%FA_v_SS = min(BTCL_v(i,J)%FA_v_SS, vhbt(i,J) / vbt(i,J)) + elseif ((dt*vbt(i,J) < BTCL_v(i,J)%vBT_NN) .and. (dt*vhbt(i,J) < BTCL_v(i,J)%vh_NN)) then + ! Expand the cubic fit to use this new point. vbt is negative. + BTCL_v(i,J)%vbt_NN = dt * vbt(i,J) + if (3.0*vhbt(i,J) < 2.0*vbt(i,J) * BTCL_v(i,J)%FA_v_N0) then + ! No further bounding is needed. + BTCL_v(i,J)%vh_crvN = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_N0) / (dt**2 * vbt(i,J)**3) + else ! This should not happen often! + BTCL_v(i,J)%FA_v_N0 = 1.5*vhbt(i,J) / (vbt(i,J)) + BTCL_v(i,J)%vh_crvN = -0.5*vhbt(i,J) / (dt**2 * vbt(i,J)**3) + endif + BTCL_v(i,J)%vh_NN = dt * vhbt(i,J) + ! I don't know whether this is helpful. +! BTCL_v(i,J)%FA_v_NN = min(BTCL_v(i,J)%FA_v_NN, vhbt(i,J) / vbt(i,J)) + endif + enddo ; enddo + +end subroutine adjust_local_BT_cont_types + +!> This subroutine uses the BT_cont_type to find the maximum face +!! areas, which can then be used for finding wave speeds, etc. +subroutine BT_cont_to_face_areas(BT_cont, Datu, Datv, G, US, MS, halo) + type(BT_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the + !! barotropic solver. + type(memory_size_type), intent(in) :: MS !< A type that describes the memory + !! sizes of the argument arrays. + real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), & + intent(out) :: Datu !< The effective zonal face area [H L ~> m2 or kg m-1]. + real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), & + intent(out) :: Datv !< The effective meridional face area [H L ~> m2 or kg m-1]. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, optional, intent(in) :: halo !< The extra halo size to use here. + + ! Local variables + integer :: i, j, is, ie, js, je, hs + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + hs = 1 ; if (present(halo)) hs = max(halo,0) + + do j=js-hs,je+hs ; do I=is-1-hs,ie+hs + Datu(I,j) = max(BT_cont%FA_u_EE(I,j), BT_cont%FA_u_E0(I,j), & + BT_cont%FA_u_W0(I,j), BT_cont%FA_u_WW(I,j)) + enddo ; enddo + do J=js-1-hs,je+hs ; do i=is-hs,ie+hs + Datv(i,J) = max(BT_cont%FA_v_NN(i,J), BT_cont%FA_v_N0(i,J), & + BT_cont%FA_v_S0(i,J), BT_cont%FA_v_SS(i,J)) + enddo ; enddo + +end subroutine BT_cont_to_face_areas + +!> Swap the values of two real variables +subroutine swap(a,b) + real, intent(inout) :: a !< The first variable to be swapped [arbitrary units] + real, intent(inout) :: b !< The second variable to be swapped [arbitrary units] + real :: tmp ! A temporary variable [arbitrary units] + tmp = a ; a = b ; b = tmp +end subroutine swap + +!> This subroutine determines the open face areas of cells for calculating +!! the barotropic transport. +subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max) + type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays. + real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), & + intent(out) :: Datu !< The open zonal face area [H L ~> m2 or kg m-1]. + real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), & + intent(out) :: Datv !< The open meridional face area [H L ~> m2 or kg m-1]. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(barotropic_CS), intent(in) :: CS !< Barotropic control structure + integer, intent(in) :: halo !< The halo size to use, default = 1. + real, dimension(MS%isdw:MS%iedw,MS%jsdw:MS%jedw), & + optional, intent(in) :: eta !< The barotropic free surface height anomaly + !! or column mass anomaly [H ~> m or kg m-2]. + real, optional, intent(in) :: add_max !< A value to add to the maximum depth (used + !! to overestimate the external wave speed) [Z ~> m]. + + ! Local variables + real :: H1, H2 ! Temporary total thicknesses [H ~> m or kg m-2]. + real :: Z_to_H ! A local conversion factor [H Z-1 ~> nondim or kg m-3] + integer :: i, j, is, ie, js, je, hs + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + hs = max(halo,0) + + !$OMP parallel default(shared) private(H1,H2,Z_to_H) + if (present(eta)) then + ! The use of harmonic mean thicknesses ensure positive definiteness. + if (GV%Boussinesq) then + !$OMP do + do j=js-hs,je+hs ; do I=is-1-hs,ie+hs + H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j) + Datu(I,j) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) & + Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * H1 * H2) / (H1 + H2) +! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2) + enddo ; enddo + !$OMP do + do J=js-1-hs,je+hs ; do i=is-hs,ie+hs + H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1) + Datv(i,J) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) & + Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * H1 * H2) / (H1 + H2) +! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2) + enddo ; enddo + else + !$OMP do + do j=js-hs,je+hs ; do I=is-1-hs,ie+hs + Datu(I,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i+1,j) > 0.0)) & + Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * eta(i,j) * eta(i+1,j)) / & + (eta(i,j) + eta(i+1,j)) + ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (eta(i,j) + eta(i+1,j)) + enddo ; enddo + !$OMP do + do J=js-1-hs,je+hs ; do i=is-hs,ie+hs + Datv(i,J) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i,j+1) > 0.0)) & + Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * eta(i,j) * eta(i,j+1)) / & + (eta(i,j) + eta(i,j+1)) + ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (eta(i,j) + eta(i,j+1)) + enddo ; enddo + endif + elseif (present(add_max)) then + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + + !$OMP do + do j=js-hs,je+hs ; do I=is-1-hs,ie+hs + Datu(I,j) = CS%dy_Cu(I,j) * Z_to_H * & + max(max(CS%bathyT(i+1,j), CS%bathyT(i,j)) + (G%Z_ref + add_max), 0.0) + enddo ; enddo + !$OMP do + do J=js-1-hs,je+hs ; do i=is-hs,ie+hs + Datv(i,J) = CS%dx_Cv(i,J) * Z_to_H * & + max(max(CS%bathyT(i,j+1), CS%bathyT(i,j)) + (G%Z_ref + add_max), 0.0) + enddo ; enddo + else + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + + !$OMP do + do j=js-hs,je+hs ; do I=is-1-hs,ie+hs + H1 = (CS%bathyT(i,j) + G%Z_ref) * Z_to_H ; H2 = (CS%bathyT(i+1,j) + G%Z_ref) * Z_to_H + Datu(I,j) = 0.0 + if ((H1 > 0.0) .and. (H2 > 0.0)) & + Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * H1 * H2) / (H1 + H2) + enddo ; enddo + !$OMP do + do J=js-1-hs,je+hs ; do i=is-hs,ie+hs + H1 = (CS%bathyT(i,j) + G%Z_ref) * Z_to_H ; H2 = (CS%bathyT(i,j+1) + G%Z_ref) * Z_to_H + Datv(i,J) = 0.0 + if ((H1 > 0.0) .and. (H2 > 0.0)) & + Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * H1 * H2) / (H1 + H2) + enddo ; enddo + endif + !$OMP end parallel + +end subroutine find_face_areas + +!> bt_mass_source determines the appropriately limited mass source for +!! the barotropic solver, along with a corrective fictitious mass source that +!! will drive the barotropic estimate of the free surface height toward the +!! baroclinic estimate. +subroutine bt_mass_source(h, eta, set_cor, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The free surface height that is to be + !! corrected [H ~> m or kg m-2]. + logical, intent(in) :: set_cor !< A flag to indicate whether to set the corrective + !! fluxes (and update the slowly varying part of eta_cor) + !! (.true.) or whether to incrementally update the + !! corrective fluxes. + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + + ! Local variables + real :: h_tot(SZI_(G)) ! The sum of the layer thicknesses [H ~> m or kg m-2]. + real :: eta_h(SZI_(G)) ! The free surface height determined from + ! the sum of the layer thicknesses [H ~> m or kg m-2]. + real :: d_eta ! The difference between estimates of the total + ! thicknesses [H ~> m or kg m-2]. + integer :: is, ie, js, je, nz, i, j, k + + if (.not.CS%module_is_initialized) call MOM_error(FATAL, "bt_mass_source: "// & + "Module MOM_barotropic must be initialized before it is used.") + + if (.not.CS%split) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + !$OMP parallel do default(shared) private(eta_h,h_tot,d_eta) + do j=js,je + do i=is,ie ; h_tot(i) = h(i,j,1) ; enddo + if (GV%Boussinesq) then + do i=is,ie ; eta_h(i) = h(i,j,1) - G%bathyT(i,j)*GV%Z_to_H ; enddo + else + do i=is,ie ; eta_h(i) = h(i,j,1) ; enddo + endif + do k=2,nz ; do i=is,ie + eta_h(i) = eta_h(i) + h(i,j,k) + h_tot(i) = h_tot(i) + h(i,j,k) + enddo ; enddo + + if (set_cor) then + do i=is,ie + d_eta = eta_h(i) - eta(i,j) + CS%eta_cor(i,j) = d_eta + enddo + else + do i=is,ie + d_eta = eta_h(i) - eta(i,j) + CS%eta_cor(i,j) = CS%eta_cor(i,j) + d_eta + enddo + endif + enddo + +end subroutine bt_mass_source + +!> barotropic_init initializes a number of time-invariant fields used in the +!! barotropic calculation and initializes any barotropic fields that have not +!! already been initialized. +subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, & + restart_CS, calc_dtbt, BT_cont, SAL_CSp) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: eta !< Free surface height or column mass anomaly + !! [Z ~> m] or [H ~> kg m-2]. + type(time_type), target, intent(in) :: Time !< The current model time. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic + !! output. + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure + logical, intent(out) :: calc_dtbt !< If true, the barotropic time step must + !! be recalculated before stepping. + type(BT_cont_type), pointer :: BT_cont !< A structure with elements that describe the + !! effective open face areas as a function of + !! barotropic flow. + type(SAL_CS), target, optional :: SAL_CSp !< A pointer to the control structure of the + !! SAL module. + + ! This include declares and sets the variable "version". +# include "version_variable.h" + ! Local variables + character(len=40) :: mdl = "MOM_barotropic" ! This module's name. + real :: Datu(SZIBS_(G),SZJ_(G)) ! Zonal open face area [H L ~> m2 or kg m-1]. + real :: Datv(SZI_(G),SZJBS_(G)) ! Meridional open face area [H L ~> m2 or kg m-1]. + real :: gtot_estimate ! Summed GV%g_prime [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2], to give an + ! upper-bound estimate for pbce. + real :: SSH_extra ! An estimate of how much higher SSH might get, for use + ! in calculating the safe external wave speed [Z ~> m]. + real :: dtbt_input ! The input value of DTBT, [nondim] if negative or [s] if positive. + real :: dtbt_tmp ! A temporary copy of CS%dtbt read from a restart file [T ~> s] + real :: wave_drag_scale ! A scaling factor for the barotropic linear wave drag + ! piston velocities [nondim]. + character(len=200) :: inputdir ! The directory in which to find input files. + character(len=200) :: wave_drag_file ! The file from which to read the wave + ! drag piston velocity. + character(len=80) :: wave_drag_var ! The wave drag piston velocity variable + ! name in wave_drag_file. + real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the + ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. + real :: Z_to_H ! A local unit conversion factor [H Z-1 ~> nondim or kg m-3] + real :: H_to_Z ! A local unit conversion factor [Z H-1 ~> nondim or m3 kg-1] + real :: det_de ! The partial derivative due to self-attraction and loading of the reference + ! geopotential with the sea surface height when scalar SAL are enabled [nondim]. + ! This is typically ~0.09 or less. + real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points + ! that acts on the barotropic flow [H T-1 ~> m s-1 or kg m-2 s-1]. + + type(memory_size_type) :: MS + type(group_pass_type) :: pass_static_data, pass_q_D_Cor + type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: use_BT_cont_type + logical :: use_tides + character(len=48) :: thickness_units, flux_units + character*(40) :: hvel_str + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer :: isdw, iedw, jsdw, jedw + integer :: i, j, k + integer :: wd_halos(2), bt_halo_sz + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + 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 + MS%isdw = G%isd ; MS%iedw = G%ied ; MS%jsdw = G%jsd ; MS%jedw = G%jed + + if (CS%module_is_initialized) then + call MOM_error(WARNING, "barotropic_init called with a control structure "// & + "that has already been initialized.") + return + endif + CS%module_is_initialized = .true. + + CS%diag => diag ; CS%Time => Time + if (present(SAL_CSp)) then + CS%SAL_CSp => SAL_CSp + endif + + ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mdl, "SPLIT", CS%split, default=.true., do_not_log=.true.) + call log_version(param_file, mdl, version, "", log_to_all=.true., layout=CS%split, & + debugging=CS%split, all_default=.not.CS%split) + call get_param(param_file, mdl, "SPLIT", CS%split, & + "Use the split time stepping if true.", default=.true.) + if (.not.CS%split) return + + call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_BT_cont_type, & + "If true, use a structure with elements that describe "//& + "effective face areas from the summed continuity solver "//& + "as a function the barotropic flow in coupling between "//& + "the barotropic and baroclinic flow. This is only used "//& + "if SPLIT is true.", default=.true.) + call get_param(param_file, mdl, "INTEGRAL_BT_CONTINUITY", CS%integral_bt_cont, & + "If true, use the time-integrated velocity over the barotropic steps "//& + "to determine the integrated transports used to update the continuity "//& + "equation. Otherwise the transports are the sum of the transports based on "//& + "a series of instantaneous velocities and the BT_CONT_TYPE for transports. "//& + "This is only valid if USE_BT_CONT_TYPE = True.", & + default=.false., do_not_log=.not.use_BT_cont_type) + call get_param(param_file, mdl, "BOUND_BT_CORRECTION", CS%bound_BT_corr, & + "If true, the corrective pseudo mass-fluxes into the "//& + "barotropic solver are limited to values that require "//& + "less than maxCFL_BT_cont to be accommodated.",default=.false.) + call get_param(param_file, mdl, "BT_CONT_CORR_BOUNDS", CS%BT_cont_bounds, & + "If true, and BOUND_BT_CORRECTION is true, use the "//& + "BT_cont_type variables to set limits determined by "//& + "MAXCFL_BT_CONT on the CFL number of the velocities "//& + "that are likely to be driven by the corrective mass fluxes.", & + default=.true., do_not_log=.not.CS%bound_BT_corr) + call get_param(param_file, mdl, "ADJUST_BT_CONT", CS%adjust_BT_cont, & + "If true, adjust the curve fit to the BT_cont type "//& + "that is used by the barotropic solver to match the "//& + "transport about which the flow is being linearized.", & + default=.false., do_not_log=.not.use_BT_cont_type) + call get_param(param_file, mdl, "GRADUAL_BT_ICS", CS%gradual_BT_ICs, & + "If true, adjust the initial conditions for the "//& + "barotropic solver to the values from the layered "//& + "solution over a whole timestep instead of instantly. "//& + "This is a decent approximation to the inclusion of "//& + "sum(u dh_dt) while also correcting for truncation errors.", & + default=.false.) + call get_param(param_file, mdl, "BT_USE_VISC_REM_U_UH0", CS%visc_rem_u_uh0, & + "If true, use the viscous remnants when estimating the "//& + "barotropic velocities that were used to calculate uh0 "//& + "and vh0. False is probably the better choice.", default=.false.) + call get_param(param_file, mdl, "BT_USE_WIDE_HALOS", CS%use_wide_halos, & + "If true, use wide halos and march in during the "//& + "barotropic time stepping for efficiency.", default=.true., & + layoutParam=.true.) + call get_param(param_file, mdl, "BTHALO", bt_halo_sz, & + "The minimum halo size for the barotropic solver.", default=0, & + layoutParam=.true.) +#ifdef STATIC_MEMORY_ + if ((bt_halo_sz > 0) .and. (bt_halo_sz /= BTHALO_)) call MOM_error(FATAL, & + "barotropic_init: Run-time values of BTHALO must agree with the "//& + "macro BTHALO_ with STATIC_MEMORY_.") + wd_halos(1) = WHALOI_+NIHALO_ ; wd_halos(2) = WHALOJ_+NJHALO_ +#else + wd_halos(1) = bt_halo_sz; wd_halos(2) = bt_halo_sz +#endif + call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", CS%Nonlinear_continuity, & + "If true, use nonlinear transports in the barotropic "//& + "continuity equation. This does not apply if "//& + "USE_BT_CONT_TYPE is true.", default=.false., do_not_log=use_BT_cont_type) + call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", CS%Nonlin_cont_update_period, & + "If NONLINEAR_BT_CONTINUITY is true, this is the number "//& + "of barotropic time steps between updates to the face "//& + "areas, or 0 to update only before the barotropic stepping.", & + default=1, do_not_log=.not.CS%Nonlinear_continuity) + + call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", CS%BT_project_velocity,& + "If true, step the barotropic velocity first and project "//& + "out the velocity tendency by 1+BEBT when calculating the "//& + "transport. The default (false) is to use a predictor "//& + "continuity step to find the pressure field, and then "//& + "to do a corrector continuity step using a weighted "//& + "average of the old and new velocities, with weights "//& + "of (1-BEBT) and BEBT.", default=.false.) + call get_param(param_file, mdl, "BT_NONLIN_STRESS", CS%nonlin_stress, & + "If true, use the full depth of the ocean at the start of the barotropic "//& + "step when calculating the surface stress contribution to the barotropic "//& + "acclerations. Otherwise use the depth based on bathyT.", default=.false.) + call get_param(param_file, mdl, "BT_RHO_LINEARIZED", CS%Rho_BT_lin, & + "A density that is used to convert total water column thicknesses into mass "//& + "in non-Boussinesq mode with linearized options in the barotropic solver or "//& + "when estimating the stable barotropic timestep without access to the full "//& + "baroclinic model state.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=GV%Boussinesq) + + call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", CS%dynamic_psurf, & + "If true, add a dynamic pressure due to a viscous ice "//& + "shelf, for instance.", default=.false.) + call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", CS%ice_strength_length, & + "The length scale at which the Rayleigh damping rate due "//& + "to the ice strength should be the same as if a Laplacian "//& + "were applied, if DYNAMIC_SURFACE_PRESSURE is true.", & + units="m", default=1.0e4, scale=US%m_to_L, do_not_log=.not.CS%dynamic_psurf) + call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", CS%Dmin_dyn_psurf, & + "The minimum depth to use in limiting the size of the "//& + "dynamic surface pressure for stability, if "//& + "DYNAMIC_SURFACE_PRESSURE is true..", & + units="m", default=1.0e-6, scale=GV%m_to_H, do_not_log=.not.CS%dynamic_psurf) + call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & + "The constant that scales the dynamic surface pressure, "//& + "if DYNAMIC_SURFACE_PRESSURE is true. Stable values "//& + "are < ~1.0.", units="nondim", default=0.9, do_not_log=.not.CS%dynamic_psurf) + + call get_param(param_file, mdl, "BT_CORIOLIS_SCALE", CS%BT_Coriolis_scale, & + "A factor by which the barotropic Coriolis anomaly terms are scaled.", & + units="nondim", default=1.0) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "BAROTROPIC_ANSWER_DATE", CS%answer_date, & + "The vintage of the expressions in the barotropic solver. "//& + "Values below 20190101 recover the answers from the end of 2018, "//& + "while higher values uuse more efficient or general expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + + call get_param(param_file, mdl, "TIDES", use_tides, & + "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=use_tides) + det_de = 0.0 + if (CS%calculate_SAL .and. associated(CS%SAL_CSp)) & + call scalar_SAL_sensitivity(CS%SAL_CSp, det_de) + call get_param(param_file, mdl, "BAROTROPIC_TIDAL_SAL_BUG", CS%tidal_sal_bug, & + "If true, the tidal self-attraction and loading anomaly in the barotropic "//& + "solver has the wrong sign, replicating a long-standing bug with a scalar "//& + "self-attraction and loading term or the SAL term from a previous simulation.", & + default=.false., do_not_log=(det_de==0.0)) + call get_param(param_file, mdl, "TIDAL_SAL_FLATHER", CS%tidal_sal_flather, & + "If true, then apply adjustments to the external gravity "//& + "wave speed used with the Flather OBC routine consistent "//& + "with the barotropic solver. This applies to cases with "//& + "tidal forcing using the scalar self-attraction approximation. "//& + "The default is currently False in order to retain previous answers "//& + "but should be set to True for new experiments", default=.false.) + + call get_param(param_file, mdl, "SADOURNY", CS%Sadourny, & + "If true, the Coriolis terms are discretized with the "//& + "Sadourny (1975) energy conserving scheme, otherwise "//& + "the Arakawa & Hsu scheme is used. If the internal "//& + "deformation radius is not resolved, the Sadourny scheme "//& + "should probably be used.", default=.true.) + + call get_param(param_file, mdl, "BT_THICK_SCHEME", hvel_str, & + "A string describing the scheme that is used to set the "//& + "open face areas used for barotropic transport and the "//& + "relative weights of the accelerations. Valid values are:\n"//& + "\t ARITHMETIC - arithmetic mean layer thicknesses \n"//& + "\t HARMONIC - harmonic mean layer thicknesses \n"//& + "\t HYBRID (the default) - use arithmetic means for \n"//& + "\t layers above the shallowest bottom, the harmonic \n"//& + "\t mean for layers below, and a weighted average for \n"//& + "\t layers that straddle that depth \n"//& + "\t FROM_BT_CONT - use the average thicknesses kept \n"//& + "\t in the h_u and h_v fields of the BT_cont_type", & + default=BT_CONT_STRING) + select case (hvel_str) + case (HYBRID_STRING) ; CS%hvel_scheme = HYBRID + case (HARMONIC_STRING) ; CS%hvel_scheme = HARMONIC + case (ARITHMETIC_STRING) ; CS%hvel_scheme = ARITHMETIC + case (BT_CONT_STRING) ; CS%hvel_scheme = FROM_BT_CONT + case default + call MOM_mesg('barotropic_init: BT_THICK_SCHEME ="'//trim(hvel_str)//'"', 0) + call MOM_error(FATAL, "barotropic_init: Unrecognized setting "// & + "#define BT_THICK_SCHEME "//trim(hvel_str)//" found in input file.") + end select + if ((CS%hvel_scheme == FROM_BT_CONT) .and. .not.use_BT_cont_type) & + call MOM_error(FATAL, "barotropic_init: BT_THICK_SCHEME FROM_BT_CONT "//& + "can only be used if USE_BT_CONT_TYPE is defined.") + + call get_param(param_file, mdl, "BT_STRONG_DRAG", CS%strong_drag, & + "If true, use a stronger estimate of the retarding "//& + "effects of strong bottom drag, by making it implicit "//& + "with the barotropic time-step instead of implicit with "//& + "the baroclinic time-step and dividing by the number of "//& + "barotropic steps.", default=.false.) + call get_param(param_file, mdl, "BT_LINEAR_WAVE_DRAG", CS%linear_wave_drag, & + "If true, apply a linear drag to the barotropic velocities, "//& + "using rates set by lin_drag_u & _v divided by the depth of "//& + "the ocean. This was introduced to facilitate tide modeling.", & + default=.false.) + call get_param(param_file, mdl, "BT_WAVE_DRAG_FILE", wave_drag_file, & + "The name of the file with the barotropic linear wave drag "//& + "piston velocities.", default="", do_not_log=.not.CS%linear_wave_drag) + call get_param(param_file, mdl, "BT_WAVE_DRAG_VAR", wave_drag_var, & + "The name of the variable in BT_WAVE_DRAG_FILE with the "//& + "barotropic linear wave drag piston velocities at h points.", & + default="rH", do_not_log=.not.CS%linear_wave_drag) + call get_param(param_file, mdl, "BT_WAVE_DRAG_SCALE", wave_drag_scale, & + "A scaling factor for the barotropic linear wave drag "//& + "piston velocities.", default=1.0, units="nondim", & + do_not_log=.not.CS%linear_wave_drag) + + call get_param(param_file, mdl, "CLIP_BT_VELOCITY", CS%clip_velocity, & + "If true, limit any velocity components that exceed "//& + "CFL_TRUNCATE. This should only be used as a desperate "//& + "debugging measure.", default=.false.) + call get_param(param_file, mdl, "CFL_TRUNCATE", CS%CFL_trunc, & + "The value of the CFL number that will cause velocity "//& + "components to be truncated; instability can occur past 0.5.", & + units="nondim", default=0.5, do_not_log=.not.CS%clip_velocity) + call get_param(param_file, mdl, "MAXVEL", CS%maxvel, & + "The maximum velocity allowed before the velocity "//& + "components are truncated.", units="m s-1", default=3.0e8, scale=US%m_s_to_L_T, & + do_not_log=.not.CS%clip_velocity) + call get_param(param_file, mdl, "MAXCFL_BT_CONT", CS%maxCFL_BT_cont, & + "The maximum permitted CFL number associated with the "//& + "barotropic accelerations from the summed velocities "//& + "times the time-derivatives of thicknesses.", units="nondim", & + default=0.25) + call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & + "A negligibly small velocity magnitude below which velocity "//& + "components are set to 0. A reasonable value might be "//& + "1e-30 m/s, which is less than an Angstrom divided by "//& + "the age of the universe.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) + + call get_param(param_file, mdl, "DT_BT_FILTER", CS%dt_bt_filter, & + "A time-scale over which the barotropic mode solutions "//& + "are filtered, in seconds if positive, or as a fraction "//& + "of DT if negative. When used this can never be taken to "//& + "be longer than 2*dt. Set this to 0 to apply no filtering.", & + units="sec or nondim", default=-0.25) + if (CS%dt_bt_filter > 0.0) CS%dt_bt_filter = US%s_to_T*CS%dt_bt_filter + call get_param(param_file, mdl, "G_BT_EXTRA", CS%G_extra, & + "A nondimensional factor by which gtot is enhanced.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "SSH_EXTRA", SSH_extra, & + "An estimate of how much higher SSH might get, for use "//& + "in calculating the safe external wave speed. The "//& + "default is the minimum of 10 m or 5% of MAXIMUM_DEPTH.", & + units="m", default=min(10.0,0.05*G%max_depth*US%Z_to_m), scale=US%m_to_Z) + + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_BT", CS%debug_bt, & + "If true, write out verbose debugging data within the "//& + "barotropic time-stepping loop. The data volume can be "//& + "quite large if this is true.", default=CS%debug, & + debuggingParam=.true.) + + call get_param(param_file, mdl, "LINEARIZED_BT_CORIOLIS", CS%linearized_BT_PV, & + "If true use the bottom depth instead of the total water column thickness "//& + "in the barotropic Coriolis term calculations.", default=.true.) + call get_param(param_file, mdl, "BEBT", CS%bebt, & + "BEBT determines whether the barotropic time stepping "//& + "uses the forward-backward time-stepping scheme or a "//& + "backward Euler scheme. BEBT is valid in the range from "//& + "0 (for a forward-backward treatment of nonrotating "//& + "gravity waves) to 1 (for a backward Euler treatment). "//& + "In practice, BEBT must be greater than about 0.05.", & + units="nondim", default=0.1) + ! Note that dtbt_input is not rescaled because it has different units for + ! positive [s] and negative [nondim] values. + call get_param(param_file, mdl, "DTBT", dtbt_input, & + "The barotropic time step, in s. DTBT is only used with "//& + "the split explicit time stepping. To set the time step "//& + "automatically based the maximum stable value use 0, or "//& + "a negative value gives the fraction of the stable value. "//& + "Setting DTBT to 0 is the same as setting it to -0.98. "//& + "The value of DTBT that will actually be used is an "//& + "integer fraction of DT, rounding down.", & + units="s or nondim", default=-0.98) + call get_param(param_file, mdl, "BT_USE_OLD_CORIOLIS_BRACKET_BUG", & + CS%use_old_coriolis_bracket_bug , & + "If True, use an order of operations that is not bitwise "//& + "rotationally symmetric in the meridional Coriolis term of "//& + "the barotropic solver.", default=.false.) + + ! Initialize a version of the MOM domain that is specific to the barotropic solver. + call clone_MOM_domain(G%Domain, CS%BT_Domain, min_halo=wd_halos, symmetric=.true.) +#ifdef STATIC_MEMORY_ + if (wd_halos(1) /= WHALOI_+NIHALO_) call MOM_error(FATAL, "barotropic_init: "//& + "Barotropic x-halo sizes are incorrectly resized with STATIC_MEMORY_.") + if (wd_halos(2) /= WHALOJ_+NJHALO_) call MOM_error(FATAL, "barotropic_init: "//& + "Barotropic y-halo sizes are incorrectly resized with STATIC_MEMORY_.") +#else + if (bt_halo_sz > 0) then + if (wd_halos(1) > bt_halo_sz) & + call MOM_mesg("barotropic_init: barotropic x-halo size increased.", 3) + if (wd_halos(2) > bt_halo_sz) & + call MOM_mesg("barotropic_init: barotropic y-halo size increased.", 3) + endif +#endif + call log_param(param_file, mdl, "!BT x-halo", wd_halos(1), & + "The barotropic x-halo size that is actually used.", & + layoutParam=.true.) + call log_param(param_file, mdl, "!BT y-halo", wd_halos(2), & + "The barotropic y-halo size that is actually used.", & + layoutParam=.true.) + + CS%isdw = G%isc-wd_halos(1) ; CS%iedw = G%iec+wd_halos(1) + CS%jsdw = G%jsc-wd_halos(2) ; CS%jedw = G%jec+wd_halos(2) + isdw = CS%isdw ; iedw = CS%iedw ; jsdw = CS%jsdw ; jedw = CS%jedw + + ALLOC_(CS%frhatu(IsdB:IedB,jsd:jed,nz)) ; ALLOC_(CS%frhatv(isd:ied,JsdB:JedB,nz)) + ALLOC_(CS%eta_cor(isd:ied,jsd:jed)) + if (CS%bound_BT_corr) then + ALLOC_(CS%eta_cor_bound(isd:ied,jsd:jed)) ; CS%eta_cor_bound(:,:) = 0.0 + endif + ALLOC_(CS%IDatu(IsdB:IedB,jsd:jed)) ; ALLOC_(CS%IDatv(isd:ied,JsdB:JedB)) + + ALLOC_(CS%ua_polarity(isdw:iedw,jsdw:jedw)) + ALLOC_(CS%va_polarity(isdw:iedw,jsdw:jedw)) + + CS%frhatu(:,:,:) = 0.0 ; CS%frhatv(:,:,:) = 0.0 + CS%eta_cor(:,:) = 0.0 + CS%IDatu(:,:) = 0.0 ; CS%IDatv(:,:) = 0.0 + + CS%ua_polarity(:,:) = 1.0 ; CS%va_polarity(:,:) = 1.0 + call create_group_pass(pass_a_polarity, CS%ua_polarity, CS%va_polarity, CS%BT_domain, To_All, AGRID) + call do_group_pass(pass_a_polarity, CS%BT_domain) + + if (use_BT_cont_type) & + call alloc_BT_cont_type(BT_cont, G, GV, (CS%hvel_scheme == FROM_BT_CONT)) + + if (CS%debug) then ! Make a local copy of loop ranges for chksum calls + allocate(CS%debug_BT_HI) + CS%debug_BT_HI%isc=G%isc + CS%debug_BT_HI%iec=G%iec + CS%debug_BT_HI%jsc=G%jsc + CS%debug_BT_HI%jec=G%jec + CS%debug_BT_HI%IscB=G%isc-1 + CS%debug_BT_HI%IecB=G%iec + CS%debug_BT_HI%JscB=G%jsc-1 + CS%debug_BT_HI%JecB=G%jec + CS%debug_BT_HI%isd=CS%isdw + CS%debug_BT_HI%ied=CS%iedw + CS%debug_BT_HI%jsd=CS%jsdw + CS%debug_BT_HI%jed=CS%jedw + CS%debug_BT_HI%IsdB=CS%isdw-1 + CS%debug_BT_HI%IedB=CS%iedw + CS%debug_BT_HI%JsdB=CS%jsdw-1 + CS%debug_BT_HI%JedB=CS%jedw + CS%debug_BT_HI%turns = G%HI%turns + endif + + ! IareaT, IdxCu, and IdyCv need to be allocated with wide halos. + ALLOC_(CS%IareaT(CS%isdw:CS%iedw,CS%jsdw:CS%jedw)) ; CS%IareaT(:,:) = 0.0 + ALLOC_(CS%bathyT(CS%isdw:CS%iedw,CS%jsdw:CS%jedw)) ; CS%bathyT(:,:) = 0.0 + ALLOC_(CS%IdxCu(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ; CS%IdxCu(:,:) = 0.0 + ALLOC_(CS%IdyCv(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%IdyCv(:,:) = 0.0 + ALLOC_(CS%dy_Cu(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ; CS%dy_Cu(:,:) = 0.0 + ALLOC_(CS%dx_Cv(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%dx_Cv(:,:) = 0.0 + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%IareaT(i,j) = G%IareaT(i,j) + CS%bathyT(i,j) = G%bathyT(i,j) + enddo ; enddo + + ! Note: G%IdxCu & G%IdyCv may be valid for a smaller extent than CS%IdxCu & CS%IdyCv, even without + ! wide halos. + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + CS%IdxCu(I,j) = G%IdxCu(I,j) ; CS%dy_Cu(I,j) = G%dy_Cu(I,j) + enddo ; enddo + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + CS%IdyCv(i,J) = G%IdyCv(i,J) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J) + enddo ; enddo + call create_group_pass(pass_static_data, CS%IareaT, CS%BT_domain, To_All) + call create_group_pass(pass_static_data, CS%bathyT, CS%BT_domain, To_All) + call create_group_pass(pass_static_data, CS%IdxCu, CS%IdyCv, CS%BT_domain, To_All+Scalar_Pair) + call create_group_pass(pass_static_data, CS%dy_Cu, CS%dx_Cv, CS%BT_domain, To_All+Scalar_Pair) + call do_group_pass(pass_static_data, CS%BT_domain) + + if (CS%linearized_BT_PV) then + ALLOC_(CS%q_D(CS%isdw-1:CS%iedw,CS%jsdw-1:CS%jedw)) + ALLOC_(CS%D_u_Cor(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) + ALLOC_(CS%D_v_Cor(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) + CS%q_D(:,:) = 0.0 ; CS%D_u_Cor(:,:) = 0.0 ; CS%D_v_Cor(:,:) = 0.0 + + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + + Mean_SL = G%Z_ref + do j=js,je ; do I=is-1,ie + CS%D_u_Cor(I,j) = 0.5 * (max(Mean_SL+G%bathyT(i+1,j),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) * Z_to_H + enddo ; enddo + do J=js-1,je ; do i=is,ie + CS%D_v_Cor(i,J) = 0.5 * (max(Mean_SL+G%bathyT(i,j+1),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) * Z_to_H + enddo ; enddo + do J=js-1,je ; do I=is-1,ie + if (G%mask2dT(i,j)+G%mask2dT(i,j+1)+G%mask2dT(i+1,j)+G%mask2dT(i+1,j+1)>0.) then + CS%q_D(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & + ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & + (Z_to_H * max(((G%areaT(i,j) * max(Mean_SL+G%bathyT(i,j),0.0) + & + G%areaT(i+1,j+1) * max(Mean_SL+G%bathyT(i+1,j+1),0.0)) + & + (G%areaT(i+1,j) * max(Mean_SL+G%bathyT(i+1,j),0.0) + & + G%areaT(i,j+1) * max(Mean_SL+G%bathyT(i,j+1),0.0))), GV%H_subroundoff) ) + else ! All four h points are masked out so q_D(I,J) will is meaningless + CS%q_D(I,J) = 0. + endif + enddo ; enddo + ! With very wide halos, q and D need to be calculated on the available data + ! domain and then updated onto the full computational domain. + call create_group_pass(pass_q_D_Cor, CS%q_D, CS%BT_Domain, To_All, position=CORNER) + call create_group_pass(pass_q_D_Cor, CS%D_u_Cor, CS%D_v_Cor, CS%BT_Domain, & + To_All+Scalar_Pair) + call do_group_pass(pass_q_D_Cor, CS%BT_Domain) + endif + + if (CS%linear_wave_drag) then + ALLOC_(CS%lin_drag_u(IsdB:IedB,jsd:jed)) ; CS%lin_drag_u(:,:) = 0.0 + ALLOC_(CS%lin_drag_v(isd:ied,JsdB:JedB)) ; CS%lin_drag_v(:,:) = 0.0 + + if (len_trim(wave_drag_file) > 0) then + inputdir = "." ; call get_param(param_file, mdl, "INPUTDIR", inputdir) + wave_drag_file = trim(slasher(inputdir))//trim(wave_drag_file) + call log_param(param_file, mdl, "INPUTDIR/BT_WAVE_DRAG_FILE", wave_drag_file) + + allocate(lin_drag_h(isd:ied,jsd:jed), source=0.0) + + call MOM_read_data(wave_drag_file, wave_drag_var, lin_drag_h, G%Domain, scale=GV%m_to_H*US%T_to_s) + call pass_var(lin_drag_h, G%Domain) + do j=js,je ; do I=is-1,ie + CS%lin_drag_u(I,j) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + CS%lin_drag_v(i,J) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1)) + enddo ; enddo + deallocate(lin_drag_h) + endif + endif + + CS%dtbt_fraction = 0.98 ; if (dtbt_input < 0.0) CS%dtbt_fraction = -dtbt_input + + dtbt_tmp = -1.0 + if (query_initialized(CS%dtbt, "DTBT", restart_CS)) then + dtbt_tmp = CS%dtbt + endif + + ! Estimate the maximum stable barotropic time step. + gtot_estimate = 0.0 + if (GV%Boussinesq) then + do k=1,GV%ke ; gtot_estimate = gtot_estimate + GV%H_to_Z*GV%g_prime(K) ; enddo + else + H_to_Z = GV%H_to_RZ / CS%Rho_BT_lin + do k=1,GV%ke ; gtot_estimate = gtot_estimate + H_to_Z*GV%g_prime(K) ; enddo + endif + call set_dtbt(G, GV, US, CS, gtot_est=gtot_estimate, SSH_add=SSH_extra) + + if (dtbt_input > 0.0) then + CS%dtbt = US%s_to_T * dtbt_input + elseif (dtbt_tmp > 0.0) then + CS%dtbt = dtbt_tmp + endif + if ((dtbt_tmp > 0.0) .and. (dtbt_input > 0.0)) calc_dtbt = .false. + + call log_param(param_file, mdl, "DTBT as used", CS%dtbt, units="s", unscale=US%T_to_s) + call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max, units="s", unscale=US%T_to_s) + + ! ubtav and vbtav, and perhaps ubt_IC and vbt_IC, are allocated and + ! initialized in register_barotropic_restarts. + + if (GV%Boussinesq) then + thickness_units = "m" ; flux_units = "m3 s-1" + else + thickness_units = "kg m-2" ; flux_units = "kg s-1" + endif + + CS%id_PFu_bt = register_diag_field('ocean_model', 'PFuBT', diag%axesCu1, Time, & + 'Zonal Anomalous Barotropic Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_PFv_bt = register_diag_field('ocean_model', 'PFvBT', diag%axesCv1, Time, & + 'Meridional Anomalous Barotropic Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_Coru_bt = register_diag_field('ocean_model', 'CoruBT', diag%axesCu1, Time, & + 'Zonal Barotropic Coriolis Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_Corv_bt = register_diag_field('ocean_model', 'CorvBT', diag%axesCv1, Time, & + 'Meridional Barotropic Coriolis Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_uaccel = register_diag_field('ocean_model', 'u_accel_bt', diag%axesCu1, Time, & + 'Barotropic zonal acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_vaccel = register_diag_field('ocean_model', 'v_accel_bt', diag%axesCv1, Time, & + 'Barotropic meridional acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_ubtforce = register_diag_field('ocean_model', 'ubtforce', diag%axesCu1, Time, & + 'Barotropic zonal acceleration from baroclinic terms', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_vbtforce = register_diag_field('ocean_model', 'vbtforce', diag%axesCv1, Time, & + 'Barotropic meridional acceleration from baroclinic terms', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_ubtdt = register_diag_field('ocean_model', 'ubt_dt', diag%axesCu1, Time, & + 'Barotropic zonal acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_vbtdt = register_diag_field('ocean_model', 'vbt_dt', diag%axesCv1, Time, & + 'Barotropic meridional acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + + CS%id_eta_bt = register_diag_field('ocean_model', 'eta_bt', diag%axesT1, Time, & + 'Barotropic end SSH', thickness_units, conversion=GV%H_to_MKS) + CS%id_ubt = register_diag_field('ocean_model', 'ubt', diag%axesCu1, Time, & + 'Barotropic end zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vbt = register_diag_field('ocean_model', 'vbt', diag%axesCv1, Time, & + 'Barotropic end meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_eta_st = register_diag_field('ocean_model', 'eta_st', diag%axesT1, Time, & + 'Barotropic start SSH', thickness_units, conversion=GV%H_to_MKS) + CS%id_ubt_st = register_diag_field('ocean_model', 'ubt_st', diag%axesCu1, Time, & + 'Barotropic start zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vbt_st = register_diag_field('ocean_model', 'vbt_st', diag%axesCv1, Time, & + 'Barotropic start meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_ubtav = register_diag_field('ocean_model', 'ubtav', diag%axesCu1, Time, & + 'Barotropic time-average zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vbtav = register_diag_field('ocean_model', 'vbtav', diag%axesCv1, Time, & + 'Barotropic time-average meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_eta_cor = register_diag_field('ocean_model', 'eta_cor', diag%axesT1, Time, & + 'Corrective mass flux within a timestep', 'm', conversion=GV%H_to_m) + CS%id_visc_rem_u = register_diag_field('ocean_model', 'visc_rem_u', diag%axesCuL, Time, & + 'Viscous remnant at u', 'nondim') + CS%id_visc_rem_v = register_diag_field('ocean_model', 'visc_rem_v', diag%axesCvL, Time, & + 'Viscous remnant at v', 'nondim') + CS%id_gtotn = register_diag_field('ocean_model', 'gtot_n', diag%axesT1, Time, & + 'gtot to North', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) + CS%id_gtots = register_diag_field('ocean_model', 'gtot_s', diag%axesT1, Time, & + 'gtot to South', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) + CS%id_gtote = register_diag_field('ocean_model', 'gtot_e', diag%axesT1, Time, & + 'gtot to East', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) + CS%id_gtotw = register_diag_field('ocean_model', 'gtot_w', diag%axesT1, Time, & + 'gtot to West', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) + CS%id_eta_hifreq = register_diag_field('ocean_model', 'eta_hifreq', diag%axesT1, Time, & + 'High Frequency Barotropic SSH', thickness_units, conversion=GV%H_to_MKS) + CS%id_ubt_hifreq = register_diag_field('ocean_model', 'ubt_hifreq', diag%axesCu1, Time, & + 'High Frequency Barotropic zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vbt_hifreq = register_diag_field('ocean_model', 'vbt_hifreq', diag%axesCv1, Time, & + 'High Frequency Barotropic meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_eta_pred_hifreq = register_diag_field('ocean_model', 'eta_pred_hifreq', diag%axesT1, Time, & + 'High Frequency Predictor Barotropic SSH', thickness_units, conversion=GV%H_to_MKS) + CS%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, Time, & + 'High Frequency Barotropic zonal transport', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) + CS%id_vhbt_hifreq = register_diag_field('ocean_model', 'vhbt_hifreq', diag%axesCv1, Time, & + 'High Frequency Barotropic meridional transport', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) + CS%id_frhatu = register_diag_field('ocean_model', 'frhatu', diag%axesCuL, Time, & + 'Fractional thickness of layers in u-columns', 'nondim') + CS%id_frhatv = register_diag_field('ocean_model', 'frhatv', diag%axesCvL, Time, & + 'Fractional thickness of layers in v-columns', 'nondim') + CS%id_frhatu1 = register_diag_field('ocean_model', 'frhatu1', diag%axesCuL, Time, & + 'Predictor Fractional thickness of layers in u-columns', 'nondim') + CS%id_frhatv1 = register_diag_field('ocean_model', 'frhatv1', diag%axesCvL, Time, & + 'Predictor Fractional thickness of layers in v-columns', 'nondim') + CS%id_uhbt = register_diag_field('ocean_model', 'uhbt', diag%axesCu1, Time, & + 'Barotropic zonal transport averaged over a baroclinic step', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) + CS%id_vhbt = register_diag_field('ocean_model', 'vhbt', diag%axesCv1, Time, & + 'Barotropic meridional transport averaged over a baroclinic step', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) + + if (use_BT_cont_type) then + CS%id_BTC_FA_u_EE = register_diag_field('ocean_model', 'BTC_FA_u_EE', diag%axesCu1, Time, & + 'BTCont type far east face area', 'm2', conversion=US%L_to_m*GV%H_to_m) + CS%id_BTC_FA_u_E0 = register_diag_field('ocean_model', 'BTC_FA_u_E0', diag%axesCu1, Time, & + 'BTCont type near east face area', 'm2', conversion=US%L_to_m*GV%H_to_m) + CS%id_BTC_FA_u_WW = register_diag_field('ocean_model', 'BTC_FA_u_WW', diag%axesCu1, Time, & + 'BTCont type far west face area', 'm2', conversion=US%L_to_m*GV%H_to_m) + CS%id_BTC_FA_u_W0 = register_diag_field('ocean_model', 'BTC_FA_u_W0', diag%axesCu1, Time, & + 'BTCont type near west face area', 'm2', conversion=US%L_to_m*GV%H_to_m) + CS%id_BTC_ubt_EE = register_diag_field('ocean_model', 'BTC_ubt_EE', diag%axesCu1, Time, & + 'BTCont type far east velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_BTC_ubt_WW = register_diag_field('ocean_model', 'BTC_ubt_WW', diag%axesCu1, Time, & + 'BTCont type far west velocity', 'm s-1', conversion=US%L_T_to_m_s) + ! This is a specialized diagnostic that is not being made widely available (yet). + ! CS%id_BTC_FA_u_rat0 = register_diag_field('ocean_model', 'BTC_FA_u_rat0', diag%axesCu1, Time, & + ! 'BTCont type ratio of near east and west face areas', 'nondim') + CS%id_BTC_FA_v_NN = register_diag_field('ocean_model', 'BTC_FA_v_NN', diag%axesCv1, Time, & + 'BTCont type far north face area', 'm2', conversion=US%L_to_m*GV%H_to_m) + CS%id_BTC_FA_v_N0 = register_diag_field('ocean_model', 'BTC_FA_v_N0', diag%axesCv1, Time, & + 'BTCont type near north face area', 'm2', conversion=US%L_to_m*GV%H_to_m) + CS%id_BTC_FA_v_SS = register_diag_field('ocean_model', 'BTC_FA_v_SS', diag%axesCv1, Time, & + 'BTCont type far south face area', 'm2', conversion=US%L_to_m*GV%H_to_m) + CS%id_BTC_FA_v_S0 = register_diag_field('ocean_model', 'BTC_FA_v_S0', diag%axesCv1, Time, & + 'BTCont type near south face area', 'm2', conversion=US%L_to_m*GV%H_to_m) + CS%id_BTC_vbt_NN = register_diag_field('ocean_model', 'BTC_vbt_NN', diag%axesCv1, Time, & + 'BTCont type far north velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_BTC_vbt_SS = register_diag_field('ocean_model', 'BTC_vbt_SS', diag%axesCv1, Time, & + 'BTCont type far south velocity', 'm s-1', conversion=US%L_T_to_m_s) + ! This is a specialized diagnostic that is not being made widely available (yet). + ! CS%id_BTC_FA_v_rat0 = register_diag_field('ocean_model', 'BTC_FA_v_rat0', diag%axesCv1, Time, & + ! 'BTCont type ratio of near north and south face areas', 'nondim') + ! CS%id_BTC_FA_h_rat0 = register_diag_field('ocean_model', 'BTC_FA_h_rat0', diag%axesT1, Time, & + ! 'BTCont type maximum ratios of near face areas around cells', 'nondim') + endif + CS%id_uhbt0 = register_diag_field('ocean_model', 'uhbt0', diag%axesCu1, Time, & + 'Barotropic zonal transport difference', 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) + CS%id_vhbt0 = register_diag_field('ocean_model', 'vhbt0', diag%axesCv1, Time, & + 'Barotropic meridional transport difference', 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) + + if (CS%id_frhatu1 > 0) allocate(CS%frhatu1(IsdB:IedB,jsd:jed,nz), source=0.) + if (CS%id_frhatv1 > 0) allocate(CS%frhatv1(isd:ied,JsdB:JedB,nz), source=0.) + + if (.NOT.query_initialized(CS%ubtav,"ubtav",restart_CS) .or. & + .NOT.query_initialized(CS%vbtav,"vbtav",restart_CS)) then + call btcalc(h, G, GV, CS, may_use_default=.true.) + CS%ubtav(:,:) = 0.0 ; CS%vbtav(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=is-1,ie + CS%ubtav(I,j) = CS%ubtav(I,j) + CS%frhatu(I,j,k) * u(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=js-1,je ; do i=is,ie + CS%vbtav(i,J) = CS%vbtav(i,J) + CS%frhatv(i,J,k) * v(i,J,k) + enddo ; enddo ; enddo + endif + + if (CS%gradual_BT_ICs) then + if (.NOT.query_initialized(CS%ubt_IC,"ubt_IC",restart_CS) .or. & + .NOT.query_initialized(CS%vbt_IC,"vbt_IC",restart_CS)) then + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo + endif + endif +! Calculate other constants which are used for btstep. + + if (.not.CS%nonlin_stress) then + Mean_SL = G%Z_ref + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + do j=js,je ; do I=is-1,ie + if (G%mask2dCu(I,j)>0.) then + CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (Z_to_H * ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*Mean_SL)) + else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless + CS%IDatu(I,j) = 0. + endif + enddo ; enddo + do J=js-1,je ; do i=is,ie + if (G%mask2dCv(i,J)>0.) then + CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (Z_to_H * ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL)) + else ! Both neighboring H points are masked out so IDatv(i,J) is meaningless + CS%IDatv(i,J) = 0. + endif + enddo ; enddo + endif + + call find_face_areas(Datu, Datv, G, GV, US, CS, MS, 1) + if ((CS%bound_BT_corr) .and. .not.(use_BT_Cont_type .and. CS%BT_cont_bounds)) then + ! This is not used in most test cases. Were it ever to become more widely used, consider + ! replacing maxvel with min(G%dxT(i,j),G%dyT(i,j)) * (CS%maxCFL_BT_cont*Idt) . + do j=js,je ; do i=is,ie + CS%eta_cor_bound(i,j) = G%IareaT(i,j) * 0.1 * CS%maxvel * & + ((Datu(I-1,j) + Datu(I,j)) + (Datv(i,J) + Datv(i,J-1))) + enddo ; enddo + endif + + if (CS%gradual_BT_ICs) & + call create_group_pass(pass_bt_hbt_btav, CS%ubt_IC, CS%vbt_IC, G%Domain) + call create_group_pass(pass_bt_hbt_btav, CS%ubtav, CS%vbtav, G%Domain) + call do_group_pass(pass_bt_hbt_btav, G%Domain) + +! id_clock_pass = cpu_clock_id('(Ocean BT halo updates)', grain=CLOCK_ROUTINE) + id_clock_calc_pre = cpu_clock_id('(Ocean BT pre-calcs only)', grain=CLOCK_ROUTINE) + id_clock_pass_pre = cpu_clock_id('(Ocean BT pre-step halo updates)', grain=CLOCK_ROUTINE) + id_clock_calc = cpu_clock_id('(Ocean BT stepping calcs only)', grain=CLOCK_ROUTINE) + id_clock_pass_step = cpu_clock_id('(Ocean BT stepping halo updates)', grain=CLOCK_ROUTINE) + id_clock_calc_post = cpu_clock_id('(Ocean BT post-calcs only)', grain=CLOCK_ROUTINE) + id_clock_pass_post = cpu_clock_id('(Ocean BT post-step halo updates)', grain=CLOCK_ROUTINE) + if (dtbt_input <= 0.0) & + id_clock_sync = cpu_clock_id('(Ocean BT global synch)', grain=CLOCK_ROUTINE) + +end subroutine barotropic_init + +!> Copies ubtav and vbtav from private type into arrays +subroutine barotropic_get_tav(CS, ubtav, vbtav, G, US) + type(barotropic_CS), intent(in) :: CS !< Barotropic control structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: ubtav !< Zonal barotropic velocity averaged + !! over a baroclinic timestep [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vbtav !< Meridional barotropic velocity averaged + !! over a baroclinic timestep [L T-1 ~> m s-1] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! Local variables + integer :: i,j + + do j=G%jsc,G%jec ; do I=G%isc-1,G%iec + ubtav(I,j) = CS%ubtav(I,j) + enddo ; enddo + + do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + vbtav(i,J) = CS%vbtav(i,J) + enddo ; enddo + +end subroutine barotropic_get_tav + + +!> Clean up the barotropic control structure. +subroutine barotropic_end(CS) + type(barotropic_CS), intent(inout) :: CS !< Control structure to clear out. + + call destroy_BT_OBC(CS%BT_OBC) + + ! Allocated in barotropic_init, called in timestep initialization + DEALLOC_(CS%ua_polarity) ; DEALLOC_(CS%va_polarity) + DEALLOC_(CS%IDatu) ; DEALLOC_(CS%IDatv) + if (CS%bound_BT_corr) then + DEALLOC_(CS%eta_cor_bound) + endif + DEALLOC_(CS%eta_cor) + DEALLOC_(CS%frhatu) ; DEALLOC_(CS%frhatv) + + if (allocated(CS%frhatu1)) deallocate(CS%frhatu1) + if (allocated(CS%frhatv1)) deallocate(CS%frhatv1) + call deallocate_MOM_domain(CS%BT_domain) + + ! Allocated in restart registration, prior to timestep initialization + DEALLOC_(CS%ubtav) ; DEALLOC_(CS%vbtav) +end subroutine barotropic_end + +!> This subroutine is used to register any fields from MOM_barotropic.F90 +!! that should be written to or read from the restart file. +subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + + ! Local variables + type(vardesc) :: vd(3) + character(len=40) :: mdl = "MOM_barotropic" ! This module's name. + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed + IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB + + call get_param(param_file, mdl, "GRADUAL_BT_ICS", CS%gradual_BT_ICs, & + "If true, adjust the initial conditions for the "//& + "barotropic solver to the values from the layered "//& + "solution over a whole timestep instead of instantly. "//& + "This is a decent approximation to the inclusion of "//& + "sum(u dh_dt) while also correcting for truncation errors.", & + default=.false., do_not_log=.true.) + + ALLOC_(CS%ubtav(IsdB:IedB,jsd:jed)) ; CS%ubtav(:,:) = 0.0 + ALLOC_(CS%vbtav(isd:ied,JsdB:JedB)) ; CS%vbtav(:,:) = 0.0 + if (CS%gradual_BT_ICs) then + ALLOC_(CS%ubt_IC(IsdB:IedB,jsd:jed)) ; CS%ubt_IC(:,:) = 0.0 + ALLOC_(CS%vbt_IC(isd:ied,JsdB:JedB)) ; CS%vbt_IC(:,:) = 0.0 + endif + + vd(2) = var_desc("ubtav","m s-1","Time mean barotropic zonal velocity", & + hor_grid='u', z_grid='1') + vd(3) = var_desc("vbtav","m s-1","Time mean barotropic meridional velocity",& + hor_grid='v', z_grid='1') + call register_restart_pair(CS%ubtav, CS%vbtav, vd(2), vd(3), .false., restart_CS, & + conversion=US%L_T_to_m_s) + + if (CS%gradual_BT_ICs) then + vd(2) = var_desc("ubt_IC", "m s-1", & + longname="Next initial condition for the barotropic zonal velocity", & + hor_grid='u', z_grid='1') + vd(3) = var_desc("vbt_IC", "m s-1", & + longname="Next initial condition for the barotropic meridional velocity",& + hor_grid='v', z_grid='1') + call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS, & + conversion=US%L_T_to_m_s) + endif + + call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & + longname="Barotropic timestep", units="seconds", conversion=US%T_to_s) + +end subroutine register_barotropic_restarts + +!> \namespace mom_barotropic +!! +!! By Robert Hallberg, April 1994 - January 2007 +!! +!! This program contains the subroutines that time steps the +!! linearized barotropic equations. btstep is used to actually +!! time step the barotropic equations, and contains most of the +!! substance of this module. +!! +!! btstep uses a forwards-backwards based scheme to time step +!! the barotropic equations, returning the layers' accelerations due +!! to the barotropic changes in the ocean state, the final free +!! surface height (or column mass), and the volume (or mass) fluxes +!! summed through the layers and averaged over the baroclinic time +!! step. As input, btstep takes the initial 3-D velocities, the +!! inital free surface height, the 3-D accelerations of the layers, +!! and the external forcing. Everything in btstep is cast in terms +!! of anomalies, so if everything is in balance, there is explicitly +!! no acceleration due to btstep. +!! +!! The spatial discretization of the continuity equation is second +!! order accurate. A flux conservative form is used to guarantee +!! global conservation of volume. The spatial discretization of the +!! momentum equation is second order accurate. The Coriolis force +!! is written in a form which does not contribute to the energy +!! tendency and which conserves linearized potential vorticity, f/D. +!! These terms are exactly removed from the baroclinic momentum +!! equations, so the linearization of vorticity advection will not +!! degrade the overall solution. +!! +!! btcalc calculates the fractional thickness of each layer at the +!! velocity points, for later use in calculating the barotropic +!! velocities and the averaged accelerations. Harmonic mean +!! thicknesses (i.e. 2*h_L*h_R/(h_L + h_R)) are used to avoid overly +!! strong weighting of overly thin layers. This may later be relaxed +!! to use thicknesses determined from the continuity equations. +!! +!! bt_mass_source determines the real mass sources for the +!! barotropic solver, along with the corrective pseudo-fluxes that +!! keep the barotropic and baroclinic estimates of the free surface +!! height close to each other. Given the layer thicknesses and the +!! free surface height that correspond to each other, it calculates +!! a corrective mass source that is added to the barotropic continuity* +!! equation, and optionally adjusts a slowly varying correction rate. +!! Newer algorithmic changes have deemphasized the need for this, but +!! it is still here to add net water sources to the barotropic solver.* +!! +!! barotropic_init allocates and initializes any barotropic arrays +!! that have not been read from a restart file, reads parameters from +!! the inputfile, and sets up diagnostic fields. +!! +!! barotropic_end deallocates anything allocated in barotropic_init +!! or register_barotropic_restarts. +!! +!! register_barotropic_restarts is used to indicate any fields that +!! are private to the barotropic solver that need to be included in +!! the restart files, and to ensure that they are read. + +end module MOM_barotropic diff --git a/core/MOM_boundary_update.F90 b/core/MOM_boundary_update.F90 new file mode 100644 index 0000000000..75f69dc779 --- /dev/null +++ b/core/MOM_boundary_update.F90 @@ -0,0 +1,191 @@ +! This file is part of MOM6. See LICENSE.md for the license. +!> Controls where open boundary conditions are applied +module MOM_boundary_update + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_diag_mediator, only : time_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type, log_param +use MOM_grid, only : ocean_grid_type +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_open_boundary, only : ocean_obc_type, update_OBC_segment_data +use MOM_open_boundary, only : OBC_registry_type, file_OBC_CS +use MOM_open_boundary, only : register_file_OBC, file_OBC_end +use MOM_unit_scaling, only : unit_scale_type +use MOM_tracer_registry, only : tracer_registry_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use DOME_initialization, only : register_DOME_OBC +use tidal_bay_initialization, only : tidal_bay_set_OBC_data, register_tidal_bay_OBC +use tidal_bay_initialization, only : tidal_bay_OBC_CS +use Kelvin_initialization, only : Kelvin_set_OBC_data, register_Kelvin_OBC +use Kelvin_initialization, only : Kelvin_OBC_end, Kelvin_OBC_CS +use shelfwave_initialization, only : shelfwave_set_OBC_data, register_shelfwave_OBC +use shelfwave_initialization, only : shelfwave_OBC_end, shelfwave_OBC_CS +use dyed_channel_initialization, only : dyed_channel_update_flow, register_dyed_channel_OBC +use dyed_channel_initialization, only : dyed_channel_OBC_end, dyed_channel_OBC_CS + +implicit none ; private + +#include + +public call_OBC_register, OBC_register_end +public update_OBC_data + +!> The control structure for the MOM_boundary_update module +type, public :: update_OBC_CS ; private + logical :: use_files = .false. !< If true, use external files for the open boundary. + logical :: use_Kelvin = .false. !< If true, use the Kelvin wave open boundary. + logical :: use_tidal_bay = .false. !< If true, use the tidal_bay open boundary. + logical :: use_shelfwave = .false. !< If true, use the shelfwave open boundary. + logical :: use_dyed_channel = .false. !< If true, use the dyed channel open boundary. + !>@{ Pointers to the control structures for named OBC specifications + type(file_OBC_CS), pointer :: file_OBC_CSp => NULL() + type(Kelvin_OBC_CS), pointer :: Kelvin_OBC_CSp => NULL() + type(tidal_bay_OBC_CS) :: tidal_bay_OBC + type(shelfwave_OBC_CS), pointer :: shelfwave_OBC_CSp => NULL() + type(dyed_channel_OBC_CS), pointer :: dyed_channel_OBC_CSp => NULL() + !>@} +end type update_OBC_CS + +integer :: id_clock_pass !< A CPU time clock ID + +! character(len=40) :: mdl = "MOM_boundary_update" ! This module's name. + +contains + +!> The following subroutines and associated definitions provide the +!! machinery to register and call the subroutines that initialize +!! open boundary conditions. +subroutine call_OBC_register(G, GV, US, param_file, CS, OBC, tr_Reg) + 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(param_file_type), intent(in) :: param_file !< Parameter file to parse + type(update_OBC_CS), pointer :: CS !< Control structure for OBCs + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. + + ! Local variables + character(len=200) :: config + character(len=40) :: mdl = "MOM_boundary_update" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + if (associated(CS)) then + call MOM_error(WARNING, "call_OBC_register called with an associated "// & + "control structure.") + return + else ; allocate(CS) ; endif + + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "USE_FILE_OBC", CS%use_files, & + "If true, use external files for the open boundary.", & + default=.false.) + call get_param(param_file, mdl, "USE_TIDAL_BAY_OBC", CS%use_tidal_bay, & + "If true, use the tidal_bay open boundary.", & + default=.false.) + call get_param(param_file, mdl, "USE_KELVIN_WAVE_OBC", CS%use_Kelvin, & + "If true, use the Kelvin wave open boundary.", & + default=.false.) + call get_param(param_file, mdl, "USE_SHELFWAVE_OBC", CS%use_shelfwave, & + "If true, use the shelfwave open boundary.", & + default=.false.) + call get_param(param_file, mdl, "USE_DYED_CHANNEL_OBC", CS%use_dyed_channel, & + "If true, use the dyed channel open boundary.", & + default=.false.) + call get_param(param_file, mdl, "OBC_USER_CONFIG", config, & + "A string that sets how the user code is invoked to set open boundary data: \n"//& + " DOME - specified inflow on northern boundary\n"//& + " dyed_channel - supercritical with dye on the inflow boundary\n"//& + " dyed_obcs - circle_obcs with dyes on the open boundaries\n"//& + " Kelvin - barotropic Kelvin wave forcing on the western boundary\n"//& + " shelfwave - Flather with shelf wave forcing on western boundary\n"//& + " supercritical - now only needed here for the allocations\n"//& + " tidal_bay - Flather with tidal forcing on eastern boundary\n"//& + " USER - user specified", default="none", do_not_log=.true.) + + if (CS%use_files) CS%use_files = & + register_file_OBC(param_file, CS%file_OBC_CSp, US, & + OBC%OBC_Reg) + + if (trim(config) == "DOME") then + call register_DOME_OBC(param_file, US, OBC, tr_Reg) +! elseif (trim(config) == "tidal_bay") then +! elseif (trim(config) == "Kelvin") then +! elseif (trim(config) == "shelfwave") then +! elseif (trim(config) == "dyed_channel") then + endif + + if (CS%use_tidal_bay) CS%use_tidal_bay = & + register_tidal_bay_OBC(param_file, CS%tidal_bay_OBC, US, & + OBC%OBC_Reg) + if (CS%use_Kelvin) CS%use_Kelvin = & + register_Kelvin_OBC(param_file, CS%Kelvin_OBC_CSp, US, & + OBC%OBC_Reg) + if (CS%use_shelfwave) CS%use_shelfwave = & + register_shelfwave_OBC(param_file, CS%shelfwave_OBC_CSp, G, US, & + OBC%OBC_Reg) + if (CS%use_dyed_channel) CS%use_dyed_channel = & + register_dyed_channel_OBC(param_file, CS%dyed_channel_OBC_CSp, US, & + OBC%OBC_Reg) + +end subroutine call_OBC_register + +!> Calls appropriate routine to update the open boundary conditions. +subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time) + 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(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< layer thicknesses [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(update_OBC_CS), pointer :: CS !< Control structure for OBCs + type(time_type), intent(in) :: Time !< Model time + +! Something here... with CS%file_OBC_CSp? +! if (CS%use_files) & +! call update_OBC_segment_data(G, GV, OBC, tv, h, Time) + if (CS%use_tidal_bay) & + call tidal_bay_set_OBC_data(OBC, CS%tidal_bay_OBC, G, GV, US, h, Time) + if (CS%use_Kelvin) & + call Kelvin_set_OBC_data(OBC, CS%Kelvin_OBC_CSp, G, GV, US, h, Time) + if (CS%use_shelfwave) & + call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, GV, US, h, Time) + if (CS%use_dyed_channel) & + call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, GV, US, Time) + if (OBC%any_needs_IO_for_data .or. OBC%add_tide_constituents) & + call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + +end subroutine update_OBC_data + +!> Clean up the OBC registry. +subroutine OBC_register_end(CS) + type(update_OBC_CS), pointer :: CS !< Control structure for OBCs + + if (CS%use_files) call file_OBC_end(CS%file_OBC_CSp) + if (CS%use_Kelvin) call Kelvin_OBC_end(CS%Kelvin_OBC_CSp) + + if (associated(CS)) deallocate(CS) +end subroutine OBC_register_end + +!> \namespace mom_boundary_update +!! This module updates the open boundary arrays when time-varying. +!! It caused a circular dependency with the tidal_bay and other setups when in +!! MOM_open_boundary. +!! +!! A small fragment of the grid is shown below: +!! +!! j+1 x ^ x ^ x At x: q, CoriolisBu +!! j+1 > o > o > At ^: v, tauy +!! j x ^ x ^ x At >: u, taux +!! j > o > o > At o: h, bathyT, buoy, tr, T, S, Rml, ustar +!! j-1 x ^ x ^ x +!! i-1 i i+1 At x & ^: +!! i i+1 At > & o: +!! +!! The boundaries always run through q grid points (x). + +end module MOM_boundary_update diff --git a/core/MOM_check_scaling.F90 b/core/MOM_check_scaling.F90 new file mode 100644 index 0000000000..2841514924 --- /dev/null +++ b/core/MOM_check_scaling.F90 @@ -0,0 +1,235 @@ +!> This module is used to check the dimensional scaling factors used by the MOM6 ocean model +module MOM_check_scaling + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, assert, MOM_get_verbosity +use MOM_unique_scales, only : check_scaling_uniqueness, scales_to_powers +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +public check_MOM6_scaling_factors + +contains + +!> Evaluate whether the dimensional scaling factors provide unique tests for all of the combinations +!! of dimensions that are used in MOM6 (or perhaps widely used), and if they are not unique, explore +!! whether another combination of scaling factors can be found that is unique or has less common +!! cases with coinciding scaling. +subroutine check_MOM6_scaling_factors(GV, US) + type(verticalGrid_type), pointer :: GV !< The container for vertical grid data + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + integer, parameter :: ndims = 8 ! The number of rescalable dimensional factors. + real, dimension(ndims) :: scales ! An array of scaling factors for each of the basic units [various]. + integer, dimension(ndims) :: scale_pow2 ! The powers of 2 that give each element of scales. + character(len=2), dimension(ndims) :: key + integer, allocatable :: weights(:) + character(len=80), allocatable :: descriptions(:) + integer :: n, ns, max_pow + + ! If no scaling is being done, simply return. + if ((US%Z_to_m == 1.) .and. (GV%H_to_MKS == 1.) .and. (US%L_to_m == 1.) .and. & + (US%T_to_s == 1.) .and. (US%R_to_kg_m3 == 1.) .and. (US%Q_to_J_kg == 1.) .and. & + (US%C_to_degC == 1.) .and. (US%S_to_ppt == 1.)) return + + ! Set the names and scaling factors of the dimensions being rescaled. + key(:) = ["Z", "H", "L", "T", "R", "Q", "C", "S"] + scales(:) = (/ US%Z_to_m, GV%H_to_MKS, US%L_to_m, US%T_to_s, US%R_to_kg_m3, US%Q_to_J_kg, & + US%C_to_degC, US%S_to_ppt/) + call scales_to_powers(scales, scale_pow2) + max_pow = 40 ! 60 + + ! The first call is just to find out how many elements are in the list of scaling combinations. + call compose_dimension_list(ns, descriptions, weights) + + allocate(descriptions(ns)) + do n=1,ns ; descriptions(n) = "" ; enddo + allocate(weights(ns), source=0) + ! This call records all the list of powers, the descriptions, and their weights. + call compose_dimension_list(ns, descriptions, weights) + + call check_scaling_uniqueness("MOM6", descriptions, weights, key, scale_pow2, max_pow) + + deallocate(weights) + deallocate(descriptions) + +end subroutine check_MOM6_scaling_factors + + +!> This routine composes a list of the commonly used dimensional scaling factors in the MOM6 +!! code, along with weights reflecting the frequency of their occurrence in the MOM6 code or +!! other considerations of how likely the variables are be used. +subroutine compose_dimension_list(ns, des, wts) + integer, intent(out) :: ns !< The running sum of valid descriptions + character(len=*), allocatable, intent(inout) :: des(:) !< The unit descriptions that have been converted + integer, allocatable, intent(inout) :: wts(:) !< A list of the integer weights for each scaling factor, + !! perhaps the number of times it occurs in the MOM6 code. + + ns = 0 + ! Accumulate a list of units used in MOM6, in approximate descending order of frequency of occurrence in + ! doxygen comments (i.e., arguments and elements in types), excluding the code in the user, ice_shelf and + ! framework directories and the passive tracer packages. + call add_scaling(ns, des, wts, "[H ~> m or kg m-2]", 716) ! Layer thicknesses + call add_scaling(ns, des, wts, "[L T-1 ~> m s-1]", 264) ! Horizontal velocities + call add_scaling(ns, des, wts, "[Z ~> m]", 244) ! Depths and vertical distance + call add_scaling(ns, des, wts, "[T ~> s]", 154) ! Time intervals + call add_scaling(ns, des, wts, "[S ~> ppt]", 135) ! Salinities + call add_scaling(ns, des, wts, "[C ~> degC]", 135) ! Temperatures + call add_scaling(ns, des, wts, "[R L2 T-2 ~> Pa]", 133) ! Dynamic pressure + ! call add_scaling(ns, des, wts, "[R L2 T-2 ~> J m-3]") ! Energy density + call add_scaling(ns, des, wts, "[Z2 T-1 ~> m2 s-1]", 132) ! Vertical viscosities and diffusivities + call add_scaling(ns, des, wts, "[R ~> kg m-3]", 122) ! Densities + + call add_scaling(ns, des, wts, "[H L2 T-1 ~> m3 s-1 or kg s-1]", 97) ! Volume or mass transports + call add_scaling(ns, des, wts, "[H L2 ~> m3 or kg]", 91) ! Cell volumes or masses + call add_scaling(ns, des, wts, "[L T-2 ~> m s-2]", 82) ! Horizontal accelerations + call add_scaling(ns, des, wts, "[T-1 ~> s-1]", 67) ! Rates + call add_scaling(ns, des, wts, "[Z T-1 ~> m s-1]", 56) ! Friction velocities and viscous coupling + call add_scaling(ns, des, wts, "[Q R Z T-1 ~> W m-2]", 42) ! Vertical heat fluxes + call add_scaling(ns, des, wts, "[L2 T-1 ~> m2 s-1]", 45) ! Horizontal viscosity or diffusivity + call add_scaling(ns, des, wts, "[L2 T-2 ~> m2 s-2]", 37) ! Resolved kinetic energy per unit mass + call add_scaling(ns, des, wts, "[L ~> m]", 35) ! Horizontal distances + call add_scaling(ns, des, wts, "[T-2 ~> s-2]", 33) ! Squared shears and buoyancy frequency + + call add_scaling(ns, des, wts, "[R Z L T-2 ~> Pa]", 33) ! Wind stresses + call add_scaling(ns, des, wts, "[H L ~> m2 or kg m-1]", 32) ! Lateral cell face areas + call add_scaling(ns, des, wts, "[L2 ~> m2]", 31) ! Horizontal areas + call add_scaling(ns, des, wts, "[R C-1 ~> kg m-3 degC-1]", 26) ! Thermal expansion coefficients + call add_scaling(ns, des, wts, "[L2 Z-1 T-2 ~> m s-2]", 26) ! Gravitational acceleration + call add_scaling(ns, des, wts, "[R S-1 ~> kg m-3 ppt-1]", 23) ! Haline contraction coefficients + call add_scaling(ns, des, wts, "[R Z3 T-3 ~> W m-2]", 23) ! Integrated turbulent kinetic energy sources + call add_scaling(ns, des, wts, "[R Z T-1 ~> kg m-2 s-1]", 19) ! Vertical mass fluxes + call add_scaling(ns, des, wts, "[C H ~> degC m or degC kg m-2]", 17) ! Heat content + call add_scaling(ns, des, wts, "[H-1 ~> m-1 or m2 kg-1]", 17) ! Inverse cell thicknesses + + call add_scaling(ns, des, wts, "[Z-1 ~> m-1]", 14) ! Inverse vertical distances + call add_scaling(ns, des, wts, "[R-1 ~> m3 kg-1]", 14) ! Specific volumes + call add_scaling(ns, des, wts, "[Z L-1 ~> nondim]", 12) ! Slopes + call add_scaling(ns, des, wts, "[L-1 ~> m-1]", 12) ! Inverse horizontal distances + call add_scaling(ns, des, wts, "[L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]", 12) ! pbce or gtot + call add_scaling(ns, des, wts, "[R Z ~> kg m-2]", 11) ! Layer or column mass loads + call add_scaling(ns, des, wts, "[Z L2 T-2 ~> m3 s-2]", 11) ! Integrated energy per unit mass + call add_scaling(ns, des, wts, "[R Z3 T-2 ~> J m-2]", 11) ! Integrated turbulent kinetic energy density + call add_scaling(ns, des, wts, "[H T-1 ~> m s-1 or kg m-2 s-1]", 9) ! Vertical thickness fluxes + call add_scaling(ns, des, wts, "[L-1 T-1 ~> m-1 s-1]", 9) ! Laplacian of velocity + + call add_scaling(ns, des, wts, "[Z3 T-3 ~> m3 s-3]", 9) ! Integrated turbulent kinetic energy sources + call add_scaling(ns, des, wts, "[S H ~> ppt m or ppt kg m-2]", 8) ! Depth integrated salinity + call add_scaling(ns, des, wts, "[Z2 T-2 ~> m2 s-2]", 8) ! Turbulent kinetic energy + call add_scaling(ns, des, wts, "[R L2 Z T-2 ~> Pa m]", 7) ! Vertically integrated pressure anomalies + call add_scaling(ns, des, wts, "[Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1]", 7) ! (TKE_to_Kd) + call add_scaling(ns, des, wts, "[L4 T-1 ~> m4 s-1]", 7) ! Biharmonic viscosity + call add_scaling(ns, des, wts, "[L3 ~> m3]", 7) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[L2 T-3 ~> m2 s-3]", 7) ! Buoyancy flux or MEKE sources [L2 T-3 ~> W kg-1] + call add_scaling(ns, des, wts, "[H2 ~> m2 or kg2 m-4]", 7) ! Squared layer thicknesses + call add_scaling(ns, des, wts, "[C H T-1 ~> degC m s-1 or degC kg m-2 s-1]", 7) ! vertical heat fluxes + + call add_scaling(ns, des, wts, "[L-2 ~> m-2]", 6) ! Inverse areas + call add_scaling(ns, des, wts, "[R Z L2 T-3 ~> W m-2]", 6) ! Energy sources, including for MEKE + call add_scaling(ns, des, wts, "[Z2 T-3 ~> m2 s-3]", 5) ! Certain buoyancy fluxes + call add_scaling(ns, des, wts, "[Z2 ~> m2]", 5) ! Squared vertical distances + call add_scaling(ns, des, wts, "[S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1]", 5) ! vertical salinity fluxes + call add_scaling(ns, des, wts, "[R-1 C-1 ~> m3 kg-1 degC-1]", 5) ! Specific volume temperature gradient + call add_scaling(ns, des, wts, "[R-1 S-1 ~> m3 kg-1 ppt-1]", 4) ! Specific volume salnity gradient + call add_scaling(ns, des, wts, "[Q R Z ~> J m-2]", 4) ! time-integrated frazil heat flux + call add_scaling(ns, des, wts, "[Z C-1 ~> m degC-1]", 4) ! Inverse temperature gradients + call add_scaling(ns, des, wts, "[Z S-1 ~> m ppt-1]", 4) ! Inverse salinity gradients + + call add_scaling(ns, des, wts, "[R Z3 T-2 H-1 ~> J m-3 or J kg-1]", 4) ! Partial derivatives of energy + call add_scaling(ns, des, wts, "[R Z3 T-2 S-1 ~> J m-2 ppt-1]", 4) ! Sensitity of energy change to salinity + call add_scaling(ns, des, wts, "[R Z3 T-2 C-1 ~> J m-2 degC-1]", 4) ! Sensitity of energy change to temperature + call add_scaling(ns, des, wts, "[R L4 T-4 ~> Pa m2 s-2]", 4) ! Integral in geopotential of pressure + call add_scaling(ns, des, wts, "[Q ~> J kg-1]", 4) ! Latent heats + call add_scaling(ns, des, wts, "[Q C-1 ~> J kg-1 degC-1]", 4) ! Heat capacity + call add_scaling(ns, des, wts, "[L-3 ~> m-3]", 4) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[L2 Z-2 T-2 ~> s-2]", 4) ! Buoyancy frequency in some params. + call add_scaling(ns, des, wts, "[H R ~> kg m-2 or kg2 m-5]", 4) ! Layer-integrated density + call add_scaling(ns, des, wts, "[H L T-1 ~> m2 s-1 or kg m-1 s-1]", 4) ! Layer integrated velocities + + call add_scaling(ns, des, wts, "[H T2 L-1 ~> s2 or kg s2 m-3]", 4) ! BT_cont_type face curvature fit + call add_scaling(ns, des, wts, "[H L-1 ~> nondim or kg m-3]", 4) ! BT_cont_type face curvature fit + call add_scaling(ns, des, wts, "[C2 ~> degC2]", 4) ! Squared temperature anomalies + call add_scaling(ns, des, wts, "[S2 ~> ppt2]", 3) ! Squared salinity anomalies + call add_scaling(ns, des, wts, "[C S ~> degC ppt]", 3) ! Covariance of temperature and salinity anomalies + call add_scaling(ns, des, wts, "[S R Z ~> gSalt m-2]", 3) ! Total ocean column salt + call add_scaling(ns, des, wts, "[C R Z ~> degC kg m-2]", 3) ! Total ocean column temperature + call add_scaling(ns, des, wts, "[Pa T2 R-1 L-2 ~> 1]", 3) ! Pressure conversions + call add_scaling(ns, des, wts, "[Z H-1 ~> nondim or m3 kg-1]", 3) ! Thickness to height conversion + call add_scaling(ns, des, wts, "[R Z2 T-2 ~> J m-3]", 3) ! Potential energy height derivatives + + call add_scaling(ns, des, wts, "[H-2 ~> m-2 or m4 kg-2]", 3) ! Mixed layer local work variables + call add_scaling(ns, des, wts, "[C S-1 ~> degC ppt-1]", 2) ! T / S gauge transformation + call add_scaling(ns, des, wts, "[R S-2 ~> kg m-3 ppt-2]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[R C-2 ~> kg m-3 degC-2]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[R S-1 C-1 ~> kg m-3 ppt-1 degC-1]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[T2 L-2 ~> s2 m-2]", 2) ! Inverse velocities squared + call add_scaling(ns, des, wts, "[R Z2 T-3 ~> W m-3]", 2) ! Kinetic energy dissipation rates + call add_scaling(ns, des, wts, "[R H-1 ~> kg m-4 or m-1]", 2) ! Vertical density gradients + + call add_scaling(ns, des, wts, "[L4 ~> m4]", 2) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[Z L T-1 ~> m2 s-1]", 2) ! Layer integrated velocities + call add_scaling(ns, des, wts, "[C Z ~> degC m]", 2) ! Depth integrated temperature + call add_scaling(ns, des, wts, "[S Z ~> ppt m]", 1) ! Layer integrated salinity + call add_scaling(ns, des, wts, "[T L4 ~> s m4]", 2) ! Biharmonic metric dependent constant + call add_scaling(ns, des, wts, "[L6 ~> m6]", 2) ! Biharmonic Leith metric dependent constant + call add_scaling(ns, des, wts, "[L4 Z-1 T-1 ~> m3 s-1]", 2) ! Rigidity of ice + call add_scaling(ns, des, wts, "[L4 Z-2 T-1 ~> m2 s-1]", 1) ! Ice rigidity term + call add_scaling(ns, des, wts, "[R-1 Z-1 ~> m2 kg-1]", 1) ! Inverse of column mass + call add_scaling(ns, des, wts, "[Z-2 ~> m-2]", 1) ! Inverse of denominator in some weighted averages + + call add_scaling(ns, des, wts, "[R Z2 T-1 ~> J s m-3]", 1) ! River mixing term + call add_scaling(ns, des, wts, "[R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]", 1) ! Thickness to pressure conversion + call add_scaling(ns, des, wts, "[Z T2 R-1 L-2 ~> m Pa-1]", 1) ! Atmospheric pressure SSH correction + call add_scaling(ns, des, wts, "[T Z ~> s m] ", 1) ! Time integrated SSH + call add_scaling(ns, des, wts, "[Z-1 T-1 ~> m-1 s-1]", 1) ! barotropic PV + call add_scaling(ns, des, wts, "[L2 T ~> m2 s]", 1) ! Greatbatch & Lamb 90 coefficient + call add_scaling(ns, des, wts, "[Z L2 T-1 ~> m3 s-1]", 1) ! Overturning (GM) streamfunction + call add_scaling(ns, des, wts, "[kg H-1 L-2 ~> kg m-3 or 1]", 1) ! Diagnostic conversions to mass + call add_scaling(ns, des, wts, "[S-1 ~> ppt-1]", 1) ! Unscaling salinity + call add_scaling(ns, des, wts, "[C-1 ~> degC-1]", 1) ! Unscaling temperature + + call add_scaling(ns, des, wts, "[R Z H-1 ~> kg m-3 or 1] ", 1) ! A unit conversion factor + call add_scaling(ns, des, wts, "[H R-1 Z-1 ~> m3 kg-2 or 1]", 1) ! A unit conversion factor + call add_scaling(ns, des, wts, "[H Z-1 ~> 1 or kg m-3]", 1) ! A unit conversion factor + call add_scaling(ns, des, wts, "[m T s-1 L-1 ~> 1]", 1) ! A unit conversion factor + +end subroutine compose_dimension_list + +!> Augment the count the valid unit descriptions, and add the provided description and its weight +!! to the end of the list if that list is allocated. +subroutine add_scaling(ns, descs, wts, scaling, weight) + integer, intent(inout) :: ns !< The running sum of valid descriptions. + character(len=*), allocatable, intent(inout) :: descs(:) !< The unit descriptions that have been converted + integer, allocatable, intent(inout) :: wts(:) !< A list of the integers for each scaling + character(len=*), intent(in) :: scaling !< The unit description that will be converted + integer, optional, intent(in) :: weight !< An optional weight or occurrence count + !! for this unit description, 1 by default. + + integer :: iend + + iend = index(scaling, "~>") + if (iend <= 1) then + call MOM_mesg("No scaling indicator ~> found for "//trim(scaling)) + else + ! Count and perhaps store this description and its weight. + ns = ns + 1 + if (allocated(descs)) descs(ns) = scaling + if (allocated(wts)) then + wts(ns) = 1 ; if (present(weight)) wts(ns) = weight + endif + endif + +end subroutine add_scaling + +end module MOM_check_scaling diff --git a/core/MOM_checksum_packages.F90 b/core/MOM_checksum_packages.F90 new file mode 100644 index 0000000000..4a9df04c4d --- /dev/null +++ b/core/MOM_checksum_packages.F90 @@ -0,0 +1,393 @@ +!> Provides routines that do checksums of groups of MOM variables +module MOM_checksum_packages + +! This file is part of MOM6. See LICENSE.md for the license. + +! This module provides several routines that do check-sums of groups +! of variables in the various dynamic solver routines. + +use MOM_coms, only : min_across_PEs, max_across_PEs, reproducing_sum +use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_mesg, is_root_pe +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, surface +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +public MOM_state_chksum, MOM_thermo_chksum, MOM_accel_chksum +public MOM_state_stats, MOM_surface_chksum + +!> Write out checksums of the MOM6 state variables +interface MOM_state_chksum + module procedure MOM_state_chksum_5arg + module procedure MOM_state_chksum_3arg +end interface + +#include + +!> A type for storing statistica about a variable +type :: stats ; private + real :: minimum = 1.E34 !< The minimum value [degC] or [ppt] or other units + real :: maximum = -1.E34 !< The maximum value [degC] or [ppt] or other units + real :: average = 0. !< The average value [degC] or [ppt] or other units +end type stats + +contains + +! ============================================================================= + +!> Write out chksums for the model's basic state variables, including transports. +subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, symmetric, omit_corners, vel_scale) + character(len=*), & + intent(in) :: mesg !< A message that appears on the chksum lines. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1] or other units. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1] or other units. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: uh !< Volume flux through zonal faces = u*h*dy + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vh !< Volume flux through meridional faces = v*h*dx + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric + !! computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: vel_scale !< The scaling factor to convert velocities to [m s-1] + + real :: scale_vel ! The scaling factor to convert velocities to [m s-1] + logical :: sym + integer :: hs + + ! Note that for the chksum calls to be useful for reproducing across PE + ! counts, there must be no redundant points, so all variables use is..ie + ! and js...je as their extent. + hs = 1 ; if (present(haloshift)) hs=haloshift + sym = .false. ; if (present(symmetric)) sym=symmetric + scale_vel = US%L_T_to_m_s ; if (present(vel_scale)) scale_vel = vel_scale + + call uvchksum(mesg//" [uv]", u, v, G%HI, haloshift=hs, symmetric=sym, & + omit_corners=omit_corners, scale=scale_vel) + call hchksum(h, mesg//" h", G%HI, haloshift=hs, omit_corners=omit_corners, scale=GV%H_to_MKS) + call uvchksum(mesg//" [uv]h", uh, vh, G%HI, haloshift=hs, symmetric=sym, & + omit_corners=omit_corners, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) +end subroutine MOM_state_chksum_5arg + +! ============================================================================= + +!> Write out chksums for the model's basic state variables. +subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric, omit_corners) + character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] or [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] or [m s-1].. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type, which is + !! used to rescale u and v if present. + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully + !! symmetric computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + + integer :: hs + logical :: sym + + ! Note that for the chksum calls to be useful for reproducing across PE + ! counts, there must be no redundant points, so all variables use is..ie + ! and js...je as their extent. + hs = 1 ; if (present(haloshift)) hs = haloshift + sym = .false. ; if (present(symmetric)) sym = symmetric + call uvchksum(mesg//" u", u, v, G%HI, haloshift=hs, symmetric=sym, & + omit_corners=omit_corners, scale=US%L_T_to_m_s) + call hchksum(h, mesg//" h",G%HI, haloshift=hs, omit_corners=omit_corners, scale=GV%H_to_MKS) +end subroutine MOM_state_chksum_3arg + +! ============================================================================= + +!> Write out chksums for the model's thermodynamic state variables. +subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift, omit_corners) + character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + + integer :: hs + hs=1 ; if (present(haloshift)) hs=haloshift + + if (associated(tv%T)) & + call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%C_to_degC) + if (associated(tv%S)) & + call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%S_to_ppt) + if (associated(tv%frazil)) & + call hchksum(tv%frazil, mesg//" frazil", G%HI, haloshift=hs, omit_corners=omit_corners, & + scale=US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m) + if (associated(tv%salt_deficit)) & + call hchksum(tv%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, omit_corners=omit_corners, & + scale=US%S_to_ppt*US%RZ_to_kg_m2) + if (associated(tv%varT)) & + call hchksum(tv%varT, mesg//" varT", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%C_to_degC**2) + if (associated(tv%varS)) & + call hchksum(tv%varS, mesg//" varS", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%S_to_ppt**2) + if (associated(tv%covarTS)) & + call hchksum(tv%covarTS, mesg//" covarTS", G%HI, haloshift=hs, omit_corners=omit_corners, & + scale=US%S_to_ppt*US%C_to_degC) + +end subroutine MOM_thermo_chksum + +! ============================================================================= + +!> Write out chksums for the ocean surface variables. +subroutine MOM_surface_chksum(mesg, sfc_state, G, US, haloshift, symmetric) + character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. + type(surface), intent(inout) :: sfc_state !< transparent ocean surface state structure + !! shared with the calling routine data in this + !! structure is intent out. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric + !! computational domain. + + integer :: hs + logical :: sym + + sym = .false. ; if (present(symmetric)) sym = symmetric + hs = 1 ; if (present(haloshift)) hs = haloshift + + if (allocated(sfc_state%SST)) call hchksum(sfc_state%SST, mesg//" SST", G%HI, haloshift=hs, & + scale=US%C_to_degC) + if (allocated(sfc_state%SSS)) call hchksum(sfc_state%SSS, mesg//" SSS", G%HI, haloshift=hs, & + scale=US%S_to_ppt) + if (allocated(sfc_state%sea_lev)) call hchksum(sfc_state%sea_lev, mesg//" sea_lev", G%HI, & + haloshift=hs, scale=US%Z_to_m) + if (allocated(sfc_state%Hml)) call hchksum(sfc_state%Hml, mesg//" Hml", G%HI, haloshift=hs, & + scale=US%Z_to_m) + if (allocated(sfc_state%u) .and. allocated(sfc_state%v)) & + call uvchksum(mesg//" SSU", sfc_state%u, sfc_state%v, G%HI, haloshift=hs, symmetric=sym, & + scale=US%L_T_to_m_s) + if (allocated(sfc_state%frazil)) call hchksum(sfc_state%frazil, mesg//" frazil", G%HI, & + haloshift=hs, scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + +end subroutine MOM_surface_chksum + +! ============================================================================= + +!> Write out chksums for the model's accelerations +subroutine MOM_accel_chksum(mesg, CAu, CAv, PFu, PFv, diffu, diffv, G, GV, US, pbce, & + u_accel_bt, v_accel_bt, symmetric) + character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: CAu !< Zonal acceleration due to Coriolis + !! and momentum advection terms [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: CAv !< Meridional acceleration due to Coriolis + !! and momentum advection terms [L T-2 ~> m s-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: PFu !< Zonal acceleration due to pressure gradients + !! (equal to -dM/dx) [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: PFv !< Meridional acceleration due to pressure gradients + !! (equal to -dM/dy) [L T-2 ~> m s-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: diffu !< Zonal acceleration due to convergence of the + !! along-isopycnal stress tensor [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: diffv !< Meridional acceleration due to convergence of + !! the along-isopycnal stress tensor [L T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: pbce !< The baroclinic pressure anomaly in each layer + !! due to free surface height anomalies + !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: u_accel_bt !< The zonal acceleration from terms in the + !! barotropic solver [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(in) :: v_accel_bt !< The meridional acceleration from terms in + !! the barotropic solver [L T-2 ~> m s-2]. + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric + !! computational domain. + + logical :: sym + + sym=.false.; if (present(symmetric)) sym=symmetric + + ! Note that for the chksum calls to be useful for reproducing across PE + ! counts, there must be no redundant points, so all variables use is..ie + ! and js...je as their extent. + call uvchksum(mesg//" CA[uv]", CAu, CAv, G%HI, haloshift=0, symmetric=sym, scale=US%L_T2_to_m_s2) + call uvchksum(mesg//" PF[uv]", PFu, PFv, G%HI, haloshift=0, symmetric=sym, scale=US%L_T2_to_m_s2) + call uvchksum(mesg//" diffu", diffu, diffv, G%HI,haloshift=0, symmetric=sym, scale=US%L_T2_to_m_s2) + if (present(pbce)) & + call hchksum(pbce, mesg//" pbce",G%HI,haloshift=0, scale=GV%m_to_H*US%L_T_to_m_s**2) + if (present(u_accel_bt) .and. present(v_accel_bt)) & + call uvchksum(mesg//" [uv]_accel_bt", u_accel_bt, v_accel_bt, G%HI,haloshift=0, symmetric=sym, & + scale=US%L_T2_to_m_s2) +end subroutine MOM_accel_chksum + +! ============================================================================= + +!> Monitor and write out statistics for the model's state variables. +subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, permitDiminishing) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, pointer, dimension(:,:,:), & + intent(in) :: Temp !< Temperature [C ~> degC]. + real, pointer, dimension(:,:,:), & + intent(in) :: Salt !< Salinity [S ~> ppt]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, optional, intent(in) :: allowChange !< do not flag an error + !! if the statistics change. + logical, optional, intent(in) :: permitDiminishing !< do not flag error if the + !! extrema are diminishing. + + ! Local variables + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: & + tmp_A, & ! The area per cell [m2] (unscaled to permit reproducing sum). + tmp_V, & ! The column-integrated volume [m3] (unscaled to permit reproducing sum) + tmp_T, & ! The column-integrated temperature [degC m3] (unscaled to permit reproducing sum) + tmp_S ! The column-integrated salinity [ppt m3] (unscaled to permit reproducing sum) + real :: Vol, dV ! The total ocean volume and its change [m3] (unscaled to permit reproducing sum). + real :: Area ! The total ocean surface area [m2] (unscaled to permit reproducing sum). + real :: h_minimum ! The minimum layer thicknesses [H ~> m or kg m-2] + real :: T_scale ! The scaling conversion factor for temperatures [degC C-1 ~> 1] + real :: S_scale ! The scaling conversion factor for salinities [ppt S-1 ~> 1] + logical :: do_TS ! If true, evaluate statistics for temperature and salinity + type(stats) :: T, delT ! Temperature statistics in unscaled units [degC] + type(stats) :: S, delS ! Salinity statistics in unscaled units [ppt] + + ! NOTE: save data is not normally allowed but we use it for debugging purposes here on the + ! assumption we will not turn this on with threads + type(stats), save :: oldT, oldS + logical, save :: firstCall = .true. + real, save :: oldVol ! The previous total ocean volume [m3] + + character(len=80) :: lMsg + integer :: is, ie, js, je, nz, i, j, k + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + do_TS = associated(Temp) .and. associated(Salt) + + tmp_A(:,:) = 0.0 + tmp_V(:,:) = 0.0 + tmp_T(:,:) = 0.0 + tmp_S(:,:) = 0.0 + + T_scale = US%C_to_degC ; S_scale = US%S_to_ppt + + ! First collect local stats + do j=js,je ; do i=is,ie + tmp_A(i,j) = tmp_A(i,j) + US%L_to_m**2*G%areaT(i,j) + enddo ; enddo + T%minimum = 1.E34 ; T%maximum = -1.E34 ; T%average = 0. + S%minimum = 1.E34 ; S%maximum = -1.E34 ; S%average = 0. + h_minimum = 1.E34*GV%m_to_H + do k=1,nz ; do j=js,je ; do i=is,ie + if (G%mask2dT(i,j)>0.) then + dV = US%L_to_m**2*G%areaT(i,j)*GV%H_to_m*h(i,j,k) + tmp_V(i,j) = tmp_V(i,j) + dV + if (do_TS .and. h(i,j,k)>0.) then + T%minimum = min( T%minimum, T_scale*Temp(i,j,k) ) ; T%maximum = max( T%maximum, T_scale*Temp(i,j,k) ) + T%average = T%average + dV*T_scale*Temp(i,j,k) + S%minimum = min( S%minimum, S_scale*Salt(i,j,k) ) ; S%maximum = max( S%maximum, S_scale*Salt(i,j,k) ) + S%average = S%average + dV*S_scale*Salt(i,j,k) + tmp_T(i,j) = tmp_T(i,j) + dV*T_scale*Temp(i,j,k) + tmp_S(i,j) = tmp_S(i,j) + dV*S_scale*Salt(i,j,k) + endif + if (h_minimum > h(i,j,k)) h_minimum = h(i,j,k) + endif + enddo ; enddo ; enddo + Area = reproducing_sum( tmp_A ) ; Vol = reproducing_sum( tmp_V ) + if (do_TS) then + call min_across_PEs( T%minimum ) ; call max_across_PEs( T%maximum ) + call min_across_PEs( S%minimum ) ; call max_across_PEs( S%maximum ) + T%average = reproducing_sum( tmp_T ) ; S%average = reproducing_sum( tmp_S ) + T%average = T%average / Vol ; S%average = S%average / Vol + endif + if (is_root_pe()) then + if (.not.firstCall) then + dV = Vol - oldVol + delT%minimum = T%minimum - oldT%minimum ; delT%maximum = T%maximum - oldT%maximum + delT%average = T%average - oldT%average + delS%minimum = S%minimum - oldS%minimum ; delS%maximum = S%maximum - oldS%maximum + delS%average = S%average - oldS%average + write(lMsg(1:80),'(2(a,es12.4))') 'Mean thickness =', Vol/Area,' frac. delta=',dV/Vol + call MOM_mesg(lMsg//trim(mesg)) + if (do_TS) then + write(lMsg(1:80),'(a,3es12.4)') 'Temp min/mean/max =',T%minimum,T%average,T%maximum + call MOM_mesg(lMsg//trim(mesg)) + write(lMsg(1:80),'(a,3es12.4)') 'delT min/mean/max =',delT%minimum,delT%average,delT%maximum + call MOM_mesg(lMsg//trim(mesg)) + write(lMsg(1:80),'(a,3es12.4)') 'Salt min/mean/max =',S%minimum,S%average,S%maximum + call MOM_mesg(lMsg//trim(mesg)) + write(lMsg(1:80),'(a,3es12.4)') 'delS min/mean/max =',delS%minimum,delS%average,delS%maximum + call MOM_mesg(lMsg//trim(mesg)) + endif + else + write(lMsg(1:80),'(a,es12.4)') 'Mean thickness =', Vol/Area + call MOM_mesg(lMsg//trim(mesg)) + if (do_TS) then + write(lMsg(1:80),'(a,3es12.4)') 'Temp min/mean/max =', T%minimum, T%average, T%maximum + call MOM_mesg(lMsg//trim(mesg)) + write(lMsg(1:80),'(a,3es12.4)') 'Salt min/mean/max =', S%minimum, S%average, S%maximum + call MOM_mesg(lMsg//trim(mesg)) + endif + endif + endif + firstCall = .false. ; oldVol = Vol + oldT%minimum = T%minimum ; oldT%maximum = T%maximum ; oldT%average = T%average + oldS%minimum = S%minimum ; oldS%maximum = S%maximum ; oldS%average = S%average + + if (do_TS .and. T%minimum<-5.0) then + do j=js,je ; do i=is,ie + if (minval(T_scale*Temp(i,j,:)) == T%minimum) then + write(0,'(a,2f12.5)') 'x,y=', G%geoLonT(i,j), G%geoLatT(i,j) + write(0,'(a3,3a12)') 'k','h','Temp','Salt' + do k = 1, nz + write(0,'(i3,3es12.4)') k, h(i,j,k), T_scale*Temp(i,j,k), S_scale*Salt(i,j,k) + enddo + stop 'Extremum detected' + endif + enddo ; enddo + endif + + if (h_minimum<0.0) then + do j=js,je ; do i=is,ie + if (minval(h(i,j,:)) == h_minimum) then + write(0,'(a,2f12.5)') 'x,y=',G%geoLonT(i,j),G%geoLatT(i,j) + write(0,'(a3,3a12)') 'k','h','Temp','Salt' + do k = 1, nz + write(0,'(i3,3es12.4)') k, h(i,j,k), T_scale*Temp(i,j,k), S_scale*Salt(i,j,k) + enddo + stop 'Negative thickness detected' + endif + enddo ; enddo + endif + +end subroutine MOM_state_stats + +end module MOM_checksum_packages diff --git a/core/MOM_continuity.F90 b/core/MOM_continuity.F90 new file mode 100644 index 0000000000..14582d1eb5 --- /dev/null +++ b/core/MOM_continuity.F90 @@ -0,0 +1,30 @@ +!> Solve the layer continuity equation. +module MOM_continuity + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_continuity_PPM, only : continuity=>continuity_PPM +use MOM_continuity_PPM, only : continuity_stencil=>continuity_PPM_stencil +use MOM_continuity_PPM, only : continuity_init=>continuity_PPM_init +use MOM_continuity_PPM, only : continuity_CS=>continuity_PPM_CS +use MOM_continuity_PPM, only : continuity_fluxes, continuity_adjust_vel +use MOM_continuity_PPM, only : zonal_mass_flux, meridional_mass_flux +use MOM_continuity_PPM, only : zonal_edge_thickness, meridional_edge_thickness +use MOM_continuity_PPM, only : continuity_zonal_convergence, continuity_merdional_convergence +use MOM_continuity_PPM, only : zonal_flux_thickness, meridional_flux_thickness +use MOM_continuity_PPM, only : zonal_BT_mass_flux, meridional_BT_mass_flux +use MOM_continuity_PPM, only : set_continuity_loop_bounds, cont_loop_bounds_type + +implicit none ; private + +! These are direct pass-throughs of routines in continuity_PPM +public continuity, continuity_init, continuity_stencil, continuity_CS +public continuity_fluxes, continuity_adjust_vel +public zonal_mass_flux, meridional_mass_flux +public zonal_edge_thickness, meridional_edge_thickness +public continuity_zonal_convergence, continuity_merdional_convergence +public zonal_flux_thickness, meridional_flux_thickness +public zonal_BT_mass_flux, meridional_BT_mass_flux +public set_continuity_loop_bounds, cont_loop_bounds_type + +end module MOM_continuity diff --git a/core/MOM_continuity_PPM.F90 b/core/MOM_continuity_PPM.F90 new file mode 100644 index 0000000000..ba8c234bc2 --- /dev/null +++ b/core/MOM_continuity_PPM.F90 @@ -0,0 +1,2810 @@ +!> Solve the layer continuity equation using the PPM method for layer fluxes. +module MOM_continuity_PPM + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_diag_mediator, only : time_type, diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, OBC_NONE +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : BT_cont_type, porous_barrier_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public continuity_PPM, continuity_PPM_init, continuity_PPM_stencil +public continuity_fluxes, continuity_adjust_vel +public zonal_mass_flux, meridional_mass_flux +public zonal_edge_thickness, meridional_edge_thickness +public continuity_zonal_convergence, continuity_merdional_convergence +public zonal_flux_thickness, meridional_flux_thickness +public zonal_BT_mass_flux, meridional_BT_mass_flux +public set_continuity_loop_bounds + +!>@{ CPU time clock IDs +integer :: id_clock_reconstruct, id_clock_update, id_clock_correct +!>@} + +!> Control structure for mom_continuity_ppm +type, public :: continuity_PPM_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + type(diag_ctrl), pointer :: diag !< Diagnostics control structure. + logical :: upwind_1st !< If true, use a first-order upwind scheme. + logical :: monotonic !< If true, use the Colella & Woodward monotonic + !! limiter; otherwise use a simple positive + !! definite limiter. + logical :: simple_2nd !< If true, use a simple second order (arithmetic + !! mean) interpolation of the edge values instead + !! of the higher order interpolation. + real :: tol_eta !< The tolerance for free-surface height + !! discrepancies between the barotropic solution and + !! the sum of the layer thicknesses [H ~> m or kg m-2]. + real :: tol_vel !< The tolerance for barotropic velocity + !! discrepancies between the barotropic solution and + !! the sum of the layer thicknesses [L T-1 ~> m s-1]. + real :: CFL_limit_adjust !< The maximum CFL of the adjusted velocities [nondim] + logical :: aggress_adjust !< If true, allow the adjusted velocities to have a + !! relative CFL change up to 0.5. False by default. + logical :: vol_CFL !< If true, use the ratio of the open face lengths + !! to the tracer cell areas when estimating CFL + !! numbers. Without aggress_adjust, the default is + !! false; it is always true with. + logical :: better_iter !< If true, stop corrective iterations using a + !! velocity-based criterion and only stop if the + !! iteration is better than all predecessors. + logical :: use_visc_rem_max !< If true, use more appropriate limiting bounds + !! for corrections in strongly viscous columns. + logical :: marginal_faces !< If true, use the marginal face areas from the + !! continuity solver for use as the weights in the + !! barotropic solver. Otherwise use the transport + !! averaged areas. +end type continuity_PPM_CS + +!> A container for loop bounds +type, public :: cont_loop_bounds_type ; private + !>@{ Loop bounds + integer :: ish, ieh, jsh, jeh + !>@} +end type cont_loop_bounds_type + +!> Finds the thickness fluxes from the continuity solver or their vertical sum without +!! actually updating the layer thicknesses. +interface continuity_fluxes + module procedure continuity_3d_fluxes, continuity_2d_fluxes +end interface continuity_fluxes + +contains + +!> Time steps the layer thicknesses, using a monotonically limit, directionally split PPM scheme, +!! based on Lin (1994). +subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhbt, vhbt, & + visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont, du_cor, dv_cor) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: hin !< Initial layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Final layer thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: uh !< Zonal volume flux, u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: vh !< Meridional volume flux, v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< Module's control structure. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< pointers to porous barrier fractional cell metrics + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt !< The summed volume flux through zonal faces + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: vhbt !< The summed volume flux through meridional faces + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_u + !< The fraction of zonal momentum originally + !! in a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step's worth of a barotropic acceleration that + !! a layer experiences after viscosity is applied [nondim]. + !! Visc_rem_u is between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_v + !< The fraction of meridional momentum originally + !! in a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step's worth of a barotropic acceleration that + !! a layer experiences after viscosity is applied [nondim]. + !! Visc_rem_v is between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: u_cor + !< The zonal velocities that give uhbt as the depth-integrated transport [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(out) :: v_cor + !< The meridional velocities that give vhbt as the depth-integrated + !! transport [L T-1 ~> m s-1]. + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe + !! the effective open face areas as a function of barotropic flow. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(out) :: du_cor !< The zonal velocity increments from u that give uhbt + !! as the depth-integrated transports [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(out) :: dv_cor !< The meridional velocity increments from v that give vhbt + !! as the depth-integrated transports [L T-1 ~> m s-1]. + + ! Local variables + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. + type(cont_loop_bounds_type) :: LB ! A type indicating the loop range for a phase of the updates + logical :: x_first + + h_min = GV%Angstrom_H + + if (.not.CS%initialized) call MOM_error(FATAL, & + "MOM_continuity_PPM: Module must be initialized before it is used.") + + x_first = (MOD(G%first_direction,2) == 0) + + if (present(visc_rem_u) .neqv. present(visc_rem_v)) call MOM_error(FATAL, & + "MOM_continuity_PPM: Either both visc_rem_u and visc_rem_v or neither"// & + " one must be present in call to continuity_PPM.") + + if (x_first) then + ! First advect zonally, with loop bounds that accomodate the subsequent meridional advection. + LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.true.) + call zonal_edge_thickness(hin, h_W, h_E, G, GV, US, CS, OBC, LB) + call zonal_mass_flux(u, hin, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + LB, uhbt, visc_rem_u, u_cor, BT_cont, du_cor) + call continuity_zonal_convergence(h, uh, dt, G, GV, LB, hin) + + ! Now advect meridionally, using the updated thicknesses to determine the fluxes. + LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.false.) + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC, LB) + call meridional_mass_flux(v, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + LB, vhbt, visc_rem_v, v_cor, BT_cont, dv_cor) + call continuity_merdional_convergence(h, vh, dt, G, GV, LB, hmin=h_min) + + else ! .not. x_first + ! First advect meridionally, with loop bounds that accomodate the subsequent zonal advection. + LB = set_continuity_loop_bounds(G, CS, i_stencil=.true., j_stencil=.false.) + call meridional_edge_thickness(hin, h_S, h_N, G, GV, US, CS, OBC, LB) + call meridional_mass_flux(v, hin, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + LB, vhbt, visc_rem_v, v_cor, BT_cont, dv_cor) + call continuity_merdional_convergence(h, vh, dt, G, GV, LB, hin) + + ! Now advect zonally, using the updated thicknesses to determine the fluxes. + LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.false.) + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC, LB) + call zonal_mass_flux(u, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + LB, uhbt, visc_rem_u, u_cor, BT_cont, du_cor) + call continuity_zonal_convergence(h, uh, dt, G, GV, LB, hmin=h_min) + endif + +end subroutine continuity_PPM + +!> Finds the thickness fluxes from the continuity solver without actually updating the +!! layer thicknesses. Because the fluxes in the two directions are calculated based on the +!! input thicknesses, which are not updated between the direcitons, the fluxes returned here +!! are not the same as those that would be returned by a call to continuity. +subroutine continuity_3d_fluxes(u, v, h, uh, vh, dt, G, GV, US, CS, OBC, pbv) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: uh !< Thickness fluxes through zonal faces, + !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: vh !< Thickness fluxes through meridional faces, + !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< Control structure for mom_continuity. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + + ! Local variables + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) + call zonal_mass_flux(u, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) + + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) + call meridional_mass_flux(v, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) + +end subroutine continuity_3d_fluxes + +!> Find the vertical sum of the thickness fluxes from the continuity solver without actually +!! updating the layer thicknesses. Because the fluxes in the two directions are calculated +!! based on the input thicknesses, which are not updated between the directions, the fluxes +!! returned here are not the same as those that would be returned by a call to continuity. +subroutine continuity_2d_fluxes(u, v, h, uhbt, vhbt, dt, G, GV, US, CS, OBC, pbv) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G)), & + intent(out) :: uhbt !< Vertically summed thickness flux through + !! zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + intent(out) :: vhbt !< Vertically summed thickness flux through + !! meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< Control structure for mom_continuity. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + + ! Local variables + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) + call zonal_BT_mass_flux(u, h, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) + + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) + call meridional_BT_mass_flux(v, h, h_S, h_N, vhbt, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) + +end subroutine continuity_2d_fluxes + +!> Correct the velocities to give the specified depth-integrated transports by applying a +!! barotropic acceleration (subject to viscous drag) to the velocities. +subroutine continuity_adjust_vel(u, v, h, dt, G, GV, US, CS, OBC, pbv, uhbt, vhbt, visc_rem_u, visc_rem_v) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Zonal velocity, which will be adjusted to + !! give uhbt as the depth-integrated + !! transport [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Meridional velocity, which will be adjusted + !! to give vhbt as the depth-integrated + !! transport [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< Control structure for mom_continuity. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + real, dimension(SZIB_(G),SZJ_(G)), & + intent(in) :: uhbt !< The vertically summed thickness flux through + !! zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + intent(in) :: vhbt !< The vertically summed thickness flux through + !! meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_u !< Both the fraction of the zonal momentum + !! that remains after a time-step of viscosity, and + !! the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity + !! is applied [nondim]. This goes between 0 (at the + !! bottom) and 1 (far above the bottom). When this + !! column is under an ice shelf, this also goes to 0 + !! at the top due to the no-slip boundary condition there. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_v !< Both the fraction of the meridional momentum + !! that remains after a time-step of viscosity, and + !! the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity + !! is applied [nondim]. This goes between 0 (at the + !! bottom) and 1 (far above the bottom). When this + !! column is under an ice shelf, this also goes to 0 + !! at the top due to the no-slip boundary condition there. + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_in !< Input zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_in !< Input meridional velocity [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uh !< Volume flux through zonal faces = + !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vh !< Volume flux through meridional faces = + !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + + ! It might not be necessary to separate the input velocity array from the adjusted velocities, + ! but it seems safer to do so, even if it might be less efficient. + u_in(:,:,:) = u(:,:,:) + v_in(:,:,:) = v(:,:,:) + + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) + call zonal_mass_flux(u_in, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + uhbt=uhbt, visc_rem_u=visc_rem_u, u_cor=u) + + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) + call meridional_mass_flux(v_in, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + vhbt=vhbt, visc_rem_v=visc_rem_v, v_cor=v) + +end subroutine continuity_adjust_vel + + +!> Updates the thicknesses due to zonal thickness fluxes. +subroutine continuity_zonal_convergence(h, uh, dt, G, GV, LB, hin, hmin) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Final layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: uh !< Zonal thickness flux, u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1] + real, intent(in) :: dt !< Time increment [T ~> s] + type(cont_loop_bounds_type), intent(in) :: LB !< Loop bounds structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: hin !< Initial layer thickness [H ~> m or kg m-2]. + !! If hin is absent, h is also the initial thickness. + real, optional, intent(in) :: hmin !< The minimum layer thickness [H ~> m or kg m-2] + + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. + integer :: i, j, k + + call cpu_clock_begin(id_clock_update) + + h_min = 0.0 ; if (present(hmin)) h_min = hmin + + if (present(hin)) then + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh + h(i,j,k) = max( hin(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)), h_min ) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh + h(i,j,k) = max( h(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)), h_min ) + enddo ; enddo ; enddo + endif + + call cpu_clock_end(id_clock_update) + +end subroutine continuity_zonal_convergence + +!> Updates the thicknesses due to meridional thickness fluxes. +subroutine continuity_merdional_convergence(h, vh, dt, G, GV, LB, hin, hmin) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Final layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vh !< Meridional thickness flux, v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] + real, intent(in) :: dt !< Time increment [T ~> s] + type(cont_loop_bounds_type), intent(in) :: LB !< Loop bounds structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: hin !< Initial layer thickness [H ~> m or kg m-2]. + !! If hin is absent, h is also the initial thickness. + real, optional, intent(in) :: hmin !< The minimum layer thickness [H ~> m or kg m-2] + + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. + integer :: i, j, k + + call cpu_clock_begin(id_clock_update) + + h_min = 0.0 ; if (present(hmin)) h_min = hmin + + if (present(hin)) then + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh + h(i,j,k) = max( hin(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)), h_min ) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh + h(i,j,k) = max( h(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)), h_min ) + enddo ; enddo ; enddo + endif + + call cpu_clock_end(id_clock_update) + +end subroutine continuity_merdional_convergence + + +!> Set the reconstructed thicknesses at the eastern and western edges of tracer cells. +subroutine zonal_edge_thickness(h_in, h_W, h_E, G, GV, US, CS, OBC, LB_in) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_in !< Tracer cell layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h_W !< Western edge layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h_E !< Eastern edge layer thickness [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(cont_loop_bounds_type), & + optional, intent(in) :: LB_in !< Loop bounds structure. + + ! Local variables + type(cont_loop_bounds_type) :: LB + integer :: i, j, k, ish, ieh, jsh, jeh, nz + + call cpu_clock_begin(id_clock_reconstruct) + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke + + if (CS%upwind_1st) then + !$OMP parallel do default(shared) + do k=1,nz ; do j=jsh,jeh ; do i=ish-1,ieh+1 + h_W(i,j,k) = h_in(i,j,k) ; h_E(i,j,k) = h_in(i,j,k) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,nz + call PPM_reconstruction_x(h_in(:,:,k), h_W(:,:,k), h_E(:,:,k), G, LB, & + 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC) + enddo + endif + + call cpu_clock_end(id_clock_reconstruct) + +end subroutine zonal_edge_thickness + + +!> Set the reconstructed thicknesses at the eastern and western edges of tracer cells. +subroutine meridional_edge_thickness(h_in, h_S, h_N, G, GV, US, CS, OBC, LB_in) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_in !< Tracer cell layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h_S !< Southern edge layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h_N !< Northern edge layer thickness [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(cont_loop_bounds_type), & + optional, intent(in) :: LB_in !< Loop bounds structure. + + ! Local variables + type(cont_loop_bounds_type) :: LB + integer :: i, j, k, ish, ieh, jsh, jeh, nz + + call cpu_clock_begin(id_clock_reconstruct) + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke + + if (CS%upwind_1st) then + !$OMP parallel do default(shared) + do k=1,nz ; do j=jsh-1,jeh+1 ; do i=ish,ieh + h_S(i,j,k) = h_in(i,j,k) ; h_N(i,j,k) = h_in(i,j,k) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,nz + call PPM_reconstruction_y(h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), G, LB, & + 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC) + enddo + endif + + call cpu_clock_end(id_clock_reconstruct) + +end subroutine meridional_edge_thickness + + +!> Calculates the mass or volume fluxes through the zonal faces, and other related quantities. +subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_face_areaU, & + LB_in, uhbt, visc_rem_u, u_cor, BT_cont, du_cor) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_W !< Western edge thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_E !< Eastern edge thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: uh !< Volume flux through zonal faces = u*h*dy + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), & + intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] + type(cont_loop_bounds_type), & + optional, intent(in) :: LB_in !< Loop bounds structure. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt !< The summed volume flux through zonal faces + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_u + !< The fraction of zonal momentum originally in a layer that remains after a + !! time-step of viscosity, and the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity is applied [nondim]. + !! Visc_rem_u is between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: u_cor + !< The zonal velocities (u with a barotropic correction) + !! that give uhbt as the depth-integrated transport [L T-1 ~> m s-1] + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe the + !! effective open face areas as a function of barotropic flow. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(out) :: du_cor !< The zonal velocity increments from u that give uhbt + !! as the depth-integrated transports [L T-1 ~> m s-1]. + + ! Local variables + real, dimension(SZIB_(G),SZK_(GV)) :: duhdu ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. + real, dimension(SZIB_(G)) :: & + du, & ! Corrective barotropic change in the velocity to give uhbt [L T-1 ~> m s-1]. + du_min_CFL, & ! Lower limit on du correction to avoid CFL violations [L T-1 ~> m s-1] + du_max_CFL, & ! Upper limit on du correction to avoid CFL violations [L T-1 ~> m s-1] + duhdu_tot_0, & ! Summed partial derivative of uh with u [H L ~> m2 or kg m-1]. + uh_tot_0, & ! Summed transport with no barotropic correction [H L2 T-1 ~> m3 s-1 or kg s-1]. + visc_rem_max ! The column maximum of visc_rem [nondim]. + logical, dimension(SZIB_(G)) :: do_I + real, dimension(SZIB_(G),SZK_(GV)) :: & + visc_rem ! A 2-D copy of visc_rem_u or an array of 1's [nondim]. + real, dimension(SZIB_(G)) :: FAuI ! A list of sums of zonal face areas [H L ~> m2 or kg m-1]. + real :: FA_u ! A sum of zonal face areas [H L ~> m2 or kg m-1]. + real :: I_vrm ! 1.0 / visc_rem_max [nondim] + real :: CFL_dt ! The maximum CFL ratio of the adjusted velocities divided by + ! the time step [T-1 ~> s-1]. + real :: I_dt ! 1.0 / dt [T-1 ~> s-1]. + real :: du_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. + real :: dx_E, dx_W ! Effective x-grid spacings to the east and west [L ~> m]. + type(cont_loop_bounds_type) :: LB + integer :: i, j, k, ish, ieh, jsh, jeh, n, nz + integer :: l_seg ! The OBC segment number + logical :: use_visc_rem, set_BT_cont + logical :: local_specified_BC, local_Flather_OBC, local_open_BC, any_simple_OBC ! OBC-related logicals + logical :: simple_OBC_pt(SZIB_(G)) ! Indicates points in a row with specified transport OBCs + + call cpu_clock_begin(id_clock_correct) + + use_visc_rem = present(visc_rem_u) + + set_BT_cont = .false. ; if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) + + local_specified_BC = .false. ; local_Flather_OBC = .false. ; local_open_BC = .false. + if (associated(OBC)) then ; if (OBC%OBC_pe) then + local_specified_BC = OBC%specified_u_BCs_exist_globally + local_Flather_OBC = OBC%Flather_u_BCs_exist_globally + local_open_BC = OBC%open_u_BCs_exist_globally + endif ; endif + + if (present(du_cor)) du_cor(:,:) = 0.0 + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke + + CFL_dt = CS%CFL_limit_adjust / dt + I_dt = 1.0 / dt + if (CS%aggress_adjust) CFL_dt = I_dt + + if (.not.use_visc_rem) visc_rem(:,:) = 1.0 + !$OMP parallel do default(shared) private(do_I,duhdu,du,du_max_CFL,du_min_CFL,uh_tot_0, & + !$OMP duhdu_tot_0,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W, & + !$OMP simple_OBC_pt,any_simple_OBC,l_seg) & + !$OMP firstprivate(visc_rem) + do j=jsh,jeh + do I=ish-1,ieh ; do_I(I) = .true. ; enddo + ! Set uh and duhdu. + do k=1,nz + if (use_visc_rem) then ; do I=ish-1,ieh + visc_rem(I,k) = visc_rem_u(I,j,k) + enddo ; endif + call zonal_flux_layer(u(:,j,k), h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), & + uh(:,j,k), duhdu(:,k), visc_rem(:,k), & + dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), OBC) + if (local_specified_BC) then + do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + l_seg = OBC%segnum_u(I,j) + if (OBC%segment(l_seg)%specified) uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k) + endif ; enddo + endif + enddo + + if (present(uhbt) .or. set_BT_cont) then + if (use_visc_rem .and. CS%use_visc_rem_max) then + visc_rem_max(:) = 0.0 + do k=1,nz ; do I=ish-1,ieh + visc_rem_max(I) = max(visc_rem_max(I), visc_rem(I,k)) + enddo ; enddo + else + visc_rem_max(:) = 1.0 + endif + ! Set limits on du that will keep the CFL number between -1 and 1. + ! This should be adequate to keep the root bracketed in all cases. + do I=ish-1,ieh + I_vrm = 0.0 + if (visc_rem_max(I) > 0.0) I_vrm = 1.0 / visc_rem_max(I) + if (CS%vol_CFL) then + dx_W = ratio_max(G%areaT(i,j), G%dy_Cu(I,j), 1000.0*G%dxT(i,j)) + dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j)) + else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif + du_max_CFL(I) = 2.0* (CFL_dt * dx_W) * I_vrm + du_min_CFL(I) = -2.0 * (CFL_dt * dx_E) * I_vrm + uh_tot_0(I) = 0.0 ; duhdu_tot_0(I) = 0.0 + enddo + do k=1,nz ; do I=ish-1,ieh + duhdu_tot_0(I) = duhdu_tot_0(I) + duhdu(I,k) + uh_tot_0(I) = uh_tot_0(I) + uh(I,j,k) + enddo ; enddo + if (use_visc_rem) then + if (CS%aggress_adjust) then + do k=1,nz ; do I=ish-1,ieh + if (CS%vol_CFL) then + dx_W = ratio_max(G%areaT(i,j), G%dy_Cu(I,j), 1000.0*G%dxT(i,j)) + dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j)) + else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif + + du_lim = 0.499*((dx_W*I_dt - u(I,j,k)) + MIN(0.0,u(I-1,j,k))) + if (du_max_CFL(I) * visc_rem(I,k) > du_lim) & + du_max_CFL(I) = du_lim / visc_rem(I,k) + + du_lim = 0.499*((-dx_E*I_dt - u(I,j,k)) + MAX(0.0,u(I+1,j,k))) + if (du_min_CFL(I) * visc_rem(I,k) < du_lim) & + du_min_CFL(I) = du_lim / visc_rem(I,k) + enddo ; enddo + else + do k=1,nz ; do I=ish-1,ieh + if (CS%vol_CFL) then + dx_W = ratio_max(G%areaT(i,j), G%dy_Cu(I,j), 1000.0*G%dxT(i,j)) + dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j)) + else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif + + if (du_max_CFL(I) * visc_rem(I,k) > dx_W*CFL_dt - u(I,j,k)*G%mask2dCu(I,j)) & + du_max_CFL(I) = (dx_W*CFL_dt - u(I,j,k)) / visc_rem(I,k) + if (du_min_CFL(I) * visc_rem(I,k) < -dx_E*CFL_dt - u(I,j,k)*G%mask2dCu(I,j)) & + du_min_CFL(I) = -(dx_E*CFL_dt + u(I,j,k)) / visc_rem(I,k) + enddo ; enddo + endif + else + if (CS%aggress_adjust) then + do k=1,nz ; do I=ish-1,ieh + if (CS%vol_CFL) then + dx_W = ratio_max(G%areaT(i,j), G%dy_Cu(I,j), 1000.0*G%dxT(i,j)) + dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j)) + else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif + + du_max_CFL(I) = MIN(du_max_CFL(I), 0.499 * & + ((dx_W*I_dt - u(I,j,k)) + MIN(0.0,u(I-1,j,k))) ) + du_min_CFL(I) = MAX(du_min_CFL(I), 0.499 * & + ((-dx_E*I_dt - u(I,j,k)) + MAX(0.0,u(I+1,j,k))) ) + enddo ; enddo + else + do k=1,nz ; do I=ish-1,ieh + if (CS%vol_CFL) then + dx_W = ratio_max(G%areaT(i,j), G%dy_Cu(I,j), 1000.0*G%dxT(i,j)) + dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j)) + else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif + + du_max_CFL(I) = MIN(du_max_CFL(I), dx_W*CFL_dt - u(I,j,k)) + du_min_CFL(I) = MAX(du_min_CFL(I), -(dx_E*CFL_dt + u(I,j,k))) + enddo ; enddo + endif + endif + do I=ish-1,ieh + du_max_CFL(I) = max(du_max_CFL(I),0.0) + du_min_CFL(I) = min(du_min_CFL(I),0.0) + enddo + + any_simple_OBC = .false. + if (present(uhbt) .or. set_BT_cont) then + if (local_specified_BC .or. local_Flather_OBC) then ; do I=ish-1,ieh + l_seg = OBC%segnum_u(I,j) + + ! Avoid reconciling barotropic/baroclinic transports if transport is specified + simple_OBC_pt(I) = .false. + if (l_seg /= OBC_NONE) simple_OBC_pt(I) = OBC%segment(l_seg)%specified + do_I(I) = .not.simple_OBC_pt(I) + any_simple_OBC = any_simple_OBC .or. simple_OBC_pt(I) + enddo ; else ; do I=ish-1,ieh + do_I(I) = .true. + enddo ; endif + endif + + if (present(uhbt)) then + ! Find du and uh. + call zonal_flux_adjust(u, h_in, h_W, h_E, uhbt(:,j), uh_tot_0, duhdu_tot_0, du, & + du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & + j, ish, ieh, do_I, por_face_areaU, uh, OBC=OBC) + + if (present(u_cor)) then ; do k=1,nz + do I=ish-1,ieh ; u_cor(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo + if (any_simple_OBC) then ; do I=ish-1,ieh ; if (simple_OBC_pt(I)) then + u_cor(I,j,k) = OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k) + endif ; enddo ; endif + enddo ; endif ! u-corrected + + if (present(du_cor)) then + do I=ish-1,ieh ; du_cor(I,j) = du(I) ; enddo + endif + + endif + + if (set_BT_cont) then + call set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, uh_tot_0, duhdu_tot_0,& + du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & + visc_rem_max, j, ish, ieh, do_I, por_face_areaU) + if (any_simple_OBC) then + do I=ish-1,ieh + if (simple_OBC_pt(I)) FAuI(I) = GV%H_subroundoff*G%dy_Cu(I,j) + enddo + ! NOTE: simple_OBC_pt(I) should prevent access to segment OBC_NONE + do k=1,nz ; do I=ish-1,ieh ; if (simple_OBC_pt(I)) then + if ((abs(OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k)) > 0.0) .and. & + (OBC%segment(OBC%segnum_u(I,j))%specified)) & + FAuI(I) = FAuI(I) + OBC%segment(OBC%segnum_u(I,j))%normal_trans(I,j,k) / & + OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k) + endif ; enddo ; enddo + do I=ish-1,ieh ; if (simple_OBC_pt(I)) then + BT_cont%FA_u_W0(I,j) = FAuI(I) ; BT_cont%FA_u_E0(I,j) = FAuI(I) + BT_cont%FA_u_WW(I,j) = FAuI(I) ; BT_cont%FA_u_EE(I,j) = FAuI(I) + BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0 + endif ; enddo + endif + endif ! set_BT_cont + + endif ! present(uhbt) or set_BT_cont + + enddo ! j-loop + + if (local_open_BC .and. set_BT_cont) then + do n = 1, OBC%number_of_segments + if (OBC%segment(n)%open .and. OBC%segment(n)%is_E_or_W) then + I = OBC%segment(n)%HI%IsdB + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + do j = OBC%segment(n)%HI%Jsd, OBC%segment(n)%HI%Jed + FA_u = 0.0 + do k=1,nz ; FA_u = FA_u + h_in(i,j,k)*(G%dy_Cu(I,j)*por_face_areaU(I,j,k)) ; enddo + BT_cont%FA_u_W0(I,j) = FA_u ; BT_cont%FA_u_E0(I,j) = FA_u + BT_cont%FA_u_WW(I,j) = FA_u ; BT_cont%FA_u_EE(I,j) = FA_u + BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0 + enddo + else + do j = OBC%segment(n)%HI%Jsd, OBC%segment(n)%HI%Jed + FA_u = 0.0 + do k=1,nz ; FA_u = FA_u + h_in(i+1,j,k)*(G%dy_Cu(I,j)*por_face_areaU(I,j,k)) ; enddo + BT_cont%FA_u_W0(I,j) = FA_u ; BT_cont%FA_u_E0(I,j) = FA_u + BT_cont%FA_u_WW(I,j) = FA_u ; BT_cont%FA_u_EE(I,j) = FA_u + BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0 + enddo + endif + endif + enddo + endif + + if (set_BT_cont) then ; if (allocated(BT_cont%h_u)) then + if (present(u_cor)) then + call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) + else + call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) + endif + endif ; endif + + call cpu_clock_end(id_clock_correct) + +end subroutine zonal_mass_flux + + +!> Calculates the vertically integrated mass or volume fluxes through the zonal faces. +subroutine zonal_BT_mass_flux(u, h_in, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, por_face_areaU, LB_in) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to + !! calculate fluxes [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< Western edge thickness in the PPM + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< Eastern edge thickness in the PPM + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: uhbt !< The summed volume flux through zonal + !! faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type + !! specifies whether, where, and what + !! open boundary conditions are used. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] + type(cont_loop_bounds_type), optional, intent(in) :: LB_in !< Loop bounds structure. + + ! Local variables + real :: uh(SZIB_(G)) ! Volume flux through zonal faces = u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: duhdu(SZIB_(G)) ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. + logical, dimension(SZIB_(G)) :: do_I + real :: ones(SZIB_(G)) ! An array of 1's [nondim] + integer :: i, j, k, ish, ieh, jsh, jeh, nz + logical :: local_specified_BC, OBC_in_row + + call cpu_clock_begin(id_clock_correct) + + local_specified_BC = .false. + if (associated(OBC)) then ; if (OBC%OBC_pe) then + local_specified_BC = OBC%specified_v_BCs_exist_globally + endif ; endif + + if (present(LB_in)) then + ish = LB_in%ish ; ieh = LB_in%ieh ; jsh = LB_in%jsh ; jeh = LB_in%jeh ; nz = GV%ke + else + ish = G%isc ; ieh = G%iec ; jsh = G%jsc ; jeh = G%jec ; nz = GV%ke + endif + + ones(:) = 1.0 ; do_I(:) = .true. + + uhbt(:,:) = 0.0 + !$OMP parallel do default(shared) private(uh,duhdu,OBC_in_row) + do j=jsh,jeh + ! Determining whether there are any OBC points outside of the k-loop should be more efficient. + OBC_in_row = .false. + if (local_specified_BC) then ; do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_u(I,j))%specified) OBC_in_row = .true. + endif ; enddo ; endif + do k=1,nz + ! This sets uh and duhdu. + call zonal_flux_layer(u(:,j,k), h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh, duhdu, ones, & + dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), OBC) + if (OBC_in_row) then ; do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_u(I,j))%specified) uh(I) = OBC%segment(OBC%segnum_u(I,j))%normal_trans(I,j,k) + endif ; enddo ; endif + + ! Accumulate the barotropic transport. + do I=ish-1,ieh + uhbt(I,j) = uhbt(I,j) + uh(I) + enddo + enddo ! k-loop + enddo ! j-loop + call cpu_clock_end(id_clock_correct) + +end subroutine zonal_BT_mass_flux + + +!> Evaluates the zonal mass or volume fluxes in a layer. +subroutine zonal_flux_layer(u, h, h_W, h_E, uh, duhdu, visc_rem, dt, G, US, j, & + ish, ieh, do_I, vol_CFL, por_face_areaU, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + real, dimension(SZIB_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G)), intent(in) :: visc_rem !< Both the fraction of the + !! momentum originally in a layer that remains after a time-step + !! of viscosity, and the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity is applied [nondim]. + !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: h_W !< West edge thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: h_E !< East edge thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G)), intent(inout) :: uh !< Zonal mass or volume + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G)), intent(inout) :: duhdu !< Partial derivative of uh + !! with u [H L ~> m2 or kg m-1]. + real, intent(in) :: dt !< Time increment [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: j !< Spatial index. + integer, intent(in) :: ish !< Start of index range. + integer, intent(in) :: ieh !< End of index range. + logical, dimension(SZIB_(G)), intent(in) :: do_I !< Which i values to work on. + logical, intent(in) :: vol_CFL !< If true, rescale the + real, dimension(SZIB_(G)), intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] + !! ratio of face areas to the cell areas when estimating the CFL number. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + ! Local variables + real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] + real :: curv_3 ! A measure of the thickness curvature over a grid length [H ~> m or kg m-2] + real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. + integer :: i + integer :: l_seg + logical :: local_open_BC + + local_open_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_BC = OBC%open_u_BCs_exist_globally + endif ; endif + + do I=ish-1,ieh ; if (do_I(I)) then + ! Set new values of uh and duhdu. + if (u(I) > 0.0) then + if (vol_CFL) then ; CFL = (u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) + else ; CFL = u(I) * dt * G%IdxT(i,j) ; endif + curv_3 = h_W(i) + h_E(i) - 2.0*h(i) + uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * & + (h_E(i) + CFL * (0.5*(h_W(i) - h_E(i)) + curv_3*(CFL - 1.5))) + h_marg = h_E(i) + CFL * ((h_W(i) - h_E(i)) + 3.0*curv_3*(CFL - 1.0)) + elseif (u(I) < 0.0) then + if (vol_CFL) then ; CFL = (-u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) + else ; CFL = -u(I) * dt * G%IdxT(i+1,j) ; endif + curv_3 = h_W(i+1) + h_E(i+1) - 2.0*h(i+1) + uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * & + (h_W(i+1) + CFL * (0.5*(h_E(i+1)-h_W(i+1)) + curv_3*(CFL - 1.5))) + h_marg = h_W(i+1) + CFL * ((h_E(i+1)-h_W(i+1)) + 3.0*curv_3*(CFL - 1.0)) + else + uh(I) = 0.0 + h_marg = 0.5 * (h_W(i+1) + h_E(i)) + endif + duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * h_marg * visc_rem(I) + endif ; enddo + + if (local_open_BC) then + do I=ish-1,ieh ; if (do_I(I)) then ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + l_seg = OBC%segnum_u(I,j) + if (OBC%segment(l_seg)%open) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i) + duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * h(i) * visc_rem(I) + else + uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i+1) + duhdu(I) = (G%dy_Cu(I,j)* por_face_areaU(I)) * h(i+1) * visc_rem(I) + endif + endif + endif ; endif ; enddo + endif +end subroutine zonal_flux_layer + +!> Sets the effective interface thickness associated with the fluxes at each zonal velocity point, +!! optionally scaling back these thicknesses to account for viscosity and fractional open areas. +subroutine zonal_flux_thickness(u, h, h_W, h_E, h_u, dt, G, GV, US, LB, vol_CFL, & + marginal, OBC, por_face_areaU, visc_rem_u) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness used to + !! calculate fluxes [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< West edge thickness in the + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< East edge thickness in the + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_u !< Effective thickness at zonal faces, + !! scaled down to account for the effects of + !! viscosity and the fractional open area + !! [H ~> m or kg m-2]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(cont_loop_bounds_type), intent(in) :: LB !< Loop bounds structure. + logical, intent(in) :: vol_CFL !< If true, rescale the ratio + !! of face areas to the cell areas when estimating the CFL number. + logical, intent(in) :: marginal !< If true, report the + !! marginal face thicknesses; otherwise report transport-averaged thicknesses. + real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), & + intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_u + !< Both the fraction of the momentum originally in a layer that remains after + !! a time-step of viscosity, and the fraction of a time-step's worth of a + !! barotropic acceleration that a layer experiences after viscosity is applied [nondim]. + !! Visc_rem_u is between 0 (at the bottom) and 1 (far above the bottom). + + ! Local variables + real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] + real :: curv_3 ! A measure of the thickness curvature over a grid length [H ~> m or kg m-2] + real :: h_avg ! The average thickness of a flux [H ~> m or kg m-2]. + real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. + logical :: local_open_BC + integer :: i, j, k, ish, ieh, jsh, jeh, nz, n + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke + + !$OMP parallel do default(shared) private(CFL,curv_3,h_marg,h_avg) + do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh + if (u(I,j,k) > 0.0) then + if (vol_CFL) then ; CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) + else ; CFL = u(I,j,k) * dt * G%IdxT(i,j) ; endif + curv_3 = h_W(i,j,k) + h_E(i,j,k) - 2.0*h(i,j,k) + h_avg = h_E(i,j,k) + CFL * (0.5*(h_W(i,j,k) - h_E(i,j,k)) + curv_3*(CFL - 1.5)) + h_marg = h_E(i,j,k) + CFL * ((h_W(i,j,k) - h_E(i,j,k)) + 3.0*curv_3*(CFL - 1.0)) + elseif (u(I,j,k) < 0.0) then + if (vol_CFL) then ; CFL = (-u(I,j,k)*dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) + else ; CFL = -u(I,j,k) * dt * G%IdxT(i+1,j) ; endif + curv_3 = h_W(i+1,j,k) + h_E(i+1,j,k) - 2.0*h(i+1,j,k) + h_avg = h_W(i+1,j,k) + CFL * (0.5*(h_E(i+1,j,k)-h_W(i+1,j,k)) + curv_3*(CFL - 1.5)) + h_marg = h_W(i+1,j,k) + CFL * ((h_E(i+1,j,k)-h_W(i+1,j,k)) + & + 3.0*curv_3*(CFL - 1.0)) + else + h_avg = 0.5 * (h_W(i+1,j,k) + h_E(i,j,k)) + ! The choice to use the arithmetic mean here is somewhat arbitrarily, but + ! it should be noted that h_W(i+1,j,k) and h_E(i,j,k) are usually the same. + h_marg = 0.5 * (h_W(i+1,j,k) + h_E(i,j,k)) + ! h_marg = (2.0 * h_W(i+1,j,k) * h_E(i,j,k)) / & + ! (h_W(i+1,j,k) + h_E(i,j,k) + GV%H_subroundoff) + endif + + if (marginal) then ; h_u(I,j,k) = h_marg + else ; h_u(I,j,k) = h_avg ; endif + enddo ; enddo ; enddo + if (present(visc_rem_u)) then + ! Scale back the thickness to account for the effects of viscosity and the fractional open + ! thickness to give an appropriate non-normalized weight for each layer in determining the + ! barotropic acceleration. + !$OMP parallel do default(shared) + do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh + h_u(I,j,k) = h_u(I,j,k) * (visc_rem_u(I,j,k) * por_face_areaU(I,j,k)) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh + h_u(I,j,k) = h_u(I,j,k) * por_face_areaU(I,j,k) + enddo ; enddo ; enddo + endif + + local_open_BC = .false. + if (associated(OBC)) local_open_BC = OBC%open_u_BCs_exist_globally + if (local_open_BC) then + do n = 1, OBC%number_of_segments + if (OBC%segment(n)%open .and. OBC%segment(n)%is_E_or_W) then + I = OBC%segment(n)%HI%IsdB + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + if (present(visc_rem_u)) then ; do k=1,nz + do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed + h_u(I,j,k) = h(i,j,k) * (visc_rem_u(I,j,k) * por_face_areaU(I,j,k)) + enddo + enddo ; else ; do k=1,nz + do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed + h_u(I,j,k) = h(i,j,k) * por_face_areaU(I,j,k) + enddo + enddo ; endif + else + if (present(visc_rem_u)) then ; do k=1,nz + do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed + h_u(I,j,k) = h(i+1,j,k) * (visc_rem_u(I,j,k) * por_face_areaU(I,j,k)) + enddo + enddo ; else ; do k=1,nz + do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed + h_u(I,j,k) = h(i+1,j,k) * por_face_areaU(I,j,k) + enddo + enddo ; endif + endif + endif + enddo + endif + +end subroutine zonal_flux_thickness + +!> Returns the barotropic velocity adjustment that gives the +!! desired barotropic (layer-summed) transport. +subroutine zonal_flux_adjust(u, h_in, h_W, h_E, uhbt, uh_tot_0, duhdu_tot_0, & + du, du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & + j, ish, ieh, do_I_in, por_face_areaU, uh_3d, OBC) + + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to + !! calculate fluxes [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< West edge thickness in the + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< East edge thickness in the + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: visc_rem !< Both the fraction of the + !! momentum originally in a layer that remains after a time-step of viscosity, and + !! the fraction of a time-step's worth of a barotropic acceleration that a layer + !! experiences after viscosity is applied [nondim]. + !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZIB_(G)), intent(in) :: uhbt !< The summed volume flux + !! through zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + + real, dimension(SZIB_(G)), intent(in) :: du_max_CFL !< Maximum acceptable + !! value of du [L T-1 ~> m s-1]. + real, dimension(SZIB_(G)), intent(in) :: du_min_CFL !< Minimum acceptable + !! value of du [L T-1 ~> m s-1]. + real, dimension(SZIB_(G)), intent(in) :: uh_tot_0 !< The summed transport + !! with 0 adjustment [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G)), intent(in) :: duhdu_tot_0 !< The partial derivative + !! of du_err with du at 0 adjustment [H L ~> m2 or kg m-1]. + real, dimension(SZIB_(G)), intent(out) :: du !< + !! The barotropic velocity adjustment [L T-1 ~> m s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. + integer, intent(in) :: j !< Spatial index. + integer, intent(in) :: ish !< Start of index range. + integer, intent(in) :: ieh !< End of index range. + logical, dimension(SZIB_(G)), intent(in) :: do_I_in !< + !! A logical flag indicating which I values to work on. + real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), & + intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: uh_3d !< + !! Volume flux through zonal faces = u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + ! Local variables + real, dimension(SZIB_(G),SZK_(GV)) :: & + uh_aux, & ! An auxiliary zonal volume flux [H L2 T-1 ~> m3 s-1 or kg s-1]. + duhdu ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. + real, dimension(SZIB_(G)) :: & + uh_err, & ! Difference between uhbt and the summed uh [H L2 T-1 ~> m3 s-1 or kg s-1]. + uh_err_best, & ! The smallest value of uh_err found so far [H L2 T-1 ~> m3 s-1 or kg s-1]. + u_new, & ! The velocity with the correction added [L T-1 ~> m s-1]. + duhdu_tot,&! Summed partial derivative of uh with u [H L ~> m2 or kg m-1]. + du_min, & ! Lower limit on du correction based on CFL limits and previous iterations [L T-1 ~> m s-1] + du_max ! Upper limit on du correction based on CFL limits and previous iterations [L T-1 ~> m s-1] + real :: du_prev ! The previous value of du [L T-1 ~> m s-1]. + real :: ddu ! The change in du from the previous iteration [L T-1 ~> m s-1]. + real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2]. + real :: tol_vel ! The tolerance for velocity in the current iteration [L T-1 ~> m s-1]. + integer :: i, k, nz, itt, max_itts = 20 + logical :: domore, do_I(SZIB_(G)) + + nz = GV%ke + + uh_aux(:,:) = 0.0 ; duhdu(:,:) = 0.0 + + if (present(uh_3d)) then ; do k=1,nz ; do I=ish-1,ieh + uh_aux(i,k) = uh_3d(I,j,k) + enddo ; enddo ; endif + + do I=ish-1,ieh + du(I) = 0.0 ; do_I(I) = do_I_in(I) + du_max(I) = du_max_CFL(I) ; du_min(I) = du_min_CFL(I) + uh_err(I) = uh_tot_0(I) - uhbt(I) ; duhdu_tot(I) = duhdu_tot_0(I) + uh_err_best(I) = abs(uh_err(I)) + enddo + + do itt=1,max_itts + select case (itt) + case (:1) ; tol_eta = 1e-6 * CS%tol_eta + case (2) ; tol_eta = 1e-4 * CS%tol_eta + case (3) ; tol_eta = 1e-2 * CS%tol_eta + case default ; tol_eta = CS%tol_eta + end select + tol_vel = CS%tol_vel + + do I=ish-1,ieh + if (uh_err(I) > 0.0) then ; du_max(I) = du(I) + elseif (uh_err(I) < 0.0) then ; du_min(I) = du(I) + else ; do_I(I) = .false. ; endif + enddo + domore = .false. + do I=ish-1,ieh ; if (do_I(I)) then + if ((dt * min(G%IareaT(i,j),G%IareaT(i+1,j))*abs(uh_err(I)) > tol_eta) .or. & + (CS%better_iter .and. ((abs(uh_err(I)) > tol_vel * duhdu_tot(I)) .or. & + (abs(uh_err(I)) > uh_err_best(I))) )) then + ! Use Newton's method, provided it stays bounded. Otherwise bisect + ! the value with the appropriate bound. + ddu = -uh_err(I) / duhdu_tot(I) + du_prev = du(I) + du(I) = du(I) + ddu + if (abs(ddu) < 1.0e-15*abs(du(I))) then + do_I(I) = .false. ! ddu is small enough to quit. + elseif (ddu > 0.0) then + if (du(I) >= du_max(I)) then + du(I) = 0.5*(du_prev + du_max(I)) + if (du_max(I) - du_prev < 1.0e-15*abs(du(I))) do_I(I) = .false. + endif + else ! ddu < 0.0 + if (du(I) <= du_min(I)) then + du(I) = 0.5*(du_prev + du_min(I)) + if (du_prev - du_min(I) < 1.0e-15*abs(du(I))) do_I(I) = .false. + endif + endif + if (do_I(I)) domore = .true. + else + do_I(I) = .false. + endif + endif ; enddo + if (.not.domore) exit + + if ((itt < max_itts) .or. present(uh_3d)) then ; do k=1,nz + do I=ish-1,ieh ; u_new(I) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo + call zonal_flux_layer(u_new, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), & + uh_aux(:,k), duhdu(:,k), visc_rem(:,k), & + dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), OBC) + enddo ; endif + + if (itt < max_itts) then + do I=ish-1,ieh + uh_err(I) = -uhbt(I) ; duhdu_tot(I) = 0.0 + enddo + do k=1,nz ; do I=ish-1,ieh + uh_err(I) = uh_err(I) + uh_aux(I,k) + duhdu_tot(I) = duhdu_tot(I) + duhdu(I,k) + enddo ; enddo + do I=ish-1,ieh + uh_err_best(I) = min(uh_err_best(I), abs(uh_err(I))) + enddo + endif + enddo ! itt-loop + ! If there are any faces which have not converged to within the tolerance, + ! so-be-it, or else use a final upwind correction? + ! This never seems to happen with 20 iterations as max_itt. + + if (present(uh_3d)) then ; do k=1,nz ; do I=ish-1,ieh + uh_3d(I,j,k) = uh_aux(I,k) + enddo ; enddo ; endif + +end subroutine zonal_flux_adjust + +!> Sets a structure that describes the zonal barotropic volume or mass fluxes as a +!! function of barotropic flow to agree closely with the sum of the layer's transports. +subroutine set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, uh_tot_0, duhdu_tot_0, & + du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & + visc_rem_max, j, ish, ieh, do_I, por_face_areaU) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to + !! calculate fluxes [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< West edge thickness in the + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< East edge thickness in the + !! reconstruction [H ~> m or kg m-2]. + type(BT_cont_type), intent(inout) :: BT_cont !< A structure with elements + !! that describe the effective open face areas as a function of barotropic flow. + real, dimension(SZIB_(G)), intent(in) :: uh_tot_0 !< The summed transport + !! with 0 adjustment [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G)), intent(in) :: duhdu_tot_0 !< The partial derivative + !! of du_err with du at 0 adjustment [H L ~> m2 or kg m-1]. + real, dimension(SZIB_(G)), intent(in) :: du_max_CFL !< Maximum acceptable + !! value of du [L T-1 ~> m s-1]. + real, dimension(SZIB_(G)), intent(in) :: du_min_CFL !< Minimum acceptable + !! value of du [L T-1 ~> m s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. + real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: visc_rem !< Both the fraction of the + !! momentum originally in a layer that remains after a time-step of viscosity, and + !! the fraction of a time-step's worth of a barotropic acceleration that a layer + !! experiences after viscosity is applied [nondim]. + !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZIB_(G)), intent(in) :: visc_rem_max !< Maximum allowable visc_rem [nondim]. + integer, intent(in) :: j !< Spatial index. + integer, intent(in) :: ish !< Start of index range. + integer, intent(in) :: ieh !< End of index range. + logical, dimension(SZIB_(G)), intent(in) :: do_I !< A logical flag indicating + !! which I values to work on. + real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), & + intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] + ! Local variables + real, dimension(SZIB_(G)) :: & + du0, & ! The barotropic velocity increment that gives 0 transport [L T-1 ~> m s-1]. + duL, duR, & ! The barotropic velocity increments that give the westerly + ! (duL) and easterly (duR) test velocities [L T-1 ~> m s-1]. + zeros, & ! An array of full of 0 transports [H L2 T-1 ~> m3 s-1 or kg s-1] + du_CFL, & ! The velocity increment that corresponds to CFL_min [L T-1 ~> m s-1]. + u_L, u_R, & ! The westerly (u_L), easterly (u_R), and zero-barotropic + u_0, & ! transport (u_0) layer test velocities [L T-1 ~> m s-1]. + duhdu_L, & ! The effective layer marginal face areas with the westerly + duhdu_R, & ! (_L), easterly (_R), and zero-barotropic (_0) test + duhdu_0, & ! velocities [H L ~> m2 or kg m-1]. + uh_L, uh_R, & ! The layer transports with the westerly (_L), easterly (_R), + uh_0, & ! and zero-barotropic (_0) test velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. + FAmt_L, FAmt_R, & ! The summed effective marginal face areas for the 3 + FAmt_0, & ! test velocities [H L ~> m2 or kg m-1]. + uhtot_L, & ! The summed transport with the westerly (uhtot_L) and + uhtot_R ! and easterly (uhtot_R) test velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: FA_0 ! The effective face area with 0 barotropic transport [L H ~> m2 or kg m-1]. + real :: FA_avg ! The average effective face area [L H ~> m2 or kg m-1], nominally given by + ! the realized transport divided by the barotropic velocity. + real :: visc_rem_lim ! The larger of visc_rem and min_visc_rem [nondim]. This + ! limiting is necessary to keep the inverse of visc_rem + ! from leading to large CFL numbers. + real :: min_visc_rem ! The smallest permitted value for visc_rem that is used + ! in finding the barotropic velocity that changes the + ! flow direction [nondim]. This is necessary to keep the inverse + ! of visc_rem from leading to large CFL numbers. + real :: CFL_min ! A minimal increment in the CFL to try to ensure that the + ! flow is truly upwind [nondim] + real :: Idt ! The inverse of the time step [T-1 ~> s-1]. + logical :: domore + integer :: i, k, nz + + nz = GV%ke ; Idt = 1.0 / dt + min_visc_rem = 0.1 ; CFL_min = 1e-6 + + ! Diagnose the zero-transport correction, du0. + do I=ish-1,ieh ; zeros(I) = 0.0 ; enddo + call zonal_flux_adjust(u, h_in, h_W, h_E, zeros, uh_tot_0, duhdu_tot_0, du0, & + du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & + j, ish, ieh, do_I, por_face_areaU) + + ! Determine the westerly- and easterly- fluxes. Choose a sufficiently + ! negative velocity correction for the easterly-flux, and a sufficiently + ! positive correction for the westerly-flux. + domore = .false. + do I=ish-1,ieh + if (do_I(I)) domore = .true. + du_CFL(I) = (CFL_min * Idt) * G%dxCu(I,j) + duR(I) = min(0.0,du0(I) - du_CFL(I)) + duL(I) = max(0.0,du0(I) + du_CFL(I)) + FAmt_L(I) = 0.0 ; FAmt_R(I) = 0.0 ; FAmt_0(I) = 0.0 + uhtot_L(I) = 0.0 ; uhtot_R(I) = 0.0 + enddo + + if (.not.domore) then + do k=1,nz ; do I=ish-1,ieh + BT_cont%FA_u_W0(I,j) = 0.0 ; BT_cont%FA_u_WW(I,j) = 0.0 + BT_cont%FA_u_E0(I,j) = 0.0 ; BT_cont%FA_u_EE(I,j) = 0.0 + BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0 + enddo ; enddo + return + endif + + do k=1,nz ; do I=ish-1,ieh ; if (do_I(I)) then + visc_rem_lim = max(visc_rem(I,k), min_visc_rem*visc_rem_max(I)) + if (visc_rem_lim > 0.0) then ! This is almost always true for ocean points. + if (u(I,j,k) + duR(I)*visc_rem_lim > -du_CFL(I)*visc_rem(I,k)) & + duR(I) = -(u(I,j,k) + du_CFL(I)*visc_rem(I,k)) / visc_rem_lim + if (u(I,j,k) + duL(I)*visc_rem_lim < du_CFL(I)*visc_rem(I,k)) & + duL(I) = -(u(I,j,k) - du_CFL(I)*visc_rem(I,k)) / visc_rem_lim + endif + endif ; enddo ; enddo + + do k=1,nz + do I=ish-1,ieh ; if (do_I(I)) then + u_L(I) = u(I,j,k) + duL(I) * visc_rem(I,k) + u_R(I) = u(I,j,k) + duR(I) * visc_rem(I,k) + u_0(I) = u(I,j,k) + du0(I) * visc_rem(I,k) + endif ; enddo + call zonal_flux_layer(u_0, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_0, duhdu_0, & + visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k)) + call zonal_flux_layer(u_L, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_L, duhdu_L, & + visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k)) + call zonal_flux_layer(u_R, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_R, duhdu_R, & + visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k)) + do I=ish-1,ieh ; if (do_I(I)) then + FAmt_0(I) = FAmt_0(I) + duhdu_0(I) + FAmt_L(I) = FAmt_L(I) + duhdu_L(I) + FAmt_R(I) = FAmt_R(I) + duhdu_R(I) + uhtot_L(I) = uhtot_L(I) + uh_L(I) + uhtot_R(I) = uhtot_R(I) + uh_R(I) + endif ; enddo + enddo + do I=ish-1,ieh ; if (do_I(I)) then + FA_0 = FAmt_0(I) ; FA_avg = FAmt_0(I) + if ((duL(I) - du0(I)) /= 0.0) & + FA_avg = uhtot_L(I) / (duL(I) - du0(I)) + if (FA_avg > max(FA_0, FAmt_L(I))) then ; FA_avg = max(FA_0, FAmt_L(I)) + elseif (FA_avg < min(FA_0, FAmt_L(I))) then ; FA_0 = FA_avg ; endif + + BT_cont%FA_u_W0(I,j) = FA_0 ; BT_cont%FA_u_WW(I,j) = FAmt_L(I) + if (abs(FA_0-FAmt_L(I)) <= 1e-12*FA_0) then ; BT_cont%uBT_WW(I,j) = 0.0 ; else + BT_cont%uBT_WW(I,j) = (1.5 * (duL(I) - du0(I))) * & + ((FAmt_L(I) - FA_avg) / (FAmt_L(I) - FA_0)) + endif + + FA_0 = FAmt_0(I) ; FA_avg = FAmt_0(I) + if ((duR(I) - du0(I)) /= 0.0) & + FA_avg = uhtot_R(I) / (duR(I) - du0(I)) + if (FA_avg > max(FA_0, FAmt_R(I))) then ; FA_avg = max(FA_0, FAmt_R(I)) + elseif (FA_avg < min(FA_0, FAmt_R(I))) then ; FA_0 = FA_avg ; endif + + BT_cont%FA_u_E0(I,j) = FA_0 ; BT_cont%FA_u_EE(I,j) = FAmt_R(I) + if (abs(FAmt_R(I) - FA_0) <= 1e-12*FA_0) then ; BT_cont%uBT_EE(I,j) = 0.0 ; else + BT_cont%uBT_EE(I,j) = (1.5 * (duR(I) - du0(I))) * & + ((FAmt_R(I) - FA_avg) / (FAmt_R(I) - FA_0)) + endif + else + BT_cont%FA_u_W0(I,j) = 0.0 ; BT_cont%FA_u_WW(I,j) = 0.0 + BT_cont%FA_u_E0(I,j) = 0.0 ; BT_cont%FA_u_EE(I,j) = 0.0 + BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0 + endif ; enddo + +end subroutine set_zonal_BT_cont + +!> Calculates the mass or volume fluxes through the meridional faces, and other related quantities. +subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, por_face_areaV, & + LB_in, vhbt, visc_rem_v, v_cor, BT_cont, dv_cor) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to + !! calculate fluxes [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< South edge thickness in the + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< North edge thickness in the + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: vh !< Volume flux through meridional + !! faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type + !! specifies whether, where, and what + !! open boundary conditions are used. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] + type(cont_loop_bounds_type), optional, intent(in) :: LB_in !< Loop bounds structure. + real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: vhbt !< The summed volume flux through meridional + !! faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_v !< Both the fraction of the momentum + !! originally in a layer that remains after a time-step of viscosity, + !! and the fraction of a time-step's worth of a barotropic acceleration + !! that a layer experiences after viscosity is applied [nondim]. + !! Visc_rem_v is between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(out) :: v_cor + !< The meridional velocities (v with a barotropic correction) + !! that give vhbt as the depth-integrated transport [L T-1 ~> m s-1]. + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe + !! the effective open face areas as a function of barotropic flow. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(out) :: dv_cor !< The meridional velocity increments from v + !! that give vhbt as the depth-integrated + !! transports [L T-1 ~> m s-1]. + + ! Local variables + real, dimension(SZI_(G),SZK_(GV)) :: & + dvhdv ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. + real, dimension(SZI_(G)) :: & + dv, & ! Corrective barotropic change in the velocity to give vhbt [L T-1 ~> m s-1]. + dv_min_CFL, & ! Lower limit on dv correction to avoid CFL violations [L T-1 ~> m s-1] + dv_max_CFL, & ! Upper limit on dv correction to avoid CFL violations [L T-1 ~> m s-1] + dvhdv_tot_0, & ! Summed partial derivative of vh with v [H L ~> m2 or kg m-1]. + vh_tot_0, & ! Summed transport with no barotropic correction [H L2 T-1 ~> m3 s-1 or kg s-1]. + visc_rem_max ! The column maximum of visc_rem [nondim] + logical, dimension(SZI_(G)) :: do_I + real, dimension(SZI_(G)) :: FAvi ! A list of sums of meridional face areas [H L ~> m2 or kg m-1]. + real :: FA_v ! A sum of meridional face areas [H L ~> m2 or kg m-1]. + real, dimension(SZI_(G),SZK_(GV)) :: & + visc_rem ! A 2-D copy of visc_rem_v or an array of 1's [nondim] + real :: I_vrm ! 1.0 / visc_rem_max [nondim] + real :: CFL_dt ! The maximum CFL ratio of the adjusted velocities divided by + ! the time step [T-1 ~> s-1]. + real :: I_dt ! 1.0 / dt [T-1 ~> s-1]. + real :: dv_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. + real :: dy_N, dy_S ! Effective y-grid spacings to the north and south [L ~> m]. + type(cont_loop_bounds_type) :: LB + integer :: i, j, k, ish, ieh, jsh, jeh, n, nz + integer :: l_seg ! The OBC segment number + logical :: use_visc_rem, set_BT_cont + logical :: local_specified_BC, local_Flather_OBC, local_open_BC, any_simple_OBC ! OBC-related logicals + logical :: simple_OBC_pt(SZI_(G)) ! Indicates points in a row with specified transport OBCs + + call cpu_clock_begin(id_clock_correct) + + use_visc_rem = present(visc_rem_v) + + set_BT_cont = .false. ; if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) + + local_specified_BC = .false. ; local_Flather_OBC = .false. ; local_open_BC = .false. + if (associated(OBC)) then ; if (OBC%OBC_pe) then + local_specified_BC = OBC%specified_v_BCs_exist_globally + local_Flather_OBC = OBC%Flather_v_BCs_exist_globally + local_open_BC = OBC%open_v_BCs_exist_globally + endif ; endif + + if (present(dv_cor)) dv_cor(:,:) = 0.0 + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke + + CFL_dt = CS%CFL_limit_adjust / dt + I_dt = 1.0 / dt + if (CS%aggress_adjust) CFL_dt = I_dt + + if (.not.use_visc_rem) visc_rem(:,:) = 1.0 + !$OMP parallel do default(shared) private(do_I,dvhdv,dv,dv_max_CFL,dv_min_CFL,vh_tot_0, & + !$OMP dvhdv_tot_0,FAvi,visc_rem_max,I_vrm,dv_lim,dy_N,dy_S, & + !$OMP simple_OBC_pt,any_simple_OBC,l_seg) & + !$OMP firstprivate(visc_rem) + do J=jsh-1,jeh + do i=ish,ieh ; do_I(i) = .true. ; enddo + ! This sets vh and dvhdv. + do k=1,nz + if (use_visc_rem) then ; do i=ish,ieh + visc_rem(i,k) = visc_rem_v(i,J,k) + enddo ; endif + call merid_flux_layer(v(:,J,k), h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), & + vh(:,J,k), dvhdv(:,k), visc_rem(:,k), & + dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), OBC) + if (local_specified_BC) then + do i=ish,ieh ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + l_seg = OBC%segnum_v(i,J) + if (OBC%segment(l_seg)%specified) vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k) + endif ; enddo + endif + enddo ! k-loop + + if (present(vhbt) .or. set_BT_cont) then + if (use_visc_rem .and. CS%use_visc_rem_max) then + visc_rem_max(:) = 0.0 + do k=1,nz ; do i=ish,ieh + visc_rem_max(i) = max(visc_rem_max(i), visc_rem(i,k)) + enddo ; enddo + else + visc_rem_max(:) = 1.0 + endif + ! Set limits on dv that will keep the CFL number between -1 and 1. + ! This should be adequate to keep the root bracketed in all cases. + do i=ish,ieh + I_vrm = 0.0 + if (visc_rem_max(i) > 0.0) I_vrm = 1.0 / visc_rem_max(i) + if (CS%vol_CFL) then + dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(i,J), 1000.0*G%dyT(i,j)) + dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(i,J), 1000.0*G%dyT(i,j+1)) + else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif + dv_max_CFL(i) = 2.0 * (CFL_dt * dy_S) * I_vrm + dv_min_CFL(i) = -2.0 * (CFL_dt * dy_N) * I_vrm + vh_tot_0(i) = 0.0 ; dvhdv_tot_0(i) = 0.0 + enddo + do k=1,nz ; do i=ish,ieh + dvhdv_tot_0(i) = dvhdv_tot_0(i) + dvhdv(i,k) + vh_tot_0(i) = vh_tot_0(i) + vh(i,J,k) + enddo ; enddo + + if (use_visc_rem) then + if (CS%aggress_adjust) then + do k=1,nz ; do i=ish,ieh + if (CS%vol_CFL) then + dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(I,j), 1000.0*G%dyT(i,j)) + dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(I,j), 1000.0*G%dyT(i,j+1)) + else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif + dv_lim = 0.499*((dy_S*I_dt - v(i,J,k)) + MIN(0.0,v(i,J-1,k))) + if (dv_max_CFL(i) * visc_rem(i,k) > dv_lim) & + dv_max_CFL(i) = dv_lim / visc_rem(i,k) + + dv_lim = 0.499*((-dy_N*CFL_dt - v(i,J,k)) + MAX(0.0,v(i,J+1,k))) + if (dv_min_CFL(i) * visc_rem(i,k) < dv_lim) & + dv_min_CFL(i) = dv_lim / visc_rem(i,k) + enddo ; enddo + else + do k=1,nz ; do i=ish,ieh + if (CS%vol_CFL) then + dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(I,j), 1000.0*G%dyT(i,j)) + dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(I,j), 1000.0*G%dyT(i,j+1)) + else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif + if (dv_max_CFL(i) * visc_rem(i,k) > dy_S*CFL_dt - v(i,J,k)*G%mask2dCv(i,J)) & + dv_max_CFL(i) = (dy_S*CFL_dt - v(i,J,k)) / visc_rem(i,k) + if (dv_min_CFL(i) * visc_rem(i,k) < -dy_N*CFL_dt - v(i,J,k)*G%mask2dCv(i,J)) & + dv_min_CFL(i) = -(dy_N*CFL_dt + v(i,J,k)) / visc_rem(i,k) + enddo ; enddo + endif + else + if (CS%aggress_adjust) then + do k=1,nz ; do i=ish,ieh + if (CS%vol_CFL) then + dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(I,j), 1000.0*G%dyT(i,j)) + dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(I,j), 1000.0*G%dyT(i,j+1)) + else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif + dv_max_CFL(i) = min(dv_max_CFL(i), 0.499 * & + ((dy_S*I_dt - v(i,J,k)) + MIN(0.0,v(i,J-1,k))) ) + dv_min_CFL(i) = max(dv_min_CFL(i), 0.499 * & + ((-dy_N*I_dt - v(i,J,k)) + MAX(0.0,v(i,J+1,k))) ) + enddo ; enddo + else + do k=1,nz ; do i=ish,ieh + if (CS%vol_CFL) then + dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(I,j), 1000.0*G%dyT(i,j)) + dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(I,j), 1000.0*G%dyT(i,j+1)) + else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif + dv_max_CFL(i) = min(dv_max_CFL(i), dy_S*CFL_dt - v(i,J,k)) + dv_min_CFL(i) = max(dv_min_CFL(i), -(dy_N*CFL_dt + v(i,J,k))) + enddo ; enddo + endif + endif + do i=ish,ieh + dv_max_CFL(i) = max(dv_max_CFL(i),0.0) + dv_min_CFL(i) = min(dv_min_CFL(i),0.0) + enddo + + any_simple_OBC = .false. + if (present(vhbt) .or. set_BT_cont) then + if (local_specified_BC .or. local_Flather_OBC) then ; do i=ish,ieh + l_seg = OBC%segnum_v(i,J) + + ! Avoid reconciling barotropic/baroclinic transports if transport is specified + simple_OBC_pt(i) = .false. + if (l_seg /= OBC_NONE) simple_OBC_pt(i) = OBC%segment(l_seg)%specified + do_I(i) = .not.simple_OBC_pt(i) + any_simple_OBC = any_simple_OBC .or. simple_OBC_pt(i) + enddo ; else ; do i=ish,ieh + do_I(i) = .true. + enddo ; endif + endif + + if (present(vhbt)) then + ! Find dv and vh. + call meridional_flux_adjust(v, h_in, h_S, h_N, vhbt(:,J), vh_tot_0, dvhdv_tot_0, dv, & + dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & + j, ish, ieh, do_I, por_face_areaV, vh, OBC=OBC) + + if (present(v_cor)) then ; do k=1,nz + do i=ish,ieh ; v_cor(i,J,k) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo + if (any_simple_OBC) then ; do i=ish,ieh ; if (simple_OBC_pt(i)) then + v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + endif ; enddo ; endif + enddo ; endif ! v-corrected + + if (present(dv_cor)) then + do i=ish,ieh ; dv_cor(i,J) = dv(i) ; enddo + endif + + endif + + if (set_BT_cont) then + call set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, vh_tot_0, dvhdv_tot_0,& + dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & + visc_rem_max, J, ish, ieh, do_I, por_face_areaV) + if (any_simple_OBC) then + do i=ish,ieh + if (simple_OBC_pt(i)) FAvi(i) = GV%H_subroundoff*G%dx_Cv(i,J) + enddo + ! NOTE: simple_OBC_pt(i) should prevent access to segment OBC_NONE + do k=1,nz ; do i=ish,ieh ; if (simple_OBC_pt(i)) then + if ((abs(OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k)) > 0.0) .and. & + (OBC%segment(OBC%segnum_v(i,J))%specified)) & + FAvi(i) = FAvi(i) + OBC%segment(OBC%segnum_v(i,J))%normal_trans(i,J,k) / & + OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + endif ; enddo ; enddo + do i=ish,ieh ; if (simple_OBC_pt(i)) then + BT_cont%FA_v_S0(i,J) = FAvi(i) ; BT_cont%FA_v_N0(i,J) = FAvi(i) + BT_cont%FA_v_SS(i,J) = FAvi(i) ; BT_cont%FA_v_NN(i,J) = FAvi(i) + BT_cont%vBT_SS(i,J) = 0.0 ; BT_cont%vBT_NN(i,J) = 0.0 + endif ; enddo + endif + endif ! set_BT_cont + + endif ! present(vhbt) or set_BT_cont + + enddo ! j-loop + + if (local_open_BC .and. set_BT_cont) then + do n = 1, OBC%number_of_segments + if (OBC%segment(n)%open .and. OBC%segment(n)%is_N_or_S) then + J = OBC%segment(n)%HI%JsdB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + do i = OBC%segment(n)%HI%Isd, OBC%segment(n)%HI%Ied + FA_v = 0.0 + do k=1,nz ; FA_v = FA_v + h_in(i,j,k)*(G%dx_Cv(i,J)*por_face_areaV(i,J,k)) ; enddo + BT_cont%FA_v_S0(i,J) = FA_v ; BT_cont%FA_v_N0(i,J) = FA_v + BT_cont%FA_v_SS(i,J) = FA_v ; BT_cont%FA_v_NN(i,J) = FA_v + BT_cont%vBT_SS(i,J) = 0.0 ; BT_cont%vBT_NN(i,J) = 0.0 + enddo + else + do i = OBC%segment(n)%HI%Isd, OBC%segment(n)%HI%Ied + FA_v = 0.0 + do k=1,nz ; FA_v = FA_v + h_in(i,j+1,k)*(G%dx_Cv(i,J)*por_face_areaV(i,J,k)) ; enddo + BT_cont%FA_v_S0(i,J) = FA_v ; BT_cont%FA_v_N0(i,J) = FA_v + BT_cont%FA_v_SS(i,J) = FA_v ; BT_cont%FA_v_NN(i,J) = FA_v + BT_cont%vBT_SS(i,J) = 0.0 ; BT_cont%vBT_NN(i,J) = 0.0 + enddo + endif + endif + enddo + endif + + if (set_BT_cont) then ; if (allocated(BT_cont%h_v)) then + if (present(v_cor)) then + call meridional_flux_thickness(v_cor, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + else + call meridional_flux_thickness(v, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + endif + endif ; endif + + call cpu_clock_end(id_clock_correct) + +end subroutine meridional_mass_flux + + +!> Calculates the vertically integrated mass or volume fluxes through the meridional faces. +subroutine meridional_BT_mass_flux(v, h_in, h_S, h_N, vhbt, dt, G, GV, US, CS, OBC, por_face_areaV, LB_in) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to + !! calculate fluxes [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< Southern edge thickness in the PPM + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< Northern edge thickness in the PPM + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G)), intent(out) :: vhbt !< The summed volume flux through meridional + !! faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type + !! specifies whether, where, and what + !! open boundary conditions are used. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] + type(cont_loop_bounds_type), optional, intent(in) :: LB_in !< Loop bounds structure. + + ! Local variables + real :: vh(SZI_(G)) ! Volume flux through meridional faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: dvhdv(SZI_(G)) ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. + logical, dimension(SZI_(G)) :: do_I + real :: ones(SZI_(G)) ! An array of 1's [nondim] + integer :: i, j, k, ish, ieh, jsh, jeh, nz + logical :: local_specified_BC, OBC_in_row + + call cpu_clock_begin(id_clock_correct) + + local_specified_BC = .false. + if (associated(OBC)) then ; if (OBC%OBC_pe) then + local_specified_BC = OBC%specified_v_BCs_exist_globally + endif ; endif + + if (present(LB_in)) then + ish = LB_in%ish ; ieh = LB_in%ieh ; jsh = LB_in%jsh ; jeh = LB_in%jeh ; nz = GV%ke + else + ish = G%isc ; ieh = G%iec ; jsh = G%jsc ; jeh = G%jec ; nz = GV%ke + endif + + ones(:) = 1.0 ; do_I(:) = .true. + + vhbt(:,:) = 0.0 + !$OMP parallel do default(shared) private(vh,dvhdv,OBC_in_row) + do J=jsh-1,jeh + ! Determining whether there are any OBC points outside of the k-loop should be more efficient. + OBC_in_row = .false. + if (local_specified_BC) then ; do i=ish,ieh ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%specified) OBC_in_row = .true. + endif ; enddo ; endif + do k=1,nz + ! This sets vh and dvhdv. + call merid_flux_layer(v(:,J,k), h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh, dvhdv, ones, & + dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), OBC) + if (OBC_in_row) then ; do i=ish,ieh ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%specified) vh(i) = OBC%segment(OBC%segnum_v(i,J))%normal_trans(i,J,k) + endif ; enddo ; endif + + ! Accumulate the barotropic transport. + do i=ish,ieh + vhbt(i,J) = vhbt(i,J) + vh(i) + enddo + enddo ! k-loop + enddo ! j-loop + + call cpu_clock_end(id_clock_correct) + +end subroutine meridional_BT_mass_flux + + +!> Evaluates the meridional mass or volume fluxes in a layer. +subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, & + ish, ieh, do_I, vol_CFL, por_face_areaV, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + real, dimension(SZI_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G)), intent(in) :: visc_rem !< Both the fraction of the + !! momentum originally in a layer that remains after a time-step + !! of viscosity, and the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity is applied [nondim]. + !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Layer thickness used to calculate fluxes, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_S !< South edge thickness in the reconstruction + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_N !< North edge thickness in the reconstruction + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(inout) :: vh !< Meridional mass or volume transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G)), intent(inout) :: dvhdv !< Partial derivative of vh with v + !! [H L ~> m2 or kg m-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: j !< Spatial index. + integer, intent(in) :: ish !< Start of index range. + integer, intent(in) :: ieh !< End of index range. + logical, dimension(SZI_(G)), intent(in) :: do_I !< Which i values to work on. + logical, intent(in) :: vol_CFL !< If true, rescale the + !! ratio of face areas to the cell areas when estimating the CFL number. + real, dimension(SZI_(G),SZJB_(G)), & + intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + ! Local variables + real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] + real :: curv_3 ! A measure of the thickness curvature over a grid length, + ! with the same units as h, i.e. [H ~> m or kg m-2]. + real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. + integer :: i + integer :: l_seg + logical :: local_open_BC + + local_open_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_BC = OBC%open_v_BCs_exist_globally + endif ; endif + + do i=ish,ieh ; if (do_I(i)) then + if (v(i) > 0.0) then + if (vol_CFL) then ; CFL = (v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) + else ; CFL = v(i) * dt * G%IdyT(i,j) ; endif + curv_3 = h_S(i,j) + h_N(i,j) - 2.0*h(i,j) + vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_N(i,j) + CFL * & + (0.5*(h_S(i,j) - h_N(i,j)) + curv_3*(CFL - 1.5)) ) + h_marg = h_N(i,j) + CFL * ((h_S(i,j) - h_N(i,j)) + & + 3.0*curv_3*(CFL - 1.0)) + elseif (v(i) < 0.0) then + if (vol_CFL) then ; CFL = (-v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) + else ; CFL = -v(i) * dt * G%IdyT(i,j+1) ; endif + curv_3 = h_S(i,j+1) + h_N(i,j+1) - 2.0*h(i,j+1) + vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_S(i,j+1) + CFL * & + (0.5*(h_N(i,j+1)-h_S(i,j+1)) + curv_3*(CFL - 1.5)) ) + h_marg = h_S(i,j+1) + CFL * ((h_N(i,j+1)-h_S(i,j+1)) + & + 3.0*curv_3*(CFL - 1.0)) + else + vh(i) = 0.0 + h_marg = 0.5 * (h_S(i,j+1) + h_N(i,j)) + endif + dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h_marg * visc_rem(i) + endif ; enddo + + if (local_open_BC) then + do i=ish,ieh ; if (do_I(i)) then + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * h(i,j) + dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h(i,j) * visc_rem(i) + else + vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * h(i,j+1) + dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h(i,j+1) * visc_rem(i) + endif + endif + endif + endif ; enddo + endif +end subroutine merid_flux_layer + +!> Sets the effective interface thickness associated with the fluxes at each meridional velocity point, +!! optionally scaling back these thicknesses to account for viscosity and fractional open areas. +subroutine meridional_flux_thickness(v, h, h_S, h_N, h_v, dt, G, GV, US, LB, vol_CFL, & + marginal, OBC, por_face_areaV, visc_rem_v) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness used to calculate fluxes, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< South edge thickness in the reconstruction, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< North edge thickness in the reconstruction, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: h_v !< Effective thickness at meridional faces, + !! scaled down to account for the effects of + !! viscosity and the fractional open area + !! [H ~> m or kg m-2]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(cont_loop_bounds_type), intent(in) :: LB !< Loop bounds structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: vol_CFL !< If true, rescale the ratio + !! of face areas to the cell areas when estimating the CFL number. + logical, intent(in) :: marginal !< If true, report the marginal + !! face thicknesses; otherwise report transport-averaged thicknesses. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), optional, intent(in) :: visc_rem_v !< Both the fraction + !! of the momentum originally in a layer that remains after a time-step of + !! viscosity, and the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity is applied [nondim]. + !! Visc_rem_v is between 0 (at the bottom) and 1 (far above the bottom). + + ! Local variables + real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] + real :: curv_3 ! A measure of the thickness curvature over a grid length, + ! with the same units as h [H ~> m or kg m-2] . + real :: h_avg ! The average thickness of a flux [H ~> m or kg m-2]. + real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. + logical :: local_open_BC + integer :: i, j, k, ish, ieh, jsh, jeh, n, nz + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke + + !$OMP parallel do default(shared) private(CFL,curv_3,h_marg,h_avg) + do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh + if (v(i,J,k) > 0.0) then + if (vol_CFL) then ; CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) + else ; CFL = v(i,J,k) * dt * G%IdyT(i,j) ; endif + curv_3 = h_S(i,j,k) + h_N(i,j,k) - 2.0*h(i,j,k) + h_avg = h_N(i,j,k) + CFL * (0.5*(h_S(i,j,k) - h_N(i,j,k)) + curv_3*(CFL - 1.5)) + h_marg = h_N(i,j,k) + CFL * ((h_S(i,j,k) - h_N(i,j,k)) + & + 3.0*curv_3*(CFL - 1.0)) + elseif (v(i,J,k) < 0.0) then + if (vol_CFL) then ; CFL = (-v(i,J,k)*dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) + else ; CFL = -v(i,J,k) * dt * G%IdyT(i,j+1) ; endif + curv_3 = h_S(i,j+1,k) + h_N(i,j+1,k) - 2.0*h(i,j+1,k) + h_avg = h_S(i,j+1,k) + CFL * (0.5*(h_N(i,j+1,k)-h_S(i,j+1,k)) + curv_3*(CFL - 1.5)) + h_marg = h_S(i,j+1,k) + CFL * ((h_N(i,j+1,k)-h_S(i,j+1,k)) + & + 3.0*curv_3*(CFL - 1.0)) + else + h_avg = 0.5 * (h_S(i,j+1,k) + h_N(i,j,k)) + ! The choice to use the arithmetic mean here is somewhat arbitrarily, but + ! it should be noted that h_S(i+1,j,k) and h_N(i,j,k) are usually the same. + h_marg = 0.5 * (h_S(i,j+1,k) + h_N(i,j,k)) + ! h_marg = (2.0 * h_S(i,j+1,k) * h_N(i,j,k)) / & + ! (h_S(i,j+1,k) + h_N(i,j,k) + GV%H_subroundoff) + endif + + if (marginal) then ; h_v(i,J,k) = h_marg + else ; h_v(i,J,k) = h_avg ; endif + enddo ; enddo ; enddo + + if (present(visc_rem_v)) then + ! Scale back the thickness to account for the effects of viscosity and the fractional open + ! thickness to give an appropriate non-normalized weight for each layer in determining the + ! barotropic acceleration. + !$OMP parallel do default(shared) + do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh + h_v(i,J,k) = h_v(i,J,k) * (visc_rem_v(i,J,k) * por_face_areaV(i,J,k)) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh + h_v(i,J,k) = h_v(i,J,k) * por_face_areaV(i,J,k) + enddo ; enddo ; enddo + endif + + local_open_BC = .false. + if (associated(OBC)) local_open_BC = OBC%open_v_BCs_exist_globally + if (local_open_BC) then + do n = 1, OBC%number_of_segments + if (OBC%segment(n)%open .and. OBC%segment(n)%is_N_or_S) then + J = OBC%segment(n)%HI%JsdB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + if (present(visc_rem_v)) then ; do k=1,nz + do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied + h_v(i,J,k) = h(i,j,k) * (visc_rem_v(i,J,k) * por_face_areaV(i,J,k)) + enddo + enddo ; else ; do k=1,nz + do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied + h_v(i,J,k) = h(i,j,k) * por_face_areaV(i,J,k) + enddo + enddo ; endif + else + if (present(visc_rem_v)) then ; do k=1,nz + do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied + h_v(i,J,k) = h(i,j+1,k) * (visc_rem_v(i,J,k) * por_face_areaV(i,J,k)) + enddo + enddo ; else ; do k=1,nz + do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied + h_v(i,J,k) = h(i,j+1,k) * por_face_areaV(i,J,k) + enddo + enddo ; endif + endif + endif + enddo + endif + +end subroutine meridional_flux_thickness + +!> Returns the barotropic velocity adjustment that gives the desired barotropic (layer-summed) transport. +subroutine meridional_flux_adjust(v, h_in, h_S, h_N, vhbt, vh_tot_0, dvhdv_tot_0, & + dv, dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & + j, ish, ieh, do_I_in, por_face_areaV, vh_3d, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),& + intent(in) :: h_S !< South edge thickness in the reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_N !< North edge thickness in the reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: visc_rem + !< Both the fraction of the momentum originally + !! in a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step's worth of a barotropic acceleration that + !! a layer experiences after viscosity is applied [nondim]. + !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G)), intent(in) :: vhbt !< The summed volume flux through meridional faces + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value of dv [L T-1 ~> m s-1]. + real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value of dv [L T-1 ~> m s-1]. + real, dimension(SZI_(G)), intent(in) :: vh_tot_0 !< The summed transport with 0 adjustment + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< The partial derivative of dv_err with + !! dv at 0 adjustment [H L ~> m2 or kg m-1]. + real, dimension(SZI_(G)), intent(out) :: dv !< The barotropic velocity adjustment [L T-1 ~> m s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. + integer, intent(in) :: j !< Spatial index. + integer, intent(in) :: ish !< Start of index range. + integer, intent(in) :: ieh !< End of index range. + logical, dimension(SZI_(G)), & + intent(in) :: do_I_in !< A flag indicating which I values to work on. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(inout) :: vh_3d !< Volume flux through meridional + !! faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + ! Local variables + real, dimension(SZI_(G),SZK_(GV)) :: & + vh_aux, & ! An auxiliary meridional volume flux [H L2 T-1 ~> m3 s-1 or kg s-1]. + dvhdv ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. + real, dimension(SZI_(G)) :: & + vh_err, & ! Difference between vhbt and the summed vh [H L2 T-1 ~> m3 s-1 or kg s-1]. + vh_err_best, & ! The smallest value of vh_err found so far [H L2 T-1 ~> m3 s-1 or kg s-1]. + v_new, & ! The velocity with the correction added [L T-1 ~> m s-1]. + dvhdv_tot,&! Summed partial derivative of vh with u [H L ~> m2 or kg m-1]. + dv_min, & ! Lower limit on dv correction based on CFL limits and previous iterations [L T-1 ~> m s-1] + dv_max ! Upper limit on dv correction based on CFL limits and previous iterations [L T-1 ~> m s-1] + real :: dv_prev ! The previous value of dv [L T-1 ~> m s-1]. + real :: ddv ! The change in dv from the previous iteration [L T-1 ~> m s-1]. + real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2]. + real :: tol_vel ! The tolerance for velocity in the current iteration [L T-1 ~> m s-1]. + integer :: i, k, nz, itt, max_itts = 20 + logical :: domore, do_I(SZI_(G)) + + nz = GV%ke + + vh_aux(:,:) = 0.0 ; dvhdv(:,:) = 0.0 + + if (present(vh_3d)) then ; do k=1,nz ; do i=ish,ieh + vh_aux(i,k) = vh_3d(i,J,k) + enddo ; enddo ; endif + + do i=ish,ieh + dv(i) = 0.0 ; do_I(i) = do_I_in(i) + dv_max(i) = dv_max_CFL(i) ; dv_min(i) = dv_min_CFL(i) + vh_err(i) = vh_tot_0(i) - vhbt(i) ; dvhdv_tot(i) = dvhdv_tot_0(i) + vh_err_best(i) = abs(vh_err(i)) + enddo + + do itt=1,max_itts + select case (itt) + case (:1) ; tol_eta = 1e-6 * CS%tol_eta + case (2) ; tol_eta = 1e-4 * CS%tol_eta + case (3) ; tol_eta = 1e-2 * CS%tol_eta + case default ; tol_eta = CS%tol_eta + end select + tol_vel = CS%tol_vel + + do i=ish,ieh + if (vh_err(i) > 0.0) then ; dv_max(i) = dv(i) + elseif (vh_err(i) < 0.0) then ; dv_min(i) = dv(i) + else ; do_I(i) = .false. ; endif + enddo + domore = .false. + do i=ish,ieh ; if (do_I(i)) then + if ((dt * min(G%IareaT(i,j),G%IareaT(i,j+1))*abs(vh_err(i)) > tol_eta) .or. & + (CS%better_iter .and. ((abs(vh_err(i)) > tol_vel * dvhdv_tot(i)) .or. & + (abs(vh_err(i)) > vh_err_best(i))) )) then + ! Use Newton's method, provided it stays bounded. Otherwise bisect + ! the value with the appropriate bound. + ddv = -vh_err(i) / dvhdv_tot(i) + dv_prev = dv(i) + dv(i) = dv(i) + ddv + if (abs(ddv) < 1.0e-15*abs(dv(i))) then + do_I(i) = .false. ! ddv is small enough to quit. + elseif (ddv > 0.0) then + if (dv(i) >= dv_max(i)) then + dv(i) = 0.5*(dv_prev + dv_max(i)) + if (dv_max(i) - dv_prev < 1.0e-15*abs(dv(i))) do_I(i) = .false. + endif + else ! dvv(i) < 0.0 + if (dv(i) <= dv_min(i)) then + dv(i) = 0.5*(dv_prev + dv_min(i)) + if (dv_prev - dv_min(i) < 1.0e-15*abs(dv(i))) do_I(i) = .false. + endif + endif + if (do_I(i)) domore = .true. + else + do_I(i) = .false. + endif + endif ; enddo + if (.not.domore) exit + + if ((itt < max_itts) .or. present(vh_3d)) then ; do k=1,nz + do i=ish,ieh ; v_new(i) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo + call merid_flux_layer(v_new, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), & + vh_aux(:,k), dvhdv(:,k), visc_rem(:,k), & + dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), OBC) + enddo ; endif + + if (itt < max_itts) then + do i=ish,ieh + vh_err(i) = -vhbt(i) ; dvhdv_tot(i) = 0.0 + enddo + do k=1,nz ; do i=ish,ieh + vh_err(i) = vh_err(i) + vh_aux(i,k) + dvhdv_tot(i) = dvhdv_tot(i) + dvhdv(i,k) + enddo ; enddo + do i=ish,ieh + vh_err_best(i) = min(vh_err_best(i), abs(vh_err(i))) + enddo + endif + enddo ! itt-loop + ! If there are any faces which have not converged to within the tolerance, + ! so-be-it, or else use a final upwind correction? + ! This never seems to happen with 20 iterations as max_itt. + + if (present(vh_3d)) then ; do k=1,nz ; do i=ish,ieh + vh_3d(i,J,k) = vh_aux(i,k) + enddo ; enddo ; endif + +end subroutine meridional_flux_adjust + +!> Sets of a structure that describes the meridional barotropic volume or mass fluxes as a +!! function of barotropic flow to agree closely with the sum of the layer's transports. +subroutine set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, vh_tot_0, dvhdv_tot_0, & + dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & + visc_rem_max, j, ish, ieh, do_I, por_face_areaV) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to calculate fluxes, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< South edge thickness in the reconstruction, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< North edge thickness in the reconstruction, + !! [H ~> m or kg m-2]. + type(BT_cont_type), intent(inout) :: BT_cont !< A structure with elements + !! that describe the effective open face areas as a function of barotropic flow. + real, dimension(SZI_(G)), intent(in) :: vh_tot_0 !< The summed transport + !! with 0 adjustment [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< The partial derivative + !! of du_err with dv at 0 adjustment [H L ~> m2 or kg m-1]. + real, dimension(SZI_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value + !! of dv [L T-1 ~> m s-1]. + real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value + !! of dv [L T-1 ~> m s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: visc_rem !< Both the fraction of the + !! momentum originally in a layer that remains after a time-step + !! of viscosity, and the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity is applied [nondim]. + !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G)), intent(in) :: visc_rem_max !< Maximum allowable visc_rem [nondim] + integer, intent(in) :: j !< Spatial index. + integer, intent(in) :: ish !< Start of index range. + integer, intent(in) :: ieh !< End of index range. + logical, dimension(SZI_(G)), intent(in) :: do_I !< A logical flag indicating + !! which I values to work on. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] + ! Local variables + real, dimension(SZI_(G)) :: & + dv0, & ! The barotropic velocity increment that gives 0 transport [L T-1 ~> m s-1]. + dvL, dvR, & ! The barotropic velocity increments that give the southerly + ! (dvL) and northerly (dvR) test velocities [L T-1 ~> m s-1]. + zeros, & ! An array of full of 0 transports [H L2 T-1 ~> m3 s-1 or kg s-1] + dv_CFL, & ! The velocity increment that corresponds to CFL_min [L T-1 ~> m s-1]. + v_L, v_R, & ! The southerly (v_L), northerly (v_R), and zero-barotropic + v_0, & ! transport (v_0) layer test velocities [L T-1 ~> m s-1]. + dvhdv_L, & ! The effective layer marginal face areas with the southerly + dvhdv_R, & ! (_L), northerly (_R), and zero-barotropic (_0) test + dvhdv_0, & ! velocities [H L ~> m2 or kg m-1]. + vh_L, vh_R, & ! The layer transports with the southerly (_L), northerly (_R) + vh_0, & ! and zero-barotropic (_0) test velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. + FAmt_L, FAmt_R, & ! The summed effective marginal face areas for the 3 + FAmt_0, & ! test velocities [H L ~> m2 or kg m-1]. + vhtot_L, & ! The summed transport with the southerly (vhtot_L) and + vhtot_R ! and northerly (vhtot_R) test velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: FA_0 ! The effective face area with 0 barotropic transport [H L ~> m2 or kg m-1]. + real :: FA_avg ! The average effective face area [H L ~> m2 or kg m-1], nominally given by + ! the realized transport divided by the barotropic velocity. + real :: visc_rem_lim ! The larger of visc_rem and min_visc_rem [nondim] This + ! limiting is necessary to keep the inverse of visc_rem + ! from leading to large CFL numbers. + real :: min_visc_rem ! The smallest permitted value for visc_rem that is used + ! in finding the barotropic velocity that changes the + ! flow direction [nondim]. This is necessary to keep the inverse + ! of visc_rem from leading to large CFL numbers. + real :: CFL_min ! A minimal increment in the CFL to try to ensure that the + ! flow is truly upwind [nondim] + real :: Idt ! The inverse of the time step [T-1 ~> s-1]. + logical :: domore + integer :: i, k, nz + + nz = GV%ke ; Idt = 1.0 / dt + min_visc_rem = 0.1 ; CFL_min = 1e-6 + + ! Diagnose the zero-transport correction, dv0. + do i=ish,ieh ; zeros(i) = 0.0 ; enddo + call meridional_flux_adjust(v, h_in, h_S, h_N, zeros, vh_tot_0, dvhdv_tot_0, dv0, & + dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & + j, ish, ieh, do_I, por_face_areaV) + + ! Determine the southerly- and northerly- fluxes. Choose a sufficiently + ! negative velocity correction for the northerly-flux, and a sufficiently + ! positive correction for the southerly-flux. + domore = .false. + do i=ish,ieh ; if (do_I(i)) then + domore = .true. + dv_CFL(i) = (CFL_min * Idt) * G%dyCv(i,J) + dvR(i) = min(0.0,dv0(i) - dv_CFL(i)) + dvL(i) = max(0.0,dv0(i) + dv_CFL(i)) + FAmt_L(i) = 0.0 ; FAmt_R(i) = 0.0 ; FAmt_0(i) = 0.0 + vhtot_L(i) = 0.0 ; vhtot_R(i) = 0.0 + endif ; enddo + + if (.not.domore) then + do k=1,nz ; do i=ish,ieh + BT_cont%FA_v_S0(i,J) = 0.0 ; BT_cont%FA_v_SS(i,J) = 0.0 + BT_cont%vBT_SS(i,J) = 0.0 + BT_cont%FA_v_N0(i,J) = 0.0 ; BT_cont%FA_v_NN(i,J) = 0.0 + BT_cont%vBT_NN(i,J) = 0.0 + enddo ; enddo + return + endif + + do k=1,nz ; do i=ish,ieh ; if (do_I(i)) then + visc_rem_lim = max(visc_rem(i,k), min_visc_rem*visc_rem_max(i)) + if (visc_rem_lim > 0.0) then ! This is almost always true for ocean points. + if (v(i,J,k) + dvR(i)*visc_rem_lim > -dv_CFL(i)*visc_rem(i,k)) & + dvR(i) = -(v(i,J,k) + dv_CFL(i)*visc_rem(i,k)) / visc_rem_lim + if (v(i,J,k) + dvL(i)*visc_rem_lim < dv_CFL(i)*visc_rem(i,k)) & + dvL(i) = -(v(i,J,k) - dv_CFL(i)*visc_rem(i,k)) / visc_rem_lim + endif + endif ; enddo ; enddo + do k=1,nz + do i=ish,ieh ; if (do_I(i)) then + v_L(i) = v(I,j,k) + dvL(i) * visc_rem(i,k) + v_R(i) = v(I,j,k) + dvR(i) * visc_rem(i,k) + v_0(i) = v(I,j,k) + dv0(i) * visc_rem(i,k) + endif ; enddo + call merid_flux_layer(v_0, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_0, dvhdv_0, & + visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k)) + call merid_flux_layer(v_L, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_L, dvhdv_L, & + visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k)) + call merid_flux_layer(v_R, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_R, dvhdv_R, & + visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k)) + do i=ish,ieh ; if (do_I(i)) then + FAmt_0(i) = FAmt_0(i) + dvhdv_0(i) + FAmt_L(i) = FAmt_L(i) + dvhdv_L(i) + FAmt_R(i) = FAmt_R(i) + dvhdv_R(i) + vhtot_L(i) = vhtot_L(i) + vh_L(i) + vhtot_R(i) = vhtot_R(i) + vh_R(i) + endif ; enddo + enddo + do i=ish,ieh ; if (do_I(i)) then + FA_0 = FAmt_0(i) ; FA_avg = FAmt_0(i) + if ((dvL(i) - dv0(i)) /= 0.0) & + FA_avg = vhtot_L(i) / (dvL(i) - dv0(i)) + if (FA_avg > max(FA_0, FAmt_L(i))) then ; FA_avg = max(FA_0, FAmt_L(i)) + elseif (FA_avg < min(FA_0, FAmt_L(i))) then ; FA_0 = FA_avg ; endif + BT_cont%FA_v_S0(i,J) = FA_0 ; BT_cont%FA_v_SS(i,J) = FAmt_L(i) + if (abs(FA_0-FAmt_L(i)) <= 1e-12*FA_0) then ; BT_cont%vBT_SS(i,J) = 0.0 ; else + BT_cont%vBT_SS(i,J) = (1.5 * (dvL(i) - dv0(i))) * & + ((FAmt_L(i) - FA_avg) / (FAmt_L(i) - FA_0)) + endif + + FA_0 = FAmt_0(i) ; FA_avg = FAmt_0(i) + if ((dvR(i) - dv0(i)) /= 0.0) & + FA_avg = vhtot_R(i) / (dvR(i) - dv0(i)) + if (FA_avg > max(FA_0, FAmt_R(i))) then ; FA_avg = max(FA_0, FAmt_R(i)) + elseif (FA_avg < min(FA_0, FAmt_R(i))) then ; FA_0 = FA_avg ; endif + BT_cont%FA_v_N0(i,J) = FA_0 ; BT_cont%FA_v_NN(i,J) = FAmt_R(i) + if (abs(FAmt_R(i) - FA_0) <= 1e-12*FA_0) then ; BT_cont%vBT_NN(i,J) = 0.0 ; else + BT_cont%vBT_NN(i,J) = (1.5 * (dvR(i) - dv0(i))) * & + ((FAmt_R(i) - FA_avg) / (FAmt_R(i) - FA_0)) + endif + else + BT_cont%FA_v_S0(i,J) = 0.0 ; BT_cont%FA_v_SS(i,J) = 0.0 + BT_cont%FA_v_N0(i,J) = 0.0 ; BT_cont%FA_v_NN(i,J) = 0.0 + BT_cont%vBT_SS(i,J) = 0.0 ; BT_cont%vBT_NN(i,J) = 0.0 + endif ; enddo + +end subroutine set_merid_BT_cont + +!> Calculates left/right edge values for PPM reconstruction. +subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_2nd, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_W !< West edge thickness in the reconstruction, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_E !< East edge thickness in the reconstruction, + !! [H ~> m or kg m-2]. + type(cont_loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. + real, intent(in) :: h_min !< The minimum thickness + !! that can be obtained by a concave parabolic fit [H ~> m or kg m-2] + logical, intent(in) :: monotonic !< If true, use the + !! Colella & Woodward monotonic limiter. + !! Otherwise use a simple positive-definite limiter. + logical, intent(in) :: simple_2nd !< If true, use the + !! arithmetic mean thicknesses as the default edge values + !! for a simple 2nd order scheme. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + + ! Local variables with useful mnemonic names. + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes per grid point [H ~> m or kg m-2] + real, parameter :: oneSixth = 1./6. ! [nondim] + real :: h_ip1, h_im1 ! Neighboring thicknesses or sensibly extrapolated values [H ~> m or kg m-2] + real :: dMx, dMn ! The difference between the local thickness and the maximum (dMx) or + ! minimum (dMn) of the surrounding values [H ~> m or kg m-2] + character(len=256) :: mesg + integer :: i, j, isl, iel, jsl, jel, n, stencil + logical :: local_open_BC + type(OBC_segment_type), pointer :: segment => NULL() + + local_open_BC = .false. + if (associated(OBC)) then + local_open_BC = OBC%open_u_BCs_exist_globally + endif + + isl = LB%ish-1 ; iel = LB%ieh+1 ; jsl = LB%jsh ; jel = LB%jeh + + ! This is the stencil of the reconstruction, not the scheme overall. + stencil = 2 ; if (simple_2nd) stencil = 1 + + if ((isl-stencil < G%isd) .or. (iel+stencil > G%ied)) then + write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_x called with a ", & + & "x-halo that needs to be increased by ",i2,".")') & + stencil + max(G%isd-isl,iel-G%ied) + call MOM_error(FATAL,mesg) + endif + if ((jsl < G%jsd) .or. (jel > G%jed)) then + write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_x called with a ", & + & "y-halo that needs to be increased by ",i2,".")') & + max(G%jsd-jsl,jel-G%jed) + call MOM_error(FATAL,mesg) + endif + + if (simple_2nd) then + do j=jsl,jel ; do i=isl,iel + h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j) + h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j) + h_W(i,j) = 0.5*( h_im1 + h_in(i,j) ) + h_E(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + enddo ; enddo + else + do j=jsl,jel ; do i=isl-1,iel+1 + if ((G%mask2dT(i-1,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) == 0.0) then + slp(i,j) = 0.0 + else + ! This uses a simple 2nd order slope. + slp(i,j) = 0.5 * (h_in(i+1,j) - h_in(i-1,j)) + ! Monotonic constraint, see Eq. B2 in Lin 1994, MWR (132) + dMx = max(h_in(i+1,j), h_in(i-1,j), h_in(i,j)) - h_in(i,j) + dMn = h_in(i,j) - min(h_in(i+1,j), h_in(i-1,j), h_in(i,j)) + slp(i,j) = sign(1.,slp(i,j)) * min(abs(slp(i,j)), 2. * min(dMx, dMn)) + ! * (G%mask2dT(i-1,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) + endif + enddo ; enddo + + if (local_open_BC) then + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%direction == OBC_DIRECTION_E .or. & + segment%direction == OBC_DIRECTION_W) then + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + slp(i+1,j) = 0.0 + slp(i,j) = 0.0 + enddo + endif + enddo + endif + + do j=jsl,jel ; do i=isl,iel + ! Neighboring values should take into account any boundaries. The 3 + ! following sets of expressions are equivalent. + ! h_im1 = h_in(i-1,j,k) ; if (G%mask2dT(i-1,j) < 0.5) h_im1 = h_in(i,j) + ! h_ip1 = h_in(i+1,j,k) ; if (G%mask2dT(i+1,j) < 0.5) h_ip1 = h_in(i,j) + h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j) + h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j) + ! Left/right values following Eq. B2 in Lin 1994, MWR (132) + h_W(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) ) + h_E(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) ) + enddo ; enddo + endif + + if (local_open_BC) then + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%direction == OBC_DIRECTION_E) then + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + h_W(i+1,j) = h_in(i,j) + h_E(i+1,j) = h_in(i,j) + h_W(i,j) = h_in(i,j) + h_E(i,j) = h_in(i,j) + enddo + elseif (segment%direction == OBC_DIRECTION_W) then + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + h_W(i,j) = h_in(i+1,j) + h_E(i,j) = h_in(i+1,j) + h_W(i+1,j) = h_in(i+1,j) + h_E(i+1,j) = h_in(i+1,j) + enddo + endif + enddo + endif + + if (monotonic) then + call PPM_limit_CW84(h_in, h_W, h_E, G, isl, iel, jsl, jel) + else + call PPM_limit_pos(h_in, h_W, h_E, h_min, G, isl, iel, jsl, jel) + endif + + return +end subroutine PPM_reconstruction_x + +!> Calculates left/right edge values for PPM reconstruction. +subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_2nd, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_S !< South edge thickness in the reconstruction, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_N !< North edge thickness in the reconstruction, + !! [H ~> m or kg m-2]. + type(cont_loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. + real, intent(in) :: h_min !< The minimum thickness + !! that can be obtained by a concave parabolic fit [H ~> m or kg m-2] + logical, intent(in) :: monotonic !< If true, use the + !! Colella & Woodward monotonic limiter. + !! Otherwise use a simple positive-definite limiter. + logical, intent(in) :: simple_2nd !< If true, use the + !! arithmetic mean thicknesses as the default edge values + !! for a simple 2nd order scheme. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + + ! Local variables with useful mnemonic names. + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes per grid point [H ~> m or kg m-2] + real, parameter :: oneSixth = 1./6. ! [nondim] + real :: h_jp1, h_jm1 ! Neighboring thicknesses or sensibly extrapolated values [H ~> m or kg m-2] + real :: dMx, dMn ! The difference between the local thickness and the maximum (dMx) or + ! minimum (dMn) of the surrounding values [H ~> m or kg m-2] + character(len=256) :: mesg + integer :: i, j, isl, iel, jsl, jel, n, stencil + logical :: local_open_BC + type(OBC_segment_type), pointer :: segment => NULL() + + local_open_BC = .false. + if (associated(OBC)) then + local_open_BC = OBC%open_v_BCs_exist_globally + endif + + isl = LB%ish ; iel = LB%ieh ; jsl = LB%jsh-1 ; jel = LB%jeh+1 + + ! This is the stencil of the reconstruction, not the scheme overall. + stencil = 2 ; if (simple_2nd) stencil = 1 + + if ((isl < G%isd) .or. (iel > G%ied)) then + write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_y called with a ", & + & "x-halo that needs to be increased by ",i2,".")') & + max(G%isd-isl,iel-G%ied) + call MOM_error(FATAL,mesg) + endif + if ((jsl-stencil < G%jsd) .or. (jel+stencil > G%jed)) then + write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_y called with a ", & + & "y-halo that needs to be increased by ",i2,".")') & + stencil + max(G%jsd-jsl,jel-G%jed) + call MOM_error(FATAL,mesg) + endif + + if (simple_2nd) then + do j=jsl,jel ; do i=isl,iel + h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j) + h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j) + h_S(i,j) = 0.5*( h_jm1 + h_in(i,j) ) + h_N(i,j) = 0.5*( h_jp1 + h_in(i,j) ) + enddo ; enddo + else + do j=jsl-1,jel+1 ; do i=isl,iel + if ((G%mask2dT(i,j-1) * G%mask2dT(i,j) * G%mask2dT(i,j+1)) == 0.0) then + slp(i,j) = 0.0 + else + ! This uses a simple 2nd order slope. + slp(i,j) = 0.5 * (h_in(i,j+1) - h_in(i,j-1)) + ! Monotonic constraint, see Eq. B2 in Lin 1994, MWR (132) + dMx = max(h_in(i,j+1), h_in(i,j-1), h_in(i,j)) - h_in(i,j) + dMn = h_in(i,j) - min(h_in(i,j+1), h_in(i,j-1), h_in(i,j)) + slp(i,j) = sign(1.,slp(i,j)) * min(abs(slp(i,j)), 2. * min(dMx, dMn)) + ! * (G%mask2dT(i,j-1) * G%mask2dT(i,j) * G%mask2dT(i,j+1)) + endif + enddo ; enddo + + if (local_open_BC) then + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%direction == OBC_DIRECTION_S .or. & + segment%direction == OBC_DIRECTION_N) then + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + slp(i,j+1) = 0.0 + slp(i,j) = 0.0 + enddo + endif + enddo + endif + + do j=jsl,jel ; do i=isl,iel + ! Neighboring values should take into account any boundaries. The 3 + ! following sets of expressions are equivalent. + h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j) + h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j) + ! Left/right values following Eq. B2 in Lin 1994, MWR (132) + h_S(i,j) = 0.5*( h_jm1 + h_in(i,j) ) + oneSixth*( slp(i,j-1) - slp(i,j) ) + h_N(i,j) = 0.5*( h_jp1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i,j+1) ) + enddo ; enddo + endif + + if (local_open_BC) then + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%direction == OBC_DIRECTION_N) then + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + h_S(i,j+1) = h_in(i,j) + h_N(i,j+1) = h_in(i,j) + h_S(i,j) = h_in(i,j) + h_N(i,j) = h_in(i,j) + enddo + elseif (segment%direction == OBC_DIRECTION_S) then + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + h_S(i,j) = h_in(i,j+1) + h_N(i,j) = h_in(i,j+1) + h_S(i,j+1) = h_in(i,j+1) + h_N(i,j+1) = h_in(i,j+1) + enddo + endif + enddo + endif + + if (monotonic) then + call PPM_limit_CW84(h_in, h_S, h_N, G, isl, iel, jsl, jel) + else + call PPM_limit_pos(h_in, h_S, h_N, h_min, G, isl, iel, jsl, jel) + endif + + return +end subroutine PPM_reconstruction_y + +!> This subroutine limits the left/right edge values of the PPM reconstruction +!! to give a reconstruction that is positive-definite. Here this is +!! reinterpreted as giving a constant thickness if the mean thickness is less +!! than h_min, with a minimum of h_min otherwise. +subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left thickness in the reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right thickness in the reconstruction [H ~> m or kg m-2]. + real, intent(in) :: h_min !< The minimum thickness + !! that can be obtained by a concave parabolic fit [H ~> m or kg m-2] + integer, intent(in) :: iis !< Start of i index range. + integer, intent(in) :: iie !< End of i index range. + integer, intent(in) :: jis !< Start of j index range. + integer, intent(in) :: jie !< End of j index range. + +! Local variables + real :: curv ! The grid-normalized curvature of the three thicknesses [H ~> m or kg m-2] + real :: dh ! The difference between the edge thicknesses [H ~> m or kg m-2] + real :: scale ! A scaling factor to reduce the curvature of the fit [nondim] + integer :: i,j + + do j=jis,jie ; do i=iis,iie + ! This limiter prevents undershooting minima within the domain with + ! values less than h_min. + curv = 3.0*(h_L(i,j) + h_R(i,j) - 2.0*h_in(i,j)) + if (curv > 0.0) then ! Only minima are limited. + dh = h_R(i,j) - h_L(i,j) + if (abs(dh) < curv) then ! The parabola's minimum is within the cell. + if (h_in(i,j) <= h_min) then + h_L(i,j) = h_in(i,j) ; h_R(i,j) = h_in(i,j) + elseif (12.0*curv*(h_in(i,j) - h_min) < (curv**2 + 3.0*dh**2)) then + ! The minimum value is h_in - (curv^2 + 3*dh^2)/(12*curv), and must + ! be limited in this case. 0 < scale < 1. + scale = 12.0*curv*(h_in(i,j) - h_min) / (curv**2 + 3.0*dh**2) + h_L(i,j) = h_in(i,j) + scale*(h_L(i,j) - h_in(i,j)) + h_R(i,j) = h_in(i,j) + scale*(h_R(i,j) - h_in(i,j)) + endif + endif + endif + enddo ; enddo + +end subroutine PPM_limit_pos + +!> This subroutine limits the left/right edge values of the PPM reconstruction +!! according to the monotonic prescription of Colella and Woodward, 1984. +subroutine PPM_limit_CW84(h_in, h_L, h_R, G, iis, iie, jis, jie) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left thickness in the reconstruction, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right thickness in the reconstruction, + !! [H ~> m or kg m-2]. + integer, intent(in) :: iis !< Start of i index range. + integer, intent(in) :: iie !< End of i index range. + integer, intent(in) :: jis !< Start of j index range. + integer, intent(in) :: jie !< End of j index range. + + ! Local variables + real :: h_i ! A copy of the cell-average layer thickness [H ~> m or kg m-2] + real :: RLdiff ! The difference between the input edge values [H ~> m or kg m-2] + real :: RLdiff2 ! The squared difference between the input edge values [H2 ~> m2 or kg2 m-4] + real :: RLmean ! The average of the input edge thicknesses [H ~> m or kg m-2] + real :: FunFac ! A curious product of the thickness slope and curvature [H2 ~> m2 or kg2 m-4] + integer :: i, j + + do j=jis,jie ; do i=iis,iie + ! This limiter monotonizes the parabola following + ! Colella and Woodward, 1984, Eq. 1.10 + h_i = h_in(i,j) + if ( ( h_R(i,j) - h_i ) * ( h_i - h_L(i,j) ) <= 0. ) then + h_L(i,j) = h_i ; h_R(i,j) = h_i + else + RLdiff = h_R(i,j) - h_L(i,j) ! Difference of edge values + RLmean = 0.5 * ( h_R(i,j) + h_L(i,j) ) ! Mean of edge values + FunFac = 6. * RLdiff * ( h_i - RLmean ) ! Some funny factor + RLdiff2 = RLdiff * RLdiff ! Square of difference + if ( FunFac > RLdiff2 ) h_L(i,j) = 3. * h_i - 2. * h_R(i,j) + if ( FunFac < -RLdiff2 ) h_R(i,j) = 3. * h_i - 2. * h_L(i,j) + endif + enddo ; enddo + + return +end subroutine PPM_limit_CW84 + +!> Return the maximum ratio of a/b or maxrat. +function ratio_max(a, b, maxrat) result(ratio) + real, intent(in) :: a !< Numerator, in arbitrary units [A] + real, intent(in) :: b !< Denominator, in arbitrary units [B] + real, intent(in) :: maxrat !< Maximum value of ratio [A B-1] + real :: ratio !< Return value [A B-1] + + if (abs(a) > abs(maxrat*b)) then + ratio = maxrat + else + ratio = a / b + endif +end function ratio_max + +!> Initializes continuity_ppm_cs +subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) + type(time_type), target, intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating + !! the open file to parse for model parameter values. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to + !! regulate diagnostic output. + type(continuity_PPM_CS), intent(inout) :: CS !< Module's control structure. + + !> This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_continuity_PPM" ! This module's name. + + CS%initialized = .true. + +! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "MONOTONIC_CONTINUITY", CS%monotonic, & + "If true, CONTINUITY_PPM uses the Colella and Woodward "//& + "monotonic limiter. The default (false) is to use a "//& + "simple positive definite limiter.", default=.false.) + call get_param(param_file, mdl, "SIMPLE_2ND_PPM_CONTINUITY", CS%simple_2nd, & + "If true, CONTINUITY_PPM uses a simple 2nd order "//& + "(arithmetic mean) interpolation of the edge values. "//& + "This may give better PV conservation properties. While "//& + "it formally reduces the accuracy of the continuity "//& + "solver itself in the strongly advective limit, it does "//& + "not reduce the overall order of accuracy of the dynamic "//& + "core.", default=.false.) + call get_param(param_file, mdl, "UPWIND_1ST_CONTINUITY", CS%upwind_1st, & + "If true, CONTINUITY_PPM becomes a 1st-order upwind "//& + "continuity solver. This scheme is highly diffusive "//& + "but may be useful for debugging or in single-column "//& + "mode where its minimal stencil is useful.", default=.false.) + call get_param(param_file, mdl, "ETA_TOLERANCE", CS%tol_eta, & + "The tolerance for the differences between the "//& + "barotropic and baroclinic estimates of the sea surface "//& + "height due to the fluxes through each face. The total "//& + "tolerance for SSH is 4 times this value. The default "//& + "is 0.5*NK*ANGSTROM, and this should not be set less "//& + "than about 10^-15*MAXIMUM_DEPTH.", units="m", scale=GV%m_to_H, & + default=0.5*GV%ke*GV%Angstrom_m) + + call get_param(param_file, mdl, "VELOCITY_TOLERANCE", CS%tol_vel, & + "The tolerance for barotropic velocity discrepancies "//& + "between the barotropic solution and the sum of the "//& + "layer thicknesses.", units="m s-1", default=3.0e8, scale=US%m_s_to_L_T) + ! The speed of light is the default. + + call get_param(param_file, mdl, "CONT_PPM_AGGRESS_ADJUST", CS%aggress_adjust,& + "If true, allow the adjusted velocities to have a "//& + "relative CFL change up to 0.5.", default=.false.) + CS%vol_CFL = CS%aggress_adjust + call get_param(param_file, mdl, "CONT_PPM_VOLUME_BASED_CFL", CS%vol_CFL, & + "If true, use the ratio of the open face lengths to the "//& + "tracer cell areas when estimating CFL numbers. The "//& + "default is set by CONT_PPM_AGGRESS_ADJUST.", & + default=CS%aggress_adjust, do_not_read=CS%aggress_adjust) + call get_param(param_file, mdl, "CONTINUITY_CFL_LIMIT", CS%CFL_limit_adjust, & + "The maximum CFL of the adjusted velocities.", units="nondim", & + default=0.5) + call get_param(param_file, mdl, "CONT_PPM_BETTER_ITER", CS%better_iter, & + "If true, stop corrective iterations using a velocity "//& + "based criterion and only stop if the iteration is "//& + "better than all predecessors.", default=.true.) + call get_param(param_file, mdl, "CONT_PPM_USE_VISC_REM_MAX", CS%use_visc_rem_max, & + "If true, use more appropriate limiting bounds for "//& + "corrections in strongly viscous columns.", default=.true.) + call get_param(param_file, mdl, "CONT_PPM_MARGINAL_FACE_AREAS", CS%marginal_faces, & + "If true, use the marginal face areas from the continuity "//& + "solver for use as the weights in the barotropic solver. "//& + "Otherwise use the transport averaged areas.", default=.true.) + + CS%diag => diag + + id_clock_reconstruct = cpu_clock_id('(Ocean continuity reconstruction)', grain=CLOCK_ROUTINE) + id_clock_update = cpu_clock_id('(Ocean continuity update)', grain=CLOCK_ROUTINE) + id_clock_correct = cpu_clock_id('(Ocean continuity correction)', grain=CLOCK_ROUTINE) + +end subroutine continuity_PPM_init + +!> continuity_PPM_stencil returns the continuity solver stencil size +function continuity_PPM_stencil(CS) result(stencil) + type(continuity_PPM_CS), intent(in) :: CS !< Module's control structure. + integer :: stencil !< The continuity solver stencil size with the current settings. + + stencil = 3 ; if (CS%simple_2nd) stencil = 2 ; if (CS%upwind_1st) stencil = 1 + +end function continuity_PPM_stencil + +!> Set up a structure that stores the sizes of the i- and j-loops to to work on in the continuity solver. +function set_continuity_loop_bounds(G, CS, i_stencil, j_stencil) result(LB) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(continuity_PPM_CS), intent(in) :: CS !< Module's control structure. + logical, optional, intent(in) :: i_stencil !< If present and true, extend the i-loop bounds + !! by the stencil width of the continuity scheme. + logical, optional, intent(in) :: j_stencil !< If present and true, extend the j-loop bounds + !! by the stencil width of the continuity scheme. + type(cont_loop_bounds_type) :: LB !< A type storing the array sizes to work on in the continuity routines. + + ! Local variables + logical :: add_i_stencil, add_j_stencil ! Local variables set based on i_stencil and j_stensil + integer :: stencil ! The continuity solver stencil size with the current continuity scheme. + + add_i_stencil = .false. ; if (present(i_stencil)) add_i_stencil = i_stencil + add_j_stencil = .false. ; if (present(j_stencil)) add_j_stencil = j_stencil + + stencil = continuity_PPM_stencil(CS) + + if (add_i_stencil) then + LB%ish = G%isc-stencil ; LB%ieh = G%iec+stencil + else + LB%ish = G%isc ; LB%ieh = G%iec + endif + + if (add_j_stencil) then + LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil + else + LB%jsh = G%jsc ; LB%jeh = G%jec + endif + +end function set_continuity_loop_bounds + +!> \namespace mom_continuity_ppm +!! +!! This module contains the subroutines that advect layer +!! thickness. The scheme here uses a Piecewise-Parabolic method with +!! a positive definite limiter. + +end module MOM_continuity_PPM diff --git a/core/MOM_density_integrals.F90 b/core/MOM_density_integrals.F90 new file mode 100644 index 0000000000..9fed528e71 --- /dev/null +++ b/core/MOM_density_integrals.F90 @@ -0,0 +1,1697 @@ +!> Provides integrals of density +module MOM_density_integrals + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type +use MOM_EOS, only : EOS_quadrature, EOS_domain +use MOM_EOS, only : analytic_int_density_dz +use MOM_EOS, only : analytic_int_specific_vol_dp +use MOM_EOS, only : calculate_density +use MOM_EOS, only : calculate_spec_vol +use MOM_EOS, only : calculate_specific_vol_derivs +use MOM_EOS, only : average_specific_vol +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_hor_index, only : hor_index_type +use MOM_string_functions, only : uppercase +use MOM_variables, only : thermo_var_ptrs +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public int_density_dz +public int_density_dz_generic_pcm +public int_density_dz_generic_plm +public int_density_dz_generic_ppm +public int_specific_vol_dp +public int_spec_vol_dp_generic_pcm +public int_spec_vol_dp_generic_plm +public avg_specific_vol +public find_depth_of_pressure_in_cell + +contains + +!> Calls the appropriate subroutine to calculate analytical and nearly-analytical +!! integrals in z across layers of pressure anomalies, which are +!! required for calculating the finite-volume form pressure accelerations in a +!! Boussinesq model. +subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p) + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is + !! subtracted out to reduce the magnitude of each of the + !! integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dpa !< The change in the pressure anomaly + !! across the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the + !! layer of the pressure anomaly relative to the + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + + if (EOS_quadrature(EOS)) then + call int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + else + call analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + endif + +end subroutine int_density_dz + + +!> Calculates (by numerical quadrature) integrals of pressure anomalies across layers, which +!! are required for calculating the finite-volume form pressure accelerations in a Boussinesq model. +subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dz_neglect, useMassWghtInterp, use_inaccurate_form, Z_0p) + type(hor_index_type), intent(in) :: HI !< Horizontal index type for input variables. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature of the layer [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity of the layer [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is + !! subtracted out to reduce the magnitude + !! of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dpa !< The change in the pressure anomaly + !! across the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the + !! layer of the pressure anomaly relative to the + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of + !! density anomalies, as was used prior to March 2018. + real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + + ! Local variables + real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] and [S ~> ppt] + real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] + real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] + real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] + real :: dz ! The layer thickness [Z ~> m] + real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: hWght ! A pressure-thickness below topography [Z ~> m] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2] + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] + logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: use_rho_ref ! Pass rho_ref to the equation of state for more accurate calculation + ! of density anomalies. + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + GxRho = G_e * rho_0 + I_Rho = 1.0 / rho_0 + z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + use_rho_ref = .true. + if (present(use_inaccurate_form)) then + if (use_inaccurate_form) use_rho_ref = .not. use_inaccurate_form + endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + "bathyT must be present if useMassWghtInterp is present and true.") + if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dz = z_t(i,j) - z_b(i,j) + do n=1,5 + T5(n) = T(i,j) ; S5(n) = S(i,j) + p5(n) = -GxRho*((z_t(i,j) - z0pres) - 0.25*real(n-1)*dz) + enddo + if (use_rho_ref) then + call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) + else + call calculate_density(T5, S5, p5, r5, EOS) + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - rho_ref + endif + + dpa(i,j) = G_e*dz*rho_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the pressure anomaly. + if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) + enddo ; enddo + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + p5(1) = -GxRho*((wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) - z0pres) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + if (use_rho_ref) then + call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) + else + call calculate_density(T5, S5, p5, r5, EOS) + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - rho_ref ) + endif + + enddo + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo ; enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) + p5(1) = -GxRho*((wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) - z0pres) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + if (use_rho_ref) then + call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) + else + call calculate_density(T5, S5, p5, r5, EOS) + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - rho_ref ) + endif + + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo ; enddo ; endif +end subroutine int_density_dz_generic_pcm + + +!> Compute pressure gradient force integrals by quadrature for the case where +!! T and S are linear profiles. +subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & + rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, use_stanley_eos, dpa, & + intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp, & + use_inaccurate_form, Z_0p) + integer, intent(in) :: k !< Layer index to calculate integrals for + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: T_t !< Potential temperature at the cell top [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: T_b !< Potential temperature at the cell bottom [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: S_t !< Salinity at the cell top [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: S_b !< Salinity at the cell bottom [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)+1), & + intent(in) :: e !< Height of interfaces [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3], that is used to calculate + !! the pressure (as p~=-z*rho_0*G_e) used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: dz_subroundoff !< A minuscule thickness change [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: use_stanley_eos !< If true, turn on Stanley SGS T variance parameterization + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of + !! the pressure anomaly relative to the anomaly at the + !! top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the y grid spacing [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of + !! density anomalies, as was used prior to March 2018. + real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + +! This subroutine calculates (by numerical quadrature) integrals of +! pressure anomalies across layers, which are required for calculating the +! finite-volume form pressure accelerations in a Boussinesq model. The one +! potentially dodgy assumption here is that rho_0 is used both in the denominator +! of the accelerations, and in the pressure used to calculated density (the +! latter being -z*rho_0*G_e). These two uses could be separated if need be. +! +! It is assumed that the salinity and temperature profiles are linear in the +! vertical. The top and bottom values within each layer are provided and +! a linear interpolation is used to compute intermediate values. + + ! Local variables + real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [C ~> degC] + real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [S ~> ppt] + real :: T25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temperature variance along a line of subgrid + ! locations [C2 ~> degC2] + real :: TS5((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temp-salt covariance along a line of subgrid + ! locations [C S ~> degC ppt] + real :: S25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS salinity variance along a line of subgrid locations [S2 ~> ppt2] + real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations [R L2 T-2 ~> Pa] + real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid + ! locations [R ~> kg m-3] + real :: u5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid locations + ! (used for inaccurate form) [R ~> kg m-3] + real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [C ~> degC] + real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [S ~> ppt] + real :: T215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temperature variance along a line of subgrid + ! locations [C2 ~> degC2] + real :: TS15((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temp-salt covariance along a line of subgrid + ! locations [C S ~> degC ppt] + real :: S215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS salinity variance along a line of subgrid + ! locations [S2 ~> ppt2] + real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [R L2 T-2 ~> Pa] + real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations [R ~> kg m-3] + real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] + real :: rho_anom ! A density anomaly [R ~> kg m-3] + real :: w_left, w_right ! Left and right weights [nondim] + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] + real :: dz(HI%iscB:HI%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] + real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] + real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] + real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [C ~> degC] + real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [S ~> ppt] + real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: hWght ! A topographically limited thickness weight [Z ~> m] + real :: hL, hR ! Thicknesses to the left and right [Z ~> m] + real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] + logical :: use_rho_ref ! Pass rho_ref to the equation of state for more accurate calculation + ! of density anomalies. + logical :: use_varT, use_varS, use_covarTS ! Logicals for SGS variances fields + integer, dimension(2) :: EOSdom_q5 ! The 5-point q-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state + + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + GxRho = G_e * rho_0 + I_Rho = 1.0 / rho_0 + z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + massWeightToggle = 0. + if (present(useMassWghtInterp)) then + if (useMassWghtInterp) massWeightToggle = 1. + endif + use_rho_ref = .true. + if (present(use_inaccurate_form)) then + if (use_inaccurate_form) use_rho_ref = .not. use_inaccurate_form + endif + + use_varT = .false. !ensure initialized + use_covarTS = .false. + use_varS = .false. + if (use_stanley_eos) then + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) + endif + + T25(:) = 0. + TS5(:) = 0. + S25(:) = 0. + T215(:) = 0. + TS15(:) = 0. + S215(:) = 0. + + do n = 1, 5 + wt_t(n) = 0.25 * real(5-n) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! Set the loop ranges for equation of state calculations at various points. + EOSdom_q5(1) = 1 ; EOSdom_q5(2) = (ieq-isq+2)*5 + EOSdom_q15(1) = 1 ; EOSdom_q15(2) = 15*(ieq-isq+1) + EOSdom_h15(1) = 1 ; EOSdom_h15(2) = 15*(HI%iec-HI%isc+1) + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1 + do i = Isq,Ieq+1 + dz(i) = e(i,j,K) - e(i,j,K+1) + do n=1,5 + p5(i*5+n) = -GxRho*((e(i,j,K) - z0pres) - 0.25*real(n-1)*dz(i)) + ! Salinity and temperature points are linearly interpolated + S5(i*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * S_b(i,j,k) + T5(i*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * T_b(i,j,k) + enddo + if (use_varT) T25(i*5+1:i*5+5) = tv%varT(i,j,k) + if (use_covarTS) TS5(i*5+1:i*5+5) = tv%covarTS(i,j,k) + if (use_varS) S25(i*5+1:i*5+5) = tv%varS(i,j,k) + enddo + if (use_Stanley_eos) then + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, EOSdom_q5, rho_ref=rho_ref) + else + if (use_rho_ref) then + call calculate_density(T5, S5, p5, r5, EOS, EOSdom_q5, rho_ref=rho_ref) + else + call calculate_density(T5, S5, p5, r5, EOS, EOSdom_q5) + u5(:) = r5(:) - rho_ref + endif + endif + + if (use_rho_ref) then + do i=Isq,Ieq+1 + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) + dpa(i,j) = G_e*dz(i)*rho_anom + if (present(intz_dpa)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & + (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) + endif + enddo + else + do i=Isq,Ieq+1 + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) & + - rho_ref + dpa(i,j) = G_e*dz(i)*rho_anom + if (present(intz_dpa)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & + (rho_anom - C1_90*(16.0*(u5(i*5+4)-u5(i*5+2)) + 7.0*(u5(i*5+5)-u5(i*5+1))) ) + endif + enddo + endif + enddo ! end loops on j + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec + do I=Isq,Ieq + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom + else + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + dz_x(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + pos = i*15+(m-2)*5 + T15(pos+1) = w_left*Ttl + w_right*Ttr + T15(pos+5) = w_left*Tbl + w_right*Tbr + + S15(pos+1) = w_left*Stl + w_right*Str + S15(pos+5) = w_left*Sbl + w_right*Sbr + + p15(pos+1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i+1,j,K)) - z0pres) + + ! Pressure + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) + enddo + + ! Salinity and temperature (linear interpolation in the vertical) + do n=2,4 + S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) + T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) + enddo + if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) + if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) + if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) + enddo + enddo + + if (use_stanley_eos) then + call calculate_density(T15, S15, p15, T215, TS15, S215, r15, EOS, EOSdom_q15, rho_ref=rho_ref) + else + if (use_rho_ref) then + call calculate_density(T15, S15, p15, r15, EOS, EOSdom_q15, rho_ref=rho_ref) + else + call calculate_density(T15, S15, p15, r15, EOS, EOSdom_q15) + endif + endif + + do I=Isq,Ieq + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + + ! Use Boole's rule to estimate the pressure anomaly change. + if (use_rho_ref) then + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) ) + enddo + else + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) - rho_ref ) + enddo + endif + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(I,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo + enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dpa)) then ; do J=Jsq,Jeq + do i=HI%isc,HI%iec + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom + else + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + dz_y(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + pos = i*15+(m-2)*5 + T15(pos+1) = w_left*Ttl + w_right*Ttr + T15(pos+5) = w_left*Tbl + w_right*Tbr + + S15(pos+1) = w_left*Stl + w_right*Str + S15(pos+5) = w_left*Sbl + w_right*Sbr + + p15(pos+1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i,j+1,K)) - z0pres) + + ! Pressure + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) + enddo + + ! Salinity and temperature (linear interpolation in the vertical) + do n=2,4 + S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) + T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) + enddo + if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) + if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) + if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) + enddo + enddo + + if (use_stanley_eos) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15, rho_ref=rho_ref) + else + if (use_rho_ref) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15, rho_ref=rho_ref) + else + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15) + endif + endif + + do i=HI%isc,HI%iec + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + + ! Use Boole's rule to estimate the pressure anomaly change. + if (use_rho_ref) then + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) ) + enddo + else + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) - rho_ref ) + enddo + endif + ! Use Boole's rule to integrate the values. + inty_dpa(i,J) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo + enddo ; endif + +end subroutine int_density_dz_generic_plm + + +!> Compute pressure gradient force integrals for layer "k" and the case where T and S +!! are parabolic profiles +subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, use_stanley_eos, & + dpa, intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp, Z_0p) + integer, intent(in) :: k !< Layer index to calculate integrals for + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: T_t !< Potential temperature at the cell top [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: T_b !< Potential temperature at the cell bottom [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: S_t !< Salinity at the cell top [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: S_b !< Salinity at the cell bottom [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)+1), & + intent(in) :: e !< Height of interfaces [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is + !! subtracted out to reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3], that is used to calculate + !! the pressure (as p~=-z*rho_0*G_e) used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: dz_subroundoff !< A minuscule thickness change [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: use_stanley_eos !< If true, turn on Stanley SGS T variance parameterization + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of + !! the pressure anomaly relative to the anomaly at the + !! top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the y grid spacing [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + +! This subroutine calculates (by numerical quadrature) integrals of +! pressure anomalies across layers, which are required for calculating the +! finite-volume form pressure accelerations in a Boussinesq model. The one +! potentially dodgy assumption here is that rho_0 is used both in the denominator +! of the accelerations, and in the pressure used to calculated density (the +! latter being -z*rho_0*G_e). These two uses could be separated if need be. +! +! It is assumed that the salinity and temperature profiles are parabolic in the +! vertical. The top and bottom values within each layer are provided and +! a parabolic interpolation is used to compute intermediate values. + + ! Local variables + real :: T5(5) ! Temperatures along a line of subgrid locations [C ~> degC] + real :: S5(5) ! Salinities along a line of subgrid locations [S ~> ppt] + real :: T25(5) ! SGS temperature variance along a line of subgrid locations [C2 ~> degC2] + real :: TS5(5) ! SGS temperature-salinity covariance along a line of subgrid locations [C S ~> degC ppt] + real :: S25(5) ! SGS salinity variance along a line of subgrid locations [S2 ~> ppt2] + real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] + real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] + real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] + real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] + real :: w_left, w_right ! Left and right weights [nondim] + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: GxRho ! The gravitational acceleration times density [R L2 Z-1 T-2 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] + real :: dz ! Layer thicknesses at tracer points [Z ~> m] + real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: Ttl, Tbl, Tml, Ttr, Tbr, Tmr ! Temperatures at the velocity cell corners [C ~> degC] + real :: Stl, Sbl, Sml, Str, Sbr, Smr ! Salinities at the velocity cell corners [S ~> ppt] + real :: s6 ! PPM curvature coefficient for S [S ~> ppt] + real :: t6 ! PPM curvature coefficient for T [C ~> degC] + real :: T_top, T_mn, T_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of T [C ~> degC] + real :: S_top, S_mn, S_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of S [S ~> ppt] + real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: hWght ! A topographically limited thickness weight [Z ~> m] + real :: hL, hR ! Thicknesses to the left and right [Z ~> m] + real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n + logical :: use_PPM ! If false, assume zero curvature in reconstruction, i.e. PLM + logical :: use_varT, use_varS, use_covarTS + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + GxRho = G_e * rho_0 + I_Rho = 1.0 / rho_0 + z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + massWeightToggle = 0. + if (present(useMassWghtInterp)) then + if (useMassWghtInterp) massWeightToggle = 1. + endif + + ! In event PPM calculation is bypassed with use_PPM=False + s6 = 0. + t6 = 0. + use_PPM = .true. ! This is a place-holder to allow later re-use of this function + + use_varT = .false. !ensure initialized + use_covarTS = .false. + use_varS = .false. + if (use_stanley_eos) then + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) + endif + + T25(:) = 0. + TS5(:) = 0. + S25(:) = 0. + + do n = 1, 5 + wt_t(n) = 0.25 * real(5-n) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (use_PPM) then + ! Curvature coefficient of the parabolas + s6 = 3.0 * ( 2.0*tv%S(i,j,k) - ( S_t(i,j,k) + S_b(i,j,k) ) ) + t6 = 3.0 * ( 2.0*tv%T(i,j,k) - ( T_t(i,j,k) + T_b(i,j,k) ) ) + endif + dz = e(i,j,K) - e(i,j,K+1) + do n=1,5 + p5(n) = -GxRho*((e(i,j,K) - z0pres) - 0.25*real(n-1)*dz) + ! Salinity and temperature points are reconstructed with PPM + S5(n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) + enddo + if (use_stanley_eos) then + if (use_varT) T25(:) = tv%varT(i,j,k) + if (use_covarTS) TS5(:) = tv%covarTS(i,j,k) + if (use_varS) S25(:) = tv%varS(i,j,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, rho_ref=rho_ref) + else + call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) + dpa(i,j) = G_e*dz*rho_anom + if (present(intz_dpa)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) + endif + enddo ; enddo ! end loops on j and i + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i+1,j,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i+1,j,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i+1,j,k) + (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i+1,j,k) ) * iDenom + else + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) + Tml = tv%T(i,j,k); Tmr = tv%T(i+1,j,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) + Sml = tv%S(i,j,k); Smr = tv%S(i+1,j,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + T_top = w_left*Ttl + w_right*Ttr + T_mn = w_left*Tml + w_right*Tmr + T_bot = w_left*Tbl + w_right*Tbr + + S_top = w_left*Stl + w_right*Str + S_mn = w_left*Sml + w_right*Smr + S_bot = w_left*Sbl + w_right*Sbr + + ! Pressure + dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) + p5(1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i+1,j,K)) - z0pres) + do n=2,5 + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + + ! Parabolic reconstructions in the vertical for T and S + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) + endif + do n=1,5 + S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + enddo + if (use_stanley_eos) then + if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) + if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) + if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, rho_ref=rho_ref) + else + call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(I,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + + enddo ; enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i,j+1,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i,j+1,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i,j+1,k)+ (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i,j+1,k) ) * iDenom + else + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) + Tml = tv%T(i,j,k); Tmr = tv%T(i,j+1,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) + Sml = tv%S(i,j,k); Smr = tv%S(i,j+1,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + T_top = w_left*Ttl + w_right*Ttr + T_mn = w_left*Tml + w_right*Tmr + T_bot = w_left*Tbl + w_right*Tbr + + S_top = w_left*Stl + w_right*Str + S_mn = w_left*Sml + w_right*Smr + S_bot = w_left*Sbl + w_right*Sbr + + ! Pressure + dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) + p5(1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i,j+1,K)) - z0pres) + do n=2,5 + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + + ! Parabolic reconstructions in the vertical for T and S + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) + endif + do n=1,5 + S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + enddo + + if (use_stanley_eos) then + if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) + if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) + if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, rho_ref=rho_ref) + else + call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + + ! Use Boole's rule to integrate the bottom pressure anomaly values in y. + inty_dpa(i,J) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + + enddo ; enddo ; endif + +end subroutine int_density_dz_generic_ppm + +!> Calls the appropriate subroutine to calculate analytical and nearly-analytical +!! integrals in pressure across layers of geopotential anomalies, which are +!! required for calculating the finite-volume form pressure accelerations in a +!! non-Boussinesq model. There are essentially no free assumptions, apart from the +!! use of Boole's rule to do the horizontal integrals, and from a truncation in the +!! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] + !! The calculation is mathematically identical with different values of + !! alpha_ref, but this reduces the effects of roundoff. + type(EOS_type), intent(in) :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the + !! geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of the layer divided by + !! the x grid spacing [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of the layer divided by + !! the y grid spacing [L2 T-2 ~> m2 s-2] + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + + if (EOS_quadrature(EOS)) then + call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + else + call analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + endif + +end subroutine int_specific_vol_dp + + +!> This subroutine calculates integrals of specific volume anomalies in +!! pressure across layers, which are required for calculating the finite-volume +!! form pressure accelerations in a non-Boussinesq model. There are essentially +!! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. +subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, dza, & + intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature of the layer [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity of the layer [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] + !! The calculation is mathematically identical with different values of + !! alpha_ref, but alpha_ref alters the effects of roundoff, and + !! answers do change. + type(EOS_type), intent(in) :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dza !< The change in the geopotential anomaly + !! across the layer [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between + !! the geopotential anomaly at the top and bottom of the layer divided + !! by the x grid spacing [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between + !! the geopotential anomaly at the top and bottom of the layer divided + !! by the y grid spacing [L2 T-2 ~> m2 s-2] + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, optional, intent(in) :: dP_neglect !< A minuscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + +! This subroutine calculates analytical and nearly-analytical integrals in +! pressure across layers of geopotential anomalies, which are required for +! calculating the finite-volume form pressure accelerations in a non-Boussinesq +! model. There are essentially no free assumptions, apart from the use of +! Boole's rule to do the horizontal integrals, and from a truncation in the +! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. + + ! Local variables + real :: T5(5) ! Temperatures at five quadrature points [C ~> degC] + real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] + real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] + real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, n, halo + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& + "bathyP must be present if useMassWghtInterp is present and true.") + if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& + "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=jsh,jeh ; do i=ish,ieh + dp = p_b(i,j) - p_t(i,j) + do n=1,5 + T5(n) = T(i,j) ; S5(n) = S(i,j) + p5(n) = p_b(i,j) - 0.25*real(n-1)*dp + enddo + + call calculate_spec_vol(T5, S5, p5, a5, EOS, spv_ref=alpha_ref) + + ! Use Boole's rule to estimate the interface height anomaly change. + alpha_anom = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + p5(1) = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - 0.25*dp + enddo + call calculate_spec_vol(T5, S5, p5, a5, EOS, spv_ref=alpha_ref) + + ! Use Boole's rule to estimate the interface height anomaly change. + intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & + 12.0*a5(3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + p5(1) = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - 0.25*dp + enddo + call calculate_spec_vol(T5, S5, p5, a5, EOS, spv_ref=alpha_ref) + + ! Use Boole's rule to estimate the interface height anomaly change. + intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & + 12.0*a5(3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in y. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + +end subroutine int_spec_vol_dp_generic_pcm + +!> This subroutine calculates integrals of specific volume anomalies in +!! pressure across layers, which are required for calculating the finite-volume +!! form pressure accelerations in a non-Boussinesq model. There are essentially +!! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. +subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & + dP_neglect, bathyP, HI, EOS, US, dza, & + intp_dza, intx_dza, inty_dza, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T_t !< Potential temperature at the top of the layer [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T_b !< Potential temperature at the bottom of the layer [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S_t !< Salinity at the top the layer [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S_b !< Salinity at the bottom the layer [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] + !! The calculation is mathematically identical with different values of + !! alpha_ref, but alpha_ref alters the effects of roundoff, and + !! answers do change. + real, intent(in) :: dP_neglect ! Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dza !< The change in the geopotential anomaly + !! across the layer [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between + !! the geopotential anomaly at the top and bottom of the layer divided + !! by the x grid spacing [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between + !! the geopotential anomaly at the top and bottom of the layer divided + !! by the y grid spacing [L2 T-2 ~> m2 s-2] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + +! This subroutine calculates analytical and nearly-analytical integrals in +! pressure across layers of geopotential anomalies, which are required for +! calculating the finite-volume form pressure accelerations in a non-Boussinesq +! model. There are essentially no free assumptions, apart from the use of +! Boole's rule to do the horizontal integrals, and from a truncation in the +! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. + + real :: T5(5) ! Temperatures at five quadrature points [C ~> degC] + real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] + real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] + real :: T15(15) ! Temperatures at fifteen interior quadrature points [C ~> degC] + real :: S15(15) ! Salinities at fifteen interior quadrature points [S ~> ppt] + real :: p15(15) ! Pressures at fifteen quadrature points [R L2 T-2 ~> Pa] + real :: a15(15) ! Specific volumes at fifteen quadrature points [R-1 ~> m3 kg-1] + real :: wt_t(5), wt_b(5) ! Weights of top and bottom values at quadrature points [nondim] + real :: T_top, T_bot ! Horizontally interpolated temperature at the cell top and bottom [C ~> degC] + real :: S_top, S_bot ! Horizontally interpolated salinity at the cell top and bottom [S ~> ppt] + real :: P_top, P_bot ! Horizontally interpolated pressure at the cell top and bottom [R L2 T-2 ~> Pa] + + real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] + real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [R L2 T-2 ~> Pa] + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + logical :: do_massWeight ! Indicates whether to do mass weighting. + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + do_massWeight = .false. + if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp + + do n = 1, 5 ! Note that these are reversed from int_density_dz. + wt_t(n) = 0.25 * real(n-1) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dp = p_b(i,j) - p_t(i,j) + do n=1,5 ! T, S and p are linearly interpolated in the vertical. + p5(n) = wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j) + S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) + T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) + enddo + call calculate_spec_vol(T5, S5, p5, a5, EOS, spv_ref=alpha_ref) + + ! Use Boole's rule to estimate the interface height anomaly change. + alpha_anom = C1_90*((7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4))) + 12.0*a5(3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) + enddo ; enddo + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. Note: To work in terrain following coordinates we could + ! offset this distance by the layer thickness to replicate other models. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) + dp_90(m) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = (m-2)*5 + do n=1,5 + p15(pos+n) = wt_t(n) * P_top + wt_b(n) * P_bot + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo + enddo + + call calculate_spec_vol(T15, S15, p15, a15, EOS, spv_ref=alpha_ref) + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = (m-2)*5 + intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) + dp_90(m) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = (m-2)*5 + do n=1,5 + p15(pos+n) = wt_t(n) * P_top + wt_b(n) * P_bot + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo + enddo + + call calculate_spec_vol(T15, S15, p15, a15, EOS, spv_ref=alpha_ref) + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = (m-2)*5 + intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo ; enddo ; endif + +end subroutine int_spec_vol_dp_generic_plm + + +!> Find the depth at which the reconstructed pressure matches P_tgt +subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_tgt, & + rho_ref, G_e, EOS, US, P_b, z_out, z_tol) + real, intent(in) :: T_t !< Potential temperature at the cell top [C ~> degC] + real, intent(in) :: T_b !< Potential temperature at the cell bottom [C ~> degC] + real, intent(in) :: S_t !< Salinity at the cell top [S ~> ppt] + real, intent(in) :: S_b !< Salinity at the cell bottom [S ~> ppt] + real, intent(in) :: z_t !< Absolute height of top of cell [Z ~> m] (Boussinesq ????) + real, intent(in) :: z_b !< Absolute height of bottom of cell [Z ~> m] + real, intent(in) :: P_t !< Anomalous pressure of top of cell, relative + !! to g*rho_ref*z_t [R L2 T-2 ~> Pa] + real, intent(in) :: P_tgt !< Target pressure at height z_out, relative + !! to g*rho_ref*z_out [R L2 T-2 ~> Pa] + real, intent(in) :: rho_ref !< Reference density with which calculation + !! are anomalous to [R ~> kg m-3] + real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(out) :: P_b !< Pressure at the bottom of the cell [R L2 T-2 ~> Pa] + real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt [Z ~> m] + real, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m] + + ! Local variables + real :: dp ! Pressure thickness of the layer [R L2 T-2 ~> Pa] + real :: F_guess, F_l, F_r ! Fractional positions [nondim] + real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] + real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz [R L2 T-2 ~> Pa] + character(len=240) :: msg + + GxRho = G_e * rho_ref + + ! Anomalous pressure difference across whole cell + dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS) + + P_b = P_t + dp ! Anomalous pressure at bottom of cell + + if (P_tgt <= P_t ) then + z_out = z_t + return + endif + + if (P_tgt >= P_b) then + z_out = z_b + return + endif + + F_l = 0. + Pa_left = P_t - P_tgt ! Pa_left < 0 + F_r = 1. + Pa_right = P_b - P_tgt ! Pa_right > 0 + Pa_tol = GxRho * z_tol + + F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) + Pa = Pa_right - Pa_left ! To get into iterative loop + do while ( abs(Pa) > Pa_tol ) + + z_out = z_t + ( z_b - z_t ) * F_guess + Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) + + if (PaPa_right) then + write(msg,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt + call MOM_error(FATAL, 'find_depth_of_pressure_in_cell out of bounds positive: /n'//msg) + elseif (Pa>0.) then + Pa_right = Pa + F_r = F_guess + else ! Pa == 0 + return + endif + F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) + + enddo + +end subroutine find_depth_of_pressure_in_cell + +!> Calculate the average in situ specific volume across layers +subroutine avg_specific_vol(T, S, p_t, dp, HI, EOS, SpV_avg, halo_size) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature of the layer [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity of the layer [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: dp !< Pressure change in the layer [R L2 T-2 ~> Pa] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [R-1 ~> m3 kg-1] + integer, optional, intent(in) :: halo_size !< The number of halo points in which to work. + + ! Local variables + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: jsh, jeh, j, halo + + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + jsh = HI%jsc-halo ; jeh = HI%jec+halo + + EOSdom(:) = EOS_domain(HI, halo_size) + do j=jsh,jeh + call average_specific_vol(T(:,j), S(:,j), p_t(:,j), dp(:,j), SpV_avg(:,j), EOS, EOSdom) + enddo + +end subroutine avg_specific_vol + +!> Returns change in anomalous pressure change from top to non-dimensional +!! position pos between z_t and z_b [R L2 T-2 ~> Pa] +real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS) + real, intent(in) :: T_t !< Potential temperature at the cell top [C ~> degC] + real, intent(in) :: T_b !< Potential temperature at the cell bottom [C ~> degC] + real, intent(in) :: S_t !< Salinity at the cell top [S ~> ppt] + real, intent(in) :: S_b !< Salinity at the cell bottom [S ~> ppt] + real, intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] + real, intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted out to + !! reduce the magnitude of each of the integrals. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + + ! Local variables + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: dz ! Distance from the layer top [Z ~> m] + real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] + real :: rho_ave ! Average density [R ~> kg m-3] + real, dimension(5) :: T5 ! Temperatures at quadrature points [C ~> degC] + real, dimension(5) :: S5 ! Salinities at quadrature points [S ~> ppt] + real, dimension(5) :: p5 ! Pressures at quadrature points [R L2 T-2 ~> Pa] + real, dimension(5) :: rho5 ! Densities at quadrature points [R ~> kg m-3] + integer :: n + + do n=1,5 + ! Evaluate density at five quadrature points + bottom_weight = 0.25*real(n-1) * pos + top_weight = 1.0 - bottom_weight + ! Salinity and temperature points are linearly interpolated + S5(n) = top_weight * S_t + bottom_weight * S_b + T5(n) = top_weight * T_t + bottom_weight * T_b + p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) + enddo + call calculate_density(T5, S5, p5, rho5, EOS) + rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref + + ! Use Boole's rule to estimate the average density + rho_ave = C1_90*(7.0*(rho5(1)+rho5(5)) + 32.0*(rho5(2)+rho5(4)) + 12.0*rho5(3)) + + dz = ( z_t - z_b ) * pos + frac_dp_at_pos = G_e * dz * rho_ave +end function frac_dp_at_pos + +end module MOM_density_integrals + +!> \namespace mom_density_integrals +!! diff --git a/core/MOM_dynamics_split_RK2.F90 b/core/MOM_dynamics_split_RK2.F90 new file mode 100644 index 0000000000..0557ec7cd5 --- /dev/null +++ b/core/MOM_dynamics_split_RK2.F90 @@ -0,0 +1,1864 @@ +!> Time step the adiabatic dynamic core of MOM using RK2 method. +module MOM_dynamics_split_RK2 + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_type +use MOM_variables, only : BT_cont_type, alloc_bt_cont_type, dealloc_bt_cont_type +use MOM_variables, only : accel_diag_ptrs, ocean_internal_state, cont_diag_ptrs +use MOM_forcing_type, only : mech_forcing + +use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum, MOM_accel_chksum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : diag_mediator_init, enable_averages +use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr +use MOM_diag_mediator, only : post_product_u, post_product_sum_u +use MOM_diag_mediator, only : post_product_v, post_product_sum_v +use MOM_diag_mediator, only : register_diag_field, register_static_field +use MOM_diag_mediator, only : set_diag_mediator_grid, diag_ctrl, diag_update_remap_grids +use MOM_domains, only : To_South, To_West, To_All, CGRID_NE, SCALAR_PAIR +use MOM_domains, only : To_North, To_East, Omit_Corners +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : start_group_pass, complete_group_pass, pass_var, pass_vector +use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_io, only : vardesc, var_desc, EAST_FACE, NORTH_FACE +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, set_initialized, save_restart +use MOM_restart, only : only_read_from_restarts +use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS +use MOM_time_manager, only : time_type, time_type_to_real, operator(+) +use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) + +use MOM_ALE, only : ALE_CS, ALE_remap_velocities +use MOM_barotropic, only : barotropic_init, btstep, btcalc, bt_mass_source +use MOM_barotropic, only : register_barotropic_restarts, set_dtbt, barotropic_CS +use MOM_barotropic, only : barotropic_end +use MOM_boundary_update, only : update_OBC_data, update_OBC_CS +use MOM_continuity, only : continuity, continuity_CS +use MOM_continuity, only : continuity_init, continuity_stencil +use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_CS +use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end +use MOM_debugging, only : check_redundant +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS +use MOM_hor_visc, only : hor_visc_init, hor_visc_end +use MOM_interface_heights, only : thickness_to_dz, find_col_avg_SpV +use MOM_lateral_mixing_coeffs, only : VarMix_CS +use MOM_MEKE_types, only : MEKE_type +use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds +use MOM_open_boundary, only : open_boundary_zero_normal_flow, open_boundary_query +use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp +use MOM_PressureForce, only : PressureForce, PressureForce_CS +use MOM_PressureForce, only : PressureForce_init +use MOM_set_visc, only : set_viscous_ML, set_visc_CS +use MOM_thickness_diffuse, only : thickness_diffuse_CS +use MOM_self_attr_load, only : SAL_CS +use MOM_self_attr_load, only : SAL_init, SAL_end +use MOM_tidal_forcing, only : tidal_forcing_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end +use MOM_unit_scaling, only : unit_scale_type +use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_remnant +use MOM_vert_friction, only : vertvisc_init, vertvisc_end, vertvisc_CS +use MOM_vert_friction, only : updateCFLtruncationValue, vertFPmix +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units +use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units +use MOM_wave_interface, only : wave_parameters_CS, Stokes_PGF +use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS +use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member + +implicit none ; private + +#include + +!> MOM_dynamics_split_RK2 module control structure +type, public :: MOM_dyn_split_RK2_CS ; private + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & + CAu, & !< CAu = f*v - u.grad(u) [L T-2 ~> m s-2] + CAu_pred, & !< The predictor step value of CAu = f*v - u.grad(u) [L T-2 ~> m s-2] + PFu, & !< PFu = -dM/dx [L T-2 ~> m s-2] + PFu_Stokes, & !< PFu_Stokes = -d/dx int_r (u_L*duS/dr) [L T-2 ~> m s-2] + diffu !< Zonal acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2] + + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & + CAv, & !< CAv = -f*u - u.grad(v) [L T-2 ~> m s-2] + CAv_pred, & !< The predictor step value of CAv = -f*u - u.grad(v) [L T-2 ~> m s-2] + PFv, & !< PFv = -dM/dy [L T-2 ~> m s-2] + PFv_Stokes, & !< PFv_Stokes = -d/dy int_r (v_L*dvS/dr) [L T-2 ~> m s-2] + diffv !< Meridional acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2] + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: visc_rem_u + !< Both the fraction of the zonal momentum originally in a + !! layer that remains after a time-step of viscosity, and the + !! fraction of a time-step worth of a barotropic acceleration + !! that a layer experiences after viscosity is applied [nondim]. + !! Nondimensional between 0 (at the bottom) and 1 (far above). + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_accel_bt + !< The zonal layer accelerations due to the difference between + !! the barotropic accelerations and the baroclinic accelerations + !! that were fed into the barotopic calculation [L T-2 ~> m s-2] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: visc_rem_v + !< Both the fraction of the meridional momentum originally in + !! a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step worth of a barotropic acceleration + !! that a layer experiences after viscosity is applied [nondim]. + !! Nondimensional between 0 (at the bottom) and 1 (far above). + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_accel_bt + !< The meridional layer accelerations due to the difference between + !! the barotropic accelerations and the baroclinic accelerations + !! that were fed into the barotopic calculation [L T-2 ~> m s-2] + + ! The following variables are only used with the split time stepping scheme. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta !< Instantaneous free surface height (in Boussinesq + !! mode) or column mass anomaly (in non-Boussinesq + !! mode) [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_av !< layer x-velocity with vertical mean replaced by + !! time-mean barotropic velocity over a baroclinic + !! timestep [L T-1 ~> m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_av !< layer y-velocity with vertical mean replaced by + !! time-mean barotropic velocity over a baroclinic + !! timestep [L T-1 ~> m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: h_av !< arithmetic mean of two successive layer + !! thicknesses [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_PF !< instantaneous SSH used in calculating PFu and + !! PFv [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: uhbt !< average x-volume or mass flux determined by the + !! barotropic solver [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! uhbt is roughly equal to the vertical sum of uh. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vhbt !< average y-volume or mass flux determined by the + !! barotropic solver [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! vhbt is roughly equal to vertical sum of vh. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure + !! anomaly in each layer due to free surface height + !! anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to ge + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure + + real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the + !! effective summed open face areas as a function + !! of barotropic flow. + + ! This is to allow the previous, velocity-based coupling with between the + ! baroclinic and barotropic modes. + logical :: BT_use_layer_fluxes !< If true, use the summed layered fluxes plus + !! an adjustment due to a changed barotropic + !! velocity in the barotropic continuity equation. + logical :: split_bottom_stress !< If true, provide the bottom stress + !! calculated by the vertical viscosity to the + !! barotropic solver. + logical :: calc_dtbt !< If true, calculate the barotropic time-step + !! dynamically. + logical :: store_CAu !< If true, store the Coriolis and advective accelerations at the + !! end of the timestep for use in the next predictor step. + logical :: CAu_pred_stored !< If true, the Coriolis and advective accelerations at the + !! end of the timestep have been stored for use in the next + !! predictor step. This is used to accomodate various generations + !! of restart files. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. + logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D + !! variables that are needed to reproduce across restarts, + !! similarly to what is done with the primary state variables. + + real :: be !< A nondimensional number from 0.5 to 1 that controls + !! the backward weighting of the time stepping scheme [nondim] + real :: begw !< A nondimensional number from 0 to 1 that controls + !! the extent to which the treatment of gravity waves + !! is forward-backward (0) or simulated backward + !! Euler (1) [nondim]. 0 is often used. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. + logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. + logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + + !>@{ Diagnostic IDs + integer :: id_uold = -1, id_vold = -1 + integer :: id_uh = -1, id_vh = -1 + integer :: id_umo = -1, id_vmo = -1 + integer :: id_umo_2d = -1, id_vmo_2d = -1 + integer :: id_PFu = -1, id_PFv = -1 + integer :: id_CAu = -1, id_CAv = -1 + integer :: id_ueffA = -1, id_veffA = -1 + ! integer :: id_hf_PFu = -1, id_hf_PFv = -1 + integer :: id_h_PFu = -1, id_h_PFv = -1 + integer :: id_hf_PFu_2d = -1, id_hf_PFv_2d = -1 + integer :: id_intz_PFu_2d = -1, id_intz_PFv_2d = -1 + integer :: id_PFu_visc_rem = -1, id_PFv_visc_rem = -1 + ! integer :: id_hf_CAu = -1, id_hf_CAv = -1 + integer :: id_h_CAu = -1, id_h_CAv = -1 + 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 + integer :: id_u_BT_accel = -1, id_v_BT_accel = -1 + ! integer :: id_hf_u_BT_accel = -1, id_hf_v_BT_accel = -1 + integer :: id_h_u_BT_accel = -1, id_h_v_BT_accel = -1 + integer :: id_hf_u_BT_accel_2d = -1, id_hf_v_BT_accel_2d = -1 + integer :: id_intz_u_BT_accel_2d = -1, id_intz_v_BT_accel_2d = -1 + integer :: id_u_BT_accel_visc_rem = -1, id_v_BT_accel_visc_rem = -1 + !>@} + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the + !! timing of diagnostic output. + type(accel_diag_ptrs), pointer :: ADp => NULL() !< A structure pointing to the various + !! accelerations in the momentum equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + type(accel_diag_ptrs), pointer :: AD_pred => NULL() !< A structure pointing to the various + !! predictor step accelerations in the momentum equations, + !! which can be used to debug truncations. + type(cont_diag_ptrs), pointer :: CDp => NULL() !< A structure with pointers to various + !! terms in the continuity equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + + ! The remainder of the structure points to child subroutines' control structures. + !> A pointer to the horizontal viscosity control structure + type(hor_visc_CS) :: hor_visc + !> A pointer to the continuity control structure + type(continuity_CS) :: continuity_CSp + !> The CoriolisAdv control structure + type(CoriolisAdv_CS) :: CoriolisAdv + !> A pointer to the PressureForce control structure + type(PressureForce_CS) :: PressureForce_CSp + !> A pointer to a structure containing interface height diffusivities + type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() + !> A pointer to the set_visc control structure + type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the barotropic stepping control structure + type(barotropic_CS) :: barotropic_CSp + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp + !> A pointer to the tidal forcing control structure + type(tidal_forcing_CS) :: tides_CSp + !> A pointer to the ALE control structure. + type(ALE_CS), pointer :: ALE_CSp => NULL() + + type(ocean_OBC_type), pointer :: OBC => NULL() !< A pointer to an open boundary + !! condition type that specifies whether, where, and what open boundary + !! conditions are used. If no open BCs are used, this pointer stays + !! nullified. Flather OBCs use open boundary_CS as well. + !> A pointer to the update_OBC control structure + type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() + + type(group_pass_type) :: pass_eta !< Structure for group halo pass + type(group_pass_type) :: pass_visc_rem !< Structure for group halo pass + type(group_pass_type) :: pass_uvp !< Structure for group halo pass + type(group_pass_type) :: pass_hp_uv !< Structure for group halo pass + type(group_pass_type) :: pass_uv !< Structure for group halo pass + type(group_pass_type) :: pass_h !< Structure for group halo pass + type(group_pass_type) :: pass_av_uvh !< Structure for group halo pass + +end type MOM_dyn_split_RK2_CS + + +public step_MOM_dyn_split_RK2 +public register_restarts_dyn_split_RK2 +public initialize_dyn_split_RK2 +public remap_dyn_split_RK2_aux_vars +public end_dyn_split_RK2 + +!>@{ CPU time clock IDs +integer :: id_clock_Cor, id_clock_pres, id_clock_vertvisc +integer :: id_clock_horvisc, id_clock_mom_update +integer :: id_clock_continuity, id_clock_thick_diff +integer :: id_clock_btstep, id_clock_btcalc, id_clock_btforce +integer :: id_clock_pass, id_clock_pass_init +!>@} + +contains + +!> RK2 splitting for time stepping MOM adiabatic dynamics +subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & + calc_dtbt, VarMix, MEKE, thickness_diffuse_CSp, pbv, Waves) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + target, intent(inout) :: u_inst !< Instantaneous zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(inout) :: v_inst !< Instantaneous meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type + type(vertvisc_type), intent(inout) :: visc !< Vertical visc, bottom drag, and related + type(time_type), intent(in) :: Time_local !< Model time at end of time step + real, intent(in) :: dt !< Baroclinic dynamics time step [T ~> s] + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(:,:), pointer :: p_surf_begin !< Surface pressure at the start of this dynamic + !! time step [R L2 T-2 ~> Pa] + real, dimension(:,:), pointer :: p_surf_end !< Surface pressure at the end of this dynamic + !! time step [R L2 T-2 ~> Pa] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + target, intent(inout) :: uh !< Zonal volume or mass transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(inout) :: vh !< Meridional volume or mass transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Accumulated zonal volume or mass transport + !! since last tracer advection [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Accumulated meridional volume or mass transport + !! since last tracer advection [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< Free surface height or column mass + !! averaged over time step [H ~> m or kg m-2] + type(MOM_dyn_split_RK2_CS), pointer :: CS !< Module control structure + logical, intent(in) :: calc_dtbt !< If true, recalculate the barotropic time step + type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(thickness_diffuse_CS), intent(inout) :: thickness_diffuse_CSp !< Pointer to a structure containing + !! interface height diffusivities + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(wave_parameters_CS), optional, pointer :: Waves !< A pointer to a structure containing + !! fields related to the surface wave conditions + + ! local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up ! Predicted zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp ! Predicted meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: veffA ! Effective Area of V-Faces [H L ~> m2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_bc_accel ! The summed zonal baroclinic accelerations + ! of each layer calculated by the non-barotropic + ! part of the model [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_bc_accel ! The summed meridional baroclinic accelerations + ! of each layer calculated by the non-barotropic + ! part of the model [L T-2 ~> m s-2] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target :: uh_in ! The zonal mass transports that would be + ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target :: vh_in ! The meridional mass transports that would be + ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1] + + real, dimension(SZI_(G),SZJ_(G)) :: eta_pred ! The predictor value of the free surface height + ! or column mass [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)) :: SpV_avg ! The column averaged specific volume [R-1 ~> m3 kg-1] + real, dimension(SZI_(G),SZJ_(G)) :: deta_dt ! A diagnostic of the time derivative of the free surface + ! height or column mass [H T-1 ~> m s-1 or kg m-2 s-1] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_old_rad_OBC ! The starting zonal velocities, which are + ! saved for use in the radiation open boundary condition code [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_old_rad_OBC ! The starting meridional velocities, which are + ! saved for use in the radiation open boundary condition code [L T-1 ~> m s-1] + + ! GMM, TODO: make these allocatable? + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uold ! u-velocity before vert_visc is applied, for fpmix + ! [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vold ! v-velocity before vert_visc is applied, for fpmix + ! [L T-1 ~> m s-1] + real :: pres_to_eta ! A factor that converts pressures to the units of eta + ! [H T2 R-1 L-2 ~> m Pa-1 or kg m-2 Pa-1] + real, pointer, dimension(:,:) :: & + p_surf => NULL(), & ! A pointer to the surface pressure [R L2 T-2 ~> Pa] + eta_PF_start => NULL(), & ! The value of eta that corresponds to the starting pressure + ! for the barotropic solver [H ~> m or kg m-2] + taux_bot => NULL(), & ! A pointer to the zonal bottom stress in some cases [R L Z T-2 ~> Pa] + tauy_bot => NULL(), & ! A pointer to the meridional bottom stress in some cases [R L Z T-2 ~> Pa] + ! This pointer is just used as shorthand for CS%eta. + eta => NULL() ! A pointer to the instantaneous free surface height (in Boussinesq + ! mode) or column mass anomaly (in non-Boussinesq mode) [H ~> m or kg m-2] + + real, pointer, dimension(:,:,:) :: & + ! These pointers are used to alter which fields are passed to btstep with various options: + u_ptr => NULL(), & ! A pointer to a zonal velocity [L T-1 ~> m s-1] + v_ptr => NULL(), & ! A pointer to a meridional velocity [L T-1 ~> m s-1] + uh_ptr => NULL(), & ! A pointer to a zonal volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + vh_ptr => NULL(), & ! A pointer to a meridional volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + ! These pointers are just used as shorthand for CS%u_av, CS%v_av, and CS%h_av. + u_av, & ! The zonal velocity time-averaged over a time step [L T-1 ~> m s-1]. + v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. + h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. + + real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix [H ~> m or kg m-2] + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. + real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] + logical :: dyn_p_surf + logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the + ! relative weightings of the layers in calculating + ! the barotropic accelerations. + logical :: Use_Stokes_PGF ! If true, add Stokes PGF to hydrostatic PGF + !---For group halo pass + logical :: showCallTree, sym + + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: cont_stencil, obc_stencil + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + u_av => CS%u_av ; v_av => CS%v_av ; h_av => CS%h_av ; eta => CS%eta + + Idt_bc = 1.0 / dt + + sym = G%Domain%symmetric ! switch to include symmetric domain in checksums + + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("step_MOM_dyn_split_RK2(), MOM_dynamics_split_RK2.F90") + + !$OMP parallel do default(shared) + do k=1,nz + do j=G%jsd,G%jed ; do i=G%isdB,G%iedB ; up(i,j,k) = 0.0 ; enddo ; enddo + do j=G%jsdB,G%jedB ; do i=G%isd,G%ied ; vp(i,j,k) = 0.0 ; enddo ; enddo + do j=G%jsd,G%jed ; do i=G%isd,G%ied ; hp(i,j,k) = h(i,j,k) ; enddo ; enddo + enddo + + ! Update CFL truncation value as function of time + call updateCFLtruncationValue(Time_local, CS%vertvisc_CSp, US) + + if (CS%debug) then + call MOM_state_chksum("Start predictor ", u_inst, v_inst, h, uh, vh, G, GV, US, symmetric=sym) + call check_redundant("Start predictor u ", u_inst, v_inst, G, unscale=US%L_T_to_m_s) + call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif + + dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) + if (dyn_p_surf) then + p_surf => p_surf_end + call safe_alloc_ptr(eta_PF_start,G%isd,G%ied,G%jsd,G%jed) + eta_PF_start(:,:) = 0.0 + else + p_surf => forces%p_surf + endif + + if (associated(CS%OBC)) then + if (CS%debug_OBC) call open_boundary_test_extern_h(G, GV, CS%OBC, h) + + ! Update OBC ramp value as function of time + call update_OBC_ramp(Time_local, CS%OBC, US) + + do k=1,nz ; do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + u_old_rad_OBC(I,j,k) = u_av(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + v_old_rad_OBC(i,J,k) = v_av(i,J,k) + enddo ; enddo ; enddo + endif + + BT_cont_BT_thick = .false. + if (associated(CS%BT_cont)) BT_cont_BT_thick = & + (allocated(CS%BT_cont%h_u) .and. allocated(CS%BT_cont%h_v)) + + if (CS%split_bottom_stress) then + taux_bot => CS%taux_bot ; tauy_bot => CS%tauy_bot + endif + + !--- begin set up for group halo pass + + cont_stencil = continuity_stencil(CS%continuity_CSp) + obc_stencil = 2 + if (associated(CS%OBC)) then + if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3 + endif + call cpu_clock_begin(id_clock_pass) + call create_group_pass(CS%pass_eta, eta, G%Domain, halo=1) + call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, & + To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil)) + call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) + call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2) + call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + + call create_group_pass(CS%pass_uv, u_inst, v_inst, G%Domain, halo=max(2,cont_stencil)) + call create_group_pass(CS%pass_h, h, G%Domain, halo=max(2,cont_stencil)) + call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + call cpu_clock_end(id_clock_pass) + !--- end set up for group halo pass + + +! PFu = d/dx M(h,T,S) +! pbce = dM/deta + if (CS%begw == 0.0) call enable_averages(dt, Time_local, CS%diag) + call cpu_clock_begin(id_clock_pres) + call PressureForce(h, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & + CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) + if (dyn_p_surf) then + pres_to_eta = 1.0 / (GV%g_Earth * GV%H_to_RZ) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_PF_start(i,j) = CS%eta_PF(i,j) - pres_to_eta * (p_surf_begin(i,j) - p_surf_end(i,j)) + enddo ; enddo + endif + ! Stokes shear force contribution to pressure gradient + Use_Stokes_PGF = present(Waves) + if (Use_Stokes_PGF) then + Use_Stokes_PGF = associated(Waves) + if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF + if (Use_Stokes_PGF) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u_inst, v_inst, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + + ! We are adding Stokes_PGF to hydrostatic PGF here. The diag PFu/PFv + ! will therefore report the sum total PGF and we avoid other + ! modifications in the code. The PFu_Stokes is output within the waves routines. + if (.not.Waves%Passive_Stokes_PGF) then + do k=1,nz + do j=js,je ; do I=Isq,Ieq + CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) + enddo ; enddo + enddo + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie + CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) + enddo ; enddo + enddo + endif + endif + endif + call cpu_clock_end(id_clock_pres) + call disable_averaging(CS%diag) + if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2)") + + if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) + endif ; endif + if (associated(CS%OBC) .and. CS%debug_OBC) & + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) + + if (G%nonblocking_updates) & + call start_group_pass(CS%pass_eta, G%Domain, clock=id_clock_pass) + +! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av + if (.not.CS%CAu_pred_stored) then + ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms, + ! if it was not already stored from the end of the previous time step. + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%AD_pred, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2)") + endif + +! u_bc_accel = CAu + PFu + diffu(u[n-1]) + call cpu_clock_begin(id_clock_btforce) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + u_bc_accel(I,j,k) = (CS%CAu_pred(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v_bc_accel(i,J,k) = (CS%CAv_pred(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k) + enddo ; enddo + enddo + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, u_bc_accel, v_bc_accel) + endif + call cpu_clock_end(id_clock_btforce) + + if (CS%debug) then + call MOM_accel_chksum("pre-btstep accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & + symmetric=sym) + call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif + + call cpu_clock_begin(id_clock_vertvisc) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * u_bc_accel(I,j,k)) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * v_bc_accel(i,J,k)) + enddo ; enddo + enddo + + call enable_averages(dt, Time_local, CS%diag) + call set_viscous_ML(u_inst, v_inst, h, tv, forces, visc, dt, G, GV, US, CS%set_visc_CSp) + call disable_averaging(CS%diag) + + if (CS%debug) then + call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + endif + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + call cpu_clock_end(id_clock_vertvisc) + if (showCallTree) call callTree_wayPoint("done with vertvisc_coef (step_MOM_dyn_split_RK2)") + + + call cpu_clock_begin(id_clock_pass) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_eta, G%Domain) + call start_group_pass(CS%pass_visc_rem, G%Domain) + else + call do_group_pass(CS%pass_eta, G%Domain) + call do_group_pass(CS%pass_visc_rem, G%Domain) + endif + call cpu_clock_end(id_clock_pass) + + call cpu_clock_begin(id_clock_btcalc) + ! Calculate the relative layer weights for determining barotropic quantities. + if (.not.BT_cont_BT_thick) & + call btcalc(h, G, GV, CS%barotropic_CSp, OBC=CS%OBC) + call bt_mass_source(h, eta, .true., G, GV, CS%barotropic_CSp) + + SpV_avg(:,:) = 0.0 + if ((.not.GV%Boussinesq) .and. associated(CS%OBC)) then + ! Determine the column average specific volume if it is needed due to the + ! use of Flather open boundary conditions in non-Boussinesq mode. + if (open_boundary_query(CS%OBC, apply_Flather_OBC=.true.)) & + call find_col_avg_SpV(h, SpV_avg, tv, G, GV, US) + endif + call cpu_clock_end(id_clock_btcalc) + + if (G%nonblocking_updates) & + call complete_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + +! u_accel_bt = layer accelerations due to barotropic solver + if (associated(CS%BT_cont) .or. CS%BT_use_layer_fluxes) then + call cpu_clock_begin(id_clock_continuity) + call continuity(u_inst, v_inst, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, BT_cont=CS%BT_cont) + call cpu_clock_end(id_clock_continuity) + if (BT_cont_BT_thick) then + call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, & + OBC=CS%OBC) + endif + if (showCallTree) call callTree_wayPoint("done with continuity[BT_cont] (step_MOM_dyn_split_RK2)") + endif + + if (CS%BT_use_layer_fluxes) then + uh_ptr => uh_in ; vh_ptr => vh_in; u_ptr => u_inst ; v_ptr => v_inst + endif + + call cpu_clock_begin(id_clock_btstep) + if (calc_dtbt) call set_dtbt(G, GV, US, CS%barotropic_CSp, eta, CS%pbce) + if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") + ! This is the predictor step call to btstep. + ! The CS%ADp argument here stores the weights for certain integrated diagnostics. + call btstep(u_inst, v_inst, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & + CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & + eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr) + if (showCallTree) call callTree_leave("btstep()") + call cpu_clock_end(id_clock_btstep) + +! up = u + dt_pred*( u_bc_accel + u_accel_bt ) + dt_pred = dt * CS%be + call cpu_clock_begin(id_clock_mom_update) + + !$OMP parallel do default(shared) + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie + vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt_pred * & + (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) + enddo ; enddo + do j=js,je ; do I=Isq,Ieq + up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt_pred * & + (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) + enddo ; enddo + enddo + call cpu_clock_end(id_clock_mom_update) + + if (CS%debug) then + call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, & + symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) +! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1) + call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) + call MOM_state_chksum("Predictor 1 init", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1, & + symmetric=sym) + call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif + +! up <- up + dt_pred d/dz visc d/dz up +! u_av <- u_av + dt_pred d/dz visc d/dz u_av + call cpu_clock_begin(id_clock_vertvisc) + if (CS%debug) then + call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + endif + + if (CS%fpmix) then + uold(:,:,:) = 0.0 + vold(:,:,:) = 0.0 + do k = 1, nz + do j = js , je + do I = Isq, Ieq + uold(I,j,k) = up(I,j,k) + enddo + enddo + do J = Jsq, Jeq + do i = is, ie + vold(i,J,k) = vp(i,J,k) + enddo + enddo + enddo + endif + + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, & + CS%OBC, VarMix) + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + + if (CS%fpmix) then + hbl(:,:) = 0.0 + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) & + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) + call vertFPmix(up, vp, uold, vold, hbl, h, forces, & + dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + endif + + if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)") + if (G%nonblocking_updates) then + call cpu_clock_end(id_clock_vertvisc) + call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) + call cpu_clock_begin(id_clock_vertvisc) + endif + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + call cpu_clock_end(id_clock_vertvisc) + + call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) + endif + + ! uh = u_av * h + ! hp = h + dt * div . uh + call cpu_clock_begin(id_clock_continuity) + call continuity(up, vp, h, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, & + u_av, v_av, BT_cont=CS%BT_cont) + call cpu_clock_end(id_clock_continuity) + if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2)") + + call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) + + if (associated(CS%OBC)) then + + if (CS%debug) & + call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + + call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt_pred) + + if (CS%debug) & + call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + + ! These should be done with a pass that excludes uh & vh. +! call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) + endif + + if (G%nonblocking_updates) then + call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) + endif + + ! h_av = (h + hp)/2 + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) + enddo ; enddo ; enddo + + ! The correction phase of the time step starts here. + call enable_averages(dt, Time_local, CS%diag) + + ! Calculate a revised estimate of the free-surface height correction to be + ! used in the next call to btstep. This call is at this point so that + ! hp can be changed if CS%begw /= 0. + ! eta_cor = ... (hidden inside CS%barotropic_CSp) + call cpu_clock_begin(id_clock_btcalc) + call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp) + call cpu_clock_end(id_clock_btcalc) + + if (CS%begw /= 0.0) then + ! hp <- (1-begw)*h_in + begw*hp + ! Back up hp to the value it would have had after a time-step of + ! begw*dt. hp is not used again until recalculated by continuity. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + hp(i,j,k) = (1.0-CS%begw)*h(i,j,k) + CS%begw*hp(i,j,k) + enddo ; enddo ; enddo + + ! PFu = d/dx M(hp,T,S) + ! pbce = dM/deta + call cpu_clock_begin(id_clock_pres) + call PressureForce(hp, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & + CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) + ! Stokes shear force contribution to pressure gradient + Use_Stokes_PGF = present(Waves) + if (Use_Stokes_PGF) then + Use_Stokes_PGF = associated(Waves) + if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF + if (Use_Stokes_PGF) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u_inst, v_inst, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + if (.not.Waves%Passive_Stokes_PGF) then + do k=1,nz + do j=js,je ; do I=Isq,Ieq + CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) + enddo ; enddo + enddo + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie + CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) + enddo ; enddo + enddo + endif + endif + endif + call cpu_clock_end(id_clock_pres) + if (showCallTree) call callTree_wayPoint("done with PressureForce[hp=(1-b).h+b.h] (step_MOM_dyn_split_RK2)") + endif + + if (G%nonblocking_updates) & + call complete_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) + + if (BT_cont_BT_thick) then + call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, & + OBC=CS%OBC) + if (showCallTree) call callTree_wayPoint("done with btcalc[BT_cont_BT_thick] (step_MOM_dyn_split_RK2)") + endif + + if (CS%debug) then + call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym) + call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call hchksum(h_av, "Predictor avg h", G%HI, haloshift=0, scale=GV%H_to_MKS) + ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) + call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif + +! diffu = horizontal viscosity terms (u_av) + call cpu_clock_begin(id_clock_horvisc) + call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & + MEKE, Varmix, G, GV, US, CS%hor_visc, & + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & + ADp=CS%ADp, hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) + call cpu_clock_end(id_clock_horvisc) + if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2)") + +! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2)") + +! Calculate the momentum forcing terms for the barotropic equations. + +! u_bc_accel = CAu + PFu + diffu(u[n-1]) + call cpu_clock_begin(id_clock_btforce) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + u_bc_accel(I,j,k) = (CS%Cau(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v_bc_accel(i,J,k) = (CS%Cav(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k) + enddo ; enddo + enddo + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, u_bc_accel, v_bc_accel) + endif + call cpu_clock_end(id_clock_btforce) + + if (CS%debug) then + call MOM_accel_chksum("corr pre-btstep accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & + symmetric=sym) + call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif + + ! u_accel_bt = layer accelerations due to barotropic solver + ! pbce = dM/deta + call cpu_clock_begin(id_clock_btstep) + if (CS%BT_use_layer_fluxes) then + uh_ptr => uh ; vh_ptr => vh ; u_ptr => u_av ; v_ptr => v_av + endif + + if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") + ! This is the corrector step call to btstep. + call btstep(u_inst, v_inst, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & + CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & + eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr, etaav=eta_av) + if (CS%id_deta_dt>0) then + do j=js,je ; do i=is,ie ; deta_dt(i,j) = (eta_pred(i,j) - eta(i,j))*Idt_bc ; enddo ; enddo + 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) + if (showCallTree) call callTree_leave("btstep()") + + if (CS%debug) then + call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G, unscale=US%L_T2_to_m_s2) + endif + + ! u = u + dt*( u_bc_accel + u_accel_bt ) + call cpu_clock_begin(id_clock_mom_update) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + u_inst(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * & + (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v_inst(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * & + (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) + enddo ; enddo + enddo + call cpu_clock_end(id_clock_mom_update) + + if (CS%debug) then + call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & + symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1) + call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, & + symmetric=sym) + endif + + ! u <- u + dt d/dz visc d/dz u + ! u_av <- u_av + dt d/dz visc d/dz u_av + call cpu_clock_begin(id_clock_vertvisc) + + if (CS%fpmix) then + uold(:,:,:) = 0.0 + vold(:,:,:) = 0.0 + do k = 1, nz + do j = js , je + do I = Isq, Ieq + uold(I,j,k) = u_inst(I,j,k) + enddo + enddo + do J = Jsq, Jeq + do i = is, ie + vold(i,J,k) = v_inst(i,J,k) + enddo + enddo + enddo + endif + + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(u_inst, v_inst, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) + + if (CS%fpmix) then + call vertFPmix(u_inst, v_inst, uold, vold, hbl, h, forces, dt, & + G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + endif + + if (G%nonblocking_updates) then + call cpu_clock_end(id_clock_vertvisc) + call start_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) + call cpu_clock_begin(id_clock_vertvisc) + endif + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + call cpu_clock_end(id_clock_vertvisc) + if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)") + +! Later, h_av = (h_in + h_out)/2, but for now use h_av to store h_in. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = h(i,j,k) + enddo ; enddo ; enddo + + call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) + endif + + ! uh = u_av * h + ! h = h + dt * div . uh + ! u_av and v_av adjusted so their mass transports match uhbt and vhbt. + call cpu_clock_begin(id_clock_continuity) + call continuity(u_inst, v_inst, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, u_av, v_av) + call cpu_clock_end(id_clock_continuity) + call do_group_pass(CS%pass_h, G%Domain, clock=id_clock_pass) + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2)") + + if (G%nonblocking_updates) then + call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_av_uvh, G%domain, clock=id_clock_pass) + endif + + if (associated(CS%OBC)) then + !### I suspect that there is a bug here when u_inst is compared with a previous value of u_av + ! to estimate the dominant outward group velocity, but a fix is not available yet. + call radiation_open_bdry_conds(CS%OBC, u_inst, u_old_rad_OBC, v_inst, v_old_rad_OBC, G, GV, US, dt) + endif + +! h_av = (h_in + h_out)/2 . Going in to this line, h_av = h_in. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = 0.5*(h_av(i,j,k) + h(i,j,k)) + enddo ; enddo ; enddo + + if (G%nonblocking_updates) & + call complete_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) + + !$OMP parallel do default(shared) + do k=1,nz + do j=js-2,je+2 ; do I=Isq-2,Ieq+2 + uhtr(I,j,k) = uhtr(I,j,k) + uh(I,j,k)*dt + enddo ; enddo + do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 + vhtr(i,J,k) = vhtr(i,J,k) + vh(i,J,k)*dt + enddo ; enddo + enddo + + if (CS%store_CAu) then + ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms + ! for use in the next time step, possibly after it has been vertically remapped. + call cpu_clock_begin(id_clock_Cor) + call disable_averaging(CS%diag) ! These calculations should not be used for diagnostics. + ! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%AD_pred, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + CS%CAu_pred_stored = .true. + call enable_averages(dt, Time_local, CS%diag) ! Reenable the averaging + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2)") + else + CS%CAu_pred_stored = .false. + endif + + if (CS%fpmix) then + if (CS%id_uold > 0) call post_data(CS%id_uold, uold, CS%diag) + if (CS%id_vold > 0) call post_data(CS%id_vold, vold, CS%diag) + endif + + ! The time-averaged free surface height has already been set by the last call to btstep. + + ! Deallocate this memory to avoid a memory leak. ### We should revisit how this array is declared. -RWH + if (dyn_p_surf .and. associated(eta_PF_start)) deallocate(eta_PF_start) + + ! Here various terms used in to update the momentum equations are + ! offered for time averaging. + if (CS%id_PFu > 0) call post_data(CS%id_PFu, CS%PFu, CS%diag) + if (CS%id_PFv > 0) call post_data(CS%id_PFv, CS%PFv, CS%diag) + if (CS%id_CAu > 0) call post_data(CS%id_CAu, CS%CAu, CS%diag) + if (CS%id_CAv > 0) call post_data(CS%id_CAv, CS%CAv, CS%diag) + + ! Here the thickness fluxes are offered for time averaging. + if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) + if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) + if (CS%id_uav > 0) call post_data(CS%id_uav, u_av, CS%diag) + if (CS%id_vav > 0) call post_data(CS%id_vav, v_av, CS%diag) + if (CS%id_u_BT_accel > 0) call post_data(CS%id_u_BT_accel, CS%u_accel_bt, CS%diag) + if (CS%id_v_BT_accel > 0) call post_data(CS%id_v_BT_accel, CS%v_accel_bt, CS%diag) + + ! Calculate effective areas and post data + if (CS%id_ueffA > 0) then + ueffA(:,:,:) = 0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(up(I,j,k)) > 0.) ueffA(I,j,k) = uh(I,j,k) / up(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_ueffA, ueffA, CS%diag) + endif + + if (CS%id_veffA > 0) then + veffA(:,:,:) = 0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(vp(i,J,k)) > 0.) veffA(i,J,k) = vh(i,J,k) / vp(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_veffA, veffA, CS%diag) + endif + + ! Diagnostics of the fractional thicknesses times momentum budget terms + ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for debugging purposes in the future. + !if (CS%id_hf_PFu > 0) call post_product_u(CS%id_hf_PFu, CS%PFu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_PFv > 0) call post_product_v(CS%id_hf_PFv, CS%PFv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + !if (CS%id_hf_CAu > 0) call post_product_u(CS%id_hf_CAu, CS%CAu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_CAv > 0) call post_product_v(CS%id_hf_CAv, CS%CAv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + !if (CS%id_hf_u_BT_accel > 0) & + ! call post_product_u(CS%id_hf_u_BT_accel, CS%u_accel_bt, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_v_BT_accel > 0) & + ! call post_product_v(CS%id_hf_v_BT_accel, CS%v_accel_bt, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for the vertical sum of layer thickness x prssure force accelerations + if (CS%id_intz_PFu_2d > 0) call post_product_sum_u(CS%id_intz_PFu_2d, CS%PFu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_PFv_2d > 0) call post_product_sum_v(CS%id_intz_PFv_2d, CS%PFv, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics for thickness-weighted vertically averaged prssure force accelerations + if (CS%id_hf_PFu_2d > 0) call post_product_sum_u(CS%id_hf_PFu_2d, CS%PFu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_PFv_2d > 0) call post_product_sum_v(CS%id_hf_PFv_2d, CS%PFv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for thickness x prssure force accelerations + if (CS%id_h_PFu > 0) call post_product_u(CS%id_h_PFu, CS%PFu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_PFv > 0) call post_product_v(CS%id_h_PFv, CS%PFv, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics of Coriolis acceleratations + if (CS%id_intz_CAu_2d > 0) call post_product_sum_u(CS%id_intz_CAu_2d, CS%CAu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_CAv_2d > 0) call post_product_sum_v(CS%id_intz_CAv_2d, CS%CAv, CS%ADp%diag_hv, G, nz, CS%diag) + if (CS%id_hf_CAu_2d > 0) call post_product_sum_u(CS%id_hf_CAu_2d, CS%CAu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_CAv_2d > 0) call post_product_sum_v(CS%id_hf_CAv_2d, CS%CAv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + if (CS%id_h_CAu > 0) call post_product_u(CS%id_h_CAu, CS%CAu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_CAv > 0) call post_product_v(CS%id_h_CAv, CS%CAv, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics of barotropic solver acceleratations + if (CS%id_intz_u_BT_accel_2d > 0) & + call post_product_sum_u(CS%id_intz_u_BT_accel_2d, CS%u_accel_bt, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_v_BT_accel_2d > 0) & + call post_product_sum_v(CS%id_intz_v_BT_accel_2d, CS%v_accel_bt, CS%ADp%diag_hv, G, nz, CS%diag) + if (CS%id_hf_u_BT_accel_2d > 0) & + call post_product_sum_u(CS%id_hf_u_BT_accel_2d, CS%u_accel_bt, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_v_BT_accel_2d > 0) & + call post_product_sum_v(CS%id_hf_v_BT_accel_2d, CS%v_accel_bt, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + if (CS%id_h_u_BT_accel > 0) & + call post_product_u(CS%id_h_u_BT_accel, CS%u_accel_bt, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_v_BT_accel > 0) & + call post_product_v(CS%id_h_v_BT_accel, CS%v_accel_bt, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics for momentum budget terms multiplied by visc_rem_[uv], + if (CS%id_PFu_visc_rem > 0) call post_product_u(CS%id_PFu_visc_rem, CS%PFu, CS%ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_PFv_visc_rem > 0) call post_product_v(CS%id_PFv_visc_rem, CS%PFv, CS%ADp%visc_rem_v, G, nz, CS%diag) + if (CS%id_CAu_visc_rem > 0) call post_product_u(CS%id_CAu_visc_rem, CS%CAu, CS%ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_CAv_visc_rem > 0) call post_product_v(CS%id_CAv_visc_rem, CS%CAv, CS%ADp%visc_rem_v, G, nz, CS%diag) + if (CS%id_u_BT_accel_visc_rem > 0) & + call post_product_u(CS%id_u_BT_accel_visc_rem, CS%u_accel_bt, CS%ADp%visc_rem_u, G, nz, CS%diag) + 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_inst, v_inst, 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) + call hchksum(h_av, "Corrector avg h", G%HI, haloshift=1, scale=GV%H_to_MKS) + ! call MOM_state_chksum("Corrector avg ", u_av, v_av, h_av, uh, vh, G, GV, US) + endif + + if (showCallTree) call callTree_leave("step_MOM_dyn_split_RK2()") + +end subroutine step_MOM_dyn_split_RK2 + +!> This subroutine sets up any auxiliary restart variables that are specific +!! to the split-explicit time stepping scheme. All variables registered here should +!! have the ability to be recreated if they are not present in a restart file. +subroutine register_restarts_dyn_split_RK2(HI, GV, US, param_file, CS, restart_CS, uh, vh) + type(hor_index_type), intent(in) :: HI !< Horizontal index 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(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + real, dimension(SZIB_(HI),SZJ_(HI),SZK_(GV)), & + target, intent(inout) :: uh !< zonal volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(HI),SZJB_(HI),SZK_(GV)), & + target, intent(inout) :: vh !< merid volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + + character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. + type(vardesc) :: vd(2) + character(len=48) :: thickness_units, flux_units + + integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB + + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB + + ! This is where a control structure specific to this module would be allocated. + if (associated(CS)) then + call MOM_error(WARNING, "register_restarts_dyn_split_RK2 called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ALLOC_(CS%diffu(IsdB:IedB,jsd:jed,nz)) ; CS%diffu(:,:,:) = 0.0 + ALLOC_(CS%diffv(isd:ied,JsdB:JedB,nz)) ; CS%diffv(:,:,:) = 0.0 + ALLOC_(CS%CAu(IsdB:IedB,jsd:jed,nz)) ; CS%CAu(:,:,:) = 0.0 + ALLOC_(CS%CAv(isd:ied,JsdB:JedB,nz)) ; CS%CAv(:,:,:) = 0.0 + ALLOC_(CS%CAu_pred(IsdB:IedB,jsd:jed,nz)) ; CS%CAu_pred(:,:,:) = 0.0 + ALLOC_(CS%CAv_pred(isd:ied,JsdB:JedB,nz)) ; CS%CAv_pred(:,:,:) = 0.0 + ALLOC_(CS%PFu(IsdB:IedB,jsd:jed,nz)) ; CS%PFu(:,:,:) = 0.0 + ALLOC_(CS%PFv(isd:ied,JsdB:JedB,nz)) ; CS%PFv(:,:,:) = 0.0 + + ALLOC_(CS%eta(isd:ied,jsd:jed)) ; CS%eta(:,:) = 0.0 + ALLOC_(CS%u_av(IsdB:IedB,jsd:jed,nz)) ; CS%u_av(:,:,:) = 0.0 + ALLOC_(CS%v_av(isd:ied,JsdB:JedB,nz)) ; CS%v_av(:,:,:) = 0.0 + ALLOC_(CS%h_av(isd:ied,jsd:jed,nz)) ; CS%h_av(:,:,:) = GV%Angstrom_H + + thickness_units = get_thickness_units(GV) + flux_units = get_flux_units(GV) + + call get_param(param_file, mdl, "STORE_CORIOLIS_ACCEL", CS%store_CAu, & + "If true, calculate the Coriolis accelerations at the end of each "//& + "timestep for use in the predictor step of the next split RK2 timestep.", & + default=.true., do_not_log=.true.) + + if (GV%Boussinesq) then + call register_restart_field(CS%eta, "sfc", .false., restart_CS, & + longname="Free surface Height", units=thickness_units, conversion=GV%H_to_mks) + else + call register_restart_field(CS%eta, "p_bot", .false., restart_CS, & + longname="Bottom Pressure", units=thickness_units, conversion=GV%H_to_mks) + endif + + ! These are needed, either to calculate CAu and CAv or to calculate the velocity anomalies in + ! the barotropic solver's Coriolis terms. + vd(1) = var_desc("u2", "m s-1", "Auxiliary Zonal velocity", 'u', 'L') + vd(2) = var_desc("v2", "m s-1", "Auxiliary Meridional velocity", 'v', 'L') + call register_restart_pair(CS%u_av, CS%v_av, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T_to_m_s) + + if (CS%store_CAu) then + vd(1) = var_desc("CAu", "m s-2", "Zonal Coriolis and advactive acceleration", 'u', 'L') + vd(2) = var_desc("CAv", "m s-2", "Meridional Coriolis and advactive acceleration", 'v', 'L') + call register_restart_pair(CS%CAu_pred, CS%CAv_pred, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T2_to_m_s2) + else + call register_restart_field(CS%h_av, "h2", .false., restart_CS, & + longname="Auxiliary Layer Thickness", units=thickness_units, conversion=GV%H_to_mks) + + vd(1) = var_desc("uh", flux_units, "Zonal thickness flux", 'u', 'L') + vd(2) = var_desc("vh", flux_units, "Meridional thickness flux", 'v', 'L') + call register_restart_pair(uh, vh, vd(1), vd(2), .false., restart_CS, & + conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif + + vd(1) = var_desc("diffu", "m s-2", "Zonal horizontal viscous acceleration", 'u', 'L') + vd(2) = var_desc("diffv", "m s-2", "Meridional horizontal viscous acceleration", 'v', 'L') + call register_restart_pair(CS%diffu, CS%diffv, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T2_to_m_s2) + + call register_barotropic_restarts(HI, GV, US, param_file, CS%barotropic_CSp, restart_CS) + +end subroutine register_restarts_dyn_split_RK2 + +!> This subroutine does remapping for the auxiliary restart variables that are used +!! with the split RK2 time stepping scheme. +subroutine remap_dyn_split_RK2_aux_vars(G, GV, CS, h_old_u, h_old_v, h_new_u, h_new_v, ALE_CSp) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old_u !< Source grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_old_v !< Source grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new_u !< Destination grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_new_v !< Destination grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure to use when remapping + + if (.not.CS%remap_aux) return + + if (CS%store_CAu) then + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%u_av, CS%v_av) + call pass_vector(CS%u_av, CS%v_av, G%Domain, complete=.false.) + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%CAu_pred, CS%CAv_pred) + call pass_vector(CS%CAu_pred, CS%CAv_pred, G%Domain, complete=.true.) + endif + + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%diffu, CS%diffv) + +end subroutine remap_dyn_split_RK2_aux_vars + +!> This subroutine initializes all of the variables that are used by this +!! dynamic core, including diagnostics and the cpu clocks. +subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param_file, & + diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & + VarMix, MEKE, thickness_diffuse_CSp, & + OBC, update_OBC_CSp, ALE_CSp, set_visc, & + visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< merid velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + target, intent(inout) :: uh !< zonal volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(inout) :: vh !< merid volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: eta !< free surface height or column mass [H ~> m or kg m-2] + type(time_type), target, intent(in) :: Time !< current model time + type(param_file_type), intent(in) :: param_file !< parameter file for parsing + type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics + type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + real, intent(in) :: dt !< time step [T ~> s] + type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for + !! budget analysis + type(cont_diag_ptrs), target, intent(inout) :: Cont_diag !< points to terms in continuity equation + type(ocean_internal_state), intent(inout) :: MIS !< "MOM6 internal state" used to pass + !! diagnostic pointers + type(VarMix_CS), intent(inout) :: VarMix !< points to spatially variable viscosities + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(thickness_diffuse_CS), intent(inout) :: thickness_diffuse_CSp !< Pointer to the control structure + !! used for the isopycnal height diffusive transport. + type(ocean_OBC_type), pointer :: OBC !< points to OBC related fields + type(update_OBC_CS), pointer :: update_OBC_CSp !< points to OBC update related fields + type(ALE_CS), pointer :: ALE_CSp !< points to ALE control structure + type(set_visc_CS), target, intent(in) :: set_visc !< set_visc control structure + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, bottom drag, and related + type(directories), intent(in) :: dirs !< contains directory paths + integer, target, intent(inout) :: ntrunc !< A target for the variable that records + !! the number of times the velocity is + !! truncated (this should be 0). + logical, intent(out) :: calc_dtbt !< If true, recalculate the barotropic time step + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + integer, intent(out) :: cont_stencil !< The stencil for thickness + !! from the continuity solver. + + ! local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tmp ! A temporary copy of the layer thicknesses [H ~> m or kg m-2] + character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=48) :: thickness_units, flux_units, eta_rest_name + type(group_pass_type) :: pass_av_h_uvh + logical :: debug_truncations + logical :: read_uv, read_h2 + + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(CS)) call MOM_error(FATAL, & + "initialize_dyn_split_RK2 called with an unassociated control structure.") + if (CS%module_is_initialized) then + call MOM_error(WARNING, "initialize_dyn_split_RK2 called with a control "// & + "structure that has already been initialized.") + return + endif + CS%module_is_initialized = .true. + + CS%diag => diag + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "TIDES", CS%use_tides, & + "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) + call get_param(param_file, mdl, "BE", CS%be, & + "If SPLIT is true, BE determines the relative weighting "//& + "of a 2nd-order Runga-Kutta baroclinic time stepping "//& + "scheme (0.5) and a backward Euler scheme (1) that is "//& + "used for the Coriolis and inertial terms. BE may be "//& + "from 0.5 to 1, but instability may occur near 0.5. "//& + "BE is also applicable if SPLIT is false and USE_RK2 "//& + "is true.", units="nondim", default=0.6) + call get_param(param_file, mdl, "BEGW", CS%begw, & + "If SPLIT is true, BEGW is a number from 0 to 1 that "//& + "controls the extent to which the treatment of gravity "//& + "waves is forward-backward (0) or simulated backward "//& + "Euler (1). 0 is almost always used. "//& + "If SPLIT is false and USE_RK2 is true, BEGW can be "//& + "between 0 and 0.5 to damp gravity waves.", & + units="nondim", default=0.0) + + call get_param(param_file, mdl, "SPLIT_BOTTOM_STRESS", CS%split_bottom_stress, & + "If true, provide the bottom stress calculated by the "//& + "vertical viscosity to the barotropic solver.", default=.false.) + call get_param(param_file, mdl, "BT_USE_LAYER_FLUXES", CS%BT_use_layer_fluxes, & + "If true, use the summed layered fluxes plus an "//& + "adjustment due to the change in the barotropic velocity "//& + "in the barotropic continuity equation.", default=.true.) + call get_param(param_file, mdl, "STORE_CORIOLIS_ACCEL", CS%store_CAu, & + "If true, calculate the Coriolis accelerations at the end of each "//& + "timestep for use in the predictor step of the next split RK2 timestep.", & + default=.true.) + call get_param(param_file, mdl, "FPMIX", CS%fpmix, & + "If true, apply profiles of momentum flux magnitude and "//& + " direction", default=.false.) + call get_param(param_file, mdl, "REMAP_AUXILIARY_VARS", CS%remap_aux, & + "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& + "variables that are needed to reproduce across restarts, similarly to "//& + "what is already being done with the primary state variables. "//& + "The default should be changed to true.", default=.false., do_not_log=.true.) + if (CS%remap_aux .and. .not.CS%store_CAu) call MOM_error(FATAL, & + "REMAP_AUXILIARY_VARS requires that STORE_CORIOLIS_ACCEL = True.") + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) + call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & + default=.false.) + + allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) + + ALLOC_(CS%uhbt(IsdB:IedB,jsd:jed)) ; CS%uhbt(:,:) = 0.0 + ALLOC_(CS%vhbt(isd:ied,JsdB:JedB)) ; CS%vhbt(:,:) = 0.0 + ALLOC_(CS%visc_rem_u(IsdB:IedB,jsd:jed,nz)) ; CS%visc_rem_u(:,:,:) = 0.0 + ALLOC_(CS%visc_rem_v(isd:ied,JsdB:JedB,nz)) ; CS%visc_rem_v(:,:,:) = 0.0 + ALLOC_(CS%eta_PF(isd:ied,jsd:jed)) ; CS%eta_PF(:,:) = 0.0 + ALLOC_(CS%pbce(isd:ied,jsd:jed,nz)) ; CS%pbce(:,:,:) = 0.0 + + ALLOC_(CS%u_accel_bt(IsdB:IedB,jsd:jed,nz)) ; CS%u_accel_bt(:,:,:) = 0.0 + ALLOC_(CS%v_accel_bt(isd:ied,JsdB:JedB,nz)) ; CS%v_accel_bt(:,:,:) = 0.0 + ALLOC_(CS%PFu_Stokes(IsdB:IedB,jsd:jed,nz)) ; CS%PFu_Stokes(:,:,:) = 0.0 + ALLOC_(CS%PFv_Stokes(isd:ied,JsdB:JedB,nz)) ; CS%PFv_Stokes(:,:,:) = 0.0 + + MIS%diffu => CS%diffu + MIS%diffv => CS%diffv + MIS%PFu => CS%PFu + MIS%PFv => CS%PFv + MIS%CAu => CS%CAu + MIS%CAv => CS%CAv + MIS%pbce => CS%pbce + MIS%u_accel_bt => CS%u_accel_bt + MIS%v_accel_bt => CS%v_accel_bt + MIS%u_av => CS%u_av + MIS%v_av => CS%v_av + + CS%ADp => Accel_diag + CS%CDp => Cont_diag + Accel_diag%diffu => CS%diffu + Accel_diag%diffv => CS%diffv + Accel_diag%PFu => CS%PFu + Accel_diag%PFv => CS%PFv + Accel_diag%CAu => CS%CAu + Accel_diag%CAv => CS%CAv + Accel_diag%u_accel_bt => CS%u_accel_bt + Accel_diag%v_accel_bt => CS%v_accel_bt + + allocate(CS%AD_pred) + CS%AD_pred%diffu => CS%diffu + CS%AD_pred%diffv => CS%diffv + CS%AD_pred%PFu => CS%PFu + CS%AD_pred%PFv => CS%PFv + CS%AD_pred%CAu => CS%CAu_pred + CS%AD_pred%CAv => CS%CAv_pred + CS%AD_pred%u_accel_bt => CS%u_accel_bt + CS%AD_pred%v_accel_bt => CS%v_accel_bt + +! Accel_diag%pbce => CS%pbce +! Accel_diag%u_accel_bt => CS%u_accel_bt ; Accel_diag%v_accel_bt => CS%v_accel_bt +! Accel_diag%u_av => CS%u_av ; Accel_diag%v_av => CS%v_av + + id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', grain=CLOCK_ROUTINE) + + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + cont_stencil = continuity_stencil(CS%continuity_CSp) + call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) + if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & + CS%SAL_CSp, CS%tides_CSp) + call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) + call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, ntrunc, CS%vertvisc_CSp) + CS%set_visc_CSp => set_visc + call updateCFLtruncationValue(Time, CS%vertvisc_CSp, US, activate=is_new_run(restart_CS) ) + + if (associated(ALE_CSp)) CS%ALE_CSp => ALE_CSp + if (associated(OBC)) then + CS%OBC => OBC + if (OBC%ramp) call update_OBC_ramp(Time, CS%OBC, US, activate=is_new_run(restart_CS) ) + endif + if (associated(update_OBC_CSp)) CS%update_OBC_CSp => update_OBC_CSp + + eta_rest_name = "sfc" ; if (.not.GV%Boussinesq) eta_rest_name = "p_bot" + if (.not. query_initialized(CS%eta, trim(eta_rest_name), restart_CS)) then + ! Estimate eta based on the layer thicknesses - h. With the Boussinesq + ! approximation, eta is the free surface height anomaly, while without it + ! eta is the mass of ocean per unit area. eta always has the same + ! dimensions as h, either m or kg m-3. + ! CS%eta(:,:) = 0.0 already from initialization. + if (GV%Boussinesq) then + do j=js,je ; do i=is,ie ; CS%eta(i,j) = -GV%Z_to_H * G%bathyT(i,j) ; enddo ; enddo + endif + do k=1,nz ; do j=js,je ; do i=is,ie + CS%eta(i,j) = CS%eta(i,j) + h(i,j,k) + enddo ; enddo ; enddo + call set_initialized(CS%eta, trim(eta_rest_name), restart_CS) + endif + ! Copy eta into an output array. + do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo + + call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & + CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, CS%SAL_CSp) + + if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & + .not. query_initialized(CS%diffv, "diffv", restart_CS)) then + call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & + hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) + call set_initialized(CS%diffu, "diffu", restart_CS) + call set_initialized(CS%diffv, "diffv", restart_CS) + endif + + if (.not. query_initialized(CS%u_av, "u2", restart_CS) .or. & + .not. query_initialized(CS%v_av, "v2", restart_CS)) then + do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ; CS%u_av(I,j,k) = u(I,j,k) ; enddo ; enddo ; enddo + do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; CS%v_av(i,J,k) = v(i,J,k) ; enddo ; enddo ; enddo + call set_initialized(CS%u_av, "u2", restart_CS) + call set_initialized(CS%v_av, "v2", restart_CS) + endif + + if (CS%store_CAu) then + if (query_initialized(CS%CAu_pred, "CAu", restart_CS) .and. & + query_initialized(CS%CAv_pred, "CAv", restart_CS)) then + CS%CAu_pred_stored = .true. + else + call only_read_from_restarts(uh, vh, 'uh', 'vh', G, restart_CS, stagger=CGRID_NE, & + filename=dirs%input_filename, directory=dirs%restart_input_dir, & + success=read_uv, scale=US%m_to_L**2*US%T_to_s/GV%H_to_mks) + call only_read_from_restarts('h2', CS%h_av, G, restart_CS, & + filename=dirs%input_filename, directory=dirs%restart_input_dir, & + success=read_h2, scale=1.0/GV%H_to_mks) + if (read_uv .and. read_h2) then + call pass_var(CS%h_av, G%Domain, clock=id_clock_pass_init) + else + do k=1,nz ; do j=jsd,jed ; do i=isd,ied ; h_tmp(i,j,k) = h(i,j,k) ; enddo ; enddo ; enddo + call continuity(CS%u_av, CS%v_av, h, h_tmp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init) + do k=1,nz ; do j=jsd,jed ; do i=isd,ied + CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k)) + enddo ; enddo ; enddo + endif + call pass_vector(CS%u_av, CS%v_av, G%Domain, halo=2, clock=id_clock_pass_init, complete=.false.) + call pass_vector(uh, vh, G%Domain, halo=2, clock=id_clock_pass_init, complete=.true.) + call CorAdCalc(CS%u_av, CS%v_av, CS%h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%ADp, & + G, GV, US, CS%CoriolisAdv, pbv) !, Waves=Waves) + CS%CAu_pred_stored = .true. + endif + else + CS%CAu_pred_stored = .false. + ! This call is just here to initialize uh and vh. + if (.not. query_initialized(uh, "uh", restart_CS) .or. & + .not. query_initialized(vh, "vh", restart_CS)) then + do k=1,nz ; do j=jsd,jed ; do i=isd,ied ; h_tmp(i,j,k) = h(i,j,k) ; enddo ; enddo ; enddo + call continuity(u, v, h, h_tmp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init) + do k=1,nz ; do j=jsd,jed ; do i=isd,ied + CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k)) + enddo ; enddo ; enddo + call set_initialized(uh, "uh", restart_CS) + call set_initialized(vh, "vh", restart_CS) + call set_initialized(CS%h_av, "h2", restart_CS) + ! Try reading the CAu and CAv fields from the restart file, in case this restart file is + ! using a newer format. + call only_read_from_restarts(CS%CAu_pred, CS%CAv_pred, "CAu", "CAv", G, restart_CS, & + stagger=CGRID_NE, filename=dirs%input_filename, directory=dirs%restart_input_dir, & + success=read_uv, scale=US%m_s_to_L_T*US%T_to_s) + CS%CAu_pred_stored = read_uv + else + if (.not. query_initialized(CS%h_av, "h2", restart_CS)) then + CS%h_av(:,:,:) = h(:,:,:) + call set_initialized(CS%h_av, "h2", restart_CS) + endif + endif + endif + call cpu_clock_begin(id_clock_pass_init) + call create_group_pass(pass_av_h_uvh, CS%u_av, CS%v_av, G%Domain, halo=2) + if (CS%CAu_pred_stored) then + call create_group_pass(pass_av_h_uvh, CS%CAu_pred, CS%CAv_pred, G%Domain, halo=2) + else + call create_group_pass(pass_av_h_uvh, CS%h_av, G%Domain, halo=2) + call create_group_pass(pass_av_h_uvh, uh, vh, G%Domain, halo=2) + endif + call do_group_pass(pass_av_h_uvh, G%Domain) + call cpu_clock_end(id_clock_pass_init) + + flux_units = get_flux_units(GV) + thickness_units = get_thickness_units(GV) + CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & + 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) + CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & + 'Meridional Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) + + CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & + 'Zonal Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & + 'Meridional Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_PFu = register_diag_field('ocean_model', 'PFu', diag%axesCuL, Time, & + 'Zonal Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & + 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_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.) + 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', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_PFv = register_diag_field('ocean_model', 'hf_PFv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Pressure Force Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + !CS%id_hf_CAu = register_diag_field('ocean_model', 'hf_CAu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_CAv = register_diag_field('ocean_model', 'hf_CAv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_hf_PFu_2d = register_diag_field('ocean_model', 'hf_PFu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Pressure Force Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_PFv_2d = register_diag_field('ocean_model', 'hf_PFv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Pressure Force Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_h_PFu = register_diag_field('ocean_model', 'h_PFu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_PFv = register_diag_field('ocean_model', 'h_PFv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_intz_PFu_2d = register_diag_field('ocean_model', 'intz_PFu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_PFv_2d = register_diag_field('ocean_model', 'intz_PFv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_hf_CAu_2d = register_diag_field('ocean_model', 'hf_CAu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_CAv_2d = register_diag_field('ocean_model', 'hf_CAv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_h_CAu = register_diag_field('ocean_model', 'h_CAu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_CAv = register_diag_field('ocean_model', 'h_CAv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_intz_CAu_2d = register_diag_field('ocean_model', 'intz_CAu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_CAv_2d = register_diag_field('ocean_model', 'intz_CAv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_uav = register_diag_field('ocean_model', 'uav', diag%axesCuL, Time, & + 'Barotropic-step Averaged Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vav = register_diag_field('ocean_model', 'vav', diag%axesCvL, Time, & + 'Barotropic-step Averaged Meridional Velocity', 'm s-1', conversion=US%L_T_to_m_s) + + CS%id_u_BT_accel = register_diag_field('ocean_model', 'u_BT_accel', diag%axesCuL, Time, & + 'Barotropic Anomaly Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_v_BT_accel = register_diag_field('ocean_model', 'v_BT_accel', diag%axesCvL, Time, & + 'Barotropic Anomaly Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + + !CS%id_hf_u_BT_accel = register_diag_field('ocean_model', 'hf_u_BT_accel', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_v_BT_accel = register_diag_field('ocean_model', 'hf_v_BT_accel', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_hf_u_BT_accel_2d = register_diag_field('ocean_model', 'hf_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_v_BT_accel_2d = register_diag_field('ocean_model', 'hf_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_h_u_BT_accel = register_diag_field('ocean_model', 'h_u_BT_accel', diag%axesCuL, Time, & + 'Thickness Multiplied Barotropic Anomaly Zonal Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_v_BT_accel = register_diag_field('ocean_model', 'h_v_BT_accel', diag%axesCvL, Time, & + 'Thickness Multiplied Barotropic Anomaly Meridional Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_intz_u_BT_accel_2d = register_diag_field('ocean_model', 'intz_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-integral of Barotropic Anomaly Zonal Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_v_BT_accel_2d = register_diag_field('ocean_model', 'intz_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-integral of Barotropic Anomaly Meridional Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_PFu_visc_rem = register_diag_field('ocean_model', 'PFu_visc_rem', diag%axesCuL, Time, & + 'Zonal Pressure Force Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_PFu_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + CS%id_PFv_visc_rem = register_diag_field('ocean_model', 'PFv_visc_rem', diag%axesCvL, Time, & + 'Meridional Pressure Force Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_PFv_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + + CS%id_CAu_visc_rem = register_diag_field('ocean_model', 'CAu_visc_rem', diag%axesCuL, Time, & + 'Zonal Coriolis and Advective Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_CAu_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + CS%id_CAv_visc_rem = register_diag_field('ocean_model', 'CAv_visc_rem', diag%axesCvL, Time, & + 'Meridional Coriolis and Advective Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_CAv_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + + CS%id_u_BT_accel_visc_rem = register_diag_field('ocean_model', 'u_BT_accel_visc_rem', diag%axesCuL, Time, & + 'Barotropic Anomaly Zonal Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_u_BT_accel_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + CS%id_v_BT_accel_visc_rem = register_diag_field('ocean_model', 'v_BT_accel_visc_rem', diag%axesCvL, Time, & + 'Barotropic Anomaly Meridional Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_v_BT_accel_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + + id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) + id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) + id_clock_pres = cpu_clock_id('(Ocean pressure force)', grain=CLOCK_MODULE) + id_clock_vertvisc = cpu_clock_id('(Ocean vertical viscosity)', grain=CLOCK_MODULE) + id_clock_horvisc = cpu_clock_id('(Ocean horizontal viscosity)', grain=CLOCK_MODULE) + id_clock_mom_update = cpu_clock_id('(Ocean momentum increments)', grain=CLOCK_MODULE) + id_clock_pass = cpu_clock_id('(Ocean message passing)', grain=CLOCK_MODULE) + id_clock_btcalc = cpu_clock_id('(Ocean barotropic mode calc)', grain=CLOCK_MODULE) + id_clock_btstep = cpu_clock_id('(Ocean barotropic mode stepping)', grain=CLOCK_MODULE) + id_clock_btforce = cpu_clock_id('(Ocean barotropic forcing calc)', grain=CLOCK_MODULE) + +end subroutine initialize_dyn_split_RK2 + + +!> Close the dyn_split_RK2 module +subroutine end_dyn_split_RK2(CS) + type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + + call barotropic_end(CS%barotropic_CSp) + + call vertvisc_end(CS%vertvisc_CSp) + deallocate(CS%vertvisc_CSp) + + call hor_visc_end(CS%hor_visc) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) + call CoriolisAdv_end(CS%CoriolisAdv) + + DEALLOC_(CS%diffu) ; DEALLOC_(CS%diffv) + DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) + DEALLOC_(CS%CAu_pred) ; DEALLOC_(CS%CAv_pred) + DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) + + if (associated(CS%taux_bot)) deallocate(CS%taux_bot) + if (associated(CS%tauy_bot)) deallocate(CS%tauy_bot) + DEALLOC_(CS%uhbt) ; DEALLOC_(CS%vhbt) + DEALLOC_(CS%u_accel_bt) ; DEALLOC_(CS%v_accel_bt) + DEALLOC_(CS%visc_rem_u) ; DEALLOC_(CS%visc_rem_v) + + DEALLOC_(CS%eta) ; DEALLOC_(CS%eta_PF) ; DEALLOC_(CS%pbce) + DEALLOC_(CS%h_av) ; DEALLOC_(CS%u_av) ; DEALLOC_(CS%v_av) + + call dealloc_BT_cont_type(CS%BT_cont) + deallocate(CS%AD_pred) + + deallocate(CS) +end subroutine end_dyn_split_RK2 + + +!> \namespace mom_dynamics_split_rk2 +!! +!! This file time steps the adiabatic dynamic core by splitting +!! between baroclinic and barotropic modes. It uses a pseudo-second order +!! Runge-Kutta time stepping scheme for the baroclinic momentum +!! equation and a forward-backward coupling between the baroclinic +!! momentum and continuity equations. This split time-stepping +!! scheme is described in detail in Hallberg (JCP, 1997). Additional +!! issues related to exact tracer conservation and how to +!! ensure consistency between the barotropic and layered estimates +!! of the free surface height are described in Hallberg and +!! Adcroft (Ocean Modelling, 2009). This was the time stepping code +!! that is used for most GOLD applications, including GFDL's ESM2G +!! Earth system model, and all of the examples provided with the +!! MOM code (although several of these solutions are routinely +!! verified by comparison with the slower unsplit schemes). +!! +!! The subroutine step_MOM_dyn_split_RK2 actually does the time +!! stepping, while register_restarts_dyn_split_RK2 sets the fields +!! that are found in a full restart file with this scheme, and +!! initialize_dyn_split_RK2 initializes the cpu clocks that are +!! used in this module. For largely historical reasons, this module +!! does not have its own control structure, but shares the same +!! control structure with MOM.F90 and the other MOM_dynamics_... +!! modules. + +end module MOM_dynamics_split_RK2 diff --git a/core/MOM_dynamics_split_RK2b.F90 b/core/MOM_dynamics_split_RK2b.F90 new file mode 100644 index 0000000000..44a0b0bf5c --- /dev/null +++ b/core/MOM_dynamics_split_RK2b.F90 @@ -0,0 +1,1698 @@ +!> Time step the adiabatic dynamic core of MOM using RK2 method with greater use of the +!! time-filtered velocities and less inheritance of tedencies from the previous step in the +!! predictor step than in the original MOM_dyanmics_split_RK2. +module MOM_dynamics_split_RK2b + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_type +use MOM_variables, only : BT_cont_type, alloc_bt_cont_type, dealloc_bt_cont_type +use MOM_variables, only : accel_diag_ptrs, ocean_internal_state, cont_diag_ptrs +use MOM_forcing_type, only : mech_forcing + +use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum, MOM_accel_chksum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : diag_mediator_init, enable_averages +use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr +use MOM_diag_mediator, only : post_product_u, post_product_sum_u +use MOM_diag_mediator, only : post_product_v, post_product_sum_v +use MOM_diag_mediator, only : register_diag_field, register_static_field +use MOM_diag_mediator, only : set_diag_mediator_grid, diag_ctrl, diag_update_remap_grids +use MOM_domains, only : To_South, To_West, To_All, CGRID_NE, SCALAR_PAIR +use MOM_domains, only : To_North, To_East, Omit_Corners +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : start_group_pass, complete_group_pass, pass_var, pass_vector +use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_io, only : vardesc, var_desc, EAST_FACE, NORTH_FACE +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, set_initialized, save_restart +use MOM_restart, only : only_read_from_restarts +use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS +use MOM_time_manager, only : time_type, time_type_to_real, operator(+) +use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) + +use MOM_ALE, only : ALE_CS, ALE_remap_velocities +use MOM_barotropic, only : barotropic_init, btstep, btcalc, bt_mass_source +use MOM_barotropic, only : register_barotropic_restarts, set_dtbt, barotropic_CS +use MOM_barotropic, only : barotropic_end +use MOM_boundary_update, only : update_OBC_data, update_OBC_CS +use MOM_continuity, only : continuity, continuity_CS +use MOM_continuity, only : continuity_init, continuity_stencil +use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_CS +use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end +use MOM_debugging, only : check_redundant +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS +use MOM_hor_visc, only : hor_visc_init, hor_visc_end +use MOM_interface_heights, only : thickness_to_dz, find_col_avg_SpV +use MOM_lateral_mixing_coeffs, only : VarMix_CS +use MOM_MEKE_types, only : MEKE_type +use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds +use MOM_open_boundary, only : open_boundary_zero_normal_flow, open_boundary_query +use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp +use MOM_PressureForce, only : PressureForce, PressureForce_CS +use MOM_PressureForce, only : PressureForce_init +use MOM_set_visc, only : set_viscous_ML, set_visc_CS +use MOM_thickness_diffuse, only : thickness_diffuse_CS +use MOM_self_attr_load, only : SAL_CS +use MOM_self_attr_load, only : SAL_init, SAL_end +use MOM_tidal_forcing, only : tidal_forcing_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end +use MOM_unit_scaling, only : unit_scale_type +use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_remnant +use MOM_vert_friction, only : vertvisc_init, vertvisc_end, vertvisc_CS +use MOM_vert_friction, only : updateCFLtruncationValue, vertFPmix +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units +use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units +use MOM_wave_interface, only: wave_parameters_CS, Stokes_PGF +use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS +use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member + +implicit none ; private + +#include + +!> MOM_dynamics_split_RK2b module control structure +type, public :: MOM_dyn_split_RK2b_CS ; private + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & + CAu, & !< CAu = f*v - u.grad(u) [L T-2 ~> m s-2] + CAu_pred, & !< The predictor step value of CAu = f*v - u.grad(u) [L T-2 ~> m s-2] + PFu, & !< PFu = -dM/dx [L T-2 ~> m s-2] + PFu_Stokes, & !< PFu_Stokes = -d/dx int_r (u_L*duS/dr) [L T-2 ~> m s-2] + diffu !< Zonal acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2] + + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & + CAv, & !< CAv = -f*u - u.grad(v) [L T-2 ~> m s-2] + CAv_pred, & !< The predictor step value of CAv = -f*u - u.grad(v) [L T-2 ~> m s-2] + PFv, & !< PFv = -dM/dy [L T-2 ~> m s-2] + PFv_Stokes, & !< PFv_Stokes = -d/dy int_r (v_L*dvS/dr) [L T-2 ~> m s-2] + diffv !< Meridional acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2] + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: visc_rem_u + !< Both the fraction of the zonal momentum originally in a + !! layer that remains after a time-step of viscosity, and the + !! fraction of a time-step worth of a barotropic acceleration + !! that a layer experiences after viscosity is applied [nondim]. + !! Nondimensional between 0 (at the bottom) and 1 (far above). + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_accel_bt + !< The zonal layer accelerations due to the difference between + !! the barotropic accelerations and the baroclinic accelerations + !! that were fed into the barotopic calculation [L T-2 ~> m s-2] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: visc_rem_v + !< Both the fraction of the meridional momentum originally in + !! a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step worth of a barotropic acceleration + !! that a layer experiences after viscosity is applied [nondim]. + !! Nondimensional between 0 (at the bottom) and 1 (far above). + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_accel_bt + !< The meridional layer accelerations due to the difference between + !! the barotropic accelerations and the baroclinic accelerations + !! that were fed into the barotopic calculation [L T-2 ~> m s-2] + + ! The following variables are only used with the split time stepping scheme. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta !< Instantaneous free surface height (in Boussinesq + !! mode) or column mass anomaly (in non-Boussinesq + !! mode) [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_av !< layer x-velocity with vertical mean replaced by + !! time-mean barotropic velocity over a baroclinic + !! timestep [L T-1 ~> m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_av !< layer y-velocity with vertical mean replaced by + !! time-mean barotropic velocity over a baroclinic + !! timestep [L T-1 ~> m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: h_av !< arithmetic mean of two successive layer + !! thicknesses [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_PF !< instantaneous SSH used in calculating PFu and + !! PFv [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: uhbt !< average x-volume or mass flux determined by the + !! barotropic solver [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! uhbt is roughly equal to the vertical sum of uh. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vhbt !< average y-volume or mass flux determined by the + !! barotropic solver [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! vhbt is roughly equal to vertical sum of vh. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure + !! anomaly in each layer due to free surface height + !! anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: du_av_inst !< The barotropic zonal velocity increment + !! between filtered and instantaneous velocities + !! [L T-1 ~> m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: dv_av_inst !< The barotropic meridional velocity increment + !! between filtered and instantaneous velocities + !! [L T-1 ~> m s-1] + type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to ge + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure + + real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the + !! effective summed open face areas as a function + !! of barotropic flow. + + logical :: split_bottom_stress !< If true, provide the bottom stress + !! calculated by the vertical viscosity to the + !! barotropic solver. + logical :: calc_dtbt !< If true, calculate the barotropic time-step + !! dynamically. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. + logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D + !! variables that are needed to reproduce across restarts, + !! similarly to what is done with the primary state variables. + + real :: be !< A nondimensional number from 0.5 to 1 that controls + !! the backward weighting of the time stepping scheme [nondim] + real :: begw !< A nondimensional number from 0 to 1 that controls + !! the extent to which the treatment of gravity waves + !! is forward-backward (0) or simulated backward + !! Euler (1) [nondim]. 0 is often used. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. + logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. + logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + + !>@{ Diagnostic IDs + ! integer :: id_uold = -1, id_vold = -1 + integer :: id_uh = -1, id_vh = -1 + integer :: id_umo = -1, id_vmo = -1 + integer :: id_umo_2d = -1, id_vmo_2d = -1 + integer :: id_PFu = -1, id_PFv = -1 + integer :: id_CAu = -1, id_CAv = -1 + integer :: id_ueffA = -1, id_veffA = -1 + ! integer :: id_hf_PFu = -1, id_hf_PFv = -1 + integer :: id_h_PFu = -1, id_h_PFv = -1 + integer :: id_hf_PFu_2d = -1, id_hf_PFv_2d = -1 + integer :: id_intz_PFu_2d = -1, id_intz_PFv_2d = -1 + integer :: id_PFu_visc_rem = -1, id_PFv_visc_rem = -1 + ! integer :: id_hf_CAu = -1, id_hf_CAv = -1 + integer :: id_h_CAu = -1, id_h_CAv = -1 + 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 + integer :: id_u_BT_accel = -1, id_v_BT_accel = -1 + ! integer :: id_hf_u_BT_accel = -1, id_hf_v_BT_accel = -1 + integer :: id_h_u_BT_accel = -1, id_h_v_BT_accel = -1 + integer :: id_hf_u_BT_accel_2d = -1, id_hf_v_BT_accel_2d = -1 + integer :: id_intz_u_BT_accel_2d = -1, id_intz_v_BT_accel_2d = -1 + integer :: id_u_BT_accel_visc_rem = -1, id_v_BT_accel_visc_rem = -1 + !>@} + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the + !! timing of diagnostic output. + type(accel_diag_ptrs), pointer :: ADp => NULL() !< A structure pointing to the various + !! accelerations in the momentum equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + type(accel_diag_ptrs), pointer :: AD_pred => NULL() !< A structure pointing to the various + !! predictor step accelerations in the momentum equations, + !! which can be used to debug truncations. + type(cont_diag_ptrs), pointer :: CDp => NULL() !< A structure with pointers to various + !! terms in the continuity equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + + ! The remainder of the structure points to child subroutines' control structures. + !> A pointer to the horizontal viscosity control structure + type(hor_visc_CS) :: hor_visc + !> A pointer to the continuity control structure + type(continuity_CS) :: continuity_CSp + !> The CoriolisAdv control structure + type(CoriolisAdv_CS) :: CoriolisAdv + !> A pointer to the PressureForce control structure + type(PressureForce_CS) :: PressureForce_CSp + !> A pointer to a structure containing interface height diffusivities + type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() + !> A pointer to the set_visc control structure + type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the barotropic stepping control structure + type(barotropic_CS) :: barotropic_CSp + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp + !> A pointer to the tidal forcing control structure + type(tidal_forcing_CS) :: tides_CSp + !> A pointer to the ALE control structure. + type(ALE_CS), pointer :: ALE_CSp => NULL() + + type(ocean_OBC_type), pointer :: OBC => NULL() !< A pointer to an open boundary + !! condition type that specifies whether, where, and what open boundary + !! conditions are used. If no open BCs are used, this pointer stays + !! nullified. Flather OBCs use open boundary_CS as well. + !> A pointer to the update_OBC control structure + type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() + + type(group_pass_type) :: pass_eta !< Structure for group halo pass + type(group_pass_type) :: pass_visc_rem !< Structure for group halo pass + type(group_pass_type) :: pass_uvp !< Structure for group halo pass + type(group_pass_type) :: pass_uv_inst !< Structure for group halo pass + type(group_pass_type) :: pass_hp_uv !< Structure for group halo pass + type(group_pass_type) :: pass_hp_uhvh !< Structure for group halo pass + type(group_pass_type) :: pass_h_uv !< Structure for group halo pass + +end type MOM_dyn_split_RK2b_CS + + +public step_MOM_dyn_split_RK2b +public register_restarts_dyn_split_RK2b +public initialize_dyn_split_RK2b +public remap_dyn_split_RK2b_aux_vars +public end_dyn_split_RK2b + +!>@{ CPU time clock IDs +integer :: id_clock_Cor, id_clock_pres, id_clock_vertvisc +integer :: id_clock_horvisc, id_clock_mom_update +integer :: id_clock_continuity, id_clock_thick_diff +integer :: id_clock_btstep, id_clock_btcalc, id_clock_btforce +integer :: id_clock_pass +!>@} + +contains + +!> RK2 splitting for time stepping MOM adiabatic dynamics +subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, & + G, GV, US, CS, calc_dtbt, VarMix, MEKE, thickness_diffuse_CSp, pbv, Waves) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + target, intent(inout) :: u_av !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(inout) :: v_av !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type + type(vertvisc_type), intent(inout) :: visc !< Vertical visc, bottom drag, and related + type(time_type), intent(in) :: Time_local !< Model time at end of time step + real, intent(in) :: dt !< Baroclinic dynamics time step [T ~> s] + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(:,:), pointer :: p_surf_begin !< Surface pressure at the start of this dynamic + !! time step [R L2 T-2 ~> Pa] + real, dimension(:,:), pointer :: p_surf_end !< Surface pressure at the end of this dynamic + !! time step [R L2 T-2 ~> Pa] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + target, intent(inout) :: uh !< Zonal volume or mass transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(inout) :: vh !< Meridional volume or mass transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Accumulated zonal volume or mass transport + !! since last tracer advection [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Accumulated meridional volume or mass transport + !! since last tracer advection [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< Free surface height or column mass + !! averaged over time step [H ~> m or kg m-2] + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< Module control structure + logical, intent(in) :: calc_dtbt !< If true, recalculate the barotropic time step + type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(thickness_diffuse_CS), intent(inout) :: thickness_diffuse_CSp !< Pointer to a structure containing + !! interface height diffusivities + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(wave_parameters_CS), optional, pointer :: Waves !< A pointer to a structure containing + !! fields related to the surface wave conditions + + ! local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up ! Predicted zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp ! Predicted meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted thickness [H ~> m or kg m-2]. + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: veffA ! Effective Area of V-Faces [H L ~> m2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_bc_accel ! The summed zonal baroclinic accelerations + ! of each layer calculated by the non-barotropic + ! part of the model [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_bc_accel ! The summed meridional baroclinic accelerations + ! of each layer calculated by the non-barotropic + ! part of the model [L T-2 ~> m s-2] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target :: u_inst ! Instantaneous zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target :: v_inst ! Instantaneous meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av ! The average of the layer thicknesses at the beginning + ! and end of a time step [H ~> m or kg m-2] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target :: uh_in ! The zonal mass transports that would be + ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target :: vh_in ! The meridional mass transports that would be + ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1] + + real, dimension(SZI_(G),SZJ_(G)) :: eta_pred ! The predictor value of the free surface height + ! or column mass [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)) :: SpV_avg ! The column averaged specific volume [R-1 ~> m3 kg-1] + real, dimension(SZI_(G),SZJ_(G)) :: deta_dt ! A diagnostic of the time derivative of the free surface + ! height or column mass [H T-1 ~> m s-1 or kg m-2 s-1] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_old_rad_OBC ! The starting zonal velocities, which are + ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_old_rad_OBC ! The starting meridional velocities, which are + ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1] + + ! GMM, TODO: make these allocatable? + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uold ! u-velocity before vert_visc is applied, for fpmix + ! [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vold ! v-velocity before vert_visc is applied, for fpmix + ! [L T-1 ~> m s-1] + real :: pres_to_eta ! A factor that converts pressures to the units of eta + ! [H T2 R-1 L-2 ~> m Pa-1 or kg m-2 Pa-1] + real, pointer, dimension(:,:) :: & + p_surf => NULL(), & ! A pointer to the surface pressure [R L2 T-2 ~> Pa] + eta_PF_start => NULL(), & ! The value of eta that corresponds to the starting pressure + ! for the barotropic solver [H ~> m or kg m-2] + taux_bot => NULL(), & ! A pointer to the zonal bottom stress in some cases [R L Z T-2 ~> Pa] + tauy_bot => NULL(), & ! A pointer to the meridional bottom stress in some cases [R L Z T-2 ~> Pa] + ! This pointer is just used as shorthand for CS%eta. + eta => NULL() ! A pointer to the instantaneous free surface height (in Boussinesq + ! mode) or column mass anomaly (in non-Boussinesq mode) [H ~> m or kg m-2] + + real, pointer, dimension(:,:,:) :: & + ! These pointers are used to alter which fields are passed to btstep with various options: + u_ptr => NULL(), & ! A pointer to a zonal velocity [L T-1 ~> m s-1] + v_ptr => NULL(), & ! A pointer to a meridional velocity [L T-1 ~> m s-1] + uh_ptr => NULL(), & ! A pointer to a zonal volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + vh_ptr => NULL() ! A pointer to a meridional volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + + real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix [H ~> m or kg m-2] + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. + real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] + logical :: dyn_p_surf + logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the + ! relative weightings of the layers in calculating + ! the barotropic accelerations. + !---For group halo pass + logical :: showCallTree, sym + + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: cont_stencil, obc_stencil + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + eta => CS%eta + + Idt_bc = 1.0 / dt + + sym = G%Domain%symmetric ! switch to include symmetric domain in checksums + + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("step_MOM_dyn_split_RK2b(), MOM_dynamics_split_RK2b.F90") + + ! Fill in some halo points for arrays that will have halo updates. + hp(:,:,:) = h(:,:,:) + up(:,:,:) = 0.0 ; vp(:,:,:) = 0.0 ; u_inst(:,:,:) = 0.0 ; v_inst(:,:,:) = 0.0 + + ! Update CFL truncation value as function of time + call updateCFLtruncationValue(Time_local, CS%vertvisc_CSp, US) + + if (CS%debug) then + call MOM_state_chksum("Start predictor ", u_av, v_av, h, uh, vh, G, GV, US, symmetric=sym) + call check_redundant("Start predictor u ", u_av, v_av, G, unscale=US%L_T_to_m_s) + call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif + + dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) + if (dyn_p_surf) then + p_surf => p_surf_end + call safe_alloc_ptr(eta_PF_start,G%isd,G%ied,G%jsd,G%jed) + eta_PF_start(:,:) = 0.0 + else + p_surf => forces%p_surf + endif + + if (associated(CS%OBC)) then + if (CS%debug_OBC) call open_boundary_test_extern_h(G, GV, CS%OBC, h) + + ! Update OBC ramp value as function of time + call update_OBC_ramp(Time_local, CS%OBC, US) + + do k=1,nz ; do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + u_old_rad_OBC(I,j,k) = u_av(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + v_old_rad_OBC(i,J,k) = v_av(i,J,k) + enddo ; enddo ; enddo + endif + + BT_cont_BT_thick = .false. + if (associated(CS%BT_cont)) BT_cont_BT_thick = & + (allocated(CS%BT_cont%h_u) .and. allocated(CS%BT_cont%h_v)) + + if (CS%split_bottom_stress) then + taux_bot => CS%taux_bot ; tauy_bot => CS%tauy_bot + endif + + !--- begin set up for group halo pass + + cont_stencil = continuity_stencil(CS%continuity_CSp) + obc_stencil = 2 + if (associated(CS%OBC)) then + if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3 + endif + call cpu_clock_begin(id_clock_pass) + call create_group_pass(CS%pass_eta, eta, G%Domain, halo=1) + call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, & + To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil)) + call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) + call create_group_pass(CS%pass_uv_inst, u_inst, v_inst, G%Domain, halo=max(2,cont_stencil)) + + call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2) + call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + + call create_group_pass(CS%pass_hp_uhvh, hp, G%Domain, halo=2) + call create_group_pass(CS%pass_hp_uhvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + + call create_group_pass(CS%pass_h_uv, h, G%Domain, halo=max(2,cont_stencil)) + call create_group_pass(CS%pass_h_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_h_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + + call cpu_clock_end(id_clock_pass) + !--- end set up for group halo pass + + if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) + endif ; endif + + ! This calculates the transports and averaged thicknesses that will be used for the + ! predictor version of the Coriolis scheme. + call cpu_clock_begin(id_clock_continuity) + call continuity(u_av, v_av, h, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call cpu_clock_end(id_clock_continuity) + + if (G%nonblocking_updates) & + call start_group_pass(CS%pass_hp_uhvh, G%Domain, clock=id_clock_pass) + +! PFu = d/dx M(h,T,S) +! pbce = dM/deta + if (CS%begw == 0.0) call enable_averages(dt, Time_local, CS%diag) + call cpu_clock_begin(id_clock_pres) + call PressureForce(h, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & + CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) + if (dyn_p_surf) then + pres_to_eta = 1.0 / (GV%g_Earth * GV%H_to_RZ) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_PF_start(i,j) = CS%eta_PF(i,j) - pres_to_eta * (p_surf_begin(i,j) - p_surf_end(i,j)) + enddo ; enddo + endif + ! Stokes shear force contribution to pressure gradient + if (present(Waves)) then ; if (associated(Waves)) then ; if (Waves%Stokes_PGF) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u_av, v_av, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + + ! We are adding Stokes_PGF to hydrostatic PGF here. The diag PFu/PFv + ! will therefore report the sum total PGF and we avoid other + ! modifications in the code. The PFu_Stokes is output within the waves routines. + if (.not.Waves%Passive_Stokes_PGF) then + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) + enddo ; enddo ; enddo + endif + endif ; endif ; endif + call cpu_clock_end(id_clock_pres) + call disable_averaging(CS%diag) + if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2b)") + + if (associated(CS%OBC) .and. CS%debug_OBC) & + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) + + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_hp_uhvh, G%Domain, clock=id_clock_pass) + call start_group_pass(CS%pass_eta, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_hp_uhvh, G%Domain, clock=id_clock_pass) + endif + + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) + enddo ; enddo ; enddo + + ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms + ! and horizontal viscous accelerations. + +! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%AD_pred, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with predictor CorAdCalc (step_MOM_dyn_split_RK2b)") + +! diffu = horizontal viscosity terms (u_av) + call cpu_clock_begin(id_clock_horvisc) + call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%AD_pred) + call cpu_clock_end(id_clock_horvisc) + if (showCallTree) call callTree_wayPoint("done with predictor horizontal_viscosity (step_MOM_dyn_split_RK2b)") + +! u_bc_accel = CAu + PFu + diffu(u[n-1]) + call cpu_clock_begin(id_clock_btforce) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + u_bc_accel(I,j,k) = (CS%CAu_pred(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v_bc_accel(i,J,k) = (CS%CAv_pred(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k) + enddo ; enddo + enddo + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, u_bc_accel, v_bc_accel) + endif + call cpu_clock_end(id_clock_btforce) + + if (CS%debug) then + call MOM_accel_chksum("pre-btstep accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & + symmetric=sym) + call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif + + call cpu_clock_begin(id_clock_vertvisc) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + up(I,j,k) = G%mask2dCu(I,j) * (u_av(I,j,k) + dt * u_bc_accel(I,j,k)) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + vp(i,J,k) = G%mask2dCv(i,J) * (v_av(i,J,k) + dt * v_bc_accel(i,J,k)) + enddo ; enddo + enddo + + call enable_averages(dt, Time_local, CS%diag) + call set_viscous_ML(u_av, v_av, h, tv, forces, visc, dt, G, GV, US, CS%set_visc_CSp) + call disable_averaging(CS%diag) + + if (CS%debug) then + call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + endif + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + call cpu_clock_end(id_clock_vertvisc) + if (showCallTree) call callTree_wayPoint("done with vertvisc_coef (step_MOM_dyn_split_RK2b)") + + + call cpu_clock_begin(id_clock_pass) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_eta, G%Domain) + call start_group_pass(CS%pass_visc_rem, G%Domain) + else + call do_group_pass(CS%pass_eta, G%Domain) + call do_group_pass(CS%pass_visc_rem, G%Domain) + endif + call cpu_clock_end(id_clock_pass) + + call cpu_clock_begin(id_clock_btcalc) + ! Calculate the relative layer weights for determining barotropic quantities. + if (.not.BT_cont_BT_thick) & + call btcalc(h, G, GV, CS%barotropic_CSp, OBC=CS%OBC) + call bt_mass_source(h, eta, .true., G, GV, CS%barotropic_CSp) + + SpV_avg(:,:) = 0.0 + if ((.not.GV%Boussinesq) .and. associated(CS%OBC)) then + ! Determine the column average specific volume if it is needed due to the + ! use of Flather open boundary conditions in non-Boussinesq mode. + if (open_boundary_query(CS%OBC, apply_Flather_OBC=.true.)) & + call find_col_avg_SpV(h, SpV_avg, tv, G, GV, US) + endif + call cpu_clock_end(id_clock_btcalc) + + if (G%nonblocking_updates) & + call complete_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + + ! Reconstruct u_inst and v_inst from u_av and v_av. + call cpu_clock_begin(id_clock_mom_update) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + u_inst(I,j,k) = u_av(I,j,k) - CS%du_av_inst(I,j) * CS%visc_rem_u(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + v_inst(i,J,k) = v_av(i,J,k) - CS%dv_av_inst(i,j) * CS%visc_rem_v(i,J,k) + enddo ; enddo ; enddo + call cpu_clock_end(id_clock_mom_update) + call do_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) + +! u_accel_bt = layer accelerations due to barotropic solver + call cpu_clock_begin(id_clock_continuity) + call continuity(u_inst, v_inst, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, BT_cont=CS%BT_cont) + call cpu_clock_end(id_clock_continuity) + if (BT_cont_BT_thick) then + call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, & + OBC=CS%OBC) + endif + if (showCallTree) call callTree_wayPoint("done with continuity[BT_cont] (step_MOM_dyn_split_RK2b)") + + uh_ptr => uh_in ; vh_ptr => vh_in ; u_ptr => u_inst ; v_ptr => v_inst + + call cpu_clock_begin(id_clock_btstep) + if (calc_dtbt) call set_dtbt(G, GV, US, CS%barotropic_CSp, eta, CS%pbce) + if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") + ! This is the predictor step call to btstep. + ! The CS%ADp argument here stores the weights for certain integrated diagnostics. + call btstep(u_inst, v_inst, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & + CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & + eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr) + if (showCallTree) call callTree_leave("btstep()") + call cpu_clock_end(id_clock_btstep) + + dt_pred = dt * CS%be + call cpu_clock_begin(id_clock_mom_update) + +! up = u + dt_pred*( u_bc_accel + u_accel_bt ) + !$OMP parallel do default(shared) + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie + vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt_pred * & + (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) + enddo ; enddo + do j=js,je ; do I=Isq,Ieq + up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt_pred * & + (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) + enddo ; enddo + enddo + call cpu_clock_end(id_clock_mom_update) + + if (CS%debug) then + call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, & + symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) +! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1) + call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) + call MOM_state_chksum("Predictor 1 init", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1, & + symmetric=sym) + call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif + +! up <- up + dt_pred d/dz visc d/dz up +! u_av <- u_av + dt_pred d/dz visc d/dz u_av + call cpu_clock_begin(id_clock_vertvisc) + if (CS%debug) then + call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + endif + + ! if (CS%fpmix) then + ! uold(:,:,:) = 0.0 + ! vold(:,:,:) = 0.0 + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! uold(I,j,k) = up(I,j,k) + ! enddo ; enddo ; enddo + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! vold(i,J,k) = vp(i,J,k) + ! enddo ; enddo ; enddo + ! endif + + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, & + CS%OBC, VarMix) + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + + ! if (CS%fpmix) then + ! hbl(:,:) = 0.0 + ! if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + ! if (ASSOCIATED(CS%energetic_PBL_CSp)) & + ! call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) + ! call vertFPmix(up, vp, uold, vold, hbl, h, forces, & + ! dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) + ! call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & + ! GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + ! endif + + if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2b)") + if (G%nonblocking_updates) then + call cpu_clock_end(id_clock_vertvisc) + call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) + call cpu_clock_begin(id_clock_vertvisc) + endif + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + call cpu_clock_end(id_clock_vertvisc) + + call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) + endif + + ! uh = u_av * h + ! hp = h + dt * div . uh + call cpu_clock_begin(id_clock_continuity) + call continuity(up, vp, h, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, & + u_av, v_av, BT_cont=CS%BT_cont) + call cpu_clock_end(id_clock_continuity) + if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2b)") + + call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) + + if (associated(CS%OBC)) then + if (CS%debug) & + call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + + call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt_pred) + + if (CS%debug) & + call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + endif + + ! h_av = (h + hp)/2 + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) + enddo ; enddo ; enddo + + ! The correction phase of the time step starts here. + call enable_averages(dt, Time_local, CS%diag) + + ! Calculate a revised estimate of the free-surface height correction to be + ! used in the next call to btstep. This call is at this point so that + ! hp can be changed if CS%begw /= 0. + ! eta_cor = ... (hidden inside CS%barotropic_CSp) + call cpu_clock_begin(id_clock_btcalc) + call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp) + call cpu_clock_end(id_clock_btcalc) + + if (CS%begw /= 0.0) then + ! hp <- (1-begw)*h_in + begw*hp + ! Back up hp to the value it would have had after a time-step of + ! begw*dt. hp is not used again until recalculated by continuity. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + hp(i,j,k) = (1.0-CS%begw)*h(i,j,k) + CS%begw*hp(i,j,k) + enddo ; enddo ; enddo + + ! PFu = d/dx M(hp,T,S) + ! pbce = dM/deta + call cpu_clock_begin(id_clock_pres) + call PressureForce(hp, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & + CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) + ! Stokes shear force contribution to pressure gradient + if (present(Waves)) then ; if (associated(Waves)) then ; if (Waves%Stokes_PGF) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u_av, v_av, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + if (.not.Waves%Passive_Stokes_PGF) then + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) + enddo ; enddo ; enddo + endif + endif ; endif ; endif + call cpu_clock_end(id_clock_pres) + if (showCallTree) call callTree_wayPoint("done with PressureForce[hp=(1-b).h+b.h] (step_MOM_dyn_split_RK2b)") + endif + + if (BT_cont_BT_thick) then + call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, & + OBC=CS%OBC) + if (showCallTree) call callTree_wayPoint("done with btcalc[BT_cont_BT_thick] (step_MOM_dyn_split_RK2b)") + endif + + if (CS%debug) then + call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym) + call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call hchksum(h_av, "Predictor avg h", G%HI, haloshift=0, scale=GV%H_to_MKS) + ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) + call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif + +! diffu = horizontal viscosity terms (u_av) + call cpu_clock_begin(id_clock_horvisc) + call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%ADp) + call cpu_clock_end(id_clock_horvisc) + if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2b)") + +! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2b)") + +! Calculate the momentum forcing terms for the barotropic equations. + +! u_bc_accel = CAu + PFu + diffu(u[n-1]) + call cpu_clock_begin(id_clock_btforce) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + u_bc_accel(I,j,k) = (CS%Cau(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v_bc_accel(i,J,k) = (CS%Cav(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k) + enddo ; enddo + enddo + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, u_bc_accel, v_bc_accel) + endif + call cpu_clock_end(id_clock_btforce) + + if (CS%debug) then + call MOM_accel_chksum("corr pre-btstep accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & + symmetric=sym) + call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif + + ! u_accel_bt = layer accelerations due to barotropic solver + ! pbce = dM/deta + call cpu_clock_begin(id_clock_btstep) + + uh_ptr => uh ; vh_ptr => vh ; u_ptr => u_av ; v_ptr => v_av + + if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") + ! This is the corrector step call to btstep. + call btstep(u_inst, v_inst, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & + CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & + eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr, etaav=eta_av) + if (CS%id_deta_dt>0) then + do j=js,je ; do i=is,ie ; deta_dt(i,j) = (eta_pred(i,j) - eta(i,j))*Idt_bc ; enddo ; enddo + 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) + if (showCallTree) call callTree_leave("btstep()") + + if (CS%debug) then + call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G, unscale=US%L_T2_to_m_s2) + endif + + ! u = u + dt*( u_bc_accel + u_accel_bt ) + call cpu_clock_begin(id_clock_mom_update) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + u_inst(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * & + (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v_inst(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * & + (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) + enddo ; enddo + enddo + call cpu_clock_end(id_clock_mom_update) + + if (CS%debug) then + call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) + call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & + symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1) + call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, & + symmetric=sym) + endif + + ! u <- u + dt d/dz visc d/dz u + ! u_av <- u_av + dt d/dz visc d/dz u_av + call cpu_clock_begin(id_clock_vertvisc) + + ! if (CS%fpmix) then + ! uold(:,:,:) = 0.0 + ! vold(:,:,:) = 0.0 + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! uold(I,j,k) = u_inst(I,j,k) + ! enddo ; enddo ; enddo + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! vold(i,J,k) = v_inst(i,J,k) + ! enddo ; enddo ; enddo + ! endif + + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(u_inst, v_inst, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + + ! if (CS%fpmix) then + ! call vertFPmix(u_inst, v_inst, uold, vold, hbl, h, forces, dt, & + ! G, GV, US, CS%vertvisc_CSp, CS%OBC) + ! call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + ! CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + ! endif + + if (G%nonblocking_updates) then + call cpu_clock_end(id_clock_vertvisc) + call start_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) + call cpu_clock_begin(id_clock_vertvisc) + endif + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + call cpu_clock_end(id_clock_vertvisc) + if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2b)") + + call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) + endif + + ! uh = u_av * h + ! h = h + dt * div . uh + ! u_av and v_av adjusted so their mass transports match uhbt and vhbt. + call cpu_clock_begin(id_clock_continuity) + + call continuity(u_inst, v_inst, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, u_av, v_av, & + du_cor=CS%du_av_inst, dv_cor=CS%dv_av_inst) + + ! This tests the ability to readjust the instantaneous velocity, and here it changes answers only at roundoff. + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! u_inst(I,j,k) = u_av(I,j,k) - CS%du_av_inst(I,j) * CS%visc_rem_u(I,j,k) + ! enddo ; enddo ; enddo + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! v_inst(i,J,k) = v_av(i,J,k) - CS%dv_av_inst(i,J) * CS%visc_rem_v(i,J,k) + ! enddo ; enddo ; enddo + + call cpu_clock_end(id_clock_continuity) + + call do_group_pass(CS%pass_h_uv, G%Domain, clock=id_clock_pass) + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2b)") + + if (associated(CS%OBC)) then + call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt) + endif + + !$OMP parallel do default(shared) + do k=1,nz + do j=js-2,je+2 ; do I=Isq-2,Ieq+2 + uhtr(I,j,k) = uhtr(I,j,k) + uh(I,j,k)*dt + enddo ; enddo + do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 + vhtr(i,J,k) = vhtr(i,J,k) + vh(i,J,k)*dt + enddo ; enddo + enddo + + ! if (CS%fpmix) then + ! if (CS%id_uold > 0) call post_data(CS%id_uold, uold, CS%diag) + ! if (CS%id_vold > 0) call post_data(CS%id_vold, vold, CS%diag) + ! endif + + ! The time-averaged free surface height has already been set by the last call to btstep. + + ! Deallocate this memory to avoid a memory leak. ### We should revisit how this array is declared. -RWH + if (dyn_p_surf .and. associated(eta_PF_start)) deallocate(eta_PF_start) + + ! Here various terms used in to update the momentum equations are + ! offered for time averaging. + if (CS%id_PFu > 0) call post_data(CS%id_PFu, CS%PFu, CS%diag) + if (CS%id_PFv > 0) call post_data(CS%id_PFv, CS%PFv, CS%diag) + if (CS%id_CAu > 0) call post_data(CS%id_CAu, CS%CAu, CS%diag) + if (CS%id_CAv > 0) call post_data(CS%id_CAv, CS%CAv, CS%diag) + + ! Here the thickness fluxes are offered for time averaging. + if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) + if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) + if (CS%id_uav > 0) call post_data(CS%id_uav, u_av, CS%diag) + if (CS%id_vav > 0) call post_data(CS%id_vav, v_av, CS%diag) + if (CS%id_u_BT_accel > 0) call post_data(CS%id_u_BT_accel, CS%u_accel_bt, CS%diag) + if (CS%id_v_BT_accel > 0) call post_data(CS%id_v_BT_accel, CS%v_accel_bt, CS%diag) + + ! Calculate effective areas and post data + if (CS%id_ueffA > 0) then + ueffA(:,:,:) = 0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(u_av(I,j,k)) > 0.) ueffA(I,j,k) = uh(I,j,k) / u_av(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_ueffA, ueffA, CS%diag) + endif + + if (CS%id_veffA > 0) then + veffA(:,:,:) = 0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(v_av(i,J,k)) > 0.) veffA(i,J,k) = vh(i,J,k) / v_av(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_veffA, veffA, CS%diag) + endif + + ! Diagnostics of the fractional thicknesses times momentum budget terms + ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for debugging purposes in the future. + !if (CS%id_hf_PFu > 0) call post_product_u(CS%id_hf_PFu, CS%PFu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_PFv > 0) call post_product_v(CS%id_hf_PFv, CS%PFv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + !if (CS%id_hf_CAu > 0) call post_product_u(CS%id_hf_CAu, CS%CAu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_CAv > 0) call post_product_v(CS%id_hf_CAv, CS%CAv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + !if (CS%id_hf_u_BT_accel > 0) & + ! call post_product_u(CS%id_hf_u_BT_accel, CS%u_accel_bt, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_v_BT_accel > 0) & + ! call post_product_v(CS%id_hf_v_BT_accel, CS%v_accel_bt, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for the vertical sum of layer thickness x prssure force accelerations + if (CS%id_intz_PFu_2d > 0) call post_product_sum_u(CS%id_intz_PFu_2d, CS%PFu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_PFv_2d > 0) call post_product_sum_v(CS%id_intz_PFv_2d, CS%PFv, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics for thickness-weighted vertically averaged prssure force accelerations + if (CS%id_hf_PFu_2d > 0) call post_product_sum_u(CS%id_hf_PFu_2d, CS%PFu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_PFv_2d > 0) call post_product_sum_v(CS%id_hf_PFv_2d, CS%PFv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for thickness x prssure force accelerations + if (CS%id_h_PFu > 0) call post_product_u(CS%id_h_PFu, CS%PFu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_PFv > 0) call post_product_v(CS%id_h_PFv, CS%PFv, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics of Coriolis acceleratations + if (CS%id_intz_CAu_2d > 0) call post_product_sum_u(CS%id_intz_CAu_2d, CS%CAu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_CAv_2d > 0) call post_product_sum_v(CS%id_intz_CAv_2d, CS%CAv, CS%ADp%diag_hv, G, nz, CS%diag) + if (CS%id_hf_CAu_2d > 0) call post_product_sum_u(CS%id_hf_CAu_2d, CS%CAu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_CAv_2d > 0) call post_product_sum_v(CS%id_hf_CAv_2d, CS%CAv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + if (CS%id_h_CAu > 0) call post_product_u(CS%id_h_CAu, CS%CAu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_CAv > 0) call post_product_v(CS%id_h_CAv, CS%CAv, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics of barotropic solver acceleratations + if (CS%id_intz_u_BT_accel_2d > 0) & + call post_product_sum_u(CS%id_intz_u_BT_accel_2d, CS%u_accel_bt, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_v_BT_accel_2d > 0) & + call post_product_sum_v(CS%id_intz_v_BT_accel_2d, CS%v_accel_bt, CS%ADp%diag_hv, G, nz, CS%diag) + if (CS%id_hf_u_BT_accel_2d > 0) & + call post_product_sum_u(CS%id_hf_u_BT_accel_2d, CS%u_accel_bt, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_v_BT_accel_2d > 0) & + call post_product_sum_v(CS%id_hf_v_BT_accel_2d, CS%v_accel_bt, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + if (CS%id_h_u_BT_accel > 0) & + call post_product_u(CS%id_h_u_BT_accel, CS%u_accel_bt, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_v_BT_accel > 0) & + call post_product_v(CS%id_h_v_BT_accel, CS%v_accel_bt, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics for momentum budget terms multiplied by visc_rem_[uv], + if (CS%id_PFu_visc_rem > 0) call post_product_u(CS%id_PFu_visc_rem, CS%PFu, CS%ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_PFv_visc_rem > 0) call post_product_v(CS%id_PFv_visc_rem, CS%PFv, CS%ADp%visc_rem_v, G, nz, CS%diag) + if (CS%id_CAu_visc_rem > 0) call post_product_u(CS%id_CAu_visc_rem, CS%CAu, CS%ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_CAv_visc_rem > 0) call post_product_v(CS%id_CAv_visc_rem, CS%CAv, CS%ADp%visc_rem_v, G, nz, CS%diag) + if (CS%id_u_BT_accel_visc_rem > 0) & + call post_product_u(CS%id_u_BT_accel_visc_rem, CS%u_accel_bt, CS%ADp%visc_rem_u, G, nz, CS%diag) + 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_av, v_av, h, uh, vh, G, GV, US, symmetric=sym) + ! call uvchksum("Corrector inst [uv]", u_inst, v_inst, G%HI, symmetric=sym, scale=US%L_T_to_m_s) + endif + + if (showCallTree) call callTree_leave("step_MOM_dyn_split_RK2b()") + +end subroutine step_MOM_dyn_split_RK2b + +!> This subroutine sets up any auxiliary restart variables that are specific +!! to the split-explicit time stepping scheme. All variables registered here should +!! have the ability to be recreated if they are not present in a restart file. +subroutine register_restarts_dyn_split_RK2b(HI, GV, US, param_file, CS, restart_CS, uh, vh) + type(hor_index_type), intent(in) :: HI !< Horizontal index 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(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + real, dimension(SZIB_(HI),SZJ_(HI),SZK_(GV)), & + target, intent(inout) :: uh !< zonal volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(HI),SZJB_(HI),SZK_(GV)), & + target, intent(inout) :: vh !< merid volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + + character(len=40) :: mdl = "MOM_dynamics_split_RK2b" ! This module's name. + type(vardesc) :: vd(2) + character(len=48) :: thickness_units, flux_units + + integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB + + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB + + ! This is where a control structure specific to this module would be allocated. + if (associated(CS)) then + call MOM_error(WARNING, "register_restarts_dyn_split_RK2b called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ALLOC_(CS%diffu(IsdB:IedB,jsd:jed,nz)) ; CS%diffu(:,:,:) = 0.0 + ALLOC_(CS%diffv(isd:ied,JsdB:JedB,nz)) ; CS%diffv(:,:,:) = 0.0 + ALLOC_(CS%CAu(IsdB:IedB,jsd:jed,nz)) ; CS%CAu(:,:,:) = 0.0 + ALLOC_(CS%CAv(isd:ied,JsdB:JedB,nz)) ; CS%CAv(:,:,:) = 0.0 + ALLOC_(CS%CAu_pred(IsdB:IedB,jsd:jed,nz)) ; CS%CAu_pred(:,:,:) = 0.0 + ALLOC_(CS%CAv_pred(isd:ied,JsdB:JedB,nz)) ; CS%CAv_pred(:,:,:) = 0.0 + ALLOC_(CS%PFu(IsdB:IedB,jsd:jed,nz)) ; CS%PFu(:,:,:) = 0.0 + ALLOC_(CS%PFv(isd:ied,JsdB:JedB,nz)) ; CS%PFv(:,:,:) = 0.0 + ALLOC_(CS%du_av_inst(IsdB:IedB,jsd:jed)) ; CS%du_av_inst(:,:) = 0.0 + ALLOC_(CS%dv_av_inst(isd:ied,JsdB:JedB)) ; CS%dv_av_inst(:,:) = 0.0 + + ALLOC_(CS%eta(isd:ied,jsd:jed)) ; CS%eta(:,:) = 0.0 + + thickness_units = get_thickness_units(GV) + flux_units = get_flux_units(GV) + + if (GV%Boussinesq) then + call register_restart_field(CS%eta, "sfc", .false., restart_CS, & + longname="Free surface Height", units=thickness_units, conversion=GV%H_to_mks) + else + call register_restart_field(CS%eta, "p_bot", .false., restart_CS, & + longname="Bottom Pressure", units=thickness_units, conversion=GV%H_to_mks) + endif + + ! These are needed to reconstruct the phase in the barotorpic solution. + vd(1) = var_desc("du_avg_inst", "m s-1", & + "Barotropic velocity increment between instantaneous and filtered zonal velocities", 'u', '1') + vd(2) = var_desc("dv_avg_inst", "m s-1", & + "Barotropic velocity increment between instantaneous and filtered meridional velocities", 'v', '1') + call register_restart_pair(CS%du_av_inst, CS%dv_av_inst, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T_to_m_s) + + call register_barotropic_restarts(HI, GV, US, param_file, CS%barotropic_CSp, restart_CS) + +end subroutine register_restarts_dyn_split_RK2b + +!> This subroutine does remapping for the auxiliary restart variables that are used +!! with the split RK2 time stepping scheme. +subroutine remap_dyn_split_RK2b_aux_vars(G, GV, CS, h_old_u, h_old_v, h_new_u, h_new_v, ALE_CSp) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old_u !< Source grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_old_v !< Source grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new_u !< Destination grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_new_v !< Destination grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure to use when remapping + + return + +end subroutine remap_dyn_split_RK2b_aux_vars + +!> This subroutine initializes all of the variables that are used by this +!! dynamic core, including diagnostics and the cpu clocks. +subroutine initialize_dyn_split_RK2b(u, v, h, uh, vh, eta, Time, G, GV, US, param_file, & + diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & + VarMix, MEKE, thickness_diffuse_CSp, & + OBC, update_OBC_CSp, ALE_CSp, set_visc, & + visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< merid velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + target, intent(inout) :: uh !< zonal volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(inout) :: vh !< merid volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: eta !< free surface height or column mass [H ~> m or kg m-2] + type(time_type), target, intent(in) :: Time !< current model time + type(param_file_type), intent(in) :: param_file !< parameter file for parsing + type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + real, intent(in) :: dt !< time step [T ~> s] + type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for + !! budget analysis + type(cont_diag_ptrs), target, intent(inout) :: Cont_diag !< points to terms in continuity equation + type(ocean_internal_state), intent(inout) :: MIS !< "MOM6 internal state" used to pass + !! diagnostic pointers + type(VarMix_CS), intent(inout) :: VarMix !< points to spatially variable viscosities + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(thickness_diffuse_CS), intent(inout) :: thickness_diffuse_CSp !< Pointer to the control structure + !! used for the isopycnal height diffusive transport. + type(ocean_OBC_type), pointer :: OBC !< points to OBC related fields + type(update_OBC_CS), pointer :: update_OBC_CSp !< points to OBC update related fields + type(ALE_CS), pointer :: ALE_CSp !< points to ALE control structure + type(set_visc_CS), target, intent(in) :: set_visc !< set_visc control structure + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, bottom drag, and related + type(directories), intent(in) :: dirs !< contains directory paths + integer, target, intent(inout) :: ntrunc !< A target for the variable that records + !! the number of times the velocity is + !! truncated (this should be 0). + logical, intent(out) :: calc_dtbt !< If true, recalculate the barotropic time step + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + integer, intent(out) :: cont_stencil !< The stencil for thickness + !! from the continuity solver. + + ! local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tmp ! A temporary copy of the layer thicknesses [H ~> m or kg m-2] + character(len=40) :: mdl = "MOM_dynamics_split_RK2b" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=48) :: thickness_units, flux_units, eta_rest_name + logical :: debug_truncations + logical :: read_uv, read_h2 + + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(CS)) call MOM_error(FATAL, & + "initialize_dyn_split_RK2b called with an unassociated control structure.") + if (CS%module_is_initialized) then + call MOM_error(WARNING, "initialize_dyn_split_RK2b called with a control "// & + "structure that has already been initialized.") + return + endif + CS%module_is_initialized = .true. + + CS%diag => diag + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "TIDES", CS%use_tides, & + "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) + call get_param(param_file, mdl, "BE", CS%be, & + "If SPLIT is true, BE determines the relative weighting "//& + "of a 2nd-order Runga-Kutta baroclinic time stepping "//& + "scheme (0.5) and a backward Euler scheme (1) that is "//& + "used for the Coriolis and inertial terms. BE may be "//& + "from 0.5 to 1, but instability may occur near 0.5. "//& + "BE is also applicable if SPLIT is false and USE_RK2 "//& + "is true.", units="nondim", default=0.6) + call get_param(param_file, mdl, "BEGW", CS%begw, & + "If SPLIT is true, BEGW is a number from 0 to 1 that "//& + "controls the extent to which the treatment of gravity "//& + "waves is forward-backward (0) or simulated backward "//& + "Euler (1). 0 is almost always used. "//& + "If SPLIT is false and USE_RK2 is true, BEGW can be "//& + "between 0 and 0.5 to damp gravity waves.", & + units="nondim", default=0.0) + + call get_param(param_file, mdl, "SPLIT_BOTTOM_STRESS", CS%split_bottom_stress, & + "If true, provide the bottom stress calculated by the "//& + "vertical viscosity to the barotropic solver.", default=.false.) + ! call get_param(param_file, mdl, "FPMIX", CS%fpmix, & + ! "If true, apply profiles of momentum flux magnitude and direction.", & + ! default=.false.) + CS%fpmix = .false. + call get_param(param_file, mdl, "REMAP_AUXILIARY_VARS", CS%remap_aux, & + "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& + "variables that are needed to reproduce across restarts, similarly to "//& + "what is already being done with the primary state variables. "//& + "The default should be changed to true.", default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) + call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & + default=.false.) + + allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) + + ALLOC_(CS%uhbt(IsdB:IedB,jsd:jed)) ; CS%uhbt(:,:) = 0.0 + ALLOC_(CS%vhbt(isd:ied,JsdB:JedB)) ; CS%vhbt(:,:) = 0.0 + ALLOC_(CS%visc_rem_u(IsdB:IedB,jsd:jed,nz)) ; CS%visc_rem_u(:,:,:) = 0.0 + ALLOC_(CS%visc_rem_v(isd:ied,JsdB:JedB,nz)) ; CS%visc_rem_v(:,:,:) = 0.0 + ALLOC_(CS%eta_PF(isd:ied,jsd:jed)) ; CS%eta_PF(:,:) = 0.0 + ALLOC_(CS%pbce(isd:ied,jsd:jed,nz)) ; CS%pbce(:,:,:) = 0.0 + + ALLOC_(CS%u_accel_bt(IsdB:IedB,jsd:jed,nz)) ; CS%u_accel_bt(:,:,:) = 0.0 + ALLOC_(CS%v_accel_bt(isd:ied,JsdB:JedB,nz)) ; CS%v_accel_bt(:,:,:) = 0.0 + ALLOC_(CS%PFu_Stokes(IsdB:IedB,jsd:jed,nz)) ; CS%PFu_Stokes(:,:,:) = 0.0 + ALLOC_(CS%PFv_Stokes(isd:ied,JsdB:JedB,nz)) ; CS%PFv_Stokes(:,:,:) = 0.0 + + MIS%diffu => CS%diffu + MIS%diffv => CS%diffv + MIS%PFu => CS%PFu + MIS%PFv => CS%PFv + MIS%CAu => CS%CAu + MIS%CAv => CS%CAv + MIS%pbce => CS%pbce + MIS%u_accel_bt => CS%u_accel_bt + MIS%v_accel_bt => CS%v_accel_bt + + CS%ADp => Accel_diag + CS%CDp => Cont_diag + Accel_diag%diffu => CS%diffu + Accel_diag%diffv => CS%diffv + Accel_diag%PFu => CS%PFu + Accel_diag%PFv => CS%PFv + Accel_diag%CAu => CS%CAu + Accel_diag%CAv => CS%CAv + Accel_diag%u_accel_bt => CS%u_accel_bt + Accel_diag%v_accel_bt => CS%v_accel_bt + + allocate(CS%AD_pred) + CS%AD_pred%diffu => CS%diffu + CS%AD_pred%diffv => CS%diffv + CS%AD_pred%PFu => CS%PFu + CS%AD_pred%PFv => CS%PFv + CS%AD_pred%CAu => CS%CAu_pred + CS%AD_pred%CAv => CS%CAv_pred + CS%AD_pred%u_accel_bt => CS%u_accel_bt + CS%AD_pred%v_accel_bt => CS%v_accel_bt + +! Accel_diag%pbce => CS%pbce +! Accel_diag%u_accel_bt => CS%u_accel_bt ; Accel_diag%v_accel_bt => CS%v_accel_bt +! Accel_diag%u_av => CS%u_av ; Accel_diag%v_av => CS%v_av + + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + cont_stencil = continuity_stencil(CS%continuity_CSp) + call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) + if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & + CS%SAL_CSp, CS%tides_CSp) + call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) + call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & + ntrunc, CS%vertvisc_CSp) + CS%set_visc_CSp => set_visc + call updateCFLtruncationValue(Time, CS%vertvisc_CSp, US, & + activate=is_new_run(restart_CS) ) + + if (associated(ALE_CSp)) CS%ALE_CSp => ALE_CSp + if (associated(OBC)) then + CS%OBC => OBC + if (OBC%ramp) call update_OBC_ramp(Time, CS%OBC, US, & + activate=is_new_run(restart_CS) ) + endif + if (associated(update_OBC_CSp)) CS%update_OBC_CSp => update_OBC_CSp + + eta_rest_name = "sfc" ; if (.not.GV%Boussinesq) eta_rest_name = "p_bot" + if (.not. query_initialized(CS%eta, trim(eta_rest_name), restart_CS)) then + ! Estimate eta based on the layer thicknesses - h. With the Boussinesq + ! approximation, eta is the free surface height anomaly, while without it + ! eta is the mass of ocean per unit area. eta always has the same + ! dimensions as h, either m or kg m-3. + ! CS%eta(:,:) = 0.0 already from initialization. + if (GV%Boussinesq) then + do j=js,je ; do i=is,ie ; CS%eta(i,j) = -GV%Z_to_H * G%bathyT(i,j) ; enddo ; enddo + endif + do k=1,nz ; do j=js,je ; do i=is,ie + CS%eta(i,j) = CS%eta(i,j) + h(i,j,k) + enddo ; enddo ; enddo + call set_initialized(CS%eta, trim(eta_rest_name), restart_CS) + endif + ! Copy eta into an output array. + do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo + + call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & + CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & + CS%SAL_CSp) + + flux_units = get_flux_units(GV) + thickness_units = get_thickness_units(GV) + CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & + 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) + CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & + 'Meridional Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) + + CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & + 'Zonal Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & + 'Meridional Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_PFu = register_diag_field('ocean_model', 'PFu', diag%axesCuL, Time, & + 'Zonal Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & + 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_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.) + 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', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_PFv = register_diag_field('ocean_model', 'hf_PFv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Pressure Force Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + !CS%id_hf_CAu = register_diag_field('ocean_model', 'hf_CAu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_CAv = register_diag_field('ocean_model', 'hf_CAv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_hf_PFu_2d = register_diag_field('ocean_model', 'hf_PFu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Pressure Force Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_PFv_2d = register_diag_field('ocean_model', 'hf_PFv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Pressure Force Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_h_PFu = register_diag_field('ocean_model', 'h_PFu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_PFv = register_diag_field('ocean_model', 'h_PFv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_intz_PFu_2d = register_diag_field('ocean_model', 'intz_PFu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_PFv_2d = register_diag_field('ocean_model', 'intz_PFv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_hf_CAu_2d = register_diag_field('ocean_model', 'hf_CAu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_CAv_2d = register_diag_field('ocean_model', 'hf_CAv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_h_CAu = register_diag_field('ocean_model', 'h_CAu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_CAv = register_diag_field('ocean_model', 'h_CAv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_intz_CAu_2d = register_diag_field('ocean_model', 'intz_CAu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_CAv_2d = register_diag_field('ocean_model', 'intz_CAv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_uav = register_diag_field('ocean_model', 'uav', diag%axesCuL, Time, & + 'Barotropic-step Averaged Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vav = register_diag_field('ocean_model', 'vav', diag%axesCvL, Time, & + 'Barotropic-step Averaged Meridional Velocity', 'm s-1', conversion=US%L_T_to_m_s) + + CS%id_u_BT_accel = register_diag_field('ocean_model', 'u_BT_accel', diag%axesCuL, Time, & + 'Barotropic Anomaly Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_v_BT_accel = register_diag_field('ocean_model', 'v_BT_accel', diag%axesCvL, Time, & + 'Barotropic Anomaly Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + + !CS%id_hf_u_BT_accel = register_diag_field('ocean_model', 'hf_u_BT_accel', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_v_BT_accel = register_diag_field('ocean_model', 'hf_v_BT_accel', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_hf_u_BT_accel_2d = register_diag_field('ocean_model', 'hf_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_v_BT_accel_2d = register_diag_field('ocean_model', 'hf_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_h_u_BT_accel = register_diag_field('ocean_model', 'h_u_BT_accel', diag%axesCuL, Time, & + 'Thickness Multiplied Barotropic Anomaly Zonal Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_v_BT_accel = register_diag_field('ocean_model', 'h_v_BT_accel', diag%axesCvL, Time, & + 'Thickness Multiplied Barotropic Anomaly Meridional Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_intz_u_BT_accel_2d = register_diag_field('ocean_model', 'intz_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-integral of Barotropic Anomaly Zonal Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_v_BT_accel_2d = register_diag_field('ocean_model', 'intz_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-integral of Barotropic Anomaly Meridional Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_PFu_visc_rem = register_diag_field('ocean_model', 'PFu_visc_rem', diag%axesCuL, Time, & + 'Zonal Pressure Force Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_PFu_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + CS%id_PFv_visc_rem = register_diag_field('ocean_model', 'PFv_visc_rem', diag%axesCvL, Time, & + 'Meridional Pressure Force Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_PFv_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + + CS%id_CAu_visc_rem = register_diag_field('ocean_model', 'CAu_visc_rem', diag%axesCuL, Time, & + 'Zonal Coriolis and Advective Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_CAu_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + CS%id_CAv_visc_rem = register_diag_field('ocean_model', 'CAv_visc_rem', diag%axesCvL, Time, & + 'Meridional Coriolis and Advective Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_CAv_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + + CS%id_u_BT_accel_visc_rem = register_diag_field('ocean_model', 'u_BT_accel_visc_rem', diag%axesCuL, Time, & + 'Barotropic Anomaly Zonal Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_u_BT_accel_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + CS%id_v_BT_accel_visc_rem = register_diag_field('ocean_model', 'v_BT_accel_visc_rem', diag%axesCvL, Time, & + 'Barotropic Anomaly Meridional Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_v_BT_accel_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + + id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) + id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) + id_clock_pres = cpu_clock_id('(Ocean pressure force)', grain=CLOCK_MODULE) + id_clock_vertvisc = cpu_clock_id('(Ocean vertical viscosity)', grain=CLOCK_MODULE) + id_clock_horvisc = cpu_clock_id('(Ocean horizontal viscosity)', grain=CLOCK_MODULE) + id_clock_mom_update = cpu_clock_id('(Ocean momentum increments)', grain=CLOCK_MODULE) + id_clock_pass = cpu_clock_id('(Ocean message passing)', grain=CLOCK_MODULE) + id_clock_btcalc = cpu_clock_id('(Ocean barotropic mode calc)', grain=CLOCK_MODULE) + id_clock_btstep = cpu_clock_id('(Ocean barotropic mode stepping)', grain=CLOCK_MODULE) + id_clock_btforce = cpu_clock_id('(Ocean barotropic forcing calc)', grain=CLOCK_MODULE) + +end subroutine initialize_dyn_split_RK2b + + +!> Close the dyn_split_RK2b module +subroutine end_dyn_split_RK2b(CS) + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + + call barotropic_end(CS%barotropic_CSp) + + call vertvisc_end(CS%vertvisc_CSp) + deallocate(CS%vertvisc_CSp) + + call hor_visc_end(CS%hor_visc) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) + call CoriolisAdv_end(CS%CoriolisAdv) + + DEALLOC_(CS%diffu) ; DEALLOC_(CS%diffv) + DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) + DEALLOC_(CS%CAu_pred) ; DEALLOC_(CS%CAv_pred) + DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) + + if (associated(CS%taux_bot)) deallocate(CS%taux_bot) + if (associated(CS%tauy_bot)) deallocate(CS%tauy_bot) + DEALLOC_(CS%uhbt) ; DEALLOC_(CS%vhbt) + DEALLOC_(CS%du_av_inst) ; DEALLOC_(CS%dv_av_inst) + DEALLOC_(CS%u_accel_bt) ; DEALLOC_(CS%v_accel_bt) + DEALLOC_(CS%visc_rem_u) ; DEALLOC_(CS%visc_rem_v) + + DEALLOC_(CS%eta) ; DEALLOC_(CS%eta_PF) ; DEALLOC_(CS%pbce) + + call dealloc_BT_cont_type(CS%BT_cont) + deallocate(CS%AD_pred) + + deallocate(CS) +end subroutine end_dyn_split_RK2b + + +!> \namespace mom_dynamics_split_rk2b +!! +!! This file time steps the adiabatic dynamic core by splitting +!! between baroclinic and barotropic modes. It uses a pseudo-second order +!! Runge-Kutta time stepping scheme for the baroclinic momentum +!! equation and a forward-backward coupling between the baroclinic +!! momentum and continuity equations. This split time-stepping +!! scheme is described in detail in Hallberg (JCP, 1997). Additional +!! issues related to exact tracer conservation and how to +!! ensure consistency between the barotropic and layered estimates +!! of the free surface height are described in Hallberg and +!! Adcroft (Ocean Modelling, 2009). This was the time stepping code +!! that is used for most GOLD applications, including GFDL's ESM2G +!! Earth system model, and all of the examples provided with the +!! MOM code (although several of these solutions are routinely +!! verified by comparison with the slower unsplit schemes). +!! +!! The subroutine step_MOM_dyn_split_RK2b actually does the time +!! stepping, while register_restarts_dyn_split_RK2b sets the fields +!! that are found in a full restart file with this scheme, and +!! initialize_dyn_split_RK2b initializes the cpu clocks that are +!! used in this module. For largely historical reasons, this module +!! does not have its own control structure, but shares the same +!! control structure with MOM.F90 and the other MOM_dynamics_... +!! modules. + +end module MOM_dynamics_split_RK2b diff --git a/core/MOM_dynamics_unsplit.F90 b/core/MOM_dynamics_unsplit.F90 new file mode 100644 index 0000000000..f9e4aa0efe --- /dev/null +++ b/core/MOM_dynamics_unsplit.F90 @@ -0,0 +1,771 @@ +!> Time steps the ocean dynamics with an unsplit quasi 3rd order scheme +module MOM_dynamics_unsplit + +! This file is part of MOM6. See LICENSE.md for the license. + +!********+*********+*********+*********+*********+*********+*********+** +!* * +!* By Robert Hallberg, 1993-2012 * +!* * +!* This file contains code that does the time-stepping of the * +!* adiabatic dynamic core, in this case with an unsplit third-order * +!* Runge-Kutta time stepping scheme for the momentum and a forward- * +!* backward coupling between the momentum and continuity equations. * +!* This was the orignal unsplit time stepping scheme used in early * +!* versions of HIM and its precursor. While it is very simple and * +!* accurate, it is much less efficient that the split time stepping * +!* scheme for realistic oceanographic applications. It has been * +!* retained for all of these years primarily to verify that the split * +!* scheme is giving the right answers, and to debug the failings of * +!* the split scheme when it is not. The split time stepping scheme * +!* is now sufficiently robust that it should be first choice for * +!* almost any conceivable application, except perhaps from cases * +!* with just a few layers for which the exact timing of the high- * +!* frequency barotropic gravity waves is of paramount importance. * +!* This scheme is slightly more efficient than the other unsplit * +!* scheme that can be found in MOM_dynamics_unsplit_RK2.F90. * +!* * +!* The subroutine step_MOM_dyn_unsplit actually does the time * +!* stepping, while register_restarts_dyn_unsplit sets the fields * +!* that are found in a full restart file with this scheme, and * +!* initialize_dyn_unsplit initializes the cpu clocks that are * * +!* used in this module. For largely historical reasons, this module * +!* does not have its own control structure, but shares the same * +!* control structure with MOM.F90 and the other MOM_dynamics_... * +!* modules. * +!* * +!* Macros written all in capital letters are defined in MOM_memory.h. * +!* * +!* A small fragment of the grid is shown below: * +!* * +!* j+1 x ^ x ^ x At x: q, CoriolisBu * +!* j+1 > o > o > At ^: v, PFv, CAv, vh, diffv, tauy, vbt, vhtr * +!* j x ^ x ^ x At >: u, PFu, CAu, uh, diffu, taux, ubt, uhtr * +!* j > o > o > At o: h, bathyT, eta, T, S, tr * +!* j-1 x ^ x ^ x * +!* i-1 i i+1 * +!* i i+1 * +!* * +!* The boundaries always run through q grid points (x). * +!* * +!********+*********+*********+*********+*********+*********+*********+** + +use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_type +use MOM_variables, only : accel_diag_ptrs, ocean_internal_state, cont_diag_ptrs +use MOM_forcing_type, only : mech_forcing +use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum, MOM_accel_chksum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : diag_mediator_init, enable_averages +use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr +use MOM_diag_mediator, only : register_diag_field, register_static_field +use MOM_diag_mediator, only : set_diag_mediator_grid, diag_ctrl, diag_update_remap_grids +use MOM_domains, only : pass_var, pass_var_start, pass_var_complete +use MOM_domains, only : pass_vector, pass_vector_start, pass_vector_complete +use MOM_domains, only : To_South, To_West, To_All, CGRID_NE, SCALAR_PAIR +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_time_manager, only : time_type, real_to_time, operator(+) +use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) + +use MOM_ALE, only : ALE_CS +use MOM_barotropic, only : barotropic_CS +use MOM_boundary_update, only : update_OBC_data, update_OBC_CS +use MOM_continuity, only : continuity, continuity_init, continuity_CS, continuity_stencil +use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS +use MOM_debugging, only : check_redundant +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_hor_visc, only : horizontal_viscosity, hor_visc_init, hor_visc_CS +use MOM_interface_heights, only : find_eta, thickness_to_dz +use MOM_lateral_mixing_coeffs, only : VarMix_CS +use MOM_MEKE_types, only : MEKE_type +use MOM_open_boundary, only : ocean_OBC_type +use MOM_open_boundary, only : radiation_open_bdry_conds +use MOM_open_boundary, only : open_boundary_zero_normal_flow +use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS +use MOM_set_visc, only : set_viscous_ML, set_visc_CS +use MOM_self_attr_load, only : SAL_init, SAL_end, SAL_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end, tidal_forcing_CS +use MOM_unit_scaling, only : unit_scale_type +use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_init, vertvisc_CS +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units +use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units +use MOM_wave_interface, only: wave_parameters_CS + +implicit none ; private + +#include + +!> MOM_dynamics_unsplit module control structure +type, public :: MOM_dyn_unsplit_CS ; private + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & + CAu, & !< CAu = f*v - u.grad(u) [L T-2 ~> m s-2]. + PFu, & !< PFu = -dM/dx [L T-2 ~> m s-2]. + diffu !< Zonal acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2]. + + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & + CAv, & !< CAv = -f*u - u.grad(v) [L T-2 ~> m s-2]. + PFv, & !< PFv = -dM/dy [L T-2 ~> m s-2]. + diffv !< Meridional acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2]. + + real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + + logical :: dt_visc_bug !< If false, use the correct timestep in viscous terms applied in the + !! first predictor step and in the calculation of the turbulent mixed + !! layer properties for viscosity. If this is true, an older incorrect + !! setting is used. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. + + logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + + !>@{ Diagnostic IDs + integer :: id_uh = -1, id_vh = -1 + integer :: id_ueffA = -1, id_veffA = -1 + integer :: id_PFu = -1, id_PFv = -1, id_CAu = -1, id_CAv = -1 + !>@} + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(accel_diag_ptrs), pointer :: ADp => NULL() !< A structure pointing to the + !! accelerations in the momentum equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + type(cont_diag_ptrs), pointer :: CDp => NULL() !< A structure with pointers to + !! various terms in the continuity equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + + ! The remainder of the structure points to child subroutines' control structures. + !> A pointer to the horizontal viscosity control structure + type(hor_visc_CS) :: hor_visc + !> A pointer to the continuity control structure + type(continuity_CS) :: continuity_CSp + !> A pointer to the CoriolisAdv control structure + type(CoriolisAdv_CS) :: CoriolisAdv + !> A pointer to the PressureForce control structure + type(PressureForce_CS) :: PressureForce_CSp + !> A pointer to the vertvisc control structure + type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() + !> A pointer to the set_visc control structure + type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp + !> A pointer to the tidal forcing control structure + type(tidal_forcing_CS) :: tides_CSp + !> A pointer to the ALE control structure. + type(ALE_CS), pointer :: ALE_CSp => NULL() + + type(ocean_OBC_type), pointer :: OBC => NULL() !< A pointer to an open boundary + ! condition type that specifies whether, where, and what open boundary + ! conditions are used. If no open BCs are used, this pointer stays + ! nullified. Flather OBCs use open boundary_CS as well. + !> A pointer to the update_OBC control structure + type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() + +end type MOM_dyn_unsplit_CS + +public step_MOM_dyn_unsplit, register_restarts_dyn_unsplit +public initialize_dyn_unsplit, end_dyn_unsplit + +!>@{ CPU time clock IDs +integer :: id_clock_Cor, id_clock_pres, id_clock_vertvisc +integer :: id_clock_continuity, id_clock_horvisc, id_clock_mom_update +integer :: id_clock_pass, id_clock_pass_init +!>@} + +contains + +! ============================================================================= + +!> Step the MOM6 dynamics using an unsplit mixed 2nd order (for continuity) and +!! 3rd order (for the inviscid momentum equations) order scheme +subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & + VarMix, MEKE, pbv, Waves) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical + !! viscosities, bottom drag viscosities, and related fields. + type(time_type), intent(in) :: Time_local !< The model time at the end + !! of the time step. + real, intent(in) :: dt !< The dynamics time step [T ~> s]. + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the surface + !! pressure at the start of this dynamic step [R L2 T-2 ~> Pa]. + real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to the surface + !! pressure at the end of this dynamic step [R L2 T-2 ~> Pa]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uh !< The zonal volume or mass transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vh !< The meridional volume or mass + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< The accumulated zonal volume or mass + !! transport since the last tracer advection [H L2 ~> m3 or kg]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< The accumulated meridional volume or mass + !! transport since the last tracer advection [H L2 ~> m3 or kg]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< The time-mean free surface height or + !! column mass [H ~> m or kg m-2]. + type(MOM_dyn_unsplit_CS), pointer :: CS !< The control structure set up by + !! initialize_dyn_unsplit. + type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(wave_parameters_CS), optional, pointer :: Waves !< A pointer to a structure containing + !! fields related to the surface wave conditions + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av, hp ! Predicted or averaged layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up, upp ! Predicted zonal velocities [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp, vpp ! Predicted meridional velocities [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: veffA ! Effective Area of V-Faces [H L ~> m2] + real, dimension(:,:), pointer :: p_surf => NULL() ! A pointer to the surface pressure [R L2 T-2 ~> Pa] + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. + real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s]. + logical :: dyn_p_surf + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + 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 + dt_pred = dt / 3.0 + + h_av(:,:,:) = 0; hp(:,:,:) = 0 + up(:,:,:) = 0; upp(:,:,:) = 0 + vp(:,:,:) = 0; vpp(:,:,:) = 0 + + dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) + if (dyn_p_surf) then + call safe_alloc_ptr(p_surf,G%isd,G%ied,G%jsd,G%jed) ; p_surf(:,:) = 0.0 + else + p_surf => forces%p_surf + endif + +! Matsuno's third order accurate three step scheme is used to step +! all of the fields except h. h is stepped separately. + + if (CS%debug) then + call MOM_state_chksum("Start First Predictor ", u, v, h, uh, vh, G, GV, US) + endif + +! diffu = horizontal viscosity terms (u,h) + call enable_averages(dt, Time_local, CS%diag) + call cpu_clock_begin(id_clock_horvisc) + call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc) + call cpu_clock_end(id_clock_horvisc) + call disable_averaging(CS%diag) + +! uh = u*h +! hp = h + dt/2 div . uh + call cpu_clock_begin(id_clock_continuity) + call continuity(u, v, h, hp, uh, vh, dt*0.5, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call cpu_clock_end(id_clock_continuity) + call pass_var(hp, G%Domain, clock=id_clock_pass) + call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) + + call enable_averages(0.5*dt, Time_local-real_to_time(0.5*US%T_to_s*dt), CS%diag) +! Here the first half of the thickness fluxes are offered for averaging. + if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) + if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) + call disable_averaging(CS%diag) + +! h_av = (h + hp)/2 +! u = u + dt diffu + call cpu_clock_begin(id_clock_mom_update) + do k=1,nz + do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = (h(i,j,k) + hp(i,j,k)) * 0.5 + enddo ; enddo + do j=js,je ; do I=Isq,Ieq + u(I,j,k) = u(I,j,k) + dt * CS%diffu(I,j,k) * G%mask2dCu(I,j) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v(i,J,k) = v(i,J,k) + dt * CS%diffv(i,J,k) * G%mask2dCv(i,J) + enddo ; enddo + do j=js-2,je+2 ; do I=Isq-2,Ieq+2 + uhtr(i,j,k) = uhtr(i,j,k) + 0.5*dt*uh(i,j,k) + enddo ; enddo + do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 + vhtr(i,j,k) = vhtr(i,j,k) + 0.5*dt*vh(i,j,k) + enddo ; enddo + enddo + call cpu_clock_end(id_clock_mom_update) + call pass_vector(u, v, G%Domain, clock=id_clock_pass) + +! CAu = -(f+zeta)/h_av vh + d/dx KE + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(u, v, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & + G, GV, US, CS%CoriolisAdv, pbv) + call cpu_clock_end(id_clock_Cor) + +! PFu = d/dx M(h_av,T,S) + call cpu_clock_begin(id_clock_pres) + if (dyn_p_surf) then ; do j=js-2,je+2 ; do i=is-2,ie+2 + p_surf(i,j) = 0.75*p_surf_begin(i,j) + 0.25*p_surf_end(i,j) + enddo ; enddo ; endif + call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & + CS%PressureForce_CSp, CS%ALE_CSp, p_surf) + call cpu_clock_end(id_clock_pres) + + if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) + endif ; endif + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) + endif + +! up = u + dt_pred * (PFu + CAu) + call cpu_clock_begin(id_clock_mom_update) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + up(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt_pred * (CS%PFu(I,j,k) + CS%CAu(I,j,k))) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + vp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt_pred * (CS%PFv(i,J,k) + CS%CAv(i,J,k))) + enddo ; enddo ; enddo + call cpu_clock_end(id_clock_mom_update) + + if (CS%debug) then + call MOM_state_chksum("Predictor 1", up, vp, h_av, uh, vh, G, GV, US) + call MOM_accel_chksum("Predictor 1 accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US) + endif + + ! up <- up + dt/2 d/dz visc d/dz up + call cpu_clock_begin(id_clock_vertvisc) + call enable_averages(dt, Time_local, CS%diag) + dt_visc = dt ; if (CS%dt_visc_bug) dt_visc = 0.5*dt + call set_viscous_ML(u, v, h_av, tv, forces, visc, dt_visc, G, GV, US, CS%set_visc_CSp) + call disable_averaging(CS%diag) + + dt_visc = dt_pred ; if (CS%dt_visc_bug) dt_visc = 0.5*dt + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt_visc, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc(up, vp, h_av, forces, visc, dt_visc, CS%OBC, CS%ADp, CS%CDp, & + G, GV, US, CS%vertvisc_CSp, Waves=Waves) + call cpu_clock_end(id_clock_vertvisc) + call pass_vector(up, vp, G%Domain, clock=id_clock_pass) + +! uh = up * hp +! h_av = hp + dt/2 div . uh + call cpu_clock_begin(id_clock_continuity) + call continuity(up, vp, hp, h_av, uh, vh, (0.5*dt), G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call cpu_clock_end(id_clock_continuity) + call pass_var(h_av, G%Domain, clock=id_clock_pass) + call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) + +! h_av <- (hp + h_av)/2 + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = (hp(i,j,k) + h_av(i,j,k)) * 0.5 + enddo ; enddo ; enddo + +! CAu = -(f+zeta(up))/h_av vh + d/dx KE(up) + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(up, vp, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & + G, GV, US, CS%CoriolisAdv, pbv) + call cpu_clock_end(id_clock_Cor) + +! PFu = d/dx M(h_av,T,S) + call cpu_clock_begin(id_clock_pres) + if (dyn_p_surf) then ; do j=js-2,je+2 ; do i=is-2,ie+2 + p_surf(i,j) = 0.25*p_surf_begin(i,j) + 0.75*p_surf_end(i,j) + enddo ; enddo ; endif + call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & + CS%PressureForce_CSp, CS%ALE_CSp, p_surf) + call cpu_clock_end(id_clock_pres) + + if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) + endif ; endif + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) + endif + +! upp = u + dt/2 * ( PFu + CAu ) + call cpu_clock_begin(id_clock_mom_update) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + upp(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * 0.5 * (CS%PFu(I,j,k) + CS%CAu(I,j,k))) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + vpp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * 0.5 * (CS%PFv(i,J,k) + CS%CAv(i,J,k))) + enddo ; enddo ; enddo + call cpu_clock_end(id_clock_mom_update) + + if (CS%debug) then + call MOM_state_chksum("Predictor 2", upp, vpp, h_av, uh, vh, G, GV, US) + call MOM_accel_chksum("Predictor 2 accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US) + endif + +! upp <- upp + dt/2 d/dz visc d/dz upp + call cpu_clock_begin(id_clock_vertvisc) + call thickness_to_dz(hp, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(upp, vpp, hp, dz, forces, visc, tv, dt*0.5, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc(upp, vpp, hp, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & + G, GV, US, CS%vertvisc_CSp, Waves=Waves) + call cpu_clock_end(id_clock_vertvisc) + call pass_vector(upp, vpp, G%Domain, clock=id_clock_pass) + +! uh = upp * hp +! h = hp + dt/2 div . uh + call cpu_clock_begin(id_clock_continuity) + call continuity(upp, vpp, hp, h, uh, vh, (dt*0.5), G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call cpu_clock_end(id_clock_continuity) + call pass_var(h, G%Domain, clock=id_clock_pass) + call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + call enable_averages(0.5*dt, Time_local, CS%diag) +! Here the second half of the thickness fluxes are offered for averaging. + if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) + if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) + call disable_averaging(CS%diag) + call enable_averages(dt, Time_local, CS%diag) + + ! Calculate effective areas and post data + if (CS%id_ueffA > 0) then + ueffA(:,:,:) = 0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(up(I,j,k)) > 0.) ueffA(I,j,k) = uh(I,j,k)/up(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_ueffA, ueffA, CS%diag) + endif + + if (CS%id_veffA > 0) then + veffA(:,:,:) = 0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(vp(i,J,k)) > 0.) veffA(i,J,k) = vh(i,J,k)/vp(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_veffA, veffA, CS%diag) + endif + +! h_av = (h + hp)/2 + do k=1,nz + do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) + enddo ; enddo + do j=js-2,je+2 ; do I=Isq-2,Ieq+2 + uhtr(i,j,k) = uhtr(i,j,k) + 0.5*dt*uh(i,j,k) + enddo ; enddo + do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 + vhtr(i,j,k) = vhtr(i,j,k) + 0.5*dt*vh(i,j,k) + enddo ; enddo + enddo + +! CAu = -(f+zeta(upp))/h_av vh + d/dx KE(upp) + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(upp, vpp, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & + G, GV, US, CS%CoriolisAdv, pbv) + call cpu_clock_end(id_clock_Cor) + +! PFu = d/dx M(h_av,T,S) + call cpu_clock_begin(id_clock_pres) + call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & + CS%PressureForce_CSp, CS%ALE_CSp, p_surf) + call cpu_clock_end(id_clock_pres) + + if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) + endif ; endif + +! u = u + dt * ( PFu + CAu ) + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) + endif + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + u(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * (CS%PFu(I,j,k) + CS%CAu(I,j,k))) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + v(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * (CS%PFv(i,J,k) + CS%CAv(i,J,k))) + enddo ; enddo ; enddo + +! u <- u + dt d/dz visc d/dz u + call cpu_clock_begin(id_clock_vertvisc) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(u, v, h_av, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc(u, v, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & + G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, Waves=Waves) + call cpu_clock_end(id_clock_vertvisc) + call pass_vector(u, v, G%Domain, clock=id_clock_pass) + + if (CS%debug) then + call MOM_state_chksum("Corrector", u, v, h, uh, vh, G, GV, US) + call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US) + endif + + if (GV%Boussinesq) then + do j=js,je ; do i=is,ie ; eta_av(i,j) = -GV%Z_to_H*G%bathyT(i,j) ; enddo ; enddo + else + do j=js,je ; do i=is,ie ; eta_av(i,j) = 0.0 ; enddo ; enddo + endif + do k=1,nz ; do j=js,je ; do i=is,ie + eta_av(i,j) = eta_av(i,j) + h_av(i,j,k) + enddo ; enddo ; enddo + + if (dyn_p_surf) deallocate(p_surf) + +! Here various terms used in to update the momentum equations are +! offered for averaging. + if (CS%id_PFu > 0) call post_data(CS%id_PFu, CS%PFu, CS%diag) + if (CS%id_PFv > 0) call post_data(CS%id_PFv, CS%PFv, CS%diag) + if (CS%id_CAu > 0) call post_data(CS%id_CAu, CS%CAu, CS%diag) + if (CS%id_CAv > 0) call post_data(CS%id_CAv, CS%CAv, CS%diag) + +end subroutine step_MOM_dyn_unsplit + +! ============================================================================= + +!> Allocate the control structure for this module, allocates memory in it, and registers +!! any auxiliary restart variables that are specific to the unsplit time stepping scheme. +!! +!! All variables registered here should have the ability to be recreated if they are not present +!! in a restart file. +subroutine register_restarts_dyn_unsplit(HI, GV, param_file, CS) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure to parse for + !! run-time parameters. + type(MOM_dyn_unsplit_CS), pointer :: CS !< The control structure set up by + !! initialize_dyn_unsplit. + + character(len=48) :: thickness_units, flux_units + integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB + + ! This is where a control structure that is specific to this module is allocated. + if (associated(CS)) then + call MOM_error(WARNING, "register_restarts_dyn_unsplit called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ALLOC_(CS%diffu(IsdB:IedB,jsd:jed,nz)) ; CS%diffu(:,:,:) = 0.0 + ALLOC_(CS%diffv(isd:ied,JsdB:JedB,nz)) ; CS%diffv(:,:,:) = 0.0 + ALLOC_(CS%CAu(IsdB:IedB,jsd:jed,nz)) ; CS%CAu(:,:,:) = 0.0 + ALLOC_(CS%CAv(isd:ied,JsdB:JedB,nz)) ; CS%CAv(:,:,:) = 0.0 + ALLOC_(CS%PFu(IsdB:IedB,jsd:jed,nz)) ; CS%PFu(:,:,:) = 0.0 + ALLOC_(CS%PFv(isd:ied,JsdB:JedB,nz)) ; CS%PFv(:,:,:) = 0.0 + + thickness_units = get_thickness_units(GV) + flux_units = get_flux_units(GV) + +! No extra restart fields are needed with this time stepping scheme. + +end subroutine register_restarts_dyn_unsplit + +!> Initialize parameters and allocate memory associated with the unsplit dynamics module. +subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS, & + Accel_diag, Cont_diag, MIS, & + OBC, update_OBC_CSp, ALE_CSp, set_visc, & + visc, dirs, ntrunc, cont_stencil) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(time_type), target, intent(in) :: Time !< The current model time. + type(param_file_type), intent(in) :: param_file !< A structure to parse + !! for run-time parameters. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to + !! regulate diagnostic output. + type(MOM_dyn_unsplit_CS), pointer :: CS !< The control structure set up + !! by initialize_dyn_unsplit. + type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< A set of pointers to the various + !! accelerations in the momentum equations, which can be used + !! for later derived diagnostics, like energy budgets. + type(cont_diag_ptrs), target, intent(inout) :: Cont_diag !< A structure with pointers to + !! various terms in the continuity + !! equations. + type(ocean_internal_state), intent(inout) :: MIS !< The "MOM6 Internal State" + !! structure, used to pass around pointers + !! to various arrays for diagnostic purposes. + type(ocean_OBC_type), pointer :: OBC !< If open boundary conditions are + !! used, this points to the ocean_OBC_type + !! that was set up in MOM_initialization. + type(update_OBC_CS), pointer :: update_OBC_CSp !< If open boundary condition + !! updates are used, this points to + !! the appropriate control structure. + type(ALE_CS), pointer :: ALE_CSp !< This points to the ALE control + !! structure. + type(set_visc_CS), target, intent(in) :: set_visc !< set_visc control structure + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical + !! viscosities, bottom drag + !! viscosities, and related fields. + type(directories), intent(in) :: dirs !< A structure containing several + !! relevant directory paths. + integer, target, intent(inout) :: ntrunc !< A target for the variable that + !! records the number of times the velocity + !! is truncated (this should be 0). + integer, intent(out) :: cont_stencil !< The stencil for thickness + !! from the continuity solver. + + ! This subroutine initializes all of the variables that are used by this + ! dynamic core, including diagnostics and the cpu clocks. + + ! Local variables + character(len=40) :: mdl = "MOM_dynamics_unsplit" ! This module's name. + character(len=48) :: flux_units + ! This include declares and sets the variable "version". +# include "version_variable.h" + logical :: use_correct_dt_visc + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. + integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(CS)) call MOM_error(FATAL, & + "initialize_dyn_unsplit called with an unassociated control structure.") + if (CS%module_is_initialized) then + call MOM_error(WARNING, "initialize_dyn_unsplit called with a control "// & + "structure that has already been initialized.") + return + endif + CS%module_is_initialized = .true. + + CS%diag => diag + + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, & + "If false, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity with unsplit or "//& + "unsplit_RK2. If true, an older incorrect value is used.", & + default=.false., do_not_log=.true.) + ! This is used to test whether UNSPLIT_DT_VISC_BUG is being actively set. + call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%dt_visc_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", use_correct_dt_visc, & + "If true, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity with unsplit or "//& + "unsplit_RK2.", default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = use_correct_dt_visc .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (use_correct_dt_visc .eqv. CS%dt_visc_bug)) then + ! UNSPLIT_DT_VISC_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "UNSPLIT_DT_VISC_BUG and FIX_UNSPLIT_DT_VISC_BUG are both being set "//& + "with inconsistent values. FIX_UNSPLIT_DT_VISC_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_UNSPLIT_DT_VISC_BUG is an obsolete parameter. "//& + "Use UNSPLIT_DT_VISC_BUG instead (noting that it has the opposite sense).") + CS%dt_visc_bug = .not.use_correct_dt_visc + endif + call log_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, & + "If false, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity with unsplit or "//& + "unsplit_RK2. If true, an older incorrect value is used.", & + default=.false.) + + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "TIDES", CS%use_tides, & + "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) + + allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) + + MIS%diffu => CS%diffu ; MIS%diffv => CS%diffv + MIS%PFu => CS%PFu ; MIS%PFv => CS%PFv + MIS%CAu => CS%CAu ; MIS%CAv => CS%CAv + + CS%ADp => Accel_diag ; CS%CDp => Cont_diag + Accel_diag%diffu => CS%diffu ; Accel_diag%diffv => CS%diffv + Accel_diag%PFu => CS%PFu ; Accel_diag%PFv => CS%PFv + Accel_diag%CAu => CS%CAu ; Accel_diag%CAv => CS%CAv + + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + cont_stencil = continuity_stencil(CS%continuity_CSp) + call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) + if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & + CS%SAL_CSp, CS%tides_CSp) + call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc) + call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & + ntrunc, CS%vertvisc_CSp) + CS%set_visc_CSp => set_visc + + if (associated(ALE_CSp)) CS%ALE_CSp => ALE_CSp + if (associated(OBC)) CS%OBC => OBC + if (associated(update_OBC_CSp)) CS%update_OBC_CSp => update_OBC_CSp + + flux_units = get_flux_units(GV) + CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & + 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) + CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & + 'Meridional Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) + CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & + 'Zonal Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & + 'Meridional Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_PFu = register_diag_field('ocean_model', 'PFu', diag%axesCuL, Time, & + 'Zonal Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & + 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_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.) + 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.) + + id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) + id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) + id_clock_pres = cpu_clock_id('(Ocean pressure force)', grain=CLOCK_MODULE) + id_clock_vertvisc = cpu_clock_id('(Ocean vertical viscosity)', grain=CLOCK_MODULE) + id_clock_horvisc = cpu_clock_id('(Ocean horizontal viscosity)', grain=CLOCK_MODULE) + id_clock_mom_update = cpu_clock_id('(Ocean momentum increments)', grain=CLOCK_MODULE) + id_clock_pass = cpu_clock_id('(Ocean message passing)', grain=CLOCK_MODULE) + id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', grain=CLOCK_ROUTINE) + +end subroutine initialize_dyn_unsplit + +!> Clean up and deallocate memory associated with the unsplit dynamics module. +subroutine end_dyn_unsplit(CS) + type(MOM_dyn_unsplit_CS), pointer :: CS !< unsplit dynamics control structure that + !! will be deallocated in this subroutine. + + DEALLOC_(CS%diffu) ; DEALLOC_(CS%diffv) + DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) + DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) + + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) + + deallocate(CS) +end subroutine end_dyn_unsplit + +end module MOM_dynamics_unsplit diff --git a/core/MOM_dynamics_unsplit_RK2.F90 b/core/MOM_dynamics_unsplit_RK2.F90 new file mode 100644 index 0000000000..1c589f509c --- /dev/null +++ b/core/MOM_dynamics_unsplit_RK2.F90 @@ -0,0 +1,734 @@ +!> Time steps the ocean dynamics with an unsplit quasi 2nd order Runge-Kutta scheme +module MOM_dynamics_unsplit_RK2 + +! This file is part of MOM6. See LICENSE.md for the license. + +!********+*********+*********+*********+*********+*********+*********+** +!* * +!* By Alistair Adcroft and Robert Hallberg, 2010-2012 * +!* * +!* This file contains code that does the time-stepping of the * +!* adiabatic dynamic core, in this case with a pseudo-second order * +!* Runge-Kutta time stepping scheme for the momentum and a forward- * +!* backward coupling between the momentum and continuity equations, * +!* but without any splitting between the baroclinic and barotropic * +!* modes. Apart from the lack of splitting, this is closely analogous * +!* to the split time stepping scheme, and efforts have been taken to * +!* ensure that for certain configurations (e.g., very short * +!* baroclinic time steps, a single barotropic step per baroclinic * +!* step, and particular choices about how to coupled the baroclinic * +!* and barotropic solves, the two solutions reproduce each other. * +!* Although this time stepping scheme is not very efficient with a * +!* large number of layers, it is valuable for verifying the proper * +!* behavior of the more complicated split time stepping scheme, and * +!* is not too inefficient for use with only a few layers. * +!* * +!* The subroutine step_MOM_dyn_unsplit_RK2 actually does the time * +!* stepping, while register_restarts_dyn_unsplit_RK2 sets the fields * +!* that are found in a full restart file with this scheme, and * +!* initialize_dyn_unsplit_RK2 initializes the cpu clocks that are * +!* used in this module. For largely historical reasons, this module * +!* does not have its own control structure, but shares the same * +!* control structure with MOM.F90 and the other MOM_dynamics_... * +!* modules. * +!* * +!* Macros written all in capital letters are defined in MOM_memory.h. * +!* * +!* A small fragment of the grid is shown below: * +!* * +!* j+1 x ^ x ^ x At x: q, CoriolisBu * +!* j+1 > o > o > At ^: v, PFv, CAv, vh, diffv, tauy, vbt, vhtr * +!* j x ^ x ^ x At >: u, PFu, CAu, uh, diffu, taux, ubt, uhtr * +!* j > o > o > At o: h, bathyT, eta, T, S, tr * +!* j-1 x ^ x ^ x * +!* i-1 i i+1 * +!* i i+1 * +!* * +!* The boundaries always run through q grid points (x). * +!* * +!********+*********+*********+*********+*********+*********+*********+** + +use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_type +use MOM_variables, only : ocean_internal_state, accel_diag_ptrs, cont_diag_ptrs +use MOM_forcing_type, only : mech_forcing +use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum, MOM_accel_chksum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : diag_mediator_init, enable_averages +use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr +use MOM_diag_mediator, only : register_diag_field, register_static_field +use MOM_diag_mediator, only : set_diag_mediator_grid, diag_ctrl +use MOM_domains, only : pass_var, pass_var_start, pass_var_complete +use MOM_domains, only : pass_vector, pass_vector_start, pass_vector_complete +use MOM_domains, only : To_South, To_West, To_All, CGRID_NE, SCALAR_PAIR +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : MOM_set_verbosity +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_time_manager, only : time_type, time_type_to_real, operator(+) +use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) + +use MOM_ALE, only : ALE_CS +use MOM_boundary_update, only : update_OBC_data, update_OBC_CS +use MOM_barotropic, only : barotropic_CS +use MOM_continuity, only : continuity, continuity_init, continuity_CS, continuity_stencil +use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS +use MOM_debugging, only : check_redundant +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_hor_visc, only : horizontal_viscosity, hor_visc_init, hor_visc_CS +use MOM_interface_heights, only : thickness_to_dz +use MOM_lateral_mixing_coeffs, only : VarMix_CS +use MOM_MEKE_types, only : MEKE_type +use MOM_open_boundary, only : ocean_OBC_type +use MOM_open_boundary, only : radiation_open_bdry_conds +use MOM_open_boundary, only : open_boundary_zero_normal_flow +use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS +use MOM_set_visc, only : set_viscous_ML, set_visc_CS +use MOM_self_attr_load, only : SAL_init, SAL_end, SAL_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end, tidal_forcing_CS +use MOM_unit_scaling, only : unit_scale_type +use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_init, vertvisc_CS +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units +use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units + +implicit none ; private + +#include + +!> MOM_dynamics_unsplit_RK2 module control structure +type, public :: MOM_dyn_unsplit_RK2_CS ; private + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & + CAu, & !< CAu = f*v - u.grad(u) [L T-2 ~> m s-2]. + PFu, & !< PFu = -dM/dx [L T-2 ~> m s-2]. + diffu !< Zonal acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2]. + + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & + CAv, & !< CAv = -f*u - u.grad(v) [L T-2 ~> m s-2]. + PFv, & !< PFv = -dM/dy [L T-2 ~> m s-2]. + diffv !< Meridional acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2]. + + real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + + real :: be !< A nondimensional number from 0.5 to 1 that controls + !! the backward weighting of the time stepping scheme [nondim]. + real :: begw !< A nondimensional number from 0 to 1 that controls + !! the extent to which the treatment of gravity waves + !! is forward-backward (0) or simulated backward + !! Euler (1) [nondim]. 0 is often used. + logical :: dt_visc_bug !< If false, use the correct timestep in the calculation of the + !! turbulent mixed layer properties for viscosity. Otherwise if + !! this is true, an older incorrect setting is used. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. + + logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + + !>@{ Diagnostic IDs + integer :: id_uh = -1, id_vh = -1 + integer :: id_ueffA = -1, id_veffA = -1 + integer :: id_PFu = -1, id_PFv = -1, id_CAu = -1, id_CAv = -1 + !>@} + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(accel_diag_ptrs), pointer :: ADp => NULL() !< A structure pointing to the + !! accelerations in the momentum equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + type(cont_diag_ptrs), pointer :: CDp => NULL() !< A structure with pointers to + !! various terms in the continuity equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + + ! The remainder of the structure points to child subroutines' control structures. + !> A pointer to the horizontal viscosity control structure + type(hor_visc_CS) :: hor_visc + !> A pointer to the continuity control structure + type(continuity_CS) :: continuity_CSp + !> The CoriolisAdv control structure + type(CoriolisAdv_CS) :: CoriolisAdv + !> A pointer to the PressureForce control structure + type(PressureForce_CS) :: PressureForce_CSp + !> A pointer to the vertvisc control structure + type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() + !> A pointer to the set_visc control structure + type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp + !> A pointer to the tidal forcing control structure + type(tidal_forcing_CS) :: tides_CSp + !> A pointer to the ALE control structure. + type(ALE_CS), pointer :: ALE_CSp => NULL() + + type(ocean_OBC_type), pointer :: OBC => NULL() !< A pointer to an open boundary + !! condition type that specifies whether, where, and what open boundary + !! conditions are used. If no open BCs are used, this pointer stays + !! nullified. Flather OBCs use open boundary_CS as well. + !> A pointer to the update_OBC control structure + type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() + +end type MOM_dyn_unsplit_RK2_CS + + +public step_MOM_dyn_unsplit_RK2, register_restarts_dyn_unsplit_RK2 +public initialize_dyn_unsplit_RK2, end_dyn_unsplit_RK2 + +!>@{ CPU time clock IDs +integer :: id_clock_Cor, id_clock_pres, id_clock_vertvisc +integer :: id_clock_horvisc, id_clock_continuity, id_clock_mom_update +integer :: id_clock_pass, id_clock_pass_init +!>@} + +contains + +! ============================================================================= + +!> Step the MOM6 dynamics using an unsplit quasi-2nd order Runge-Kutta scheme +subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & + VarMix, MEKE, pbv) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u_in !< The input and output zonal + !! velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v_in !< The input and output meridional + !! velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_in !< The input and output layer thicknesses, + !! [H ~> m or kg m-2], depending on whether + !! the Boussinesq approximation is made. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical + !! viscosities, bottom drag + !! viscosities, and related fields. + type(time_type), intent(in) :: Time_local !< The model time at the end of + !! the time step. + real, intent(in) :: dt !< The baroclinic dynamics time step [T ~> s]. + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to + !! the surface pressure at the beginning + !! of this dynamic step [R L2 T-2 ~> Pa]. + real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to + !! the surface pressure at the end of + !! this dynamic step [R L2 T-2 ~> Pa]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uh !< The zonal volume or mass transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vh !< The meridional volume or mass + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< The accumulated zonal volume or + !! mass transport since the last + !! tracer advection [H L2 ~> m3 or kg]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< The accumulated meridional volume + !! or mass transport since the last + !! tracer advection [H L2 ~> m3 or kg]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< The time-mean free surface height + !! or column mass [H ~> m or kg m-2]. + type(MOM_dyn_unsplit_RK2_CS), pointer :: CS !< The control structure set up by + !! initialize_dyn_unsplit_RK2. + type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + !! fields related to the Mesoscale + !! Eddy Kinetic Energy. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av ! Averaged layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up ! Predicted zonal velocities [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp ! Predicted meridional velocities [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: veffA ! Effective Area of V-Faces [H L ~> m2] + real, dimension(:,:), pointer :: p_surf => NULL() ! A pointer to the surface pressure [R L2 T-2 ~> Pa] + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s] + real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s] + logical :: dyn_p_surf + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + 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 + dt_pred = dt * CS%BE + + h_av(:,:,:) = 0; hp(:,:,:) = 0 + up(:,:,:) = 0 + vp(:,:,:) = 0 + + dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) + if (dyn_p_surf) then + call safe_alloc_ptr(p_surf,G%isd,G%ied,G%jsd,G%jed) ; p_surf(:,:) = 0.0 + else + p_surf => forces%p_surf + endif + +! Runge-Kutta second order accurate two step scheme is used to step +! all of the fields except h. h is stepped separately. + + if (CS%debug) then + call MOM_state_chksum("Start Predictor ", u_in, v_in, h_in, uh, vh, G, GV, US) + endif + +! diffu = horizontal viscosity terms (u,h) + call enable_averages(dt,Time_local, CS%diag) + call cpu_clock_begin(id_clock_horvisc) + call horizontal_viscosity(u_in, v_in, h_in, CS%diffu, CS%diffv, MEKE, VarMix, & + G, GV, US, CS%hor_visc) + call cpu_clock_end(id_clock_horvisc) + call disable_averaging(CS%diag) + call pass_vector(CS%diffu, CS%diffv, G%Domain, clock=id_clock_pass) + +! This continuity step is solely for the Coroilis terms, specifically in the +! denominator of PV and in the mass transport or PV. +! uh = u[n-1]*h[n-1/2] +! hp = h[n-1/2] + dt/2 div . uh + call cpu_clock_begin(id_clock_continuity) + ! This is a duplicate calculation of the last continuity from the previous step + ! and could/should be optimized out. -AJA + call continuity(u_in, v_in, h_in, hp, uh, vh, dt_pred, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call cpu_clock_end(id_clock_continuity) + call pass_var(hp, G%Domain, clock=id_clock_pass) + call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) + +! h_av = (h + hp)/2 (used in PV denominator) + call cpu_clock_begin(id_clock_mom_update) + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = (h_in(i,j,k) + hp(i,j,k)) * 0.5 + enddo ; enddo ; enddo + call cpu_clock_end(id_clock_mom_update) + +! CAu = -(f+zeta)/h_av vh + d/dx KE (function of u[n-1] and uh[n-1]) + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(u_in, v_in, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & + G, GV, US, CS%CoriolisAdv, pbv) + call cpu_clock_end(id_clock_Cor) + +! PFu = d/dx M(h_av,T,S) (function of h[n-1/2]) + call cpu_clock_begin(id_clock_pres) + if (dyn_p_surf) then ; do j=js-2,je+2 ; do i=is-2,ie+2 + p_surf(i,j) = 0.5*p_surf_begin(i,j) + 0.5*p_surf_end(i,j) + enddo ; enddo ; endif + call PressureForce(h_in, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, CS%ALE_CSp, p_surf) + call cpu_clock_end(id_clock_pres) + call pass_vector(CS%PFu, CS%PFv, G%Domain, clock=id_clock_pass) + call pass_vector(CS%CAu, CS%CAv, G%Domain, clock=id_clock_pass) + + if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, GV, US, tv, h_in, CS%update_OBC_CSp, Time_local) + endif ; endif + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%diffu, CS%diffv) + endif + +! up+[n-1/2] = u[n-1] + dt_pred * (PFu + CAu) + call cpu_clock_begin(id_clock_mom_update) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + up(I,j,k) = G%mask2dCu(I,j) * (u_in(I,j,k) + dt_pred * & + ((CS%PFu(I,j,k) + CS%CAu(I,j,k)) + CS%diffu(I,j,k))) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + vp(i,J,k) = G%mask2dCv(i,J) * (v_in(i,J,k) + dt_pred * & + ((CS%PFv(i,J,k) + CS%CAv(i,J,k)) + CS%diffv(i,J,k))) + enddo ; enddo ; enddo + call cpu_clock_end(id_clock_mom_update) + + if (CS%debug) & + call MOM_accel_chksum("Predictor 1 accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv,& + CS%diffu, CS%diffv, G, GV, US) + + ! up[n-1/2] <- up*[n-1/2] + dt/2 d/dz visc d/dz up[n-1/2] + call cpu_clock_begin(id_clock_vertvisc) + call enable_averages(dt, Time_local, CS%diag) + dt_visc = dt ; if (CS%dt_visc_bug) dt_visc = dt_pred + call set_viscous_ML(u_in, v_in, h_av, tv, forces, visc, dt_visc, G, GV, US, CS%set_visc_CSp) + call disable_averaging(CS%diag) + + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc(up, vp, h_av, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, & + G, GV, US, CS%vertvisc_CSp) + call cpu_clock_end(id_clock_vertvisc) + call pass_vector(up, vp, G%Domain, clock=id_clock_pass) + +! uh = up[n-1/2] * h[n-1/2] +! h_av = h + dt div . uh + call cpu_clock_begin(id_clock_continuity) + call continuity(up, vp, h_in, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call cpu_clock_end(id_clock_continuity) + call pass_var(hp, G%Domain, clock=id_clock_pass) + call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) + +! h_av <- (h + hp)/2 (centered at n-1/2) + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = (h_in(i,j,k) + hp(i,j,k)) * 0.5 + enddo ; enddo ; enddo + + if (CS%debug) & + call MOM_state_chksum("Predictor 1", up, vp, h_av, uh, vh, G, GV, US) + +! CAu = -(f+zeta(up))/h_av vh + d/dx KE(up) (function of up[n-1/2], h[n-1/2]) + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(up, vp, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & + G, GV, US, CS%CoriolisAdv, pbv) + call cpu_clock_end(id_clock_Cor) + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%CAu, CS%CAv) + endif + +! call enable_averages(dt, Time_local, CS%diag) ?????????????????????/ + +! up* = u[n] + (1+gamma) * dt * ( PFu + CAu ) Extrapolated for damping +! u*[n+1] = u[n] + dt * ( PFu + CAu ) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + up(I,j,k) = G%mask2dCu(I,j) * (u_in(I,j,k) + dt * (1.+CS%begw) * & + ((CS%PFu(I,j,k) + CS%CAu(I,j,k)) + CS%diffu(I,j,k))) + u_in(I,j,k) = G%mask2dCu(I,j) * (u_in(I,j,k) + dt * & + ((CS%PFu(I,j,k) + CS%CAu(I,j,k)) + CS%diffu(I,j,k))) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + vp(i,J,k) = G%mask2dCv(i,J) * (v_in(i,J,k) + dt * (1.+CS%begw) * & + ((CS%PFv(i,J,k) + CS%CAv(i,J,k)) + CS%diffv(i,J,k))) + v_in(i,J,k) = G%mask2dCv(i,J) * (v_in(i,J,k) + dt * & + ((CS%PFv(i,J,k) + CS%CAv(i,J,k)) + CS%diffv(i,J,k))) + enddo ; enddo ; enddo + +! up[n] <- up* + dt d/dz visc d/dz up +! u[n] <- u*[n] + dt d/dz visc d/dz u[n] + call cpu_clock_begin(id_clock_vertvisc) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc(up, vp, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & + G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) + call vertvisc_coef(u_in, v_in, h_av, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc(u_in, v_in, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp,& + G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) + call cpu_clock_end(id_clock_vertvisc) + call pass_vector(up, vp, G%Domain, clock=id_clock_pass) + call pass_vector(u_in, v_in, G%Domain, clock=id_clock_pass) + +! uh = up[n] * h[n] (up[n] might be extrapolated to damp GWs) +! h[n+1] = h[n] + dt div . uh + call cpu_clock_begin(id_clock_continuity) + call continuity(up, vp, h_in, h_in, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call cpu_clock_end(id_clock_continuity) + call pass_var(h_in, G%Domain, clock=id_clock_pass) + call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) + +! Accumulate mass flux for tracer transport + do k=1,nz + do j=js-2,je+2 ; do I=Isq-2,Ieq+2 + uhtr(I,j,k) = uhtr(I,j,k) + dt*uh(I,j,k) + enddo ; enddo + do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 + vhtr(i,J,k) = vhtr(i,J,k) + dt*vh(i,J,k) + enddo ; enddo + enddo + + if (CS%debug) then + call MOM_state_chksum("Corrector", u_in, v_in, h_in, uh, vh, G, GV, US) + call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US) + endif + + if (GV%Boussinesq) then + do j=js,je ; do i=is,ie ; eta_av(i,j) = -GV%Z_to_H*G%bathyT(i,j) ; enddo ; enddo + else + do j=js,je ; do i=is,ie ; eta_av(i,j) = 0.0 ; enddo ; enddo + endif + do k=1,nz ; do j=js,je ; do i=is,ie + eta_av(i,j) = eta_av(i,j) + h_av(i,j,k) + enddo ; enddo ; enddo + + if (dyn_p_surf) deallocate(p_surf) + +! Here various terms used in to update the momentum equations are +! offered for averaging. + if (CS%id_PFu > 0) call post_data(CS%id_PFu, CS%PFu, CS%diag) + if (CS%id_PFv > 0) call post_data(CS%id_PFv, CS%PFv, CS%diag) + if (CS%id_CAu > 0) call post_data(CS%id_CAu, CS%CAu, CS%diag) + if (CS%id_CAv > 0) call post_data(CS%id_CAv, CS%CAv, CS%diag) + +! Here the thickness fluxes are offered for averaging. + if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) + if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) + +! Calculate effective areas and post data + if (CS%id_ueffA > 0) then + ueffA(:,:,:) = 0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(up(I,j,k)) > 0.) ueffA(I,j,k) = uh(I,j,k)/up(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_ueffA, ueffA, CS%diag) + endif + + if (CS%id_veffA > 0) then + veffA(:,:,:) = 0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(vp(i,J,k)) > 0.) veffA(i,J,k) = vh(i,J,k)/vp(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_veffA, veffA, CS%diag) + endif + + +end subroutine step_MOM_dyn_unsplit_RK2 + +! ============================================================================= + +!> Allocate the control structure for this module, allocates memory in it, and registers +!! any auxiliary restart variables that are specific to the unsplit RK2 time stepping scheme. +!! +!! All variables registered here should have the ability to be recreated if they are not present +!! in a restart file. +subroutine register_restarts_dyn_unsplit_RK2(HI, GV, param_file, CS) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(MOM_dyn_unsplit_RK2_CS), pointer :: CS !< The control structure set up by + !! initialize_dyn_unsplit_RK2. +! This subroutine sets up any auxiliary restart variables that are specific +! to the unsplit time stepping scheme. All variables registered here should +! have the ability to be recreated if they are not present in a restart file. + + ! Local variables + character(len=48) :: thickness_units, flux_units + integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB + +! This is where a control structure that is specific to this module would be allocated. + if (associated(CS)) then + call MOM_error(WARNING, "register_restarts_dyn_unsplit_RK2 called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ALLOC_(CS%diffu(IsdB:IedB,jsd:jed,nz)) ; CS%diffu(:,:,:) = 0.0 + ALLOC_(CS%diffv(isd:ied,JsdB:JedB,nz)) ; CS%diffv(:,:,:) = 0.0 + ALLOC_(CS%CAu(IsdB:IedB,jsd:jed,nz)) ; CS%CAu(:,:,:) = 0.0 + ALLOC_(CS%CAv(isd:ied,JsdB:JedB,nz)) ; CS%CAv(:,:,:) = 0.0 + ALLOC_(CS%PFu(IsdB:IedB,jsd:jed,nz)) ; CS%PFu(:,:,:) = 0.0 + ALLOC_(CS%PFv(isd:ied,JsdB:JedB,nz)) ; CS%PFv(:,:,:) = 0.0 + + thickness_units = get_thickness_units(GV) + flux_units = get_flux_units(GV) + +! No extra restart fields are needed with this time stepping scheme. + +end subroutine register_restarts_dyn_unsplit_RK2 + +!> Initialize parameters and allocate memory associated with the unsplit RK2 dynamics module. +subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag, CS, & + Accel_diag, Cont_diag, MIS, & + OBC, update_OBC_CSp, ALE_CSp, set_visc, & + visc, dirs, ntrunc, cont_stencil) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(time_type), target, intent(in) :: Time !< The current model time. + type(param_file_type), intent(in) :: param_file !< A structure to parse + !! for run-time parameters. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to + !! regulate diagnostic output. + type(MOM_dyn_unsplit_RK2_CS), pointer :: CS !< The control structure set up + !! by initialize_dyn_unsplit_RK2. + type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< A set of pointers to the + !! various accelerations in the momentum equations, which can + !! be used for later derived diagnostics, like energy budgets. + type(cont_diag_ptrs), target, intent(inout) :: Cont_diag !< A structure with pointers + !! to various terms in the + !! continuity equations. + type(ocean_internal_state), intent(inout) :: MIS !< The "MOM6 Internal State" + !! structure, used to pass around pointers + !! to various arrays for diagnostic purposes. + type(ocean_OBC_type), pointer :: OBC !< If open boundary conditions + !! are used, this points to the ocean_OBC_type + !! that was set up in MOM_initialization. + type(update_OBC_CS), pointer :: update_OBC_CSp !< If open boundary + !! condition updates are used, this points + !! to the appropriate control structure. + type(ALE_CS), pointer :: ALE_CSp !< This points to the ALE + !! control structure. + type(set_visc_CS), target, intent(in) :: set_visc !< set visc control structure + type(vertvisc_type), intent(inout) :: visc !< A structure containing + !! vertical viscosities, bottom drag + !! viscosities, and related fields. + type(directories), intent(in) :: dirs !< A structure containing several + !! relevant directory paths. + integer, target, intent(inout) :: ntrunc !< A target for the variable + !! that records the number of times the + !! velocity is truncated (this should be 0). + integer, intent(out) :: cont_stencil !< The stencil for + !! thickness from the continuity solver. + + ! This subroutine initializes all of the variables that are used by this + ! dynamic core, including diagnostics and the cpu clocks. + + ! Local variables + character(len=40) :: mdl = "MOM_dynamics_unsplit_RK2" ! This module's name. + character(len=48) :: flux_units + ! This include declares and sets the variable "version". +# include "version_variable.h" + logical :: use_correct_dt_visc + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. + integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(CS)) call MOM_error(FATAL, & + "initialize_dyn_unsplit_RK2 called with an unassociated control structure.") + if (CS%module_is_initialized) then + call MOM_error(WARNING, "initialize_dyn_unsplit_RK2 called with a control "// & + "structure that has already been initialized.") + return + endif + CS%module_is_initialized = .true. + + CS%diag => diag + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "BE", CS%be, & + "If SPLIT is true, BE determines the relative weighting "//& + "of a 2nd-order Runga-Kutta baroclinic time stepping "//& + "scheme (0.5) and a backward Euler scheme (1) that is "//& + "used for the Coriolis and inertial terms. BE may be "//& + "from 0.5 to 1, but instability may occur near 0.5. "//& + "BE is also applicable if SPLIT is false and USE_RK2 "//& + "is true.", units="nondim", default=0.6) + call get_param(param_file, mdl, "BEGW", CS%begw, & + "If SPLIT is true, BEGW is a number from 0 to 1 that "//& + "controls the extent to which the treatment of gravity "//& + "waves is forward-backward (0) or simulated backward "//& + "Euler (1). 0 is almost always used. "//& + "If SPLIT is false and USE_RK2 is true, BEGW can be "//& + "between 0 and 0.5 to damp gravity waves.", & + units="nondim", default=0.0) + + call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, & + "If false, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity with unsplit or "//& + "unsplit_RK2. If true, an older incorrect value is used.", & + default=.false., do_not_log=.true.) + ! This is used to test whether UNSPLIT_DT_VISC_BUG is being explicitly set. + call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%dt_visc_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", use_correct_dt_visc, & + "If true, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity with unsplit or "//& + "unsplit_RK2.", default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = use_correct_dt_visc .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (use_correct_dt_visc .eqv. CS%dt_visc_bug)) then + ! UNSPLIT_DT_VISC_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "UNSPLIT_DT_VISC_BUG and FIX_UNSPLIT_DT_VISC_BUG are both being set "//& + "with inconsistent values. FIX_UNSPLIT_DT_VISC_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_UNSPLIT_DT_VISC_BUG is an obsolete parameter. "//& + "Use UNSPLIT_DT_VISC_BUG instead (noting that it has the opposite sense).") + CS%dt_visc_bug = .not.use_correct_dt_visc + endif + call log_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, & + "If false, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity with unsplit or "//& + "unsplit_RK2. If true, an older incorrect value is used.", & + default=.false.) + + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "TIDES", CS%use_tides, & + "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) + + allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) + + MIS%diffu => CS%diffu ; MIS%diffv => CS%diffv + MIS%PFu => CS%PFu ; MIS%PFv => CS%PFv + MIS%CAu => CS%CAu ; MIS%CAv => CS%CAv + + CS%ADp => Accel_diag ; CS%CDp => Cont_diag + Accel_diag%diffu => CS%diffu ; Accel_diag%diffv => CS%diffv + Accel_diag%PFu => CS%PFu ; Accel_diag%PFv => CS%PFv + Accel_diag%CAu => CS%CAu ; Accel_diag%CAv => CS%CAv + + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + cont_stencil = continuity_stencil(CS%continuity_CSp) + call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) + if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & + CS%SAL_CSp, CS%tides_CSp) + call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc) + call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & + ntrunc, CS%vertvisc_CSp) + CS%set_visc_CSp => set_visc + + if (associated(ALE_CSp)) CS%ALE_CSp => ALE_CSp + if (associated(OBC)) CS%OBC => OBC + + flux_units = get_flux_units(GV) + CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & + 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) + CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & + 'Meridional Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) + CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & + 'Zonal Coriolis and Advective Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) + CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & + 'Meridional Coriolis and Advective Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) + CS%id_PFu = register_diag_field('ocean_model', 'PFu', diag%axesCuL, Time, & + 'Zonal Pressure Force Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) + CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & + '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.) + 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.) + + id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) + id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) + id_clock_pres = cpu_clock_id('(Ocean pressure force)', grain=CLOCK_MODULE) + id_clock_vertvisc = cpu_clock_id('(Ocean vertical viscosity)', grain=CLOCK_MODULE) + id_clock_horvisc = cpu_clock_id('(Ocean horizontal viscosity)', grain=CLOCK_MODULE) + id_clock_mom_update = cpu_clock_id('(Ocean momentum increments)', grain=CLOCK_MODULE) + id_clock_pass = cpu_clock_id('(Ocean message passing)', grain=CLOCK_MODULE) + id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', grain=CLOCK_ROUTINE) + +end subroutine initialize_dyn_unsplit_RK2 + +!> Clean up and deallocate memory associated with the dyn_unsplit_RK2 module. +subroutine end_dyn_unsplit_RK2(CS) + type(MOM_dyn_unsplit_RK2_CS), pointer :: CS !< dyn_unsplit_RK2 control structure that + !! will be deallocated in this subroutine. + + DEALLOC_(CS%diffu) ; DEALLOC_(CS%diffv) + DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) + DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) + + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) + + deallocate(CS) +end subroutine end_dyn_unsplit_RK2 + +end module MOM_dynamics_unsplit_RK2 diff --git a/core/MOM_forcing_type.F90 b/core/MOM_forcing_type.F90 new file mode 100644 index 0000000000..452161c6ca --- /dev/null +++ b/core/MOM_forcing_type.F90 @@ -0,0 +1,4168 @@ +!> This module implements boundary forcing for MOM6. +module MOM_forcing_type + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_array_transform, only : rotate_array, rotate_vector, rotate_array_pair +use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_destructor +use MOM_coupler_types, only : coupler_type_increment_data, coupler_type_initialized +use MOM_coupler_types, only : coupler_type_copy_data +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_debugging, only : hchksum, uvchksum +use MOM_diag_mediator, only : post_data, register_diag_field, register_scalar_field +use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_alloc, query_averaging_enabled +use MOM_diag_mediator, only : enable_averages, disable_averaging +use MOM_EOS, only : calculate_density_derivs, calculate_specific_vol_derivs, EOS_domain +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_opacity, only : sumSWoverBands, optics_type, extract_optics_slice, optics_nbands +use MOM_spatial_means, only : global_area_integral, global_area_mean +use MOM_spatial_means, only : global_area_mean_u, global_area_mean_v +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public extractFluxes1d, extractFluxes2d, optics_type +public MOM_forcing_chksum, MOM_mech_forcing_chksum +public calculateBuoyancyFlux1d, calculateBuoyancyFlux2d, find_ustar +public forcing_accumulate, fluxes_accumulate +public forcing_SinglePointPrint, mech_forcing_diags, forcing_diagnostics +public register_forcing_type_diags, allocate_forcing_type, deallocate_forcing_type +public copy_common_forcing_fields, allocate_mech_forcing, deallocate_mech_forcing +public set_derived_forcing_fields, copy_back_forcing_fields +public set_net_mass_forcing, get_net_mass_forcing +public rotate_forcing, rotate_mech_forcing +public homogenize_forcing, homogenize_mech_forcing + +!> Allocate the fields of a (flux) forcing type, based on either a set of input +!! flags for each group of fields, or a pre-allocated reference forcing. +interface allocate_forcing_type + module procedure allocate_forcing_by_group + module procedure allocate_forcing_by_ref +end interface allocate_forcing_type + +!> Allocate the fields of a mechanical forcing type, based on either a set of +!! input flags for each group of fields, or a pre-allocated reference forcing. +interface allocate_mech_forcing + module procedure allocate_mech_forcing_by_group + module procedure allocate_mech_forcing_from_ref +end interface allocate_mech_forcing + +!> Determine the friction velocity from a forcing type or a mechanical forcing type. +interface find_ustar + module procedure find_ustar_fluxes + module procedure find_ustar_mech_forcing +end interface find_ustar + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Structure that contains pointers to the boundary forcing used to drive the +!! liquid ocean simulated by MOM. +!! +!! Data in this type is allocated in the module MOM_surface_forcing.F90, of which there +!! are three: solo, coupled, and ice-shelf. Alternatively, they are allocated in +!! MESO_surface_forcing.F90, which is a special case of solo_driver/MOM_surface_forcing.F90. +type, public :: forcing + + ! surface stress components and turbulent velocity scale + real, pointer, dimension(:,:) :: & + !omega_w2x => NULL(), & !< the counter-clockwise angle of the wind stress with respect + ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. + tau_mag => NULL(), & !< Magnitude of the wind stress averaged over tracer cells, + !! including any contributions from sub-gridscale variability + !! or gustiness [R L Z T-2 ~> Pa] + ustar_gustless => NULL(), & !< surface friction velocity scale without any + !! any augmentation for gustiness [Z T-1 ~> m s-1]. + tau_mag_gustless => NULL() !< Magnitude of the wind stress averaged over tracer cells, + !! without any augmentation for sub-gridscale variability + !! or gustiness [R L Z T-2 ~> Pa] + + ! surface buoyancy force, used when temperature is not a state variable + real, pointer, dimension(:,:) :: & + buoy => NULL() !< buoyancy flux [L2 T-3 ~> m2 s-3] + + ! radiative heat fluxes into the ocean [Q R Z T-1 ~> W m-2] + real, pointer, dimension(:,:) :: & + sw => NULL(), & !< shortwave [Q R Z T-1 ~> W m-2] + sw_vis_dir => NULL(), & !< visible, direct shortwave [Q R Z T-1 ~> W m-2] + sw_vis_dif => NULL(), & !< visible, diffuse shortwave [Q R Z T-1 ~> W m-2] + sw_nir_dir => NULL(), & !< near-IR, direct shortwave [Q R Z T-1 ~> W m-2] + sw_nir_dif => NULL(), & !< near-IR, diffuse shortwave [Q R Z T-1 ~> W m-2] + lw => NULL() !< longwave [Q R Z T-1 ~> W m-2] (typically negative) + + ! turbulent heat fluxes into the ocean [Q R Z T-1 ~> W m-2] + real, pointer, dimension(:,:) :: & + latent => NULL(), & !< latent [Q R Z T-1 ~> W m-2] (typically < 0) + sens => NULL(), & !< sensible [Q R Z T-1 ~> W m-2] (typically negative) + seaice_melt_heat => NULL(), & !< sea ice and snow melt or formation [Q R Z T-1 ~> W m-2] (typically negative) + heat_added => NULL() !< additional heat flux from SST restoring or flux adjustments [Q R Z T-1 ~> W m-2] + + ! components of latent heat fluxes used for diagnostic purposes + real, pointer, dimension(:,:) :: & + latent_evap_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from evaporating liquid water (typically < 0) + latent_fprec_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from melting fprec (typically < 0) + latent_frunoff_diag => NULL() !< latent [Q R Z T-1 ~> W m-2] from melting frunoff (calving) (typically < 0) + + ! water mass fluxes into the ocean [R Z T-1 ~> kg m-2 s-1]; these fluxes impact the ocean mass + real, pointer, dimension(:,:) :: & + evap => NULL(), & !< (-1)*fresh water flux evaporated out of the ocean [R Z T-1 ~> kg m-2 s-1] + lprec => NULL(), & !< precipitating liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] + fprec => NULL(), & !< precipitating frozen water into the ocean [R Z T-1 ~> kg m-2 s-1] + vprec => NULL(), & !< virtual liquid precip associated w/ SSS restoring [R Z T-1 ~> kg m-2 s-1] + lrunoff => NULL(), & !< liquid river runoff entering ocean [R Z T-1 ~> kg m-2 s-1] + frunoff => NULL(), & !< frozen river runoff (calving) entering ocean [R Z T-1 ~> kg m-2 s-1] + seaice_melt => NULL() !< snow/seaice melt (positive) or formation (negative) [R Z T-1 ~> kg m-2 s-1] + + ! Integrated water mass fluxes into the ocean, used for passive tracer sources [H ~> m or kg m-2] + real, pointer, dimension(:,:) :: & + netMassIn => NULL(), & !< Sum of water mass fluxes into the ocean integrated over a + !! forcing timestep [H ~> m or kg m-2] + netMassOut => NULL(), & !< Net water mass flux out of the ocean integrated over a forcing timestep, + !! with negative values for water leaving the ocean [H ~> m or kg m-2] + KPP_salt_flux => NULL() !< KPP effective salt flux [ppt m s-1] + + ! heat associated with water crossing ocean surface + real, pointer, dimension(:,:) :: & + heat_content_cond => NULL(), & !< heat content associated with condensating water [Q R Z T-1 ~> W m-2] + heat_content_evap => NULL(), & !< heat content associated with evaporating water [Q R Z T-1 ~> W m-2] + heat_content_lprec => NULL(), & !< heat content associated with liquid >0 precip [Q R Z T-1 ~> W m-2] + heat_content_fprec => NULL(), & !< heat content associated with frozen precip [Q R Z T-1 ~> W m-2] + heat_content_vprec => NULL(), & !< heat content associated with virtual >0 precip [Q R Z T-1 ~> W m-2] + heat_content_lrunoff => NULL(), & !< heat content associated with liquid runoff [Q R Z T-1 ~> W m-2] + heat_content_frunoff => NULL(), & !< heat content associated with frozen runoff [Q R Z T-1 ~> W m-2] + heat_content_massout => NULL(), & !< heat content associated with mass leaving ocean [Q R Z T-1 ~> W m-2] + heat_content_massin => NULL() !< heat content associated with mass entering ocean [Q R Z T-1 ~> W m-2] + + ! salt mass flux (contributes to ocean mass only if non-Bouss ) + real, pointer, dimension(:,:) :: & + salt_flux => NULL(), & !< net salt flux into the ocean [R Z T-1 ~> kgSalt m-2 s-1] + salt_flux_in => NULL(), & !< salt flux provided to the ocean from coupler [R Z T-1 ~> kgSalt m-2 s-1] + salt_flux_added => NULL(), & !< additional salt flux from restoring or flux adjustment before adjustment + !! to net zero [R Z T-1 ~> kgSalt m-2 s-1] + salt_left_behind => NULL() !< salt left in ocean at the surface from brine rejection + !! [R Z T-1 ~> kgSalt m-2 s-1] + + ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) + real, pointer, dimension(:,:) :: p_surf_full => NULL() + !< Pressure at the top ocean interface [R L2 T-2 ~> Pa]. + !! if there is sea-ice, then p_surf_flux is at ice-ocean interface + real, pointer, dimension(:,:) :: p_surf => NULL() + !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] as used to drive the ocean model. + !! If p_surf is limited, p_surf may be smaller than p_surf_full, otherwise they are the same. + real, pointer, dimension(:,:) :: p_surf_SSH => NULL() + !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] that is used in corrections to the sea surface + !! height field that is passed back to the calling routines. + !! p_surf_SSH may point to p_surf or to p_surf_full. + logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere + !! and various types of ice needs to be accumulated, and the + !! surface pressure explicitly reset to zero at the driver level + !! when appropriate. + + ! tide related inputs + real, pointer, dimension(:,:) :: & + TKE_tidal => NULL(), & !< tidal energy source driving mixing in bottom boundary layer [R Z3 T-3 ~> W m-2] + ustar_tidal => NULL() !< tidal contribution to bottom ustar [Z T-1 ~> m s-1] + + ! iceberg related inputs + real, pointer, dimension(:,:) :: & + ustar_berg => NULL(), & !< iceberg contribution to top ustar [Z T-1 ~> m s-1]. + area_berg => NULL(), & !< fractional area of ocean surface covered by icebergs [nondim] + mass_berg => NULL() !< mass of icebergs [R Z ~> kg m-2] + + ! land ice-shelf related inputs + real, pointer, dimension(:,:) :: ustar_shelf => NULL() !< Friction velocity under ice-shelves [Z T-1 ~> m s-1]. + !! as computed by the ocean at the previous time step. + real, pointer, dimension(:,:) :: frac_shelf_h => NULL() !< Fractional ice shelf coverage of + !! h-cells, from 0 to 1 [nondim]. This is only + !! associated if ice shelves are enabled, and are + !! exactly 0 away from shelves or on land. + real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) + !! or freezing (negative) [R Z T-1 ~> kg m-2 s-1] + real, pointer, dimension(:,:) :: shelf_sfc_mass_flux => NULL() !< Ice shelf surface mass flux + !! deposition from the atmosphere. [R Z T-1 ~> kg m-2 s-1] + + ! Scalars set by surface forcing modules + real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] + real :: saltFluxGlobalAdj = 0. !< adjustment to restoring salt flux to zero out global net [kgSalt m-2 s-1] + real :: netFWGlobalAdj = 0. !< adjustment to net fresh water to zero out global net [kg m-2 s-1] + real :: vPrecGlobalScl = 0. !< scaling of restoring vprec to zero out global net ( -1..1 ) [nondim] + real :: saltFluxGlobalScl = 0. !< scaling of restoring salt flux to zero out global net ( -1..1 ) [nondim] + real :: netFWGlobalScl = 0. !< scaling of net fresh water to zero out global net ( -1..1 ) [nondim] + + logical :: fluxes_used = .true. !< If true, all of the heat, salt, and mass + !! fluxes have been applied to the ocean. + real :: dt_buoy_accum = -1.0 !< The amount of time over which the buoyancy fluxes + !! should be applied [T ~> s]. If negative, this forcing + !! type variable has not yet been initialized. + logical :: gustless_accum_bug = .true. !< If true, use an incorrect expression in the time + !! average of the gustless wind stress. + real :: C_p !< heat capacity of seawater [Q C-1 ~> J kg-1 degC-1]. + !! C_p is is the same value as in thermovar_ptrs_type. + + ! arrays needed in the some tracer modules, e.g., MOM_CFC_cap + real, pointer, dimension(:,:) :: & + ice_fraction => NULL(), & !< fraction of sea ice coverage at h-cells, from 0 to 1 [nondim]. + u10_sqr => NULL() !< wind magnitude at 10 m squared [L2 T-2 ~> m2 s-2] + + real, pointer, dimension(:,:) :: & + lamult => NULL() !< Langmuir enhancement factor [nondim] + + ! passive tracer surface fluxes + type(coupler_2d_bc_type) :: tr_fluxes !< This structure contains arrays of + !! of named fields used for passive tracer fluxes. + !! All arrays in tr_fluxes use the coupler indexing, which has no halos. + !! This is not a convenient convention, but imposed on MOM6 by the coupler. + + ! For internal error tracking + integer :: num_msg = 0 !< Number of messages issued about excessive SW penetration + integer :: max_msg = 2 !< Maximum number of messages to issue about excessive SW penetration + +end type forcing + +!> Structure that contains pointers to the mechanical forcing at the surface +!! used to drive the liquid ocean simulated by MOM. +!! Data in this type is allocated in the module MOM_surface_forcing.F90, +!! of which there are three versions: solo, coupled, and ice-shelf. +type, public :: mech_forcing + ! surface stress components and turbulent velocity scale + real, pointer, dimension(:,:) :: & + taux => NULL(), & !< zonal wind stress [R L Z T-2 ~> Pa] + tauy => NULL(), & !< meridional wind stress [R L Z T-2 ~> Pa] + tau_mag => NULL(), & !< Magnitude of the wind stress averaged over tracer cells, including any + !! contributions from sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] + ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. + net_mass_src => NULL() !< The net mass source to the ocean [R Z T-1 ~> kg m-2 s-1] + !omega_w2x => NULL() !< the counter-clockwise angle of the wind stress with respect + !! to the horizontal abscissa (x-coordinate) at tracer points [rad]. + + ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) + real, pointer, dimension(:,:) :: p_surf_full => NULL() + !< Pressure at the top ocean interface [R L2 T-2 ~> Pa]. + !! if there is sea-ice, then p_surf_flux is at ice-ocean interface + real, pointer, dimension(:,:) :: p_surf => NULL() + !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] as used to drive the ocean model. + !! If p_surf is limited, p_surf may be smaller than p_surf_full, otherwise they are the same. + real, pointer, dimension(:,:) :: p_surf_SSH => NULL() + !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] that is used in corrections + !! to the sea surface height field that is passed back to the calling routines. + !! p_surf_SSH may point to p_surf or to p_surf_full. + + ! iceberg related inputs + real, pointer, dimension(:,:) :: & + area_berg => NULL(), & !< fractional area of ocean surface covered by icebergs [nondim] + mass_berg => NULL() !< mass of icebergs per unit ocean area [R Z ~> kg m-2] + + ! land ice-shelf related inputs + real, pointer, dimension(:,:) :: frac_shelf_u => NULL() !< Fractional ice shelf coverage of u-cells, + !! nondimensional from 0 to 1 [nondim]. This is only associated if ice shelves are enabled, + !! and is exactly 0 away from shelves or on land. + real, pointer, dimension(:,:) :: frac_shelf_v => NULL() !< Fractional ice shelf coverage of v-cells, + !! nondimensional from 0 to 1 [nondim]. This is only associated if ice shelves are enabled, + !! and is exactly 0 away from shelves or on land. + real, pointer, dimension(:,:) :: & + rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at + !! u-points [L4 Z-1 T-1 ~> m3 s-1] + rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at + !! v-points [L4 Z-1 T-1 ~> m3 s-1] + real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes + !! have been averaged [T ~> s]. + logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. + logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere + !! and various types of ice needs to be accumulated, and the + !! surface pressure explicitly reset to zero at the driver level + !! when appropriate. + logical :: accumulate_rigidity = .false. !< If true, the rigidity due to various types of + !! ice needs to be accumulated, and the rigidity explicitly + !! reset to zero at the driver level when appropriate. + real, pointer, dimension(:) :: & + stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad Z-1 ~> rad m-1] + real, pointer, dimension(:,:,:) :: & + ustkb => NULL(), & !< Stokes Drift spectrum, zonal [L T-1 ~> m s-1] + !! Horizontal - u points + !! 3rd dimension - wavenumber + vstkb => NULL() !< Stokes Drift spectrum, meridional [L T-1 ~> m s-1] + !! Horizontal - v points + !! 3rd dimension - wavenumber + + logical :: initialized = .false. !< This indicates whether the appropriate arrays have been initialized. +end type mech_forcing + +!> Structure that defines the id handles for the forcing type +type, public :: forcing_diags + + !>@{ Forcing diagnostic handles + ! mass flux diagnostic handles + integer :: id_prcme = -1, id_evap = -1 + integer :: id_precip = -1, id_vprec = -1 + integer :: id_lprec = -1, id_fprec = -1 + integer :: id_lrunoff = -1, id_frunoff = -1 + integer :: id_net_massout = -1, id_net_massin = -1 + integer :: id_massout_flux = -1, id_massin_flux = -1 + integer :: id_seaice_melt = -1 + + ! global area integrated mass flux diagnostic handles + integer :: id_total_prcme = -1, id_total_evap = -1 + integer :: id_total_precip = -1, id_total_vprec = -1 + integer :: id_total_lprec = -1, id_total_fprec = -1 + integer :: id_total_lrunoff = -1, id_total_frunoff = -1 + integer :: id_total_net_massout = -1, id_total_net_massin = -1 + integer :: id_total_seaice_melt = -1 + + ! global area averaged mass flux diagnostic handles + integer :: id_prcme_ga = -1, id_evap_ga = -1 + integer :: id_lprec_ga = -1, id_fprec_ga= -1 + integer :: id_precip_ga = -1, id_vprec_ga= -1 + + ! heat flux diagnostic handles + integer :: id_net_heat_coupler = -1, id_net_heat_surface = -1 + integer :: id_sens = -1, id_LwLatSens = -1 + integer :: id_sw = -1, id_lw = -1 + integer :: id_sw_vis = -1, id_sw_nir = -1 + integer :: id_lat_evap = -1, id_lat_frunoff = -1 + integer :: id_lat = -1, id_lat_fprec = -1 + integer :: id_heat_content_lrunoff= -1, id_heat_content_frunoff = -1 + integer :: id_heat_content_lprec = -1, id_heat_content_fprec = -1 + integer :: id_heat_content_cond = -1, id_heat_content_surfwater= -1 + integer :: id_heat_content_evap = -1 + integer :: id_heat_content_vprec = -1, id_heat_content_massout = -1 + integer :: id_heat_added = -1, id_heat_content_massin = -1 + integer :: id_hfrainds = -1, id_hfrunoffds = -1 + integer :: id_seaice_melt_heat = -1 + + ! global area integrated heat flux diagnostic handles + integer :: id_total_net_heat_coupler = -1, id_total_net_heat_surface = -1 + integer :: id_total_sens = -1, id_total_LwLatSens = -1 + integer :: id_total_sw = -1, id_total_lw = -1 + integer :: id_total_lat_evap = -1, id_total_lat_frunoff = -1 + integer :: id_total_lat = -1, id_total_lat_fprec = -1 + integer :: id_total_heat_content_lrunoff= -1, id_total_heat_content_frunoff = -1 + integer :: id_total_heat_content_lprec = -1, id_total_heat_content_fprec = -1 + integer :: id_total_heat_content_cond = -1, id_total_heat_content_surfwater= -1 + integer :: id_total_heat_content_evap = -1 + integer :: id_total_heat_content_vprec = -1, id_total_heat_content_massout = -1 + integer :: id_total_heat_added = -1, id_total_heat_content_massin = -1 + integer :: id_total_seaice_melt_heat = -1 + + ! global area averaged heat flux diagnostic handles + integer :: id_net_heat_coupler_ga = -1, id_net_heat_surface_ga = -1 + integer :: id_sens_ga = -1, id_LwLatSens_ga = -1 + integer :: id_sw_ga = -1, id_lw_ga = -1 + integer :: id_lat_ga = -1 + + ! salt flux diagnostic handles + integer :: id_saltflux = -1 + integer :: id_saltFluxIn = -1 + integer :: id_saltFluxAdded = -1 + integer :: id_saltFluxBehind = -1 + + integer :: id_total_saltflux = -1 + integer :: id_total_saltFluxIn = -1 + integer :: id_total_saltFluxAdded = -1 + + integer :: id_vPrecGlobalAdj = -1 + integer :: id_vPrecGlobalScl = -1 + integer :: id_saltFluxGlobalAdj = -1 + integer :: id_saltFluxGlobalScl = -1 + integer :: id_netFWGlobalAdj = -1 + integer :: id_netFWGlobalScl = -1 + + ! momentum flux and forcing diagnostic handles + integer :: id_taux = -1 + integer :: id_tauy = -1 + integer :: id_ustar = -1 + !integer :: id_omega_w2x = -1 + integer :: id_tau_mag = -1 + integer :: id_psurf = -1 + integer :: id_TKE_tidal = -1 + integer :: id_buoy = -1 + + ! tracer surface flux related diagnostics handles + integer :: id_ice_fraction = -1 + integer :: id_u10_sqr = -1 + + ! iceberg diagnostic handles + integer :: id_ustar_berg = -1 + integer :: id_area_berg = -1 + integer :: id_mass_berg = -1 + + ! Iceberg + Ice shelf diagnostic handles + integer :: id_ustar_ice_cover = -1 + integer :: id_frac_ice_cover = -1 + ! wave forcing diagnostics handles. + integer :: id_lamult = -1 + !>@} + + integer :: id_clock_forcing = -1 !< CPU clock id + +end type forcing_diags + +contains + +!> This subroutine extracts fluxes from the surface fluxes type. It works on a j-row +!! for optimization purposes. The 2d (i,j) wrapper is the next subroutine below. +!! This routine multiplies fluxes by dt, so that the result is an accumulation of fluxes +!! over a time step. +subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & + FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent, & + h, T, netMassInOut, netMassOut, net_heat, net_salt, pen_SW_bnd, tv, & + aggregate_FW, nonpenSW, netmassInOut_rate, net_Heat_Rate, & + net_salt_rate, pen_sw_bnd_Rate) + + 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(forcing), intent(inout) :: fluxes !< structure containing pointers to possible + !! forcing fields. NULL unused fields. + type(optics_type), pointer :: optics !< pointer to optics + integer, intent(in) :: nsw !< number of bands of penetrating SW + integer, intent(in) :: j !< j-index to work on + real, intent(in) :: dt !< The time step for these fluxes [T ~> s] + real, intent(in) :: FluxRescaleDepth !< min ocean depth before fluxes + !! are scaled away [H ~> m or kg m-2] + logical, intent(in) :: useRiverHeatContent !< logical for river heat content + logical, intent(in) :: useCalvingHeatContent !< logical for calving heat content + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: T !< layer temperatures [C ~> degC] + real, dimension(SZI_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux + !! (if Bouss) of water in/out of ocean over + !! a time step [H ~> m or kg m-2] + real, dimension(SZI_(G)), intent(out) :: netMassOut !< net mass flux (non-Bouss) or volume flux + !! (if Bouss) of water leaving ocean surface + !! over a time step [H ~> m or kg m-2]. + !! netMassOut < 0 means mass leaves ocean. + real, dimension(SZI_(G)), intent(out) :: net_heat !< net heat at the surface accumulated over a + !! time step for coupler + restoring. + !! Exclude two terms from net_heat: + !! (1) downwelling (penetrative) SW, + !! (2) evaporation heat content, + !! (since do not yet know evap temperature). + !! [C H ~> degC m or degC kg m-2]. + real, dimension(SZI_(G)), intent(out) :: net_salt !< surface salt flux into the ocean + !! accumulated over a time step + !! [S H ~> ppt m or ppt kg m-2]. + real, dimension(max(1,nsw),G%isd:G%ied), intent(out) :: pen_SW_bnd !< penetrating SW flux, split into bands. + !! [C H ~> degC m or degC kg m-2] + !! and array size nsw x SZI_(G), where + !! nsw=number of SW bands in pen_SW_bnd. + !! This heat flux is not part of net_heat. + type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to available + !! thermodynamic fields. Used to keep + !! track of the heat flux associated with net + !! mass fluxes into the ocean. + logical, intent(in) :: aggregate_FW !< For determining how to aggregate forcing. + real, dimension(SZI_(G)), & + optional, intent(out) :: nonpenSW !< Non-penetrating SW used in net_heat + !! [C H ~> degC m or degC kg m-2]. + !! Summed over SW bands when diagnosing nonpenSW. + real, dimension(SZI_(G)), & + optional, intent(out) :: net_Heat_rate !< Rate of net surface heating + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + real, dimension(SZI_(G)), & + optional, intent(out) :: net_salt_rate !< Surface salt flux into the ocean + !! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1]. + real, dimension(SZI_(G)), & + optional, intent(out) :: netmassInOut_rate !< Rate of net mass flux into the ocean + !! [H T-1 ~> m s-1 or kg m-2 s-1]. + real, dimension(max(1,nsw),G%isd:G%ied), & + optional, intent(out) :: pen_sw_bnd_rate !< Rate of penetrative shortwave heating + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + + ! local + real :: htot(SZI_(G)) ! total ocean depth [H ~> m or kg m-2] + real :: Pen_sw_tot(SZI_(G)) ! sum across all bands of Pen_SW [C H ~> degC m or degC kg m-2]. + real :: pen_sw_tot_rate(SZI_(G)) ! Summed rate of shortwave heating across bands + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real :: Ih_limit ! inverse depth at which surface fluxes start to be limited + ! or 0 for no limiting [H-1 ~> m-1 or m2 kg-1] + real :: scale ! scale scales away fluxes if depth < FluxRescaleDepth [nondim] + real :: I_Cp ! 1.0 / C_p [C Q-1 ~> kg degC J-1] + real :: I_Cp_Hconvert ! Unit conversion factors divided by the heat capacity + ! [C H R-1 Z-1 Q-1 ~> degC m3 J-1 or kg degC J-1] + logical :: calculate_diags ! Indicate to calculate/update diagnostic arrays + logical :: do_enthalpy ! If true (default) enthalpy terms are computed in MOM6 + character(len=200) :: mesg + integer :: is, ie, nz, i, k, n + + logical :: do_NHR, do_NSR, do_NMIOR, do_PSWBR + + !BGR-Jul 5,2017{ + ! Initializes/sets logicals if 'rates' are requested + ! These factors are required for legacy reasons + ! and therefore computed only when optional outputs are requested + do_NHR = .false. + do_NSR = .false. + do_NMIOR = .false. + do_PSWBR = .false. + if (present(net_heat_rate)) do_NHR = .true. + if (present(net_salt_rate)) do_NSR = .true. + if (present(netmassinout_rate)) do_NMIOR = .true. + if (present(pen_sw_bnd_rate)) do_PSWBR = .true. + !}BGR + + ! GMM: by default heat content from mass entering and leaving the ocean (enthalpy) + ! is diagnosed in this subroutine. When heat_content_evap is associated, + ! the enthalpy terms are provided via coupler and, therefore, they do not need + ! to be computed again. + do_enthalpy = .true. + if (associated(fluxes%heat_content_evap)) do_enthalpy = .false. + + Ih_limit = 0.0 ; if (FluxRescaleDepth > 0.0) Ih_limit = 1.0 / FluxRescaleDepth + I_Cp = 1.0 / tv%C_p + I_Cp_Hconvert = 1.0 / (GV%H_to_RZ * tv%C_p) + + is = G%isc ; ie = G%iec ; nz = GV%ke + + calculate_diags = .true. + + ! error checking + + if (nsw > 0) then ; if (nsw /= optics_nbands(optics)) call MOM_error(WARNING, & + "mismatch in the number of bands of shortwave radiation in MOM_forcing_type extract_fluxes.") + endif + + if (.not.associated(fluxes%sw)) call MOM_error(FATAL, & + "MOM_forcing_type extractFluxes1d: fluxes%sw is not associated.") + + if (.not.associated(fluxes%lw)) call MOM_error(FATAL, & + "MOM_forcing_type extractFluxes1d: fluxes%lw is not associated.") + + if (.not.associated(fluxes%latent)) call MOM_error(FATAL, & + "MOM_forcing_type extractFluxes1d: fluxes%latent is not associated.") + + if (.not.associated(fluxes%sens)) call MOM_error(FATAL, & + "MOM_forcing_type extractFluxes1d: fluxes%sens is not associated.") + + if (.not.associated(fluxes%evap)) call MOM_error(FATAL, & + "MOM_forcing_type extractFluxes1d: No evaporation defined.") + + if (.not.associated(fluxes%vprec)) call MOM_error(FATAL, & + "MOM_forcing_type extractFluxes1d: fluxes%vprec not defined.") + + if ((.not.associated(fluxes%lprec)) .or. & + (.not.associated(fluxes%fprec))) call MOM_error(FATAL, & + "MOM_forcing_type extractFluxes1d: No precipitation defined.") + + do i=is,ie ; htot(i) = h(i,1) ; enddo + do k=2,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,k) ; enddo ; enddo + + if (nsw >= 1) then + call extract_optics_slice(optics, j, G, GV, penSW_top=Pen_SW_bnd) + if (do_PSWBR) call extract_optics_slice(optics, j, G, GV, penSW_top=Pen_SW_bnd_rate) + endif + + do i=is,ie + + scale = 1.0 ; if ((Ih_limit > 0.0) .and. (htot(i)*Ih_limit < 1.0)) scale = htot(i)*Ih_limit + + ! Convert the penetrating shortwave forcing to (C * H) and reduce fluxes for shallow depths. + ! (H=m for Bouss, H=kg/m2 for non-Bouss) + Pen_sw_tot(i) = 0.0 + if (nsw >= 1) then + do n=1,nsw + Pen_SW_bnd(n,i) = I_Cp_Hconvert*scale*dt * max(0.0, Pen_SW_bnd(n,i)) + Pen_sw_tot(i) = Pen_sw_tot(i) + Pen_SW_bnd(n,i) + enddo + else + Pen_SW_bnd(1,i) = 0.0 + endif + + if (do_PSWBR) then ! Repeat the above code w/ dt=1s for legacy reasons + pen_sw_tot_rate(i) = 0.0 + if (nsw >= 1) then + do n=1,nsw + Pen_SW_bnd_rate(n,i) = I_Cp_Hconvert*scale * max(0.0, Pen_SW_bnd_rate(n,i)) + pen_sw_tot_rate(i) = pen_sw_tot_rate(i) + pen_sw_bnd_rate(n,i) + enddo + else + pen_sw_bnd_rate(1,i) = 0.0 + endif + endif + + ! net volume/mass of liquid and solid passing through surface boundary fluxes + netMassInOut(i) = dt * (scale * & + (((((( fluxes%lprec(i,j) & + + fluxes%fprec(i,j) ) & + + fluxes%evap(i,j) ) & + + fluxes%lrunoff(i,j) ) & + + fluxes%vprec(i,j) ) & + + fluxes%seaice_melt(i,j)) & + + fluxes%frunoff(i,j) )) + + if (do_NMIOr) then ! Repeat the above code without multiplying by a timestep for legacy reasons + netMassInOut_rate(i) = (scale * & + (((((( fluxes%lprec(i,j) & + + fluxes%fprec(i,j) ) & + + fluxes%evap(i,j) ) & + + fluxes%lrunoff(i,j) ) & + + fluxes%vprec(i,j) ) & + + fluxes%seaice_melt(i,j)) & + + fluxes%frunoff(i,j) )) + endif + + ! smg: + ! for non-Bouss, we add/remove salt mass to total ocean mass. to conserve + ! total salt mass ocean+ice, the sea ice model must lose mass when salt mass + ! is added to the ocean, which may still need to be coded. Not that the units + ! of netMassInOut are still [Z R ~> kg m-2], so no conversion to H should occur yet. + if (.not.GV%Boussinesq .and. associated(fluxes%salt_flux)) then + netMassInOut(i) = netMassInOut(i) + dt * (scale * fluxes%salt_flux(i,j)) + if (do_NMIOr) netMassInOut_rate(i) = netMassInOut_rate(i) + & + (scale * fluxes%salt_flux(i,j)) + endif + + ! net volume/mass of water leaving the ocean. + ! check that fluxes are < 0, which means mass is indeed leaving. + netMassOut(i) = 0.0 + + ! evap > 0 means condensating water is added into ocean. + ! evap < 0 means evaporation of water from the ocean, in + ! which case heat_content_massout is computed in MOM_diabatic_driver.F90 + if (fluxes%evap(i,j) < 0.0) netMassOut(i) = netMassOut(i) + fluxes%evap(i,j) + ! if (associated(fluxes%heat_content_cond)) fluxes%heat_content_cond(i,j) = 0.0 !??? --AJA + + ! lprec < 0 means sea ice formation taking water from the ocean. + ! smg: we should split the ice melt/formation from the lprec + if (fluxes%lprec(i,j) < 0.0) netMassOut(i) = netMassOut(i) + fluxes%lprec(i,j) + + ! seaice_melt < 0 means sea ice formation taking water from the ocean. + if (fluxes%seaice_melt(i,j) < 0.0) netMassOut(i) = netMassOut(i) + fluxes%seaice_melt(i,j) + + ! vprec < 0 means virtual evaporation arising from surface salinity restoring, + ! in which case heat_content_vprec is computed in MOM_diabatic_driver.F90. + if (fluxes%vprec(i,j) < 0.0) netMassOut(i) = netMassOut(i) + fluxes%vprec(i,j) + + netMassOut(i) = dt * scale * netMassOut(i) + + ! convert to H units (Bouss=meter or non-Bouss=kg/m^2) + netMassInOut(i) = GV%RZ_to_H * netMassInOut(i) + if (do_NMIOr) netMassInOut_rate(i) = GV%RZ_to_H * netMassInOut_rate(i) + netMassOut(i) = GV%RZ_to_H * netMassOut(i) + + ! surface heat fluxes from radiation and turbulent fluxes (K * H) + ! (H=m for Bouss, H=kg/m2 for non-Bouss) + + ! CIME provides heat flux from snow&ice melt (seaice_melt_heat), so this is added below + ! Note: this term accounts for the enthalpy associated with water flux due to sea ice melting/freezing + if (associated(fluxes%seaice_melt_heat)) then + net_heat(i) = scale * dt * I_Cp_Hconvert * & + ( fluxes%sw(i,j) + (((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & + fluxes%seaice_melt_heat(i,j)) ) + !Repeats above code w/ dt=1. for legacy reason + if (do_NHR) net_heat_rate(i) = scale * I_Cp_Hconvert * & + ( fluxes%sw(i,j) + (((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & + fluxes%seaice_melt_heat(i,j))) + else + net_heat(i) = scale * dt * I_Cp_Hconvert * & + ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) + !Repeats above code w/ dt=1. for legacy reason + if (do_NHR) net_heat_rate(i) = scale * I_Cp_Hconvert * & + ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) + endif + + ! Add heat flux from surface damping (restoring) (K * H) or flux adjustments. + if (associated(fluxes%heat_added)) then + net_heat(i) = net_heat(i) + (scale * (dt * I_Cp_Hconvert)) * fluxes%heat_added(i,j) + if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * I_Cp_Hconvert) * fluxes%heat_added(i,j) + endif + + ! Add explicit heat flux for runoff (which is part of the ice-ocean boundary + ! flux type). Runoff is otherwise added with a temperature of SST. + if (useRiverHeatContent) then + ! remove lrunoff*SST here, to counteract its addition elsewhere + net_heat(i) = (net_heat(i) + (scale*(dt * I_Cp_Hconvert)) * fluxes%heat_content_lrunoff(i,j)) - & + (GV%RZ_to_H * (scale * dt)) * fluxes%lrunoff(i,j) * T(i,1) + !BGR-Jul 5, 2017{ + !Intentionally neglect the following contribution to rate for legacy reasons. + !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*I_Cp_Hconvert) * fluxes%heat_content_lrunoff(i,j)) - & + ! (GV%RZ_to_H * (scale)) * fluxes%lrunoff(i,j) * T(i,1) + !}BGR + if (calculate_diags .and. associated(tv%TempxPmE)) then + tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & + (I_Cp*fluxes%heat_content_lrunoff(i,j) - fluxes%lrunoff(i,j)*T(i,1)) + endif + endif + + ! Add explicit heat flux for calving (which is part of the ice-ocean boundary + ! flux type). Calving is otherwise added with a temperature of SST. + if (useCalvingHeatContent) then + ! remove frunoff*SST here, to counteract its addition elsewhere + net_heat(i) = net_heat(i) + (scale*(dt * I_Cp_Hconvert)) * fluxes%heat_content_frunoff(i,j) - & + (GV%RZ_to_H * (scale * dt)) * fluxes%frunoff(i,j) * T(i,1) + !BGR-Jul 5, 2017{ + !Intentionally neglect the following contribution to rate for legacy reasons. +! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*I_Cp_Hconvert) * fluxes%heat_content_frunoff(i,j) - & +! (GV%RZ_to_H * scale) * fluxes%frunoff(i,j) * T(i,1) + !}BGR + if (calculate_diags .and. associated(tv%TempxPmE)) then + tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & + (I_Cp*fluxes%heat_content_frunoff(i,j) - fluxes%frunoff(i,j)*T(i,1)) + endif + endif + +! smg: new code + ! add heat from all terms that may add mass to the ocean (K * H). + ! if evap, lprec, or vprec < 0, then compute their heat content + ! inside MOM_diabatic_driver.F90 and fill in fluxes%heat_content_massout. + ! we do so since we do not here know the temperature + ! of water leaving the ocean, as it could be leaving from more than + ! one layer of the upper ocean in the case of very thin layers. + ! When evap, lprec, or vprec > 0, then we know their heat content here + ! via settings from inside of the appropriate config_src driver files. +! if (associated(fluxes%heat_content_lprec)) then +! net_heat(i) = net_heat(i) + scale * dt * I_Cp_Hconvert * & +! (fluxes%heat_content_lprec(i,j) + (fluxes%heat_content_fprec(i,j) + & +! (fluxes%heat_content_lrunoff(i,j) + (fluxes%heat_content_frunoff(i,j) + & +! (fluxes%heat_content_cond(i,j) + fluxes%heat_content_vprec(i,j)))))) +! endif + + ! When enthalpy terms are provided via coupler, they must be included in net_heat + if (.not. do_enthalpy) then + net_heat(i) = net_heat(i) + (scale * dt * I_Cp_Hconvert * & + (fluxes%heat_content_lrunoff(i,j) + fluxes%heat_content_frunoff(i,j) + & + fluxes%heat_content_lprec(i,j) + fluxes%heat_content_fprec(i,j) + & + fluxes%heat_content_evap(i,j) + fluxes%heat_content_cond(i,j))) + endif + + if (fluxes%num_msg < fluxes%max_msg) then + if (Pen_SW_tot(i) > 1.000001 * I_Cp_Hconvert*scale*dt*fluxes%sw(i,j)) then + fluxes%num_msg = fluxes%num_msg + 1 + write(mesg,'("Penetrating shortwave of ",1pe17.10, & + &" exceeds total shortwave of ",1pe17.10,& + &" at ",1pg11.4,",E,",1pg11.4,"N.")') & + US%C_to_degC*Pen_SW_tot(i), US%C_to_degC*I_Cp_Hconvert*scale*dt * fluxes%sw(i,j), & + G%geoLonT(i,j), G%geoLatT(i,j) + call MOM_error(WARNING,mesg) + endif + endif + + ! remove penetrative portion of the SW that is NOT absorbed within a + ! tiny layer at the top of the ocean. + net_heat(i) = net_heat(i) - Pen_SW_tot(i) + !Repeat above code for 'rate' term + if (do_NHR) net_heat_rate(i) = net_heat_rate(i) - Pen_SW_tot_rate(i) + + ! diagnose non-downwelling SW + if (present(nonPenSW)) then + nonPenSW(i) = scale * dt * I_Cp_Hconvert * fluxes%sw(i,j) - Pen_SW_tot(i) + endif + + ! Salt fluxes + net_salt(i) = 0.0 + if (do_NSR) net_salt_rate(i) = 0.0 + ! Convert salt_flux from kg (salt)/(m^2 * s) to + ! Boussinesq: (ppt * m) + ! non-Bouss: (g/m^2) + if (associated(fluxes%salt_flux)) then + net_salt(i) = (scale * dt * (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j))) * GV%RZ_to_H + !Repeat above code for 'rate' term + if (do_NSR) net_salt_rate(i) = (scale * 1. * (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j))) * GV%RZ_to_H + endif + + ! Diagnostics follow... + if (calculate_diags .and. do_enthalpy) then + + ! Initialize heat_content_massin that is diagnosed in mixedlayer_convection or + ! applyBoundaryFluxes such that the meaning is as the sum of all incoming components. + if (associated(fluxes%heat_content_massin)) then + if (aggregate_FW) then + if (netMassInOut(i) > 0.0) then ! net is "in" + fluxes%heat_content_massin(i,j) = -tv%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt + else ! net is "out" + fluxes%heat_content_massin(i,j) = tv%C_p * ( netMassInout(i) - netMassOut(i) ) * & + T(i,1) * GV%H_to_RZ / dt + endif + else + fluxes%heat_content_massin(i,j) = 0. + endif + endif + + ! Initialize heat_content_massout that is diagnosed in mixedlayer_convection or + ! applyBoundaryFluxes such that the meaning is as the sum of all outgoing components. + if (associated(fluxes%heat_content_massout)) then + if (aggregate_FW) then + if (netMassInOut(i) > 0.0) then ! net is "in" + fluxes%heat_content_massout(i,j) = tv%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt + else ! net is "out" + fluxes%heat_content_massout(i,j) = -tv%C_p * ( netMassInout(i) - netMassOut(i) ) * & + T(i,1) * GV%H_to_RZ / dt + endif + else + fluxes%heat_content_massout(i,j) = 0.0 + endif + endif + + ! smg: we should remove sea ice melt from lprec!!! + ! fluxes%lprec > 0 means ocean gains mass via liquid precipitation and/or sea ice melt. + ! When atmosphere does not provide heat of this precipitation, the ocean assumes + ! it enters the ocean at the SST. + ! fluxes%lprec < 0 means ocean loses mass via sea ice formation. As we do not yet know + ! the layer at which this mass is removed, we cannot compute it heat content. We must + ! wait until MOM_diabatic_driver.F90. + if (associated(fluxes%heat_content_lprec)) then + if (fluxes%lprec(i,j) > 0.0) then + fluxes%heat_content_lprec(i,j) = tv%C_p*fluxes%lprec(i,j)*T(i,1) + else + fluxes%heat_content_lprec(i,j) = 0.0 + endif + endif + + ! fprec SHOULD enter ocean at 0degC if atmos model does not provide fprec heat content. + ! However, we need to adjust netHeat above to reflect the difference between 0decC and SST + ! and until we do so fprec is treated like lprec and enters at SST. -AJA + if (associated(fluxes%heat_content_fprec)) then + if (fluxes%fprec(i,j) > 0.0) then + fluxes%heat_content_fprec(i,j) = tv%C_p*fluxes%fprec(i,j)*T(i,1) + else + fluxes%heat_content_fprec(i,j) = 0.0 + endif + endif + + ! virtual precip associated with salinity restoring + ! vprec > 0 means add water to ocean, assumed to be at SST + ! vprec < 0 means remove water from ocean; set heat_content_vprec in MOM_diabatic_driver.F90 + if (associated(fluxes%heat_content_vprec)) then + if (fluxes%vprec(i,j) > 0.0) then + fluxes%heat_content_vprec(i,j) = tv%C_p*fluxes%vprec(i,j)*T(i,1) + else + fluxes%heat_content_vprec(i,j) = 0.0 + endif + endif + + ! fluxes%evap < 0 means ocean loses mass due to evaporation. + ! Evaporation leaves ocean surface at a temperature that has yet to be determined, + ! since we do not know the precise layer that the water evaporates. We therefore + ! compute fluxes%heat_content_massout at the relevant point inside MOM_diabatic_driver.F90. + ! fluxes%evap > 0 means ocean gains moisture via condensation. + ! Condensation is assumed to drop into the ocean at the SST, just like lprec. + if (associated(fluxes%heat_content_cond)) then + if (fluxes%evap(i,j) > 0.0) then + fluxes%heat_content_cond(i,j) = tv%C_p*fluxes%evap(i,j)*T(i,1) + else + fluxes%heat_content_cond(i,j) = 0.0 + endif + endif + + ! Liquid runoff enters ocean at SST if land model does not provide runoff heat content. + if (.not. useRiverHeatContent) then + if (associated(fluxes%lrunoff) .and. associated(fluxes%heat_content_lrunoff)) then + fluxes%heat_content_lrunoff(i,j) = tv%C_p*fluxes%lrunoff(i,j)*T(i,1) + endif + endif + + ! Icebergs enter ocean at SST if land model does not provide calving heat content. + if (.not. useCalvingHeatContent) then + if (associated(fluxes%frunoff) .and. associated(fluxes%heat_content_frunoff)) then + fluxes%heat_content_frunoff(i,j) = tv%C_p*fluxes%frunoff(i,j)*T(i,1) + endif + endif + + elseif (.not. do_enthalpy) then + + ! virtual precip associated with salinity restoring. Heat content associated with + ! that is *not* provided by the coupler and must be calculated by MOM6. + ! vprec > 0 means add water to ocean, assumed to be at SST + ! vprec < 0 means remove water from ocean; set heat_content_vprec in MOM_diabatic_driver.F90 + if (associated(fluxes%heat_content_vprec)) then + if (fluxes%vprec(i,j) > 0.0) then + fluxes%heat_content_vprec(i,j) = fluxes%C_p*fluxes%vprec(i,j)*T(i,1) + else + fluxes%heat_content_vprec(i,j) = 0.0 + endif + endif + + if (associated(tv%TempxPmE)) then + tv%TempxPmE(i,j) = (I_Cp*dt*scale) * & + (fluxes%heat_content_lprec(i,j) + & + fluxes%heat_content_fprec(i,j) + & + fluxes%heat_content_lrunoff(i,j) + & + fluxes%heat_content_frunoff(i,j) + & + fluxes%heat_content_evap(i,j) + & + fluxes%heat_content_cond(i,j)) + endif + + endif ! calculate_diags and do_enthalpy + + enddo ! i-loop + +end subroutine extractFluxes1d + + +!> 2d wrapper for 1d extract fluxes from surface fluxes type. +!! This subroutine extracts fluxes from the surface fluxes type. It multiplies the +!! fluxes by dt, so that the result is an accumulation of the fluxes over a time step. +subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, & + useRiverHeatContent, useCalvingHeatContent, h, T, & + netMassInOut, netMassOut, net_heat, Net_salt, Pen_SW_bnd, tv, & + aggregate_FW) + + 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(forcing), intent(inout) :: fluxes !< structure containing pointers to forcing. + type(optics_type), pointer :: optics !< pointer to optics + integer, intent(in) :: nsw !< number of bands of penetrating SW + real, intent(in) :: dt !< The time step for these fluxes [T ~> s] + real, intent(in) :: FluxRescaleDepth !< min ocean depth before fluxes + !! are scaled away [H ~> m or kg m-2] + logical, intent(in) :: useRiverHeatContent !< logical for river heat content + logical, intent(in) :: useCalvingHeatContent !< logical for calving heat content + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: T !< layer temperatures [C ~> degC] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux + !! (if Bouss) of water in/out of ocean over + !! a time step [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: netMassOut !< net mass flux (non-Bouss) or volume flux + !! (if Bouss) of water leaving ocean surface + !! over a time step [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_heat !< net heat at the surface accumulated over a + !! time step associated with coupler + restore. + !! Exclude two terms from net_heat: + !! (1) downwelling (penetrative) SW, + !! (2) evaporation heat content, + !! (since do not yet know temperature of evap). + !! [C H ~> degC m or degC kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_salt !< surface salt flux into the ocean accumulated + !! over a time step [S H ~> ppt m or ppt kg m-2] + real, dimension(max(1,nsw),G%isd:G%ied,G%jsd:G%jed), intent(out) :: pen_SW_bnd !< penetrating SW flux, by frequency + !! band [C H ~> degC m or degC kg m-2] with array + !! size nsw x SZI_(G), where nsw=number of SW bands + !! in pen_SW_bnd. This heat flux is not in net_heat. + type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to available + !! thermodynamic fields. Here it is used to keep + !! track of the heat flux associated with net + !! mass fluxes into the ocean. + logical, intent(in) :: aggregate_FW !< For determining how to aggregate the forcing. + + integer :: j + !$OMP parallel do default(shared) + do j=G%jsc, G%jec + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & + FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent,& + h(:,j,:), T(:,j,:), netMassInOut(:,j), netMassOut(:,j), & + net_heat(:,j), net_salt(:,j), pen_SW_bnd(:,:,j), tv, aggregate_FW) + enddo + +end subroutine extractFluxes2d + + +!> This routine calculates surface buoyancy flux by adding up the heat, FW & salt fluxes. +!! These are actual fluxes, with units of stuff per time. Setting dt=1 in the call to +!! extractFluxes routine allows us to get "stuf per time" rather than the time integrated +!! fluxes needed in other routines that call extractFluxes. +subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt, tv, j, & + buoyancyFlux, netHeatMinusSW, netSalt) + type(ocean_grid_type), intent(in) :: G !< ocean grid + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(forcing), intent(inout) :: fluxes !< surface fluxes + type(optics_type), pointer :: optics !< penetrating SW optics + integer, intent(in) :: nsw !< The number of frequency bands of + !! penetrating shortwave radiation + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Temp !< prognostic temp [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< salinity [S ~> ppt] + type(thermo_var_ptrs), intent(inout) :: tv !< thermodynamics type + integer, intent(in) :: j !< j-row to work on + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: buoyancyFlux !< buoyancy fluxes [L2 T-3 ~> m2 s-3] + real, dimension(SZI_(G)), intent(out) :: netHeatMinusSW !< Surface heat flux excluding shortwave + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real, dimension(SZI_(G)), intent(out) :: netSalt !< surface salt flux + !! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + + ! local variables + real, dimension(SZI_(G)) :: netH ! net FW flux [H T-1 ~> m s-1 or kg m-2 s-1] + real, dimension(SZI_(G)) :: netEvap ! net FW flux leaving ocean via evaporation + ! [H T-1 ~> m s-1 or kg m-2 s-1] + real, dimension(SZI_(G)) :: netHeat ! net temp flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real, dimension(SZI_(G), SZK_(GV)) :: dz ! Layer thicknesses in depth units [Z ~> m] + real, dimension(max(nsw,1), SZI_(G)) :: penSWbnd ! penetrating SW radiation by band + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real, dimension(SZI_(G)) :: pressure ! pressure at the surface [R L2 T-2 ~> Pa] + real, dimension(SZI_(G)) :: dRhodT ! density partial derivative wrt temp [R C-1 ~> kg m-3 degC-1] + real, dimension(SZI_(G)) :: dRhodS ! density partial derivative wrt saln [R S-1 ~> kg m-3 ppt-1] + real, dimension(SZI_(G)) :: dSpV_dT ! Partial derivative of specific volume with respect + ! to temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)) :: dSpV_dS ! Partial derivative of specific volume with respect + ! to salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + real, dimension(SZI_(G),SZK_(GV)+1) :: netPen ! The net penetrating shortwave radiation at each level + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + + logical :: useRiverHeatContent + logical :: useCalvingHeatContent + real :: GoRho ! The gravitational acceleration divided by mean density times a + ! unit conversion factor [L2 H-1 R-1 T-2 ~> m4 kg-1 s-2 or m7 kg-2 s-2] + real :: g_conv ! The gravitational acceleration times the conversion factors from non-Boussinesq + ! thickness units to mass per units area [R L2 H-1 T-2 ~> kg m-2 s-2 or m s-2] + real :: H_limit_fluxes ! A depth scale that specifies when the ocean is shallow that + ! it is necessary to eliminate fluxes [H ~> m or kg m-2] + integer :: i, k + + ! smg: what do we do when have heat fluxes from calving and river? + useRiverHeatContent = .False. + useCalvingHeatContent = .False. + + H_limit_fluxes = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) + + ! The surface forcing is contained in the fluxes type. + ! We aggregate the thermodynamic forcing for a time step into the following: + ! netH = water added/removed via surface fluxes [H T-1 ~> m s-1 or kg m-2 s-1] + ! netHeat = heat via surface fluxes [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + ! netSalt = salt via surface fluxes [S H T-1 ~> ppt m s-1 or gSalt m-2 s-1] + ! Note that unlike other calls to extractFLuxes1d() that return the time-integrated flux + ! this call returns the rate because dt=1 (in arbitrary time units) + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, 1.0, & + H_limit_fluxes, useRiverHeatContent, useCalvingHeatContent, & + h(:,j,:), Temp(:,j,:), netH, netEvap, netHeatMinusSW, & + netSalt, penSWbnd, tv, .false.) + + ! Sum over bands and attenuate as a function of depth + ! netPen is the netSW as a function of depth + call thickness_to_dz(h, tv, dz, j, G, GV) + call sumSWoverBands(G, GV, US, h(:,j,:), dz, optics_nbands(optics), optics, j, 1.0, & + H_limit_fluxes, .true., penSWbnd, netPen) + + ! Adjust netSalt to reflect dilution effect of FW flux + ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) + + ! Add in the SW heating for purposes of calculating the net + ! surface buoyancy flux affecting the top layer. + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + !netHeat(:) = netHeatMinusSW(:) + sum( penSWbnd, dim=1 ) + netHeat(G%isc:G%iec) = netHeatMinusSW(G%isc:G%iec) + netPen(G%isc:G%iec,1) + + ! Determine the buoyancy flux + pressure(:) = 0. + if (associated(tv%p_surf)) then ; do i=G%isc,G%iec ; pressure(i) = tv%p_surf(i,j) ; enddo ; endif + + if ((.not.GV%Boussinesq) .and. (.not.GV%semi_Boussinesq)) then + g_conv = GV%g_Earth * GV%H_to_RZ + + ! Specific volume derivatives + call calculate_specific_vol_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, EOS_domain(G%HI)) + + ! Convert to a buoyancy flux [L2 T-3 ~> m2 s-3], first excluding penetrating SW heating + do i=G%isc,G%iec + buoyancyFlux(i,1) = g_conv * (dSpV_dS(i) * netSalt(i) + dSpV_dT(i) * netHeat(i)) + enddo + ! We also have a penetrative buoyancy flux associated with penetrative SW + do k=2,GV%ke+1 ; do i=G%isc,G%iec + buoyancyFlux(i,k) = g_conv * ( dSpV_dT(i) * netPen(i,k) ) ! [L2 T-3 ~> m2 s-3] + enddo ; enddo + else + GoRho = (GV%g_Earth * GV%H_to_Z) / GV%Rho0 + + ! Density derivatives + call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, & + tv%eqn_of_state, EOS_domain(G%HI)) + + ! Convert to a buoyancy flux [L2 T-3 ~> m2 s-3], excluding penetrating SW heating + do i=G%isc,G%iec + buoyancyFlux(i,1) = - GoRho * ( dRhodS(i) * netSalt(i) + dRhodT(i) * netHeat(i) ) + enddo + ! We also have a penetrative buoyancy flux associated with penetrative SW + do k=2,GV%ke+1 ; do i=G%isc,G%iec + buoyancyFlux(i,k) = - GoRho * ( dRhodT(i) * netPen(i,k) ) ! [L2 T-3 ~> m2 s-3] + enddo ; enddo + endif + +end subroutine calculateBuoyancyFlux1d + + +!> Calculates surface buoyancy flux by adding up the heat, FW and salt fluxes, +!! for 2d arrays. This is a wrapper for calculateBuoyancyFlux1d. +subroutine calculateBuoyancyFlux2d(G, GV, US, fluxes, optics, h, Temp, Salt, tv, & + buoyancyFlux, netHeatMinusSW, netSalt) + type(ocean_grid_type), intent(in) :: G !< ocean grid + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(forcing), intent(inout) :: fluxes !< surface fluxes + type(optics_type), pointer :: optics !< SW ocean optics + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Temp !< temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< salinity [S ~> ppt] + type(thermo_var_ptrs), intent(inout) :: tv !< thermodynamics type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: buoyancyFlux !< buoyancy fluxes [L2 T-3 ~> m2 s-3] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: netHeatMinusSW !< surface heat flux excluding shortwave + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: netSalt !< Net surface salt flux + !! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + + ! local variables + integer :: j + + !$OMP parallel do default(shared) + do j=G%jsc,G%jec + call calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, optics_nbands(optics), h, Temp, Salt, & + tv, j, buoyancyFlux(:,j,:), netHeatMinusSW(:,j), netSalt(:,j)) + enddo + +end subroutine calculateBuoyancyFlux2d + + +!> Determine the friction velocity from the contenxts of a forcing type, perhaps +!! using the evolving surface density. +subroutine find_ustar_fluxes(fluxes, tv, U_star, G, GV, US, halo, H_T_units) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(forcing), intent(in) :: fluxes !< Surface fluxes container + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: U_star !< The surface friction velocity [Z T-1 ~> m s-1] or + !! [H T-1 ~> m s-1 or kg m-2 s-1], depending on H_T_units. + integer, optional, intent(in) :: halo !< The extra halo size to fill in, 0 by default + logical, optional, intent(in) :: H_T_units !< If present and true, return U_star in units + !! of [H T-1 ~> m s-1 or kg m-2 s-1] + + ! Local variables + real :: I_rho ! The inverse of the reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] or in some semi-Boussinesq cases + ! the rescaled reference density [H2 Z-1 L-1 R-1 ~> m3 kg-1 or kg m-3] + logical :: Z_T_units ! If true, U_star is returned in units of [Z T-1 ~> m s-1], otherwise it is + ! returned in [H T-1 ~> m s-1 or kg m-2 s-1] + integer :: i, j, k, is, ie, js, je, hs + + hs = 0 ; if (present(halo)) hs = max(halo, 0) + is = G%isc - hs ; ie = G%iec + hs ; js = G%jsc - hs ; je = G%jec + hs + + Z_T_units = .true. ; if (present(H_T_units)) Z_T_units = .not.H_T_units + + if (.not.(associated(fluxes%ustar) .or. associated(fluxes%tau_mag))) & + call MOM_error(FATAL, "find_ustar_fluxes requires that either ustar or tau_mag be associated.") + + if (associated(fluxes%ustar) .and. (GV%Boussinesq .or. .not.associated(fluxes%tau_mag))) then + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = fluxes%ustar(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%Z_to_H * fluxes%ustar(i,j) + enddo ; enddo + endif + elseif (allocated(tv%SpV_avg)) then + if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & + "find_ustar_fluxes called in non-Boussinesq mode with invalid values of SpV_avg.") + if (tv%valid_SpV_halo < hs) call MOM_error(FATAL, & + "find_ustar_fluxes called in non-Boussinesq mode with insufficient valid values of SpV_avg.") + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(US%L_to_Z*fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%RZ_to_H * sqrt(US%L_to_Z*fluxes%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + enddo ; enddo + endif + else + I_rho = US%L_to_Z * GV%Z_to_H * GV%RZ_to_H + if (Z_T_units) I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(fluxes%tau_mag(i,j) * I_rho) + enddo ; enddo + endif + +end subroutine find_ustar_fluxes + + +!> Determine the friction velocity from the contenxts of a forcing type, perhaps +!! using the evolving surface density. +subroutine find_ustar_mech_forcing(forces, tv, U_star, G, GV, US, halo, H_T_units) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(mech_forcing), intent(in) :: forces !< Surface forces container + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: U_star !< The surface friction velocity [Z T-1 ~> m s-1] + integer, optional, intent(in) :: halo !< The extra halo size to fill in, 0 by default + logical, optional, intent(in) :: H_T_units !< If present and true, return U_star in units + !! of [H T-1 ~> m s-1 or kg m-2 s-1] + + ! Local variables + real :: I_rho ! The inverse of the reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] or in some semi-Boussinesq cases + ! the rescaled reference density [H2 Z-1 L-1 R-1 ~> m3 kg-1 or kg m-3] + logical :: Z_T_units ! If true, U_star is returned in units of [Z T-1 ~> m s-1], otherwise it is + ! returned in [H T-1 ~> m s-1 or kg m-2 s-1] + integer :: i, j, k, is, ie, js, je, hs + + hs = 0 ; if (present(halo)) hs = max(halo, 0) + is = G%isc - hs ; ie = G%iec + hs ; js = G%jsc - hs ; je = G%jec + hs + + Z_T_units = .true. ; if (present(H_T_units)) Z_T_units = .not.H_T_units + + if (.not.(associated(forces%ustar) .or. associated(forces%tau_mag))) & + call MOM_error(FATAL, "find_ustar_mech requires that either ustar or tau_mag be associated.") + + if (associated(forces%ustar) .and. (GV%Boussinesq .or. .not.associated(forces%tau_mag))) then + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = forces%ustar(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%Z_to_H * forces%ustar(i,j) + enddo ; enddo + endif + elseif (allocated(tv%SpV_avg)) then + if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & + "find_ustar_mech called in non-Boussinesq mode with invalid values of SpV_avg.") + if (tv%valid_SpV_halo < hs) call MOM_error(FATAL, & + "find_ustar_mech called in non-Boussinesq mode with insufficient valid values of SpV_avg.") + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(US%L_to_Z*forces%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%RZ_to_H * sqrt(US%L_to_Z*forces%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + enddo ; enddo + endif + else + I_rho = US%L_to_Z * GV%Z_to_H * GV%RZ_to_H + if (Z_T_units) I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(forces%tau_mag(i,j) * I_rho) + enddo ; enddo + endif + +end subroutine find_ustar_mech_forcing + + +!> Write out chksums for thermodynamic fluxes. +subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) + character(len=*), intent(in) :: mesg !< message + type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields + type(ocean_grid_type), intent(in) :: G !< grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, optional, intent(in) :: haloshift !< shift in halo + + integer :: hshift + + hshift = 1 ; if (present(haloshift)) hshift = haloshift + + ! Note that for the chksum calls to be useful for reproducing across PE + ! counts, there must be no redundant points, so all variables use is..ie + ! and js...je as their extent. + if (associated(fluxes%ustar)) & + call hchksum(fluxes%ustar, mesg//" fluxes%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + if (associated(fluxes%tau_mag)) & + call hchksum(fluxes%tau_mag, mesg//" fluxes%tau_mag", G%HI, haloshift=hshift, scale=US%RLZ_T2_to_Pa) + if (associated(fluxes%buoy)) & + call hchksum(fluxes%buoy, mesg//" fluxes%buoy ", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**3) + if (associated(fluxes%sw)) & + call hchksum(fluxes%sw, mesg//" fluxes%sw", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%sw_vis_dir)) & + call hchksum(fluxes%sw_vis_dir, mesg//" fluxes%sw_vis_dir", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%sw_vis_dif)) & + call hchksum(fluxes%sw_vis_dif, mesg//" fluxes%sw_vis_dif", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%sw_nir_dir)) & + call hchksum(fluxes%sw_nir_dir, mesg//" fluxes%sw_nir_dir", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%sw_nir_dif)) & + call hchksum(fluxes%sw_nir_dif, mesg//" fluxes%sw_nir_dif", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%lw)) & + call hchksum(fluxes%lw, mesg//" fluxes%lw", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%latent)) & + call hchksum(fluxes%latent, mesg//" fluxes%latent", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%latent_evap_diag)) & + call hchksum(fluxes%latent_evap_diag, mesg//" fluxes%latent_evap_diag", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%latent_fprec_diag)) & + call hchksum(fluxes%latent_fprec_diag, mesg//" fluxes%latent_fprec_diag", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%latent_frunoff_diag)) & + call hchksum(fluxes%latent_frunoff_diag, mesg//" fluxes%latent_frunoff_diag", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%sens)) & + call hchksum(fluxes%sens, mesg//" fluxes%sens", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%evap)) & + call hchksum(fluxes%evap, mesg//" fluxes%evap", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%lprec)) & + call hchksum(fluxes%lprec, mesg//" fluxes%lprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%fprec)) & + call hchksum(fluxes%fprec, mesg//" fluxes%fprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%vprec)) & + call hchksum(fluxes%vprec, mesg//" fluxes%vprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%seaice_melt)) & + call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%seaice_melt_heat)) & + call hchksum(fluxes%seaice_melt_heat, mesg//" fluxes%seaice_melt_heat", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%p_surf)) & + call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf", G%HI, haloshift=hshift, scale=US%RL2_T2_to_Pa) + if (associated(fluxes%u10_sqr)) & + call hchksum(fluxes%u10_sqr, mesg//" fluxes%u10_sqr", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**2) + if (associated(fluxes%ice_fraction)) & + call hchksum(fluxes%ice_fraction, mesg//" fluxes%ice_fraction", G%HI, haloshift=hshift) + if (associated(fluxes%salt_flux)) & + call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%TKE_tidal)) & + call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal", G%HI, haloshift=hshift, scale=US%RZ3_T3_to_W_m2) + if (associated(fluxes%ustar_tidal)) & + call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + if (associated(fluxes%lrunoff)) & + call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%frunoff)) & + call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%heat_content_lrunoff)) & + call hchksum(fluxes%heat_content_lrunoff, mesg//" fluxes%heat_content_lrunoff", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_frunoff)) & + call hchksum(fluxes%heat_content_frunoff, mesg//" fluxes%heat_content_frunoff", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_lprec)) & + call hchksum(fluxes%heat_content_lprec, mesg//" fluxes%heat_content_lprec", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_fprec)) & + call hchksum(fluxes%heat_content_fprec, mesg//" fluxes%heat_content_fprec", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_cond)) & + call hchksum(fluxes%heat_content_cond, mesg//" fluxes%heat_content_cond", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_evap)) & + call hchksum(fluxes%heat_content_evap, mesg//" fluxes%heat_content_evap", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_massout)) & + call hchksum(fluxes%heat_content_massout, mesg//" fluxes%heat_content_massout", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_massin)) & + call hchksum(fluxes%heat_content_massin, mesg//" fluxes%heat_content_massin", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) +end subroutine MOM_forcing_chksum + +!> Write out chksums for the driving mechanical forces. +subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) + character(len=*), intent(in) :: mesg !< message + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(ocean_grid_type), intent(in) :: G !< grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, optional, intent(in) :: haloshift !< shift in halo + + integer :: hshift + + hshift = 1 ; if (present(haloshift)) hshift = haloshift + + ! Note that for the chksum calls to be useful for reproducing across PE + ! counts, there must be no redundant points, so all variables use is..ie + ! and js...je as their extent. + if (associated(forces%taux) .and. associated(forces%tauy)) & + call uvchksum(mesg//" forces%tau[xy]", forces%taux, forces%tauy, G%HI, & + haloshift=hshift, symmetric=.true., scale=US%RLZ_T2_to_Pa) + if (associated(forces%p_surf)) & + call hchksum(forces%p_surf, mesg//" forces%p_surf", G%HI, haloshift=hshift, scale=US%RL2_T2_to_Pa) + if (associated(forces%ustar)) & + call hchksum(forces%ustar, mesg//" forces%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + if (associated(forces%tau_mag)) & + call hchksum(forces%tau_mag, mesg//" forces%tau_mag", G%HI, haloshift=hshift, scale=US%RLZ_T2_to_Pa) + if (associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)) & + call uvchksum(mesg//" forces%rigidity_ice_[uv]", forces%rigidity_ice_u, & + forces%rigidity_ice_v, G%HI, haloshift=hshift, symmetric=.true., & + scale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) + +end subroutine MOM_mech_forcing_chksum + +!> Write out values of the mechanical forcing arrays at the i,j location. This is a debugging tool. +subroutine mech_forcing_SinglePointPrint(forces, G, i, j, mesg) + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(ocean_grid_type), intent(in) :: G !< Grid type + character(len=*), intent(in) :: mesg !< Message + integer, intent(in) :: i !< i-index + integer, intent(in) :: j !< j-index + + write(0,'(2a)') 'MOM_forcing_type, forcing_SinglePointPrint: Called from ',mesg + write(0,'(a,2es15.3)') 'MOM_forcing_type, forcing_SinglePointPrint: lon,lat = ',G%geoLonT(i,j),G%geoLatT(i,j) + call locMsg(forces%taux,'taux') + call locMsg(forces%tauy,'tauy') + + contains + !> Format and write a message depending on associated state of array + subroutine locMsg(array,aname) + real, dimension(:,:), pointer :: array !< Array to write element from + character(len=*) :: aname !< Name of array + + if (associated(array)) then + write(0,'(3a,es15.3)') 'MOM_forcing_type, mech_forcing_SinglePointPrint: ',trim(aname),' = ',array(i,j) + else + write(0,'(4a)') 'MOM_forcing_type, mech_forcing_SinglePointPrint: ',trim(aname),' is not associated.' + endif + end subroutine locMsg + +end subroutine mech_forcing_SinglePointPrint + +!> Write out values of the fluxes arrays at the i,j location. This is a debugging tool. +subroutine forcing_SinglePointPrint(fluxes, G, i, j, mesg) + type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields + type(ocean_grid_type), intent(in) :: G !< Grid type + character(len=*), intent(in) :: mesg !< Message + integer, intent(in) :: i !< i-index + integer, intent(in) :: j !< j-index + + write(0,'(2a)') 'MOM_forcing_type, forcing_SinglePointPrint: Called from ',mesg + write(0,'(a,2es15.3)') 'MOM_forcing_type, forcing_SinglePointPrint: lon,lat = ',G%geoLonT(i,j),G%geoLatT(i,j) + call locMsg(fluxes%ustar,'ustar') + call locMsg(fluxes%tau_mag,'tau_mag') + call locMsg(fluxes%buoy,'buoy') + call locMsg(fluxes%sw,'sw') + call locMsg(fluxes%sw_vis_dir,'sw_vis_dir') + call locMsg(fluxes%sw_vis_dif,'sw_vis_dif') + call locMsg(fluxes%sw_nir_dir,'sw_nir_dir') + call locMsg(fluxes%sw_nir_dif,'sw_nir_dif') + call locMsg(fluxes%lw,'lw') + call locMsg(fluxes%latent,'latent') + call locMsg(fluxes%latent_evap_diag,'latent_evap_diag') + call locMsg(fluxes%latent_fprec_diag,'latent_fprec_diag') + call locMsg(fluxes%latent_frunoff_diag,'latent_frunoff_diag') + call locMsg(fluxes%sens,'sens') + call locMsg(fluxes%evap,'evap') + call locMsg(fluxes%lprec,'lprec') + call locMsg(fluxes%fprec,'fprec') + call locMsg(fluxes%vprec,'vprec') + call locMsg(fluxes%seaice_melt,'seaice_melt') + call locMsg(fluxes%seaice_melt_heat,'seaice_melt_heat') + call locMsg(fluxes%p_surf,'p_surf') + call locMsg(fluxes%salt_flux,'salt_flux') + call locMsg(fluxes%TKE_tidal,'TKE_tidal') + call locMsg(fluxes%ustar_tidal,'ustar_tidal') + call locMsg(fluxes%lrunoff,'lrunoff') + call locMsg(fluxes%frunoff,'frunoff') + call locMsg(fluxes%heat_content_lrunoff,'heat_content_lrunoff') + call locMsg(fluxes%heat_content_frunoff,'heat_content_frunoff') + call locMsg(fluxes%heat_content_lprec,'heat_content_lprec') + call locMsg(fluxes%heat_content_fprec,'heat_content_fprec') + call locMsg(fluxes%heat_content_vprec,'heat_content_vprec') + call locMsg(fluxes%heat_content_cond,'heat_content_cond') + call locMsg(fluxes%heat_content_cond,'heat_content_massout') + call locMsg(fluxes%heat_content_evap,'heat_content_evap') + call locMsg(fluxes%heat_content_massout,'heat_content_massout') + call locMsg(fluxes%heat_content_massin,'heat_content_massin') + + contains + !> Format and write a message depending on associated state of array + subroutine locMsg(array,aname) + real, dimension(:,:), pointer :: array !< Array to write element from + character(len=*) :: aname !< Name of array + + if (associated(array)) then + write(0,'(3a,es15.3)') 'MOM_forcing_type, forcing_SinglePointPrint: ',trim(aname),' = ',array(i,j) + else + write(0,'(4a)') 'MOM_forcing_type, forcing_SinglePointPrint: ',trim(aname),' is not associated.' + endif + end subroutine locMsg + +end subroutine forcing_SinglePointPrint + + +!> Register members of the forcing type for diagnostics +subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, use_berg_fluxes, use_waves, use_cfcs) + type(time_type), intent(in) :: Time !< time type + type(diag_ctrl), intent(inout) :: diag !< diagnostic control type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: use_temperature !< True if T/S are in use + type(forcing_diags), intent(inout) :: handles !< handles for diagnostics + logical, optional, intent(in) :: use_berg_fluxes !< If true, allow iceberg flux diagnostics + logical, optional, intent(in) :: use_waves !< If true, allow wave forcing diagnostics + logical, optional, intent(in) :: use_cfcs !< If true, allow cfc related diagnostics + + ! Clock for forcing diagnostics + handles%id_clock_forcing=cpu_clock_id('(Ocean forcing diagnostics)', grain=CLOCK_ROUTINE) + + + handles%id_taux = register_diag_field('ocean_model', 'taux', diag%axesCu1, Time, & + 'Zonal surface stress from ocean interactions with atmos and ice', & + 'Pa', conversion=US%RLZ_T2_to_Pa, & + standard_name='surface_downward_x_stress', cmor_field_name='tauuo', & + cmor_units='N m-2', cmor_long_name='Surface Downward X Stress', & + cmor_standard_name='surface_downward_x_stress') + + handles%id_tauy = register_diag_field('ocean_model', 'tauy', diag%axesCv1, Time, & + 'Meridional surface stress ocean interactions with atmos and ice', & + 'Pa', conversion=US%RLZ_T2_to_Pa, & + standard_name='surface_downward_y_stress', cmor_field_name='tauvo', & + cmor_units='N m-2', cmor_long_name='Surface Downward Y Stress', & + cmor_standard_name='surface_downward_y_stress') + + handles%id_tau_mag = register_diag_field('ocean_model', 'tau_mag', diag%axesT1, Time, & + 'Average magnitude of the wind stress including contributions from gustiness', & + 'Pa', conversion=US%RLZ_T2_to_Pa) + + handles%id_ustar = register_diag_field('ocean_model', 'ustar', diag%axesT1, Time, & + 'Surface friction velocity = [(gustiness + tau_magnitude)/rho0]^(1/2)', & + 'm s-1', conversion=US%Z_to_m*US%s_to_T) + + !handles%id_omega_w2x = register_diag_field('ocean_model', 'omega_w2x', diag%axesT1, Time, & + ! 'Counter-clockwise angle of the wind stress from the horizontal axis.', 'rad') + + if (present(use_berg_fluxes)) then + if (use_berg_fluxes) then + handles%id_ustar_berg = register_diag_field('ocean_model', 'ustar_berg', diag%axesT1, Time, & + 'Friction velocity below iceberg ', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + + handles%id_area_berg = register_diag_field('ocean_model', 'area_berg', diag%axesT1, Time, & + 'Area of grid cell covered by iceberg ', 'm2 m-2') + + handles%id_mass_berg = register_diag_field('ocean_model', 'mass_berg', diag%axesT1, Time, & + 'Mass of icebergs ', 'kg m-2', conversion=US%RZ_to_kg_m2) + + handles%id_ustar_ice_cover = register_diag_field('ocean_model', 'ustar_ice_cover', diag%axesT1, Time, & + 'Friction velocity below iceberg and ice shelf together', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + + handles%id_frac_ice_cover = register_diag_field('ocean_model', 'frac_ice_cover', diag%axesT1, Time, & + 'Area of grid cell below iceberg and ice shelf together ', 'm2 m-2') + endif + endif + + ! See: + if (present(use_cfcs)) then + if (use_cfcs) then + handles%id_ice_fraction = register_diag_field('ocean_model', 'ice_fraction', diag%axesT1, Time, & + 'Fraction of cell area covered by sea ice', 'm2 m-2') + + handles%id_u10_sqr = register_diag_field('ocean_model', 'u10_sqr', diag%axesT1, Time, & + 'Wind magnitude at 10m, squared', 'm2 s-2', conversion=US%L_to_m**2*US%s_to_T**2) + endif + endif + + handles%id_psurf = register_diag_field('ocean_model', 'p_surf', diag%axesT1, Time, & + 'Pressure at ice-ocean or atmosphere-ocean interface', & + 'Pa', conversion=US%RL2_T2_to_Pa, cmor_field_name='pso', & + cmor_long_name='Sea Water Pressure at Sea Water Surface', & + cmor_standard_name='sea_water_pressure_at_sea_water_surface') + + handles%id_TKE_tidal = register_diag_field('ocean_model', 'TKE_tidal', diag%axesT1, Time, & + 'Tidal source of BBL mixing', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + + if (.not. use_temperature) then + handles%id_buoy = register_diag_field('ocean_model', 'buoy', diag%axesT1, Time, & + 'Buoyancy forcing', 'm2 s-3', conversion=US%L_to_m**2*US%s_to_T**3) + return + endif + + + !=============================================================== + ! surface mass flux maps + + handles%id_prcme = register_diag_field('ocean_model', 'PRCmE', diag%axesT1, Time, & + 'Net surface water flux (precip+melt+lrunoff+ice calving-evap)', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_flux_into_sea_water', cmor_field_name='wfo', & + cmor_standard_name='water_flux_into_sea_water',cmor_long_name='Water Flux Into Sea Water') + + handles%id_evap = register_diag_field('ocean_model', 'evap', diag%axesT1, Time, & + 'Evaporation/condensation at ocean surface (evaporation is negative)', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_evaporation_flux', cmor_field_name='evs', & + cmor_standard_name='water_evaporation_flux', & + cmor_long_name='Water Evaporation Flux Where Ice Free Ocean over Sea') + + ! smg: seaice_melt field requires updates to the sea ice model + handles%id_seaice_melt = register_diag_field('ocean_model', 'seaice_melt', & + diag%axesT1, Time, 'water flux to ocean from snow/sea ice melting(> 0) or formation(< 0)', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics', & + cmor_field_name='fsitherm', & + cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics',& + cmor_long_name='water flux to ocean from sea ice melt(> 0) or form(< 0)') + + handles%id_precip = register_diag_field('ocean_model', 'precip', diag%axesT1, Time, & + 'Liquid + frozen precipitation into ocean', 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + + handles%id_fprec = register_diag_field('ocean_model', 'fprec', diag%axesT1, Time, & + 'Frozen precipitation into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='snowfall_flux', cmor_field_name='prsn', & + cmor_standard_name='snowfall_flux', cmor_long_name='Snowfall Flux where Ice Free Ocean over Sea') + + handles%id_lprec = register_diag_field('ocean_model', 'lprec', diag%axesT1, Time, & + 'Liquid precipitation into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='rainfall_flux', & + cmor_field_name='prlq', cmor_standard_name='rainfall_flux', & + cmor_long_name='Rainfall Flux where Ice Free Ocean over Sea') + + handles%id_vprec = register_diag_field('ocean_model', 'vprec', diag%axesT1, Time, & + 'Virtual liquid precip into ocean due to SSS restoring', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + + handles%id_frunoff = register_diag_field('ocean_model', 'frunoff', diag%axesT1, Time, & + 'Frozen runoff (calving) and iceberg melt into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_flux_into_sea_water_from_icebergs', & + cmor_field_name='ficeberg', & + cmor_standard_name='water_flux_into_sea_water_from_icebergs', & + cmor_long_name='Water Flux into Seawater from Icebergs') + + handles%id_lrunoff = register_diag_field('ocean_model', 'lrunoff', diag%axesT1, Time, & + 'Liquid runoff (rivers) into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_flux_into_sea_water_from_rivers', cmor_field_name='friver', & + cmor_standard_name='water_flux_into_sea_water_from_rivers', & + cmor_long_name='Water Flux into Sea Water From Rivers') + + handles%id_net_massout = register_diag_field('ocean_model', 'net_massout', diag%axesT1, Time, & + 'Net mass leaving the ocean due to evaporation, seaice formation', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + + handles%id_net_massin = register_diag_field('ocean_model', 'net_massin', diag%axesT1, Time, & + 'Net mass entering ocean due to precip, runoff, ice melt', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + + handles%id_massout_flux = register_diag_field('ocean_model', 'massout_flux', diag%axesT1, Time, & + 'Net mass flux of freshwater out of the ocean (used in the boundary flux calculation)', & + 'kg m-2', conversion=diag%GV%H_to_kg_m2) + + handles%id_massin_flux = register_diag_field('ocean_model', 'massin_flux', diag%axesT1, Time, & + 'Net mass flux of freshwater into the ocean (used in boundary flux calculation)', & + 'kg m-2', conversion=diag%GV%H_to_kg_m2) + + !========================================================================= + ! area integrated surface mass transport, all are rescaled to MKS units before area integration. + + handles%id_total_prcme = register_scalar_field('ocean_model', 'total_PRCmE', Time, diag, & + long_name='Area integrated net surface water flux (precip+melt+liq runoff+ice calving-evap)',& + units='kg s-1', standard_name='water_flux_into_sea_water_area_integrated', & + cmor_field_name='total_wfo', & + cmor_standard_name='water_flux_into_sea_water_area_integrated', & + cmor_long_name='Water Transport Into Sea Water Area Integrated') + + handles%id_total_evap = register_scalar_field('ocean_model', 'total_evap', Time, diag,& + long_name='Area integrated evap/condense at ocean surface', & + units='kg s-1', standard_name='water_evaporation_flux_area_integrated', & + cmor_field_name='total_evs', & + cmor_standard_name='water_evaporation_flux_area_integrated', & + cmor_long_name='Evaporation Where Ice Free Ocean over Sea Area Integrated') + + ! seaice_melt field requires updates to the sea ice model + handles%id_total_seaice_melt = register_scalar_field('ocean_model', 'total_icemelt', Time, diag, & + long_name='Area integrated sea ice melt (>0) or form (<0)', units='kg s-1', & + standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics_area_integrated', & + cmor_field_name='total_fsitherm', & + cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics_area_integrated', & + cmor_long_name='Water Melt/Form from Sea Ice Area Integrated') + + handles%id_total_precip = register_scalar_field('ocean_model', 'total_precip', Time, diag, & + long_name='Area integrated liquid+frozen precip into ocean', units='kg s-1') + + handles%id_total_fprec = register_scalar_field('ocean_model', 'total_fprec', Time, diag,& + long_name='Area integrated frozen precip into ocean', units='kg s-1', & + standard_name='snowfall_flux_area_integrated', & + cmor_field_name='total_prsn', & + cmor_standard_name='snowfall_flux_area_integrated', & + cmor_long_name='Snowfall Flux where Ice Free Ocean over Sea Area Integrated') + + handles%id_total_lprec = register_scalar_field('ocean_model', 'total_lprec', Time, diag,& + long_name='Area integrated liquid precip into ocean', units='kg s-1', & + standard_name='rainfall_flux_area_integrated', & + cmor_field_name='total_pr', & + cmor_standard_name='rainfall_flux_area_integrated', & + cmor_long_name='Rainfall Flux where Ice Free Ocean over Sea Area Integrated') + + handles%id_total_vprec = register_scalar_field('ocean_model', 'total_vprec', Time, diag, & + long_name='Area integrated virtual liquid precip due to SSS restoring', units='kg s-1') + + handles%id_total_frunoff = register_scalar_field('ocean_model', 'total_frunoff', Time, diag, & + long_name='Area integrated frozen runoff (calving) & iceberg melt into ocean', units='kg s-1',& + cmor_field_name='total_ficeberg', & + cmor_standard_name='water_flux_into_sea_water_from_icebergs_area_integrated', & + cmor_long_name='Water Flux into Seawater from Icebergs Area Integrated') + + handles%id_total_lrunoff = register_scalar_field('ocean_model', 'total_lrunoff', Time, diag,& + long_name='Area integrated liquid runoff into ocean', units='kg s-1', & + cmor_field_name='total_friver', & + cmor_standard_name='water_flux_into_sea_water_from_rivers_area_integrated', & + cmor_long_name='Water Flux into Sea Water From Rivers Area Integrated') + + handles%id_total_net_massout = register_scalar_field('ocean_model', 'total_net_massout', Time, diag, & + long_name='Area integrated mass leaving ocean due to evap and seaice form', units='kg s-1') + + handles%id_total_net_massin = register_scalar_field('ocean_model', 'total_net_massin', Time, diag, & + long_name='Area integrated mass entering ocean due to predip, runoff, ice melt', units='kg s-1') + + !========================================================================= + ! area averaged surface mass transport + + handles%id_prcme_ga = register_scalar_field('ocean_model', 'PRCmE_ga', Time, diag, & + long_name='Area averaged net surface water flux (precip+melt+liq runoff+ice calving-evap)', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_flux_into_sea_water_area_averaged', & + cmor_field_name='ave_wfo', cmor_standard_name='rainfall_flux_area_averaged', & + cmor_long_name='Water Transport Into Sea Water Area Averaged') + + handles%id_evap_ga = register_scalar_field('ocean_model', 'evap_ga', Time, diag, & + long_name='Area averaged evap/condense at ocean surface', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_evaporation_flux_area_averaged', & + 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,& + 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, & + 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', & + cmor_field_name='ave_prsn',cmor_standard_name='snowfall_flux_area_averaged', & + cmor_long_name='Snowfall Flux where Ice Free Ocean over Sea Area Averaged') + + handles%id_precip_ga = register_scalar_field('ocean_model', 'precip_ga', Time, diag, & + long_name='Area averaged liquid+frozen precip into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + + handles%id_vprec_ga = register_scalar_field('ocean_model', 'vrec_ga', Time, diag, & + long_name='Area averaged virtual liquid precip due to SSS restoring', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + + !=============================================================== + ! surface heat flux maps + + handles%id_heat_content_frunoff = register_diag_field('ocean_model', 'heat_content_frunoff', & + diag%axesT1, Time, 'Heat content (relative to 0C) of solid runoff into ocean', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='temperature_flux_due_to_solid_runoff_expressed_as_heat_flux_into_sea_water') + + handles%id_heat_content_lrunoff = register_diag_field('ocean_model', 'heat_content_lrunoff', & + diag%axesT1, Time, 'Heat content (relative to 0C) of liquid runoff into ocean', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water') + + handles%id_hfrunoffds = register_diag_field('ocean_model', 'hfrunoffds', & + diag%axesT1, Time, 'Heat content (relative to 0C) of liquid+solid runoff into ocean', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water') + + handles%id_heat_content_lprec = register_diag_field('ocean_model', 'heat_content_lprec', & + diag%axesT1,Time,'Heat content (relative to 0degC) of liquid precip entering ocean', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_heat_content_fprec = register_diag_field('ocean_model', 'heat_content_fprec',& + diag%axesT1,Time,'Heat content (relative to 0degC) of frozen prec entering ocean',& + 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_heat_content_vprec = register_diag_field('ocean_model', 'heat_content_vprec', & + diag%axesT1,Time,'Heat content (relative to 0degC) of virtual precip entering ocean',& + 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_heat_content_cond = register_diag_field('ocean_model', 'heat_content_cond', & + diag%axesT1,Time,'Heat content (relative to 0degC) of water condensing into ocean',& + 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_heat_content_evap = register_diag_field('ocean_model', 'heat_content_evap', & + diag%axesT1,Time,'Heat content (relative to 0degC) of water evaporating from ocean',& + 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_hfrainds = register_diag_field('ocean_model', 'hfrainds', & + diag%axesT1,Time,'Heat content (relative to 0degC) of liquid+frozen precip entering ocean', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='temperature_flux_due_to_rainfall_expressed_as_heat_flux_into_sea_water',& + cmor_long_name='Heat Content (relative to 0degC) of Liquid + Frozen Precipitation') + + handles%id_heat_content_surfwater = register_diag_field('ocean_model', 'heat_content_surfwater',& + diag%axesT1, Time, & + 'Heat content (relative to 0degC) of net water crossing ocean surface (frozen+liquid)', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_heat_content_massout = register_diag_field('ocean_model', 'heat_content_massout', & + diag%axesT1, Time,'Heat content (relative to 0degC) of net mass leaving ocean ocean via evap and ice form',& + 'W m-2', conversion=US%QRZ_T_to_W_m2, & + cmor_field_name='hfevapds', & + cmor_standard_name='temperature_flux_due_to_evaporation_expressed_as_heat_flux_out_of_sea_water', & + cmor_long_name='Heat Content (relative to 0degC) of Water Leaving Ocean via Evaporation and Ice Formation') + + handles%id_heat_content_massin = register_diag_field('ocean_model', 'heat_content_massin', & + diag%axesT1, Time,'Heat content (relative to 0degC) of net mass entering ocean ocean',& + 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_net_heat_coupler = register_diag_field('ocean_model', 'net_heat_coupler', & + diag%axesT1,Time,'Surface ocean heat flux from SW+LW+latent+sensible+seaice_melt_heat (via the coupler)',& + 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_net_heat_surface = register_diag_field('ocean_model', 'net_heat_surface',diag%axesT1, Time, & + 'Surface ocean heat flux from SW+LW+lat+sens+mass transfer+frazil+restore+seaice_melt_heat or '// & + 'flux adjustments', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='surface_downward_heat_flux_in_sea_water', cmor_field_name='hfds', & + cmor_standard_name='surface_downward_heat_flux_in_sea_water', & + cmor_long_name='Surface ocean heat flux from SW+LW+latent+sensible+masstransfer+frazil+seaice_melt_heat') + + handles%id_sw = register_diag_field('ocean_model', 'SW', diag%axesT1, Time, & + 'Shortwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='net_downward_shortwave_flux_at_sea_water_surface', & + cmor_field_name='rsntds', & + cmor_standard_name='net_downward_shortwave_flux_at_sea_water_surface', & + cmor_long_name='Net Downward Shortwave Radiation at Sea Water Surface') + handles%id_sw_vis = register_diag_field('ocean_model', 'sw_vis', diag%axesT1, Time, & + 'Shortwave radiation direct and diffuse flux into the ocean in the visible band', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) + handles%id_sw_nir = register_diag_field('ocean_model', 'sw_nir', diag%axesT1, Time, & + 'Shortwave radiation direct and diffuse flux into the ocean in the near-infrared band', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_LwLatSens = register_diag_field('ocean_model', 'LwLatSens', diag%axesT1, Time, & + 'Combined longwave, latent, and sensible heating at ocean surface', 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_lw = register_diag_field('ocean_model', 'LW', diag%axesT1, Time, & + 'Longwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='surface_net_downward_longwave_flux', & + cmor_field_name='rlntds', & + cmor_standard_name='surface_net_downward_longwave_flux', & + cmor_long_name='Surface Net Downward Longwave Radiation') + + handles%id_lat = register_diag_field('ocean_model', 'latent', diag%axesT1, Time, & + 'Latent heat flux into ocean due to fusion and evaporation (negative means ocean heat loss)', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, cmor_field_name='hflso', & + cmor_standard_name='surface_downward_latent_heat_flux', & + cmor_long_name='Surface Downward Latent Heat Flux due to Evap + Melt Snow/Ice') + + handles%id_lat_evap = register_diag_field('ocean_model', 'latent_evap', diag%axesT1, Time, & + 'Latent heat flux into ocean due to evaporation/condensation', 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_lat_fprec = register_diag_field('ocean_model', 'latent_fprec_diag', diag%axesT1, Time,& + 'Latent heat flux into ocean due to melting of frozen precipitation', 'W m-2', conversion=US%QRZ_T_to_W_m2, & + cmor_field_name='hfsnthermds', & + cmor_standard_name='heat_flux_into_sea_water_due_to_snow_thermodynamics', & + cmor_long_name='Latent Heat to Melt Frozen Precipitation') + + handles%id_lat_frunoff = register_diag_field('ocean_model', 'latent_frunoff', diag%axesT1, Time, & + 'Latent heat flux into ocean due to melting of icebergs', 'W m-2', conversion=US%QRZ_T_to_W_m2, & + cmor_field_name='hfibthermds', & + cmor_standard_name='heat_flux_into_sea_water_due_to_iceberg_thermodynamics', & + cmor_long_name='Latent Heat to Melt Frozen Runoff/Iceberg') + + handles%id_sens = register_diag_field('ocean_model', 'sensible', diag%axesT1, Time, & + 'Sensible heat flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='surface_downward_sensible_heat_flux', & + cmor_field_name='hfsso', & + cmor_standard_name='surface_downward_sensible_heat_flux', & + cmor_long_name='Surface Downward Sensible Heat Flux') + + handles%id_seaice_melt_heat = register_diag_field('ocean_model', 'seaice_melt_heat', diag%axesT1, Time,& + 'Heat flux into ocean due to snow and sea ice melt/freeze', 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='snow_ice_melt_heat_flux', & + !GMM TODO cmor_field_name='hfsso', & + cmor_standard_name='snow_ice_melt_heat_flux', & + cmor_long_name='Heat flux into ocean from snow and sea ice melt') + + handles%id_heat_added = register_diag_field('ocean_model', 'heat_added', diag%axesT1, Time, & + 'Flux Adjustment or restoring surface heat flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2) + + + !=============================================================== + ! area integrated surface heat fluxes + + handles%id_total_heat_content_frunoff = register_scalar_field('ocean_model', & + 'total_heat_content_frunoff', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of solid runoff', & + units='W', cmor_field_name='total_hfsolidrunoffds', & + cmor_standard_name= & + 'temperature_flux_due_to_solid_runoff_expressed_as_heat_flux_into_sea_water_area_integrated',& + cmor_long_name= & + 'Temperature Flux due to Solid Runoff Expressed as Heat Flux into Sea Water Area Integrated') + + handles%id_total_heat_content_lrunoff = register_scalar_field('ocean_model', & + 'total_heat_content_lrunoff', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of liquid runoff', & + units='W', cmor_field_name='total_hfrunoffds', & + cmor_standard_name= & + 'temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water_area_integrated',& + cmor_long_name= & + 'Temperature Flux due to Runoff Expressed as Heat Flux into Sea Water Area Integrated') + + handles%id_total_heat_content_lprec = register_scalar_field('ocean_model', & + 'total_heat_content_lprec', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of liquid precip', & + units='W', cmor_field_name='total_hfrainds', & + cmor_standard_name= & + 'temperature_flux_due_to_rainfall_expressed_as_heat_flux_into_sea_water_area_integrated',& + cmor_long_name= & + 'Temperature Flux due to Rainfall Expressed as Heat Flux into Sea Water Area Integrated') + + handles%id_total_heat_content_fprec = register_scalar_field('ocean_model', & + 'total_heat_content_fprec', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of frozen precip',& + units='W') + + handles%id_total_heat_content_vprec = register_scalar_field('ocean_model', & + 'total_heat_content_vprec', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of virtual precip',& + units='W') + + handles%id_total_heat_content_cond = register_scalar_field('ocean_model', & + 'total_heat_content_cond', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of condensate',& + units='W') + + handles%id_total_heat_content_evap = register_scalar_field('ocean_model', & + 'total_heat_content_evap', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of evaporation',& + units='W') + + handles%id_total_heat_content_surfwater = register_scalar_field('ocean_model', & + 'total_heat_content_surfwater', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of water crossing surface',& + units='W') + + handles%id_total_heat_content_massout = register_scalar_field('ocean_model', & + 'total_heat_content_massout', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of water leaving ocean', & + units='W', & + cmor_field_name='total_hfevapds', & + cmor_standard_name= & + 'temperature_flux_due_to_evaporation_expressed_as_heat_flux_out_of_sea_water_area_integrated',& + cmor_long_name='Heat Flux Out of Sea Water due to Evaporating Water Area Integrated') + + handles%id_total_heat_content_massin = register_scalar_field('ocean_model', & + 'total_heat_content_massin', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of water entering ocean',& + units='W') + + handles%id_total_net_heat_coupler = register_scalar_field('ocean_model', & + 'total_net_heat_coupler', Time, diag, & + long_name='Area integrated surface heat flux from SW+LW+latent+sensible+seaice_melt_heat (via the coupler)',& + units='W') + + handles%id_total_net_heat_surface = register_scalar_field('ocean_model', & + 'total_net_heat_surface', Time, diag, & + long_name='Area integrated surface heat flux from SW+LW+lat+sens+mass+frazil+restore or flux adjustments', & + units='W', & + cmor_field_name='total_hfds', & + cmor_standard_name='surface_downward_heat_flux_in_sea_water_area_integrated', & + cmor_long_name= & + 'Surface Ocean Heat Flux from SW+LW+latent+sensible+mass transfer+frazil Area Integrated') + + handles%id_total_sw = register_scalar_field('ocean_model', & + 'total_sw', Time, diag, & + long_name='Area integrated net downward shortwave at sea water surface', & + units='W', & + cmor_field_name='total_rsntds', & + cmor_standard_name='net_downward_shortwave_flux_at_sea_water_surface_area_integrated',& + cmor_long_name= & + 'Net Downward Shortwave Radiation at Sea Water Surface Area Integrated') + + handles%id_total_LwLatSens = register_scalar_field('ocean_model',& + 'total_LwLatSens', Time, diag, & + long_name='Area integrated longwave+latent+sensible heating',& + units='W') + + handles%id_total_lw = register_scalar_field('ocean_model', & + 'total_lw', Time, diag, & + long_name='Area integrated net downward longwave at sea water surface', & + units='W', & + cmor_field_name='total_rlntds', & + cmor_standard_name='surface_net_downward_longwave_flux_area_integrated',& + cmor_long_name= & + 'Surface Net Downward Longwave Radiation Area Integrated') + + handles%id_total_lat = register_scalar_field('ocean_model', & + 'total_lat', Time, diag, & + long_name='Area integrated surface downward latent heat flux', & + units='W', & + cmor_field_name='total_hflso', & + cmor_standard_name='surface_downward_latent_heat_flux_area_integrated',& + cmor_long_name= & + 'Surface Downward Latent Heat Flux Area Integrated') + + handles%id_total_lat_evap = register_scalar_field('ocean_model', & + 'total_lat_evap', Time, diag, & + long_name='Area integrated latent heat flux due to evap/condense',& + units='W') + + handles%id_total_lat_fprec = register_scalar_field('ocean_model', & + 'total_lat_fprec', Time, diag, & + long_name='Area integrated latent heat flux due to melting frozen precip', & + units='W', & + cmor_field_name='total_hfsnthermds', & + cmor_standard_name='heat_flux_into_sea_water_due_to_snow_thermodynamics_area_integrated',& + cmor_long_name= & + 'Latent Heat to Melt Frozen Precipitation Area Integrated') + + handles%id_total_lat_frunoff = register_scalar_field('ocean_model', & + 'total_lat_frunoff', Time, diag, & + long_name='Area integrated latent heat flux due to melting icebergs', & + units='W', & + cmor_field_name='total_hfibthermds', & + cmor_standard_name='heat_flux_into_sea_water_due_to_iceberg_thermodynamics_area_integrated',& + cmor_long_name= & + 'Heat Flux into Sea Water due to Iceberg Thermodynamics Area Integrated') + + handles%id_total_sens = register_scalar_field('ocean_model', & + 'total_sens', Time, diag, & + long_name='Area integrated downward sensible heat flux', & + units='W', & + cmor_field_name='total_hfsso', & + cmor_standard_name='surface_downward_sensible_heat_flux_area_integrated',& + cmor_long_name= & + 'Surface Downward Sensible Heat Flux Area Integrated') + + handles%id_total_heat_added = register_scalar_field('ocean_model',& + 'total_heat_adjustment', Time, diag, & + long_name='Area integrated surface heat flux from restoring and/or flux adjustment', & + units='W') + + handles%id_total_seaice_melt_heat = register_scalar_field('ocean_model',& + 'total_seaice_melt_heat', Time, diag, & + long_name='Area integrated surface heat flux from snow and sea ice melt', & + units='W') + + !=============================================================== + ! area averaged surface heat fluxes + + handles%id_net_heat_coupler_ga = register_scalar_field('ocean_model', & + 'net_heat_coupler_ga', Time, diag, & + long_name='Area averaged surface heat flux from SW+LW+latent+sensible+seaice_melt_heat (via the coupler)',& + units='W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_net_heat_surface_ga = register_scalar_field('ocean_model', & + 'net_heat_surface_ga', Time, diag, long_name= & + 'Area averaged surface heat flux from SW+LW+lat+sens+mass+frazil+restore+seaice_melt_heat or flux adjustments', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & + cmor_field_name='ave_hfds', & + cmor_standard_name='surface_downward_heat_flux_in_sea_water_area_averaged', & + cmor_long_name= & + 'Surface Ocean Heat Flux from SW+LW+latent+sensible+mass transfer+frazil Area Averaged') + + handles%id_sw_ga = register_scalar_field('ocean_model', & + 'sw_ga', Time, diag, & + long_name='Area averaged net downward shortwave at sea water surface', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & + cmor_field_name='ave_rsntds', & + cmor_standard_name='net_downward_shortwave_flux_at_sea_water_surface_area_averaged',& + cmor_long_name= & + 'Net Downward Shortwave Radiation at Sea Water Surface Area Averaged') + + handles%id_LwLatSens_ga = register_scalar_field('ocean_model',& + 'LwLatSens_ga', Time, diag, & + long_name='Area averaged longwave+latent+sensible heating',& + units='W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_lw_ga = register_scalar_field('ocean_model', & + 'lw_ga', Time, diag, & + long_name='Area averaged net downward longwave at sea water surface', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & + cmor_field_name='ave_rlntds', & + cmor_standard_name='surface_net_downward_longwave_flux_area_averaged',& + cmor_long_name= & + 'Surface Net Downward Longwave Radiation Area Averaged') + + handles%id_lat_ga = register_scalar_field('ocean_model', & + 'lat_ga', Time, diag, & + long_name='Area averaged surface downward latent heat flux', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & + cmor_field_name='ave_hflso', & + cmor_standard_name='surface_downward_latent_heat_flux_area_averaged',& + cmor_long_name= & + 'Surface Downward Latent Heat Flux Area Averaged') + + handles%id_sens_ga = register_scalar_field('ocean_model', & + 'sens_ga', Time, diag, & + long_name='Area averaged downward sensible heat flux', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & + cmor_field_name='ave_hfsso', & + cmor_standard_name='surface_downward_sensible_heat_flux_area_averaged',& + cmor_long_name= & + 'Surface Downward Sensible Heat Flux Area Averaged') + + + !=============================================================== + ! maps of surface salt fluxes, virtual precip fluxes, and adjustments + + handles%id_saltflux = register_diag_field('ocean_model', 'salt_flux', diag%axesT1, Time,& + 'Net salt flux into ocean at surface (restoring + sea-ice)', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + cmor_field_name='sfdsi', cmor_standard_name='downward_sea_ice_basal_salt_flux', & + cmor_long_name='Downward Sea Ice Basal Salt Flux') + + handles%id_saltFluxIn = register_diag_field('ocean_model', 'salt_flux_in', diag%axesT1, Time, & + 'Salt flux into ocean at surface from coupler', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + + handles%id_saltFluxAdded = register_diag_field('ocean_model', 'salt_flux_added', & + diag%axesT1,Time,'Salt flux into ocean at surface due to restoring or flux adjustment', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + + handles%id_saltFluxBehind = register_diag_field('ocean_model', 'salt_left_behind', & + diag%axesT1,Time,'Salt left in ocean at surface due to ice formation', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + + handles%id_saltFluxGlobalAdj = register_scalar_field('ocean_model', & + 'salt_flux_global_restoring_adjustment', Time, diag, & + 'Adjustment needed to balance net global salt flux into ocean at surface', & + units='kg m-2 s-1') !, conversion=US%RZ_T_to_kg_m2s) + + handles%id_vPrecGlobalAdj = register_scalar_field('ocean_model', & + 'vprec_global_adjustment', Time, diag, & + 'Adjustment needed to adjust net vprec into ocean to zero', & + 'kg m-2 s-1') + + handles%id_netFWGlobalAdj = register_scalar_field('ocean_model', & + 'net_fresh_water_global_adjustment', Time, diag, & + 'Adjustment needed to adjust net fresh water into ocean to zero',& + 'kg m-2 s-1') + + handles%id_saltFluxGlobalScl = register_scalar_field('ocean_model', & + 'salt_flux_global_restoring_scaling', Time, diag, & + 'Scaling applied to balance net global salt flux into ocean at surface', & + 'nondim') + + handles%id_vPrecGlobalScl = register_scalar_field('ocean_model',& + 'vprec_global_scaling', Time, diag, & + 'Scaling applied to adjust net vprec into ocean to zero', & + 'nondim') + + handles%id_netFWGlobalScl = register_scalar_field('ocean_model', & + 'net_fresh_water_global_scaling', Time, diag, & + 'Scaling applied to adjust net fresh water into ocean to zero', & + 'nondim') + + !=============================================================== + ! area integrals of surface salt fluxes + + handles%id_total_saltflux = register_scalar_field('ocean_model', & + 'total_salt_flux', Time, diag, & + long_name='Area integrated surface salt flux', units='kg s-1', & + cmor_field_name='total_sfdsi', & + cmor_standard_name='downward_sea_ice_basal_salt_flux_area_integrated',& + cmor_long_name='Downward Sea Ice Basal Salt Flux Area Integrated') + + handles%id_total_saltFluxIn = register_scalar_field('ocean_model', 'total_salt_Flux_In', & + Time, diag, long_name='Area integrated surface salt flux at surface from coupler', units='kg s-1') + + handles%id_total_saltFluxAdded = register_scalar_field('ocean_model', 'total_salt_Flux_Added', & + Time, diag, long_name='Area integrated surface salt flux due to restoring or flux adjustment', units='kg s-1') + + !=============================================================== + ! wave forcing diagnostics + if (present(use_waves)) then + if (use_waves) then + handles%id_lamult = register_diag_field('ocean_model', 'lamult', & + diag%axesT1, Time, long_name='Langmuir enhancement factor received from WW3', units="nondim") + endif + endif + +end subroutine register_forcing_type_diags + +!> Accumulate the forcing over time steps, taking input from a mechanical forcing type +!! and a temporary forcing-flux type. +subroutine forcing_accumulate(flux_tmp, forces, fluxes, G, wt2) + type(forcing), intent(in) :: flux_tmp !< A temporary structure with current + !!thermodynamic forcing fields + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged + !! thermodynamic forcing fields + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, intent(out) :: wt2 !< The relative weight of the new fluxes [nondim] + + ! This subroutine copies mechancal forcing from flux_tmp to fluxes and + ! stores the time-weighted averages of the various buoyancy fluxes in fluxes, + ! and increments the amount of time over which the buoyancy forcing should be + ! applied, all via a call to fluxes accumulate. + + call fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) + +end subroutine forcing_accumulate + +!> Accumulate the thermodynamic fluxes over time steps +subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) + type(forcing), intent(in) :: flux_tmp !< A temporary structure with current + !! thermodynamic forcing fields + type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged + !! thermodynamic forcing fields + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, intent(out) :: wt2 !< The relative weight of the new fluxes [nondim] + type(mech_forcing), optional, intent(in) :: forces !< A structure with the driving mechanical forces + + ! This subroutine copies mechanical forcing from flux_tmp to fluxes and + ! stores the time-weighted averages of the various buoyancy fluxes in fluxes, + ! and increments the amount of time over which the buoyancy forcing in fluxes should be + ! applied based on the time interval stored in flux_tmp. + + real :: wt1 ! The relative weight of the previous fluxes [nondim] + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + + if (fluxes%dt_buoy_accum < 0) call MOM_error(FATAL, "fluxes_accumulate: "//& + "fluxes must be initialzed before it can be augmented.") + + ! wt1 is the relative weight of the previous fluxes. + wt1 = fluxes%dt_buoy_accum / (fluxes%dt_buoy_accum + flux_tmp%dt_buoy_accum) + wt2 = 1.0 - wt1 ! = flux_tmp%dt_buoy_accum / (fluxes%dt_buoy_accum + flux_tmp%dt_buoy_accum) + fluxes%dt_buoy_accum = fluxes%dt_buoy_accum + flux_tmp%dt_buoy_accum + + ! Copy over the pressure fields and accumulate averages of ustar or tau_mag, either from the forcing + ! type or from the temporary fluxes type. + if (present(forces)) then + do j=js,je ; do i=is,ie + fluxes%p_surf(i,j) = forces%p_surf(i,j) + fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) + enddo ; enddo + + if (associated(fluxes%ustar)) then ; do j=js,je ; do i=is,ie + fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*forces%ustar(i,j) + enddo ; enddo ; endif + if (associated(fluxes%tau_mag)) then ; do j=js,je ; do i=is,ie + fluxes%tau_mag(i,j) = wt1*fluxes%tau_mag(i,j) + wt2*forces%tau_mag(i,j) + enddo ; enddo ; endif + else + do j=js,je ; do i=is,ie + fluxes%p_surf(i,j) = flux_tmp%p_surf(i,j) + fluxes%p_surf_full(i,j) = flux_tmp%p_surf_full(i,j) + enddo ; enddo + + if (associated(fluxes%ustar)) then ; do j=js,je ; do i=is,ie + fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*flux_tmp%ustar(i,j) + enddo ; enddo ; endif + if (associated(fluxes%tau_mag)) then ; do j=js,je ; do i=is,ie + fluxes%tau_mag(i,j) = wt1*fluxes%tau_mag(i,j) + wt2*flux_tmp%tau_mag(i,j) + enddo ; enddo ; endif + endif + + ! Average ustar_gustless. + if (associated(fluxes%ustar_gustless)) then + if (fluxes%gustless_accum_bug) then + do j=js,je ; do i=is,ie + fluxes%ustar_gustless(i,j) = flux_tmp%ustar_gustless(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + fluxes%ustar_gustless(i,j) = wt1*fluxes%ustar_gustless(i,j) + wt2*flux_tmp%ustar_gustless(i,j) + enddo ; enddo + endif + endif + + if (associated(fluxes%tau_mag_gustless)) then + do j=js,je ; do i=is,ie + fluxes%tau_mag_gustless(i,j) = wt1*fluxes%tau_mag_gustless(i,j) + wt2*flux_tmp%tau_mag_gustless(i,j) + enddo ; enddo + endif + + ! Average the water, heat, and salt fluxes. + do j=js,je ; do i=is,ie + fluxes%evap(i,j) = wt1*fluxes%evap(i,j) + wt2*flux_tmp%evap(i,j) + fluxes%lprec(i,j) = wt1*fluxes%lprec(i,j) + wt2*flux_tmp%lprec(i,j) + fluxes%fprec(i,j) = wt1*fluxes%fprec(i,j) + wt2*flux_tmp%fprec(i,j) + fluxes%vprec(i,j) = wt1*fluxes%vprec(i,j) + wt2*flux_tmp%vprec(i,j) + fluxes%lrunoff(i,j) = wt1*fluxes%lrunoff(i,j) + wt2*flux_tmp%lrunoff(i,j) + fluxes%frunoff(i,j) = wt1*fluxes%frunoff(i,j) + wt2*flux_tmp%frunoff(i,j) + fluxes%seaice_melt(i,j) = wt1*fluxes%seaice_melt(i,j) + wt2*flux_tmp%seaice_melt(i,j) + fluxes%sw(i,j) = wt1*fluxes%sw(i,j) + wt2*flux_tmp%sw(i,j) + fluxes%sw_vis_dir(i,j) = wt1*fluxes%sw_vis_dir(i,j) + wt2*flux_tmp%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) = wt1*fluxes%sw_vis_dif(i,j) + wt2*flux_tmp%sw_vis_dif(i,j) + fluxes%sw_nir_dir(i,j) = wt1*fluxes%sw_nir_dir(i,j) + wt2*flux_tmp%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) = wt1*fluxes%sw_nir_dif(i,j) + wt2*flux_tmp%sw_nir_dif(i,j) + fluxes%lw(i,j) = wt1*fluxes%lw(i,j) + wt2*flux_tmp%lw(i,j) + fluxes%latent(i,j) = wt1*fluxes%latent(i,j) + wt2*flux_tmp%latent(i,j) + fluxes%sens(i,j) = wt1*fluxes%sens(i,j) + wt2*flux_tmp%sens(i,j) + + fluxes%salt_flux(i,j) = wt1*fluxes%salt_flux(i,j) + wt2*flux_tmp%salt_flux(i,j) + enddo ; enddo + if (associated(fluxes%heat_added) .and. associated(flux_tmp%heat_added)) then + do j=js,je ; do i=is,ie + fluxes%heat_added(i,j) = wt1*fluxes%heat_added(i,j) + wt2*flux_tmp%heat_added(i,j) + enddo ; enddo + endif + ! These might always be associated, in which case they can be combined? + if (associated(fluxes%heat_content_cond) .and. associated(flux_tmp%heat_content_cond)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_cond(i,j) = wt1*fluxes%heat_content_cond(i,j) + wt2*flux_tmp%heat_content_cond(i,j) + enddo ; enddo + endif + if (associated(fluxes%heat_content_evap) .and. associated(flux_tmp%heat_content_evap)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_evap(i,j) = wt1*fluxes%heat_content_evap(i,j) + wt2*flux_tmp%heat_content_evap(i,j) + enddo ; enddo + endif + if (associated(fluxes%heat_content_lprec) .and. associated(flux_tmp%heat_content_lprec)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_lprec(i,j) = wt1*fluxes%heat_content_lprec(i,j) + wt2*flux_tmp%heat_content_lprec(i,j) + enddo ; enddo + endif + if (associated(fluxes%heat_content_fprec) .and. associated(flux_tmp%heat_content_fprec)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_fprec(i,j) = wt1*fluxes%heat_content_fprec(i,j) + wt2*flux_tmp%heat_content_fprec(i,j) + enddo ; enddo + endif + if (associated(fluxes%heat_content_vprec) .and. associated(flux_tmp%heat_content_vprec)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_vprec(i,j) = wt1*fluxes%heat_content_vprec(i,j) + wt2*flux_tmp%heat_content_vprec(i,j) + enddo ; enddo + endif + if (associated(fluxes%heat_content_lrunoff) .and. associated(flux_tmp%heat_content_lrunoff)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_lrunoff(i,j) = wt1*fluxes%heat_content_lrunoff(i,j) + wt2*flux_tmp%heat_content_lrunoff(i,j) + enddo ; enddo + endif + if (associated(fluxes%heat_content_frunoff) .and. associated(flux_tmp%heat_content_frunoff)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_frunoff(i,j) = wt1*fluxes%heat_content_frunoff(i,j) + wt2*flux_tmp%heat_content_frunoff(i,j) + enddo ; enddo + endif + + if (associated(fluxes%ustar_shelf) .and. associated(flux_tmp%ustar_shelf)) then + do i=isd,ied ; do j=jsd,jed + fluxes%ustar_shelf(i,j) = flux_tmp%ustar_shelf(i,j) + enddo ; enddo + endif + if (associated(fluxes%iceshelf_melt) .and. associated(flux_tmp%iceshelf_melt)) then + do i=isd,ied ; do j=jsd,jed + fluxes%iceshelf_melt(i,j) = flux_tmp%iceshelf_melt(i,j) + enddo ; enddo + endif + if (associated(fluxes%shelf_sfc_mass_flux) & + .and. associated(flux_tmp%shelf_sfc_mass_flux)) then + do i=isd,ied ; do j=jsd,jed + fluxes%shelf_sfc_mass_flux(i,j) = flux_tmp%shelf_sfc_mass_flux(i,j) + enddo ; enddo + endif + if (associated(fluxes%frac_shelf_h) .and. associated(flux_tmp%frac_shelf_h)) then + do i=isd,ied ; do j=jsd,jed + fluxes%frac_shelf_h(i,j) = flux_tmp%frac_shelf_h(i,j) + enddo ; enddo + endif + + if (coupler_type_initialized(fluxes%tr_fluxes) .and. & + coupler_type_initialized(flux_tmp%tr_fluxes)) & + call coupler_type_increment_data(flux_tmp%tr_fluxes, fluxes%tr_fluxes, & + scale_factor=wt2, scale_prev=wt1) + +end subroutine fluxes_accumulate + +!> This subroutine copies the computational domains of common forcing fields +!! from a mech_forcing type to a (thermodynamic) forcing type. +subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(ocean_grid_type), intent(in) :: G !< grid type + logical, optional, intent(in) :: skip_pres !< If present and true, do not copy pressure fields. + + logical :: do_pres + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + do_pres = .true. ; if (present(skip_pres)) do_pres = .not.skip_pres + + if (associated(forces%ustar) .and. associated(fluxes%ustar)) then + do j=js,je ; do i=is,ie + fluxes%ustar(i,j) = forces%ustar(i,j) + enddo ; enddo + endif + !if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then + ! do j=js,je ; do i=is,ie + ! fluxes%omega_w2x(i,j) = forces%omega_w2x(i,j) + ! enddo ; enddo + !endif + if (associated(forces%tau_mag) .and. associated(fluxes%tau_mag)) then + do j=js,je ; do i=is,ie + fluxes%tau_mag(i,j) = forces%tau_mag(i,j) + enddo ; enddo + endif + + if (do_pres) then + if (associated(forces%p_surf) .and. associated(fluxes%p_surf)) then + do j=js,je ; do i=is,ie + fluxes%p_surf(i,j) = forces%p_surf(i,j) + enddo ; enddo + endif + + if (associated(forces%p_surf_full) .and. associated(fluxes%p_surf_full)) then + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) + enddo ; enddo + endif + + if (associated(forces%p_surf_SSH, forces%p_surf_full)) then + fluxes%p_surf_SSH => fluxes%p_surf_full + elseif (associated(forces%p_surf_SSH, forces%p_surf)) then + fluxes%p_surf_SSH => fluxes%p_surf + endif + endif + +end subroutine copy_common_forcing_fields + +!> This subroutine calculates certain derived forcing fields based on information +!! from a mech_forcing type and stores them in a (thermodynamic) forcing type. +subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(ocean_grid_type), intent(in) :: G !< grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< A reference density of seawater [R ~> kg m-3], + !! as used to calculate ustar. + + real :: taux2, tauy2 ! Squared wind stress components [R2 L2 Z2 T-4 ~> Pa2]. + real :: Irho0 ! Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + Irho0 = US%L_to_Z / Rho0 + + if ( associated(forces%taux) .and. associated(forces%tauy) .and. & + (associated(fluxes%ustar_gustless) .or. associated(fluxes%tau_mag_gustless)) ) then + do j=js,je ; do i=is,ie + taux2 = 0.0 + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & + taux2 = (G%mask2dCu(I-1,j) * forces%taux(I-1,j)**2 + & + G%mask2dCu(I,j) * forces%taux(I,j)**2) / & + (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) + tauy2 = 0.0 + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & + tauy2 = (G%mask2dCv(i,J-1) * forces%tauy(i,J-1)**2 + & + G%mask2dCv(i,J) * forces%tauy(i,J)**2) / & + (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) + + if (associated(fluxes%ustar_gustless)) then + if (fluxes%gustless_accum_bug) then + ! This change is just for computational efficiency, but it is wrapped with another change. + fluxes%ustar_gustless(i,j) = sqrt(US%L_to_Z * sqrt(taux2 + tauy2) / Rho0) + else + fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) + endif + endif + if (associated(fluxes%tau_mag_gustless)) then + fluxes%tau_mag_gustless(i,j) = sqrt(taux2 + tauy2) + endif + enddo ; enddo + endif + +end subroutine set_derived_forcing_fields + + +!> This subroutine determines the net mass source to the ocean from +!! a (thermodynamic) forcing type and stores it in a mech_forcing type. +subroutine set_net_mass_forcing(fluxes, forces, G, US) + type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_grid_type), intent(in) :: G !< The ocean grid type + + if (associated(forces%net_mass_src)) & + call get_net_mass_forcing(fluxes, G, US, forces%net_mass_src) + +end subroutine set_net_mass_forcing + +!> This subroutine calculates determines the net mass source to the ocean from +!! a (thermodynamic) forcing type and stores it in a provided array. +subroutine get_net_mass_forcing(fluxes, G, US, net_mass_src) + type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields + type(ocean_grid_type), intent(in) :: G !< The ocean grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_mass_src !< The net mass flux of water into the ocean + !! [R Z T-1 ~> kg m-2 s-1]. + + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + net_mass_src(:,:) = 0.0 + if (associated(fluxes%lprec)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%lprec(i,j) + enddo ; enddo ; endif + if (associated(fluxes%fprec)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%fprec(i,j) + enddo ; enddo ; endif + if (associated(fluxes%vprec)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%vprec(i,j) + enddo ; enddo ; endif + if (associated(fluxes%lrunoff)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%lrunoff(i,j) + enddo ; enddo ; endif + if (associated(fluxes%frunoff)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%frunoff(i,j) + enddo ; enddo ; endif + if (associated(fluxes%evap)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%evap(i,j) + enddo ; enddo ; endif + if (associated(fluxes%seaice_melt)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%seaice_melt(i,j) + enddo ; enddo ; endif + +end subroutine get_net_mass_forcing + +!> This subroutine copies the computational domains of common forcing fields +!! from a mech_forcing type to a (thermodynamic) forcing type. +subroutine copy_back_forcing_fields(fluxes, forces, G) + type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(ocean_grid_type), intent(in) :: G !< grid type + + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if (associated(forces%ustar) .and. associated(fluxes%ustar)) then + do j=js,je ; do i=is,ie + forces%ustar(i,j) = fluxes%ustar(i,j) + enddo ; enddo + endif + !if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then + ! do j=js,je ; do i=is,ie + ! forces%omega_w2x(i,j) = fluxes%omega_w2x(i,j) + ! enddo ; enddo + !endif + if (associated(forces%tau_mag) .and. associated(fluxes%tau_mag)) then + do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = fluxes%tau_mag(i,j) + enddo ; enddo + endif + +end subroutine copy_back_forcing_fields + +!> Offer mechanical forcing fields for diagnostics for those +!! fields registered as part of register_forcing_type_diags. +subroutine mech_forcing_diags(forces_in, dt, G, time_end, diag, handles) + type(mech_forcing), target, intent(in) :: forces_in !< mechanical forcing input fields + real, intent(in) :: dt !< time step for the forcing [T ~> s] + type(ocean_grid_type), intent(in) :: G !< grid type + type(time_type), intent(in) :: time_end !< The end time of the diagnostic interval. + type(diag_ctrl), intent(inout) :: diag !< diagnostic type + type(forcing_diags), intent(inout) :: handles !< diagnostic id for diag_manager + + integer :: is, ie, js, je + + type(mech_forcing), pointer :: forces + integer :: turns + + call cpu_clock_begin(handles%id_clock_forcing) + + ! NOTE: post_data expects data to be on the rotated index map, so any + ! rotations must be applied before saving the output. + turns = diag%G%HI%turns + if (turns /= 0) then + allocate(forces) + call allocate_mech_forcing(forces_in, diag%G, forces) + call rotate_mech_forcing(forces_in, turns, forces) + else + forces => forces_in + endif + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + call enable_averages(dt, time_end, diag) + ! if (query_averaging_enabled(diag)) then + + if ((handles%id_taux > 0) .and. associated(forces%taux)) & + call post_data(handles%id_taux, forces%taux, diag) + + if ((handles%id_tauy > 0) .and. associated(forces%tauy)) & + call post_data(handles%id_tauy, forces%tauy, diag) + + if ((handles%id_mass_berg > 0) .and. associated(forces%mass_berg)) & + call post_data(handles%id_mass_berg, forces%mass_berg, diag) + + if ((handles%id_area_berg > 0) .and. associated(forces%area_berg)) & + call post_data(handles%id_area_berg, forces%area_berg, diag) + + ! endif + + call disable_averaging(diag) + + if (turns /= 0) then + call deallocate_mech_forcing(forces) + deallocate(forces) + endif + + call cpu_clock_end(handles%id_clock_forcing) +end subroutine mech_forcing_diags + + +!> Offer buoyancy forcing fields for diagnostics for those +!! fields registered as part of register_forcing_type_diags. +subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, handles, enthalpy) + type(forcing), target, intent(in) :: fluxes_in !< A structure containing thermodynamic forcing fields + type(surface), intent(in) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(ocean_grid_type), target, intent(in) :: G_in !< Input grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(time_type), intent(in) :: time_end !< The end time of the diagnostic interval. + type(diag_ctrl), intent(inout) :: diag !< diagnostic regulator + type(forcing_diags), intent(inout) :: handles !< diagnostic ids + logical, optional, intent(in ) :: enthalpy !< If present and true, the heat content associated + !! with mass entering/leaving the ocean is provided + !! by the coupler. Diagnostics net_heat_surface and + !! heat_content_surfwater are computed using + !! heat_content_evap instead of heat_content_massout. + + ! local variables + type(ocean_grid_type), pointer :: G ! Grid metric on model index map + type(forcing), pointer :: fluxes ! Fluxes on the model index map + real, dimension(SZI_(diag%G),SZJ_(diag%G)) :: res ! A temporary array for combinations + ! of fluxes [R Z T-1 ~> kg m-2 s-1] or [Q R Z T-1 ~> W m-2] + real :: total_transport ! for diagnosing integrated boundary transport, in MKS units of [kg s-1] or [W] + real :: ave_flux ! for diagnosing averaged boundary flux in [R Z T-1 ~> kg m-2 s-1] or [Q R Z T-1 ~> W m-2] + real :: I_dt ! inverse time step [T-1 ~> s-1] + real :: ppt2mks ! conversion between ppt and mks units [nondim] + integer :: turns ! Number of index quarter turns + logical :: mom_enthalpy ! If true (default) enthalpy terms are computed in MOM6 + integer :: i, j, is, ie, js, je + + call cpu_clock_begin(handles%id_clock_forcing) + + mom_enthalpy = .true. + if (present(enthalpy)) mom_enthalpy = .not. enthalpy + + ! NOTE: post_data expects data to be on the rotated index map, so any + ! rotations must be applied before saving the output. + turns = diag%G%HI%turns + if (turns /= 0) then + G => diag%G + allocate(fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes) + call rotate_forcing(fluxes_in, fluxes, turns) + else + G => G_in + fluxes => fluxes_in + endif + + I_dt = 1.0 / fluxes%dt_buoy_accum + ppt2mks = 1e-3 + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + call enable_averages(fluxes%dt_buoy_accum, time_end, diag) + ! if (query_averaging_enabled(diag)) then + + ! post the diagnostics for surface mass fluxes ================================== + + if (handles%id_prcme > 0 .or. handles%id_total_prcme > 0 .or. handles%id_prcme_ga > 0) then + do j=js,je ; do i=is,ie + res(i,j) = 0.0 + if (associated(fluxes%lprec)) res(i,j) = res(i,j) + fluxes%lprec(i,j) + if (associated(fluxes%fprec)) res(i,j) = res(i,j) + fluxes%fprec(i,j) + ! fluxes%cond is not needed because it is derived from %evap > 0 + if (associated(fluxes%evap)) res(i,j) = res(i,j) + fluxes%evap(i,j) + if (associated(fluxes%lrunoff)) res(i,j) = res(i,j) + fluxes%lrunoff(i,j) + if (associated(fluxes%frunoff)) res(i,j) = res(i,j) + fluxes%frunoff(i,j) + if (associated(fluxes%vprec)) res(i,j) = res(i,j) + fluxes%vprec(i,j) + if (associated(fluxes%seaice_melt)) res(i,j) = res(i,j) + fluxes%seaice_melt(i,j) + enddo ; enddo + if (handles%id_prcme > 0) call post_data(handles%id_prcme, res, diag) + if (handles%id_total_prcme > 0) then + total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_prcme, total_transport, diag) + endif + if (handles%id_prcme_ga > 0) then + ave_flux = global_area_mean(res, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_prcme_ga, ave_flux, diag) + endif + endif + + if (handles%id_net_massout > 0 .or. handles%id_total_net_massout > 0) then + do j=js,je ; do i=is,ie + res(i,j) = 0.0 + if (associated(fluxes%lprec)) then + if (fluxes%lprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) + endif + if (associated(fluxes%vprec)) then + if (fluxes%vprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) + endif + if (associated(fluxes%evap)) then + if (fluxes%evap(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) + endif + if (associated(fluxes%seaice_melt)) then + if (fluxes%seaice_melt(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%seaice_melt(i,j) + endif + enddo ; enddo + if (handles%id_net_massout > 0) call post_data(handles%id_net_massout, res, diag) + if (handles%id_total_net_massout > 0) then + total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_net_massout, total_transport, diag) + endif + endif + + if (handles%id_massout_flux > 0 .and. associated(fluxes%netMassOut)) & + call post_data(handles%id_massout_flux, fluxes%netMassOut, diag) + + if (handles%id_net_massin > 0 .or. handles%id_total_net_massin > 0) then + do j=js,je ; do i=is,ie + res(i,j) = 0.0 + + if (associated(fluxes%fprec)) res(i,j) = res(i,j) + fluxes%fprec(i,j) + if (associated(fluxes%lrunoff)) res(i,j) = res(i,j) + fluxes%lrunoff(i,j) + if (associated(fluxes%frunoff)) res(i,j) = res(i,j) + fluxes%frunoff(i,j) + + if (associated(fluxes%lprec)) then + if (fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) + endif + if (associated(fluxes%vprec)) then + if (fluxes%vprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) + endif + ! fluxes%cond is not needed because it is derived from %evap > 0 + if (associated(fluxes%evap)) then + if (fluxes%evap(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) + endif + if (associated(fluxes%seaice_melt)) then + if (fluxes%seaice_melt(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%seaice_melt(i,j) + endif + enddo ; enddo + if (handles%id_net_massin > 0) call post_data(handles%id_net_massin, res, diag) + if (handles%id_total_net_massin > 0) then + total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_net_massin, total_transport, diag) + endif + endif + + if (handles%id_massin_flux > 0 .and. associated(fluxes%netMassIn)) & + call post_data(handles%id_massin_flux, fluxes%netMassIn, diag) + + if ((handles%id_evap > 0) .and. associated(fluxes%evap)) & + call post_data(handles%id_evap, fluxes%evap, diag) + if ((handles%id_total_evap > 0) .and. associated(fluxes%evap)) then + total_transport = global_area_integral(fluxes%evap, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_evap, total_transport, diag) + endif + if ((handles%id_evap_ga > 0) .and. associated(fluxes%evap)) then + ave_flux = global_area_mean(fluxes%evap, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_evap_ga, ave_flux, diag) + endif + + if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then + do j=js,je ; do i=is,ie + res(i,j) = fluxes%lprec(i,j) + fluxes%fprec(i,j) + enddo ; enddo + if (handles%id_precip > 0) call post_data(handles%id_precip, res, diag) + if (handles%id_total_precip > 0) then + total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_precip, total_transport, diag) + endif + if (handles%id_precip_ga > 0) then + ave_flux = global_area_mean(res, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_precip_ga, ave_flux, diag) + endif + endif + + if (associated(fluxes%lprec)) then + if (handles%id_lprec > 0) call post_data(handles%id_lprec, fluxes%lprec, diag) + if (handles%id_total_lprec > 0) then + total_transport = global_area_integral(fluxes%lprec, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_lprec, total_transport, diag) + endif + if (handles%id_lprec_ga > 0) then + ave_flux = global_area_mean(fluxes%lprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_lprec_ga, ave_flux, diag) + endif + endif + + if (associated(fluxes%fprec)) then + if (handles%id_fprec > 0) call post_data(handles%id_fprec, fluxes%fprec, diag) + if (handles%id_total_fprec > 0) then + total_transport = global_area_integral(fluxes%fprec, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_fprec, total_transport, diag) + endif + if (handles%id_fprec_ga > 0) then + ave_flux = global_area_mean(fluxes%fprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_fprec_ga, ave_flux, diag) + endif + endif + + if (associated(fluxes%vprec)) then + if (handles%id_vprec > 0) call post_data(handles%id_vprec, fluxes%vprec, diag) + if (handles%id_total_vprec > 0) then + total_transport = global_area_integral(fluxes%vprec, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_vprec, total_transport, diag) + endif + if (handles%id_vprec_ga > 0) then + ave_flux = global_area_mean(fluxes%vprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_vprec_ga, ave_flux, diag) + endif + endif + + if (associated(fluxes%lrunoff)) then + if (handles%id_lrunoff > 0) call post_data(handles%id_lrunoff, fluxes%lrunoff, diag) + if (handles%id_total_lrunoff > 0) then + total_transport = global_area_integral(fluxes%lrunoff, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_lrunoff, total_transport, diag) + endif + endif + + if (associated(fluxes%frunoff)) then + if (handles%id_frunoff > 0) call post_data(handles%id_frunoff, fluxes%frunoff, diag) + if (handles%id_total_frunoff > 0) then + total_transport = global_area_integral(fluxes%frunoff, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_frunoff, total_transport, diag) + endif + endif + + if (associated(fluxes%seaice_melt)) then + if (handles%id_seaice_melt > 0) call post_data(handles%id_seaice_melt, fluxes%seaice_melt, diag) + if (handles%id_total_seaice_melt > 0) then + total_transport = global_area_integral(fluxes%seaice_melt, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_seaice_melt, total_transport, diag) + endif + endif + + ! post diagnostics for boundary heat fluxes ==================================== + + if ((handles%id_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) & + call post_data(handles%id_heat_content_lrunoff, fluxes%heat_content_lrunoff, diag) + if ((handles%id_total_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) then + total_transport = global_area_integral(fluxes%heat_content_lrunoff, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_lrunoff, total_transport, diag) + endif + + if ((handles%id_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) & + call post_data(handles%id_heat_content_frunoff, fluxes%heat_content_frunoff, diag) + if ((handles%id_total_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) then + total_transport = global_area_integral(fluxes%heat_content_frunoff, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_frunoff, total_transport, diag) + endif + + if ((handles%id_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) & + call post_data(handles%id_heat_content_lprec, fluxes%heat_content_lprec, diag) + if ((handles%id_total_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) then + total_transport = global_area_integral(fluxes%heat_content_lprec, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_lprec, total_transport, diag) + endif + + if ((handles%id_heat_content_fprec > 0) .and. associated(fluxes%heat_content_fprec)) & + call post_data(handles%id_heat_content_fprec, fluxes%heat_content_fprec, diag) + if ((handles%id_total_heat_content_fprec > 0) .and. associated(fluxes%heat_content_fprec)) then + total_transport = global_area_integral(fluxes%heat_content_fprec, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_fprec, total_transport, diag) + endif + + if ((handles%id_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) & + call post_data(handles%id_heat_content_vprec, fluxes%heat_content_vprec, diag) + if ((handles%id_total_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) then + total_transport = global_area_integral(fluxes%heat_content_vprec, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_vprec, total_transport, diag) + endif + + if ((handles%id_heat_content_cond > 0) .and. associated(fluxes%heat_content_cond)) & + call post_data(handles%id_heat_content_cond, fluxes%heat_content_cond, diag) + if ((handles%id_total_heat_content_cond > 0) .and. associated(fluxes%heat_content_cond)) then + total_transport = global_area_integral(fluxes%heat_content_cond, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_cond, total_transport, diag) + endif + + if ((handles%id_heat_content_evap > 0) .and. associated(fluxes%heat_content_evap)) & + call post_data(handles%id_heat_content_evap, fluxes%heat_content_evap, diag) + if ((handles%id_total_heat_content_evap > 0) .and. associated(fluxes%heat_content_evap)) then + total_transport = global_area_integral(fluxes%heat_content_evap, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_evap, total_transport, diag) + endif + + if ((handles%id_heat_content_massout > 0) .and. associated(fluxes%heat_content_massout)) & + call post_data(handles%id_heat_content_massout, fluxes%heat_content_massout, diag) + if ((handles%id_total_heat_content_massout > 0) .and. associated(fluxes%heat_content_massout)) then + total_transport = global_area_integral(fluxes%heat_content_massout, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_massout, total_transport, diag) + endif + + if ((handles%id_heat_content_massin > 0) .and. associated(fluxes%heat_content_massin)) & + call post_data(handles%id_heat_content_massin, fluxes%heat_content_massin, diag) + if ((handles%id_total_heat_content_massin > 0) .and. associated(fluxes%heat_content_massin)) then + total_transport = global_area_integral(fluxes%heat_content_massin, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_massin, total_transport, diag) + endif + + if (handles%id_net_heat_coupler > 0 .or. handles%id_total_net_heat_coupler > 0 .or. & + handles%id_net_heat_coupler_ga > 0. ) then + do j=js,je ; do i=is,ie + res(i,j) = 0.0 + if (associated(fluxes%LW)) res(i,j) = res(i,j) + fluxes%lw(i,j) + if (associated(fluxes%latent)) res(i,j) = res(i,j) + fluxes%latent(i,j) + if (associated(fluxes%sens)) res(i,j) = res(i,j) + fluxes%sens(i,j) + if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%sw(i,j) + if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) + enddo ; enddo + if (handles%id_net_heat_coupler > 0) call post_data(handles%id_net_heat_coupler, res, diag) + if (handles%id_total_net_heat_coupler > 0) then + total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_net_heat_coupler, total_transport, diag) + endif + if (handles%id_net_heat_coupler_ga > 0) then + ave_flux = global_area_mean(res, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_net_heat_coupler_ga, ave_flux, diag) + endif + endif + + if (handles%id_net_heat_surface > 0 .or. handles%id_total_net_heat_surface > 0 .or. & + handles%id_net_heat_surface_ga > 0. ) then + do j=js,je ; do i=is,ie + res(i,j) = 0.0 + if (associated(fluxes%LW)) res(i,j) = res(i,j) + fluxes%lw(i,j) + if (associated(fluxes%latent)) res(i,j) = res(i,j) + fluxes%latent(i,j) + if (associated(fluxes%sens)) res(i,j) = res(i,j) + fluxes%sens(i,j) + if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%sw(i,j) + if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) + if (allocated(sfc_state%frazil)) res(i,j) = res(i,j) + sfc_state%frazil(i,j) * I_dt + if (associated(fluxes%heat_content_lrunoff)) & + res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) & + res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lprec)) & + res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) & + res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_vprec)) & + res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) + if (associated(fluxes%heat_content_cond)) & + res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (mom_enthalpy) then + if (associated(fluxes%heat_content_massout)) & + res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) + else + if (associated(fluxes%heat_content_evap)) & + res(i,j) = res(i,j) + fluxes%heat_content_evap(i,j) + endif + if (associated(fluxes%heat_added)) res(i,j) = res(i,j) + fluxes%heat_added(i,j) + enddo ; enddo + if (handles%id_net_heat_surface > 0) call post_data(handles%id_net_heat_surface, res, diag) + + if (handles%id_total_net_heat_surface > 0) then + total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_net_heat_surface, total_transport, diag) + endif + if (handles%id_net_heat_surface_ga > 0) then + ave_flux = global_area_mean(res, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_net_heat_surface_ga, ave_flux, diag) + endif + endif + + if (handles%id_heat_content_surfwater > 0 .or. handles%id_total_heat_content_surfwater > 0) then + do j=js,je ; do i=is,ie + res(i,j) = 0.0 + if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) + if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (mom_enthalpy) then + if (associated(fluxes%heat_content_massout)) res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) + else + if (associated(fluxes%heat_content_evap)) res(i,j) = res(i,j) + fluxes%heat_content_evap(i,j) + endif + enddo ; enddo + if (handles%id_heat_content_surfwater > 0) call post_data(handles%id_heat_content_surfwater, res, diag) + if (handles%id_total_heat_content_surfwater > 0) then + total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_surfwater, total_transport, diag) + endif + endif + + ! for OMIP, hfrunoffds = heat content of liquid plus frozen runoff + if (handles%id_hfrunoffds > 0) then + do j=js,je ; do i=is,ie + res(i,j) = 0.0 + if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + enddo ; enddo + call post_data(handles%id_hfrunoffds, res, diag) + endif + + ! for OMIP, hfrainds = heat content of lprec + fprec + cond + if (handles%id_hfrainds > 0) then + do j=js,je ; do i=is,ie + res(i,j) = 0.0 + if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + enddo ; enddo + call post_data(handles%id_hfrainds, res, diag) + endif + + if ((handles%id_LwLatSens > 0) .and. associated(fluxes%lw) .and. & + associated(fluxes%latent) .and. associated(fluxes%sens)) then + do j=js,je ; do i=is,ie + res(i,j) = (fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + enddo ; enddo + call post_data(handles%id_LwLatSens, res, diag) + endif + + if ((handles%id_total_LwLatSens > 0) .and. associated(fluxes%lw) .and. & + associated(fluxes%latent) .and. associated(fluxes%sens)) then + do j=js,je ; do i=is,ie + res(i,j) = (fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + enddo ; enddo + total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_LwLatSens, total_transport, diag) + endif + + if ((handles%id_LwLatSens_ga > 0) .and. associated(fluxes%lw) .and. & + associated(fluxes%latent) .and. associated(fluxes%sens)) then + do j=js,je ; do i=is,ie + res(i,j) = ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + enddo ; enddo + ave_flux = global_area_mean(res, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_LwLatSens_ga, ave_flux, diag) + endif + + if ((handles%id_sw > 0) .and. associated(fluxes%sw)) then + call post_data(handles%id_sw, fluxes%sw, diag) + endif + if ((handles%id_sw_vis > 0) .and. associated(fluxes%sw_vis_dir) .and. & + associated(fluxes%sw_vis_dif)) then + call post_data(handles%id_sw_vis, fluxes%sw_vis_dir+fluxes%sw_vis_dif, diag) + endif + if ((handles%id_sw_nir > 0) .and. associated(fluxes%sw_nir_dir) .and. & + associated(fluxes%sw_nir_dif)) then + call post_data(handles%id_sw_nir, fluxes%sw_nir_dir+fluxes%sw_nir_dif, diag) + endif + if ((handles%id_total_sw > 0) .and. associated(fluxes%sw)) then + total_transport = global_area_integral(fluxes%sw, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_sw, total_transport, diag) + endif + if ((handles%id_sw_ga > 0) .and. associated(fluxes%sw)) then + ave_flux = global_area_mean(fluxes%sw, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_sw_ga, ave_flux, diag) + endif + + if ((handles%id_lw > 0) .and. associated(fluxes%lw)) then + call post_data(handles%id_lw, fluxes%lw, diag) + endif + if ((handles%id_total_lw > 0) .and. associated(fluxes%lw)) then + total_transport = global_area_integral(fluxes%lw, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lw, total_transport, diag) + endif + if ((handles%id_lw_ga > 0) .and. associated(fluxes%lw)) then + ave_flux = global_area_mean(fluxes%lw, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_lw_ga, ave_flux, diag) + endif + + if ((handles%id_lat > 0) .and. associated(fluxes%latent)) then + call post_data(handles%id_lat, fluxes%latent, diag) + endif + if ((handles%id_total_lat > 0) .and. associated(fluxes%latent)) then + total_transport = global_area_integral(fluxes%latent, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lat, total_transport, diag) + endif + if ((handles%id_lat_ga > 0) .and. associated(fluxes%latent)) then + ave_flux = global_area_mean(fluxes%latent, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_lat_ga, ave_flux, diag) + endif + + if ((handles%id_lat_evap > 0) .and. associated(fluxes%latent_evap_diag)) then + call post_data(handles%id_lat_evap, fluxes%latent_evap_diag, diag) + endif + if ((handles%id_total_lat_evap > 0) .and. associated(fluxes%latent_evap_diag)) then + total_transport = global_area_integral(fluxes%latent_evap_diag, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lat_evap, total_transport, diag) + endif + + if ((handles%id_lat_fprec > 0) .and. associated(fluxes%latent_fprec_diag)) then + call post_data(handles%id_lat_fprec, fluxes%latent_fprec_diag, diag) + endif + if ((handles%id_total_lat_fprec > 0) .and. associated(fluxes%latent_fprec_diag)) then + total_transport = global_area_integral(fluxes%latent_fprec_diag, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lat_fprec, total_transport, diag) + endif + + if ((handles%id_lat_frunoff > 0) .and. associated(fluxes%latent_frunoff_diag)) then + call post_data(handles%id_lat_frunoff, fluxes%latent_frunoff_diag, diag) + endif + if (handles%id_total_lat_frunoff > 0 .and. associated(fluxes%latent_frunoff_diag)) then + total_transport = global_area_integral(fluxes%latent_frunoff_diag, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lat_frunoff, total_transport, diag) + endif + + if ((handles%id_sens > 0) .and. associated(fluxes%sens)) then + call post_data(handles%id_sens, fluxes%sens, diag) + endif + + if ((handles%id_seaice_melt_heat > 0) .and. associated(fluxes%seaice_melt_heat)) then + call post_data(handles%id_seaice_melt_heat, fluxes%seaice_melt_heat, diag) + endif + + if ((handles%id_total_seaice_melt_heat > 0) .and. associated(fluxes%seaice_melt_heat)) then + total_transport = global_area_integral(fluxes%seaice_melt_heat, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_seaice_melt_heat, total_transport, diag) + endif + + if ((handles%id_total_sens > 0) .and. associated(fluxes%sens)) then + total_transport = global_area_integral(fluxes%sens, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_sens, total_transport, diag) + endif + if ((handles%id_sens_ga > 0) .and. associated(fluxes%sens)) then + ave_flux = global_area_mean(fluxes%sens, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_sens_ga, ave_flux, diag) + endif + + if ((handles%id_heat_added > 0) .and. associated(fluxes%heat_added)) then + call post_data(handles%id_heat_added, fluxes%heat_added, diag) + endif + + if ((handles%id_total_heat_added > 0) .and. associated(fluxes%heat_added)) then + total_transport = global_area_integral(fluxes%heat_added, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_added, total_transport, diag) + endif + + + ! post the diagnostics for boundary salt fluxes ========================== + + if ((handles%id_saltflux > 0) .and. associated(fluxes%salt_flux)) & + call post_data(handles%id_saltflux, fluxes%salt_flux, diag) + if ((handles%id_total_saltflux > 0) .and. associated(fluxes%salt_flux)) then + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_saltflux, total_transport, diag) + endif + + if ((handles%id_saltFluxAdded > 0) .and. associated(fluxes%salt_flux_added)) & + call post_data(handles%id_saltFluxAdded, fluxes%salt_flux_added, diag) + if ((handles%id_total_saltFluxAdded > 0) .and. associated(fluxes%salt_flux_added)) then + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_added, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_saltFluxAdded, total_transport, diag) + endif + + if (handles%id_saltFluxIn > 0 .and. associated(fluxes%salt_flux_in)) & + call post_data(handles%id_saltFluxIn, fluxes%salt_flux_in, diag) + if ((handles%id_total_saltFluxIn > 0) .and. associated(fluxes%salt_flux_in)) then + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_in, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_saltFluxIn, total_transport, diag) + endif + + if (handles%id_saltFluxBehind > 0 .and. associated(fluxes%salt_left_behind)) & + call post_data(handles%id_saltFluxBehind, fluxes%salt_left_behind, diag) + + if (handles%id_saltFluxGlobalAdj > 0) & + call post_data(handles%id_saltFluxGlobalAdj, fluxes%saltFluxGlobalAdj, diag) + if (handles%id_vPrecGlobalAdj > 0) & + call post_data(handles%id_vPrecGlobalAdj, fluxes%vPrecGlobalAdj, diag) + if (handles%id_netFWGlobalAdj > 0) & + call post_data(handles%id_netFWGlobalAdj, fluxes%netFWGlobalAdj, diag) + if (handles%id_saltFluxGlobalScl > 0) & + call post_data(handles%id_saltFluxGlobalScl, fluxes%saltFluxGlobalScl, diag) + if (handles%id_vPrecGlobalScl > 0) & + call post_data(handles%id_vPrecGlobalScl, fluxes%vPrecGlobalScl, diag) + if (handles%id_netFWGlobalScl > 0) & + call post_data(handles%id_netFWGlobalScl, fluxes%netFWGlobalScl, diag) + + ! post diagnostics related to tracer surface fluxes ======================== + + if ((handles%id_ice_fraction > 0) .and. associated(fluxes%ice_fraction)) & + call post_data(handles%id_ice_fraction, fluxes%ice_fraction, diag) + + if ((handles%id_u10_sqr > 0) .and. associated(fluxes%u10_sqr)) & + call post_data(handles%id_u10_sqr, fluxes%u10_sqr, diag) + + ! remaining boundary terms ================================================== + + if ((handles%id_psurf > 0) .and. associated(fluxes%p_surf)) & + call post_data(handles%id_psurf, fluxes%p_surf, diag) + + if ((handles%id_TKE_tidal > 0) .and. associated(fluxes%TKE_tidal)) & + call post_data(handles%id_TKE_tidal, fluxes%TKE_tidal, diag) + + if ((handles%id_buoy > 0) .and. associated(fluxes%buoy)) & + call post_data(handles%id_buoy, fluxes%buoy, diag) + + if ((handles%id_tau_mag > 0) .and. associated(fluxes%tau_mag)) & + call post_data(handles%id_tau_mag, fluxes%tau_mag, diag) + + if ((handles%id_ustar > 0) .and. associated(fluxes%ustar)) & + call post_data(handles%id_ustar, fluxes%ustar, diag) + + !if ((handles%id_omega_w2x > 0) .and. associated(fluxes%omega_w2x)) & + ! call post_data(handles%id_omega_w2x, fluxes%omega_w2x, diag) + + if ((handles%id_ustar_berg > 0) .and. associated(fluxes%ustar_berg)) & + call post_data(handles%id_ustar_berg, fluxes%ustar_berg, diag) + + if ((handles%id_frac_ice_cover > 0) .and. associated(fluxes%frac_shelf_h)) & + call post_data(handles%id_frac_ice_cover, fluxes%frac_shelf_h, diag) + + if ((handles%id_ustar_ice_cover > 0) .and. associated(fluxes%ustar_shelf)) & + call post_data(handles%id_ustar_ice_cover, fluxes%ustar_shelf, diag) + + ! wave forcing =============================================================== + if (handles%id_lamult > 0) & + call post_data(handles%id_lamult, fluxes%lamult, diag) + + ! endif ! query_averaging_enabled + call disable_averaging(diag) + + if (turns /= 0) then + call deallocate_forcing_type(fluxes) + deallocate(fluxes) + endif + + call cpu_clock_end(handles%id_clock_forcing) +end subroutine forcing_diagnostics + + +!> Conditionally allocate fields within the forcing type +subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & + shelf, iceberg, salt, fix_accum_bug, cfc, waves, & + shelf_sfc_accumulation, lamult, hevap, tau_mag) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + logical, optional, intent(in) :: water !< If present and true, allocate water fluxes + logical, optional, intent(in) :: heat !< If present and true, allocate heat fluxes + logical, optional, intent(in) :: ustar !< If present and true, allocate ustar and related fields + logical, optional, intent(in) :: press !< If present and true, allocate p_surf and related fields + logical, optional, intent(in) :: shelf !< If present and true, allocate fluxes for ice-shelf + logical, optional, intent(in) :: iceberg !< If present and true, allocate fluxes for icebergs + logical, optional, intent(in) :: salt !< If present and true, allocate salt fluxes + logical, optional, intent(in) :: fix_accum_bug !< If present and true, avoid using a bug in + !! accumulation of ustar_gustless + logical, optional, intent(in) :: cfc !< If present and true, allocate fields needed + !! for cfc surface fluxes + logical, optional, intent(in) :: waves !< If present and true, allocate wave fields + logical, optional, intent(in) :: shelf_sfc_accumulation !< If present and true, and shelf is true, + !! then allocate surface flux deposition from the atmosphere + !! over ice shelves and ice sheets. + logical, optional, intent(in) :: lamult !< If present and true, allocate langmuir enhancement factor + logical, optional, intent(in) :: hevap !< If present and true, allocate heat content evap. + !! This field must be allocated when enthalpy is provided + !! via coupler. + logical, optional, intent(in) :: tau_mag !< If present and true, allocate tau_mag and related fields + + ! Local variables + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + logical :: shelf_sfc_acc, enthalpy_mom + + ! if true, allocate fluxes needed to calculate enthalpy terms in MOM6 + enthalpy_mom = .true. + if (present (hevap)) enthalpy_mom = .not. hevap + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + shelf_sfc_acc=.false. + if (present(shelf_sfc_accumulation)) shelf_sfc_acc=shelf_sfc_accumulation + + call myAlloc(fluxes%ustar,isd,ied,jsd,jed, ustar) + call myAlloc(fluxes%ustar_gustless,isd,ied,jsd,jed, ustar) + call myAlloc(fluxes%tau_mag,isd,ied,jsd,jed, ustar) + + ! Note that myAlloc can be called safely multiple times for the same pointer. + call myAlloc(fluxes%tau_mag,isd,ied,jsd,jed, tau_mag) + call myAlloc(fluxes%tau_mag_gustless,isd,ied,jsd,jed, tau_mag) + + call myAlloc(fluxes%evap,isd,ied,jsd,jed, water) + call myAlloc(fluxes%lprec,isd,ied,jsd,jed, water) + call myAlloc(fluxes%fprec,isd,ied,jsd,jed, water) + call myAlloc(fluxes%vprec,isd,ied,jsd,jed, water) + call myAlloc(fluxes%lrunoff,isd,ied,jsd,jed, water) + call myAlloc(fluxes%frunoff,isd,ied,jsd,jed, water) + call myAlloc(fluxes%seaice_melt,isd,ied,jsd,jed, water) + call myAlloc(fluxes%netMassOut,isd,ied,jsd,jed, water) + call myAlloc(fluxes%netMassIn,isd,ied,jsd,jed, water) + call myAlloc(fluxes%seaice_melt_heat,isd,ied,jsd,jed, heat) + call myAlloc(fluxes%sw,isd,ied,jsd,jed, heat) + call myAlloc(fluxes%lw,isd,ied,jsd,jed, heat) + call myAlloc(fluxes%latent,isd,ied,jsd,jed, heat) + call myAlloc(fluxes%sens,isd,ied,jsd,jed, heat) + call myAlloc(fluxes%latent_evap_diag,isd,ied,jsd,jed, heat) + call myAlloc(fluxes%latent_fprec_diag,isd,ied,jsd,jed, heat) + call myAlloc(fluxes%latent_frunoff_diag,isd,ied,jsd,jed, heat) + + call myAlloc(fluxes%salt_flux,isd,ied,jsd,jed, salt) + + if (present(heat) .and. present(water)) then ; if (heat .and. water) then + call myAlloc(fluxes%heat_content_cond,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_evap,isd,ied,jsd,jed, .not. enthalpy_mom) + call myAlloc(fluxes%heat_content_lprec,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_fprec,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_vprec,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_lrunoff,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_frunoff,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_massout,isd,ied,jsd,jed, enthalpy_mom) + call myAlloc(fluxes%heat_content_massin,isd,ied,jsd,jed, enthalpy_mom) + endif ; endif + + call myAlloc(fluxes%p_surf,isd,ied,jsd,jed, press) + + ! These fields should only be allocated if ice shelf is enabled. + if (present(shelf)) then; if (shelf) then + call myAlloc(fluxes%frac_shelf_h,isd,ied,jsd,jed, shelf) + call myAlloc(fluxes%ustar_shelf,isd,ied,jsd,jed, shelf) + call myAlloc(fluxes%iceshelf_melt,isd,ied,jsd,jed, shelf) + if (shelf_sfc_acc) call myAlloc(fluxes%shelf_sfc_mass_flux,isd,ied,jsd,jed, shelf_sfc_acc) + endif; endif + + !These fields should only on allocated when iceberg area is being passed through the coupler. + call myAlloc(fluxes%ustar_berg,isd,ied,jsd,jed, iceberg) + call myAlloc(fluxes%area_berg,isd,ied,jsd,jed, iceberg) + call myAlloc(fluxes%mass_berg,isd,ied,jsd,jed, iceberg) + + !These fields should only on allocated when USE_CFC_CAP is activated. + call myAlloc(fluxes%ice_fraction,isd,ied,jsd,jed, cfc) + call myAlloc(fluxes%u10_sqr,isd,ied,jsd,jed, cfc) + + !These fields should only on allocated when wave coupling is activated. + call myAlloc(fluxes%ice_fraction,isd,ied,jsd,jed, waves) + call myAlloc(fluxes%lamult,isd,ied,jsd,jed, lamult) + + if (present(fix_accum_bug)) fluxes%gustless_accum_bug = .not.fix_accum_bug +end subroutine allocate_forcing_by_group + +!> Allocate elements of a new forcing type based on their status in an existing type. +subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) + type(forcing), intent(in) :: fluxes_ref !< Reference fluxes + type(ocean_grid_type), intent(in) :: G !< Grid metric of target fluxes + type(forcing), intent(out) :: fluxes !< Target fluxes + + logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf + logical :: do_iceberg, do_heat_added, do_buoy + + call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, do_taumag, do_press, & + do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) + + call allocate_forcing_type(G, fluxes, do_water, do_heat, do_ustar, & + do_press, do_shelf, do_iceberg, do_salt, tau_mag=do_taumag) + + ! The following fluxes would typically be allocated by the driver + call myAlloc(fluxes%sw_vis_dir, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%sw_vis_dir)) + call myAlloc(fluxes%sw_vis_dif, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%sw_vis_dif)) + call myAlloc(fluxes%sw_nir_dir, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%sw_nir_dir)) + call myAlloc(fluxes%sw_nir_dif, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%sw_nir_dif)) + + call myAlloc(fluxes%salt_flux_in, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%salt_flux_in)) + call myAlloc(fluxes%salt_flux_added, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%salt_flux_added)) + + call myAlloc(fluxes%p_surf_full, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%p_surf_full)) + + call myAlloc(fluxes%heat_added, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%heat_added)) + call myAlloc(fluxes%buoy, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%buoy)) + + call myAlloc(fluxes%TKE_tidal, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%TKE_tidal)) + call myAlloc(fluxes%ustar_tidal, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%ustar_tidal)) + + ! This flag would normally be set by a control flag in allocate_forcing_type. + ! Here we copy the flag from the reference forcing. + fluxes%gustless_accum_bug = fluxes_ref%gustless_accum_bug +end subroutine allocate_forcing_by_ref + + +!> Conditionally allocate fields within the mechanical forcing type using +!! control flags. +subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & + press, iceberg, waves, num_stk_bands, tau_mag) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(mech_forcing), intent(inout) :: forces !< Forcing fields structure + + logical, optional, intent(in) :: stress !< If present and true, allocate taux, tauy + logical, optional, intent(in) :: ustar !< If present and true, allocate ustar and related fields + logical, optional, intent(in) :: shelf !< If present and true, allocate forces for ice-shelf + logical, optional, intent(in) :: press !< If present and true, allocate p_surf and related fields + logical, optional, intent(in) :: iceberg !< If present and true, allocate forces for icebergs + logical, optional, intent(in) :: waves !< If present and true, allocate wave fields + integer, optional, intent(in) :: num_stk_bands !< Number of Stokes bands to allocate + logical, optional, intent(in) :: tau_mag !< If present and true, allocate tau_mag + + ! Local variables + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + call myAlloc(forces%taux,IsdB,IedB,jsd,jed, stress) + call myAlloc(forces%tauy,isd,ied,JsdB,JedB, stress) + + call myAlloc(forces%ustar,isd,ied,jsd,jed, ustar) + call myAlloc(forces%tau_mag,isd,ied,jsd,jed, ustar) + ! Note that myAlloc can be called safely multiple times for the same pointer. + call myAlloc(forces%tau_mag,isd,ied,jsd,jed, tau_mag) + + call myAlloc(forces%p_surf,isd,ied,jsd,jed, press) + call myAlloc(forces%p_surf_full,isd,ied,jsd,jed, press) + call myAlloc(forces%net_mass_src,isd,ied,jsd,jed, press) + + call myAlloc(forces%rigidity_ice_u,IsdB,IedB,jsd,jed, shelf) + call myAlloc(forces%rigidity_ice_v,isd,ied,JsdB,JedB, shelf) + call myAlloc(forces%frac_shelf_u,IsdB,IedB,jsd,jed, shelf) + call myAlloc(forces%frac_shelf_v,isd,ied,JsdB,JedB, shelf) + + !These fields should only on allocated when iceberg area is being passed through the coupler. + call myAlloc(forces%area_berg,isd,ied,jsd,jed, iceberg) + call myAlloc(forces%mass_berg,isd,ied,jsd,jed, iceberg) + + !These fields should only be allocated when waves + if (present(waves)) then; if (waves) then; + if (.not. present(num_stk_bands)) then + call MOM_error(FATAL,"Requested to & + &initialize with waves, but no waves are present.") + endif + if (num_stk_bands > 0) then + if (.not.associated(forces%ustkb)) then + allocate(forces%stk_wavenumbers(num_stk_bands), source=0.0) + allocate(forces%ustkb(isd:ied,jsd:jed,num_stk_bands), source=0.0) + allocate(forces%vstkb(isd:ied,jsd:jed,num_stk_bands), source=0.0) + endif + endif + endif ; endif + +end subroutine allocate_mech_forcing_by_group + + +!> Conditionally allocate fields within the mechanical forcing type based on a +!! reference forcing. +subroutine allocate_mech_forcing_from_ref(forces_ref, G, forces) + type(mech_forcing), intent(in) :: forces_ref !< Reference forcing fields + type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing + type(mech_forcing), intent(out) :: forces !< Mechanical forcing fields + + logical :: do_stress, do_ustar, do_tau_mag, do_shelf, do_press, do_iceberg + + ! Identify the active fields in the reference forcing + call get_mech_forcing_groups(forces_ref, do_stress, do_ustar, do_tau_mag, do_shelf, & + do_press, do_iceberg) + + call allocate_mech_forcing(G, forces, do_stress, do_ustar, do_shelf, & + do_press, do_iceberg, tau_mag=do_tau_mag) +end subroutine allocate_mech_forcing_from_ref + + +!> Return flags indicating which groups of forcings are allocated +subroutine get_forcing_groups(fluxes, water, heat, ustar, tau_mag, press, shelf, & + iceberg, salt, heat_added, buoy) + type(forcing), intent(in) :: fluxes !< Reference flux fields + logical, intent(out) :: water !< True if fluxes contains water-based fluxes + logical, intent(out) :: heat !< True if fluxes contains heat-based fluxes + logical, intent(out) :: ustar !< True if fluxes contains ustar + logical, intent(out) :: tau_mag !< True if fluxes contains tau_mag + logical, intent(out) :: press !< True if fluxes contains surface pressure + logical, intent(out) :: shelf !< True if fluxes contains ice shelf fields + logical, intent(out) :: iceberg !< True if fluxes contains iceberg fluxes + logical, intent(out) :: salt !< True if fluxes contains salt flux + logical, intent(out) :: heat_added !< True if fluxes contains explicit heat + logical, intent(out) :: buoy !< True if fluxes contains buoyancy fluxes + + ! NOTE: heat, salt, heat_added, and buoy would typically depend on each other + ! to some degree. But since this would be enforced at the driver level, + ! we handle them here as independent flags. + + ustar = associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless) + tau_mag = associated(fluxes%tau_mag) .and. associated(fluxes%tau_mag_gustless) + ! TODO: Check for all associated fields, but for now just check one as a marker + water = associated(fluxes%evap) + heat = associated(fluxes%seaice_melt_heat) + salt = associated(fluxes%salt_flux) + press = associated(fluxes%p_surf) + shelf = associated(fluxes%frac_shelf_h) + iceberg = associated(fluxes%ustar_berg) + heat_added = associated(fluxes%heat_added) + buoy = associated(fluxes%buoy) +end subroutine get_forcing_groups + + +!> Return flags indicating which groups of mechanical forcings are allocated +subroutine get_mech_forcing_groups(forces, stress, ustar, tau_mag, shelf, press, iceberg) + type(mech_forcing), intent(in) :: forces !< Reference forcing fields + logical, intent(out) :: stress !< True if forces contains wind stress fields + logical, intent(out) :: ustar !< True if forces contains ustar field + logical, intent(out) :: tau_mag !< True if forces contains tau_mag field + logical, intent(out) :: shelf !< True if forces contains ice shelf fields + logical, intent(out) :: press !< True if forces contains pressure fields + logical, intent(out) :: iceberg !< True if forces contains iceberg fields + + stress = associated(forces%taux) & + .and. associated(forces%tauy) + ustar = associated(forces%ustar) + tau_mag = associated(forces%tau_mag) + shelf = associated(forces%rigidity_ice_u) & + .and. associated(forces%rigidity_ice_v) & + .and. associated(forces%frac_shelf_u) & + .and. associated(forces%frac_shelf_v) + press = associated(forces%p_surf) & + .and. associated(forces%p_surf_full) & + .and. associated(forces%net_mass_src) + iceberg = associated(forces%area_berg) & + .and. associated(forces%mass_berg) +end subroutine get_mech_forcing_groups + + +!> Allocates and zeroes-out array. +subroutine myAlloc(array, is, ie, js, je, flag) + real, dimension(:,:), pointer :: array !< Array to be allocated [arbitrary] + integer, intent(in) :: is !< Start i-index + integer, intent(in) :: ie !< End i-index + integer, intent(in) :: js !< Start j-index + integer, intent(in) :: je !< End j-index + logical, optional, intent(in) :: flag !< Flag to indicate to allocate + + if (present(flag)) then ; if (flag) then ; if (.not.associated(array)) then + allocate(array(is:ie,js:je), source=0.0) + endif ; endif ; endif +end subroutine myAlloc + +!> Deallocate the forcing type +subroutine deallocate_forcing_type(fluxes) + type(forcing), intent(inout) :: fluxes !< Forcing fields structure + + !if (associated(fluxes%omega_w2x)) deallocate(fluxes%omega_w2x) + if (associated(fluxes%ustar)) deallocate(fluxes%ustar) + if (associated(fluxes%ustar_gustless)) deallocate(fluxes%ustar_gustless) + if (associated(fluxes%tau_mag)) deallocate(fluxes%tau_mag) + if (associated(fluxes%buoy)) deallocate(fluxes%buoy) + if (associated(fluxes%sw)) deallocate(fluxes%sw) + if (associated(fluxes%seaice_melt_heat)) deallocate(fluxes%seaice_melt_heat) + if (associated(fluxes%sw_vis_dir)) deallocate(fluxes%sw_vis_dir) + if (associated(fluxes%sw_vis_dif)) deallocate(fluxes%sw_vis_dif) + if (associated(fluxes%sw_nir_dir)) deallocate(fluxes%sw_nir_dir) + if (associated(fluxes%sw_nir_dif)) deallocate(fluxes%sw_nir_dif) + if (associated(fluxes%lw)) deallocate(fluxes%lw) + if (associated(fluxes%latent)) deallocate(fluxes%latent) + if (associated(fluxes%latent_evap_diag)) deallocate(fluxes%latent_evap_diag) + if (associated(fluxes%latent_fprec_diag)) deallocate(fluxes%latent_fprec_diag) + if (associated(fluxes%latent_frunoff_diag)) deallocate(fluxes%latent_frunoff_diag) + if (associated(fluxes%sens)) deallocate(fluxes%sens) + if (associated(fluxes%heat_added)) deallocate(fluxes%heat_added) + if (associated(fluxes%heat_content_lrunoff)) deallocate(fluxes%heat_content_lrunoff) + if (associated(fluxes%heat_content_frunoff)) deallocate(fluxes%heat_content_frunoff) + if (associated(fluxes%heat_content_lprec)) deallocate(fluxes%heat_content_lprec) + if (associated(fluxes%heat_content_fprec)) deallocate(fluxes%heat_content_fprec) + if (associated(fluxes%heat_content_cond)) deallocate(fluxes%heat_content_cond) + if (associated(fluxes%heat_content_evap)) deallocate(fluxes%heat_content_evap) + if (associated(fluxes%heat_content_massout)) deallocate(fluxes%heat_content_massout) + if (associated(fluxes%heat_content_massin)) deallocate(fluxes%heat_content_massin) + if (associated(fluxes%evap)) deallocate(fluxes%evap) + if (associated(fluxes%lprec)) deallocate(fluxes%lprec) + if (associated(fluxes%fprec)) deallocate(fluxes%fprec) + if (associated(fluxes%vprec)) deallocate(fluxes%vprec) + if (associated(fluxes%lrunoff)) deallocate(fluxes%lrunoff) + if (associated(fluxes%frunoff)) deallocate(fluxes%frunoff) + if (associated(fluxes%seaice_melt)) deallocate(fluxes%seaice_melt) + if (associated(fluxes%netMassOut)) deallocate(fluxes%netMassOut) + if (associated(fluxes%netMassIn)) deallocate(fluxes%netMassIn) + if (associated(fluxes%salt_flux)) deallocate(fluxes%salt_flux) + if (associated(fluxes%p_surf_full)) deallocate(fluxes%p_surf_full) + if (associated(fluxes%p_surf)) deallocate(fluxes%p_surf) + if (associated(fluxes%TKE_tidal)) deallocate(fluxes%TKE_tidal) + if (associated(fluxes%ustar_tidal)) deallocate(fluxes%ustar_tidal) + if (associated(fluxes%ustar_shelf)) deallocate(fluxes%ustar_shelf) + if (associated(fluxes%iceshelf_melt)) deallocate(fluxes%iceshelf_melt) + if (associated(fluxes%shelf_sfc_mass_flux)) & + deallocate(fluxes%shelf_sfc_mass_flux) + if (associated(fluxes%frac_shelf_h)) deallocate(fluxes%frac_shelf_h) + if (associated(fluxes%ustar_berg)) deallocate(fluxes%ustar_berg) + if (associated(fluxes%area_berg)) deallocate(fluxes%area_berg) + if (associated(fluxes%mass_berg)) deallocate(fluxes%mass_berg) + if (associated(fluxes%ice_fraction)) deallocate(fluxes%ice_fraction) + if (associated(fluxes%u10_sqr)) deallocate(fluxes%u10_sqr) + + call coupler_type_destructor(fluxes%tr_fluxes) + +end subroutine deallocate_forcing_type + + +!> Deallocate the mechanical forcing type +subroutine deallocate_mech_forcing(forces) + type(mech_forcing), intent(inout) :: forces !< Forcing fields structure + + !if (associated(forces%omega_w2x)) deallocate(forces%omega_w2x) + if (associated(forces%taux)) deallocate(forces%taux) + if (associated(forces%tauy)) deallocate(forces%tauy) + if (associated(forces%ustar)) deallocate(forces%ustar) + if (associated(forces%tau_mag)) deallocate(forces%tau_mag) + if (associated(forces%p_surf)) deallocate(forces%p_surf) + if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) + if (associated(forces%net_mass_src)) deallocate(forces%net_mass_src) + if (associated(forces%rigidity_ice_u)) deallocate(forces%rigidity_ice_u) + if (associated(forces%rigidity_ice_v)) deallocate(forces%rigidity_ice_v) + if (associated(forces%frac_shelf_u)) deallocate(forces%frac_shelf_u) + if (associated(forces%frac_shelf_v)) deallocate(forces%frac_shelf_v) + if (associated(forces%area_berg)) deallocate(forces%area_berg) + if (associated(forces%mass_berg)) deallocate(forces%mass_berg) + +end subroutine deallocate_mech_forcing + + +!< Rotate the fluxes by a set number of quarter turns +subroutine rotate_forcing(fluxes_in, fluxes, turns) + type(forcing), intent(in) :: fluxes_in !< Input forcing structure + type(forcing), intent(inout) :: fluxes !< Rotated forcing structure + integer, intent(in) :: turns !< Number of quarter turns + + logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf, & + do_iceberg, do_heat_added, do_buoy + + call get_forcing_groups(fluxes_in, do_water, do_heat, do_ustar, do_taumag, do_press, & + do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) + + if (associated(fluxes_in%ustar)) & + call rotate_array(fluxes_in%ustar, turns, fluxes%ustar) + if (associated(fluxes_in%ustar_gustless)) & + call rotate_array(fluxes_in%ustar_gustless, turns, fluxes%ustar_gustless) + + if (associated(fluxes_in%tau_mag)) & + call rotate_array(fluxes_in%tau_mag, turns, fluxes%tau_mag) + if (associated(fluxes_in%tau_mag_gustless)) & + call rotate_array(fluxes_in%tau_mag_gustless, turns, fluxes%tau_mag_gustless) + + if (do_water) then + call rotate_array(fluxes_in%evap, turns, fluxes%evap) + call rotate_array(fluxes_in%lprec, turns, fluxes%lprec) + call rotate_array(fluxes_in%fprec, turns, fluxes%fprec) + call rotate_array(fluxes_in%vprec, turns, fluxes%vprec) + call rotate_array(fluxes_in%lrunoff, turns, fluxes%lrunoff) + call rotate_array(fluxes_in%frunoff, turns, fluxes%frunoff) + call rotate_array(fluxes_in%seaice_melt, turns, fluxes%seaice_melt) + call rotate_array(fluxes_in%netMassOut, turns, fluxes%netMassOut) + call rotate_array(fluxes_in%netMassIn, turns, fluxes%netMassIn) + endif + + if (do_heat) then + call rotate_array(fluxes_in%seaice_melt_heat, turns, fluxes%seaice_melt_heat) + call rotate_array(fluxes_in%sw, turns, fluxes%sw) + call rotate_array(fluxes_in%lw, turns, fluxes%lw) + call rotate_array(fluxes_in%latent, turns, fluxes%latent) + call rotate_array(fluxes_in%sens, turns, fluxes%sens) + call rotate_array(fluxes_in%latent_evap_diag, turns, fluxes%latent_evap_diag) + call rotate_array(fluxes_in%latent_fprec_diag, turns, fluxes%latent_fprec_diag) + call rotate_array(fluxes_in%latent_frunoff_diag, turns, fluxes%latent_frunoff_diag) + endif + + if (do_salt) then + call rotate_array(fluxes_in%salt_flux, turns, fluxes%salt_flux) + endif + + if (do_heat .and. do_water) then + call rotate_array(fluxes_in%heat_content_cond, turns, fluxes%heat_content_cond) + call rotate_array(fluxes_in%heat_content_lprec, turns, fluxes%heat_content_lprec) + call rotate_array(fluxes_in%heat_content_fprec, turns, fluxes%heat_content_fprec) + call rotate_array(fluxes_in%heat_content_vprec, turns, fluxes%heat_content_vprec) + call rotate_array(fluxes_in%heat_content_lrunoff, turns, fluxes%heat_content_lrunoff) + call rotate_array(fluxes_in%heat_content_frunoff, turns, fluxes%heat_content_frunoff) + if (associated (fluxes_in%heat_content_evap)) then + call rotate_array(fluxes_in%heat_content_evap, turns, fluxes%heat_content_evap) + else + call rotate_array(fluxes_in%heat_content_massout, turns, fluxes%heat_content_massout) + call rotate_array(fluxes_in%heat_content_massin, turns, fluxes%heat_content_massin) + endif + endif + + if (do_press) then + call rotate_array(fluxes_in%p_surf, turns, fluxes%p_surf) + endif + + if (do_shelf) then + call rotate_array(fluxes_in%frac_shelf_h, turns, fluxes%frac_shelf_h) + call rotate_array(fluxes_in%ustar_shelf, turns, fluxes%ustar_shelf) + call rotate_array(fluxes_in%iceshelf_melt, turns, fluxes%iceshelf_melt) + call rotate_array(fluxes_in%shelf_sfc_mass_flux, turns, fluxes%shelf_sfc_mass_flux) + endif + + if (do_iceberg) then + call rotate_array(fluxes_in%ustar_berg, turns, fluxes%ustar_berg) + call rotate_array(fluxes_in%area_berg, turns, fluxes%area_berg) + !BGR: pretty sure the following line isn't supposed to be here. + call rotate_array(fluxes_in%iceshelf_melt, turns, fluxes%iceshelf_melt) + endif + + if (do_heat_added) then + call rotate_array(fluxes_in%heat_added, turns, fluxes%heat_added) + endif + + ! The following fields are handled by drivers rather than control flags. + if (associated(fluxes_in%sw_vis_dir)) & + call rotate_array(fluxes_in%sw_vis_dir, turns, fluxes%sw_vis_dir) + if (associated(fluxes_in%sw_vis_dif)) & + call rotate_array(fluxes_in%sw_vis_dif, turns, fluxes%sw_vis_dif) + if (associated(fluxes_in%sw_nir_dir)) & + call rotate_array(fluxes_in%sw_nir_dir, turns, fluxes%sw_nir_dir) + if (associated(fluxes_in%sw_nir_dif)) & + call rotate_array(fluxes_in%sw_nir_dif, turns, fluxes%sw_nir_dif) + + if (associated(fluxes_in%salt_flux_in)) & + call rotate_array(fluxes_in%salt_flux_in, turns, fluxes%salt_flux_in) + if (associated(fluxes_in%salt_flux_added)) & + call rotate_array(fluxes_in%salt_flux_added, turns, fluxes%salt_flux_added) + + if (associated(fluxes_in%p_surf_full)) & + call rotate_array(fluxes_in%p_surf_full, turns, fluxes%p_surf_full) + + if (associated(fluxes_in%buoy)) & + call rotate_array(fluxes_in%buoy, turns, fluxes%buoy) + + if (associated(fluxes_in%TKE_tidal)) & + call rotate_array(fluxes_in%TKE_tidal, turns, fluxes%TKE_tidal) + if (associated(fluxes_in%ustar_tidal)) & + call rotate_array(fluxes_in%ustar_tidal, turns, fluxes%ustar_tidal) + + ! NOTE: Tracer fields are handled by FMS, so are left unrotated. Any + ! reads/writes to tr_fields must be appropriately rotated. + if (coupler_type_initialized(fluxes%tr_fluxes)) then + call coupler_type_copy_data(fluxes_in%tr_fluxes, fluxes%tr_fluxes) + endif + + ! Scalars and flags + fluxes%accumulate_p_surf = fluxes_in%accumulate_p_surf + + fluxes%vPrecGlobalAdj = fluxes_in%vPrecGlobalAdj + fluxes%saltFluxGlobalAdj = fluxes_in%saltFluxGlobalAdj + fluxes%netFWGlobalAdj = fluxes_in%netFWGlobalAdj + fluxes%vPrecGlobalScl = fluxes_in%vPrecGlobalScl + fluxes%saltFluxGlobalScl = fluxes_in%saltFluxGlobalScl + fluxes%netFWGlobalScl = fluxes_in%netFWGlobalScl + + fluxes%fluxes_used = fluxes_in%fluxes_used + fluxes%dt_buoy_accum = fluxes_in%dt_buoy_accum + fluxes%C_p = fluxes_in%C_p + ! NOTE: gustless_accum_bug is set during allocation + + fluxes%num_msg = fluxes_in%num_msg + fluxes%max_msg = fluxes_in%max_msg +end subroutine rotate_forcing + +!< Rotate the forcing fields from the input domain +subroutine rotate_mech_forcing(forces_in, turns, forces) + type(mech_forcing), intent(in) :: forces_in !< Forcing on the input domain + integer, intent(in) :: turns !< Number of quarter-turns + type(mech_forcing), intent(inout) :: forces !< Forcing on the rotated domain + + logical :: do_stress, do_ustar, do_tau_mag, do_shelf, do_press, do_iceberg + + call get_mech_forcing_groups(forces_in, do_stress, do_ustar, do_tau_mag, do_shelf, & + do_press, do_iceberg) + + if (do_stress) & + call rotate_vector(forces_in%taux, forces_in%tauy, turns, & + forces%taux, forces%tauy) + + if (associated(forces_in%ustar)) & + call rotate_array(forces_in%ustar, turns, forces%ustar) + if (associated(forces_in%tau_mag)) & + call rotate_array(forces_in%tau_mag, turns, forces%tau_mag) + + if (do_shelf) then + call rotate_array_pair( & + forces_in%rigidity_ice_u, forces_in%rigidity_ice_v, turns, & + forces%rigidity_ice_u, forces%rigidity_ice_v & + ) + call rotate_array_pair( & + forces_in%frac_shelf_u, forces_in%frac_shelf_v, turns, & + forces%frac_shelf_u, forces%frac_shelf_v & + ) + endif + + if (do_press) then + call rotate_array(forces_in%p_surf, turns, forces%p_surf) + call rotate_array(forces_in%p_surf_full, turns, forces%p_surf_full) + call rotate_array(forces_in%net_mass_src, turns, forces%net_mass_src) + + ! p_surf_SSH points to either p_surf or p_surf_full + if (associated(forces_in%p_surf_SSH, forces_in%p_surf)) then + forces%p_surf_SSH => forces%p_surf + else if (associated(forces_in%p_surf_SSH, forces_in%p_surf_full)) then + forces%p_surf_SSH => forces%p_surf_full + else + forces%p_surf_SSH => null() + endif + endif + + if (do_iceberg) then + call rotate_array(forces_in%area_berg, turns, forces%area_berg) + call rotate_array(forces_in%mass_berg, turns, forces%mass_berg) + endif + + ! Copy fields + forces%dt_force_accum = forces_in%dt_force_accum + forces%net_mass_src_set = forces_in%net_mass_src_set + forces%accumulate_p_surf = forces_in%accumulate_p_surf + forces%accumulate_rigidity = forces_in%accumulate_rigidity + forces%initialized = forces_in%initialized +end subroutine rotate_mech_forcing + +!< Homogenize the forcing fields from the input domain +subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) + type(mech_forcing), intent(inout) :: forces !< Forcing on the input domain + type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< A reference density of seawater [R ~> kg m-3], + !! as used to calculate ustar. + logical, optional, intent(in) :: UpdateUstar !< A logical to determine if Ustar should be directly averaged + !! or updated from mean tau. + + real :: tx_mean, ty_mean ! Mean wind stresses [R L Z T-2 ~> Pa] + real :: tau_mag ! The magnitude of the wind stresses [R L Z T-2 ~> Pa] + real :: Irho0 ! Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] + logical :: do_stress, do_ustar, do_taumag, do_shelf, do_press, do_iceberg, tau2ustar + integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB + + Irho0 = US%L_to_Z / Rho0 + + tau2ustar = .false. + if (present(UpdateUstar)) tau2ustar = UpdateUstar + + call get_mech_forcing_groups(forces, do_stress, do_ustar, do_taumag, do_shelf, & + do_press, do_iceberg) + + if (do_stress) then + tx_mean = global_area_mean_u(forces%taux, G, tmp_scale=US%RLZ_T2_to_Pa) + do j=js,je ; do i=isB,ieB + 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%RLZ_T2_to_Pa) + do j=jsB,jeB ; do i=is,ie + if (G%mask2dCv(i,J) > 0.0) forces%tauy(i,J) = ty_mean + enddo ; enddo + if (tau2ustar) then + tau_mag = sqrt(tx_mean**2 + ty_mean**2) + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + forces%tau_mag(i,j) = tau_mag + endif ; enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + forces%ustar(i,j) = sqrt(tau_mag * Irho0) + endif ; enddo ; enddo ; endif + else + if (associated(forces%ustar)) & + call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + if (associated(forces%tau_mag)) & + call homogenize_field_t(forces%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) + endif + else + if (associated(forces%ustar)) & + call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + if (associated(forces%tau_mag)) & + call homogenize_field_t(forces%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) + endif + + if (do_shelf) then + call homogenize_field_u(forces%rigidity_ice_u, G, tmp_scale=US%L_T_to_m_s*US%L_to_m**2*US%L_to_Z) + call homogenize_field_v(forces%rigidity_ice_v, G, tmp_scale=US%L_T_to_m_s*US%L_to_m**2*US%L_to_Z) + call homogenize_field_u(forces%frac_shelf_u, G) + call homogenize_field_v(forces%frac_shelf_v, G) + endif + + if (do_press) then + ! NOTE: p_surf_SSH either points to p_surf or p_surf_full + call homogenize_field_t(forces%p_surf, G, tmp_scale=US%RL2_T2_to_Pa) + call homogenize_field_t(forces%p_surf_full, G, tmp_scale=US%RL2_T2_to_Pa) + call homogenize_field_t(forces%net_mass_src, G, tmp_scale=US%RZ_T_to_kg_m2s) + endif + + if (do_iceberg) then + call homogenize_field_t(forces%area_berg, G) + call homogenize_field_t(forces%mass_berg, G, tmp_scale=US%RZ_to_kg_m2) + endif + +end subroutine homogenize_mech_forcing + +!< Homogenize the fluxes +subroutine homogenize_forcing(fluxes, G, GV, US) + type(forcing), intent(inout) :: fluxes !< Input forcing struct + type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf + logical :: do_iceberg, do_heat_added, do_buoy + + call get_forcing_groups(fluxes, do_water, do_heat, do_ustar, do_taumag, do_press, & + do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) + + if (associated(fluxes%ustar)) & + call homogenize_field_t(fluxes%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + if (associated(fluxes%ustar_gustless)) & + call homogenize_field_t(fluxes%ustar_gustless, G, tmp_scale=US%Z_to_m*US%s_to_T) + + if (associated(fluxes%tau_mag)) & + call homogenize_field_t(fluxes%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) + if (associated(fluxes%tau_mag_gustless)) & + call homogenize_field_t(fluxes%tau_mag_gustless, G, tmp_scale=US%RLZ_T2_to_Pa) + + if (do_water) then + call homogenize_field_t(fluxes%evap, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%lprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%fprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%vprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%lrunoff, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%frunoff, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%seaice_melt, G, tmp_scale=US%RZ_T_to_kg_m2s) + ! These two calls might not be needed. + call homogenize_field_t(fluxes%netMassOut, G, tmp_scale=GV%H_to_mks) + call homogenize_field_t(fluxes%netMassIn, G, tmp_scale=GV%H_to_mks) + !This was removed and I don't think replaced. Not needed? + !call homogenize_field_t(fluxes%netSalt, G) + endif + + if (do_heat) then + call homogenize_field_t(fluxes%seaice_melt_heat, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%sw, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%lw, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%sens, G, tmp_scale=US%QRZ_T_to_W_m2) + !### These are for diagnostics only and may not be needed. + call homogenize_field_t(fluxes%latent_evap_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent_fprec_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent_frunoff_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + endif + + if (do_salt) call homogenize_field_t(fluxes%salt_flux, G, tmp_scale=US%RZ_T_to_kg_m2s) + + if (do_heat .and. do_water) then + call homogenize_field_t(fluxes%heat_content_cond, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_lprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_fprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_vprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_lrunoff, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_frunoff, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_massout, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_massin, G, tmp_scale=US%QRZ_T_to_W_m2) + endif + + if (do_press) call homogenize_field_t(fluxes%p_surf, G, tmp_scale=US%RL2_T2_to_Pa) + + if (do_shelf) then + call homogenize_field_t(fluxes%frac_shelf_h, G) + call homogenize_field_t(fluxes%ustar_shelf, G, tmp_scale=US%Z_to_m*US%s_to_T) + call homogenize_field_t(fluxes%iceshelf_melt, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%shelf_sfc_mass_flux, G, tmp_scale=US%RZ_T_to_kg_m2s) + endif + + if (do_iceberg) then + call homogenize_field_t(fluxes%ustar_berg, G, tmp_scale=US%Z_to_m*US%s_to_T) + call homogenize_field_t(fluxes%area_berg, G) + endif + + if (do_heat_added) then + call homogenize_field_t(fluxes%heat_added, G, tmp_scale=US%QRZ_T_to_W_m2) + endif + + ! The following fields are handled by drivers rather than control flags. + if (associated(fluxes%sw_vis_dir)) & + call homogenize_field_t(fluxes%sw_vis_dir, G, tmp_scale=US%QRZ_T_to_W_m2) + + if (associated(fluxes%sw_vis_dif)) & + call homogenize_field_t(fluxes%sw_vis_dif, G, tmp_scale=US%QRZ_T_to_W_m2) + + if (associated(fluxes%sw_nir_dir)) & + call homogenize_field_t(fluxes%sw_nir_dir, G, tmp_scale=US%QRZ_T_to_W_m2) + + if (associated(fluxes%sw_nir_dif)) & + call homogenize_field_t(fluxes%sw_nir_dif, G, tmp_scale=US%QRZ_T_to_W_m2) + + if (associated(fluxes%salt_flux_in)) & + call homogenize_field_t(fluxes%salt_flux_in, G, tmp_scale=US%RZ_T_to_kg_m2s) + + if (associated(fluxes%salt_flux_added)) & + call homogenize_field_t(fluxes%salt_flux_added, G, tmp_scale=US%RZ_T_to_kg_m2s) + + if (associated(fluxes%p_surf_full)) & + call homogenize_field_t(fluxes%p_surf_full, G, tmp_scale=US%RL2_T2_to_Pa) + + if (associated(fluxes%buoy)) & + call homogenize_field_t(fluxes%buoy, G, tmp_scale=US%L_to_m**2*US%s_to_T**3) + + if (associated(fluxes%TKE_tidal)) & + call homogenize_field_t(fluxes%TKE_tidal, G, tmp_scale=US%RZ3_T3_to_W_m2) + + if (associated(fluxes%ustar_tidal)) & + call homogenize_field_t(fluxes%ustar_tidal, G, tmp_scale=US%Z_to_m*US%s_to_T) + + ! TODO: tracer flux homogenization + ! Having a warning causes a lot of errors (each time step). + !if (coupler_type_initialized(fluxes%tr_fluxes)) & + ! call MOM_error(WARNING, "Homogenization of tracer BC fluxes not yet implemented.") + +end subroutine homogenize_forcing + +subroutine homogenize_field_t(var, G, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: var !< The variable to homogenize [A ~> a] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the + !! return value [a A-1 ~> 1] + + real :: avg ! Global average of var, in the same units as var [A ~> a] + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + avg = global_area_mean(var, G, tmp_scale=tmp_scale) + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) > 0.0) var(i,j) = avg + enddo ; enddo + +end subroutine homogenize_field_t + +subroutine homogenize_field_v(var, G, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: var !< The variable to homogenize [A ~> a] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the + !! return value [a A-1 ~> 1] + + real :: avg ! Global average of var, in the same units as var [A ~> a] + integer :: i, j, is, ie, jsB, jeB + is = G%isc ; ie = G%iec ; jsB = G%jscB ; jeB = G%jecB + + 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.0) var(i,J) = avg + enddo ; enddo + +end subroutine homogenize_field_v + +subroutine homogenize_field_u(var, G, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: var !< The variable to homogenize [A ~> a] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the + !! return value [a A-1 ~> 1] + + real :: avg ! Global average of var, in the same units as var [A ~> a] + integer :: i, j, isB, ieB, js, je + isB = G%iscB ; ieB = G%iecB ; js = G%jsc ; je = G%jec + + 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.0) var(I,j) = avg + enddo ; enddo + +end subroutine homogenize_field_u + +!> \namespace mom_forcing_type +!! +!! \section section_fluxes Boundary fluxes +!! +!! The ocean is a forced-dissipative system. Forcing occurs at the +!! boundaries, and this module mediates the various forcing terms +!! from momentum, heat, salt, and mass. Boundary fluxes from other +!! tracers are treated by coupling to biogeochemical models. We +!! here present elements of how MOM6 assumes boundary fluxes are +!! passed into the ocean. +!! +!! Note that all fluxes are positive into the ocean. For surface +!! boundary fluxes, that means fluxes are positive downward. +!! For example, a positive shortwave flux warms the ocean. +!! +!! \subsection subsection_momentum_fluxes Surface boundary momentum fluxes +!! +!! The ocean surface exchanges momentum with the overlying atmosphere, +!! sea ice, and land ice. The momentum is exchanged as a horizontal +!! stress (Newtons per squared meter: N/m2) imposed on the upper ocean +!! grid cell. +!! +!! \subsection subsection_mass_fluxes Surface boundary mass fluxes +!! +!! The ocean gains or loses mass through evaporation, precipitation, +!! sea ice melt/form, and river runoff. Positive mass fluxes +!! add mass to the liquid ocean. The boundary mass flux units are +!! (kilogram per square meter per sec: kg/(m2/sec)). +!! +!! * Evaporation field can in fact represent a +!! mass loss (evaporation) or mass gain (condensation in foggy areas). +!! * sea ice formation leads to mass moving from the liquid ocean to the +!! ice model, and melt adds liquid to the ocean. +!! * Precipitation can be liquid or frozen (snow). Furthermore, in +!! some versions of the GFDL coupler, precipitation can be negative. +!! The reason is that the ice model combines precipitation with +!! ice melt and ice formation. This limitation of the ice model +!! diagnostics should be overcome future versions. +!! * River runoff can be liquid or frozen. Frozen runoff is often +!! associated with calving land-ice and/or ice bergs. +!! +!! \subsection subsection_salt_fluxes Surface boundary salt fluxes +!! +!! Over most of the ocean, there is no exchange of salt with the +!! atmosphere. However, the liquid ocean exchanges salt with sea ice. +!! When ice forms, it extracts salt from ice pockets and discharges the +!! salt into the liquid ocean. The salt concentration of sea ice +!! is therefore much lower (around 5ppt) than liquid seawater +!! (around 30-35ppt in high latitudes). +!! +!! For ocean-ice models run with a prescribed atmosphere, such as +!! in the CORE/OMMIP simulations, it is necessary to employ a surface +!! restoring term to the k=1 salinity equation, thus imposing a salt +!! flux onto the ocean even outside of sea ice regimes. This salt +!! flux is non-physical, and represents a limitation of the ocean-ice +!! models run without an interactive atmosphere. Sometimes this salt +!! flux is converted to an implied fresh water flux. However, doing +!! so generally leads to changes in the sea level, unless a global +!! normalization is provided to zero-out the net water flux. +!! As a complement, for models with a restoring salt flux, one may +!! choose to zero-out the net salt entering the ocean. There are +!! pros/cons of each approach. +!! +!! +!! \subsection subsection_heat_fluxes Surface boundary heat fluxes +!! +!! There are many terms that contribute to boundary-related heating +!! of the k=1 surface model grid cell. We here outline details of +!! this heat, with each term having units W/m2. +!! +!! The net flux of heat crossing ocean surface is stored in the diagnostic +!! array "hfds". This array is computed as +!! \f[ +!! \mbox{hfds = shortwave + longwave + latent + sensible + mass transfer + frazil + restore + flux adjustments} +!! \f] +!! +!! * shortwave (SW) = shortwave radiation (always warms ocean) +!! * longwave (LW) = longwave radiation (generally cools ocean) +!! * latent (LAT) = turbulent latent heat loss due to evaporation +!! (liquid to vapor) or melt (snow to liquid); generally +!! cools the ocean +!! * sensible (SENS) = turbulent heat transfer due to differences in +!! air-sea or ice-sea temperature +!! * mass transfer (MASS) = heat transfer due to heat content of mass (e.g., E-P+R) +!! transferred across ocean surface; computed relative +!! to 0 Celsius +!! * frazil (FRAZ) = heat transferred to form frazil sea ice +!! (positive heating of liquid ocean) +!! * restore (RES) = heat from surface damping sometimes imposed +!! in non-coupled model simulations . +!! * restore (flux adjustments) = heat from surface flux adjustment. +!! +!! \subsubsection subsubsection_SW Treatment of shortwave +!! +!! The shortwave field itself is split into two pieces: +!! +!! * shortwave = penetrative SW + non-penetrative SW +!! * non-penetrative = non-downwelling shortwave; portion of SW +!! totally absorbed in the k=1 cell. +!! The non-penetrative SW is combined with +!! LW+LAT+SENS+seaice_melt_heat in net_heat inside routine +!! extractFluxes1d. Notably, for many cases, +!! non-penetrative SW = 0. +!! * penetrative = that portion of shortwave penetrating below +!! a tiny surface layer. This is the downwelling +!! shortwave. Penetrative SW participates in +!! the penetrative SW heating of k=1,nz cells, +!! with the amount of penetration dependent on +!! optical properties. +!! +!! \subsubsection subsubsection_bdy_heating Convergence of heat into the k=1 cell +!! +!! The convergence of boundary-related heat into surface grid cell is +!! given by the difference in the net heat entering the top of the k=1 +!! cell and the penetrative SW leaving the bottom of the cell. +!! \f{eqnarray*} +!! Q(k=1) &=& \mbox{hfds} - \mbox{pen}\_\mbox{SW(leaving bottom of k=1)} +!! \\ &=& \mbox{nonpen}\_\mbox{SW} + (\mbox{pen}\_\mbox{SW(enter k=1)}-\mbox{pen}\_\mbox{SW(leave k=1)}) +!! + \mbox{LW+LAT+SENS+MASS+FRAZ+RES} +!! \\ &=& \mbox{nonpen}\_\mbox{SW}+ \mbox{LW+LAT+SENS+MASS+FRAZ+RES} +!! + [\mbox{pen}\_\mbox{SW(enter k=1)} - \mbox{pen}\_\mbox{SW(leave k=1)}] +!! \f} +!! The convergence of the penetrative shortwave flux is given by +!! \f$ \mbox{pen}\_\mbox{SW (enter k)}-\mbox{pen}\_\mbox{SW (leave k)}\f$. This term +!! appears for all cells k=1,nz. It is diagnosed as "rsdoabsorb" inside module +!! MOM6/src/parameterizations/vertical/MOM_diabatic_aux.F90 +!! + +end module MOM_forcing_type diff --git a/core/MOM_grid.F90 b/core/MOM_grid.F90 new file mode 100644 index 0000000000..52e37f1a9b --- /dev/null +++ b/core/MOM_grid.F90 @@ -0,0 +1,671 @@ +!> Provides the ocean grid type +module MOM_grid + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_hor_index, only : hor_index_type, hor_index_init +use MOM_domains, only : MOM_domain_type, get_domain_extent, compute_block_extent +use MOM_domains, only : get_global_shape, deallocate_MOM_domain +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +#include + +public MOM_grid_init, MOM_grid_end, set_derived_metrics, set_first_direction +public isPointInCell, hor_index_type, get_global_grid_size + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Ocean grid type. See mom_grid for details. +type, public :: ocean_grid_type + type(MOM_domain_type), pointer :: Domain => NULL() !< Ocean model domain + type(MOM_domain_type), pointer :: Domain_aux => NULL() !< A non-symmetric auxiliary domain type. + type(hor_index_type) :: HI !< Horizontal index ranges + type(hor_index_type) :: HId2 !< Horizontal index ranges for level-2-downsampling + + integer :: isc !< The start i-index of cell centers within the computational domain + integer :: iec !< The end i-index of cell centers within the computational domain + integer :: jsc !< The start j-index of cell centers within the computational domain + integer :: jec !< The end j-index of cell centers within the computational domain + + integer :: isd !< The start i-index of cell centers within the data domain + integer :: ied !< The end i-index of cell centers within the data domain + integer :: jsd !< The start j-index of cell centers within the data domain + integer :: jed !< The end j-index of cell centers within the data domain + + integer :: isg !< The start i-index of cell centers within the global domain + integer :: ieg !< The end i-index of cell centers within the global domain + integer :: jsg !< The start j-index of cell centers within the global domain + integer :: jeg !< The end j-index of cell centers within the global domain + + integer :: IscB !< The start i-index of cell vertices within the computational domain + integer :: IecB !< The end i-index of cell vertices within the computational domain + integer :: JscB !< The start j-index of cell vertices within the computational domain + integer :: JecB !< The end j-index of cell vertices within the computational domain + + integer :: IsdB !< The start i-index of cell vertices within the data domain + integer :: IedB !< The end i-index of cell vertices within the data domain + integer :: JsdB !< The start j-index of cell vertices within the data domain + integer :: JedB !< The end j-index of cell vertices within the data domain + + integer :: IsgB !< The start i-index of cell vertices within the global domain + integer :: IegB !< The end i-index of cell vertices within the global domain + integer :: JsgB !< The start j-index of cell vertices within the global domain + integer :: JegB !< The end j-index of cell vertices within the global domain + + integer :: isd_global !< The value of isd in the global index space (decomposition invariant). + integer :: jsd_global !< The value of isd in the global index space (decomposition invariant). + integer :: idg_offset !< The offset between the corresponding global and local i-indices. + integer :: jdg_offset !< The offset between the corresponding global and local j-indices. + integer :: ke !< The number of layers in the vertical. + logical :: symmetric !< True if symmetric memory is used. + logical :: nonblocking_updates !< If true, non-blocking halo updates are + !! allowed. The default is .false. (for now). + integer :: first_direction !< An integer that indicates which direction is + !! to be updated first in directionally split + !! parts of the calculation. This can be altered + !! during the course of the run via calls to + !! set_first_direction. + + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & + mask2dT, & !< 0 for land points and 1 for ocean points on the h-grid [nondim]. + geoLatT, & !< The geographic latitude at q points [degrees_N] or [km] or [m]. + geoLonT, & !< The geographic longitude at q points [degrees_E] or [km] or [m]. + dxT, & !< dxT is delta x at h points [L ~> m]. + IdxT, & !< 1/dxT [L-1 ~> m-1]. + dyT, & !< dyT is delta y at h points [L ~> m]. + IdyT, & !< IdyT is 1/dyT [L-1 ~> m-1]. + areaT, & !< The area of an h-cell [L2 ~> m2]. + IareaT, & !< 1/areaT [L-2 ~> m-2]. + sin_rot, & !< The sine of the angular rotation between the local model grid's northward + !! and the true northward directions [nondim]. + cos_rot !< The cosine of the angular rotation between the local model grid's northward + !! and the true northward directions [nondim]. + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & + mask2dCu, & !< 0 for boundary points and 1 for ocean points on the u grid [nondim]. + OBCmaskCu, & !< 0 for boundary or OBC points and 1 for ocean points on the u grid [nondim]. + geoLatCu, & !< The geographic latitude at u points [degrees_N] or [km] or [m] + geoLonCu, & !< The geographic longitude at u points [degrees_E] or [km] or [m]. + dxCu, & !< dxCu is delta x at u points [L ~> m]. + IdxCu, & !< 1/dxCu [L-1 ~> m-1]. + dyCu, & !< dyCu is delta y at u points [L ~> m]. + IdyCu, & !< 1/dyCu [L-1 ~> m-1]. + dy_Cu, & !< The unblocked lengths of the u-faces of the h-cell [L ~> m]. + IareaCu, & !< The masked inverse areas of u-grid cells [L-2 ~> m-2]. + areaCu !< The areas of the u-grid cells [L2 ~> m2]. + + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & + mask2dCv, & !< 0 for boundary points and 1 for ocean points on the v grid [nondim]. + OBCmaskCv, & !< 0 for boundary or OBC points and 1 for ocean points on the v grid [nondim]. + geoLatCv, & !< The geographic latitude at v points [degrees_N] or [km] or [m] + geoLonCv, & !< The geographic longitude at v points [degrees_E] or [km] or [m]. + dxCv, & !< dxCv is delta x at v points [L ~> m]. + IdxCv, & !< 1/dxCv [L-1 ~> m-1]. + dyCv, & !< dyCv is delta y at v points [L ~> m]. + IdyCv, & !< 1/dyCv [L-1 ~> m-1]. + dx_Cv, & !< The unblocked lengths of the v-faces of the h-cell [L ~> m]. + IareaCv, & !< The masked inverse areas of v-grid cells [L-2 ~> m-2]. + areaCv !< The areas of the v-grid cells [L2 ~> m2]. + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & + porous_DminU, & !< minimum topographic height (deepest) of U-face [Z ~> m] + porous_DmaxU, & !< maximum topographic height (shallowest) of U-face [Z ~> m] + porous_DavgU !< average topographic height of U-face [Z ~> m] + + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & + porous_DminV, & !< minimum topographic height (deepest) of V-face [Z ~> m] + porous_DmaxV, & !< maximum topographic height (shallowest) of V-face [Z ~> m] + porous_DavgV !< average topographic height of V-face [Z ~> m] + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & + mask2dBu, & !< 0 for boundary points and 1 for ocean points on the q grid [nondim]. + geoLatBu, & !< The geographic latitude at q points [degrees_N] or [km] or [m] + geoLonBu, & !< The geographic longitude at q points [degrees_E] or [km] or [m]. + dxBu, & !< dxBu is delta x at q points [L ~> m]. + IdxBu, & !< 1/dxBu [L-1 ~> m-1]. + dyBu, & !< dyBu is delta y at q points [L ~> m]. + IdyBu, & !< 1/dyBu [L-1 ~> m-1]. + areaBu, & !< areaBu is the area of a q-cell [L2 ~> m2] + IareaBu !< IareaBu = 1/areaBu [L-2 ~> m-2]. + + real, pointer, dimension(:) :: & + gridLatT => NULL(), & !< The latitude of T points for the purpose of labeling the output axes, + !! often in units of [degrees_N] or [km] or [m] or [gridpoints]. + !! On many grids this is the same as geoLatT. + gridLatB => NULL() !< The latitude of B points for the purpose of labeling the output axes, + !! often in units of [degrees_N] or [km] or [m] or [gridpoints]. + !! On many grids this is the same as geoLatBu. + real, pointer, dimension(:) :: & + gridLonT => NULL(), & !< The longitude of T points for the purpose of labeling the output axes, + !! often in units of [degrees_E] or [km] or [m] or [gridpoints]. + !! On many grids this is the same as geoLonT. + gridLonB => NULL() !< The longitude of B points for the purpose of labeling the output axes, + !! often in units of [degrees_E] or [km] or [m] or [gridpoints]. + !! On many grids this is the same as geoLonBu. + character(len=40) :: & + ! Except on a Cartesian grid, these are usually some variant of "degrees". + x_axis_units, & !< The units that are used in labeling the x coordinate axes. + y_axis_units, & !< The units that are used in labeling the y coordinate axes. + ! These are internally generated names, including "m", "km", "deg_E" and "deg_N". + x_ax_unit_short, & !< A short description of the x-axis units for documenting parameter units + y_ax_unit_short !< A short description of the y-axis units for documenting parameter units + + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & + bathyT !< Ocean bottom depth at tracer points, in depth units [Z ~> m]. + real :: Z_ref !< A reference value for all geometric height fields, such as bathyT [Z ~> m]. + + logical :: bathymetry_at_vel !< If true, there are separate values for the + !! basin depths at velocity points. Otherwise the effects of + !! of topography are entirely determined from thickness points. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & + Dblock_u, & !< Topographic depths at u-points at which the flow is blocked [Z ~> m]. + Dopen_u !< Topographic depths at u-points at which the flow is open at width dy_Cu [Z ~> m]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & + Dblock_v, & !< Topographic depths at v-points at which the flow is blocked [Z ~> m]. + Dopen_v !< Topographic depths at v-points at which the flow is open at width dx_Cv [Z ~> m]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & + CoriolisBu !< The Coriolis parameter at corner points [T-1 ~> s-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & + df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1]. + df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1]. + + ! These variables are global sums that are useful for 1-d diagnostics and should not be rescaled. + real :: areaT_global !< Global sum of h-cell area [m2] + real :: IareaT_global !< Global sum of inverse h-cell area (1/areaT_global) [m-2]. + + type(unit_scale_type), pointer :: US => NULL() !< A dimensional unit scaling type + + + ! These variables are for block structures. + integer :: nblocks !< The number of sub-PE blocks on this PE + type(hor_index_type), pointer :: Block(:) => NULL() !< Index ranges for each block + + ! These parameters are run-time parameters that are used during some + ! initialization routines (but not all) + real :: south_lat !< The latitude (or y-coordinate) of the first v-line [degrees_N] or [km] or [m] + real :: west_lon !< The longitude (or x-coordinate) of the first u-line [degrees_E] or [km] or [m] + real :: len_lat !< The latitudinal (or y-coord) extent of physical domain [degrees_N] or [km] or [m] + real :: len_lon !< The longitudinal (or x-coord) extent of physical domain [degrees_E] or [km] or [m] + real :: Rad_Earth !< The radius of the planet [m] + real :: Rad_Earth_L !< The radius of the planet in rescaled units [L ~> m] + real :: max_depth !< The maximum depth of the ocean in depth units [Z ~> m] +end type ocean_grid_type + +contains + +!> MOM_grid_init initializes the ocean grid array sizes and grid memory. +subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_vel) + type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type + type(param_file_type), intent(in) :: param_file !< Parameter file handle + type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type + type(hor_index_type), & + optional, intent(in) :: HI !< A hor_index_type for array extents + logical, optional, intent(in) :: global_indexing !< If true use global index + !! values instead of having the data domain on each + !! processor start at 1. + logical, optional, intent(in) :: bathymetry_at_vel !< If true, there are + !! separate values for the ocean bottom depths at + !! velocity points. Otherwise the effects of topography + !! are entirely determined from thickness points. + + ! Local variables + real :: mean_SeaLev_scale ! A scaling factor for the reference height variable [1] or [Z m-1 ~> 1] + integer :: isd, ied, jsd, jed + integer :: IsdB, IedB, JsdB, JedB + integer :: ied_max, jed_max + integer :: niblock, njblock, nihalo, njhalo, nblocks, n, i, j + logical :: local_indexing ! If false use global index values instead of having + ! the data domain on each processor start at 1. + ! This include declares and sets the variable "version". +# include "version_variable.h" + + integer, allocatable, dimension(:) :: ibegin, iend, jbegin, jend + character(len=40) :: mod_nm = "MOM_grid" ! This module's name. + + mean_SeaLev_scale = 1.0 ; if (associated(G%US)) mean_SeaLev_scale = G%US%m_to_Z + + ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, & + units="m", default=0.0, scale=mean_SeaLev_scale, do_not_log=.true.) + call log_version(param_file, mod_nm, version, & + "Parameters providing information about the lateral grid.", & + log_to_all=.true., layout=.true., all_default=(G%Z_ref==0.0)) + + call get_param(param_file, mod_nm, "NIBLOCK", niblock, "The number of blocks "// & + "in the x-direction on each processor (for openmp).", default=1, & + layoutParam=.true.) + call get_param(param_file, mod_nm, "NJBLOCK", njblock, "The number of blocks "// & + "in the y-direction on each processor (for openmp).", default=1, & + layoutParam=.true.) + if (present(US)) then ; if (associated(US)) G%US => US ; endif + + call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, & + "A reference value for geometric height fields, such as bathyT.", & + units="m", default=0.0, scale=mean_SeaLev_scale) + + if (present(HI)) then + G%HI = HI + + G%isc = HI%isc ; G%iec = HI%iec ; G%jsc = HI%jsc ; G%jec = HI%jec + G%isd = HI%isd ; G%ied = HI%ied ; G%jsd = HI%jsd ; G%jed = HI%jed + G%isg = HI%isg ; G%ieg = HI%ieg ; G%jsg = HI%jsg ; G%jeg = HI%jeg + + G%IscB = HI%IscB ; G%IecB = HI%IecB ; G%JscB = HI%JscB ; G%JecB = HI%JecB + G%IsdB = HI%IsdB ; G%IedB = HI%IedB ; G%JsdB = HI%JsdB ; G%JedB = HI%JedB + G%IsgB = HI%IsgB ; G%IegB = HI%IegB ; G%JsgB = HI%JsgB ; G%JegB = HI%JegB + + G%idg_offset = HI%idg_offset ; G%jdg_offset = HI%jdg_offset + G%isd_global = G%isd + HI%idg_offset ; G%jsd_global = G%jsd + HI%jdg_offset + G%symmetric = HI%symmetric + else + local_indexing = .true. + if (present(global_indexing)) local_indexing = .not.global_indexing + call hor_index_init(G%Domain, G%HI, param_file, & + local_indexing=local_indexing) + + ! get_domain_extent ensures that domains start at 1 for compatibility between + ! static and dynamically allocated arrays, unless global_indexing is true. + call get_domain_extent(G%Domain, G%isc, G%iec, G%jsc, G%jec, & + G%isd, G%ied, G%jsd, G%jed, & + G%isg, G%ieg, G%jsg, G%jeg, & + G%idg_offset, G%jdg_offset, G%symmetric, & + local_indexing=local_indexing) + G%isd_global = G%isd+G%idg_offset ; G%jsd_global = G%jsd+G%jdg_offset + endif + + G%nonblocking_updates = G%Domain%nonblocking_updates + + ! Set array sizes for fields that are discretized at tracer cell boundaries. + G%IscB = G%isc ; G%JscB = G%jsc + G%IsdB = G%isd ; G%JsdB = G%jsd + G%IsgB = G%isg ; G%JsgB = G%jsg + if (G%symmetric) then + G%IscB = G%isc-1 ; G%JscB = G%jsc-1 + G%IsdB = G%isd-1 ; G%JsdB = G%jsd-1 + G%IsgB = G%isg-1 ; G%JsgB = G%jsg-1 + endif + G%IecB = G%iec ; G%JecB = G%jec + G%IedB = G%ied ; G%JedB = G%jed + G%IegB = G%ieg ; G%JegB = G%jeg + + call MOM_mesg(" MOM_grid.F90, MOM_grid_init: allocating metrics", 5) + + call allocate_metrics(G) + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + G%bathymetry_at_vel = .false. + if (present(bathymetry_at_vel)) G%bathymetry_at_vel = bathymetry_at_vel + if (G%bathymetry_at_vel) then + ALLOC_(G%Dblock_u(IsdB:IedB, jsd:jed)) ; G%Dblock_u(:,:) = -G%Z_ref + ALLOC_(G%Dopen_u(IsdB:IedB, jsd:jed)) ; G%Dopen_u(:,:) = -G%Z_ref + ALLOC_(G%Dblock_v(isd:ied, JsdB:JedB)) ; G%Dblock_v(:,:) = -G%Z_ref + ALLOC_(G%Dopen_v(isd:ied, JsdB:JedB)) ; G%Dopen_v(:,:) = -G%Z_ref + endif + +! setup block indices. + nihalo = G%Domain%nihalo + njhalo = G%Domain%njhalo + nblocks = niblock * njblock + if (nblocks < 1) call MOM_error(FATAL, "MOM_grid_init: " // & + "nblocks(=NI_BLOCK*NJ_BLOCK) must be no less than 1") + + allocate(ibegin(niblock), iend(niblock), jbegin(njblock), jend(njblock)) + call compute_block_extent(G%HI%isc,G%HI%iec,niblock,ibegin,iend) + call compute_block_extent(G%HI%jsc,G%HI%jec,njblock,jbegin,jend) + !-- make sure the last block is the largest. + do i = 1, niblock-1 + if (iend(i)-ibegin(i) > iend(niblock)-ibegin(niblock) ) call MOM_error(FATAL, & + "MOM_grid_init: the last block size in x-direction is not the largest") + enddo + do j = 1, njblock-1 + if (jend(j)-jbegin(j) > jend(njblock)-jbegin(njblock) ) call MOM_error(FATAL, & + "MOM_grid_init: the last block size in y-direction is not the largest") + enddo + + G%nblocks = nblocks + allocate(G%Block(nblocks)) + ied_max = 1 ; jed_max = 1 + do n = 1,nblocks + ! Copy all information from the array index type describing the local grid. + G%Block(n) = G%HI + + i = mod((n-1), niblock) + 1 + j = (n-1)/niblock + 1 + !--- isd and jsd are always 1 for each block to permit array reuse. + G%Block(n)%isd = 1 ; G%Block(n)%jsd = 1 + G%Block(n)%isc = G%Block(n)%isd+nihalo + G%Block(n)%jsc = G%Block(n)%jsd+njhalo + G%Block(n)%iec = G%Block(n)%isc + iend(i) - ibegin(i) + G%Block(n)%jec = G%Block(n)%jsc + jend(j) - jbegin(j) + G%Block(n)%ied = G%Block(n)%iec + nihalo + G%Block(n)%jed = G%Block(n)%jec + njhalo + G%Block(n)%IscB = G%Block(n)%isc; G%Block(n)%IecB = G%Block(n)%iec + G%Block(n)%JscB = G%Block(n)%jsc; G%Block(n)%JecB = G%Block(n)%jec + ! For symmetric memory domains, the first block will have the extra point + ! at the lower boundary of its computational domain. + if (G%symmetric) then + if (i==1) G%Block(n)%IscB = G%Block(n)%IscB-1 + if (j==1) G%Block(n)%JscB = G%Block(n)%JscB-1 + endif + G%Block(n)%IsdB = G%Block(n)%isd; G%Block(n)%IedB = G%Block(n)%ied + G%Block(n)%JsdB = G%Block(n)%jsd; G%Block(n)%JedB = G%Block(n)%jed + !--- For symmetric memory domain, every block will have an extra point + !--- at the lower boundary of its data domain. + if (G%symmetric) then + G%Block(n)%IsdB = G%Block(n)%IsdB-1 + G%Block(n)%JsdB = G%Block(n)%JsdB-1 + endif + G%Block(n)%idg_offset = (ibegin(i) - G%Block(n)%isc) + G%HI%idg_offset + G%Block(n)%jdg_offset = (jbegin(j) - G%Block(n)%jsc) + G%HI%jdg_offset + ! Find the largest values of ied and jed so that all blocks will have the + ! same size in memory. + ied_max = max(ied_max, G%Block(n)%ied) + jed_max = max(jed_max, G%Block(n)%jed) + enddo + + ! Reset all of the data domain sizes to match the largest for array reuse, + ! recalling that all block have isd=jed=1 for array reuse. + do n = 1,nblocks + G%Block(n)%ied = ied_max ; G%Block(n)%IedB = ied_max + G%Block(n)%jed = jed_max ; G%Block(n)%JedB = jed_max + enddo + + !-- do some bounds error checking + if ( G%block(nblocks)%ied+G%block(nblocks)%idg_offset > G%HI%ied + G%HI%idg_offset ) & + call MOM_error(FATAL, "MOM_grid_init: G%ied_bk > G%ied") + if ( G%block(nblocks)%jed+G%block(nblocks)%jdg_offset > G%HI%jed + G%HI%jdg_offset ) & + call MOM_error(FATAL, "MOM_grid_init: G%jed_bk > G%jed") + + call get_domain_extent(G%Domain, G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, & + G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed, & + G%HId2%isg, G%HId2%ieg, G%HId2%jsg, G%HId2%jeg, coarsen=2) + + ! Set array sizes for fields that are discretized at tracer cell boundaries. + G%HId2%IscB = G%HId2%isc ; G%HId2%JscB = G%HId2%jsc + G%HId2%IsdB = G%HId2%isd ; G%HId2%JsdB = G%HId2%jsd + G%HId2%IsgB = G%HId2%isg ; G%HId2%JsgB = G%HId2%jsg + if (G%symmetric) then + G%HId2%IscB = G%HId2%isc-1 ; G%HId2%JscB = G%HId2%jsc-1 + G%HId2%IsdB = G%HId2%isd-1 ; G%HId2%JsdB = G%HId2%jsd-1 + G%HId2%IsgB = G%HId2%isg-1 ; G%HId2%JsgB = G%HId2%jsg-1 + endif + G%HId2%IecB = G%HId2%iec ; G%HId2%JecB = G%HId2%jec + G%HId2%IedB = G%HId2%ied ; G%HId2%JedB = G%HId2%jed + G%HId2%IegB = G%HId2%ieg ; G%HId2%JegB = G%HId2%jeg + +end subroutine MOM_grid_init + +!> set_derived_metrics calculates metric terms that are derived from other metrics. +subroutine set_derived_metrics(G, US) + type(ocean_grid_type), intent(inout) :: G !< The horizontal grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type +! Various inverse grid spacings and derived areas are calculated within this +! subroutine. + integer :: i, j, isd, ied, jsd, jed + integer :: IsdB, IedB, JsdB, JedB + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + do j=jsd,jed ; do i=isd,ied + if (G%dxT(i,j) < 0.0) G%dxT(i,j) = 0.0 + if (G%dyT(i,j) < 0.0) G%dyT(i,j) = 0.0 + G%IdxT(i,j) = Adcroft_reciprocal(G%dxT(i,j)) + G%IdyT(i,j) = Adcroft_reciprocal(G%dyT(i,j)) + G%IareaT(i,j) = Adcroft_reciprocal(G%areaT(i,j)) + enddo ; enddo + + do j=jsd,jed ; do I=IsdB,IedB + if (G%dxCu(I,j) < 0.0) G%dxCu(I,j) = 0.0 + if (G%dyCu(I,j) < 0.0) G%dyCu(I,j) = 0.0 + G%IdxCu(I,j) = Adcroft_reciprocal(G%dxCu(I,j)) + G%IdyCu(I,j) = Adcroft_reciprocal(G%dyCu(I,j)) + enddo ; enddo + + do J=JsdB,JedB ; do i=isd,ied + if (G%dxCv(i,J) < 0.0) G%dxCv(i,J) = 0.0 + if (G%dyCv(i,J) < 0.0) G%dyCv(i,J) = 0.0 + G%IdxCv(i,J) = Adcroft_reciprocal(G%dxCv(i,J)) + G%IdyCv(i,J) = Adcroft_reciprocal(G%dyCv(i,J)) + enddo ; enddo + + do J=JsdB,JedB ; do I=IsdB,IedB + if (G%dxBu(I,J) < 0.0) G%dxBu(I,J) = 0.0 + if (G%dyBu(I,J) < 0.0) G%dyBu(I,J) = 0.0 + + G%IdxBu(I,J) = Adcroft_reciprocal(G%dxBu(I,J)) + G%IdyBu(I,J) = Adcroft_reciprocal(G%dyBu(I,J)) + ! areaBu has usually been set to a positive area elsewhere. + if (G%areaBu(I,J) <= 0.0) G%areaBu(I,J) = G%dxBu(I,J) * G%dyBu(I,J) + G%IareaBu(I,J) = Adcroft_reciprocal(G%areaBu(I,J)) + enddo ; enddo +end subroutine set_derived_metrics + +!> Adcroft_reciprocal(x) = 1/x for |x|>0 or 0 for x=0. +function Adcroft_reciprocal(val) result(I_val) + real, intent(in) :: val !< The value being inverted [A]. + real :: I_val !< The Adcroft reciprocal of val [A-1]. + + I_val = 0.0 ; if (val /= 0.0) I_val = 1.0/val +end function Adcroft_reciprocal + +!> Returns true if the coordinates (x,y) are within the h-cell (i,j) +logical function isPointInCell(G, i, j, x, y) + type(ocean_grid_type), intent(in) :: G !< Grid type + integer, intent(in) :: i !< i index of cell to test + integer, intent(in) :: j !< j index of cell to test + real, intent(in) :: x !< x coordinate of point [degrees_E] + real, intent(in) :: y !< y coordinate of point [degrees_N] + ! Local variables + real :: xNE, xNW, xSE, xSW ! Longitudes of cell corners [degrees_E] + real :: yNE, yNW, ySE, ySW ! Latitudes of cell corners [degrees_N] + real :: l0, l1, l2, l3 ! Crossed products of differences in position [degrees_E degrees_N] + real :: p0, p1, p2, p3 ! Trinary unitary values reflecting the signs of the crossed products [nondim] + isPointInCell = .false. + xNE = G%geoLonBu(i ,j ) ; yNE = G%geoLatBu(i ,j ) + xNW = G%geoLonBu(i-1,j ) ; yNW = G%geoLatBu(i-1,j ) + xSE = G%geoLonBu(i ,j-1) ; ySE = G%geoLatBu(i ,j-1) + xSW = G%geoLonBu(i-1,j-1) ; ySW = G%geoLatBu(i-1,j-1) + ! This is a crude calculation that assumes a geographic coordinate system + if (xmax(xNE,xNW,xSE,xSW) .or. & + ymax(yNE,yNW,ySE,ySW) ) then + return ! Avoid the more complicated calculation + endif + l0 = (x-xSW)*(ySE-ySW) - (y-ySW)*(xSE-xSW) + l1 = (x-xSE)*(yNE-ySE) - (y-ySE)*(xNE-xSE) + l2 = (x-xNE)*(yNW-yNE) - (y-yNE)*(xNW-xNE) + l3 = (x-xNW)*(ySW-yNW) - (y-yNW)*(xSW-xNW) + + p0 = sign(1., l0) ; if (l0 == 0.) p0=0. + p1 = sign(1., l1) ; if (l1 == 0.) p1=0. + p2 = sign(1., l2) ; if (l2 == 0.) p2=0. + p3 = sign(1., l3) ; if (l3 == 0.) p3=0. + + if ( (abs(p0)+abs(p2)) + (abs(p1)+abs(p3)) == abs((p0+p2) + (p1+p3)) ) then + isPointInCell=.true. + endif +end function isPointInCell + +!> Store an integer indicating which direction to work on first. +subroutine set_first_direction(G, y_first) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + integer, intent(in) :: y_first !< The first direction to store + + G%first_direction = y_first +end subroutine set_first_direction + +!> Return global shape of horizontal grid +subroutine get_global_grid_size(G, niglobal, njglobal) + type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type + integer, intent(out) :: niglobal !< i-index global size of grid + integer, intent(out) :: njglobal !< j-index global size of grid + + call get_global_shape(G%domain, niglobal, njglobal) + +end subroutine get_global_grid_size + +!> Allocate memory used by the ocean_grid_type and related structures. +subroutine allocate_metrics(G) + type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isg, ieg, jsg, jeg + + ! This subroutine allocates the lateral elements of the ocean_grid_type that + ! are always used and zeros them out. + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + isg = G%isg ; ieg = G%ieg ; jsg = G%jsg ; jeg = G%jeg + + ALLOC_(G%dxT(isd:ied,jsd:jed)) ; G%dxT(:,:) = 0.0 + ALLOC_(G%dxCu(IsdB:IedB,jsd:jed)) ; G%dxCu(:,:) = 0.0 + ALLOC_(G%dxCv(isd:ied,JsdB:JedB)) ; G%dxCv(:,:) = 0.0 + ALLOC_(G%dxBu(IsdB:IedB,JsdB:JedB)) ; G%dxBu(:,:) = 0.0 + ALLOC_(G%IdxT(isd:ied,jsd:jed)) ; G%IdxT(:,:) = 0.0 + ALLOC_(G%IdxCu(IsdB:IedB,jsd:jed)) ; G%IdxCu(:,:) = 0.0 + ALLOC_(G%IdxCv(isd:ied,JsdB:JedB)) ; G%IdxCv(:,:) = 0.0 + ALLOC_(G%IdxBu(IsdB:IedB,JsdB:JedB)) ; G%IdxBu(:,:) = 0.0 + + ALLOC_(G%dyT(isd:ied,jsd:jed)) ; G%dyT(:,:) = 0.0 + ALLOC_(G%dyCu(IsdB:IedB,jsd:jed)) ; G%dyCu(:,:) = 0.0 + ALLOC_(G%dyCv(isd:ied,JsdB:JedB)) ; G%dyCv(:,:) = 0.0 + ALLOC_(G%dyBu(IsdB:IedB,JsdB:JedB)) ; G%dyBu(:,:) = 0.0 + ALLOC_(G%IdyT(isd:ied,jsd:jed)) ; G%IdyT(:,:) = 0.0 + ALLOC_(G%IdyCu(IsdB:IedB,jsd:jed)) ; G%IdyCu(:,:) = 0.0 + ALLOC_(G%IdyCv(isd:ied,JsdB:JedB)) ; G%IdyCv(:,:) = 0.0 + ALLOC_(G%IdyBu(IsdB:IedB,JsdB:JedB)) ; G%IdyBu(:,:) = 0.0 + + ALLOC_(G%areaT(isd:ied,jsd:jed)) ; G%areaT(:,:) = 0.0 + ALLOC_(G%IareaT(isd:ied,jsd:jed)) ; G%IareaT(:,:) = 0.0 + ALLOC_(G%areaBu(IsdB:IedB,JsdB:JedB)) ; G%areaBu(:,:) = 0.0 + ALLOC_(G%IareaBu(IsdB:IedB,JsdB:JedB)) ; G%IareaBu(:,:) = 0.0 + + ALLOC_(G%mask2dT(isd:ied,jsd:jed)) ; G%mask2dT(:,:) = 0.0 + ALLOC_(G%mask2dCu(IsdB:IedB,jsd:jed)) ; G%mask2dCu(:,:) = 0.0 + ALLOC_(G%OBCmaskCu(IsdB:IedB,jsd:jed)) ; G%OBCmaskCu(:,:) = 0.0 + ALLOC_(G%mask2dCv(isd:ied,JsdB:JedB)) ; G%mask2dCv(:,:) = 0.0 + ALLOC_(G%OBCmaskCv(isd:ied,JsdB:JedB)) ; G%OBCmaskCv(:,:) = 0.0 + ALLOC_(G%mask2dBu(IsdB:IedB,JsdB:JedB)) ; G%mask2dBu(:,:) = 0.0 + ALLOC_(G%geoLatT(isd:ied,jsd:jed)) ; G%geoLatT(:,:) = 0.0 + ALLOC_(G%geoLatCu(IsdB:IedB,jsd:jed)) ; G%geoLatCu(:,:) = 0.0 + ALLOC_(G%geoLatCv(isd:ied,JsdB:JedB)) ; G%geoLatCv(:,:) = 0.0 + ALLOC_(G%geoLatBu(IsdB:IedB,JsdB:JedB)) ; G%geoLatBu(:,:) = 0.0 + ALLOC_(G%geoLonT(isd:ied,jsd:jed)) ; G%geoLonT(:,:) = 0.0 + ALLOC_(G%geoLonCu(IsdB:IedB,jsd:jed)) ; G%geoLonCu(:,:) = 0.0 + ALLOC_(G%geoLonCv(isd:ied,JsdB:JedB)) ; G%geoLonCv(:,:) = 0.0 + ALLOC_(G%geoLonBu(IsdB:IedB,JsdB:JedB)) ; G%geoLonBu(:,:) = 0.0 + + ALLOC_(G%dx_Cv(isd:ied,JsdB:JedB)) ; G%dx_Cv(:,:) = 0.0 + ALLOC_(G%dy_Cu(IsdB:IedB,jsd:jed)) ; G%dy_Cu(:,:) = 0.0 + + ALLOC_(G%porous_DminU(IsdB:IedB,jsd:jed)); G%porous_DminU(:,:) = 0.0 + ALLOC_(G%porous_DmaxU(IsdB:IedB,jsd:jed)); G%porous_DmaxU(:,:) = 0.0 + ALLOC_(G%porous_DavgU(IsdB:IedB,jsd:jed)); G%porous_DavgU(:,:) = 0.0 + + ALLOC_(G%porous_DminV(isd:ied,JsdB:JedB)); G%porous_DminV(:,:) = 0.0 + ALLOC_(G%porous_DmaxV(isd:ied,JsdB:JedB)); G%porous_DmaxV(:,:) = 0.0 + ALLOC_(G%porous_DavgV(isd:ied,JsdB:JedB)); G%porous_DavgV(:,:) = 0.0 + + ALLOC_(G%areaCu(IsdB:IedB,jsd:jed)) ; G%areaCu(:,:) = 0.0 + ALLOC_(G%areaCv(isd:ied,JsdB:JedB)) ; G%areaCv(:,:) = 0.0 + ALLOC_(G%IareaCu(IsdB:IedB,jsd:jed)) ; G%IareaCu(:,:) = 0.0 + ALLOC_(G%IareaCv(isd:ied,JsdB:JedB)) ; G%IareaCv(:,:) = 0.0 + + ALLOC_(G%bathyT(isd:ied, jsd:jed)) ; G%bathyT(:,:) = -G%Z_ref + ALLOC_(G%CoriolisBu(IsdB:IedB, JsdB:JedB)) ; G%CoriolisBu(:,:) = 0.0 + ALLOC_(G%dF_dx(isd:ied, jsd:jed)) ; G%dF_dx(:,:) = 0.0 + ALLOC_(G%dF_dy(isd:ied, jsd:jed)) ; G%dF_dy(:,:) = 0.0 + + ALLOC_(G%sin_rot(isd:ied,jsd:jed)) ; G%sin_rot(:,:) = 0.0 + ALLOC_(G%cos_rot(isd:ied,jsd:jed)) ; G%cos_rot(:,:) = 1.0 + + allocate(G%gridLonT(isg:ieg), source=0.0) + allocate(G%gridLonB(G%IsgB:G%IegB), source=0.0) + allocate(G%gridLatT(jsg:jeg), source=0.0) + allocate(G%gridLatB(G%JsgB:G%JegB), source=0.0) + +end subroutine allocate_metrics + +!> Release memory used by the ocean_grid_type and related structures. +subroutine MOM_grid_end(G) + type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type + + deallocate(G%Block) + + if (G%bathymetry_at_vel) then + DEALLOC_(G%Dblock_u) ; DEALLOC_(G%Dopen_u) + DEALLOC_(G%Dblock_v) ; DEALLOC_(G%Dopen_v) + endif + + DEALLOC_(G%dxT) ; DEALLOC_(G%dxCu) ; DEALLOC_(G%dxCv) ; DEALLOC_(G%dxBu) + DEALLOC_(G%IdxT) ; DEALLOC_(G%IdxCu) ; DEALLOC_(G%IdxCv) ; DEALLOC_(G%IdxBu) + + DEALLOC_(G%dyT) ; DEALLOC_(G%dyCu) ; DEALLOC_(G%dyCv) ; DEALLOC_(G%dyBu) + DEALLOC_(G%IdyT) ; DEALLOC_(G%IdyCu) ; DEALLOC_(G%IdyCv) ; DEALLOC_(G%IdyBu) + + DEALLOC_(G%areaT) ; DEALLOC_(G%IareaT) + DEALLOC_(G%areaBu) ; DEALLOC_(G%IareaBu) + DEALLOC_(G%areaCu) ; DEALLOC_(G%IareaCu) + DEALLOC_(G%areaCv) ; DEALLOC_(G%IareaCv) + + DEALLOC_(G%mask2dT) ; DEALLOC_(G%mask2dCu) ; DEALLOC_(G%OBCmaskCu) + DEALLOC_(G%mask2dCv) ; DEALLOC_(G%OBCmaskCv) ; DEALLOC_(G%mask2dBu) + + DEALLOC_(G%geoLatT) ; DEALLOC_(G%geoLatCu) + DEALLOC_(G%geoLatCv) ; DEALLOC_(G%geoLatBu) + DEALLOC_(G%geoLonT) ; DEALLOC_(G%geoLonCu) + DEALLOC_(G%geoLonCv) ; DEALLOC_(G%geoLonBu) + + DEALLOC_(G%dx_Cv) ; DEALLOC_(G%dy_Cu) + + DEALLOC_(G%bathyT) ; DEALLOC_(G%CoriolisBu) + DEALLOC_(G%dF_dx) ; DEALLOC_(G%dF_dy) + DEALLOC_(G%sin_rot) ; DEALLOC_(G%cos_rot) + + DEALLOC_(G%porous_DminU) ; DEALLOC_(G%porous_DmaxU) ; DEALLOC_(G%porous_DavgU) + DEALLOC_(G%porous_DminV) ; DEALLOC_(G%porous_DmaxV) ; DEALLOC_(G%porous_DavgV) + + deallocate(G%gridLonT) ; deallocate(G%gridLatT) + deallocate(G%gridLonB) ; deallocate(G%gridLatB) + + ! The cursory flag avoids doing any deallocation of memory in the underlying + ! infrastructure to avoid problems due to shared pointers. + call deallocate_MOM_domain(G%Domain, cursory=.true.) + +end subroutine MOM_grid_end + +!> \namespace mom_grid +!! +!! Grid metrics and their inverses are labelled according to their staggered location on a Arakawa C (or B) grid. +!! - Metrics centered on h- or T-points are labelled T, e.g. dxT is the distance across the cell in the x-direction. +!! - Metrics centered on u-points are labelled Cu (C-grid u location). e.g. dyCu is the y-distance between +!! two corners of a T-cell. +!! - Metrics centered on v-points are labelled Cv (C-grid v location). e.g. dyCv is the y-distance between two -points. +!! - Metrics centered on q-points are labelled Bu (B-grid u,v location). e.g. areaBu is the area centered on a q-point. +!! +!! \image html Grid_metrics.png "The labelling of distances (grid metrics) at various staggered +!! location on an T-cell and around a q-point." +!! +!! Areas centered at T-, u-, v- and q- points are `areaT`, `areaCu`, `areaCv` and `areaBu` respectively. +!! +!! The reciprocal of metrics are pre-calculated and also stored in the ocean_grid_type with a I prepended to the name. +!! For example, `1./areaT` is called `IareaT`, and `1./dyCv` is `IdyCv`. +!! +!! Geographic latitude and longitude (or model coordinates if not on a sphere) are stored in +!! `geoLatT`, `geoLonT` for T-points. +!! u-, v- and q- point coordinates are follow same pattern of replacing T with Cu, Cv and Bu respectively. +!! +!! Each location also has a 2D mask indicating whether the entire column is land or ocean. +!! `mask2dT` is 1 if the column is wet or 0 if the T-cell is land. +!! `mask2dCu` is 1 if both neighboring columns are ocean, and 0 if either is land. +!! `OBCmasku` is 1 if both neighboring columns are ocean, and 0 if either is land of if this is OBC point. + +end module MOM_grid diff --git a/core/MOM_interface_heights.F90 b/core/MOM_interface_heights.F90 new file mode 100644 index 0000000000..6681034cb9 --- /dev/null +++ b/core/MOM_interface_heights.F90 @@ -0,0 +1,827 @@ +!> Functions for calculating interface heights, including free surface height. +module MOM_interface_heights + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_density_integrals, only : int_specific_vol_dp, avg_specific_vol +use MOM_debugging, only : hchksum +use MOM_error_handler, only : MOM_error, FATAL +use MOM_EOS, only : calculate_density, average_specific_vol, EOS_type, EOS_domain +use MOM_file_parser, only : log_version +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public find_eta, dz_to_thickness, thickness_to_dz, dz_to_thickness_simple +public calc_derived_thermo +public find_rho_bottom, find_col_avg_SpV + +!> Calculates the heights of the free surface or all interfaces from layer thicknesses. +interface find_eta + module procedure find_eta_2d, find_eta_3d +end interface find_eta + +!> Calculates layer thickness in thickness units from geometric distance between the +!! interfaces around that layer in height units. +interface dz_to_thickness + module procedure dz_to_thickness_tv, dz_to_thickness_EoS +end interface dz_to_thickness + +!> Converts layer thickness in thickness units into the vertical distance between the +!! interfaces around a layer in height units. +interface thickness_to_dz + module procedure thickness_to_dz_3d, thickness_to_dz_jslice +end interface thickness_to_dz + +contains + +!> Calculates the heights of all interfaces between layers, using the appropriate +!! form for consistency with the calculation of the pressure gradient forces. +!! Additionally, these height may be dilated for consistency with the +!! corresponding time-average quantity from the barotropic calculation. +subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: eta !< layer interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic variable + !! that gives the "correct" free surface height (Boussinesq) or total water + !! column mass per unit area (non-Boussinesq). This is used to dilate the layer + !! thicknesses when calculating interface heights [H ~> m or kg m-2]. + !! In Boussinesq mode, eta_bt and G%bathyT use the same reference height. + integer, optional, intent(in) :: halo_size !< width of halo points on + !! which to calculate eta. + real, optional, intent(in) :: dZref !< The difference in the + !! reference height between G%bathyT and eta [Z ~> m]. The default is 0. + + ! Local variables + real :: p(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] + real :: dz_geo(SZI_(G),SZJ_(G),SZK_(GV)) ! The change in geopotential height + ! across a layer [L2 T-2 ~> m2 s-2]. + real :: dilate(SZI_(G)) ! A non-dimensional dilation factor [nondim] + real :: htot(SZI_(G)) ! total thickness [H ~> m or kg m-2] + real :: I_gEarth ! The inverse of the gravitational acceleration times the + ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1] + real :: dZ_ref ! The difference in the reference height between G%bathyT and eta [Z ~> m]. + ! dZ_ref is 0 unless the optional argument dZref is present. + integer i, j, k, isv, iev, jsv, jev, nz, halo + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + + isv = G%isc-halo ; iev = G%iec+halo ; jsv = G%jsc-halo ; jev = G%jec+halo + nz = GV%ke + + if ((isvG%ied) .or. (jsvG%jed)) & + call MOM_error(FATAL,"find_eta called with an overly large halo_size.") + + I_gEarth = 1.0 / GV%g_Earth + dZ_ref = 0.0 ; if (present(dZref)) dZ_ref = dZref + + !$OMP parallel default(shared) private(dilate,htot) + !$OMP do + do j=jsv,jev ; do i=isv,iev ; eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo + + if (GV%Boussinesq) then + !$OMP do + do j=jsv,jev ; do k=nz,1,-1 ; do i=isv,iev + eta(i,j,K) = eta(i,j,K+1) + h(i,j,k)*GV%H_to_Z + enddo ; enddo ; enddo + if (present(eta_bt)) then + ! Dilate the water column to agree with the free surface height + ! that is used for the dynamics. + !$OMP do + do j=jsv,jev + do i=isv,iev + dilate(i) = (eta_bt(i,j)*GV%H_to_Z + G%bathyT(i,j)) / & + (eta(i,j,1) + (G%bathyT(i,j) + dZ_ref)) + enddo + do k=1,nz ; do i=isv,iev + eta(i,j,K) = dilate(i) * (eta(i,j,K) + (G%bathyT(i,j) + dZ_ref)) - & + (G%bathyT(i,j) + dZ_ref) + enddo ; enddo + enddo + endif + else + if (associated(tv%eqn_of_state)) then + !$OMP do + do j=jsv,jev + if (associated(tv%p_surf)) then + do i=isv,iev ; p(i,j,1) = tv%p_surf(i,j) ; enddo + else + do i=isv,iev ; p(i,j,1) = 0.0 ; enddo + endif + do k=1,nz ; do i=isv,iev + p(i,j,K+1) = p(i,j,K) + GV%g_Earth*GV%H_to_RZ*h(i,j,k) + enddo ; enddo + enddo + !$OMP do + do k=1,nz + call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,K), p(:,:,K+1), & + 0.0, G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) + enddo + !$OMP do + do j=jsv,jev + do k=nz,1,-1 ; do i=isv,iev + eta(i,j,K) = eta(i,j,K+1) + I_gEarth * dz_geo(i,j,k) + enddo ; enddo + enddo + else + !$OMP do + do j=jsv,jev ; do k=nz,1,-1 ; do i=isv,iev + eta(i,j,K) = eta(i,j,K+1) + GV%H_to_RZ*h(i,j,k) / GV%Rlay(k) + enddo ; enddo ; enddo + endif + if (present(eta_bt)) then + ! Dilate the water column to agree with the free surface height + ! from the time-averaged barotropic solution. + !$OMP do + do j=jsv,jev + do i=isv,iev ; htot(i) = GV%H_subroundoff ; enddo + do k=1,nz ; do i=isv,iev ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo + do i=isv,iev ; dilate(i) = eta_bt(i,j) / htot(i) ; enddo + do k=1,nz ; do i=isv,iev + eta(i,j,K) = dilate(i) * (eta(i,j,K) + (G%bathyT(i,j) + dZ_ref)) - & + (G%bathyT(i,j) + dZ_ref) + enddo ; enddo + enddo + endif + endif + !$OMP end parallel + +end subroutine find_eta_3d + +!> Calculates the free surface height, using the appropriate form for consistency +!! with the calculation of the pressure gradient forces. Additionally, the sea +!! surface height may be adjusted for consistency with the corresponding +!! time-average quantity from the barotropic calculation. +subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta !< free surface height relative to + !! mean sea level (z=0) often [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic + !! variable that gives the "correct" free surface height (Boussinesq) or total + !! water column mass per unit area (non-Boussinesq) [H ~> m or kg m-2]. + !! In Boussinesq mode, eta_bt and G%bathyT use the same reference height. + integer, optional, intent(in) :: halo_size !< width of halo points on + !! which to calculate eta. + real, optional, intent(in) :: dZref !< The difference in the + !! reference height between G%bathyT and eta [Z ~> m]. The default is 0. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + p ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + dz_geo ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2]. + real :: htot(SZI_(G)) ! The sum of all layers' thicknesses [H ~> m or kg m-2]. + real :: I_gEarth ! The inverse of the gravitational acceleration times the + ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1] + real :: dZ_ref ! The difference in the reference height between G%bathyT and eta [Z ~> m]. + ! dZ_ref is 0 unless the optional argument dZref is present. + integer i, j, k, is, ie, js, je, nz, halo + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + nz = GV%ke + + I_gEarth = 1.0 / GV%g_Earth + dZ_ref = 0.0 ; if (present(dZref)) dZ_ref = dZref + + !$OMP parallel default(shared) private(htot) + !$OMP do + do j=js,je ; do i=is,ie ; eta(i,j) = -(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo + + if (GV%Boussinesq) then + if (present(eta_bt)) then + !$OMP do + do j=js,je ; do i=is,ie + eta(i,j) = GV%H_to_Z*eta_bt(i,j) - dZ_ref + enddo ; enddo + else + !$OMP do + do j=js,je ; do k=1,nz ; do i=is,ie + eta(i,j) = eta(i,j) + h(i,j,k)*GV%H_to_Z + enddo ; enddo ; enddo + endif + else + if (associated(tv%eqn_of_state)) then + !$OMP do + do j=js,je + if (associated(tv%p_surf)) then + do i=is,ie ; p(i,j,1) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; p(i,j,1) = 0.0 ; enddo + endif + + do k=1,nz ; do i=is,ie + p(i,j,k+1) = p(i,j,k) + GV%g_Earth*GV%H_to_RZ*h(i,j,k) + enddo ; enddo + enddo + !$OMP do + do k = 1, nz + call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), 0.0, & + G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) + enddo + !$OMP do + do j=js,je ; do k=1,nz ; do i=is,ie + eta(i,j) = eta(i,j) + I_gEarth * dz_geo(i,j,k) + enddo ; enddo ; enddo + else + !$OMP do + do j=js,je ; do k=1,nz ; do i=is,ie + eta(i,j) = eta(i,j) + GV%H_to_RZ*h(i,j,k) / GV%Rlay(k) + enddo ; enddo ; enddo + endif + if (present(eta_bt)) then + ! Dilate the water column to agree with the time-averaged column + ! mass from the barotropic solution. + !$OMP do + do j=js,je + do i=is,ie ; htot(i) = GV%H_subroundoff ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo + do i=is,ie + eta(i,j) = (eta_bt(i,j) / htot(i)) * (eta(i,j) + (G%bathyT(i,j) + dZ_ref)) - & + (G%bathyT(i,j) + dZ_ref) + enddo + enddo + endif + endif + !$OMP end parallel + +end subroutine find_eta_2d + + +!> Calculate derived thermodynamic quantities for re-use later. +subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various + !! thermodynamic variables, some of + !! which will be set here. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + integer, optional, intent(in) :: halo !< Width of halo within which to + !! calculate thicknesses + logical, optional, intent(in) :: debug !< If present and true, write debugging checksums + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: p_t ! Hydrostatic pressure atop a layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G)) :: dp ! Pressure change across a layer [R L2 T-2 ~> Pa] + real, dimension(SZK_(GV)) :: SpV_lay ! The specific volume of each layer when no equation of + ! state is used [R-1 ~> m3 kg-1] + logical :: do_debug ! If true, write checksums for debugging. + integer :: i, j, k, is, ie, js, je, halos, nz + + do_debug = .false. ; if (present(debug)) do_debug = debug + halos = 0 ; if (present(halo)) halos = max(0,halo) + is = G%isc-halos ; ie = G%iec+halos ; js = G%jsc-halos ; je = G%jec+halos ; nz = GV%ke + + if (allocated(tv%Spv_avg) .and. associated(tv%eqn_of_state)) then + if (associated(tv%p_surf)) then + do j=js,je ; do i=is,ie ; p_t(i,j) = tv%p_surf(i,j) ; enddo ; enddo + else + do j=js,je ; do i=is,ie ; p_t(i,j) = 0.0 ; enddo ; enddo + endif + do k=1,nz + do j=js,je ; do i=is,ie + dp(i,j) = GV%g_Earth*GV%H_to_RZ*h(i,j,k) + enddo ; enddo + call avg_specific_vol(tv%T(:,:,k), tv%S(:,:,k), p_t, dp, G%HI, tv%eqn_of_state, tv%SpV_avg(:,:,k), halo) + if (k Determine the column average specific volumes. +subroutine find_col_avg_SpV(h, SpV_avg, tv, G, GV, US, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: SpV_avg !< Column average specific volume [R-1 ~> m3 kg-1] + ! SpV_avg is intent inout to retain excess halo values. + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + integer, optional, intent(in) :: halo_size !< width of halo points on which to work + + ! Local variables + real :: h_tot(SZI_(G)) ! Sum of the layer thicknesses [H ~> m or kg m-3] + real :: SpV_x_h_tot(SZI_(G)) ! Vertical sum of the layer average specific volume times + ! the layer thicknesses [H R-1 ~> m4 kg-1 or m] + real :: I_rho ! The inverse of the Boussiensq reference density [R-1 ~> m3 kg-1] + real :: SpV_lay(SZK_(GV)) ! The inverse of the layer target potential densities [R-1 ~> m3 kg-1] + character(len=128) :: mesg ! A string for error messages + integer i, j, k, is, ie, js, je, nz, halo + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + nz = GV%ke + + if (GV%Boussinesq) then + I_rho = 1.0 / GV%Rho0 + do j=js,je ; do i=is,ie + SpV_avg(i,j) = I_rho + enddo ; enddo + elseif (.not.allocated(tv%SpV_avg)) then + do k=1,nz ; Spv_lay(k) = 1.0 / GV%Rlay(k) ; enddo + do j=js,je + do i=is,ie ; SpV_x_h_tot(i) = 0.0 ; h_tot(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + h_tot(i) = h_tot(i) + max(h(i,j,k), GV%H_subroundoff) + SpV_x_h_tot(i) = SpV_x_h_tot(i) + Spv_lay(k)*max(h(i,j,k), GV%H_subroundoff) + enddo ; enddo + do i=is,ie ; SpV_avg(i,j) = SpV_x_h_tot(i) / h_tot(i) ; enddo + enddo + else + ! Check that SpV_avg has been set. + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halo)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halo + endif + call MOM_error(FATAL, "find_col_avg_SpV called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + do j=js,je + do i=is,ie ; SpV_x_h_tot(i) = 0.0 ; h_tot(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + h_tot(i) = h_tot(i) + max(h(i,j,k), GV%H_subroundoff) + SpV_x_h_tot(i) = SpV_x_h_tot(i) + tv%SpV_avg(i,j,k)*max(h(i,j,k), GV%H_subroundoff) + enddo ; enddo + do i=is,ie ; SpV_avg(i,j) = SpV_x_h_tot(i) / h_tot(i) ; enddo + enddo + endif + +end subroutine find_col_avg_SpV + + +!> Determine the in situ density averaged over a specified distance from the bottom, +!! calculating it as the inverse of the mass-weighted average specific volume. +subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dz !< Height change across layers [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(in) :: pres_int !< Pressure at each interface [R L2 T-2 ~> Pa] + real, dimension(SZI_(G)), intent(in) :: dz_avg !< The vertical distance over which to average [Z ~> m] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + integer, intent(in) :: j !< j-index of row to work on + real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + + ! Local variables + real :: hb(SZI_(G)) ! Running sum of the thickness in the bottom boundary layer [H ~> m or kg m-2] + real :: SpV_h_bot(SZI_(G)) ! Running sum of the specific volume times thickness in the bottom + ! boundary layer [R-1 H ~> m4 kg-1 or m] + real :: dz_bbl_rem(SZI_(G)) ! Vertical extent of the boundary layer that has yet to be accounted + ! for [Z ~> m] + real :: h_bbl_frac(SZI_(G)) ! Thickness of the fractional layer that makes up the top of the + ! boundary layer [H ~> m or kg m-2] + real :: T_bbl(SZI_(G)) ! Temperature of the fractional layer that makes up the top of the + ! boundary layer [C ~> degC] + real :: S_bbl(SZI_(G)) ! Salinity of the fractional layer that makes up the top of the + ! boundary layer [S ~> ppt] + real :: P_bbl(SZI_(G)) ! Pressure the top of the boundary layer [R L2 T-2 ~> Pa] + real :: dp(SZI_(G)) ! Pressure change across the fractional layer that makes up the top + ! of the boundary layer [R L2 T-2 ~> Pa] + real :: SpV_bbl(SZI_(G)) ! In situ specific volume of the fractional layer that makes up the + ! top of the boundary layer [R-1 ~> m3 kg-1] + real :: frac_in ! The fraction of a layer that is within the bottom boundary layer [nondim] + logical :: do_i(SZI_(G)), do_any + logical :: use_EOS + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, k, is, ie, nz + + is = G%isc ; ie = G%iec ; nz = GV%ke + + use_EOS = associated(tv%T) .and. associated(tv%S) .and. associated(tv%eqn_of_state) + + if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.allocated(tv%SpV_avg)) then + do i=is,ie + rho_bot(i) = GV%Rho0 + enddo + else + ! Check that SpV_avg has been set. + if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & + "find_rho_bottom called in fully non-Boussinesq mode with invalid values of SpV_avg.") + + ! Set the bottom density to the inverse of the in situ specific volume averaged over the + ! specified distance, with care taken to avoid having compressibility lead to an imprint + ! of the layer thicknesses on this density. + do i=is,ie + hb(i) = 0.0 ; SpV_h_bot(i) = 0.0 + dz_bbl_rem(i) = G%mask2dT(i,j) * max(0.0, dz_avg(i)) + do_i(i) = .true. + if (G%mask2dT(i,j) <= 0.0) then + ! Set acceptable values for calling the equation of state over land. + T_bbl(i) = 0.0 ; S_bbl(i) = 0.0 ; dp(i) = 0.0 ; P_bbl(i) = 0.0 + SpV_bbl(i) = 1.0 ! This value is arbitrary, provided it is non-zero. + h_bbl_frac(i) = 0.0 + do_i(i) = .false. + endif + enddo + + do k=nz,1,-1 + do_any = .false. + do i=is,ie ; if (do_i(i)) then + if (dz(i,k) < dz_bbl_rem(i)) then + ! This layer is fully within the averaging depth. + SpV_h_bot(i) = SpV_h_bot(i) + h(i,j,k) * tv%SpV_avg(i,j,k) + dz_bbl_rem(i) = dz_bbl_rem(i) - dz(i,k) + hb(i) = hb(i) + h(i,j,k) + do_any = .true. + else + if (dz(i,k) > 0.0) then + frac_in = dz_bbl_rem(i) / dz(i,k) + else + frac_in = 0.0 + endif + if (use_EOS) then + ! Store the properties of this layer to determine the average + ! specific volume of the portion that is within the BBL. + T_bbl(i) = tv%T(i,j,k) ; S_bbl(i) = tv%S(i,j,k) + dp(i) = frac_in * (GV%g_Earth*GV%H_to_RZ * h(i,j,k)) + P_bbl(i) = pres_int(i,K) + (1.0-frac_in) * (GV%g_Earth*GV%H_to_RZ * h(i,j,k)) + else + SpV_bbl(i) = tv%SpV_avg(i,j,k) + endif + h_bbl_frac(i) = frac_in * h(i,j,k) + dz_bbl_rem(i) = 0.0 + do_i(i) = .false. + endif + endif ; enddo + if (.not.do_any) exit + enddo + do i=is,ie ; if (do_i(i)) then + ! The nominal bottom boundary layer is thicker than the water column, but layer 1 is + ! already included in the averages. These values are set so that the call to find + ! the layer-average specific volume will behave sensibly. + if (use_EOS) then + T_bbl(i) = tv%T(i,j,1) ; S_bbl(i) = tv%S(i,j,1) + dp(i) = 0.0 + P_bbl(i) = pres_int(i,1) + else + SpV_bbl(i) = tv%SpV_avg(i,j,1) + endif + h_bbl_frac(i) = 0.0 + endif ; enddo + + if (use_EOS) then + ! Find the average specific volume of the fractional layer atop the BBL. + EOSdom(:) = EOS_domain(G%HI) + call average_specific_vol(T_bbl, S_bbl, P_bbl, dp, SpV_bbl, tv%eqn_of_state, EOSdom) + endif + + do i=is,ie + if (hb(i) + h_bbl_frac(i) < GV%H_subroundoff) h_bbl_frac(i) = GV%H_subroundoff + rho_bot(i) = G%mask2dT(i,j) * (hb(i) + h_bbl_frac(i)) / (SpV_h_bot(i) + h_bbl_frac(i)*SpV_bbl(i)) + enddo + endif + +end subroutine find_rho_bottom + + +!> Converts thickness from geometric height units to thickness units, perhaps via an +!! inversion of the integral of the density in pressure using variables stored in +!! the thermo_var_ptrs type when in non-Boussinesq mode. +subroutine dz_to_thickness_tv(dz, tv, h, G, GV, US, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Output thicknesses in thickness units [H ~> m or kg m-2]. + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + ! Local variables + integer :: i, j, k, is, ie, js, je, halo, nz + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + + if (GV%Boussinesq) then + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%Z_to_H * dz(i,j,k) + enddo ; enddo ; enddo + else + if (associated(tv%eqn_of_state)) then + if (associated(tv%p_surf)) then + call dz_to_thickness_EOS(dz, tv%T, tv%S, tv%eqn_of_state, h, G, GV, US, halo, tv%p_surf) + else + call dz_to_thickness_EOS(dz, tv%T, tv%S, tv%eqn_of_state, h, G, GV, US, halo) + endif + else + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = (GV%RZ_to_H * GV%Rlay(k)) * dz(i,j,k) + enddo ; enddo ; enddo + endif + endif + +end subroutine dz_to_thickness_tv + +!> Converts thickness from geometric height units to thickness units, working via an +!! inversion of the integral of the density in pressure when in non-Boussinesq mode. +subroutine dz_to_thickness_EOS(dz, Temp, Saln, EoS, h, G, GV, US, halo_size, p_surf) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: Temp !< Input layer temperatures [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: Saln !< Input layer salinities [S ~> ppt] + type(EOS_type), intent(in) :: EoS !< Equation of state structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Output thicknesses in thickness units [H ~> m or kg m-2]. + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: p_surf !< Surface pressures [R L2 T-2 ~> Pa] + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + p_top, p_bot ! Pressure at the interfaces above and below a layer [R L2 T-2 ~> Pa] + real :: dp(SZI_(G),SZJ_(G)) ! Pressure change across a layer [R L2 T-2 ~> Pa] + real :: dz_geo(SZI_(G),SZJ_(G)) ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2] + real :: rho(SZI_(G)) ! The in situ density [R ~> kg m-3] + real :: dp_adj ! The amount by which to change the bottom pressure in an + ! iteration [R L2 T-2 ~> Pa] + real :: I_gEarth ! Unit conversion factors divided by the gravitational + ! acceleration [H T2 R-1 L-2 ~> s2 m2 kg-1 or s2 m-1] + logical :: do_more(SZI_(G),SZJ_(G)) ! If true, additional iterations would be beneficial. + logical :: do_any ! True if there are points in this layer that need more itertions. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, halo, nz + integer :: itt, max_itt + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + max_itt = 10 + + if (GV%Boussinesq) then + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%Z_to_H * dz(i,j,k) + enddo ; enddo ; enddo + else + I_gEarth = GV%RZ_to_H / GV%g_Earth + + if (present(p_surf)) then + do j=js,je ; do i=is,ie + p_bot(i,j) = 0.0 ; p_top(i,j) = p_surf(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + p_bot(i,j) = 0.0 ; p_top(i,j) = 0.0 + enddo ; enddo + endif + EOSdom(:) = EOS_domain(G%HI) + + ! The iterative approach here is inherited from very old code that was in the + ! MOM_state_initialization module. It does converge, but it is very inefficient and + ! should be revised, although doing so would change answers in non-Boussinesq mode. + do k=1,nz + do j=js,je + do i=is,ie ; p_top(i,j) = p_bot(i,j) ; enddo + call calculate_density(Temp(:,j,k), Saln(:,j,k), p_top(:,j), rho, & + EoS, EOSdom) + ! The following two expressions are mathematically equivalent. + if (GV%semi_Boussinesq) then + do i=is,ie + p_bot(i,j) = p_top(i,j) + (GV%g_Earth*GV%H_to_Z) * ((GV%Z_to_H*dz(i,j,k)) * rho(i)) + dp(i,j) = (GV%g_Earth*GV%H_to_Z) * ((GV%Z_to_H*dz(i,j,k)) * rho(i)) + enddo + else + do i=is,ie + p_bot(i,j) = p_top(i,j) + rho(i) * (GV%g_Earth * dz(i,j,k)) + dp(i,j) = rho(i) * (GV%g_Earth * dz(i,j,k)) + enddo + endif + enddo + + do_more(:,:) = .true. + do itt=1,max_itt + do_any = .false. + call int_specific_vol_dp(Temp(:,:,k), Saln(:,:,k), p_top, p_bot, 0.0, G%HI, EoS, US, dz_geo) + if (itt < max_itt) then ; do j=js,je + call calculate_density(Temp(:,j,k), Saln(:,j,k), p_bot(:,j), rho, EoS, EOSdom) + ! Use Newton's method to correct the bottom value. + ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. + if (GV%semi_Boussinesq) then + do i=is,ie + dp_adj = rho(i) * ((GV%g_Earth*GV%H_to_Z)*(GV%Z_to_H*dz(i,j,k)) - dz_geo(i,j)) + p_bot(i,j) = p_bot(i,j) + dp_adj + dp(i,j) = dp(i,j) + dp_adj + enddo + do_any = .true. ! To avoid changing answers, always use the maximum number of itertions. + else + do i=is,ie ; if (do_more(i,j)) then + dp_adj = rho(i) * (GV%g_Earth*dz(i,j,k) - dz_geo(i,j)) + p_bot(i,j) = p_bot(i,j) + dp_adj + dp(i,j) = dp(i,j) + dp_adj + ! Check for convergence to roundoff. + do_more(i,j) = (abs(dp_adj) > 1.0e-15*dp(i,j)) + if (do_more(i,j)) do_any = .true. + endif ; enddo + endif + enddo ; endif + if (.not.do_any) exit + enddo + + if (GV%semi_Boussinesq) then + do j=js,je ; do i=is,ie + h(i,j,k) = (p_bot(i,j) - p_top(i,j)) * I_gEarth + enddo ; enddo + else + do j=js,je ; do i=is,ie + h(i,j,k) = dp(i,j) * I_gEarth + enddo ; enddo + endif + enddo + endif + +end subroutine dz_to_thickness_EOS + +!> Converts thickness from geometric height units to thickness units, perhaps using +!! a simple conversion factor that may be problematic in non-Boussinesq mode. +subroutine dz_to_thickness_simple(dz, h, G, GV, US, halo_size, layer_mode) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Output thicknesses in thickness units [H ~> m or kg m-2]. + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + logical, optional, intent(in) :: layer_mode !< If present and true, do the conversion that + !! is appropriate in pure isopycnal layer mode with + !! no state variables or equation of state. Otherwise + !! use a simple constant rescaling factor and avoid the + !! use of GV%Rlay. + ! Local variables + logical :: layered ! If true and the model is non-Boussinesq, do calculations appropriate for use + ! in pure isopycnal layered mode with no state variables or equation of state. + integer :: i, j, k, is, ie, js, je, halo, nz + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + layered = .false. ; if (present(layer_mode)) layered = layer_mode + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + + if (GV%Boussinesq) then + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%Z_to_H * dz(i,j,k) + enddo ; enddo ; enddo + elseif (layered) then + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = (GV%RZ_to_H * GV%Rlay(k)) * dz(i,j,k) + enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = (US%Z_to_m * GV%m_to_H) * dz(i,j,k) + enddo ; enddo ; enddo + endif + +end subroutine dz_to_thickness_simple + +!> Converts layer thicknesses in thickness units to the vertical distance between edges in height +!! units, perhaps by multiplication by the precomputed layer-mean specific volume stored in an +!! array in the thermo_var_ptrs type when in non-Boussinesq mode. +subroutine thickness_to_dz_3d(h, tv, dz, G, GV, US, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Input thicknesses in thickness units [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + ! Local variables + character(len=128) :: mesg ! A string for error messages + integer :: i, j, k, is, ie, js, je, halo, nz + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halo)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halo + endif + call MOM_error(FATAL, "thickness_to_dz called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + do k=1,nz ; do j=js,je ; do i=is,ie + dz(i,j,k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + dz(i,j,k) = GV%H_to_Z * h(i,j,k) + enddo ; enddo ; enddo + endif + +end subroutine thickness_to_dz_3d + + +!> Converts a vertical i- / k- slice of layer thicknesses in thickness units to the vertical +!! distance between edges in height units, perhaps by multiplication by the precomputed layer-mean +!! specific volume stored in an array in the thermo_var_ptrs type when in non-Boussinesq mode. +subroutine thickness_to_dz_jslice(h, tv, dz, j, G, GV, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Input thicknesses in thickness units [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, dimension(SZI_(G),SZK_(GV)), & + intent(inout) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, intent(in) :: j !< The second (j-) index of the input thicknesses to work with + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + ! Local variables + character(len=128) :: mesg ! A string for error messages + integer :: i, k, is, ie, halo, nz + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; nz = GV%ke + + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halo)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halo + endif + call MOM_error(FATAL, "thickness_to_dz called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + do k=1,nz ; do i=is,ie + dz(i,k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo ; enddo + else + do k=1,nz ; do i=is,ie + dz(i,k) = GV%H_to_Z * h(i,j,k) + enddo ; enddo + endif + +end subroutine thickness_to_dz_jslice + +end module MOM_interface_heights diff --git a/core/MOM_isopycnal_slopes.F90 b/core/MOM_isopycnal_slopes.F90 new file mode 100644 index 0000000000..9defa597ab --- /dev/null +++ b/core/MOM_isopycnal_slopes.F90 @@ -0,0 +1,631 @@ +!> Calculations of isoneutral slopes and stratification. +module MOM_isopycnal_slopes + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_error, FATAL +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs, calculate_density_second_derivs, EOS_domain +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S + +implicit none ; private + +#include + +public calc_isoneutral_slopes, vert_fill_TS + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> Calculate isopycnal slopes, and optionally return other stratification dependent functions such as N^2 +!! and dz*S^2*g-prime used, or calculable from factors used, during the calculation. +subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stanley, & + slope_x, slope_y, N2_u, N2_v, dzu, dzv, dzSxN, dzSyN, halo, OBC) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface heights [Z ~> m] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, intent(in) :: dt_kappa_smooth !< A smoothing vertical + !! diffusivity times a smoothing + !! timescale [H Z ~> m2 or kg m-1] + logical, intent(in) :: use_stanley !< turn on stanley param in slope + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: slope_x !< Isopycnal slope in i-dir [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: slope_y !< Isopycnal slope in j-dir [Z L-1 ~> nondim] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: N2_u !< Brunt-Vaisala frequency squared at + !! interfaces between u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & + optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at + !! interfaces between v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzu !< Z-thickness at u-points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzv !< Z-thickness at v-points [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzSxN !< Z-thickness times zonal slope contribution to + !! Eady growth rate at u-points. [Z T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzSyN !< Z-thickness times meridional slope contrib. to + !! Eady growth rate at v-points. [Z T-1 ~> m s-1] + integer, optional, intent(in) :: halo !< Halo width over which to compute + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + + ! Local variables + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & + T, & ! The temperature [C ~> degC], with the values in + ! in massless layers filled vertically by diffusion. + S ! The filled salinity [S ~> ppt], with the values in + ! in massless layers filled vertically by diffusion. + real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & + pres ! The pressure at an interface [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that is + ! set there but will be ignored, it is used simultaneously with four different + ! inconsistent units of [R S-1 C-1 ~> kg m-3 degC-1 ppt-1], [R S-2 ~> kg m-3 ppt-2], + ! [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] and [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1]. + real, dimension(SZIB_(G)) :: & + drho_dT_u, & ! The derivative of density with temperature at u points [R C-1 ~> kg m-3 degC-1]. + drho_dS_u ! The derivative of density with salinity at u points [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)) :: & + drho_dT_v, & ! The derivative of density with temperature at v points [R C-1 ~> kg m-3 degC-1]. + drho_dS_v, & ! The derivative of density with salinity at v points [R S-1 ~> kg m-3 ppt-1]. + drho_dT_dT_h, & ! The second derivative of density with temperature at h points [R C-2 ~> kg m-3 degC-2] + drho_dT_dT_hr ! The second derivative of density with temperature at h (+1) points [R C-2 ~> kg m-3 degC-2] + real, dimension(SZIB_(G)) :: & + T_u, & ! Temperature on the interface at the u-point [C ~> degC]. + S_u, & ! Salinity on the interface at the u-point [S ~> ppt]. + GxSpV_u, & ! Gravitiational acceleration times the specific volume at an interface + ! at the u-points [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + pres_u ! Pressure on the interface at the u-point [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G)) :: & + T_v, & ! Temperature on the interface at the v-point [C ~> degC]. + S_v, & ! Salinity on the interface at the v-point [S ~> ppt]. + GxSpV_v, & ! Gravitiational acceleration times the specific volume at an interface + ! at the v-points [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + pres_v ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G)) :: & + T_h, & ! Temperature on the interface at the h-point [C ~> degC]. + S_h, & ! Salinity on the interface at the h-point [S ~> ppt] + pres_h, & ! Pressure on the interface at the h-point [R L2 T-2 ~> Pa]. + T_hr, & ! Temperature on the interface at the h (+1) point [C ~> degC]. + S_hr, & ! Salinity on the interface at the h (+1) point [S ~> ppt] + pres_hr ! Pressure on the interface at the h (+1) point [R L2 T-2 ~> Pa]. + real :: drdiA, drdiB ! Along layer zonal potential density gradients in the layers above (A) + ! and below (B) the interface times the grid spacing [R ~> kg m-3]. + real :: drdjA, drdjB ! Along layer meridional potential density gradients in the layers above (A) + ! and below (B) the interface times the grid spacing [R ~> kg m-3]. + real :: drdkL, drdkR ! Vertical density differences across an interface [R ~> kg m-3]. + real :: hg2A, hg2B ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. + real :: hg2L, hg2R ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. + real :: haA, haB, haL, haR ! Arithmetic mean thicknesses [H ~> m or kg m-2]. + real :: dzaL, dzaR ! Temporary thicknesses in eta units [Z ~> m]. + real :: wtA, wtB ! Unnormalized weights of the slopes above and below [H3 ~> m3 or kg3 m-6] + real :: wtL, wtR ! Unnormalized weights of the slopes to the left and right [H3 Z ~> m4 or kg3 m-5] + real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. + real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. + real :: slope ! The slope of density surfaces, calculated in a way + ! that is always between -1 and 1. [Z L-1 ~> nondim] + real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 Z-2 ~> kg2 m-8]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4]. + real :: dz_neglect ! A change in interface heights that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + real :: G_Rho0 ! The gravitational acceleration divided by density [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + + logical :: present_N2_u, present_N2_v + logical :: local_open_u_BC, local_open_v_BC ! True if u- or v-face OBCs exist anywhere in the global domain. + integer, dimension(2) :: EOSdom_u ! The shifted I-computational domain to use for equation of + ! state calculations at u-points. + integer, dimension(2) :: EOSdom_v ! The shifted i-computational domain to use for equation of + ! state calculations at v-points. + integer, dimension(2) :: EOSdom_h1 ! The shifted i-computational domain to use for equation of + ! state calculations at h points with 1 extra halo point + integer :: is, ie, js, je, nz, IsdB + integer :: i, j, k + integer :: l_seg + + if (present(halo)) then + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + EOSdom_h1(:) = EOS_domain(G%HI, halo=halo+1) + else + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + EOSdom_h1(:) = EOS_domain(G%HI, halo=1) + endif + EOSdom_u(1) = is-1 - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) + EOSdom_v(:) = EOS_domain(G%HI, halo=halo) + + nz = GV%ke ; IsdB = G%IsdB + + + h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 + dz_neglect = GV%dZ_subroundoff + + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + + use_EOS = associated(tv%eqn_of_state) + + present_N2_u = PRESENT(N2_u) + present_N2_v = PRESENT(N2_v) + G_Rho0 = GV%g_Earth / GV%Rho0 + if (present_N2_u) then + do j=js,je ; do I=is-1,ie + N2_u(I,j,1) = 0. + N2_u(I,j,nz+1) = 0. + enddo ; enddo + endif + if (present_N2_v) then + do J=js-1,je ; do i=is,ie + N2_v(i,J,1) = 0. + N2_v(i,J,nz+1) = 0. + enddo ; enddo + endif + if (present(dzu)) then + do j=js,je ; do I=is-1,ie + dzu(I,j,1) = 0. + dzu(I,j,nz+1) = 0. + enddo ; enddo + endif + if (present(dzv)) then + do J=js-1,je ; do i=is,ie + dzv(i,J,1) = 0. + dzv(i,J,nz+1) = 0. + enddo ; enddo + endif + if (present(dzSxN)) then + do j=js,je ; do I=is-1,ie + dzSxN(I,j,1) = 0. + dzSxN(I,j,nz+1) = 0. + enddo ; enddo + endif + if (present(dzSyN)) then + do J=js-1,je ; do i=is,ie + dzSyN(i,J,1) = 0. + dzSyN(i,J,nz+1) = 0. + enddo ; enddo + endif + + if (use_EOS) then + if (present(halo)) then + call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, US, halo+1) + else + call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, US, 1) + endif + endif + + if ((use_EOS .and. allocated(tv%SpV_avg) .and. (tv%valid_SpV_halo < 1)) .and. & + (present_N2_u .or. present(dzSxN) .or. present_N2_v .or. present(dzSyN))) then + if (tv%valid_SpV_halo < 0) then + call MOM_error(FATAL, "calc_isoneutral_slopes called in fully non-Boussinesq mode "//& + "with invalid values of SpV_avg.") + else + call MOM_error(FATAL, "calc_isoneutral_slopes called in fully non-Boussinesq mode "//& + "with insufficiently large SpV_avg halos of width 0 but 1 is needed.") + endif + endif + + ! Find the maximum and minimum permitted streamfunction. + if (associated(tv%p_surf)) then + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + pres(i,j,1) = tv%p_surf(i,j) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + pres(i,j,1) = 0.0 + enddo ; enddo + endif + !$OMP parallel do default(shared) + do j=js-1,je+1 + do k=1,nz ; do i=is-1,ie+1 + pres(i,j,K+1) = pres(i,j,K) + GV%g_Earth * GV%H_to_RZ * h(i,j,k) + enddo ; enddo + enddo + + !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & + !$OMP h_neglect,dz_neglect,h_neglect2, & + !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSxN,EOSdom_u,EOSdom_h1, & + !$OMP local_open_u_BC,dzu,OBC,use_stanley) & + !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & + !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,GxSpV_u, & + !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & + !$OMP drdx,mag_grad2,slope,l_seg) + do j=js,je ; do K=nz,2,-1 + if (.not.(use_EOS)) then + drdiA = 0.0 ; drdiB = 0.0 + drdkL = GV%Rlay(k)-GV%Rlay(k-1) ; drdkR = GV%Rlay(k)-GV%Rlay(k-1) + endif + + ! Calculate the zonal isopycnal slope. + if (use_EOS) then + do I=is-1,ie + pres_u(I) = 0.5*(pres(i,j,K) + pres(i+1,j,K)) + T_u(I) = 0.25*((T(i,j,k) + T(i+1,j,k)) + (T(i,j,k-1) + T(i+1,j,k-1))) + S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) + enddo + call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & + tv%eqn_of_state, EOSdom_u) + if (present_N2_u .or. (present(dzSxN))) then + if (allocated(tv%SpV_avg)) then + do I=is-1,ie + GxSpV_u(I) = GV%g_Earth * 0.25* ((tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + & + (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i+1,j,k-1))) + enddo + else + do I=is-1,ie + GxSpV_u(I) = G_Rho0 + enddo + endif + endif + endif + + if (use_stanley) then + do i=is-1,ie+1 + pres_h(i) = pres(i,j,K) + T_h(i) = 0.5*(T(i,j,k) + T(i,j,k-1)) + S_h(i) = 0.5*(S(i,j,k) + S(i,j,k-1)) + enddo + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_h, S_h, pres_h, & + scrap, scrap, drho_dT_dT_h, scrap, scrap, & + tv%eqn_of_state, dom=EOSdom_h1) + endif + + do I=is-1,ie + if (use_EOS) then + ! Estimate the horizontal density gradients along layers. + drdiA = drho_dT_u(I) * (T(i+1,j,k-1)-T(i,j,k-1)) + & + drho_dS_u(I) * (S(i+1,j,k-1)-S(i,j,k-1)) + drdiB = drho_dT_u(I) * (T(i+1,j,k)-T(i,j,k)) + & + drho_dS_u(I) * (S(i+1,j,k)-S(i,j,k)) + + ! Estimate the vertical density gradients times the grid spacing. + drdkL = (drho_dT_u(I) * (T(i,j,k)-T(i,j,k-1)) + & + drho_dS_u(I) * (S(i,j,k)-S(i,j,k-1))) + drdkR = (drho_dT_u(I) * (T(i+1,j,k)-T(i+1,j,k-1)) + & + drho_dS_u(I) * (S(i+1,j,k)-S(i+1,j,k-1))) + endif + if (use_stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdiA = drdiA + 0.5 * ((drho_dT_dT_h(i+1) * tv%varT(i+1,j,k-1)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k-1)) ) + drdiB = drdiB + 0.5 * ((drho_dT_dT_h(i+1) * tv%varT(i+1,j,k)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k)) ) + endif + + hg2A = h(i,j,k-1)*h(i+1,j,k-1) + h_neglect2 + hg2B = h(i,j,k)*h(i+1,j,k) + h_neglect2 + hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 + hg2R = h(i+1,j,k-1)*h(i+1,j,k) + h_neglect2 + haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + h_neglect + haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect + haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect + haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect + if (GV%Boussinesq) then + dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z + else + dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect + dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect + endif + if (present(dzu)) dzu(I,j,K) = 0.5*( dzaL + dzaR ) + ! Use the harmonic mean thicknesses to weight the horizontal gradients. + ! These unnormalized weights have been rearranged to minimize divisions. + wtA = hg2A*haB ; wtB = hg2B*haA + wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) + + drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) + ! The expression for drdz above is mathematically equivalent to: + ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & + ! ((hg2L/haL) + (hg2R/haR)) + ! This is the gradient of density along geopotentials. + if (present_N2_u) then + N2_u(I,j,K) = GxSpV_u(I) * drdz * G%mask2dCu(I,j) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + endif + + if (use_EOS) then + drdx = ((wtA * drdiA + wtB * drdiB) / (wtA + wtB) - & + drdz * (e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) + + ! This estimate of slope is accurate for small slopes, but bounded + ! to be between -1 and 1. + mag_grad2 = (US%Z_to_L*drdx)**2 + drdz**2 + if (mag_grad2 > 0.0) then + slope = drdx / sqrt(mag_grad2) + else ! Just in case mag_grad2 = 0 ever. + slope = 0.0 + endif + else ! With .not.use_EOS, the layers are constant density. + slope = (e(i,j,K)-e(i+1,j,K)) * G%IdxCu(I,j) + endif + if (local_open_u_BC) then + l_seg = OBC%segnum_u(I,j) + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + slope = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then +! slope_x(I+1,j,K) = 0. +! else +! slope_x(I-1,j,K) = 0. +! endif + endif + endif + slope = slope * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) + endif + slope_x(I,j,K) = slope + if (present(dzSxN)) & + dzSxN(I,j,K) = sqrt( GxSpV_u(I) * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + * abs(slope) * G%mask2dCu(I,j) ! x-direction contribution to S^2 + + enddo ! I + enddo ; enddo ! end of j-loop + + ! Calculate the meridional isopycnal slope. + !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & + !$OMP h,h_neglect,e,dz_neglect, & + !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,dzSyN,EOSdom_v, & + !$OMP dzv,local_open_v_BC,OBC,use_stanley) & + !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & + !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,GxSpV_v, & + !$OMP drho_dT_dT_hr,pres_hr,T_hr,S_hr, & + !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & + !$OMP drdy,mag_grad2,slope,l_seg) + do j=js-1,je ; do K=nz,2,-1 + if (.not.(use_EOS)) then + drdjA = 0.0 ; drdjB = 0.0 + drdkL = GV%Rlay(k)-GV%Rlay(k-1) ; drdkR = GV%Rlay(k)-GV%Rlay(k-1) + endif + + if (use_EOS) then + do i=is,ie + pres_v(i) = 0.5*(pres(i,j,K) + pres(i,j+1,K)) + T_v(i) = 0.25*((T(i,j,k) + T(i,j+1,k)) + (T(i,j,k-1) + T(i,j+1,k-1))) + S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) + enddo + call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & + tv%eqn_of_state, EOSdom_v) + + if ((present_N2_v) .or. (present(dzSyN))) then + if (allocated(tv%SpV_avg)) then + do i=is,ie + GxSpV_v(i) = GV%g_Earth * 0.25* ((tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + & + (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j+1,k-1))) + enddo + else + do i=is,ie + GxSpV_v(i) = G_Rho0 + enddo + endif + endif + endif + + if (use_stanley) then + do i=is,ie + pres_h(i) = pres(i,j,K) + T_h(i) = 0.5*(T(i,j,k) + T(i,j,k-1)) + S_h(i) = 0.5*(S(i,j,k) + S(i,j,k-1)) + + pres_hr(i) = pres(i,j+1,K) + T_hr(i) = 0.5*(T(i,j+1,k) + T(i,j+1,k-1)) + S_hr(i) = 0.5*(S(i,j+1,k) + S(i,j+1,k-1)) + enddo + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_h, S_h, pres_h, & + scrap, scrap, drho_dT_dT_h, scrap, scrap, & + tv%eqn_of_state, dom=EOSdom_v) + call calculate_density_second_derivs(T_hr, S_hr, pres_hr, & + scrap, scrap, drho_dT_dT_hr, scrap, scrap, & + tv%eqn_of_state, dom=EOSdom_v) + endif + do i=is,ie + if (use_EOS) then + ! Estimate the horizontal density gradients along layers. + drdjA = drho_dT_v(i) * (T(i,j+1,k-1)-T(i,j,k-1)) + & + drho_dS_v(i) * (S(i,j+1,k-1)-S(i,j,k-1)) + drdjB = drho_dT_v(i) * (T(i,j+1,k)-T(i,j,k)) + & + drho_dS_v(i) * (S(i,j+1,k)-S(i,j,k)) + + ! Estimate the vertical density gradients times the grid spacing. + drdkL = (drho_dT_v(i) * (T(i,j,k)-T(i,j,k-1)) + & + drho_dS_v(i) * (S(i,j,k)-S(i,j,k-1))) + drdkR = (drho_dT_v(i) * (T(i,j+1,k)-T(i,j+1,k-1)) + & + drho_dS_v(i) * (S(i,j+1,k)-S(i,j+1,k-1))) + endif + if (use_stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdjA = drdjA + 0.5 * ((drho_dT_dT_hr(i) * tv%varT(i,j+1,k-1)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k-1)) ) + drdjB = drdjB + 0.5 * ((drho_dT_dT_hr(i) * tv%varT(i,j+1,k)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k)) ) + endif + + hg2A = h(i,j,k-1)*h(i,j+1,k-1) + h_neglect2 + hg2B = h(i,j,k)*h(i,j+1,k) + h_neglect2 + hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 + hg2R = h(i,j+1,k-1)*h(i,j+1,k) + h_neglect2 + haA = 0.5*(h(i,j,k-1) + h(i,j+1,k-1)) + h_neglect + haB = 0.5*(h(i,j,k) + h(i,j+1,k)) + h_neglect + haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect + haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect + if (GV%Boussinesq) then + dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z + else + dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect + dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect + endif + if (present(dzv)) dzv(i,J,K) = 0.5*( dzaL + dzaR ) + ! Use the harmonic mean thicknesses to weight the horizontal gradients. + ! These unnormalized weights have been rearranged to minimize divisions. + wtA = hg2A*haB ; wtB = hg2B*haA + wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) + + drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) + ! The expression for drdz above is mathematically equivalent to: + ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & + ! ((hg2L/haL) + (hg2R/haR)) + ! This is the gradient of density along geopotentials. + if (present_N2_v) N2_v(i,J,K) = GxSpV_v(i) * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + + if (use_EOS) then + drdy = ((wtA * drdjA + wtB * drdjB) / (wtA + wtB) - & + drdz * (e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) + + ! This estimate of slope is accurate for small slopes, but bounded + ! to be between -1 and 1. + mag_grad2 = (US%Z_to_L*drdy)**2 + drdz**2 + if (mag_grad2 > 0.0) then + slope = drdy / sqrt(mag_grad2) + else ! Just in case mag_grad2 = 0 ever. + slope = 0.0 + endif + + + else ! With .not.use_EOS, the layers are constant density. + slope = (e(i,j,K)-e(i,j+1,K)) * G%IdyCv(i,J) + endif + if (local_open_v_BC) then + l_seg = OBC%segnum_v(i,J) + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + slope = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then +! slope_y(i,J+1,K) = 0. +! else +! slope_y(i,J-1,K) = 0. +! endif + endif + endif + slope = slope * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) + endif + slope_y(i,J,K) = slope + if (present(dzSyN)) & + dzSyN(i,J,K) = sqrt( GxSpV_v(i) * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + * abs(slope) * G%mask2dCv(i,J) ! x-direction contribution to S^2 + + enddo ! i + enddo ; enddo ! end of j-loop + +end subroutine calc_isoneutral_slopes + +!> Returns tracer arrays (nominally T and S) with massless layers filled with +!! sensible values, by diffusing vertically with a small but constant diffusivity. +subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, US, halo_here, larger_h_denom) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T_in !< Input temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S_in !< Input salinity [S ~> ppt] + real, intent(in) :: kappa_dt !< A vertical diffusivity to use for smoothing + !! times a smoothing timescale [H Z ~> m2 or kg m-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T_f !< Filled temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S_f !< Filled salinity [S ~> ppt] + integer, optional, intent(in) :: halo_here !< Number of halo points to work on, + !! 0 by default + logical, optional, intent(in) :: larger_h_denom !< Present and true, add a large + !! enough minimal thickness in the denominator of + !! the flux calculations so that the fluxes are + !! never so large as eliminate the transmission + !! of information across groups of massless layers. + ! Local variables + real :: ent(SZI_(G),SZK_(GV)+1) ! The diffusive entrainment (kappa*dt)/dz + ! between layers in a timestep [H ~> m or kg m-2]. + real :: b1(SZI_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1] + real :: d1(SZI_(G)) ! A variable used by the tridiagonal solver [nondim], d1 = 1 - c1. + real :: c1(SZI_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. + real :: kap_dt_x2 ! The 2*kappa_dt converted to H units [H2 ~> m2 or kg2 m-4]. + real :: h_neglect ! A negligible thickness [H ~> m or kg m-2], to allow for zero thicknesses. + real :: h0 ! A negligible thickness to allow for zero thickness layers without + ! completely decoupling groups of layers [H ~> m or kg m-2]. + ! Often 0 < h_neglect << h0. + real :: h_tr ! h_tr is h at tracer points with a tiny thickness + ! added to ensure positive definiteness [H ~> m or kg m-2]. + integer :: i, j, k, is, ie, js, je, nz, halo + + halo=0 ; if (present(halo_here)) halo = max(halo_here,0) + + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + + h_neglect = GV%H_subroundoff + ! The use of the fixed rescaling factor in the next line avoids an extra call to thickness_to_dz() + ! and the use of an extra 3-d array of vertical distnaces across layers (dz). This would be more + ! physically consistent, but it would also be more expensive, and given that this routine applies + ! a small (but arbitrary) amount of mixing to clean up the properties of nearly massless layers, + ! the added expense is hard to justify. + kap_dt_x2 = (2.0*kappa_dt) * (US%Z_to_m*GV%m_to_H) ! Usually the latter term is GV%Z_to_H. + h0 = h_neglect + if (present(larger_h_denom)) then + if (larger_h_denom) h0 = 1.0e-16*sqrt(0.5*kap_dt_x2) + endif + + if (kap_dt_x2 <= 0.0) then + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do i=is,ie + T_f(i,j,k) = T_in(i,j,k) ; S_f(i,j,k) = S_in(i,j,k) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) private(ent,b1,d1,c1,h_tr) + do j=js,je + do i=is,ie + ent(i,2) = kap_dt_x2 / ((h(i,j,1)+h(i,j,2)) + h0) + h_tr = h(i,j,1) + h_neglect + b1(i) = 1.0 / (h_tr + ent(i,2)) + d1(i) = b1(i) * h_tr + T_f(i,j,1) = (b1(i)*h_tr)*T_in(i,j,1) + S_f(i,j,1) = (b1(i)*h_tr)*S_in(i,j,1) + enddo + do k=2,nz-1 ; do i=is,ie + ent(i,K+1) = kap_dt_x2 / ((h(i,j,k)+h(i,j,k+1)) + h0) + h_tr = h(i,j,k) + h_neglect + c1(i,k) = ent(i,K) * b1(i) + b1(i) = 1.0 / ((h_tr + d1(i)*ent(i,K)) + ent(i,K+1)) + d1(i) = b1(i) * (h_tr + d1(i)*ent(i,K)) + T_f(i,j,k) = b1(i) * (h_tr*T_in(i,j,k) + ent(i,K)*T_f(i,j,k-1)) + S_f(i,j,k) = b1(i) * (h_tr*S_in(i,j,k) + ent(i,K)*S_f(i,j,k-1)) + enddo ; enddo + do i=is,ie + c1(i,nz) = ent(i,nz) * b1(i) + h_tr = h(i,j,nz) + h_neglect + b1(i) = 1.0 / (h_tr + d1(i)*ent(i,nz)) + T_f(i,j,nz) = b1(i) * (h_tr*T_in(i,j,nz) + ent(i,nz)*T_f(i,j,nz-1)) + S_f(i,j,nz) = b1(i) * (h_tr*S_in(i,j,nz) + ent(i,nz)*S_f(i,j,nz-1)) + enddo + do k=nz-1,1,-1 ; do i=is,ie + T_f(i,j,k) = T_f(i,j,k) + c1(i,k+1)*T_f(i,j,k+1) + S_f(i,j,k) = S_f(i,j,k) + c1(i,k+1)*S_f(i,j,k+1) + enddo ; enddo + enddo + endif + +end subroutine vert_fill_TS + +end module MOM_isopycnal_slopes diff --git a/core/MOM_open_boundary.F90 b/core/MOM_open_boundary.F90 new file mode 100644 index 0000000000..94320a30c7 --- /dev/null +++ b/core/MOM_open_boundary.F90 @@ -0,0 +1,6113 @@ +!> Controls where open boundary conditions are applied +module MOM_open_boundary + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_array_transform, only : rotate_array, rotate_array_pair +use MOM_array_transform, only : allocate_rotated_array +use MOM_coms, only : sum_across_PEs, Set_PElist, Get_PElist, PE_here, num_PEs +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_debugging, only : hchksum, uvchksum +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_domains, only : pass_var, pass_vector +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : To_All, EAST_FACE, NORTH_FACE, SCALAR_PAIR, CGRID_NE, CORNER +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, NOTE, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type, log_param +use MOM_grid, only : ocean_grid_type, hor_index_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init +use MOM_interpolate, only : external_field +use MOM_io, only : slasher, field_size, SINGLE_FILE +use MOM_io, only : vardesc, query_vardesc, var_desc +use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char +use MOM_regridding, only : regridding_CS +use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme, remapping_CS +use MOM_remapping, only : initialize_remapping, remapping_core_h, end_remapping +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_string_functions, only : extract_word, remove_spaces, uppercase, lowercase +use MOM_tidal_forcing, only : astro_longitudes, astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency +use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) +use MOM_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public open_boundary_apply_normal_flow +public open_boundary_config +public open_boundary_init +public open_boundary_query +public open_boundary_end +public open_boundary_impose_normal_slope +public open_boundary_impose_land_mask +public radiation_open_bdry_conds +public set_tracer_data +public update_OBC_segment_data +public open_boundary_test_extern_uv +public open_boundary_test_extern_h +public open_boundary_zero_normal_flow +public parse_segment_str +public parse_segment_manifest_str +public parse_segment_data_str +public register_OBC, OBC_registry_init +public register_file_OBC, file_OBC_end +public segment_tracer_registry_init +public segment_tracer_registry_end +public register_segment_tracer +public register_temp_salt_segments +public register_obgc_segments +public fill_temp_salt_segments +public fill_obgc_segments +public set_obgc_segments_props +public setup_OBC_tracer_reservoirs +public open_boundary_register_restarts +public update_segment_tracer_reservoirs +public update_OBC_ramp +public remap_OBC_fields +public rotate_OBC_config +public rotate_OBC_init +public initialize_segment_data +public flood_fill +public flood_fill2 + +integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary +integer, parameter, public :: OBC_DIRECTION_N = 100 !< Indicates the boundary is an effective northern boundary +integer, parameter, public :: OBC_DIRECTION_S = 200 !< Indicates the boundary is an effective southern boundary +integer, parameter, public :: OBC_DIRECTION_E = 300 !< Indicates the boundary is an effective eastern boundary +integer, parameter, public :: OBC_DIRECTION_W = 400 !< Indicates the boundary is an effective western boundary +integer, parameter :: MAX_OBC_FIELDS = 100 !< Maximum number of data fields needed for OBC segments + +!> Open boundary segment data from files (mostly). +type, public :: OBC_segment_data_type + type(external_field) :: handle !< handle from FMS associated with segment data on disk + type(external_field) :: dz_handle !< handle from FMS associated with segment thicknesses on disk + logical :: use_IO = .false. !< True if segment data is based on file input + character(len=32) :: name !< a name identifier for the segment data + character(len=8) :: genre !< an identifier for the segment data + real :: scale !< A scaling factor for converting input data to + !! the internal units of this field. For salinity this would + !! be in units of [S ppt-1 ~> 1] + real, allocatable :: buffer_src(:,:,:) !< buffer for segment data located at cell faces and on + !! the original vertical grid in the internally scaled + !! units for the field in question, such as [L T-1 ~> m s-1] + !! for a velocity or [S ~> ppt] for salinity. + integer :: nk_src !< Number of vertical levels in the source data + real, allocatable :: dz_src(:,:,:) !< vertical grid cell spacing of the incoming segment + !! data in [Z ~> m]. + real, allocatable :: buffer_dst(:,:,:) !< buffer src data remapped to the target vertical grid + !! in the internally scaled units for the field in + !! question, such as [L T-1 ~> m s-1] for a velocity or + !! [S ~> ppt] for salinity. + real :: value !< A constant value for the inflow concentration if not read + !! from file, in the internal units of a field, such as [S ~> ppt] + !! for salinity. + real :: resrv_lfac_in = 1. !< The reservoir inverse length scale factor for the inward + !! direction per field [nondim]. The general 1/Lscale_in is + !! multiplied by this factor for a specific tracer. + real :: resrv_lfac_out= 1. !< The reservoir inverse length scale factor for the outward + !! direction per field [nondim]. The general 1/Lscale_out is + !! multiplied by this factor for a specific tracer. +end type OBC_segment_data_type + +!> Tracer on OBC segment data structure, for putting into a segment tracer registry. +type, public :: OBC_segment_tracer_type + real, allocatable :: t(:,:,:) !< tracer concentration array in rescaled units, + !! like [S ~> ppt] for salinity. + real :: OBC_inflow_conc = 0.0 !< tracer concentration for generic inflows in rescaled units, + !! like [S ~> ppt] for salinity. + character(len=32) :: name !< tracer name used for error messages + type(tracer_type), pointer :: Tr => NULL() !< metadata describing the tracer + real, allocatable :: tres(:,:,:) !< tracer reservoir array in rescaled units, + !! like [S ~> ppt] for salinity. + real :: scale !< A scaling factor for converting the units of input + !! data, like [S ppt-1 ~> 1] for salinity. + logical :: is_initialized !< reservoir values have been set when True + integer :: ntr_index = -1 !< index of segment tracer in the global tracer registry + integer :: fd_index = -1 !< index of segment tracer in the input fields +end type OBC_segment_tracer_type + +!> Registry type for tracers on segments +type, public :: segment_tracer_registry_type + integer :: ntseg = 0 !< number of registered tracer segments + type(OBC_segment_tracer_type) :: Tr(MAX_FIELDS_) !< array of registered tracers + logical :: locked = .false. !< New tracers may be registered if locked=.false. + !! When locked=.true.,no more tracers can be registered. + !! Not sure who should lock it or when... +end type segment_tracer_registry_type + +!> Open boundary segment data structure. Unless otherwise noted, 2-d and 3-d arrays are discretized +!! at the same position as normal velocity points in the middle of the OBC segments. +type, public :: OBC_segment_type + logical :: Flather !< If true, applies Flather + Chapman radiation of barotropic gravity waves. + logical :: radiation !< If true, 1D Orlanksi radiation boundary conditions are applied. + !! If False, a gradient condition is applied. + logical :: radiation_tan !< If true, 1D Orlanksi radiation boundary conditions are applied to + !! tangential flows. + logical :: radiation_grad !< If true, 1D Orlanksi radiation boundary conditions are applied to + !! dudv and dvdx. + logical :: oblique !< Oblique waves supported at radiation boundary. + logical :: oblique_tan !< If true, 2D radiation boundary conditions are applied to + !! tangential flows. + logical :: oblique_grad !< If true, 2D radiation boundary conditions are applied to + !! dudv and dvdx. + logical :: nudged !< Optional supplement to radiation boundary. + logical :: nudged_tan !< Optional supplement to nudge tangential velocity. + logical :: nudged_grad !< Optional supplement to nudge normal gradient of tangential velocity. + logical :: specified !< Boundary normal velocity fixed to external value. + logical :: specified_tan !< Boundary tangential velocity fixed to external value. + logical :: specified_grad !< Boundary gradient of tangential velocity fixed to external value. + logical :: open !< Boundary is open for continuity solver, and there are no other + !! parameterized mass fluxes at the open boundary. + logical :: gradient !< Zero gradient at boundary. + logical :: values_needed !< Whether or not any external OBC fields are needed. + logical :: u_values_needed !< Whether or not external u OBC fields are needed. + logical :: uamp_values_needed !< Whether or not external u amplitude OBC fields are needed. + logical :: uphase_values_needed !< Whether or not external u phase OBC fields are needed. + logical :: v_values_needed !< Whether or not external v OBC fields are needed. + logical :: vamp_values_needed !< Whether or not external v amplitude OBC fields are needed. + logical :: vphase_values_needed !< Whether or not external v phase OBC fields are needed. + logical :: t_values_needed!< Whether or not external T OBC fields are needed. + logical :: s_values_needed!< Whether or not external S OBC fields are needed. + logical :: z_values_needed!< Whether or not external zeta OBC fields are needed. + logical :: zamp_values_needed !< Whether or not external zeta amplitude OBC fields are needed. + logical :: zphase_values_needed !< Whether or not external zeta phase OBC fields are needed. + logical :: g_values_needed!< Whether or not external gradient OBC fields are needed. + integer :: direction !< Boundary faces one of the four directions. + logical :: is_N_or_S !< True if the OB is facing North or South and exists on this PE. + logical :: is_E_or_W !< True if the OB is facing East or West and exists on this PE. + logical :: is_E_or_W_2 !< True if the OB is facing East or West anywhere. + type(OBC_segment_data_type), pointer :: field(:) => NULL() !< OBC data + integer :: num_fields !< number of OBC data fields (e.g. u_normal,u_parallel and eta for Flather) + integer :: Is_obc !< i-indices of boundary segment. + integer :: Ie_obc !< i-indices of boundary segment. + integer :: Js_obc !< j-indices of boundary segment. + integer :: Je_obc !< j-indices of boundary segment. + integer :: uamp_index !< Save where uamp is in segment%field. + integer :: uphase_index !< Save where uphase is in segment%field. + integer :: vamp_index !< Save where vamp is in segment%field. + integer :: vphase_index !< Save where vphase is in segment%field. + integer :: zamp_index !< Save where zamp is in segment%field. + integer :: zphase_index !< Save where zphase is in segment%field. + real :: Velocity_nudging_timescale_in !< Nudging timescale on inflow [T ~> s]. + real :: Velocity_nudging_timescale_out !< Nudging timescale on outflow [T ~> s]. + logical :: on_pe !< true if any portion of the segment is located in this PE's data domain + logical :: temp_segment_data_exists !< true if temperature data arrays are present + logical :: salt_segment_data_exists !< true if salinity data arrays are present + real, allocatable :: Cg(:,:) !< The external gravity wave speed [L T-1 ~> m s-1] + !! at OBC-points. + real, allocatable :: Htot(:,:) !< The total column thickness [H ~> m or kg m-2] at OBC-points. + real, allocatable :: dZtot(:,:) !< The total column vertical extent [Z ~> m] at OBC-points. + real, allocatable :: h(:,:,:) !< The cell thickness [H ~> m or kg m-2] at OBC-points. + real, allocatable :: normal_vel(:,:,:) !< The layer velocity normal to the OB + !! segment [L T-1 ~> m s-1]. + real, allocatable :: tangential_vel(:,:,:) !< The layer velocity tangential to the OB segment + !! [L T-1 ~> m s-1], discretized at the corner points. + real, allocatable :: tangential_grad(:,:,:) !< The gradient of the velocity tangential to the OB + !! segment [T-1 ~> s-1], discretized at the corner points. + real, allocatable :: normal_trans(:,:,:) !< The layer transport normal to the OB + !! segment [H L2 T-1 ~> m3 s-1]. + real, allocatable :: normal_vel_bt(:,:) !< The barotropic velocity normal to + !! the OB segment [L T-1 ~> m s-1]. + real, allocatable :: SSH(:,:) !< The sea-surface elevation along the + !! segment [Z ~> m]. + real, allocatable :: grad_normal(:,:,:) !< The gradient of the normal flow along the + !! segment times the grid spacing [L T-1 ~> m s-1], + !! with the first index being the corner-point index + !! along the segment, and the second index being 1 (for + !! values one point into the domain) or 2 (for values + !! along the OBC itself) + real, allocatable :: grad_tan(:,:,:) !< The gradient of the tangential flow along the + !! segment times the grid spacing [L T-1 ~> m s-1], with the + !! first index being the velocity/tracer point index along the + !! segment, and the second being 1 for the value 1.5 points + !! inside the domain and 2 for the value half a point + !! inside the domain. + real, allocatable :: grad_gradient(:,:,:) !< The gradient normal to the segment of the gradient + !! tangetial to the segment of tangential flow along the segment + !! times the grid spacing [T-1 ~> s-1], with the first + !! index being the velocity/tracer point index along the segment, + !! and the second being 1 for the value 2 points into the domain + !! and 2 for the value 1 point into the domain. + real, allocatable :: rx_norm_rad(:,:,:) !< The previous normal phase speed use for EW radiation + !! OBC, in grid points per timestep [nondim] + real, allocatable :: ry_norm_rad(:,:,:) !< The previous normal phase speed use for NS radiation + !! OBC, in grid points per timestep [nondim] + real, allocatable :: rx_norm_obl(:,:,:) !< The previous x-direction normalized radiation coefficient + !! for either EW or NS oblique OBCs [L2 T-2 ~> m2 s-2] + real, allocatable :: ry_norm_obl(:,:,:) !< The previous y-direction normalized radiation coefficient + !! for either EW or NS oblique OBCs [L2 T-2 ~> m2 s-2] + real, allocatable :: cff_normal(:,:,:) !< The denominator for oblique radiation of the normal + !! velocity [L2 T-2 ~> m2 s-2] + real, allocatable :: nudged_normal_vel(:,:,:) !< The layer velocity normal to the OB segment + !! that values should be nudged towards [L T-1 ~> m s-1]. + real, allocatable :: nudged_tangential_vel(:,:,:) !< The layer velocity tangential to the OB segment + !! that values should be nudged towards [L T-1 ~> m s-1], + !! discretized at the corner (PV) points. + real, allocatable :: nudged_tangential_grad(:,:,:) !< The layer dvdx or dudy towards which nudging + !! can occur [T-1 ~> s-1]. + type(segment_tracer_registry_type), pointer :: tr_Reg=> NULL()!< A pointer to the tracer registry for the segment. + type(hor_index_type) :: HI !< Horizontal index ranges + real :: Tr_InvLscale_out !< An effective inverse length scale for restoring + !! the tracer concentration in a fictitious + !! reservoir towards interior values when flow + !! is exiting the domain [L-1 ~> m-1] + real :: Tr_InvLscale_in !< An effective inverse length scale for restoring + !! the tracer concentration towards an externally + !! imposed value when flow is entering [L-1 ~> m-1] +end type OBC_segment_type + +!> Open-boundary data +type, public :: ocean_OBC_type + integer :: number_of_segments = 0 !< The number of open-boundary segments. + integer :: ke = 0 !< The number of model layers + logical :: open_u_BCs_exist_globally = .false. !< True if any zonal velocity points + !! in the global domain use open BCs. + logical :: open_v_BCs_exist_globally = .false. !< True if any meridional velocity points + !! in the global domain use open BCs. + logical :: Flather_u_BCs_exist_globally = .false. !< True if any zonal velocity points + !! in the global domain use Flather BCs. + logical :: Flather_v_BCs_exist_globally = .false. !< True if any meridional velocity points + !! in the global domain use Flather BCs. + logical :: oblique_BCs_exist_globally = .false. !< True if any velocity points + !! in the global domain use oblique BCs. + logical :: nudged_u_BCs_exist_globally = .false. !< True if any velocity points in the + !! global domain use nudged BCs. + logical :: nudged_v_BCs_exist_globally = .false. !< True if any velocity points in the + !! global domain use nudged BCs. + logical :: specified_u_BCs_exist_globally = .false. !< True if any zonal velocity points + !! in the global domain use specified BCs. + logical :: specified_v_BCs_exist_globally = .false. !< True if any meridional velocity points + !! in the global domain use specified BCs. + logical :: radiation_BCs_exist_globally = .false. !< True if radiations BCs are in use anywhere. + logical :: user_BCs_set_globally = .false. !< True if any OBC_USER_CONFIG is set + !! for input from user directory. + logical :: update_OBC = .false. !< Is OBC data time-dependent + logical :: update_OBC_seg_data = .false. !< Is it the time for OBC segment data update for fields that + !! require less frequent update + logical :: needs_IO_for_data = .false. !< Is any i/o needed for OBCs on the current PE + logical :: any_needs_IO_for_data = .false. !< Is any i/o needed for OBCs globally + logical :: some_need_no_IO_for_data = .false. !< Are there any PEs with OBCs that do not need i/o. + logical :: zero_vorticity = .false. !< If True, sets relative vorticity to zero on open boundaries. + logical :: freeslip_vorticity = .false. !< If True, sets normal gradient of tangential velocity to zero + !! in the relative vorticity on open boundaries. + logical :: computed_vorticity = .false. !< If True, uses external data for tangential velocity + !! in the relative vorticity on open boundaries. + logical :: specified_vorticity = .false. !< If True, uses external data for tangential velocity + !! gradients in the relative vorticity on open boundaries. + logical :: zero_strain = .false. !< If True, sets strain to zero on open boundaries. + logical :: freeslip_strain = .false. !< If True, sets normal gradient of tangential velocity to zero + !! in the strain on open boundaries. + logical :: computed_strain = .false. !< If True, uses external data for tangential velocity to compute + !! normal gradient in the strain on open boundaries. + logical :: specified_strain = .false. !< If True, uses external data for tangential velocity gradients + !! to compute strain on open boundaries. + logical :: zero_biharmonic = .false. !< If True, zeros the Laplacian of flow on open boundaries for + !! use in the biharmonic viscosity term. + logical :: brushcutter_mode = .false. !< If True, read data on supergrid. + logical, allocatable :: tracer_x_reservoirs_used(:) !< Dimensioned by the number of tracers, set globally, + !! true for those with x reservoirs (needed for restarts). + logical, allocatable :: tracer_y_reservoirs_used(:) !< Dimensioned by the number of tracers, set globally, + !! true for those with y reservoirs (needed for restarts). + integer :: ntr = 0 !< number of tracers + integer :: n_tide_constituents = 0 !< Number of tidal constituents to add to the boundary. + logical :: add_tide_constituents = .false. !< If true, add tidal constituents to the boundary elevation + !! and velocity. Will be set to true if n_tide_constituents > 0. + character(len=2), allocatable, dimension(:) :: tide_names !< Names of tidal constituents to add to the boundary data. + real, allocatable, dimension(:) :: tide_frequencies !< Angular frequencies of chosen tidal constituents [T-1 ~> s-1]. + real, allocatable, dimension(:) :: tide_eq_phases !< Equilibrium phases of chosen tidal constituents [rad]. + real, allocatable, dimension(:) :: tide_fn !< Amplitude modulation of boundary tides by nodal cycle [nondim]. + real, allocatable, dimension(:) :: tide_un !< Phase modulation of boundary tides by nodal cycle [rad]. + logical :: add_eq_phase = .false. !< If true, add the equilibrium phase argument + !! to the specified boundary tidal phase. + logical :: add_nodal_terms = .false. !< If true, insert terms for the 18.6 year modulation when + !! calculating tidal boundary conditions. + type(time_type) :: time_ref !< Reference date (t = 0) for tidal forcing. + type(astro_longitudes) :: tidal_longitudes !< Lunar and solar longitudes used to calculate tidal forcing. + ! Properties of the segments used. + type(OBC_segment_type), allocatable :: segment(:) !< List of segment objects. + ! Which segment object describes the current point. + integer, allocatable :: segnum_u(:,:) !< Segment number of u-points. + integer, allocatable :: segnum_v(:,:) !< Segment number of v-points. + ! Keep the OBC segment properties for external BGC tracers + type(external_tracers_segments_props), pointer :: obgc_segments_props => NULL() !< obgc segment properties + integer :: num_obgc_tracers = 0 !< The total number of obgc tracers + + ! The following parameters are used in the baroclinic radiation code: + real :: gamma_uv !< The relative weighting for the baroclinic radiation + !! velocities (or speed of characteristics) at the + !! new time level (1) or the running mean (0) for velocities [nondim]. + !! Valid values range from 0 to 1, with a default of 0.3. + real :: rx_max !< The maximum magnitude of the baroclinic radiation velocity (or speed of + !! characteristics) in units of grid points per timestep [nondim]. + logical :: OBC_pe !< Is there an open boundary on this tile? + type(remapping_CS), pointer :: remap_CS=> NULL() !< ALE remapping control structure for segments only + type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries + real, allocatable :: rx_normal(:,:,:) !< Array storage for normal phase speed for EW radiation OBCs in units of + !! grid points per timestep [nondim] + real, allocatable :: ry_normal(:,:,:) !< Array storage for normal phase speed for NS radiation OBCs in units of + !! grid points per timestep [nondim] + real, allocatable :: rx_oblique_u(:,:,:) !< X-direction oblique boundary condition radiation speeds squared + !! at u points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: ry_oblique_u(:,:,:) !< Y-direction oblique boundary condition radiation speeds squared + !! at u points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: rx_oblique_v(:,:,:) !< X-direction oblique boundary condition radiation speeds squared + !! at v points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: ry_oblique_v(:,:,:) !< Y-direction oblique boundary condition radiation speeds squared + !! at v points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: cff_normal_u(:,:,:) !< Denominator for normalizing EW oblique boundary condition radiation + !! rates at u points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: cff_normal_v(:,:,:) !< Denominator for normalizing NS oblique boundary condition radiation + !! rates at v points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: tres_x(:,:,:,:) !< Array storage of tracer reservoirs for restarts, in unscaled units [conc] + real, allocatable :: tres_y(:,:,:,:) !< Array storage of tracer reservoirs for restarts, in unscaled units [conc] + logical :: debug !< If true, write verbose checksums for debugging purposes. + real :: silly_h !< A silly value of thickness outside of the domain that can be used to test + !! the independence of the OBCs to this external data [Z ~> m]. + real :: silly_u !< A silly value of velocity outside of the domain that can be used to test + !! the independence of the OBCs to this external data [L T-1 ~> m s-1]. + logical :: ramp = .false. !< If True, ramp from zero to the external values for SSH. + logical :: ramping_is_activated = .false. !< True if the ramping has been initialized + real :: ramp_timescale !< If ramp is True, use this timescale for ramping [T ~> s]. + real :: trunc_ramp_time !< If ramp is True, time after which ramp is done [T ~> s]. + real :: ramp_value !< If ramp is True, where we are on the ramp from + !! zero to one [nondim]. + type(time_type) :: ramp_start_time !< Time when model was started. + integer :: remap_answer_date !< The vintage of the order of arithmetic and expressions to use + !! for remapping. Values below 20190101 recover the remapping + !! answers from 2018, while higher values use more robust + !! forms of the same remapping expressions. + type(group_pass_type) :: pass_oblique !< Structure for group halo pass +end type ocean_OBC_type + +!> Control structure for open boundaries that read from files. +!! Probably lots to update here. +type, public :: file_OBC_CS ; private + real :: tide_flow = 3.0e6 !< Placeholder for now..., perhaps in [m3 s-1]? +end type file_OBC_CS + +!> Type to carry something (what??) for the OBC registry. +type, public :: OBC_struct_type + character(len=32) :: name !< OBC name used for error messages +end type OBC_struct_type + +!> Type to carry basic OBC information needed for updating values. +type, public :: OBC_registry_type + integer :: nobc = 0 !< number of registered open boundary types. + type(OBC_struct_type) :: OB(MAX_FIELDS_) !< array of registered boundary types. + logical :: locked = .false. !< New OBC types may be registered if locked=.false. + !! When locked=.true.,no more boundaries can be registered. +end type OBC_registry_type + +!> Type to carry OBC information needed for setting segments for OBGC tracers +type, private :: external_tracers_segments_props + type(external_tracers_segments_props), pointer :: next => NULL() !< pointer to the next node + character(len=128) :: tracer_name !< tracer name + character(len=128) :: tracer_src_file !< tracer source file for BC + character(len=128) :: tracer_src_field !< name of the field in source file to extract BC + real :: lfac_in !< multiplicative factor for inbound tracer reservoir length scale [nondim] + real :: lfac_out !< multiplicative factor for outbound tracer reservoir length scale [nondim] +end type external_tracers_segments_props +integer :: id_clock_pass !< A CPU time clock + +character(len=40) :: mdl = "MOM_open_boundary" !< This module's name. + +contains + +!> Enables OBC module and reads configuration parameters +!> This routine is called from MOM_initialize_fixed which +!> occurs before the initialization of the vertical coordinate +!> and ALE_init. Therefore segment data are not fully initialized +!> here. The remainder of the segment data are initialized in a +!> later call to update_open_boundary_data + +subroutine open_boundary_config(G, US, param_file, OBC) + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handle + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + + ! Local variables + integer :: l ! For looping over segments + logical :: debug, debug_OBC, mask_outside, reentrant_x, reentrant_y + character(len=15) :: segment_param_str ! The run-time parameter name for each segment + character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str" + character(len=200) :: config1 ! String for OBC_USER_CONFIG + real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: check_reconstruction, check_remapping, force_bounds_in_subcell + character(len=64) :: remappingScheme + ! This include declares and sets the variable "version". +# include "version_variable.h" + + allocate(OBC) + + call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & + default=0, do_not_log=.true.) + call log_version(param_file, mdl, version, & + "Controls where open boundaries are located, what kind of boundary condition "//& + "to impose, and what data to apply, if any.", & + all_default=(OBC%number_of_segments<=0)) + call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & + "The number of open boundary segments.", & + default=0) + call get_param(param_file, mdl, "OBC_USER_CONFIG", config1, & + "A string that sets how the open boundary conditions are "//& + " configured: \n", default="none", do_not_log=.true.) + call get_param(param_file, mdl, "NK", OBC%ke, & + "The number of model layers", default=0, do_not_log=.true.) + + if (config1 /= "none" .and. config1 /= "dyed_obcs") OBC%user_BCs_set_globally = .true. + + if (OBC%number_of_segments > 0) then + call get_param(param_file, mdl, "OBC_ZERO_VORTICITY", OBC%zero_vorticity, & + "If true, sets relative vorticity to zero on open boundaries.", & + default=.false.) + call get_param(param_file, mdl, "OBC_FREESLIP_VORTICITY", OBC%freeslip_vorticity, & + "If true, sets the normal gradient of tangential velocity to "//& + "zero in the relative vorticity on open boundaries. This cannot "//& + "be true if another OBC_XXX_VORTICITY option is True.", default=.true.) + call get_param(param_file, mdl, "OBC_COMPUTED_VORTICITY", OBC%computed_vorticity, & + "If true, uses the external values of tangential velocity "//& + "in the relative vorticity on open boundaries. This cannot "//& + "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) + call get_param(param_file, mdl, "OBC_SPECIFIED_VORTICITY", OBC%specified_vorticity, & + "If true, uses the external values of tangential velocity "//& + "in the relative vorticity on open boundaries. This cannot "//& + "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) + if ((OBC%zero_vorticity .and. OBC%freeslip_vorticity) .or. & + (OBC%zero_vorticity .and. OBC%computed_vorticity) .or. & + (OBC%zero_vorticity .and. OBC%specified_vorticity) .or. & + (OBC%freeslip_vorticity .and. OBC%computed_vorticity) .or. & + (OBC%freeslip_vorticity .and. OBC%specified_vorticity) .or. & + (OBC%computed_vorticity .and. OBC%specified_vorticity)) & + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config:\n"//& + "Only one of OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY\n"//& + "and OBC_IMPORTED_VORTICITY can be True at once.") + call get_param(param_file, mdl, "OBC_ZERO_STRAIN", OBC%zero_strain, & + "If true, sets the strain used in the stress tensor to zero on open boundaries.", & + default=.false.) + call get_param(param_file, mdl, "OBC_FREESLIP_STRAIN", OBC%freeslip_strain, & + "If true, sets the normal gradient of tangential velocity to "//& + "zero in the strain use in the stress tensor on open boundaries. This cannot "//& + "be true if another OBC_XXX_STRAIN option is True.", default=.true.) + call get_param(param_file, mdl, "OBC_COMPUTED_STRAIN", OBC%computed_strain, & + "If true, sets the normal gradient of tangential velocity to "//& + "zero in the strain use in the stress tensor on open boundaries. This cannot "//& + "be true if another OBC_XXX_STRAIN option is True.", default=.false.) + call get_param(param_file, mdl, "OBC_SPECIFIED_STRAIN", OBC%specified_strain, & + "If true, sets the normal gradient of tangential velocity to "//& + "zero in the strain use in the stress tensor on open boundaries. This cannot "//& + "be true if another OBC_XXX_STRAIN option is True.", default=.false.) + if ((OBC%zero_strain .and. OBC%freeslip_strain) .or. & + (OBC%zero_strain .and. OBC%computed_strain) .or. & + (OBC%zero_strain .and. OBC%specified_strain) .or. & + (OBC%freeslip_strain .and. OBC%computed_strain) .or. & + (OBC%freeslip_strain .and. OBC%specified_strain) .or. & + (OBC%computed_strain .and. OBC%specified_strain)) & + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: \n"//& + "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN \n"//& + "and OBC_IMPORTED_STRAIN can be True at once.") + call get_param(param_file, mdl, "OBC_ZERO_BIHARMONIC", OBC%zero_biharmonic, & + "If true, zeros the Laplacian of flow on open boundaries in the biharmonic "//& + "viscosity term.", default=.false.) + call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, & + "If true, set the areas outside open boundaries to be land.", & + default=.false.) + call get_param(param_file, mdl, "RAMP_OBCS", OBC%ramp, & + "If true, ramps from zero to the external values over time, with"//& + "a ramping timescale given by RAMP_TIMESCALE. Ramping SSH only so far", & + default=.false.) + call get_param(param_file, mdl, "OBC_RAMP_TIMESCALE", OBC%ramp_timescale, & + "If RAMP_OBCS is true, this sets the ramping timescale.", & + units="days", default=1.0, scale=86400.0*US%s_to_T) + call get_param(param_file, mdl, "OBC_TIDE_N_CONSTITUENTS", OBC%n_tide_constituents, & + "Number of tidal constituents being added to the open boundary.", & + default=0) + + if (OBC%n_tide_constituents > 0) then + OBC%add_tide_constituents = .true. + else + OBC%add_tide_constituents = .false. + endif + + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) + ! This extra get_param call is to enable logging if either DEBUG or DEBUG_OBC are true. + call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=debug) + call get_param(param_file, mdl, "DEBUG_OBC", OBC%debug, & + "If true, do additional calls to help debug the performance "//& + "of the open boundary condition code.", & + default=debug, do_not_log=.not.(debug_OBC.or.debug), debuggingParam=.true.) + + call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & + "A silly value of thicknesses used outside of open boundary "//& + "conditions for debugging.", units="m", default=0.0, scale=US%m_to_Z, & + do_not_log=.not.OBC%debug, debuggingParam=.true.) + call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, & + "A silly value of velocities used outside of open boundary "//& + "conditions for debugging.", units="m/s", default=0.0, scale=US%m_s_to_L_T, & + do_not_log=.not.OBC%debug, debuggingParam=.true.) + reentrant_x = .false. + call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.) + reentrant_y = .false. + call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, default=.false.) + + ! Allocate everything + allocate(OBC%segment(1:OBC%number_of_segments)) + do l=1,OBC%number_of_segments + OBC%segment(l)%Flather = .false. + OBC%segment(l)%radiation = .false. + OBC%segment(l)%radiation_tan = .false. + OBC%segment(l)%radiation_grad = .false. + OBC%segment(l)%oblique = .false. + OBC%segment(l)%oblique_tan = .false. + OBC%segment(l)%oblique_grad = .false. + OBC%segment(l)%nudged = .false. + OBC%segment(l)%nudged_tan = .false. + OBC%segment(l)%nudged_grad = .false. + OBC%segment(l)%specified = .false. + OBC%segment(l)%specified_tan = .false. + OBC%segment(l)%specified_grad = .false. + OBC%segment(l)%open = .false. + OBC%segment(l)%gradient = .false. + OBC%segment(l)%values_needed = .false. + OBC%segment(l)%u_values_needed = .false. + OBC%segment(l)%uamp_values_needed = OBC%add_tide_constituents + OBC%segment(l)%uphase_values_needed = OBC%add_tide_constituents + OBC%segment(l)%v_values_needed = .false. + OBC%segment(l)%vamp_values_needed = OBC%add_tide_constituents + OBC%segment(l)%vphase_values_needed = OBC%add_tide_constituents + OBC%segment(l)%t_values_needed = .false. + OBC%segment(l)%s_values_needed = .false. + OBC%segment(l)%z_values_needed = .false. + OBC%segment(l)%zamp_values_needed = OBC%add_tide_constituents + OBC%segment(l)%zphase_values_needed = OBC%add_tide_constituents + OBC%segment(l)%g_values_needed = .false. + OBC%segment(l)%direction = OBC_NONE + OBC%segment(l)%is_N_or_S = .false. + OBC%segment(l)%is_E_or_W = .false. + OBC%segment(l)%is_E_or_W_2 = .false. + OBC%segment(l)%Velocity_nudging_timescale_in = 0.0 + OBC%segment(l)%Velocity_nudging_timescale_out = 0.0 + OBC%segment(l)%num_fields = 0 + enddo + allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed), source=OBC_NONE) + allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB), source=OBC_NONE) + + do l = 1, OBC%number_of_segments + write(segment_param_str(1:15),"('OBC_SEGMENT_',i3.3)") l + call get_param(param_file, mdl, segment_param_str, segment_str, & + "Documentation needs to be dynamic?????", & + fail_if_missing=.true.) + segment_str = remove_spaces(segment_str) + if (segment_str(1:2) == 'I=') then + call setup_u_point_obc(OBC, G, US, segment_str, l, param_file, reentrant_y) + elseif (segment_str(1:2) == 'J=') then + call setup_v_point_obc(OBC, G, US, segment_str, l, param_file, reentrant_x) + else + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//& + "Unable to interpret "//segment_param_str//" = "//trim(segment_str)) + endif + enddo + + ! Moved this earlier because time_interp_external_init needs to be called + ! before anything that uses time_interp_external (such as initialize_segment_data) + if (OBC%specified_u_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally .or. & + OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) then + ! Need this for ocean_only mode boundary interpolation. + call time_interp_external_init() + endif + ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) & + ! call initialize_segment_data(G, OBC, param_file) + + if (open_boundary_query(OBC, apply_open_OBC=.true.)) then + call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & + "The maximum magnitude of the baroclinic radiation velocity (or speed of "//& + "characteristics), in gridpoints per timestep. This is only "//& + "used if one of the open boundary segments is using Orlanski.", & + units="nondim", default=1.0) + call get_param(param_file, mdl, "OBC_RAD_VEL_WT", OBC%gamma_uv, & + "The relative weighting for the baroclinic radiation "//& + "velocities (or speed of characteristics) at the new "//& + "time level (1) or the running mean (0) for velocities. "//& + "Valid values range from 0 to 1. This is only used if "//& + "one of the open boundary segments is using Orlanski.", & + units="nondim", default=0.3) + endif + + Lscale_in = 0. + Lscale_out = 0. + if (open_boundary_query(OBC, apply_open_OBC=.true.)) then + call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, & + "An effective length scale for restoring the tracer concentration "//& + "at the boundaries to externally imposed values when the flow "//& + "is exiting the domain.", units="m", default=0.0, scale=US%m_to_L) + + call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, & + "An effective length scale for restoring the tracer concentration "//& + "at the boundaries to values from the interior when the flow "//& + "is entering the domain.", units="m", default=0.0, scale=US%m_to_L) + endif + + if (mask_outside) call mask_outside_OBCs(G, US, param_file, OBC) + + ! All tracers are using the same restoring length scale for now, but we may want to make this + ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained + ! by data while others are well constrained - MJH. + do l = 1, OBC%number_of_segments + OBC%segment(l)%Tr_InvLscale_in = 0.0 + if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale_in = 1.0/Lscale_in + OBC%segment(l)%Tr_InvLscale_out = 0.0 + if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out + enddo + + call get_param(param_file, mdl, "REMAPPING_SCHEME", remappingScheme, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: \n"//& + trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) + call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & + "If true, cell-by-cell reconstructions are checked for "//& + "consistency and if non-monotonicity or an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & + "If true, the results of remapping are checked for "//& + "conservation and new extrema and if an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & + "If true, read external OBC data on the supergrid.", & + default=.false.) + call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & + "If true, the values on the intermediate grid used for remapping "//& + "are forced to be bounded, which might not be the case due to "//& + "round off.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", OBC%remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date) + + allocate(OBC%remap_CS) + call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & + check_reconstruction=check_reconstruction, check_remapping=check_remapping, & + force_bounds_in_subcell=force_bounds_in_subcell, answer_date=OBC%remap_answer_date) + + endif ! OBC%number_of_segments > 0 + + ! Safety check + if ((OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) .and. & + .not.G%symmetric ) call MOM_error(FATAL, & + "MOM_open_boundary, open_boundary_config: "//& + "Symmetric memory must be used when using Flather OBCs.") + ! Need to do this last, because it depends on time_interp_external_init having already been called + if (OBC%add_tide_constituents) then + call initialize_obc_tides(OBC, US, param_file) + ! Tide update is done within update_OBC_segment_data, so this should be true if tides are included. + OBC%update_OBC = .true. + endif + + if (.not.(OBC%specified_u_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally .or. & + OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally)) then + ! No open boundaries have been requested + call open_boundary_dealloc(OBC) + endif + +end subroutine open_boundary_config + +!> Allocate space for reading OBC data from files. It sets up the required vertical +!! remapping. In the process, it does funky stuff with the MPI processes. +subroutine initialize_segment_data(G, GV, US, OBC, PF) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure + type(param_file_type), intent(in) :: PF !< Parameter file handle + + integer :: n, m, num_fields, mm + character(len=1024) :: segstr + character(len=256) :: filename + character(len=20) :: segnam, suffix + character(len=32) :: fieldname + real :: value ! A value that is parsed from the segment data string [various units] + character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names + character(len=128) :: inputdir + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + character(len=256) :: mesg ! Message for error messages. + integer, dimension(4) :: siz,siz2 + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + integer :: IsdB, IedB, JsdB, JedB + integer, dimension(:), allocatable :: saved_pelist + integer :: current_pe + integer, dimension(1) :: single_pelist + type(external_tracers_segments_props), pointer :: obgc_segments_props_list =>NULL() + !will be able to dynamically switch between sub-sampling refined grid data or model grid + integer :: IO_needs(3) ! Sums to determine global OBC data use and update patterns. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + ! There is a problem with the order of the OBC initialization + ! with respect to ALE_init. Currently handling this by copying the + ! param file so that I can use it later in step_MOM in order to finish + ! initializing segments on the first step. + + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + if (OBC%user_BCs_set_globally) return + + ! Try this here just for the documentation. It is repeated below. + do n=1, OBC%number_of_segments + write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n + call get_param(PF, mdl, segnam, segstr, 'OBC segment docs') + enddo + + !< temporarily disable communication in order to read segment data independently + + allocate(saved_pelist(0:num_PEs()-1)) + call Get_PElist(saved_pelist) + current_pe = PE_here() + single_pelist(1) = current_pe + call Set_PElist(single_pelist) + + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%values_needed) cycle + + write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n + write(suffix,"('_segment_',i3.3)") n + ! needs documentation !! Yet, unsafe for now, causes grief for + ! MOM_parameter_docs in circle_obcs on two processes. +! call get_param(PF, mdl, segnam, segstr, 'xyz') + ! Clear out any old values + segstr = '' + call get_param(PF, mdl, segnam, segstr) + if (segstr == '') then + write(mesg,'("No OBC_SEGMENT_XXX_DATA string for OBC segment ",I3)') n + call MOM_error(FATAL, mesg) + endif + + call parse_segment_manifest_str(trim(segstr), num_fields, fields) + if (num_fields == 0) then + call MOM_mesg('initialize_segment_data: num_fields = 0') + cycle ! cycle to next segment + endif + + !There are OBC%num_obgc_tracers obgc tracers are there that are not listed in param file + segment%num_fields = num_fields + OBC%num_obgc_tracers + allocate(segment%field(segment%num_fields)) + + segment%temp_segment_data_exists = .false. + segment%salt_segment_data_exists = .false. +!! +! CODE HERE FOR OTHER OPTIONS (CLAMPED, NUDGED,..) +!! + + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + obgc_segments_props_list => OBC%obgc_segments_props !pointer to the head node + do m=1,segment%num_fields + if (m <= num_fields) then + !These are tracers with segments specified in MOM6 style override files + call parse_segment_data_str(trim(segstr), m, trim(fields(m)), value, filename, fieldname) + else + !These are obgc tracers with segments specified by external modules. + !Set a flag so that these can be distinguished from native tracers as they may need + !extra steps for preparation and handling. + segment%field(m)%genre = 'obgc' + !Query the obgc segment properties by traversing the linkedlist + call get_obgc_segments_props(obgc_segments_props_list,fields(m),filename,fieldname,& + segment%field(m)%resrv_lfac_in,segment%field(m)%resrv_lfac_out) + !Make sure the obgc tracer is not specified in the MOM6 param file too. + do mm=1,num_fields + if (trim(fields(m)) == trim(fields(mm))) then + if (is_root_pe()) & + call MOM_error(FATAL,"MOM_open_boundary:initialize_segment_data(): obgc tracer " //trim(fields(m))// & + " appears in OBC_SEGMENT_XXX_DATA string in MOM6 param file. This is not supported!") + endif + enddo + endif + if (trim(filename) /= 'none') then + OBC%update_OBC = .true. ! Data is assumed to be time-dependent if we are reading from file + OBC%needs_IO_for_data = .true. ! At least one segment is using I/O for OBC data +! segment%values_needed = .true. ! Indicates that i/o will be needed for this segment + segment%field(m)%name = trim(fields(m)) + ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input + ! value is rescaled there. + segment%field(m)%scale = scale_factor_from_name(fields(m), GV, US, segment%tr_Reg) + segment%field(m)%use_IO = .true. + if (segment%field(m)%name == 'TEMP') then + segment%temp_segment_data_exists = .true. + segment%t_values_needed = .false. + endif + if (segment%field(m)%name == 'SALT') then + segment%salt_segment_data_exists = .true. + segment%s_values_needed = .false. + endif + filename = trim(inputdir)//trim(filename) + fieldname = trim(fieldname)//trim(suffix) + call field_size(filename,fieldname,siz,no_domain=.true.) +! if (siz(4) == 1) segment%values_needed = .false. + if (segment%on_pe) then + if (OBC%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then + write(mesg,'("Brushcutter mode sizes ", I6, I6)') siz(1), siz(2) + call MOM_error(WARNING, mesg // " " // trim(filename) // " " // trim(fieldname)) + call MOM_error(FATAL,'segment data are not on the supergrid') + endif + siz2(1) = 1 + + if (siz(1)>1) then + if (OBC%brushcutter_mode) then + siz2(1) = (siz(1)-1)/2 + else + siz2(1) = siz(1) + endif + endif + siz2(2) = 1 + if (siz(2)>1) then + if (OBC%brushcutter_mode) then + siz2(2) = (siz(2)-1)/2 + else + siz2(2) = siz(2) + endif + endif + siz2(3) = siz(3) + + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V') then + allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) + segment%v_values_needed = .false. + elseif (segment%field(m)%name == 'Vamp') then + allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) + segment%vamp_values_needed = .false. + segment%vamp_index = m + elseif (segment%field(m)%name == 'Vphase') then + allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) + segment%vphase_values_needed = .false. + segment%vphase_index = m + elseif (segment%field(m)%name == 'DVDX') then + allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) + segment%g_values_needed = .false. + else + allocate(segment%field(m)%buffer_src(IsdB:IedB,jsd:jed,siz2(3))) + if (segment%field(m)%name == 'U') then + segment%u_values_needed = .false. + elseif (segment%field(m)%name == 'Uamp') then + segment%uamp_values_needed = .false. + segment%uamp_index = m + elseif (segment%field(m)%name == 'Uphase') then + segment%uphase_values_needed = .false. + segment%uphase_index = m + elseif (segment%field(m)%name == 'SSH') then + segment%z_values_needed = .false. + elseif (segment%field(m)%name == 'SSHamp') then + segment%zamp_values_needed = .false. + segment%zamp_index = m + elseif (segment%field(m)%name == 'SSHphase') then + segment%zphase_values_needed = .false. + segment%zphase_index = m + elseif (segment%field(m)%name == 'TEMP') then + segment%t_values_needed = .false. + elseif (segment%field(m)%name == 'SALT') then + segment%s_values_needed = .false. + endif + endif + else + if (segment%field(m)%name == 'U') then + allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) + segment%u_values_needed = .false. + elseif (segment%field(m)%name == 'DUDY') then + allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) + segment%g_values_needed = .false. + elseif (segment%field(m)%name == 'Uamp') then + allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) + segment%uamp_values_needed = .false. + segment%uamp_index = m + elseif (segment%field(m)%name == 'Uphase') then + allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) + segment%uphase_values_needed = .false. + segment%uphase_index = m + else + allocate(segment%field(m)%buffer_src(isd:ied,JsdB:JedB,siz2(3))) + if (segment%field(m)%name == 'V') then + segment%v_values_needed = .false. + elseif (segment%field(m)%name == 'Vamp') then + segment%vamp_values_needed = .false. + segment%vamp_index = m + elseif (segment%field(m)%name == 'Vphase') then + segment%vphase_values_needed = .false. + segment%vphase_index = m + elseif (segment%field(m)%name == 'SSH') then + segment%z_values_needed = .false. + elseif (segment%field(m)%name == 'SSHamp') then + segment%zamp_values_needed = .false. + segment%zamp_index = m + elseif (segment%field(m)%name == 'SSHphase') then + segment%zphase_values_needed = .false. + segment%zphase_index = m + elseif (segment%field(m)%name == 'TEMP') then + segment%t_values_needed = .false. + elseif (segment%field(m)%name == 'SALT') then + segment%s_values_needed = .false. + endif + endif + endif + segment%field(m)%buffer_src(:,:,:) = 0.0 + segment%field(m)%handle = init_external_field(trim(filename), trim(fieldname), & + ignore_axis_atts=.true., threading=SINGLE_FILE) + if (siz(3) > 1) then + if ((index(segment%field(m)%name, 'phase') > 0) .or. (index(segment%field(m)%name, 'amp') > 0)) then + ! siz(3) is constituent for tidal variables + call field_size(filename, 'constituent', siz, no_domain=.true.) + ! expect third dimension to be number of constituents in MOM_input + if (siz(3) /= OBC%n_tide_constituents .and. OBC%add_tide_constituents) then + call MOM_error(FATAL, 'Number of constituents in input data is not '//& + 'the same as the number specified') + endif + segment%field(m)%nk_src=siz(3) + else + ! siz(3) is depth for everything else + fieldname = 'dz_'//trim(fieldname) + call field_size(filename,fieldname,siz,no_domain=.true.) + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3))) + else + allocate(segment%field(m)%dz_src(IsdB:IedB,jsd:jed,siz(3))) + endif + else + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3))) + else + allocate(segment%field(m)%dz_src(isd:ied,JsdB:JedB,siz(3))) + endif + endif + segment%field(m)%dz_src(:,:,:) = 0.0 + segment%field(m)%nk_src=siz(3) + segment%field(m)%dz_handle = init_external_field(trim(filename), trim(fieldname), & + ignore_axis_atts=.true., threading=SINGLE_FILE) + endif + else + segment%field(m)%nk_src=1 + endif + endif + else + segment%field(m)%name = trim(fields(m)) + ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input + ! value is rescaled there. + segment%field(m)%scale = scale_factor_from_name(fields(m), GV, US, segment%tr_Reg) + segment%field(m)%value = segment%field(m)%scale * value + segment%field(m)%use_IO = .false. + + ! Check if this is a tidal field. If so, the number + ! of expected constituents must be 1. + if ((index(segment%field(m)%name, 'phase') > 0) .or. (index(segment%field(m)%name, 'amp') > 0)) then + if (OBC%n_tide_constituents > 1 .and. OBC%add_tide_constituents) then + call MOM_error(FATAL, 'Only one constituent is supported when specifying '//& + 'tidal boundary conditions by value rather than file.') + endif + endif + if (segment%field(m)%name == 'U') then + segment%u_values_needed = .false. + elseif (segment%field(m)%name == 'Uamp') then + segment%uamp_values_needed = .false. + segment%uamp_index = m + elseif (segment%field(m)%name == 'Uphase') then + segment%uphase_values_needed = .false. + segment%uphase_index = m + elseif (segment%field(m)%name == 'V') then + segment%v_values_needed = .false. + elseif (segment%field(m)%name == 'Vamp') then + segment%vamp_values_needed = .false. + segment%vamp_index = m + elseif (segment%field(m)%name == 'Vphase') then + segment%vphase_values_needed = .false. + segment%vphase_index = m + elseif (segment%field(m)%name == 'SSH') then + segment%z_values_needed = .false. + elseif (segment%field(m)%name == 'SSHamp') then + segment%zamp_values_needed = .false. + segment%zamp_index = m + elseif (segment%field(m)%name == 'SSHphase') then + segment%zphase_values_needed = .false. + segment%zphase_index = m + elseif (segment%field(m)%name == 'TEMP') then + segment%t_values_needed = .false. + elseif (segment%field(m)%name == 'SALT') then + segment%s_values_needed = .false. + elseif (segment%field(m)%name == 'DVDX' .or. segment%field(m)%name == 'DUDY') then + segment%g_values_needed = .false. + endif + endif + enddo + if (segment%u_values_needed .or. segment%uamp_values_needed .or. segment%uphase_values_needed .or. & + segment%v_values_needed .or. segment%vamp_values_needed .or. segment%vphase_values_needed .or. & + segment%t_values_needed .or. segment%s_values_needed .or. segment%g_values_needed .or. & + segment%z_values_needed .or. segment%zamp_values_needed .or. segment%zphase_values_needed ) then + write(mesg,'("Values needed for OBC segment ",I3)') n + call MOM_error(FATAL, mesg) + endif + enddo + + call Set_PElist(saved_pelist) + + ! Determine global IO data requirement patterns. + IO_needs(1) = 0 ; if (OBC%needs_IO_for_data) IO_needs(1) = 1 + IO_needs(2) = 0 ; if (OBC%update_OBC) IO_needs(2) = 1 + IO_needs(3) = 0 ; if (.not.OBC%needs_IO_for_data) IO_needs(3) = 1 + call sum_across_PES(IO_needs, 3) + OBC%any_needs_IO_for_data = (IO_needs(1) > 0) + OBC%update_OBC = (IO_needs(2) > 0) + OBC%some_need_no_IO_for_data = (IO_needs(3) > 0) + +end subroutine initialize_segment_data + +!> Return an appropriate dimensional scaling factor for input data based on an OBC segment data +!! name, or 1 for tracers or other fields that do not match one of the specified names. +!! Note that calls to register_segment_tracer can come before or after calls to scale_factor_from_name. + +real function scale_factor_from_name(name, GV, US, Tr_Reg) + character(len=*), intent(in) :: name !< The OBC segment data name to interpret + type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(segment_tracer_registry_type), pointer :: Tr_Reg !< pointer to tracer registry for this segment + + integer :: m + + select case (trim(name)) + case ('U') ; scale_factor_from_name = US%m_s_to_L_T + case ('V') ; scale_factor_from_name = US%m_s_to_L_T + case ('Uamp') ; scale_factor_from_name = US%m_s_to_L_T + case ('Vamp') ; scale_factor_from_name = US%m_s_to_L_T + case ('DVDX') ; scale_factor_from_name = US%T_to_s + case ('DUDY') ; scale_factor_from_name = US%T_to_s + case ('SSH') ; scale_factor_from_name = US%m_to_Z + case ('SSHamp') ; scale_factor_from_name = US%m_to_Z + case default ; scale_factor_from_name = 1.0 + end select + + if (associated(Tr_Reg) .and. (scale_factor_from_name == 1.0)) then + ! Check for name matches with previously registered tracers. + do m=1,Tr_Reg%ntseg + if (uppercase(name) == uppercase(Tr_Reg%Tr(m)%name)) then + scale_factor_from_name = Tr_Reg%Tr(m)%scale + exit + endif + enddo + endif + +end function scale_factor_from_name + +!> Initize parameters and fields related to the specification of tides at open boundaries. +subroutine initialize_obc_tides(OBC, US, param_file) + type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handle + integer, dimension(3) :: tide_ref_date !< Reference date (t = 0) for tidal forcing (year, month, day). + integer, dimension(3) :: nodal_ref_date !< Date to calculate nodal modulation for (year, month, day). + character(len=50) :: tide_constituent_str !< List of tidal constituents to include on boundary. + type(astro_longitudes) :: nodal_longitudes !< Solar and lunar longitudes for tidal forcing + type(time_type) :: nodal_time !< Model time to calculate nodal modulation for. + integer :: c !< Index to tidal constituent. + + call get_param(param_file, mdl, "OBC_TIDE_CONSTITUENTS", tide_constituent_str, & + "Names of tidal constituents being added to the open boundaries.", & + fail_if_missing=.true.) + + call get_param(param_file, mdl, "OBC_TIDE_ADD_EQ_PHASE", OBC%add_eq_phase, & + "If true, add the equilibrium phase argument to the specified tidal phases.", & + default=.false., fail_if_missing=.false.) + + call get_param(param_file, mdl, "OBC_TIDE_ADD_NODAL", OBC%add_nodal_terms, & + "If true, include 18.6 year nodal modulation in the boundary tidal forcing.", & + default=.false.) + + call get_param(param_file, mdl, "OBC_TIDE_REF_DATE", tide_ref_date, & + "Reference date to use for tidal calculations and equilibrium phase.", & + fail_if_missing=.true.) + + call get_param(param_file, mdl, "OBC_TIDE_NODAL_REF_DATE", nodal_ref_date, & + "Fixed reference date to use for nodal modulation of boundary tides.", & + fail_if_missing=.false., default=0) + + if (.not. OBC%add_eq_phase) then + ! If equilibrium phase argument is not added, the input phases + ! should already be relative to the reference time. + call MOM_mesg('OBC tidal phases will *not* be corrected with equilibrium arguments.') + endif + + allocate(OBC%tide_names(OBC%n_tide_constituents)) + read(tide_constituent_str, *) OBC%tide_names + + ! Set reference time (t = 0) for boundary tidal forcing. + OBC%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3)) + + ! Find relevant lunar and solar longitudes at the reference time + if (OBC%add_eq_phase) call astro_longitudes_init(OBC%time_ref, OBC%tidal_longitudes) + + ! If the nodal correction is based on a different time, initialize that. + ! Otherwise, it can use N from the time reference. + if (OBC%add_nodal_terms) then + if (sum(nodal_ref_date) /= 0) then + ! A reference date was provided for the nodal correction + nodal_time = set_date(nodal_ref_date(1), nodal_ref_date(2), nodal_ref_date(3)) + call astro_longitudes_init(nodal_time, nodal_longitudes) + elseif (OBC%add_eq_phase) then + ! Astronomical longitudes were already calculated for use in equilibrium phases, + ! so use nodal longitude from that. + nodal_longitudes = OBC%tidal_longitudes + else + ! Tidal reference time is a required parameter, so calculate the longitudes from that. + call astro_longitudes_init(OBC%time_ref, nodal_longitudes) + endif + endif + + allocate(OBC%tide_frequencies(OBC%n_tide_constituents)) + allocate(OBC%tide_eq_phases(OBC%n_tide_constituents)) + allocate(OBC%tide_fn(OBC%n_tide_constituents)) + allocate(OBC%tide_un(OBC%n_tide_constituents)) + + do c=1,OBC%n_tide_constituents + ! If tidal frequency is overridden by setting TIDE_*_FREQ, use that, otherwise use the + ! default realistic frequency for this constituent. + call get_param(param_file, mdl, "TIDE_"//trim(OBC%tide_names(c))//"_FREQ", OBC%tide_frequencies(c), & + "Frequency of the "//trim(OBC%tide_names(c))//" tidal constituent. "//& + "This is only used if TIDES and TIDE_"//trim(OBC%tide_names(c))// & + " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and "//trim(OBC%tide_names(c))//& + " is in OBC_TIDE_CONSTITUENTS.", & + units="s-1", default=tidal_frequency(trim(OBC%tide_names(c))), scale=US%T_to_s) + + ! Find equilibrium phase if needed + if (OBC%add_eq_phase) then + OBC%tide_eq_phases(c) = eq_phase(trim(OBC%tide_names(c)), OBC%tidal_longitudes) + else + OBC%tide_eq_phases(c) = 0.0 + endif + + ! Find nodal corrections if needed + if (OBC%add_nodal_terms) then + call nodal_fu(trim(OBC%tide_names(c)), nodal_longitudes%N, OBC%tide_fn(c), OBC%tide_un(c)) + else + OBC%tide_fn(c) = 1.0 + OBC%tide_un(c) = 0.0 + endif + enddo +end subroutine initialize_obc_tides + +!> Define indices for segment and store in hor_index_type +!> using global segment bounds corresponding to q-points +subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) + type(dyn_horgrid_type), intent(in) :: G !< grid type + type(OBC_segment_type), intent(inout) :: seg !< Open boundary segment + integer, intent(in) :: Is_obc !< Q-point global i-index of start of segment + integer, intent(in) :: Ie_obc !< Q-point global i-index of end of segment + integer, intent(in) :: Js_obc !< Q-point global j-index of start of segment + integer, intent(in) :: Je_obc !< Q-point global j-index of end of segment + ! Local variables + integer :: IsgB, IegB, JsgB, JegB + integer :: isg, ieg, jsg, jeg + + ! Isg, Ieg will be I*_obc in global space + if (Ie_obc < Is_obc) then + IsgB = Ie_obc + IegB = Is_obc + else + IsgB = Is_obc + IegB = Ie_obc + endif + + if (Je_obc < Js_obc) then + JsgB = Je_obc + JegB = Js_obc + else + JsgB = Js_obc + JegB = Je_obc + endif + + ! NOTE: h-points are defined along the interior of the segment q-points. + ! For a given segment and its start and end index pairs, [IJ][se]gB, the + ! h-cell corresponding to this pair are shown in the figure below. + ! + ! x-x----------------x-x + ! | | N | | + ! x-x W E x-x + ! | S | + ! x-x----------------x-x + ! | | | | + ! x-x x-x + ! + ! For segment points on the west and south, h-point indices are incremented + ! in order to move to the interior cell. + + if (Is_obc > Ie_obc) then + ! Northern boundary + isg = IsgB + 1 + jsg = JsgB + ieg = IegB + jeg = JegB + endif + + if (Is_obc < Ie_obc) then + ! Southern boundary + isg = IsgB + 1 + jsg = JsgB + 1 + ieg = IegB + jeg = JegB + 1 + endif + + if (Js_obc < Je_obc) then + ! Eastern boundary + isg = IsgB + jsg = JsgB + 1 + ieg = IegB + jeg = JegB + endif + + if (Js_obc > Je_obc) then + ! Western boundary + isg = IsgB + 1 + jsg = JsgB + 1 + ieg = IegB + 1 + jeg = JegB + endif + + ! Global space I*_obc but sorted + seg%HI%IsgB = IsgB + seg%HI%JegB = JegB + seg%HI%IegB = IegB + seg%HI%JsgB = JsgB + + seg%HI%isg = isg + seg%HI%jsg = jsg + seg%HI%ieg = ieg + seg%HI%jeg = jeg + + ! Move into local index space + IsgB = IsgB - G%idg_offset + JsgB = JsgB - G%jdg_offset + IegB = IegB - G%idg_offset + JegB = JegB - G%jdg_offset + + isg = isg - G%idg_offset + jsg = jsg - G%jdg_offset + ieg = ieg - G%idg_offset + jeg = jeg - G%jdg_offset + + ! This is the i-extent of the segment on this PE. + ! The values are nonsense if the segment is not on this PE. + seg%HI%IsdB = min(max(IsgB, G%HI%IsdB), G%HI%IedB) + seg%HI%IedB = min(max(IegB, G%HI%IsdB), G%HI%IedB) + seg%HI%isd = min(max(isg, G%HI%isd), G%HI%ied) + seg%HI%ied = min(max(ieg, G%HI%isd), G%HI%ied) + seg%HI%IscB = min(max(IsgB, G%HI%IscB), G%HI%IecB) + seg%HI%IecB = min(max(IegB, G%HI%IscB), G%HI%IecB) + seg%HI%isc = min(max(isg, G%HI%isc), G%HI%iec) + seg%HI%iec = min(max(ieg, G%HI%isc), G%HI%iec) + + ! This is the j-extent of the segment on this PE. + ! The values are nonsense if the segment is not on this PE. + seg%HI%JsdB = min(max(JsgB, G%HI%JsdB), G%HI%JedB) + seg%HI%JedB = min(max(JegB, G%HI%JsdB), G%HI%JedB) + seg%HI%jsd = min(max(jsg, G%HI%jsd), G%HI%jed) + seg%HI%jed = min(max(jeg, G%HI%jsd), G%HI%jed) + seg%HI%JscB = min(max(JsgB, G%HI%JscB), G%HI%JecB) + seg%HI%JecB = min(max(JegB, G%HI%JscB), G%HI%JecB) + seg%HI%jsc = min(max(jsg, G%HI%jsc), G%HI%jec) + seg%HI%jec = min(max(jeg, G%HI%jsc), G%HI%jec) + +end subroutine setup_segment_indices + +!> Parse an OBC_SEGMENT_%%% string starting with "I=" and configure placement and type of OBC accordingly +subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) + type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + character(len=*), intent(in) :: segment_str !< A string in form of "I=%,J=%:%,string" + integer, intent(in) :: l_seg !< which segment is this? + type(param_file_type), intent(in) :: PF !< Parameter file handle + logical, intent(in) :: reentrant_y !< is the domain reentrant in y? + ! Local variables + integer :: I_obc, Js_obc, Je_obc ! Position of segment in global index space + integer :: j, a_loop + character(len=32) :: action_str(8) + character(len=128) :: segment_param_str + real, allocatable, dimension(:) :: tnudge ! Nudging timescales [T ~> s] + ! This returns the global indices for the segment + call parse_segment_str(G%ieg, G%jeg, segment_str, I_obc, Js_obc, Je_obc, action_str, reentrant_y) + + call setup_segment_indices(G, OBC%segment(l_seg),I_obc,I_obc,Js_obc,Je_obc) + + I_obc = I_obc - G%idg_offset ! Convert to local tile indices on this tile + Js_obc = Js_obc - G%jdg_offset ! Convert to local tile indices on this tile + Je_obc = Je_obc - G%jdg_offset ! Convert to local tile indices on this tile + + if (Je_obc>Js_obc) then + OBC%segment(l_seg)%direction = OBC_DIRECTION_E + elseif (Je_obc=G%HI%IedB-1) return ! Boundary is not on tile + if (Je_obc<=G%HI%JsdB .or. Js_obc>=G%HI%JedB) return ! Segment is not on tile + + OBC%segment(l_seg)%on_pe = .true. + OBC%segment(l_seg)%is_E_or_W = .true. + + do j=G%HI%jsd, G%HI%jed + if (j>Js_obc .and. j<=Je_obc) then + OBC%segnum_u(I_obc,j) = l_seg + endif + enddo + OBC%segment(l_seg)%Is_obc = I_obc + OBC%segment(l_seg)%Ie_obc = I_obc + OBC%segment(l_seg)%Js_obc = Js_obc + OBC%segment(l_seg)%Je_obc = Je_obc + call allocate_OBC_segment_data(OBC, OBC%segment(l_seg)) + + if (OBC%segment(l_seg)%oblique .and. OBC%segment(l_seg)%radiation) & + call MOM_error(FATAL, "MOM_open_boundary.F90, setup_u_point_obc: \n"//& + "Orlanski and Oblique OBC options cannot be used together on one segment.") + + if (OBC%segment(l_seg)%u_values_needed .or. OBC%segment(l_seg)%v_values_needed .or. & + OBC%segment(l_seg)%t_values_needed .or. OBC%segment(l_seg)%s_values_needed .or. & + OBC%segment(l_seg)%z_values_needed .or. OBC%segment(l_seg)%g_values_needed) & + OBC%segment(l_seg)%values_needed = .true. +end subroutine setup_u_point_obc + +!> Parse an OBC_SEGMENT_%%% string starting with "J=" and configure placement and type of OBC accordingly +subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) + type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + character(len=*), intent(in) :: segment_str !< A string in form of "J=%,I=%:%,string" + integer, intent(in) :: l_seg !< which segment is this? + type(param_file_type), intent(in) :: PF !< Parameter file handle + logical, intent(in) :: reentrant_x !< is the domain reentrant in x? + ! Local variables + integer :: J_obc, Is_obc, Ie_obc ! Position of segment in global index space + integer :: i, a_loop + character(len=32) :: action_str(8) + character(len=128) :: segment_param_str + real, allocatable, dimension(:) :: tnudge ! Nudging timescales [T ~> s] + + ! This returns the global indices for the segment + call parse_segment_str(G%ieg, G%jeg, segment_str, J_obc, Is_obc, Ie_obc, action_str, reentrant_x) + + call setup_segment_indices(G, OBC%segment(l_seg),Is_obc,Ie_obc,J_obc,J_obc) + + J_obc = J_obc - G%jdg_offset ! Convert to local tile indices on this tile + Is_obc = Is_obc - G%idg_offset ! Convert to local tile indices on this tile + Ie_obc = Ie_obc - G%idg_offset ! Convert to local tile indices on this tile + + if (Ie_obc>Is_obc) then + OBC%segment(l_seg)%direction = OBC_DIRECTION_S + elseif (Ie_obc=G%HI%JedB-1) return ! Boundary is not on tile + if (Ie_obc<=G%HI%IsdB .or. Is_obc>=G%HI%IedB) return ! Segment is not on tile + + OBC%segment(l_seg)%on_pe = .true. + OBC%segment(l_seg)%is_N_or_S = .true. + + do i=G%HI%isd, G%HI%ied + if (i>Is_obc .and. i<=Ie_obc) then + OBC%segnum_v(i,J_obc) = l_seg + endif + enddo + OBC%segment(l_seg)%Is_obc = Is_obc + OBC%segment(l_seg)%Ie_obc = Ie_obc + OBC%segment(l_seg)%Js_obc = J_obc + OBC%segment(l_seg)%Je_obc = J_obc + call allocate_OBC_segment_data(OBC, OBC%segment(l_seg)) + + if (OBC%segment(l_seg)%oblique .and. OBC%segment(l_seg)%radiation) & + call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc: \n"//& + "Orlanski and Oblique OBC options cannot be used together on one segment.") + + if (OBC%segment(l_seg)%u_values_needed .or. OBC%segment(l_seg)%v_values_needed .or. & + OBC%segment(l_seg)%t_values_needed .or. OBC%segment(l_seg)%s_values_needed .or. & + OBC%segment(l_seg)%z_values_needed .or. OBC%segment(l_seg)%g_values_needed) & + OBC%segment(l_seg)%values_needed = .true. +end subroutine setup_v_point_obc + +!> Parse an OBC_SEGMENT_%%% string +subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_str, reentrant) + integer, intent(in) :: ni_global !< Number of h-points in zonal direction + integer, intent(in) :: nj_global !< Number of h-points in meridional direction + character(len=*), intent(in) :: segment_str !< A string in form of "I=l,J=m:n,string" or "J=l,I=m,n,string" + integer, intent(out) :: l !< The value of I=l, if segment_str begins with I=l, or the value of J=l + integer, intent(out) :: m !< The value of J=m, if segment_str begins with I=, or the value of I=m + integer, intent(out) :: n !< The value of J=n, if segment_str begins with I=, or the value of I=n + character(len=*), intent(out) :: action_str(:) !< The "string" part of segment_str + logical, intent(in) :: reentrant !< is domain reentrant in relevant direction? + ! Local variables + character(len=24) :: word1, word2, m_word, n_word !< Words delineated by commas in a string in form of + !! "I=%,J=%:%,string" + integer :: l_max !< Either ni_global or nj_global, depending on whether segment_str begins with "I=" or "J=" + integer :: mn_max !< Either nj_global or ni_global, depending on whether segment_str begins with "I=" or "J=" + integer :: j + integer, parameter :: halo = 10 + + ! Process first word which will started with either 'I=' or 'J=' + word1 = extract_word(segment_str,',',1) + word2 = extract_word(segment_str,',',2) + if (word1(1:2)=='I=') then + l_max = ni_global + mn_max = nj_global + if (.not. (word2(1:2)=='J=')) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "Second word of string '"//trim(segment_str)//"' must start with 'J='.") + elseif (word1(1:2)=='J=') then ! Note that the file_parser uniformly expands "=" to " = " + l_max = nj_global + mn_max = ni_global + if (.not. (word2(1:2)=='I=')) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "Second word of string '"//trim(segment_str)//"' must start with 'I='.") + else + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str"//& + "String '"//segment_str//"' must start with 'I=' or 'J='.") + endif + + ! Read l + l = interpret_int_expr( word1(3:24), l_max ) + if (l<0 .or. l>l_max) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "First value from string '"//trim(segment_str)//"' is outside of the physical domain.") + endif + + ! Read m + m_word = extract_word(word2(3:24),':',1) + m = interpret_int_expr( m_word, mn_max ) + if (reentrant) then + if (m<-halo .or. m>mn_max+halo) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "Beginning of range in string '"//trim(segment_str)//"' is outside of the physical domain.") + endif + else + if (m<-1 .or. m>mn_max+1) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "Beginning of range in string '"//trim(segment_str)//"' is outside of the physical domain.") + endif + endif + + ! Read n + n_word = extract_word(word2(3:24),':',2) + n = interpret_int_expr( n_word, mn_max ) + if (reentrant) then + if (n<-halo .or. n>mn_max+halo) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "End of range in string '"//trim(segment_str)//"' is outside of the physical domain.") + endif + else + if (n<-1 .or. n>mn_max+1) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "End of range in string '"//trim(segment_str)//"' is outside of the physical domain.") + endif + endif + + if (abs(n-m)==0) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "Range in string '"//trim(segment_str)//"' must span one cell.") + endif + + ! Type of open boundary condition + do j = 1, size(action_str) + action_str(j) = extract_word(segment_str,',',2+j) + enddo + + contains + + ! Returns integer value interpreted from string in form of %I, N or N+-%I + integer function interpret_int_expr(string, imax) + character(len=*), intent(in) :: string !< Integer in form or %I, N or N-%I + integer, intent(in) :: imax !< Value to replace 'N' with + ! Local variables + integer slen + + slen = len_trim(string) + if (slen==0) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str"//& + "Parsed string was empty!") + if (len_trim(string)==1 .and. string(1:1)=='N') then + interpret_int_expr = imax + elseif (string(1:1)=='N') then + if (string(2:2)=='+') then + read(string(3:slen),*,err=911) interpret_int_expr + interpret_int_expr = imax + interpret_int_expr + elseif (string(2:2)=='-') then + read(string(3:slen),*,err=911) interpret_int_expr + interpret_int_expr = imax - interpret_int_expr + endif + else + read(string(1:slen),*,err=911) interpret_int_expr + endif + return + 911 call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str"//& + "Problem reading value from string '"//trim(string)//"'.") + end function interpret_int_expr +end subroutine parse_segment_str + + +!> Parse an OBC_SEGMENT_%%%_DATA string and determine its fields +subroutine parse_segment_manifest_str(segment_str, num_fields, fields) + character(len=*), intent(in) :: segment_str !< A string in form of + !< "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." + integer, intent(out) :: num_fields !< The number of fields in the segment data + character(len=*), dimension(MAX_OBC_FIELDS), intent(out) :: fields + !< List of fieldnames for each segment + + ! Local variables + character(len=128) :: word1, word2 + + num_fields = 0 + do + word1 = extract_word(segment_str, ',', num_fields+1) + if (trim(word1) == '') exit + num_fields = num_fields + 1 + word2 = extract_word(word1, '=', 1) + fields(num_fields) = trim(word2) + enddo +end subroutine parse_segment_manifest_str + + +!> Parse an OBC_SEGMENT_%%%_DATA string +subroutine parse_segment_data_str(segment_str, idx, var, value, filename, fieldname) + character(len=*), intent(in) :: segment_str !< A string in form of + !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." + integer, intent(in) :: idx !< Index of segment_str record + character(len=*), intent(in) :: var !< The name of the variable for which parameters are needed + character(len=*), intent(out) :: filename !< The name of the input file if using "file" method + character(len=*), intent(out) :: fieldname !< The name of the variable in the input file if using + !! "file" method + real, optional, intent(out) :: value !< A constant value if using the "value" method in various + !! units but without the internal rescaling [various units] + + ! Local variables + character(len=128) :: word1, word2, word3, method + integer :: lword + + ! Process first word which will start with the fieldname + word3 = extract_word(segment_str, ',', idx) + word1 = extract_word(word3, ':', 1) + !if (trim(word1) == '') exit + word2 = extract_word(word1, '=', 1) + if (trim(word2) == trim(var)) then + method = trim(extract_word(word1, '=', 2)) + lword = len_trim(method) + if (method(lword-3:lword) == 'file') then + ! raise an error id filename/fieldname not in argument list + word1 = extract_word(word3, ':', 2) + filename = extract_word(word1, '(', 1) + fieldname = extract_word(word1, '(', 2) + lword = len_trim(fieldname) + fieldname = fieldname(1:lword-1) ! remove trailing parenth + value = -999. + elseif (method(lword-4:lword) == 'value') then + filename = 'none' + fieldname = 'none' + word1 = extract_word(word3, ':', 2) + lword = len_trim(word1) + read(word1(1:lword), *, end=986, err=987) value + endif + endif + + return +986 call MOM_error(FATAL,'End of record while parsing segment data specification! '//trim(segment_str)) +987 call MOM_error(FATAL,'Error while parsing segment data specification! '//trim(segment_str)) +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) + 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 + + ! Local variables + integer :: n,m,num_fields,na + character(len=1024) :: segstr + character(len=256) :: filename + character(len=20) :: segnam, suffix + character(len=32) :: fieldname + real :: value ! A value that is parsed from the segment data string [various units] + character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n + write(suffix,"('_segment_',i3.3)") n + ! Clear out any old values + segstr = '' + call get_param(PF, mdl, segnam, segstr) + if (segstr == '') cycle + + call parse_segment_manifest_str(trim(segstr), num_fields, fields) + if (num_fields == 0) cycle + + ! At this point, just search for TEMP and SALT as tracers 1 and 2. + do m=1,num_fields + call parse_segment_data_str(trim(segstr), m, trim(fields(m)), value, filename, fieldname) + if (trim(filename) /= 'none') then + if (fields(m) == 'TEMP') then + if (segment%is_E_or_W_2) then + OBC%tracer_x_reservoirs_used(1) = .true. + else + OBC%tracer_y_reservoirs_used(1) = .true. + endif + endif + if (fields(m) == 'SALT') then + if (segment%is_E_or_W_2) then + OBC%tracer_x_reservoirs_used(2) = .true. + else + OBC%tracer_y_reservoirs_used(2) = .true. + endif + endif + endif + enddo + ! Alternately, set first two to true if use_temperature is true + if (use_temperature) then + if (segment%is_E_or_W_2) then + OBC%tracer_x_reservoirs_used(1) = .true. + OBC%tracer_x_reservoirs_used(2) = .true. + else + OBC%tracer_y_reservoirs_used(1) = .true. + OBC%tracer_y_reservoirs_used(2) = .true. + endif + endif + !Add reservoirs for external/obgc tracers + !There is a diconnect in the above logic between tracer index and reservoir index. + !It arbitarily assigns reservoir indexes 1&2 to tracers T&S, + !So we need to start from reservoir index for non-native tracers from 3, hence na=2 below. + !num_fields is the number of vars in segstr (6 of them now, U,V,SSH,TEMP,SALT,dye) + !but OBC%tracer_x_reservoirs_used is allocated to size Reg%ntr, which is the total number of tracers + na=2 !number of native MOM6 tracers (T&S) with reservoirs + do m=1,OBC%num_obgc_tracers + !This logic assumes all external tarcers need a reservoir + !The segments for tracers are not initialized yet (that happens later in initialize_segment_data()) + !so we cannot query to determine if this tracer needs a reservoir. + if (segment%is_E_or_W_2) then + OBC%tracer_x_reservoirs_used(m+na) = .true. + else + OBC%tracer_y_reservoirs_used(m+na) = .true. + endif + enddo + enddo + + return + +end subroutine parse_for_tracer_reservoirs + +!> Initialize open boundary control structure and do any necessary rescaling of OBC +!! fields that have been read from a restart file. +subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handle + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(MOM_restart_CS), intent(in) :: restart_CS !< Restart structure, data intent(inout) + + ! Local variables + integer :: i, j, k, isd, ied, jsd, jed, nz, m + integer :: IsdB, IedB, JsdB, JedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(OBC)) return + + id_clock_pass = cpu_clock_id('(Ocean OBC halo updates)', grain=CLOCK_ROUTINE) + if (OBC%radiation_BCs_exist_globally) call pass_vector(OBC%rx_normal, OBC%ry_normal, G%Domain, & + To_All+Scalar_Pair) + if (OBC%oblique_BCs_exist_globally) then +! call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + call do_group_pass(OBC%pass_oblique, G%Domain) + endif + if (allocated(OBC%tres_x) .and. allocated(OBC%tres_y)) then + do m=1,OBC%ntr + call pass_vector(OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%Domain, To_All+Scalar_Pair) + enddo + elseif (allocated(OBC%tres_x)) then + do m=1,OBC%ntr + call pass_var(OBC%tres_x(:,:,:,m), G%Domain, position=EAST_FACE) + enddo + elseif (allocated(OBC%tres_y)) then + do m=1,OBC%ntr + call pass_var(OBC%tres_y(:,:,:,m), G%Domain, position=NORTH_FACE) + enddo + endif + +end subroutine open_boundary_init + +logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, apply_Flather_OBC, & + apply_nudged_OBC, needs_ext_seg_data) + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + logical, optional, intent(in) :: apply_open_OBC !< Returns True if open_*_BCs_exist_globally is true + logical, optional, intent(in) :: apply_specified_OBC !< Returns True if specified_*_BCs_exist_globally is true + logical, optional, intent(in) :: apply_Flather_OBC !< Returns True if Flather_*_BCs_exist_globally is true + logical, optional, intent(in) :: apply_nudged_OBC !< Returns True if nudged_*_BCs_exist_globally is true + logical, optional, intent(in) :: needs_ext_seg_data !< Returns True if external segment data needed + open_boundary_query = .false. + if (.not. associated(OBC)) return + if (present(apply_open_OBC)) open_boundary_query = OBC%open_u_BCs_exist_globally .or. & + OBC%open_v_BCs_exist_globally + if (present(apply_specified_OBC)) open_boundary_query = OBC%specified_u_BCs_exist_globally .or. & + OBC%specified_v_BCs_exist_globally + if (present(apply_Flather_OBC)) open_boundary_query = OBC%Flather_u_BCs_exist_globally .or. & + OBC%Flather_v_BCs_exist_globally + if (present(apply_nudged_OBC)) open_boundary_query = OBC%nudged_u_BCs_exist_globally .or. & + OBC%nudged_v_BCs_exist_globally + if (present(needs_ext_seg_data)) open_boundary_query = OBC%any_needs_IO_for_data + +end function open_boundary_query + +!> Deallocate open boundary data +subroutine open_boundary_dealloc(OBC) + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(OBC_segment_type), pointer :: segment => NULL() + integer :: n + + if (.not. associated(OBC)) return + + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + call deallocate_OBC_segment_data(segment) + enddo + if (allocated(OBC%segment)) deallocate(OBC%segment) + if (allocated(OBC%segnum_u)) deallocate(OBC%segnum_u) + if (allocated(OBC%segnum_v)) deallocate(OBC%segnum_v) + if (allocated(OBC%rx_normal)) deallocate(OBC%rx_normal) + if (allocated(OBC%ry_normal)) deallocate(OBC%ry_normal) + if (allocated(OBC%rx_oblique_u)) deallocate(OBC%rx_oblique_u) + if (allocated(OBC%ry_oblique_u)) deallocate(OBC%ry_oblique_u) + if (allocated(OBC%rx_oblique_v)) deallocate(OBC%rx_oblique_v) + if (allocated(OBC%ry_oblique_v)) deallocate(OBC%ry_oblique_v) + if (allocated(OBC%cff_normal_u)) deallocate(OBC%cff_normal_u) + if (allocated(OBC%cff_normal_v)) deallocate(OBC%cff_normal_v) + if (allocated(OBC%tres_x)) deallocate(OBC%tres_x) + if (allocated(OBC%tres_y)) deallocate(OBC%tres_y) + deallocate(OBC) +end subroutine open_boundary_dealloc + +!> Close open boundary data +subroutine open_boundary_end(OBC) + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + call open_boundary_dealloc(OBC) +end subroutine open_boundary_end + +!> Sets the slope of bathymetry normal to an open boundary to zero. +subroutine open_boundary_impose_normal_slope(OBC, G, depth) + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: depth !< Bathymetry at h-points, in [Z ~> m] or other units + ! Local variables + integer :: i, j, n + type(OBC_segment_type), pointer :: segment => NULL() + + if (.not.associated(OBC)) return + + if (.not.(OBC%specified_u_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally .or. & + OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally)) & + return + + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%direction == OBC_DIRECTION_E) then + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + depth(i+1,j) = depth(i,j) + enddo + elseif (segment%direction == OBC_DIRECTION_W) then + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + depth(i,j) = depth(i+1,j) + enddo + elseif (segment%direction == OBC_DIRECTION_N) then + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + depth(i,j+1) = depth(i,j) + enddo + elseif (segment%direction == OBC_DIRECTION_S) then + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + depth(i,j) = depth(i,j+1) + enddo + endif + enddo + +end subroutine open_boundary_impose_normal_slope + +!> Reconcile masks and open boundaries, deallocate OBC on PEs where it is not needed. +!! Also adjust u- and v-point cell area on specified open boundaries and mask all +!! points outside open boundaries. +subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: areaCu !< Area of a u-cell [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: areaCv !< Area of a u-cell [L2 ~> m2] + ! Local variables + integer :: i, j, n + type(OBC_segment_type), pointer :: segment => NULL() + logical :: any_U, any_V + + if (.not.associated(OBC)) return + + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%is_E_or_W) then + ! Sweep along u-segments and delete the OBC for blocked points. + ! Also, mask all points outside. + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + if (G%mask2dCu(I,j) == 0) OBC%segnum_u(I,j) = OBC_NONE + if (segment%direction == OBC_DIRECTION_W) then + G%mask2dT(i,j) = 0.0 + else + G%mask2dT(i+1,j) = 0.0 + endif + enddo + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + if (segment%direction == OBC_DIRECTION_W) then + G%mask2dCv(i,J) = 0 ; G%OBCmaskCv(i,J) = 0.0 + else + G%mask2dCv(i+1,J) = 0.0 ; G%OBCmaskCv(i+1,J) = 0.0 + endif + enddo + else + ! Sweep along v-segments and delete the OBC for blocked points. + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + if (G%mask2dCv(i,J) == 0) OBC%segnum_v(i,J) = OBC_NONE + if (segment%direction == OBC_DIRECTION_S) then + G%mask2dT(i,j) = 0.0 + else + G%mask2dT(i,j+1) = 0.0 + endif + enddo + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + if (segment%direction == OBC_DIRECTION_S) then + G%mask2dCu(I,j) = 0.0 ; G%OBCmaskCu(I,j) = 0.0 + else + G%mask2dCu(I,j+1) = 0.0 ; G%OBCmaskCu(I,j+1) = 0.0 + endif + enddo + endif + enddo + + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. (segment%on_pe .and. segment%open)) cycle + ! Set the OBCmask values to help eliminate certain terms at u- or v- OBC points. + if (segment%is_E_or_W) then + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + G%OBCmaskCu(I,j) = 0.0 + enddo + else + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + G%OBCmaskCv(i,J) = 0.0 + enddo + endif + enddo + + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%on_pe .or. .not. segment%specified) cycle + if (segment%is_E_or_W) then + ! Sweep along u-segments and for %specified BC points reset the u-point area which was masked out + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + if (segment%direction == OBC_DIRECTION_E) then + areaCu(I,j) = G%areaT(i,j) ! Both of these are in [L2 ~> m2] + else ! West + areaCu(I,j) = G%areaT(i+1,j) ! Both of these are in [L2 ~> m2] + endif + enddo + else + ! Sweep along v-segments and for %specified BC points reset the v-point area which was masked out + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + if (segment%direction == OBC_DIRECTION_S) then + areaCv(i,J) = G%areaT(i,j+1) ! Both of these are in [L2 ~> m2] + else ! North + areaCv(i,J) = G%areaT(i,j) ! Both of these are in [L2 ~> m2] + endif + enddo + endif + enddo + + ! G%mask2du will be open wherever bathymetry allows it. + ! Bathymetry outside of the open boundary was adjusted to match + ! the bathymetry inside so these points will be open unless the + ! bathymetry inside the boundary was too shallow and flagged as land. + any_U = .false. + any_V = .false. + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%is_E_or_W) then + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + if (OBC%segnum_u(I,j) /= OBC_NONE) any_U = .true. + enddo + else + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + if (OBC%segnum_v(i,J) /= OBC_NONE) any_V = .true. + enddo + endif + enddo + + OBC%OBC_pe = .true. + if (.not.(any_U .or. any_V)) OBC%OBC_pe = .false. + +end subroutine open_boundary_impose_land_mask + +!> Make sure the OBC tracer reservoirs are initialized. +subroutine setup_OBC_tracer_reservoirs(G, GV, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure + + type(OBC_segment_type), pointer :: segment => NULL() + real :: I_scale ! The inverse of the scaling factor for the tracers. + ! For salinity the units would be [ppt S-1 ~> 1] + integer :: i, j, k, m, n + + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (associated(segment%tr_Reg)) then + if (segment%is_E_or_W) then + I = segment%HI%IsdB + do m=1,OBC%ntr + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + do k=1,GV%ke + do j=segment%HI%jsd,segment%HI%jed + OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%t(i,j,k) + enddo + enddo + endif + enddo + else + J = segment%HI%JsdB + do m=1,OBC%ntr + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + do k=1,GV%ke + do i=segment%HI%isd,segment%HI%ied + OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%t(i,J,k) + enddo + enddo + endif + enddo + endif + endif + enddo + +end subroutine setup_OBC_tracer_reservoirs + +!> Apply radiation conditions to 3D u,v at open boundaries +subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dt) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u_new !< On exit, new u values on open boundaries + !! On entry, the old time-level v but including + !! barotropic accelerations [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_old !< Original unadjusted u [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v_new !< On exit, new v values on open boundaries. + !! On entry, the old time-level v but including + !! barotropic accelerations [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_old !< Original unadjusted v [L T-1 ~> m s-1] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: dt !< Appropriate timestep [T ~> s] + ! Local variables + real :: dhdt, dhdx, dhdy ! One-point differences in time or space [L T-1 ~> m s-1] + real :: gamma_u, gamma_2 ! Fractional weightings of new values [nondim] + real :: tau ! A local nudging timescale [T ~> s] + real :: rx_max, ry_max ! coefficients for radiation [nondim] + real :: rx_new, rx_avg ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2] + real :: ry_new, ry_avg ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2] + real :: cff_new, cff_avg ! denominator in oblique [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: & + rx_tang_rad, & ! The phase speed at u-points for tangential oblique OBCs + ! in units of grid points per timestep [nondim], + ! discretized at the corner (PV) points. + ry_tang_rad, & ! The phase speed at v-points for tangential oblique OBCs + ! in units of grid points per timestep [nondim], + ! discretized at the corner (PV) points. + rx_tang_obl, & ! The x-coefficient for tangential oblique OBCs [L2 T-2 ~> m2 s-2], + ! discretized at the corner (PV) points. + ry_tang_obl, & ! The y-coefficient for tangential oblique OBCs [L2 T-2 ~> m2 s-2], + ! discretized at the corner (PV) points. + cff_tangential ! The denominator for tangential oblique OBCs [L2 T-2 ~> m2 s-2], + ! discretized at the corner (PV) points. + real :: eps ! A small velocity squared [L2 T-2 ~> m2 s-2] + type(OBC_segment_type), pointer :: segment => NULL() + integer :: i, j, k, is, ie, js, je, m, nz, n + integer :: is_obc, ie_obc, js_obc, je_obc + logical :: sym + character(len=3) :: var_num + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(OBC)) return + + if (.not.(OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally)) & + return + + eps = 1.0e-20*US%m_s_to_L_T**2 + + !! Copy previously calculated phase velocity from global arrays into segments + !! This is terribly inefficient and temporary solution for continuity across restarts + !! and needs to be revisited in the future. + if (OBC%gamma_uv < 1.0) then + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%is_E_or_W .and. segment%radiation) then + do k=1,GV%ke + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + segment%rx_norm_rad(I,j,k) = OBC%rx_normal(I,j,k) + enddo + enddo + elseif (segment%is_N_or_S .and. segment%radiation) then + do k=1,GV%ke + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + segment%ry_norm_rad(i,J,k) = OBC%ry_normal(i,J,k) + enddo + enddo + endif + if (segment%is_E_or_W .and. segment%oblique) then + do k=1,GV%ke + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + segment%rx_norm_obl(I,j,k) = OBC%rx_oblique_u(I,j,k) + segment%ry_norm_obl(I,j,k) = OBC%ry_oblique_u(I,j,k) + segment%cff_normal(I,j,k) = OBC%cff_normal_u(I,j,k) + enddo + enddo + elseif (segment%is_N_or_S .and. segment%oblique) then + do k=1,GV%ke + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + segment%rx_norm_obl(i,J,k) = OBC%rx_oblique_v(i,J,k) + segment%ry_norm_obl(i,J,k) = OBC%ry_oblique_v(i,J,k) + segment%cff_normal(i,J,k) = OBC%cff_normal_v(i,J,k) + enddo + enddo + endif + enddo + endif + + ! Now tracers (if any) + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (associated(segment%tr_Reg)) then + if (segment%is_E_or_W) then + I = segment%HI%IsdB + do m=1,OBC%ntr + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + do k=1,GV%ke + do j=segment%HI%jsd,segment%HI%jed + segment%tr_Reg%Tr(m)%tres(I,j,k) = segment%tr_Reg%Tr(m)%scale * OBC%tres_x(I,j,k,m) + enddo + enddo + endif + enddo + else + J = segment%HI%JsdB + do m=1,OBC%ntr + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + do k=1,GV%ke + do i=segment%HI%isd,segment%HI%ied + segment%tr_Reg%Tr(m)%tres(i,J,k) = segment%tr_Reg%Tr(m)%scale * OBC%tres_y(i,J,k,m) + enddo + enddo + endif + enddo + endif + endif + enddo + + gamma_u = OBC%gamma_uv + rx_max = OBC%rx_max ; ry_max = OBC%rx_max + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%oblique) call gradient_at_q_points(G, GV, segment, u_new(:,:,:), v_new(:,:,:)) + if (segment%direction == OBC_DIRECTION_E) then + I=segment%HI%IsdB + if (I 0.0) rx_new = min( (dhdt/dhdx), rx_max) ! outward phase speed + if (gamma_u < 1.0) then + rx_avg = (1.0-gamma_u)*segment%rx_norm_rad(I,j,k) + gamma_u*rx_new + else + rx_avg = rx_new + endif + segment%rx_norm_rad(I,j,k) = rx_avg + ! The new boundary value is interpolated between future interior + ! value, u_new(I-1) and past boundary value but with barotropic + ! accelerations, u_new(I). + segment%normal_vel(I,j,k) = (u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) / (1.0+rx_avg) + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + if (gamma_u < 1.0) then + OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) + endif + elseif (segment%oblique) then + dhdt = (u_old(I-1,j,k) - u_new(I-1,j,k)) !old-new + dhdx = (u_new(I-1,j,k) - u_new(I-2,j,k)) !in new time backward sashay for I-1 + if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then + dhdy = segment%grad_normal(J-1,1,k) + elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_normal(J,1,k) + endif + if (dhdt*dhdx < 0.0) dhdt = 0.0 + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(dhdt*dhdx, cff_new*rx_max) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) + if (gamma_u < 1.0) then + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(I,j,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new + else + rx_avg = rx_new + ry_avg = ry_new + cff_avg = cff_new + endif + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(I,j,k) = ry_avg + segment%cff_normal(I,j,k) = cff_avg + segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) - & + (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & + min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & + (cff_avg + rx_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary + ! implementation as a work-around to limitations in restart capability + OBC%rx_oblique_u(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique_u(I,j,k) = segment%ry_norm_obl(I,j,k) + OBC%cff_normal_u(I,j,k) = segment%cff_normal(I,j,k) + endif + elseif (segment%gradient) then + segment%normal_vel(I,j,k) = u_new(I-1,j,k) + endif + if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then + ! dhdt gets set to 0 on inflow in oblique case + if (dhdt*dhdx <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%normal_vel(I,j,k) = (1.0 - gamma_2) * segment%normal_vel(I,j,k) + & + gamma_2 * segment%nudged_normal_vel(I,j,k) + endif + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + I=segment%HI%IsdB + allocate(rx_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + rx_tang_rad(I,segment%HI%JsdB,k) = segment%rx_norm_rad(I,segment%HI%jsd,k) + rx_tang_rad(I,segment%HI%JedB,k) = segment%rx_norm_rad(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tang_rad(I,J,k) = 0.5*(segment%rx_norm_rad(I,j,k) + segment%rx_norm_rad(I,j+1,k)) + enddo + else + do J=segment%HI%JsdB,segment%HI%JedB + dhdt = v_old(i,J,k)-v_new(i,J,k) !old-new + dhdx = v_new(i,J,k)-v_new(i-1,J,k) !in new time backward sashay for I-1 + rx_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdx > 0.0) rx_tang_rad(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed + enddo + endif + enddo + if (segment%radiation_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tang_rad(I,J,k) + segment%tangential_vel(I,J,k) = (v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=Js_obc,Je_obc + rx_avg = rx_tang_rad(I,J,k) +! if (G%mask2dCu(I-1,j) > 0.0 .and. G%mask2dCu(I-1,j+1) > 0.0) then +! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k)) * dt * G%IdxBu(I-1,J) +! elseif (G%mask2dCu(I-1,j) > 0.0) then +! rx_avg = u_new(I-1,j,k) * dt * G%IdxBu(I-1,J) +! elseif (G%mask2dCu(I-1,j+1) > 0.0) then +! rx_avg = u_new(I-1,j+1,k) * dt * G%IdxBu(I-1,J) +! else +! rx_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & + rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tang_rad) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + I=segment%HI%IsdB + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + rx_tang_obl(I,segment%HI%JsdB,k) = segment%rx_norm_obl(I,segment%HI%jsd,k) + rx_tang_obl(I,segment%HI%JedB,k) = segment%rx_norm_obl(I,segment%HI%jed,k) + ry_tang_obl(I,segment%HI%JsdB,k) = segment%ry_norm_obl(I,segment%HI%jsd,k) + ry_tang_obl(I,segment%HI%JedB,k) = segment%ry_norm_obl(I,segment%HI%jed,k) + cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) + cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(I,j,k) + segment%rx_norm_obl(I,j+1,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(I,j,k) + segment%ry_norm_obl(I,j+1,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) + enddo + else + do J=segment%HI%JsdB,segment%HI%JedB + dhdt = v_old(i,J,k)-v_new(i,J,k) !old-new + dhdx = v_new(i,J,k)-v_new(i-1,J,k) !in new time backward sashay for I-1 + if (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) > 0.0) then + dhdy = segment%grad_tan(j,1,k) + elseif (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_tan(j+1,1,k) + endif + if (dhdt*dhdx < 0.0) dhdt = 0.0 + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(dhdt*dhdx, cff_new*rx_max) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) + rx_tang_obl(I,J,k) = rx_new + ry_tang_obl(I,J,k) = ry_new + cff_tangential(I,J,k) = cff_new + enddo + endif + enddo + if (segment%oblique_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) - & + (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + & + min(ry_avg,0.0)*segment%grad_tan(j+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = & + ((cff_avg*(v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & + rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) - & + (max(ry_avg,0.0)*segment%grad_gradient(J,2,k) + & + min(ry_avg,0.0)*segment%grad_gradient(J+1,2,k)) ) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) + deallocate(cff_tangential) + endif + endif + + if (segment%direction == OBC_DIRECTION_W) then + I=segment%HI%IsdB + if (I>G%HI%IecB) cycle + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + if (segment%radiation) then + dhdt = (u_old(I+1,j,k) - u_new(I+1,j,k)) !old-new + dhdx = (u_new(I+1,j,k) - u_new(I+2,j,k)) !in new time forward sashay for I+1 + rx_new = 0.0 + if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) + if (gamma_u < 1.0) then + rx_avg = (1.0-gamma_u)*segment%rx_norm_rad(I,j,k) + gamma_u*rx_new + else + rx_avg = rx_new + endif + segment%rx_norm_rad(I,j,k) = rx_avg + ! The new boundary value is interpolated between future interior + ! value, u_new(I+1) and past boundary value but with barotropic + ! accelerations, u_new(I). + segment%normal_vel(I,j,k) = (u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) / (1.0+rx_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) + endif + elseif (segment%oblique) then + dhdt = (u_old(I+1,j,k) - u_new(I+1,j,k)) !old-new + dhdx = (u_new(I+1,j,k) - u_new(I+2,j,k)) !in new time forward sashay for I+1 + if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then + dhdy = segment%grad_normal(J-1,1,k) + elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_normal(J,1,k) + endif + if (dhdt*dhdx < 0.0) dhdt = 0.0 + + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(dhdt*dhdx, cff_new*rx_max) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) + if (gamma_u < 1.0) then + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(I,j,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new + else + rx_avg = rx_new + ry_avg = ry_new + cff_avg = cff_new + endif + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(I,j,k) = ry_avg + segment%cff_normal(I,j,k) = cff_avg + segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) - & + (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & + min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & + (cff_avg + rx_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_oblique_u(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique_u(I,j,k) = segment%ry_norm_obl(I,j,k) + OBC%cff_normal_u(I,j,k) = segment%cff_normal(I,j,k) + endif + elseif (segment%gradient) then + segment%normal_vel(I,j,k) = u_new(I+1,j,k) + endif + if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then + ! dhdt gets set to 0. on inflow in oblique case + if (dhdt*dhdx <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%normal_vel(I,j,k) = (1.0 - gamma_2) * segment%normal_vel(I,j,k) + & + gamma_2 * segment%nudged_normal_vel(I,j,k) + endif + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + I=segment%HI%IsdB + allocate(rx_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + rx_tang_rad(I,segment%HI%JsdB,k) = segment%rx_norm_rad(I,segment%HI%jsd,k) + rx_tang_rad(I,segment%HI%JedB,k) = segment%rx_norm_rad(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tang_rad(I,J,k) = 0.5*(segment%rx_norm_rad(I,j,k) + segment%rx_norm_rad(I,j+1,k)) + enddo + else + do J=segment%HI%JsdB,segment%HI%JedB + dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new + dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sashay for I-1 + rx_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdx > 0.0) rx_tang_rad(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed + enddo + endif + enddo + if (segment%radiation_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tang_rad(I,J,k) + segment%tangential_vel(I,J,k) = (v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=Js_obc,Je_obc + rx_avg = rx_tang_rad(I,J,k) +! if (G%mask2dCu(I+1,j) > 0.0 .and. G%mask2dCu(I+1,j+1) > 0.0) then +! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k)) * dt * G%IdxBu(I+1,J) +! elseif (G%mask2dCu(I+1,j) > 0.0) then +! rx_avg = u_new(I+1,j,k) * dt * G%IdxBu(I+1,J) +! elseif (G%mask2dCu(I+1,j+1) > 0.0) then +! rx_avg = u_new(I+1,j+1,k) * dt * G%IdxBu(I+1,J) +! else +! rx_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & + rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tang_rad) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + I=segment%HI%IsdB + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + rx_tang_obl(I,segment%HI%JsdB,k) = segment%rx_norm_obl(I,segment%HI%jsd,k) + rx_tang_obl(I,segment%HI%JedB,k) = segment%rx_norm_obl(I,segment%HI%jed,k) + ry_tang_obl(I,segment%HI%JsdB,k) = segment%ry_norm_obl(I,segment%HI%jsd,k) + ry_tang_obl(I,segment%HI%JedB,k) = segment%ry_norm_obl(I,segment%HI%jed,k) + cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) + cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(I,j,k) + segment%rx_norm_obl(I,j+1,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(I,j,k) + segment%ry_norm_obl(I,j+1,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) + enddo + else + do J=segment%HI%JsdB,segment%HI%JedB + dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new + dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sashay for I-1 + if (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) > 0.0) then + dhdy = segment%grad_tan(j,1,k) + elseif (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_tan(j+1,1,k) + endif + if (dhdt*dhdx < 0.0) dhdt = 0.0 + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(dhdt*dhdx, cff_new*rx_max) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) + rx_tang_obl(I,J,k) = rx_new + ry_tang_obl(I,J,k) = ry_new + cff_tangential(I,J,k) = cff_new + enddo + endif + enddo + if (segment%oblique_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) - & + (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + & + min(ry_avg,0.0)*segment%grad_tan(j+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = & + ((cff_avg*(v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & + rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) - & + (max(ry_avg,0.0)*segment%grad_gradient(J,2,k) + & + min(ry_avg,0.0)*segment%grad_gradient(J+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) + deallocate(cff_tangential) + endif + endif + + if (segment%direction == OBC_DIRECTION_N) then + J=segment%HI%JsdB + if (J 0.0) ry_new = min( (dhdt/dhdy), ry_max) + if (gamma_u < 1.0) then + ry_avg = (1.0-gamma_u)*segment%ry_norm_rad(I,j,k) + gamma_u*ry_new + else + ry_avg = ry_new + endif + segment%ry_norm_rad(i,J,k) = ry_avg + ! The new boundary value is interpolated between future interior + ! value, v_new(J-1) and past boundary value but with barotropic + ! accelerations, v_new(J). + segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) / (1.0+ry_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) + endif + elseif (segment%oblique) then + dhdt = (v_old(i,J-1,k) - v_new(i,J-1,k)) !old-new + dhdy = (v_new(i,J-1,k) - v_new(i,J-2,k)) !in new time backward sashay for J-1 + if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then + dhdx = segment%grad_normal(I-1,1,k) + elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then + dhdx = 0.0 + else + dhdx = segment%grad_normal(I,1,k) + endif + if (dhdt*dhdy < 0.0) dhdt = 0.0 + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(dhdt*dhdy, cff_new*ry_max) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) + if (gamma_u < 1.0) then + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + else + rx_avg = rx_new + ry_avg = ry_new + cff_avg = cff_new + endif + segment%rx_norm_obl(i,J,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) - & + (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) +& + min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & + (cff_avg + ry_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_oblique_v(i,J,k) = segment%rx_norm_obl(i,J,k) + OBC%ry_oblique_v(i,J,k) = segment%ry_norm_obl(i,J,k) + OBC%cff_normal_v(i,J,k) = segment%cff_normal(i,J,k) + endif + elseif (segment%gradient) then + segment%normal_vel(i,J,k) = v_new(i,J-1,k) + endif + if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then + ! dhdt gets set to 0 on inflow in oblique case + if (dhdt*dhdy <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%normal_vel(i,J,k) = (1.0 - gamma_2) * segment%normal_vel(i,J,k) + & + gamma_2 * segment%nudged_normal_vel(i,J,k) + endif + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + J=segment%HI%JsdB + allocate(ry_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + ry_tang_rad(segment%HI%IsdB,J,k) = segment%ry_norm_rad(segment%HI%isd,J,k) + ry_tang_rad(segment%HI%IedB,J,k) = segment%ry_norm_rad(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + ry_tang_rad(I,J,k) = 0.5*(segment%ry_norm_rad(i,J,k) + segment%ry_norm_rad(i+1,J,k)) + enddo + else + do I=segment%HI%IsdB,segment%HI%IedB + dhdt = u_old(I,j-1,k)-u_new(I,j-1,k) !old-new + dhdy = u_new(I,j-1,k)-u_new(I,j-2,k) !in new time backward sashay for I-1 + ry_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdy > 0.0) ry_tang_rad(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed + enddo + endif + enddo + if (segment%radiation_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ry_avg = ry_tang_rad(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j,k) + ry_avg*u_new(I,j-1,k)) / (1.0+ry_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=Is_obc,Ie_obc + ry_avg = ry_tang_rad(I,J,k) +! if (G%mask2dCv(i,J-1) > 0.0 .and. G%mask2dCv(i+1,J-1) > 0.0) then +! ry_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k) * dt * G%IdyBu(I,J-1)) +! elseif (G%mask2dCv(i,J-1) > 0.0) then +! ry_avg = v_new(i,J-1,k) * dt *G%IdyBu(I,J-1) +! elseif (G%mask2dCv(i+1,J-1) > 0.0) then +! ry_avg = v_new(i+1,J-1,k) * dt *G%IdyBu(I,J-1) +! else +! ry_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & + ry_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) / (1.0+ry_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(ry_tang_rad) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + J=segment%HI%JsdB + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + rx_tang_obl(segment%HI%IsdB,J,k) = segment%rx_norm_obl(segment%HI%isd,J,k) + rx_tang_obl(segment%HI%IedB,J,k) = segment%rx_norm_obl(segment%HI%ied,J,k) + ry_tang_obl(segment%HI%IsdB,J,k) = segment%ry_norm_obl(segment%HI%isd,J,k) + ry_tang_obl(segment%HI%IedB,J,k) = segment%ry_norm_obl(segment%HI%ied,J,k) + cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) + cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(i,J,k) + segment%rx_norm_obl(i+1,J,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(i,J,k) + segment%ry_norm_obl(i+1,J,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) + enddo + else + do I=segment%HI%IsdB,segment%HI%IedB + dhdt = u_old(I,j,k)-u_new(I,j,k) !old-new + dhdy = u_new(I,j,k)-u_new(I,j-1,k) !in new time backward sashay for I-1 + if (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) > 0.0) then + dhdx = segment%grad_tan(i,1,k) + elseif (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) == 0.0) then + dhdx = 0.0 + else + dhdx = segment%grad_tan(i+1,1,k) + endif + if (dhdt*dhdy < 0.0) dhdt = 0.0 + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(dhdt*dhdy, cff_new*ry_max) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) + rx_tang_obl(I,J,k) = rx_new + ry_tang_obl(I,J,k) = ry_new + cff_tangential(I,J,k) = cff_new + enddo + endif + enddo + if (segment%oblique_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j,k) + ry_avg*u_new(I,j-1,k)) - & + (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + & + min(rx_avg,0.0)*segment%grad_tan(i+1,2,k))) / & + (cff_avg + ry_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = & + ((cff_avg*(u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & + ry_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) - & + (max(rx_avg,0.0)*segment%grad_gradient(I,2,k) + & + min(rx_avg,0.0)*segment%grad_gradient(I+1,2,k))) / & + (cff_avg + ry_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) + deallocate(cff_tangential) + endif + endif + + if (segment%direction == OBC_DIRECTION_S) then + J=segment%HI%JsdB + if (J>G%HI%JecB) cycle + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + if (segment%radiation) then + dhdt = (v_old(i,J+1,k) - v_new(i,J+1,k)) !old-new + dhdy = (v_new(i,J+1,k) - v_new(i,J+2,k)) !in new time backward sashay for J-1 + ry_new = 0.0 + if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) + if (gamma_u < 1.0) then + ry_avg = (1.0-gamma_u)*segment%ry_norm_rad(I,j,k) + gamma_u*ry_new + else + ry_avg = ry_new + endif + segment%ry_norm_rad(i,J,k) = ry_avg + ! The new boundary value is interpolated between future interior + ! value, v_new(J+1) and past boundary value but with barotropic + ! accelerations, v_new(J). + segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) / (1.0+ry_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) + endif + elseif (segment%oblique) then + dhdt = (v_old(i,J+1,k) - v_new(i,J+1,k)) !old-new + dhdy = (v_new(i,J+1,k) - v_new(i,J+2,k)) !in new time backward sashay for J-1 + if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then + dhdx = segment%grad_normal(I-1,1,k) + elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then + dhdx = 0.0 + else + dhdx = segment%grad_normal(I,1,k) + endif + if (dhdt*dhdy < 0.0) dhdt = 0.0 + + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(dhdt*dhdy, cff_new*ry_max) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) + if (gamma_u < 1.0) then + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(i,J,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + else + rx_avg = rx_new + ry_avg = ry_new + cff_avg = cff_new + endif + segment%rx_norm_obl(i,J,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) - & + (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + & + min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & + (cff_avg + ry_avg) + if (gamma_u < 1.0) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_oblique_v(i,J,k) = segment%rx_norm_obl(i,J,k) + OBC%ry_oblique_v(i,J,k) = segment%ry_norm_obl(i,J,k) + OBC%cff_normal_v(i,J,k) = segment%cff_normal(i,J,k) + endif + elseif (segment%gradient) then + segment%normal_vel(i,J,k) = v_new(i,J+1,k) + endif + if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then + ! dhdt gets set to 0 on inflow in oblique case + if (dhdt*dhdy <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%normal_vel(i,J,k) = (1.0 - gamma_2) * segment%normal_vel(i,J,k) + & + gamma_2 * segment%nudged_normal_vel(i,J,k) + endif + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + J=segment%HI%JsdB + allocate(ry_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + ry_tang_rad(segment%HI%IsdB,J,k) = segment%ry_norm_rad(segment%HI%isd,J,k) + ry_tang_rad(segment%HI%IedB,J,k) = segment%ry_norm_rad(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + ry_tang_rad(I,J,k) = 0.5*(segment%ry_norm_rad(i,J,k) + segment%ry_norm_rad(i+1,J,k)) + enddo + else + do I=segment%HI%IsdB,segment%HI%IedB + dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new + dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sashay for I-1 + ry_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdy > 0.0) ry_tang_rad(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed + enddo + endif + enddo + if (segment%radiation_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ry_avg = ry_tang_rad(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j+1,k) + ry_avg*u_new(I,j+2,k)) / (1.0+ry_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=Is_obc,Ie_obc + ry_avg = ry_tang_rad(I,J,k) +! if (G%mask2dCv(i,J+1) > 0.0 .and. G%mask2dCv(i+1,J+1) > 0.0) then +! ry_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k)) * dt * G%IdyBu(I,J+1) +! elseif (G%mask2dCv(i,J+1) > 0.0) then +! ry_avg = v_new(i,J+1,k) * dt * G%IdyBu(I,J+1) +! elseif (G%mask2dCv(i+1,J+1) > 0.0) then +! ry_avg = v_new(i+1,J+1,k) * dt * G%IdyBu(I,J+1) +! else +! ry_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & + ry_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) / (1.0+ry_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_rad(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(ry_tang_rad) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + J=segment%HI%JsdB + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + if (gamma_u < 1.0) then + rx_tang_obl(segment%HI%IsdB,J,k) = segment%rx_norm_obl(segment%HI%isd,J,k) + rx_tang_obl(segment%HI%IedB,J,k) = segment%rx_norm_obl(segment%HI%ied,J,k) + ry_tang_obl(segment%HI%IsdB,J,k) = segment%ry_norm_obl(segment%HI%isd,J,k) + ry_tang_obl(segment%HI%IedB,J,k) = segment%ry_norm_obl(segment%HI%ied,J,k) + cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) + cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(i,J,k) + segment%rx_norm_obl(i+1,J,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(i,J,k) + segment%ry_norm_obl(i+1,J,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) + enddo + else + do I=segment%HI%IsdB,segment%HI%IedB + dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new + dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sashay for I-1 + if (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) > 0.0) then + dhdx = segment%grad_tan(i,1,k) + elseif (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) == 0.0) then + dhdx = 0.0 + else + dhdx = segment%grad_tan(i+1,1,k) + endif + if (dhdt*dhdy < 0.0) dhdt = 0.0 + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(dhdt*dhdy, cff_new*ry_max) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) + rx_tang_obl(I,J,k) = rx_new + ry_tang_obl(I,J,k) = ry_new + cff_tangential(I,J,k) = cff_new + enddo + endif + enddo + if (segment%oblique_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j+1,k) + ry_avg*u_new(I,j+2,k)) - & + (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + & + min(rx_avg,0.0)*segment%grad_tan(i+1,2,k)) ) / & + (cff_avg + ry_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = & + ((cff_avg*(u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & + ry_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) - & + (max(rx_avg,0.0)*segment%grad_gradient(i,2,k) + & + min(rx_avg,0.0)*segment%grad_gradient(i+1,2,k))) / & + (cff_avg + ry_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tang_obl(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) + deallocate(cff_tangential) + endif + endif + enddo + + ! Actually update u_new, v_new + call open_boundary_apply_normal_flow(OBC, G, GV, u_new, v_new) + + call pass_vector(u_new, v_new, G%Domain, clock=id_clock_pass) + + if (OBC%debug) then + sym = G%Domain%symmetric + if (OBC%radiation_BCs_exist_globally) then + call uvchksum("radiation_OBCs: OBC%r[xy]_normal", OBC%rx_normal, OBC%ry_normal, G%HI, & + haloshift=0, symmetric=sym, scale=1.0) + endif + if (OBC%oblique_BCs_exist_globally) then + call uvchksum("radiation_OBCs: OBC%r[xy]_oblique_[uv]", OBC%rx_oblique_u, OBC%ry_oblique_v, G%HI, & + haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + call uvchksum("radiation_OBCs: OBC%r[yx]_oblique_[uv]", OBC%ry_oblique_u, OBC%rx_oblique_v, G%HI, & + haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + call uvchksum("radiation_OBCs: OBC%cff_normal_[uv]", OBC%cff_normal_u, OBC%cff_normal_v, G%HI, & + haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + endif + if (OBC%ntr == 0) return + if (.not. allocated (OBC%tres_x) .or. .not. allocated (OBC%tres_y)) return + do m=1,OBC%ntr + write(var_num,'(I3.3)') m + call uvchksum("radiation_OBCs: OBC%tres_[xy]_"//var_num, OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%HI, & + haloshift=0, symmetric=sym, scale=1.0) + enddo + endif + +end subroutine radiation_open_bdry_conds + +!> Applies OBC values stored in segments to 3d u,v fields +subroutine open_boundary_apply_normal_flow(OBC, G, GV, u, v) + ! Arguments + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< u field to update on open + !! boundaries [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< v field to update on open + !! boundaries [L T-1 ~> m s-1] + ! Local variables + integer :: i, j, k, n + type(OBC_segment_type), pointer :: segment => NULL() + + if (.not.associated(OBC)) return ! Bail out if OBC is not available + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) then + cycle + elseif (segment%radiation .or. segment%oblique .or. segment%gradient) then + if (segment%is_E_or_W) then + I=segment%HI%IsdB + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + u(I,j,k) = segment%normal_vel(I,j,k) + enddo ; enddo + elseif (segment%is_N_or_S) then + J=segment%HI%JsdB + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + v(i,J,k) = segment%normal_vel(i,J,k) + enddo ; enddo + endif + endif + enddo + +end subroutine open_boundary_apply_normal_flow + +!> Applies zero values to 3d u,v fields on OBC segments +subroutine open_boundary_zero_normal_flow(OBC, G, GV, u, v) + ! Arguments + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< u field to update on open boundaries [arbitrary] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< v field to update on open boundaries [arbitrary] + ! Local variables + integer :: i, j, k, n + type(OBC_segment_type), pointer :: segment => NULL() + + if (.not.associated(OBC)) return ! Bail out if OBC is not available + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) then + cycle + elseif (segment%is_E_or_W) then + I=segment%HI%IsdB + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + u(I,j,k) = 0. + enddo ; enddo + elseif (segment%is_N_or_S) then + J=segment%HI%JsdB + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + v(i,J,k) = 0. + enddo ; enddo + endif + enddo + +end subroutine open_boundary_zero_normal_flow + +!> Calculate the tangential gradient of the normal flow at the boundary q-points. +subroutine gradient_at_q_points(G, GV, segment, uvel, vvel) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(OBC_segment_type), intent(inout) :: segment !< OBC segment structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uvel !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vvel !< meridional velocity [L T-1 ~> m s-1] + integer :: i,j,k + + if (.not. segment%on_pe) return + + if (segment%is_E_or_W) then + if (segment%direction == OBC_DIRECTION_E) then + I=segment%HI%isdB + do k=1,GV%ke + do J=max(segment%HI%JsdB, G%HI%JsdB+1),min(segment%HI%JedB, G%HI%JedB-1) + segment%grad_normal(J,1,k) = (uvel(I-1,j+1,k)-uvel(I-1,j,k)) * G%mask2dBu(I-1,J) + segment%grad_normal(J,2,k) = (uvel(I,j+1,k)-uvel(I,j,k)) * G%mask2dBu(I,J) + enddo + enddo + if (segment%oblique_tan) then + do k=1,GV%ke + do J=max(segment%HI%jsd-1, G%HI%jsd),min(segment%HI%jed+1, G%HI%jed) + segment%grad_tan(j,1,k) = (vvel(i-1,J,k)-vvel(i-1,J-1,k)) * G%mask2dT(i-1,j) + segment%grad_tan(j,2,k) = (vvel(i,J,k)-vvel(i,J-1,k)) * G%mask2dT(i,j) + enddo + enddo + endif + if (segment%oblique_grad) then + do k=1,GV%ke + do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) + segment%grad_gradient(j,1,k) = (((vvel(i-1,J,k) - vvel(i-2,J,k))*G%IdxBu(I-2,J)) - & + (vvel(i-1,J-1,k) - vvel(i-2,J-1,k))*G%IdxBu(I-2,J-1)) * G%mask2dCu(I-2,j) + segment%grad_gradient(j,2,k) = (((vvel(i,J,k) - vvel(i-1,J,k))*G%IdxBu(I-1,J)) - & + (vvel(i,J-1,k) - vvel(i-1,J-1,k))*G%IdxBu(I-1,J-1)) * G%mask2dCu(I-1,j) + enddo + enddo + endif + else ! western segment + I=segment%HI%isdB + do k=1,GV%ke + do J=max(segment%HI%JsdB, G%HI%JsdB+1),min(segment%HI%JedB, G%HI%JedB-1) + segment%grad_normal(J,1,k) = (uvel(I+1,j+1,k)-uvel(I+1,j,k)) * G%mask2dBu(I+1,J) + segment%grad_normal(J,2,k) = (uvel(I,j+1,k)-uvel(I,j,k)) * G%mask2dBu(I,J) + enddo + enddo + if (segment%oblique_tan) then + do k=1,GV%ke + do J=max(segment%HI%jsd-1, G%HI%jsd),min(segment%HI%jed+1, G%HI%jed) + segment%grad_tan(j,1,k) = (vvel(i+2,J,k)-vvel(i+2,J-1,k)) * G%mask2dT(i+2,j) + segment%grad_tan(j,2,k) = (vvel(i+1,J,k)-vvel(i+1,J-1,k)) * G%mask2dT(i+1,j) + enddo + enddo + endif + if (segment%oblique_grad) then + do k=1,GV%ke + do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) + segment%grad_gradient(j,1,k) = (((vvel(i+3,J,k) - vvel(i+2,J,k))*G%IdxBu(I+2,J)) - & + (vvel(i+3,J-1,k) - vvel(i+2,J-1,k))*G%IdxBu(I+2,J-1)) * G%mask2dCu(I+2,j) + segment%grad_gradient(j,2,k) = (((vvel(i+2,J,k) - vvel(i+1,J,k))*G%IdxBu(I+1,J)) - & + (vvel(i+2,J-1,k) - vvel(i+1,J-1,k))*G%IdxBu(I+1,J-1)) * G%mask2dCu(I+1,j) + enddo + enddo + endif + endif + elseif (segment%is_N_or_S) then + if (segment%direction == OBC_DIRECTION_N) then + J=segment%HI%jsdB + do k=1,GV%ke + do I=max(segment%HI%IsdB, G%HI%IsdB+1),min(segment%HI%IedB, G%HI%IedB-1) + segment%grad_normal(I,1,k) = (vvel(i+1,J-1,k)-vvel(i,J-1,k)) * G%mask2dBu(I,J-1) + segment%grad_normal(I,2,k) = (vvel(i+1,J,k)-vvel(i,J,k)) * G%mask2dBu(I,J) + enddo + enddo + if (segment%oblique_tan) then + do k=1,GV%ke + do I=max(segment%HI%isd-1, G%HI%isd),min(segment%HI%ied+1, G%HI%ied) + segment%grad_tan(i,1,k) = (uvel(I,j-1,k)-uvel(I-1,j-1,k)) * G%mask2dT(i,j-1) + segment%grad_tan(i,2,k) = (uvel(I,j,k)-uvel(I-1,j,k)) * G%mask2dT(i,j) + enddo + enddo + endif + if (segment%oblique_grad) then + do k=1,GV%ke + do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) + segment%grad_gradient(i,1,k) = (((uvel(I,j-1,k) - uvel(I,j-2,k))*G%IdyBu(I,J-2)) - & + (uvel(I-1,j-1,k) - uvel(I-1,j-2,k))*G%IdyBu(I-1,J-2)) * G%mask2dCv(i,J-2) + segment%grad_gradient(i,2,k) = (((uvel(I,j,k) - uvel(I,j-1,k))*G%IdyBu(I,J-1)) - & + (uvel(I-1,j,k) - uvel(I-1,j-1,k))*G%IdyBu(I-1,J-1)) * G%mask2dCv(i,J-1) + enddo + enddo + endif + else ! south segment + J=segment%HI%jsdB + do k=1,GV%ke + do I=max(segment%HI%IsdB, G%HI%IsdB+1),min(segment%HI%IedB, G%HI%IedB-1) + segment%grad_normal(I,1,k) = (vvel(i+1,J+1,k)-vvel(i,J+1,k)) * G%mask2dBu(I,J+1) + segment%grad_normal(I,2,k) = (vvel(i+1,J,k)-vvel(i,J,k)) * G%mask2dBu(I,J) + enddo + enddo + if (segment%oblique_tan) then + do k=1,GV%ke + do I=max(segment%HI%isd-1, G%HI%isd),min(segment%HI%ied+1, G%HI%ied) + segment%grad_tan(i,1,k) = (uvel(I,j+2,k)-uvel(I-1,j+2,k)) * G%mask2dT(i,j+2) + segment%grad_tan(i,2,k) = (uvel(I,j+1,k)-uvel(I-1,j+1,k)) * G%mask2dT(i,j+1) + enddo + enddo + endif + if (segment%oblique_grad) then + do k=1,GV%ke + do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) + segment%grad_gradient(i,1,k) = (((uvel(I,j+3,k) - uvel(I,j+2,k))*G%IdyBu(I,J+2)) - & + (uvel(I-1,j+3,k) - uvel(I-1,j+2,k))*G%IdyBu(I-1,J+2)) * G%mask2dCv(i,J+2) + segment%grad_gradient(i,2,k) = (((uvel(I,j+2,k) - uvel(I,j+1,k))*G%IdyBu(I,J+1)) - & + (uvel(I-1,j+2,k) - uvel(I-1,j+1,k))*G%IdyBu(I-1,J+1)) * G%mask2dCv(i,J+1) + enddo + enddo + endif + endif + endif + +end subroutine gradient_at_q_points + + +!> Sets the initial values of the tracer open boundary conditions. +!! Redoing this elsewhere. +subroutine set_tracer_data(OBC, tv, h, G, GV, PF) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), target, intent(in) :: OBC !< Open boundary structure + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(param_file_type), intent(in) :: PF !< Parameter file handle + + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + integer :: i, j, k, n + + ! For now, there are no radiation conditions applied to the thicknesses, since + ! the thicknesses might not be physically motivated. Instead, sponges should be + ! used to enforce the near-boundary layer structure. + + if (associated(tv%T)) then + + call pass_var(tv%T, G%Domain) + call pass_var(tv%S, G%Domain) + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + + if (segment%direction == OBC_DIRECTION_E) then + I=segment%HI%IsdB + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + tv%T(i+1,j,k) = tv%T(i,j,k) ; tv%S(i+1,j,k) = tv%S(i,j,k) + enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_W) then + I=segment%HI%IsdB + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + tv%T(i,j,k) = tv%T(i+1,j,k) ; tv%S(i,j,k) = tv%S(i+1,j,k) + enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_N) then + J=segment%HI%JsdB + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + tv%T(i,j+1,k) = tv%T(i,j,k) ; tv%S(i,j+1,k) = tv%S(i,j,k) + enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_S) then + J=segment%HI%JsdB + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + tv%T(i,j,k) = tv%T(i,j+1,k) ; tv%S(i,j,k) = tv%S(i,j+1,k) + enddo ; enddo + endif + enddo + endif + +end subroutine set_tracer_data + +!> Needs documentation +function lookup_seg_field(OBC_seg,field) + type(OBC_segment_type), intent(in) :: OBC_seg !< OBC segment + character(len=32), intent(in) :: field !< The field name + integer :: lookup_seg_field + ! Local variables + integer :: n + + lookup_seg_field = -1 + do n=1,OBC_seg%num_fields + if (trim(field) == OBC_seg%field(n)%name) then + lookup_seg_field = n + return + endif + enddo + +end function lookup_seg_field + +!> Return the tracer index from its name +function get_tracer_index(OBC_seg,tr_name) + type(OBC_segment_type), pointer :: OBC_seg !< OBC segment + character(len=*), intent(in) :: tr_name !< The field name + integer :: get_tracer_index, it + get_tracer_index=-1 + it=1 + do while(allocated(OBC_seg%tr_Reg%Tr(it)%t)) + if (trim(OBC_seg%tr_Reg%Tr(it)%name) == trim(tr_name)) then + get_tracer_index=it + exit + endif + it=it+1 + enddo + return +end function get_tracer_index + +!> Allocate segment data fields +subroutine allocate_OBC_segment_data(OBC, segment) + type(ocean_OBC_type), intent(in) :: OBC !< Open boundary structure + type(OBC_segment_type), intent(inout) :: segment !< Open boundary segment + ! Local variables + integer :: isd, ied, jsd, jed + integer :: IsdB, IedB, JsdB, JedB + integer :: IscB, IecB, JscB, JecB + + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + IscB = segment%HI%IscB ; IecB = segment%HI%IecB + JscB = segment%HI%JscB ; JecB = segment%HI%JecB + + if (.not. segment%on_pe) return + + if (segment%is_E_or_W) then + ! If these are just Flather, change update_OBC_segment_data accordingly + allocate(segment%Cg(IsdB:IedB,jsd:jed), source=0.0) + allocate(segment%Htot(IsdB:IedB,jsd:jed), source=0.0) + allocate(segment%dZtot(IsdB:IedB,jsd:jed), source=0.0) + allocate(segment%h(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) + allocate(segment%SSH(IsdB:IedB,jsd:jed), source=0.0) + if (segment%radiation) & + allocate(segment%rx_norm_rad(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) + allocate(segment%normal_vel(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) + allocate(segment%normal_vel_bt(IsdB:IedB,jsd:jed), source=0.0) + allocate(segment%normal_trans(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) + if (segment%nudged) & + allocate(segment%nudged_normal_vel(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) + if (segment%radiation_tan .or. segment%nudged_tan .or. segment%specified_tan .or. & + segment%oblique_tan .or. OBC%computed_vorticity .or. OBC%computed_strain) & + allocate(segment%tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) + if (segment%nudged_tan) & + allocate(segment%nudged_tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) + if (segment%nudged_grad) & + allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) + if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad .or. & + segment%oblique_grad .or. segment%specified_grad) & + allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) + if (segment%oblique) then + allocate(segment%grad_normal(JsdB:JedB,2,OBC%ke), source=0.0) + allocate(segment%rx_norm_obl(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) + allocate(segment%ry_norm_obl(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) + allocate(segment%cff_normal(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) + endif + if (segment%oblique_tan) & + allocate(segment%grad_tan(jsd-1:jed+1,2,OBC%ke), source=0.0) + if (segment%oblique_grad) & + allocate(segment%grad_gradient(jsd:jed,2,OBC%ke), source=0.0) + endif + + if (segment%is_N_or_S) then + ! If these are just Flather, change update_OBC_segment_data accordingly + allocate(segment%Cg(isd:ied,JsdB:JedB), source=0.0) + allocate(segment%Htot(isd:ied,JsdB:JedB), source=0.0) + allocate(segment%dZtot(isd:ied,JsdB:JedB), source=0.0) + allocate(segment%h(isd:ied,JsdB:JedB,OBC%ke), source=0.0) + allocate(segment%SSH(isd:ied,JsdB:JedB), source=0.0) + if (segment%radiation) & + allocate(segment%ry_norm_rad(isd:ied,JsdB:JedB,OBC%ke), source=0.0) + allocate(segment%normal_vel(isd:ied,JsdB:JedB,OBC%ke), source=0.0) + allocate(segment%normal_vel_bt(isd:ied,JsdB:JedB), source=0.0) + allocate(segment%normal_trans(isd:ied,JsdB:JedB,OBC%ke), source=0.0) + if (segment%nudged) & + allocate(segment%nudged_normal_vel(isd:ied,JsdB:JedB,OBC%ke), source=0.0) + if (segment%radiation_tan .or. segment%nudged_tan .or. segment%specified_tan .or. & + segment%oblique_tan .or. OBC%computed_vorticity .or. OBC%computed_strain) & + allocate(segment%tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) + if (segment%nudged_tan) & + allocate(segment%nudged_tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) + if (segment%nudged_grad) & + allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) + if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad .or. & + segment%oblique_grad .or. segment%specified_grad) & + allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) + if (segment%oblique) then + allocate(segment%grad_normal(IsdB:IedB,2,OBC%ke), source=0.0) + allocate(segment%rx_norm_obl(isd:ied,JsdB:JedB,OBC%ke), source=0.0) + allocate(segment%ry_norm_obl(isd:ied,JsdB:JedB,OBC%ke), source=0.0) + allocate(segment%cff_normal(isd:ied,JsdB:JedB,OBC%ke), source=0.0) + endif + if (segment%oblique_tan) & + allocate(segment%grad_tan(isd-1:ied+1,2,OBC%ke), source=0.0) + if (segment%oblique_grad) & + allocate(segment%grad_gradient(isd:ied,2,OBC%ke), source=0.0) + endif + +end subroutine allocate_OBC_segment_data + +!> Deallocate segment data fields +subroutine deallocate_OBC_segment_data(segment) + type(OBC_segment_type), intent(inout) :: segment !< Open boundary segment + + if (.not. segment%on_pe) return + + if (allocated(segment%Cg)) deallocate(segment%Cg) + if (allocated(segment%Htot)) deallocate(segment%Htot) + if (allocated(segment%dZtot)) deallocate(segment%dZtot) + if (allocated(segment%h)) deallocate(segment%h) + if (allocated(segment%SSH)) deallocate(segment%SSH) + if (allocated(segment%rx_norm_rad)) deallocate(segment%rx_norm_rad) + if (allocated(segment%ry_norm_rad)) deallocate(segment%ry_norm_rad) + if (allocated(segment%rx_norm_obl)) deallocate(segment%rx_norm_obl) + if (allocated(segment%ry_norm_obl)) deallocate(segment%ry_norm_obl) + if (allocated(segment%cff_normal)) deallocate(segment%cff_normal) + if (allocated(segment%grad_normal)) deallocate(segment%grad_normal) + if (allocated(segment%grad_tan)) deallocate(segment%grad_tan) + if (allocated(segment%grad_gradient)) deallocate(segment%grad_gradient) + if (allocated(segment%normal_vel)) deallocate(segment%normal_vel) + if (allocated(segment%normal_vel_bt)) deallocate(segment%normal_vel_bt) + if (allocated(segment%normal_trans)) deallocate(segment%normal_trans) + if (allocated(segment%nudged_normal_vel)) deallocate(segment%nudged_normal_vel) + if (allocated(segment%tangential_vel)) deallocate(segment%tangential_vel) + if (allocated(segment%nudged_tangential_vel)) deallocate(segment%nudged_tangential_vel) + if (allocated(segment%nudged_tangential_grad)) deallocate(segment%nudged_tangential_grad) + if (allocated(segment%tangential_grad)) deallocate(segment%tangential_grad) + + if (associated(segment%tr_Reg)) call segment_tracer_registry_end(segment%tr_Reg) + + +end subroutine deallocate_OBC_segment_data + +!> Set tangential velocities outside of open boundaries to silly values +!! (used for checking the interior state is independent of values outside +!! of the domain). +subroutine open_boundary_test_extern_uv(G, GV, OBC, u, v) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)),intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)),intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + ! Local variables + integer :: i, j, k, n + + if (.not. associated(OBC)) return + + do n = 1, OBC%number_of_segments + do k = 1, GV%ke + if (OBC%segment(n)%is_N_or_S) then + J = OBC%segment(n)%HI%JsdB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + do I = OBC%segment(n)%HI%IsdB, OBC%segment(n)%HI%IedB + u(I,j+1,k) = OBC%silly_u + enddo + else + do I = OBC%segment(n)%HI%IsdB, OBC%segment(n)%HI%IedB + u(I,j,k) = OBC%silly_u + enddo + endif + elseif (OBC%segment(n)%is_E_or_W) then + I = OBC%segment(n)%HI%IsdB + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + do J = OBC%segment(n)%HI%JsdB, OBC%segment(n)%HI%JedB + v(i+1,J,k) = OBC%silly_u + enddo + else + do J = OBC%segment(n)%HI%JsdB, OBC%segment(n)%HI%JedB + v(i,J,k) = OBC%silly_u + enddo + endif + endif + enddo + enddo + +end subroutine open_boundary_test_extern_uv + +!> Set thicknesses outside of open boundaries to silly values +!! (used for checking the interior state is independent of values outside +!! of the domain). +subroutine open_boundary_test_extern_h(G, GV, OBC, h) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(SZI_(G),SZJ_(G), SZK_(GV)),intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + ! Local variables + real :: silly_h ! A silly thickness for testing [H ~> m or kg m-2] + integer :: i, j, k, n + + if (.not. associated(OBC)) return + + silly_h = GV%Z_to_H * OBC%silly_h ! This rescaling is here because GV was initialized after OBC. + + do n = 1, OBC%number_of_segments + do k = 1, GV%ke + if (OBC%segment(n)%is_N_or_S) then + J = OBC%segment(n)%HI%JsdB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied + h(i,j+1,k) = silly_h + enddo + else + do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied + h(i,j,k) = silly_h + enddo + endif + elseif (OBC%segment(n)%is_E_or_W) then + I = OBC%segment(n)%HI%IsdB + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed + h(i+1,j,k) = silly_h + enddo + else + do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed + h(i,j,k) = silly_h + enddo + endif + endif + enddo + enddo + +end subroutine open_boundary_test_extern_h + +!> Update the OBC values on the segments. +subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + 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(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Thickness [H ~> m or kg m-2] + type(time_type), intent(in) :: Time !< Model time + ! Local variables + integer :: c, i, j, k, is, ie, js, je, isd, ied, jsd, jed + integer :: IsdB, IedB, JsdB, JedB, n, m, nz, nt + type(OBC_segment_type), pointer :: segment => NULL() + integer, dimension(4) :: siz + real, dimension(:,:,:), pointer :: tmp_buffer_in => NULL() ! Unrotated input [various units] + integer :: ni_seg, nj_seg ! number of src gridpoints along the segments + integer :: ni_buf, nj_buf ! Number of filled values in tmp_buffer + integer :: is_obc, ie_obc, js_obc, je_obc ! segment indices within local domain + integer :: ishift, jshift ! offsets for staggered locations + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] + real, dimension(:,:,:), allocatable, target :: tmp_buffer ! A buffer for input data [various units] + real, dimension(:), allocatable :: dz_stack ! Distance between the interfaces at corner points [Z ~> m] + integer :: is_obc2, js_obc2 + integer :: i_seg_offset, j_seg_offset + real :: net_dz_src ! Total vertical extent of the incoming flow in the source field [Z ~> m] + real :: net_dz_int ! Total vertical extent of the incoming flow in the model [Z ~> m] + real :: scl_fac ! A scaling factor to compensate for differences in total thicknesses [nondim] + real :: tidal_vel ! Interpolated tidal velocity at the OBC points [L T-1 ~> m s-1] + real :: tidal_elev ! Interpolated tidal elevation at the OBC points [Z ~> m] + real, allocatable :: normal_trans_bt(:,:) ! barotropic transport [H L2 T-1 ~> m3 s-1] + integer :: turns ! Number of index quarter turns + real :: time_delta ! Time since tidal reference date [T ~> s] + real :: dz_neglect, dz_neglect_edge ! Small thicknesses [Z ~> m] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + nz=GV%ke + + turns = G%HI%turns + + if (.not. associated(OBC)) return + + if (OBC%add_tide_constituents) time_delta = US%s_to_T * time_type_to_real(Time - OBC%time_ref) + + if (GV%Boussinesq .and. (OBC%remap_answer_date < 20190101)) then + dz_neglect = US%m_to_Z * 1.0e-30 ; dz_neglect_edge = US%m_to_Z * 1.0e-10 + elseif (GV%semi_Boussinesq .and. (OBC%remap_answer_date < 20190101)) then + dz_neglect = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-10 + else + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + endif + + if (OBC%number_of_segments >= 1) then + call thickness_to_dz(h, tv, dz, G, GV, US) + call pass_var(dz, G%Domain) + endif + + do n = 1, OBC%number_of_segments + segment => OBC%segment(n) + + if (.not. segment%on_pe) cycle ! continue to next segment if not in computational domain + + ! NOTE: These are in segment%HI, but defined slightly differently + ni_seg = segment%ie_obc-segment%is_obc+1 + nj_seg = segment%je_obc-segment%js_obc+1 + is_obc = max(segment%is_obc,isd-1) + ie_obc = min(segment%ie_obc,ied) + js_obc = max(segment%js_obc,jsd-1) + je_obc = min(segment%je_obc,jed) + i_seg_offset = G%idg_offset - segment%HI%Isgb + j_seg_offset = G%jdg_offset - segment%HI%Jsgb + +! Calculate auxiliary fields at staggered locations. +! Segment indices are on q points: +! +! |-----------|------------|-----------|-----------| J_obc +! Is_obc Ie_obc +! +! i2 has to start at Is_obc+1 and end at Ie_obc. +! j2 is J_obc and jshift has to be +1 at both the north and south. + + ! calculate auxiliary fields at staggered locations + ishift=0;jshift=0 + if (segment%is_E_or_W) then + allocate(normal_trans_bt(segment%HI%IsdB:segment%HI%IedB,segment%HI%jsd:segment%HI%jed), source=0.0) + if (segment%direction == OBC_DIRECTION_W) ishift=1 + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + segment%Htot(I,j) = 0.0 + segment%dZtot(I,j) = 0.0 + do k=1,GV%ke + segment%h(I,j,k) = h(i+ishift,j,k) + segment%Htot(I,j) = segment%Htot(I,j) + segment%h(I,j,k) + segment%dZtot(I,j) = segment%dZtot(I,j) + dz(i+ishift,j,k) + enddo + segment%Cg(I,j) = sqrt(GV%g_prime(1) * max(0.0, segment%dZtot(I,j))) + enddo + else! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) + allocate(normal_trans_bt(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB), source=0.0) + if (segment%direction == OBC_DIRECTION_S) jshift=1 + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + segment%Htot(i,J) = 0.0 + segment%dZtot(i,J) = 0.0 + do k=1,GV%ke + segment%h(i,J,k) = h(i,j+jshift,k) + segment%Htot(i,J) = segment%Htot(i,J) + segment%h(i,J,k) + segment%dZtot(i,J) = segment%dZtot(i,J) + dz(i,j+jshift,k) + enddo + segment%Cg(i,J) = sqrt(GV%g_prime(1) * max(0.0, segment%dZtot(i,J))) + enddo + endif + + allocate(dz_stack(GV%ke), source=0.0) + do m = 1,segment%num_fields + !This field may not require a high frequency OBC segment update and might be allowed + !a less frequent update as set by the parameter update_OBC_period_max in MOM.F90. + !Cycle if it is not the time to update OBC segment data for this field. + if (trim(segment%field(m)%genre) == 'obgc' .and. (.not. OBC%update_OBC_seg_data)) cycle + if (segment%field(m)%use_IO) then + siz(1) = size(segment%field(m)%buffer_src,1) + siz(2) = size(segment%field(m)%buffer_src,2) + siz(3) = size(segment%field(m)%buffer_src,3) + if (.not.allocated(segment%field(m)%buffer_dst)) then + if (siz(3) /= segment%field(m)%nk_src) call MOM_error(FATAL,'nk_src inconsistency') + if (segment%field(m)%nk_src > 1) then + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) + elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent + elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase' .or. & + segment%field(m)%name == 'SSHamp' .or. segment%field(m)%name == 'SSHphase') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,siz(3))) ! 3rd dim is constituent + else + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke)) + endif + else + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) + elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent + elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase' .or. & + segment%field(m)%name == 'SSHamp' .or. segment%field(m)%name == 'SSHphase') then + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent + else + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke)) + endif + endif + else + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX' .or. & + segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) + else + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) + endif + else + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY' .or. & + segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) + else + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) + endif + endif + endif + segment%field(m)%buffer_dst(:,:,:) = 0.0 + endif + ! read source data interpolated to the current model time + ! NOTE: buffer is sized for vertex points, but may be used for faces + if (siz(1)==1) then + if (OBC%brushcutter_mode) then + allocate(tmp_buffer(1,nj_seg*2-1,segment%field(m)%nk_src)) ! segment data is currently on supergrid + else + allocate(tmp_buffer(1,nj_seg,segment%field(m)%nk_src)) ! segment data is currently on native grid + endif + else + if (OBC%brushcutter_mode) then + allocate(tmp_buffer(ni_seg*2-1,1,segment%field(m)%nk_src)) ! segment data is currently on supergrid + else + allocate(tmp_buffer(ni_seg,1,segment%field(m)%nk_src)) ! segment data is currently on native grid + endif + endif + + ! TODO: Since we conditionally rotate a subset of tmp_buffer_in after + ! reading the value, it is currently not possible to use the rotated + ! implementation of time_interp_extern. + ! For now, we must explicitly allocate and rotate this array. + if (turns /= 0) then + if (modulo(turns, 2) /= 0) then + allocate(tmp_buffer_in(size(tmp_buffer, 2), size(tmp_buffer, 1), size(tmp_buffer, 3))) + else + allocate(tmp_buffer_in(size(tmp_buffer, 1), size(tmp_buffer, 2), size(tmp_buffer, 3))) + endif + else + tmp_buffer_in => tmp_buffer + endif + + ! This is where the data values are actually read in. + call time_interp_external(segment%field(m)%handle, Time, tmp_buffer_in, scale=segment%field(m)%scale) + + ! NOTE: Rotation of face-points require that we skip the final value + if (turns /= 0) then + ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. + if (segment%is_E_or_W & + .and. .not. (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'Vamp' & + .or. segment%field(m)%name == 'Vphase' .or. segment%field(m)%name == 'DVDX')) then + nj_buf = size(tmp_buffer, 2) - 1 + call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:)) + elseif (segment%is_N_or_S & + .and. .not. (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'Uamp' & + .or. segment%field(m)%name == 'Uphase' .or. segment%field(m)%name == 'DUDY')) then + ni_buf = size(tmp_buffer, 1) - 1 + call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:)) + else + call rotate_array(tmp_buffer_in, turns, tmp_buffer) + endif + + ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. + if (segment%field(m)%name == 'U' & + .or. segment%field(m)%name == 'DVDX' & + .or. segment%field(m)%name == 'DUDY' & + .or. segment%field(m)%name == 'Uamp') then + tmp_buffer(:,:,:) = -tmp_buffer(:,:,:) + endif + endif + + if (OBC%brushcutter_mode) then + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX' .or. & + segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then + segment%field(m)%buffer_src(is_obc,:,:) = & + tmp_buffer(1,2*(js_obc+j_seg_offset)+1:2*(je_obc+j_seg_offset)+1:2,:) + else + segment%field(m)%buffer_src(is_obc,:,:) = & + tmp_buffer(1,2*(js_obc+j_seg_offset)+1:2*(je_obc+j_seg_offset):2,:) + endif + else + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY' .or. & + segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then + segment%field(m)%buffer_src(:,js_obc,:) = & + tmp_buffer(2*(is_obc+i_seg_offset)+1:2*(ie_obc+i_seg_offset)+1:2,1,:) + else + segment%field(m)%buffer_src(:,js_obc,:) = & + tmp_buffer(2*(is_obc+i_seg_offset)+1:2*(ie_obc+i_seg_offset):2,1,:) + endif + endif + else + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX' .or. & + segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then + segment%field(m)%buffer_src(is_obc,:,:) = & + tmp_buffer(1,js_obc+j_seg_offset+1:je_obc+j_seg_offset+1,:) + else + segment%field(m)%buffer_src(is_obc,:,:) = & + tmp_buffer(1,js_obc+j_seg_offset+1:je_obc+j_seg_offset,:) + endif + else + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY' .or. & + segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then + segment%field(m)%buffer_src(:,js_obc,:) = & + tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset+1,1,:) + else + segment%field(m)%buffer_src(:,js_obc,:) = & + tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset,1,:) + endif + endif + endif + ! no dz for tidal variables + if (segment%field(m)%nk_src > 1 .and.& + (index(segment%field(m)%name, 'phase') <= 0 .and. index(segment%field(m)%name, 'amp') <= 0)) then + ! This is where the 2-d tidal data values are actually read in. + call time_interp_external(segment%field(m)%dz_handle, Time, tmp_buffer_in, scale=US%m_to_Z) + if (turns /= 0) then + ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. + if (segment%is_E_or_W & + .and. .not. (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX')) then + nj_buf = size(tmp_buffer, 2) - 1 + call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:)) + elseif (segment%is_N_or_S & + .and. .not. (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY')) then + ni_buf = size(tmp_buffer, 1) - 1 + call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:)) + else + call rotate_array(tmp_buffer_in, turns, tmp_buffer) + endif + endif + if (OBC%brushcutter_mode) then + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + segment%field(m)%dz_src(is_obc,:,:) = & + tmp_buffer(1,2*(js_obc+j_seg_offset)+1:2*(je_obc+j_seg_offset)+1:2,:) + else + segment%field(m)%dz_src(is_obc,:,:) = & + tmp_buffer(1,2*(js_obc+j_seg_offset)+1:2*(je_obc+j_seg_offset):2,:) + endif + else + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + segment%field(m)%dz_src(:,js_obc,:) = & + tmp_buffer(2*(is_obc+i_seg_offset)+1:2*(ie_obc+i_seg_offset)+1:2,1,:) + else + segment%field(m)%dz_src(:,js_obc,:) = & + tmp_buffer(2*(is_obc+i_seg_offset)+1:2*(ie_obc+i_seg_offset):2,1,:) + endif + endif + else + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + segment%field(m)%dz_src(is_obc,:,:) = & + tmp_buffer(1,js_obc+j_seg_offset+1:je_obc+j_seg_offset+1,:) + else + segment%field(m)%dz_src(is_obc,:,:) = & + tmp_buffer(1,js_obc+j_seg_offset+1:je_obc+j_seg_offset,:) + endif + else + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + segment%field(m)%dz_src(:,js_obc,:) = & + tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset+1,1,:) + else + segment%field(m)%dz_src(:,js_obc,:) = & + tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset,1,:) + endif + endif + endif + + ! The units of ...%dz_src are no longer changed from [Z ~> m] to [H ~> m or kg m-2] here. + call adjustSegmentEtaToFitBathymetry(G,GV,US,segment,m) + + if (segment%is_E_or_W) then + ishift=1 + if (segment%direction == OBC_DIRECTION_E) ishift=0 + I=is_obc + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + ! Do q points for the whole segment + do J=max(js_obc,jsd),min(je_obc,jed-1) + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer + if (G%mask2dCu(I,j)>0. .and. G%mask2dCu(I,j+1)>0.) then + dz_stack(:) = 0.5*(dz(i+ishift,j,:) + dz(i+ishift,j+1,:)) + call remapping_core_h(OBC%remap_CS, & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & + segment%field(m)%buffer_src(I,J,:), & + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & + dz_neglect, dz_neglect_edge) + elseif (G%mask2dCu(I,j)>0.) then + dz_stack(:) = dz(i+ishift,j,:) + call remapping_core_h(OBC%remap_CS, & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & + segment%field(m)%buffer_src(I,J,:), & + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & + dz_neglect, dz_neglect_edge) + elseif (G%mask2dCu(I,j+1)>0.) then + dz_stack(:) = dz(i+ishift,j+1,:) + call remapping_core_h(OBC%remap_CS, & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,j,:), & + segment%field(m)%buffer_src(I,J,:), & + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & + dz_neglect, dz_neglect_edge) + endif + enddo + else + do j=js_obc+1,je_obc + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + segment%field(m)%buffer_dst(I,j,:) = 0.0 ! initialize remap destination buffer + if (G%mask2dCu(I,j)>0.) then + net_dz_src = sum( segment%field(m)%dz_src(I,j,:) ) + net_dz_int = sum( dz(i+ishift,j,:) ) + scl_fac = net_dz_int / net_dz_src + call remapping_core_h(OBC%remap_CS, & + segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), & + segment%field(m)%buffer_src(I,j,:), & + GV%ke, dz(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:), & + dz_neglect, dz_neglect_edge) + endif + enddo + endif + else + jshift=1 + if (segment%direction == OBC_DIRECTION_N) jshift=0 + J=js_obc + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + ! Do q points for the whole segment + do I=max(is_obc,isd),min(ie_obc,ied-1) + segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer + if (G%mask2dCv(i,J)>0. .and. G%mask2dCv(i+1,J)>0.) then + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + dz_stack(:) = 0.5*(dz(i,j+jshift,:) + dz(i+1,j+jshift,:)) + call remapping_core_h(OBC%remap_CS, & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & + segment%field(m)%buffer_src(I,J,:), & + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & + dz_neglect, dz_neglect_edge) + elseif (G%mask2dCv(i,J)>0.) then + dz_stack(:) = dz(i,j+jshift,:) + call remapping_core_h(OBC%remap_CS, & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & + segment%field(m)%buffer_src(I,J,:), & + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & + dz_neglect, dz_neglect_edge) + elseif (G%mask2dCv(i+1,J)>0.) then + dz_stack(:) = dz(i+1,j+jshift,:) + call remapping_core_h(OBC%remap_CS, & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & + segment%field(m)%buffer_src(I,J,:), & + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & + dz_neglect, dz_neglect_edge) + endif + enddo + else + do i=is_obc+1,ie_obc + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + segment%field(m)%buffer_dst(i,J,:) = 0.0 ! initialize remap destination buffer + if (G%mask2dCv(i,J)>0.) then + net_dz_src = sum( segment%field(m)%dz_src(i,J,:) ) + net_dz_int = sum( dz(i,j+jshift,:) ) + scl_fac = net_dz_int / net_dz_src + call remapping_core_h(OBC%remap_CS, & + segment%field(m)%nk_src, scl_fac* segment%field(m)%dz_src(i,J,:), & + segment%field(m)%buffer_src(i,J,:), & + GV%ke, dz(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:), & + dz_neglect, dz_neglect_edge) + endif + enddo + endif + endif + elseif (segment%field(m)%nk_src > 1 .and. & + (index(segment%field(m)%name, 'phase') > 0 .or. index(segment%field(m)%name, 'amp') > 0)) then + ! no dz for tidal variables + segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%buffer_src(:,:,:) + else ! 2d data + segment%field(m)%buffer_dst(:,:,1) = segment%field(m)%buffer_src(:,:,1) ! initialize remap destination buffer + endif + deallocate(tmp_buffer) + if (turns /= 0) & + deallocate(tmp_buffer_in) + else ! use_IO = .false. (Uniform value) + if (.not. allocated(segment%field(m)%buffer_dst)) then + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) + else if (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) + elseif (segment%field(m)%name == 'U') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke)) + elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) + elseif (segment%field(m)%name == 'DVDX') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) + elseif (segment%field(m)%name == 'SSH' .or. segment%field(m)%name == 'SSHamp' & + .or. segment%field(m)%name == 'SSHphase') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) + else + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke)) + endif + else + if (segment%field(m)%name == 'U') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) + elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) + elseif (segment%field(m)%name == 'V') then + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke)) + elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) + elseif (segment%field(m)%name == 'DUDY') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) + elseif (segment%field(m)%name == 'SSH' .or. segment%field(m)%name == 'SSHamp' & + .or. segment%field(m)%name == 'SSHphase') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) + else + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke)) + endif + endif + segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%value + endif + endif + enddo + ! Start second loop to update all fields now that data for all fields are available. + ! (split because tides depend on multiple variables). + do m = 1,segment%num_fields + !cycle if it is not the time to update OBGC tracers from source + if (trim(segment%field(m)%genre) == 'obgc' .and. (.not. OBC%update_OBC_seg_data)) cycle + ! if (segment%field(m)%use_IO) then + ! calculate external BT velocity and transport if needed + if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then + if (trim(segment%field(m)%name) == 'U' .and. segment%is_E_or_W) then + I=is_obc + do j=js_obc+1,je_obc + normal_trans_bt(I,j) = 0.0 + tidal_vel = 0.0 + if (OBC%add_tide_constituents) then + do c=1,OBC%n_tide_constituents + tidal_vel = tidal_vel + (OBC%tide_fn(c) * segment%field(segment%uamp_index)%buffer_dst(I,j,c)) * & + cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%uphase_index)%buffer_dst(I,j,c)) & + + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) + enddo + endif + do k=1,GV%ke + segment%normal_vel(I,j,k) = segment%field(m)%buffer_dst(I,j,k) + tidal_vel + segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k)*segment%h(I,j,k) * G%dyCu(I,j) + normal_trans_bt(I,j) = normal_trans_bt(I,j) + segment%normal_trans(I,j,k) + enddo + segment%normal_vel_bt(I,j) = normal_trans_bt(I,j) & + / (max(segment%Htot(I,j), 1.e-12 * GV%m_to_H) * G%dyCu(I,j)) + if (allocated(segment%nudged_normal_vel)) segment%nudged_normal_vel(I,j,:) = segment%normal_vel(I,j,:) + enddo + elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_N_or_S) then + J=js_obc + do i=is_obc+1,ie_obc + normal_trans_bt(i,J) = 0.0 + tidal_vel = 0.0 + if (OBC%add_tide_constituents) then + do c=1,OBC%n_tide_constituents + tidal_vel = tidal_vel + (OBC%tide_fn(c) * segment%field(segment%vamp_index)%buffer_dst(I,j,c)) * & + cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%vphase_index)%buffer_dst(I,j,c)) & + + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) + enddo + endif + do k=1,GV%ke + segment%normal_vel(i,J,k) = segment%field(m)%buffer_dst(i,J,k) + tidal_vel + segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k)*segment%h(i,J,k) * & + G%dxCv(i,J) + normal_trans_bt(i,J) = normal_trans_bt(i,J) + segment%normal_trans(i,J,k) + enddo + segment%normal_vel_bt(i,J) = normal_trans_bt(i,J) & + / (max(segment%Htot(i,J), 1.e-12 * GV%m_to_H) * G%dxCv(i,J)) + if (allocated(segment%nudged_normal_vel)) segment%nudged_normal_vel(i,J,:) = segment%normal_vel(i,J,:) + enddo + elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_E_or_W .and. & + allocated(segment%tangential_vel)) then + I=is_obc + do J=js_obc,je_obc + tidal_vel = 0.0 + if (OBC%add_tide_constituents) then + do c=1,OBC%n_tide_constituents + tidal_vel = tidal_vel + (OBC%tide_fn(c) * segment%field(segment%vamp_index)%buffer_dst(I,j,c)) * & + cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%vphase_index)%buffer_dst(I,j,c)) & + + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) + enddo + endif + do k=1,GV%ke + segment%tangential_vel(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + tidal_vel + enddo + if (allocated(segment%nudged_tangential_vel)) & + segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) + enddo + elseif (trim(segment%field(m)%name) == 'U' .and. segment%is_N_or_S .and. & + allocated(segment%tangential_vel)) then + J=js_obc + do I=is_obc,ie_obc + tidal_vel = 0.0 + if (OBC%add_tide_constituents) then + do c=1,OBC%n_tide_constituents + tidal_vel = tidal_vel + (OBC%tide_fn(c) * segment%field(segment%uamp_index)%buffer_dst(I,j,c)) * & + cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%uphase_index)%buffer_dst(I,j,c)) & + + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) + enddo + endif + do k=1,GV%ke + segment%tangential_vel(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + tidal_vel + enddo + if (allocated(segment%nudged_tangential_vel)) & + segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) + enddo + endif + elseif (trim(segment%field(m)%name) == 'DVDX' .and. segment%is_E_or_W .and. & + allocated(segment%tangential_grad)) then + I=is_obc + do J=js_obc,je_obc + do k=1,GV%ke + segment%tangential_grad(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + if (allocated(segment%nudged_tangential_grad)) & + segment%nudged_tangential_grad(I,J,:) = segment%tangential_grad(I,J,:) + enddo + enddo + elseif (trim(segment%field(m)%name) == 'DUDY' .and. segment%is_N_or_S .and. & + allocated(segment%tangential_grad)) then + J=js_obc + do I=is_obc,ie_obc + do k=1,GV%ke + segment%tangential_grad(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + if (allocated(segment%nudged_tangential_grad)) & + segment%nudged_tangential_grad(I,J,:) = segment%tangential_grad(I,J,:) + enddo + enddo + endif + + ! endif + + ! from this point on, data are entirely on segments - will + ! write all segment loops as 2d loops. + if (segment%is_E_or_W) then + js_obc2 = js_obc+1 + is_obc2 = is_obc + else + js_obc2 = js_obc + is_obc2 = is_obc+1 + endif + if (segment%is_N_or_S) then + is_obc2 = is_obc+1 + js_obc2 = js_obc + else + is_obc2 = is_obc + js_obc2 = js_obc+1 + endif + + if (trim(segment%field(m)%name) == 'SSH') then + if (OBC%ramp) then + do j=js_obc2,je_obc + do i=is_obc2,ie_obc + tidal_elev = 0.0 + if (OBC%add_tide_constituents) then + do c=1,OBC%n_tide_constituents + tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & + cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & + + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) + enddo + endif + segment%SSH(i,j) = OBC%ramp_value * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) + enddo + enddo + else + do j=js_obc2,je_obc + do i=is_obc2,ie_obc + tidal_elev = 0.0 + if (OBC%add_tide_constituents) then + do c=1,OBC%n_tide_constituents + tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & + cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & + + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) + enddo + endif + segment%SSH(i,j) = (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) + enddo + enddo + endif + endif + + if (trim(segment%field(m)%name) == 'TEMP') then + if (allocated(segment%field(m)%buffer_dst)) then + do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc + segment%tr_Reg%Tr(1)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) + enddo ; enddo ; enddo + if (.not. segment%tr_Reg%Tr(1)%is_initialized) then + ! if the tracer reservoir has not yet been initialized, then set to external value. + do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc + segment%tr_Reg%Tr(1)%tres(i,j,k) = segment%tr_Reg%Tr(1)%t(i,j,k) + enddo ; enddo ; enddo + segment%tr_Reg%Tr(1)%is_initialized=.true. + endif + else + segment%tr_Reg%Tr(1)%OBC_inflow_conc = segment%field(m)%value + endif + elseif (trim(segment%field(m)%name) == 'SALT') then + if (allocated(segment%field(m)%buffer_dst)) then + do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc + segment%tr_Reg%Tr(2)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) + enddo ; enddo ; enddo + if (.not. segment%tr_Reg%Tr(2)%is_initialized) then + !if the tracer reservoir has not yet been initialized, then set to external value. + do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc + segment%tr_Reg%Tr(2)%tres(i,j,k) = segment%tr_Reg%Tr(2)%t(i,j,k) + enddo ; enddo ; enddo + segment%tr_Reg%Tr(2)%is_initialized=.true. + endif + else + segment%tr_Reg%Tr(2)%OBC_inflow_conc = segment%field(m)%value + endif + elseif (trim(segment%field(m)%genre) == 'obgc') then + nt=get_tracer_index(segment,trim(segment%field(m)%name)) + if (nt < 0) then + call MOM_error(FATAL,"update_OBC_segment_data: Did not find tracer "//trim(segment%field(m)%name)) + endif + if (allocated(segment%field(m)%buffer_dst)) then + do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + segment%tr_Reg%Tr(nt)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) + enddo ; enddo ; enddo + if (.not. segment%tr_Reg%Tr(nt)%is_initialized) then + !if the tracer reservoir has not yet been initialized, then set to external value. + do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + segment%tr_Reg%Tr(nt)%tres(i,j,k) = segment%tr_Reg%Tr(nt)%t(i,j,k) + enddo ; enddo ; enddo + segment%tr_Reg%Tr(nt)%is_initialized=.true. + endif + else + segment%tr_Reg%Tr(nt)%OBC_inflow_conc = segment%field(m)%value + endif + endif + + enddo ! end field loop + deallocate(dz_stack) + deallocate(normal_trans_bt) + + enddo ! end segment loop + +end subroutine update_OBC_segment_data + +!> Update the OBC ramp value as a function of time. +!! If called with the optional argument activate=.true., record the +!! value of Time as the beginning of the ramp period. +subroutine update_OBC_ramp(Time, OBC, US, activate) + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, optional, intent(in) :: activate !< Specify whether to record the value of + !! Time as the beginning of the ramp period + + ! Local variables + real :: deltaTime ! The time since start of ramping [T ~> s] + real :: wghtA ! A temporary variable used to set OBC%ramp_value [nondim] + character(len=12) :: msg + + if (.not. OBC%ramp) return ! This indicates the ramping is turned off + + ! We use the optional argument to indicate this Time should be recorded as the + ! beginning of the ramp-up period. + if (present(activate)) then + if (activate) then + OBC%ramp_start_time = Time ! Record the current time + OBC%ramping_is_activated = .true. + OBC%trunc_ramp_time = OBC%ramp_timescale ! times 3.0 for tanh + endif + endif + if (.not.OBC%ramping_is_activated) return + deltaTime = max( 0., US%s_to_T*time_type_to_real( Time - OBC%ramp_start_time ) ) + if (deltaTime >= OBC%trunc_ramp_time) then + OBC%ramp_value = 1.0 + OBC%ramp = .false. ! This turns off ramping after this call + else + wghtA = min( 1., deltaTime / OBC%ramp_timescale ) ! Linear profile in time + !wghtA = wghtA*wghtA ! Convert linear profile to parabolic profile in time + !wghtA = wghtA*wghtA*(3. - 2.*wghtA) ! Convert linear profile to cosine profile + !wghtA = 1. - ( (1. - wghtA)**2 ) ! Convert linear profile to inverted parabolic profile + !wghtA = tanh(wghtA) ! Convert linear profile to tanh + OBC%ramp_value = wghtA + endif + write(msg(1:12),'(es12.3)') OBC%ramp_value + call MOM_error(NOTE, "MOM_open_boundary: update_OBC_ramp set OBC"// & + " ramp to "//trim(msg)) +end subroutine update_OBC_ramp + +!> register open boundary objects for boundary updates. +subroutine register_OBC(name, param_file, Reg) + character(len=32), intent(in) :: name !< OBC name used for error messages + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + type(OBC_registry_type), pointer :: Reg !< pointer to the tracer registry + integer :: nobc + character(len=256) :: mesg ! Message for error messages. + + if (.not. associated(Reg)) call OBC_registry_init(param_file, Reg) + + if (Reg%nobc>=MAX_FIELDS_) then + write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for & + &all the open boundaries being registered via register_OBC.")') Reg%nobc+1 + call MOM_error(FATAL,"MOM register_OBC: "//mesg) + endif + Reg%nobc = Reg%nobc + 1 + nobc = Reg%nobc + + Reg%OB(nobc)%name = name + + if (Reg%locked) call MOM_error(FATAL, & + "MOM register_OBC was called for OBC "//trim(Reg%OB(nobc)%name)//& + " with a locked OBC registry.") + +end subroutine register_OBC + +!> This routine include declares and sets the variable "version". +subroutine OBC_registry_init(param_file, Reg) + type(param_file_type), intent(in) :: param_file !< open file to parse for model parameters + type(OBC_registry_type), pointer :: Reg !< pointer to OBC registry + + integer, save :: init_calls = 0 + +# include "version_variable.h" + character(len=256) :: mesg ! Message for error messages. + + if (.not.associated(Reg)) then ; allocate(Reg) + else ; return ; endif + + ! Read all relevant parameters and write them to the model log. +! call log_version(param_file, mdl, version, "") + + init_calls = init_calls + 1 + if (init_calls > 1) then + write(mesg,'("OBC_registry_init called ",I3, & + &" times with different registry pointers.")') init_calls + if (is_root_pe()) call MOM_error(WARNING,"MOM_open_boundary"//mesg) + endif + +end subroutine OBC_registry_init + +!> Add file to OBC registry. +function register_file_OBC(param_file, CS, US, OBC_Reg) + type(param_file_type), intent(in) :: param_file !< parameter file. + type(file_OBC_CS), pointer :: CS !< file control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. + logical :: register_file_OBC + character(len=32) :: casename = "OBC file" !< This case's name. + + if (associated(CS)) then + call MOM_error(WARNING, "register_file_OBC called with an "// & + "associated control structure.") + return + endif + allocate(CS) + + ! Register the file for boundary updates. + call register_OBC(casename, param_file, OBC_Reg) + register_file_OBC = .true. + +end function register_file_OBC + +!> Clean up the file OBC from registry. +subroutine file_OBC_end(CS) + type(file_OBC_CS), pointer :: CS !< OBC file control structure. + + if (associated(CS)) then + deallocate(CS) + endif +end subroutine file_OBC_end + +!> Initialize the segment tracer registry. +subroutine segment_tracer_registry_init(param_file, segment) + type(param_file_type), intent(in) :: param_file !< open file to parse for model parameters + type(OBC_segment_type), intent(inout) :: segment !< the segment + + integer, save :: init_calls = 0 + +! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "segment_tracer_registry_init" ! This routine's name. + !character(len=256) :: mesg ! Message for error messages. + + if (.not.associated(segment%tr_Reg)) then + allocate(segment%tr_Reg) + else + return + endif + + init_calls = init_calls + 1 + + ! Read all relevant parameters and write them to the model log. + if (init_calls == 1) call log_version(param_file, mdl, version, "") + +! Need to call once per segment with tracers... +! if (init_calls > 1) then +! write(mesg,'("segment_tracer_registry_init called ",I3, & +! &" times with different registry pointers.")') init_calls +! if (is_root_pe()) call MOM_error(WARNING,"MOM_tracer"//mesg) +! endif + +end subroutine segment_tracer_registry_init + +!> Register a tracer array that is active on an OBC segment, potentially also specifying how the +!! tracer inflow values are specified. +subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, & + OBC_scalar, OBC_array, scale, fd_index) + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(tracer_type), target :: tr_ptr !< A target that can be used to set a pointer to the + !! stored value of tr. This target must be + !! an enduring part of the control structure, + !! because the tracer registry will use this memory, + !! but it also means that any updates to this + !! structure in the calling module will be + !! available subsequently to the tracer registry. + integer, intent(in) :: ntr_index !< index of segment tracer in the global tracer registry + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + type(OBC_segment_type), intent(inout) :: segment !< current segment data structure + real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer + !! inflow concentration, including any rescaling to + !! put the tracer concentration into its internal units, + !! like [S ~> ppt] for salinity. + logical, optional, intent(in) :: OBC_array !< If true, use array values for segment tracer + !! inflow concentration. + real, optional, intent(in) :: scale !< A scaling factor that should be used with any + !! data that is read in to convert it to the internal + !! units of this tracer, in units like [S ppt-1 ~> 1] + !! for salinity. + integer, optional, intent(in) :: fd_index !< index of segment tracer in the input field + +! Local variables + real :: rescale ! A multiplicatively corrected scaling factor, in units like [S ppt-1 ~> 1] for + ! salinity, or other various units depending on what rescaling has occurred previously. + integer :: ntseg, m, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + character(len=256) :: mesg ! Message for error messages. + + call segment_tracer_registry_init(param_file, segment) + + if (segment%tr_Reg%ntseg>=MAX_FIELDS_) then + write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for & + &all the tracers being registered via register_segment_tracer.")') segment%tr_Reg%ntseg+1 + call MOM_error(FATAL,"MOM register_segment_tracer: "//mesg) + endif + segment%tr_Reg%ntseg = segment%tr_Reg%ntseg + 1 + ntseg = segment%tr_Reg%ntseg + + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + segment%tr_Reg%Tr(ntseg)%Tr => tr_ptr + segment%tr_Reg%Tr(ntseg)%name = tr_ptr%name + segment%tr_Reg%Tr(ntseg)%ntr_index = ntr_index + if (present(fd_index)) segment%tr_Reg%Tr(ntseg)%fd_index = fd_index + + segment%tr_Reg%Tr(ntseg)%scale = 1.0 + if (present(scale)) then + segment%tr_Reg%Tr(ntseg)%scale = scale + do m=1,segment%num_fields + ! Store the scaling factor for fields with exactly matching names, and possibly + ! rescale the previously stored input values. Note that calls to register_segment_tracer + ! can come before or after calls to initialize_segment_data. + if (uppercase(segment%field(m)%name) == uppercase(segment%tr_Reg%Tr(ntseg)%name)) then + if (.not. segment%field(m)%use_IO) then + rescale = scale + if ((segment%field(m)%scale /= 0.0) .and. (segment%field(m)%scale /= 1.0)) & + rescale = scale / segment%field(m)%scale + segment%field(m)%value = rescale * segment%field(m)%value + endif + segment%field(m)%scale = scale + endif + enddo + endif + + if (segment%tr_Reg%locked) call MOM_error(FATAL, & + "MOM register_segment_tracer was called for variable "//trim(segment%tr_Reg%Tr(ntseg)%name)//& + " with a locked tracer registry.") + + if (present(OBC_scalar)) segment%tr_Reg%Tr(ntseg)%OBC_inflow_conc = OBC_scalar ! initialize tracer value later + if (present(OBC_array)) then + if (segment%is_E_or_W) then + allocate(segment%tr_Reg%Tr(ntseg)%t(IsdB:IedB,jsd:jed,1:GV%ke), source=0.0) + allocate(segment%tr_Reg%Tr(ntseg)%tres(IsdB:IedB,jsd:jed,1:GV%ke), source=0.0) + segment%tr_Reg%Tr(ntseg)%is_initialized=.false. + elseif (segment%is_N_or_S) then + allocate(segment%tr_Reg%Tr(ntseg)%t(isd:ied,JsdB:JedB,1:GV%ke), source=0.0) + allocate(segment%tr_Reg%Tr(ntseg)%tres(isd:ied,JsdB:JedB,1:GV%ke), source=0.0) + segment%tr_Reg%Tr(ntseg)%is_initialized=.false. + endif + endif + +end subroutine register_segment_tracer + +!> Clean up the segment tracer registry. +subroutine segment_tracer_registry_end(Reg) + type(segment_tracer_registry_type), pointer :: Reg !< pointer to tracer registry + +! Local variables + integer n + + if (associated(Reg)) then + do n = 1, Reg%ntseg + if (allocated(Reg%Tr(n)%t)) deallocate(Reg%Tr(n)%t) + enddo + deallocate(Reg) + endif +end subroutine segment_tracer_registry_end + +subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file) + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< Unit scaling type + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + +! Local variables + integer :: n, ntr_id + character(len=32) :: name + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + type(tracer_type), pointer :: tr_ptr => NULL() + + if (.not. associated(OBC)) return + + do n=1, OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%on_pe) cycle + + if (associated(segment%tr_Reg)) & + call MOM_error(FATAL,"register_temp_salt_segments: tracer array was previously allocated") + + name = 'temp' + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, & + OBC_array=segment%temp_segment_data_exists, scale=US%degC_to_C) + name = 'salt' + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, & + OBC_array=segment%salt_segment_data_exists, scale=US%ppt_to_S) + enddo + +end subroutine register_temp_salt_segments + +!> Sets the OBC properties of external obgc tracers, such as their source file and field name +subroutine set_obgc_segments_props(OBC,tr_name,obc_src_file_name,obc_src_field_name,lfac_in,lfac_out) + type(ocean_OBC_type),pointer :: OBC !< Open boundary structure + character(len=*), intent(in) :: tr_name !< Tracer name + character(len=*), intent(in) :: obc_src_file_name !< OBC source file name + character(len=*), intent(in) :: obc_src_field_name !< name of the field in the source file + real, intent(in) :: lfac_in !< factors for tracer reservoir inbound length scales [nondim] + real, intent(in) :: lfac_out !< factors for tracer reservoir outbound length scales [nondim] + + type(external_tracers_segments_props),pointer :: node_ptr => NULL() !pointer to type that keeps + ! the tracer segment properties + allocate(node_ptr) + node_ptr%tracer_name = trim(tr_name) + node_ptr%tracer_src_file = trim(obc_src_file_name) + node_ptr%tracer_src_field = trim(obc_src_field_name) + node_ptr%lfac_in = lfac_in + node_ptr%lfac_out = lfac_out + ! Reversed Linked List implementation! Make this new node to be the head of the list. + node_ptr%next => OBC%obgc_segments_props + OBC%obgc_segments_props => node_ptr + OBC%num_obgc_tracers = OBC%num_obgc_tracers+1 +end subroutine set_obgc_segments_props + +!> Get the OBC properties of external obgc tracers, such as their source file, field name, +!! reservoir length scale factors +subroutine get_obgc_segments_props(node, tr_name,obc_src_file_name,obc_src_field_name,lfac_in,lfac_out) + type(external_tracers_segments_props),pointer :: node !< pointer to tracer segment properties + character(len=*), intent(out) :: tr_name !< Tracer name + character(len=*), intent(out) :: obc_src_file_name !< OBC source file name + character(len=*), intent(out) :: obc_src_field_name !< name of the field in the source file + real, intent(out) :: lfac_in !< multiplicative factor for inbound reservoir length scale [nondim] + real, intent(out) :: lfac_out !< multiplicative factor for outbound reservoir length scale [nondim] + tr_name = trim(node%tracer_name) + obc_src_file_name = trim(node%tracer_src_file) + obc_src_field_name = trim(node%tracer_src_field) + lfac_in = node%lfac_in + lfac_out = node%lfac_out + node => node%next +end subroutine get_obgc_segments_props + +subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + character(len=*), intent(in) :: tr_name!< Tracer name +! Local variables + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf, ntr_id, fd_id + integer :: i, j, k, n, m + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + type(tracer_type), pointer :: tr_ptr => NULL() + + if (.not. associated(OBC)) return + + do n=1, OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%on_pe) cycle + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, tr_name) + ! get the obgc field index + fd_id = -1 + do m=1,segment%num_fields + if (lowercase(segment%field(m)%name) == lowercase(tr_name)) fd_id = m + enddo + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, OBC_array=.True., fd_index=fd_id) + enddo + +end subroutine register_obgc_segments + +subroutine fill_obgc_segments(G, GV, OBC, tr_ptr, tr_name) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(:,:,:), pointer :: tr_ptr !< Pointer to tracer field in scaled concentration + !! units, like [S ~> ppt] for salinity. + character(len=*), intent(in) :: tr_name !< Tracer name +! Local variables + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz, nt + integer :: i, j, k + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + real :: I_scale ! A factor that unscales the internal units of a tracer, like [ppt S-1 ~> 1] for salinity + + if (.not. associated(OBC)) return + call pass_var(tr_ptr, G%Domain) + nz = G%ke + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + nt=get_tracer_index(segment,tr_name) + if (nt < 0) then + call MOM_error(FATAL,"fill_obgc_segments: Did not find tracer "// tr_name) + endif + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + I_scale = 1.0 + if (segment%tr_Reg%Tr(nt)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(nt)%scale + ! Fill with Tracer values + if (segment%is_E_or_W) then + I=segment%HI%IsdB + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + if (segment%direction == OBC_DIRECTION_W) then + segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i+1,j,k) + else + segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i,j,k) + endif + OBC%tres_x(I,j,k,nt) = I_scale * segment%tr_Reg%Tr(nt)%t(I,j,k) + enddo ; enddo + else + J=segment%HI%JsdB + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + if (segment%direction == OBC_DIRECTION_S) then + segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j+1,k) + else + segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j,k) + endif + OBC%tres_y(i,J,k,nt) = I_scale * segment%tr_Reg%Tr(nt)%t(i,J,k) + enddo ; enddo + endif + segment%tr_Reg%Tr(nt)%tres(:,:,:) = segment%tr_Reg%Tr(nt)%t(:,:,:) + enddo +end subroutine fill_obgc_segments + +subroutine fill_temp_salt_segments(G, GV, US, OBC, tv) + 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 !< Unit scaling + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz + integer :: i, j, k + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + + if (.not. associated(OBC)) return + if (.not. associated(tv%T) .and. associated(tv%S)) return + ! Both temperature and salinity fields + + call pass_var(tv%T, G%Domain) + call pass_var(tv%S, G%Domain) + + nz = GV%ke + + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + ! Fill with T and S values + if (segment%is_E_or_W) then + I=segment%HI%IsdB + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + if (segment%direction == OBC_DIRECTION_W) then + segment%tr_Reg%Tr(1)%t(I,j,k) = tv%T(i+1,j,k) + segment%tr_Reg%Tr(2)%t(I,j,k) = tv%S(i+1,j,k) + else + segment%tr_Reg%Tr(1)%t(I,j,k) = tv%T(i,j,k) + segment%tr_Reg%Tr(2)%t(I,j,k) = tv%S(i,j,k) + endif + enddo ; enddo + else + J=segment%HI%JsdB + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + if (segment%direction == OBC_DIRECTION_S) then + segment%tr_Reg%Tr(1)%t(i,J,k) = tv%T(i,j+1,k) + segment%tr_Reg%Tr(2)%t(i,J,k) = tv%S(i,j+1,k) + else + segment%tr_Reg%Tr(1)%t(i,J,k) = tv%T(i,j,k) + segment%tr_Reg%Tr(2)%t(i,J,k) = tv%S(i,j,k) + endif + enddo ; enddo + endif + segment%tr_Reg%Tr(1)%tres(:,:,:) = segment%tr_Reg%Tr(1)%t(:,:,:) + segment%tr_Reg%Tr(2)%tres(:,:,:) = segment%tr_Reg%Tr(2)%t(:,:,:) + enddo + + call setup_OBC_tracer_reservoirs(G, GV, OBC) +end subroutine fill_temp_salt_segments + +!> Find the region outside of all open boundary segments and +!! make sure it is set to land mask. Gonna need to know global land +!! mask as well to get it right... +subroutine mask_outside_OBCs(G, US, param_file, OBC) + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure + type(param_file_type), intent(in) :: param_file !< Parameter file handle + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + integer :: i, j + integer :: l_seg + logical :: fatal_error = .False. + real :: min_depth ! The minimum depth for ocean points [Z ~> m] + integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2 + character(len=256) :: mesg ! Message for error messages. + real, allocatable, dimension(:,:) :: color, color2 ! For sorting inside from outside, + ! two different ways + + if (.not. associated(OBC)) return + + call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & + units="m", default=0.0, scale=US%m_to_Z, do_not_log=.true.) + ! The reference depth on a dyn_horgrid is 0, otherwise would need: min_depth = min_depth - G%Z_ref + + allocate(color(G%isd:G%ied, G%jsd:G%jed), source=0.0) + allocate(color2(G%isd:G%ied, G%jsd:G%jed), source=0.0) + + ! Paint a frame around the outside. + do j=G%jsd,G%jed + color(G%isd,j) = cedge + color(G%ied,j) = cedge + color2(G%isd,j) = cedge + color2(G%ied,j) = cedge + enddo + do i=G%isd,G%ied + color(i,G%jsd) = cedge + color(i,G%jed) = cedge + color2(i,G%jsd) = cedge + color2(i,G%jed) = cedge + enddo + + ! Set color to cland in the land. Note that this is before the land + ! mask has been initialized, set mask values based on depth. + do j=G%jsd,G%jed + do i=G%isd,G%ied + if (G%bathyT(i,j) <= min_depth) color(i,j) = cland + if (G%bathyT(i,j) <= min_depth) color2(i,j) = cland + enddo + enddo + + do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then + if (color(i,j) == 0.0) color(i,j) = cout + if (color(i+1,j) == 0.0) color(i+1,j) = cin + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + if (color(i,j) == 0.0) color(i,j) = cin + if (color(i+1,j) == 0.0) color(i+1,j) = cout + endif + enddo ; enddo + do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then + if (color(i,j) == 0.0) color(i,j) = cout + if (color(i,j+1) == 0.0) color(i,j+1) = cin + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + if (color(i,j) == 0.0) color(i,j) = cin + if (color(i,j+1) == 0.0) color(i,j+1) = cout + endif + enddo ; enddo + + do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then + if (color2(i,j) == 0.0) color2(i,j) = cout + if (color2(i,j+1) == 0.0) color2(i,j+1) = cin + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + if (color2(i,j) == 0.0) color2(i,j) = cin + if (color2(i,j+1) == 0.0) color2(i,j+1) = cout + endif + enddo ; enddo + do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then + if (color2(i,j) == 0.0) color2(i,j) = cout + if (color2(i+1,j) == 0.0) color2(i+1,j) = cin + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + if (color2(i,j) == 0.0) color2(i,j) = cin + if (color2(i+1,j) == 0.0) color2(i+1,j) = cout + endif + enddo ; enddo + + ! Do the flood fill until there are no more uncolored cells. + call flood_fill(G, color, cin, cout, cland) + call flood_fill2(G, color2, cin, cout, cland) + + ! Use the color to set outside to min_depth on this process. + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if (color(i,j) /= color2(i,j)) then + fatal_error = .True. + write(mesg,'("MOM_open_boundary: problem with OBC segments specification at ",I5,",",I5," during\n", & + &"the masking of the outside grid points.")') i, j + call MOM_error(WARNING,"MOM mask_outside_OBCs: "//mesg, all_print=.true.) + endif + if (color(i,j) == cout) G%bathyT(i,j) = min_depth + enddo ; enddo + if (fatal_error) call MOM_error(FATAL, & + "MOM_open_boundary: inconsistent OBC segments.") + + deallocate(color) + deallocate(color2) +end subroutine mask_outside_OBCs + +!> flood the cin, cout values +subroutine flood_fill(G, color, cin, cout, cland) + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure + real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside + integer, intent(in) :: cin !< color for inside the domain + integer, intent(in) :: cout !< color for outside the domain + integer, intent(in) :: cland !< color for inside the land mask + +! Local variables + integer :: i, j, ncount + + ncount = 1 + do while (ncount > 0) + ncount = 0 + do j=G%jsd+1,G%jed-1 + do i=G%isd+1,G%ied-1 + if (color(i,j) == 0.0 .and. color(i-1,j) > 0.0) then + color(i,j) = color(i-1,j) + ncount = ncount + 1 + endif + if (color(i,j) == 0.0 .and. color(i+1,j) > 0.0) then + color(i,j) = color(i+1,j) + ncount = ncount + 1 + endif + if (color(i,j) == 0.0 .and. color(i,j-1) > 0.0) then + color(i,j) = color(i,j-1) + ncount = ncount + 1 + endif + if (color(i,j) == 0.0 .and. color(i,j+1) > 0.0) then + color(i,j) = color(i,j+1) + ncount = ncount + 1 + endif + enddo + enddo + do j=G%jed-1,G%jsd+1,-1 + do i=G%ied-1,G%isd+1,-1 + if (color(i,j) == 0.0 .and. color(i-1,j) > 0.0) then + color(i,j) = color(i-1,j) + ncount = ncount + 1 + endif + if (color(i,j) == 0.0 .and. color(i+1,j) > 0.0) then + color(i,j) = color(i+1,j) + ncount = ncount + 1 + endif + if (color(i,j) == 0.0 .and. color(i,j-1) > 0.0) then + color(i,j) = color(i,j-1) + ncount = ncount + 1 + endif + if (color(i,j) == 0.0 .and. color(i,j+1) > 0.0) then + color(i,j) = color(i,j+1) + ncount = ncount + 1 + endif + enddo + enddo + call pass_var(color, G%Domain) + call sum_across_PEs(ncount) + enddo + +end subroutine flood_fill + +!> flood the cin, cout values +subroutine flood_fill2(G, color, cin, cout, cland) + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure + real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside + integer, intent(in) :: cin !< color for inside the domain + integer, intent(in) :: cout !< color for outside the domain + integer, intent(in) :: cland !< color for inside the land mask + +! Local variables + integer :: i, j, ncount + + ncount = 1 + do while (ncount > 0) + ncount = 0 + do i=G%isd+1,G%ied-1 + do j=G%jsd+1,G%jed-1 + if (color(i,j) == 0.0 .and. color(i-1,j) > 0.0) then + color(i,j) = color(i-1,j) + ncount = ncount + 1 + endif + if (color(i,j) == 0.0 .and. color(i+1,j) > 0.0) then + color(i,j) = color(i+1,j) + ncount = ncount + 1 + endif + if (color(i,j) == 0.0 .and. color(i,j-1) > 0.0) then + color(i,j) = color(i,j-1) + ncount = ncount + 1 + endif + if (color(i,j) == 0.0 .and. color(i,j+1) > 0.0) then + color(i,j) = color(i,j+1) + ncount = ncount + 1 + endif + enddo + enddo + do i=G%ied-1,G%isd+1,-1 + do j=G%jed-1,G%jsd+1,-1 + if (color(i,j) == 0.0 .and. color(i-1,j) > 0.0) then + color(i,j) = color(i-1,j) + ncount = ncount + 1 + endif + if (color(i,j) == 0.0 .and. color(i+1,j) > 0.0) then + color(i,j) = color(i+1,j) + ncount = ncount + 1 + endif + if (color(i,j) == 0.0 .and. color(i,j-1) > 0.0) then + color(i,j) = color(i,j-1) + ncount = ncount + 1 + endif + if (color(i,j) == 0.0 .and. color(i,j+1) > 0.0) then + color(i,j) = color(i,j+1) + ncount = ncount + 1 + endif + enddo + enddo + call pass_var(color, G%Domain) + call sum_across_PEs(ncount) + enddo + +end subroutine flood_fill2 + +!> Register OBC segment data for restarts +subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, restart_CS, & + use_temperature) + type(hor_index_type), intent(in) :: HI !< Horizontal indices + type(verticalGrid_type), pointer :: GV !< Container for vertical grid information + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), pointer :: OBC !< OBC data structure, data intent(inout) + type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry + type(param_file_type), intent(in) :: param_file !< Parameter file handle + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + logical, intent(in) :: use_temperature !< If true, T and S are used + ! Local variables + type(vardesc) :: vd(2) + integer :: m + character(len=100) :: mesg, var_name + + if (.not. associated(OBC)) & + call MOM_error(FATAL, "open_boundary_register_restarts: Called with "//& + "uninitialized OBC control structure") + + ! ### This is a temporary work around for restarts with OBC segments. + ! This implementation uses 3D arrays solely for restarts. We need + ! to be able to add 2D ( x,z or y,z ) data to restarts to avoid using + ! so much memory and disk space. + if (OBC%radiation_BCs_exist_globally) then + allocate(OBC%rx_normal(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke), source=0.0) + allocate(OBC%ry_normal(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) + + vd(1) = var_desc("rx_normal", "gridpoint timestep-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') + vd(2) = var_desc("ry_normal", "gridpoint timestep-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') + call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), .false., restart_CS) + ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid + ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to + ! permit timesteps to change between calls to the OBC code, the following would be needed instead: + ! vd(1) = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') + ! vd(2) = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') + ! call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), .false., restart_CS, & + ! conversion=US%L_T_to_m_s) + endif + + if (OBC%oblique_BCs_exist_globally) then + allocate(OBC%rx_oblique_u(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke), source=0.0) + allocate(OBC%ry_oblique_u(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke), source=0.0) + allocate(OBC%cff_normal_u(HI%IsdB:HI%IedB,HI%jsd:HI%jed,GV%ke), source=0.0) + allocate(OBC%rx_oblique_v(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) + allocate(OBC%ry_oblique_v(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) + allocate(OBC%cff_normal_v(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) + + vd(1) = var_desc("rx_oblique_u", "m2 s-2", "X-Direction Radiation Speed Squared for EW oblique OBCs", 'u', 'L') + vd(2) = var_desc("ry_oblique_v", "m2 s-2", "Y-Direction Radiation Speed Squared for NS oblique OBCs", 'v', 'L') + call register_restart_pair(OBC%rx_oblique_u, OBC%ry_oblique_v, vd(1), vd(2), .false., & + restart_CS, conversion=US%L_T_to_m_s**2) + vd(1) = var_desc("ry_oblique_u", "m2 s-2", "Y-Direction Radiation Speed Squared for EW oblique OBCs", 'u', 'L') + vd(2) = var_desc("rx_oblique_v", "m2 s-2", "X-Direction Radiation Speed Squared for NS oblique OBCs", 'v', 'L') + call register_restart_pair(OBC%ry_oblique_u, OBC%rx_oblique_v, vd(1), vd(2), .false., & + restart_CS, conversion=US%L_T_to_m_s**2) + + vd(1) = var_desc("norm_oblique_u", "m2 s-2", "Denominator for normalizing EW oblique OBC radiation rates", & + 'u', 'L') + vd(2) = var_desc("norm_oblique_v", "m2 s-2", "Denominator for normalizing NS oblique OBC radiation rates", & + 'v', 'L') + call register_restart_pair(OBC%cff_normal_u, OBC%cff_normal_v, vd(1), vd(2), .false., & + restart_CS, conversion=US%L_T_to_m_s**2) + endif + + if (Reg%ntr == 0) return + if (.not. allocated(OBC%tracer_x_reservoirs_used)) then + OBC%ntr = Reg%ntr + allocate(OBC%tracer_x_reservoirs_used(Reg%ntr), source=.false.) + allocate(OBC%tracer_y_reservoirs_used(Reg%ntr), source=.false.) + call parse_for_tracer_reservoirs(OBC, param_file, use_temperature) + else + ! This would be coming from user code such as DOME. + if (OBC%ntr /= Reg%ntr) then +! call MOM_error(FATAL, "open_boundary_register_restarts: Inconsistent value for ntr") + write(mesg,'("Inconsistent values for ntr ", I8," and ",I8,".")') OBC%ntr, Reg%ntr + call MOM_error(WARNING, 'open_boundary_register_restarts: '//mesg) + endif + endif + + ! Still painfully inefficient, now in four dimensions. + if (any(OBC%tracer_x_reservoirs_used)) then + allocate(OBC%tres_x(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke,OBC%ntr), source=0.0) + do m=1,OBC%ntr + if (OBC%tracer_x_reservoirs_used(m)) then + if (modulo(HI%turns, 2) /= 0) then + write(var_name,'("tres_y_",I3.3)') m + call register_restart_field(OBC%tres_x(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for NS OBCs", units="Conc", hor_grid='v') + else + write(var_name,'("tres_x_",I3.3)') m + call register_restart_field(OBC%tres_x(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for EW OBCs", units="Conc", hor_grid='u') + endif + endif + enddo + endif + if (any(OBC%tracer_y_reservoirs_used)) then + allocate(OBC%tres_y(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke,OBC%ntr), source=0.0) + do m=1,OBC%ntr + if (OBC%tracer_y_reservoirs_used(m)) then + if (modulo(HI%turns, 2) /= 0) then + write(var_name,'("tres_x_",I3.3)') m + call register_restart_field(OBC%tres_y(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for EW OBCs", units="Conc", hor_grid='u') + else + write(var_name,'("tres_y_",I3.3)') m + call register_restart_field(OBC%tres_y(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for NS OBCs", units="Conc", hor_grid='v') + endif + endif + enddo + endif + +end subroutine open_boundary_register_restarts + +!> Update the OBC tracer reservoirs after the tracers have been updated. +subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uhr !< accumulated volume/mass flux through + !! the zonal face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vhr !< accumulated volume/mass flux through + !! the meridional face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness after advection + !! [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, intent(in) :: dt !< time increment [T ~> s] + type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry + + ! Local variable + type(OBC_segment_type), pointer :: segment=>NULL() + real :: u_L_in, u_L_out ! The zonal distance moved in or out of a cell, normalized by the reservoir + ! length scale [nondim] + real :: v_L_in, v_L_out ! The meridional distance moved in or out of a cell, normalized by the reservoir + ! length scale [nondim] + real :: fac1 ! The denominator of the expression for tracer updates [nondim] + real :: I_scale ! The inverse of the scaling factor for the tracers. + ! For salinity the units would be [ppt S-1 ~> 1] + integer :: i, j, k, m, n, ntr, nz, ntr_id, fd_id + integer :: ishift, idir, jshift, jdir + real :: resrv_lfac_out, resrv_lfac_in + real :: b_in, b_out ! The 0 and 1 switch for tracer reservoirs + ! 1 if the length scale of reservoir is zero [nondim] + real :: a_in, a_out ! The 0 and 1(-1) switch for reservoir source weights + ! e.g. a_in is -1 only if b_in ==1 and uhr or vhr is inward + ! e.g. a_out is 1 only if b_out==1 and uhr or vhr is outward + ! It's clear that a_in and a_out cannot be both non-zero [nondim] + nz = GV%ke + ntr = Reg%ntr + + if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. associated(segment%tr_Reg)) cycle + b_in = 0.0; if (segment%Tr_InvLscale_in == 0.0) b_in = 1.0 + b_out = 0.0; if (segment%Tr_InvLscale_out == 0.0) b_out = 1.0 + if (segment%is_E_or_W) then + I = segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + ! ishift+I corresponds to the nearest interior tracer cell index + ! idir switches the sign of the flow so that positive is into the reservoir + if (segment%direction == OBC_DIRECTION_W) then + ishift = 1 ; idir = -1 + else + ishift = 0 ; idir = 1 + endif + ! Can keep this or take it out, either way + if (G%mask2dT(I+ishift,j) == 0.0) cycle + ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index + fd_id = segment%tr_reg%Tr(m)%fd_index + if (fd_id == -1) then + resrv_lfac_out = 1.0 + resrv_lfac_in = 1.0 + else + resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out + resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in + endif + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz + ! Calculate weights. Both a and u_L are nodim. Adding them together has no meaning. + ! However, since they cannot be both non-zero, adding them works like a switch. + ! When InvLscale_out is 0 and outflow, only interior data is applied to reservoirs + ! When InvLscale_in is 0 and inflow, only nudged data is applied to reservoirs + a_out = b_out * max(0.0, sign(1.0, idir*uhr(I,j,k))) + a_in = b_in * min(0.0, sign(1.0, idir*uhr(I,j,k))) + u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out*resrv_lfac_out / & + ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) + u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in*resrv_lfac_in / & + ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) + fac1 = (1.0 - (a_out - a_in)) + ((u_L_out + a_out) - (u_L_in + a_in)) + segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1) * & + ((1.0-a_out+a_in)*segment%tr_Reg%Tr(m)%tres(I,j,k)+ & + ((u_L_out+a_out)*Reg%Tr(ntr_id)%t(I+ishift,j,k) - & + (u_L_in+a_in)*segment%tr_Reg%Tr(m)%t(I,j,k))) + if (allocated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(I,j,k) + enddo ; endif + enddo + enddo + elseif (segment%is_N_or_S) then + J = segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + ! jshift+J corresponds to the nearest interior tracer cell index + ! jdir switches the sign of the flow so that positive is into the reservoir + if (segment%direction == OBC_DIRECTION_S) then + jshift = 1 ; jdir = -1 + else + jshift = 0 ; jdir = 1 + endif + ! Can keep this or take it out, either way + if (G%mask2dT(i,j+jshift) == 0.0) cycle + ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index + fd_id = segment%tr_reg%Tr(m)%fd_index + if (fd_id == -1) then + resrv_lfac_out = 1.0 + resrv_lfac_in = 1.0 + else + resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out + resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in + endif + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz + a_out = b_out * max(0.0, sign(1.0, jdir*vhr(i,J,k))) + a_in = b_in * min(0.0, sign(1.0, jdir*vhr(i,J,k))) + v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out*resrv_lfac_out / & + ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) + v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in*resrv_lfac_in / & + ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) + fac1 = (1.0 - (a_out - a_in)) + ((v_L_out + a_out) - (v_L_in + a_in)) + segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1) * & + ((1.0-a_out+a_in)*segment%tr_Reg%Tr(m)%tres(i,J,k) + & + ((v_L_out+a_out)*Reg%Tr(ntr_id)%t(i,J+jshift,k) - & + (v_L_in+a_in)*segment%tr_Reg%Tr(m)%t(i,J,k))) + if (allocated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k) + enddo ; endif + enddo + enddo + endif + enddo ; endif ; endif + +end subroutine update_segment_tracer_reservoirs + +!> Vertically remap the OBC tracer reservoirs and radiation rates that are filtered in time. +subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: PCM_cell !< Use PCM remapping in cells where true + + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() ! A pointer to the various segments, used just for shorthand. + + real :: tr_column(GV%ke) ! A column of updated tracer concentrations in internally scaled units. + ! For salinity the units would be [S ~> ppt]. + real :: r_norm_col(GV%ke) ! A column of updated radiation rates, in grid points per timestep [nondim] + real :: rxy_col(GV%ke) ! A column of updated radiation rates for oblique OBCs [L2 T-2 ~> m2 s-2] + real :: h1(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] + real :: h2(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] + real :: I_scale ! The inverse of the scaling factor for the tracers. + ! For salinity the units would be [ppt S-1 ~> 1]. + real :: h_neglect ! Tiny thickness used in remapping [H ~> m or kg m-2] + logical :: PCM(GV%ke) ! If true, do PCM remapping from a cell. + integer :: i, j, k, m, n, ntr, nz + + if (.not.associated(OBC)) return + + nz = GV%ke + ntr = OBC%ntr + h_neglect = GV%H_subroundoff + + if (.not.present(PCM_cell)) PCM(:) = .false. + + if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (.not.associated(segment%tr_Reg)) cycle + + if (segment%is_E_or_W) then + I = segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + + ! Store a column of the start and final grids + if (segment%direction == OBC_DIRECTION_W) then + if (G%mask2dT(i+1,j) == 0.0) cycle + h1(:) = h_old(i+1,j,:) + h2(:) = h_new(i+1,j,:) + if (present(PCM_cell)) then ; PCM(:) = PCM_cell(i+1,j,:) ; endif + else + if (G%mask2dT(i,j) == 0.0) cycle + h1(:) = h_old(i,j,:) + h2(:) = h_new(i,j,:) + if (present(PCM_cell)) then ; PCM(:) = PCM_cell(i,j,:) ; endif + endif + + ! Vertically remap the reservoir tracer concentrations + do m=1,ntr ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + + if (present(PCM_cell)) then + call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(I,j,:), nz, h2, tr_column, & + h_neglect, h_neglect, PCM_cell=PCM) + else + call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(I,j,:), nz, h2, tr_column, & + h_neglect, h_neglect) + endif + + ! Possibly underflow any very tiny tracer concentrations to 0? + + ! Update tracer concentrations + segment%tr_Reg%Tr(m)%tres(I,j,:) = tr_column(:) + if (allocated(OBC%tres_x)) then ; do k=1,nz + OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(I,j,k) + enddo ; endif + + endif ; enddo + + if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then + call remapping_core_h(OBC%remap_CS, nz, h1, segment%rx_norm_rad(I,j,:), nz, h2, r_norm_col, & + h_neglect, h_neglect, PCM_cell=PCM) + + do k=1,nz + segment%rx_norm_rad(I,j,k) = r_norm_col(k) + OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) + enddo + endif + + if (segment%oblique .and. (OBC%gamma_uv < 1.0)) then + call remapping_core_h(OBC%remap_CS, nz, h1, segment%rx_norm_obl(I,j,:), nz, h2, rxy_col, & + h_neglect, h_neglect, PCM_cell=PCM) + segment%rx_norm_obl(I,j,:) = rxy_col(:) + call remapping_core_h(OBC%remap_CS, nz, h1, segment%ry_norm_obl(I,j,:), nz, h2, rxy_col, & + h_neglect, h_neglect, PCM_cell=PCM) + segment%ry_norm_obl(I,j,:) = rxy_col(:) + call remapping_core_h(OBC%remap_CS, nz, h1, segment%cff_normal(I,j,:), nz, h2, rxy_col, & + h_neglect, h_neglect, PCM_cell=PCM) + segment%cff_normal(I,j,:) = rxy_col(:) + + do k=1,nz + OBC%rx_oblique_u(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique_u(I,j,k) = segment%ry_norm_obl(I,j,k) + OBC%cff_normal_u(I,j,k) = segment%cff_normal(I,j,k) + enddo + endif + + enddo + elseif (segment%is_N_or_S) then + J = segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + + ! Store a column of the start and final grids + if (segment%direction == OBC_DIRECTION_S) then + if (G%mask2dT(i,j+1) == 0.0) cycle + h1(:) = h_old(i,j+1,:) + h2(:) = h_new(i,j+1,:) + if (present(PCM_cell)) then ; PCM(:) = PCM_cell(i,j+1,:) ; endif + else + if (G%mask2dT(i,j) == 0.0) cycle + h1(:) = h_old(i,j,:) + h2(:) = h_new(i,j,:) + if (present(PCM_cell)) then ; PCM(:) = PCM_cell(i,j,:) ; endif + endif + + ! Vertically remap the reservoir tracer concentrations + do m=1,ntr ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + + if (present(PCM_cell)) then + call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,J,:), nz, h2, tr_column, & + h_neglect, h_neglect, PCM_cell=PCM) + else + call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,J,:), nz, h2, tr_column, & + h_neglect, h_neglect) + endif + + ! Possibly underflow any very tiny tracer concentrations to 0? + + ! Update tracer concentrations + segment%tr_Reg%Tr(m)%tres(i,J,:) = tr_column(:) + if (allocated(OBC%tres_y)) then ; do k=1,nz + OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k) + enddo ; endif + + endif ; enddo + + if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then + call remapping_core_h(OBC%remap_CS, nz, h1, segment%ry_norm_rad(i,J,:), nz, h2, r_norm_col, & + h_neglect, h_neglect, PCM_cell=PCM) + + do k=1,nz + segment%ry_norm_rad(i,J,k) = r_norm_col(k) + OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) + enddo + endif + + if (segment%oblique .and. (OBC%gamma_uv < 1.0)) then + call remapping_core_h(OBC%remap_CS, nz, h1, segment%rx_norm_obl(i,J,:), nz, h2, rxy_col, & + h_neglect, h_neglect, PCM_cell=PCM) + segment%rx_norm_obl(i,J,:) = rxy_col(:) + call remapping_core_h(OBC%remap_CS, nz, h1, segment%ry_norm_obl(i,J,:), nz, h2, rxy_col, & + h_neglect, h_neglect, PCM_cell=PCM) + segment%ry_norm_obl(i,J,:) = rxy_col(:) + call remapping_core_h(OBC%remap_CS, nz, h1, segment%cff_normal(i,J,:), nz, h2, rxy_col, & + h_neglect, h_neglect, PCM_cell=PCM) + segment%cff_normal(i,J,:) = rxy_col(:) + + do k=1,nz + OBC%rx_oblique_v(i,J,k) = segment%rx_norm_obl(i,J,k) + OBC%ry_oblique_v(i,J,k) = segment%ry_norm_obl(i,J,k) + OBC%cff_normal_v(i,J,k) = segment%cff_normal(i,J,k) + enddo + endif + + enddo + endif + enddo ; endif ; endif + if (OBC%radiation_BCs_exist_globally) call pass_vector(OBC%rx_normal, OBC%ry_normal, G%Domain, & + To_All+Scalar_Pair) + if (OBC%oblique_BCs_exist_globally) then + call do_group_pass(OBC%pass_oblique, G%Domain) + endif + +end subroutine remap_OBC_fields + + +!> Adjust interface heights to fit the bathymetry and diagnose layer thickness. +!! +!! If the bottom most interface is below the topography then the bottom-most +!! layers are contracted to GV%Angstrom_Z. +!! If the bottom most interface is above the topography then the entire column +!! is dilated (expanded) to fill the void. +!! @remark{There is a (hard-wired) "tolerance" parameter such that the +!! criteria for adjustment must equal or exceed 10cm.} +subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(OBC_segment_type), intent(inout) :: segment !< OBC segment + integer, intent(in) :: fld !< field index to adjust thickness + + integer :: i, j, k, is, ie, js, je, nz, contractions, dilations + real, allocatable, dimension(:,:,:) :: eta ! Segment source data interface heights [Z ~> m] + real :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria [Z ~> m] + ! real :: dilate ! A factor by which to dilate the water column [nondim] + !character(len=100) :: mesg + + hTolerance = 0.1*US%m_to_Z + + nz = size(segment%field(fld)%dz_src,3) + + if (segment%is_E_or_W) then + ! segment thicknesses are defined at cell face centers. + is = segment%HI%isdB ; ie = segment%HI%iedB + js = segment%HI%jsd ; je = segment%HI%jed + else + is = segment%HI%isd ; ie = segment%HI%ied + js = segment%HI%jsdB ; je = segment%HI%jedB + endif + allocate(eta(is:ie,js:je,nz+1)) + contractions=0; dilations=0 + do j=js,je ; do i=is,ie + eta(i,j,1) = 0.0 ! segment data are assumed to be located on a static grid + ! For remapping calls, the entire column will be dilated + ! by a factor equal to the ratio of the sum of the geopotential referenced + ! source data thicknesses, and the current model thicknesses. This could be + ! an issue to be addressed, for instance if we are placing open boundaries + ! under ice shelf cavities. + do k=2,nz+1 + eta(i,j,k) = eta(i,j,k-1) - segment%field(fld)%dz_src(i,j,k-1) + enddo + ! The normal slope at the boundary is zero by a + ! previous call to open_boundary_impose_normal_slope + do k=nz+1,1,-1 + if (-eta(i,j,k) > segment%dZtot(i,j) + hTolerance) then + eta(i,j,k) = -segment%dZtot(i,j) + contractions = contractions + 1 + endif + enddo + + do k=1,nz + ! Collapse layers to thinnest possible if the thickness less than + ! the thinnest possible (or negative). + if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) then + eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z + segment%field(fld)%dz_src(i,j,k) = GV%Angstrom_Z + else + segment%field(fld)%dz_src(i,j,k) = (eta(i,j,K) - eta(i,j,K+1)) + endif + enddo + + ! The whole column is dilated to accommodate deeper topography than + ! the bathymetry would indicate. + if (-eta(i,j,nz+1) < segment%dZtot(i,j) - hTolerance) then + dilations = dilations + 1 + ! expand bottom-most cell only + eta(i,j,nz+1) = -segment%dZtot(i,j) + segment%field(fld)%dz_src(i,j,nz) = eta(i,j,nz) - eta(i,j,nz+1) + ! if (eta(i,j,1) <= eta(i,j,nz+1)) then + ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = (eta(i,j,1) + G%bathyT(i,j)) / real(nz) ; enddo + ! else + ! dilate = (eta(i,j,1) + G%bathyT(i,j)) / (eta(i,j,1) - eta(i,j,nz+1)) + ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = segment%field(fld)%dz_src(i,j,k) * dilate ; enddo + ! endif + !do k=nz,2,-1 ; eta(i,j,K) = eta(i,j,K+1) + segment%field(fld)%dz_src(i,j,k) ; enddo + endif + enddo ; enddo + + ! can not do communication call here since only PEs on the current segment are here + + ! call sum_across_PEs(contractions) + ! if ((contractions > 0) .and. (is_root_pe())) then + ! write(mesg,'("Thickness OBCs were contracted ",'// & + ! '"to fit topography in ",I8," places.")') contractions + ! call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) + ! endif + ! call sum_across_PEs(dilations) + ! if ((dilations > 0) .and. (is_root_pe())) then + ! write(mesg,'("Thickness OBCs were dilated ",'// & + ! '"to fit topography in ",I8," places.")') dilations + ! call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) + ! endif + deallocate(eta) + +end subroutine adjustSegmentEtaToFitBathymetry + +!> This is more of a rotate initialization than an actual rotate +subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) + type(ocean_OBC_type), pointer, intent(in) :: OBC_in !< Input OBC + type(dyn_horgrid_type), intent(in) :: G_in !< Input grid metric + type(ocean_OBC_type), pointer, intent(inout) :: OBC !< Rotated OBC + type(dyn_horgrid_type), intent(in) :: G !< Rotated grid metric + integer, intent(in) :: turns !< Number of quarter turns + + integer :: l + + if (OBC_in%number_of_segments==0) return + + ! Scalar and logical transfer + OBC%number_of_segments = OBC_in%number_of_segments + OBC%ke = OBC_in%ke + OBC%user_BCs_set_globally = OBC_in%user_BCs_set_globally + + ! These are conditionally read and set if number_of_segments > 0 + OBC%zero_vorticity = OBC_in%zero_vorticity + OBC%freeslip_vorticity = OBC_in%freeslip_vorticity + OBC%computed_vorticity = OBC_in%computed_vorticity + OBC%specified_vorticity = OBC_in%specified_vorticity + OBC%zero_strain = OBC_in%zero_strain + OBC%freeslip_strain = OBC_in%freeslip_strain + OBC%computed_strain = OBC_in%computed_strain + OBC%specified_strain = OBC_in%specified_strain + OBC%zero_biharmonic = OBC_in%zero_biharmonic + OBC%silly_h = OBC_in%silly_h + OBC%silly_u = OBC_in%silly_u + + ! Segment rotation + allocate(OBC%segment(0:OBC%number_of_segments)) + do l = 1, OBC%number_of_segments + call rotate_OBC_segment_config(OBC_in%segment(l), G_in, OBC%segment(l), G, turns) + ! Data up to setup_[uv]_point_obc is needed for allocate_obc_segment_data! + call allocate_OBC_segment_data(OBC, OBC%segment(l)) + call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), turns) + enddo + + ! The horizontal segment map + allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed)) + allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB)) + call rotate_array_pair(OBC_in%segnum_u, OBC_in%segnum_v, turns, & + OBC%segnum_u, OBC%segnum_v) + + ! These are conditionally enabled during segment configuration + OBC%open_u_BCs_exist_globally = OBC_in%open_v_BCs_exist_globally + OBC%open_v_BCs_exist_globally = OBC_in%open_u_BCs_exist_globally + OBC%Flather_u_BCs_exist_globally = OBC_in%Flather_v_BCs_exist_globally + OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_u_BCs_exist_globally + OBC%oblique_BCs_exist_globally = OBC_in%oblique_BCs_exist_globally + OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally + OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally + OBC%specified_u_BCs_exist_globally= OBC_in%specified_v_BCs_exist_globally + OBC%specified_v_BCs_exist_globally= OBC_in%specified_u_BCs_exist_globally + OBC%radiation_BCs_exist_globally = OBC_in%radiation_BCs_exist_globally + + ! These are set by initialize_segment_data + OBC%brushcutter_mode = OBC_in%brushcutter_mode + OBC%update_OBC = OBC_in%update_OBC + OBC%needs_IO_for_data = OBC_in%needs_IO_for_data + OBC%any_needs_IO_for_data = OBC_in%any_needs_IO_for_data + OBC%some_need_no_IO_for_data = OBC_in%some_need_no_IO_for_data + + OBC%ntr = OBC_in%ntr + + OBC%gamma_uv = OBC_in%gamma_uv + OBC%rx_max = OBC_in%rx_max + OBC%OBC_pe = OBC_in%OBC_pe + + ! remap_CS is set up by initialize_segment_data, so we copy the fields here. + if (ASSOCIATED(OBC_in%remap_CS)) then + allocate(OBC%remap_CS) + OBC%remap_CS = OBC_in%remap_CS + endif + + ! TODO: The OBC registry seems to be a list of "registered" OBC types. + ! It does not appear to be used, so for now we skip this record. + !OBC%OBC_Reg => OBC_in%OBC_Reg +end subroutine rotate_OBC_config + +!> Rotate the OBC segment configuration data from the input to model index map. +subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) + type(OBC_segment_type), intent(in) :: segment_in !< Input OBC segment + type(dyn_horgrid_type), intent(in) :: G_in !< Input grid metric + type(OBC_segment_type), intent(inout) :: segment !< Rotated OBC segment + type(dyn_horgrid_type), intent(in) :: G !< Rotated grid metric + integer, intent(in) :: turns !< Number of quarter turns + + ! Global segment indices + integer :: Is_obc_in, Ie_obc_in, Js_obc_in, Je_obc_in ! Input domain + integer :: Is_obc, Ie_obc, Js_obc, Je_obc ! Rotated domain + + ! NOTE: A "rotation" of the OBC segment string would allow us to use + ! setup_[uv]_point_obc to set up most of this. For now, we just copy/swap + ! flags and manually rotate the indices. + + ! This is set if the segment is in the local grid + segment%on_pe = segment_in%on_pe + + ! Transfer configuration flags + segment%Flather = segment_in%Flather + segment%radiation = segment_in%radiation + segment%radiation_tan = segment_in%radiation_tan + segment%radiation_grad = segment_in%radiation_grad + segment%oblique = segment_in%oblique + segment%oblique_tan = segment_in%oblique_tan + segment%oblique_grad = segment_in%oblique_grad + segment%nudged = segment_in%nudged + segment%nudged_tan = segment_in%nudged_tan + segment%nudged_grad = segment_in%nudged_grad + segment%specified = segment_in%specified + segment%specified_tan = segment_in%specified_tan + segment%specified_grad = segment_in%specified_grad + segment%open = segment_in%open + segment%gradient = segment_in%gradient + + ! NOTE: [uv]_values_needed are swapped + segment%u_values_needed = segment_in%v_values_needed + segment%v_values_needed = segment_in%u_values_needed + segment%z_values_needed = segment_in%z_values_needed + segment%g_values_needed = segment_in%g_values_needed + segment%t_values_needed = segment_in%t_values_needed + segment%s_values_needed = segment_in%s_values_needed + + segment%values_needed = segment_in%values_needed + + ! These are conditionally set if nudged + segment%Velocity_nudging_timescale_in = segment_in%Velocity_nudging_timescale_in + segment%Velocity_nudging_timescale_out= segment_in%Velocity_nudging_timescale_out + + ! Rotate segment indices + + ! Reverse engineer the input [IJ][se]_obc segment indices + ! NOTE: The values stored in the segment are always saved in ascending order, + ! e.g. (is < ie). In order to use setup_segment_indices, we reorder the + ! indices here to indicate face direction. + ! Segment indices are also indexed locally, so we remove the halo offset. + if (segment_in%direction == OBC_DIRECTION_N) then + Is_obc_in = segment_in%Ie_obc + G_in%idg_offset + Ie_obc_in = segment_in%Is_obc + G_in%idg_offset + else + Is_obc_in = segment_in%Is_obc + G_in%idg_offset + Ie_obc_in = segment_in%Ie_obc + G_in%idg_offset + endif + + if (segment_in%direction == OBC_DIRECTION_W) then + Js_obc_in = segment_in%Je_obc + G_in%jdg_offset + Je_obc_in = segment_in%Js_obc + G_in%jdg_offset + else + Js_obc_in = segment_in%Js_obc + G_in%jdg_offset + Je_obc_in = segment_in%Je_obc + G_in%jdg_offset + endif + + ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. + Is_obc = G_in%jegB - Js_obc_in + Ie_obc = G_in%JegB - Je_obc_in + Js_obc = Is_obc_in + Je_obc = Ie_obc_in + + ! Orientation is based on the index ordering, [IJ][se]_obc are re-ordered + ! after the index is set. So we now need to restore the original order + + call setup_segment_indices(G, segment, Is_obc, Ie_obc, Js_obc, Je_obc) + + ! Re-order [IJ][se]_obc back to ascending, and remove the halo offset. + if (Is_obc > Ie_obc) then + segment%Is_obc = Ie_obc - G%idg_offset + segment%Ie_obc = Is_obc - G%idg_offset + else + segment%Is_obc = Is_obc - G%idg_offset + segment%Ie_obc = Ie_obc - G%idg_offset + endif + + if (Js_obc > Je_obc) then + segment%Js_obc = Je_obc - G%jdg_offset + segment%Je_obc = Js_obc - G%jdg_offset + else + segment%Js_obc = Js_obc - G%jdg_offset + segment%Je_obc = Je_obc - G%jdg_offset + endif + + ! Reconfigure the directional flags + ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. + select case (segment_in%direction) + case (OBC_DIRECTION_N) + segment%direction = OBC_DIRECTION_W + segment%is_E_or_W_2 = segment_in%is_N_or_S + segment%is_E_or_W = segment_in%is_N_or_S .and. segment_in%on_pe + segment%is_N_or_S = .false. + case (OBC_DIRECTION_W) + segment%direction = OBC_DIRECTION_S + segment%is_N_or_S = segment_in%is_E_or_W + segment%is_E_or_W = .false. + segment%is_E_or_W_2 = .false. + case (OBC_DIRECTION_S) + segment%direction = OBC_DIRECTION_E + segment%is_E_or_W_2 = segment_in%is_N_or_S + segment%is_E_or_W = segment_in%is_N_or_S .and. segment_in%on_pe + segment%is_N_or_S = .false. + case (OBC_DIRECTION_E) + segment%direction = OBC_DIRECTION_N + segment%is_N_or_S = segment_in%is_E_or_W + segment%is_E_or_W = .false. + segment%is_E_or_W_2 = .false. + case (OBC_NONE) + segment%direction = OBC_NONE + end select + + ! These are conditionally set if Lscale_{in,out} are present + segment%Tr_InvLscale_in = segment_in%Tr_InvLscale_in + segment%Tr_InvLscale_out = segment_in%Tr_InvLscale_out +end subroutine rotate_OBC_segment_config + + +!> Initialize the segments and field-related data of a rotated OBC. +subroutine rotate_OBC_init(OBC_in, G, GV, US, param_file, tv, restart_CS, OBC) + type(ocean_OBC_type), intent(in) :: OBC_in !< OBC on input map + type(ocean_grid_type), intent(in) :: G !< Rotated grid metric + type(verticalGrid_type), intent(in) :: GV !< Vertical grid + type(unit_scale_type), intent(in) :: US !< Unit scaling + type(param_file_type), intent(in) :: param_file !< Input parameters + type(thermo_var_ptrs), intent(inout) :: tv !< Tracer fields + type(MOM_restart_CS), intent(in) :: restart_CS !< Restart CS + type(ocean_OBC_type), pointer, intent(inout) :: OBC !< Rotated OBC + + logical :: use_temperature + integer :: l + + call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, & + "If true, Temperature and salinity are used as state "//& + "variables.", default=.true., do_not_log=.true.) + + do l = 1, OBC%number_of_segments + call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), G%HI%turns) + enddo + + if (use_temperature) & + call fill_temp_salt_segments(G, GV, US, OBC, tv) + + call open_boundary_init(G, GV, US, param_file, OBC, restart_CS) +end subroutine rotate_OBC_init + + +!> Rotate an OBC segment's fields from the input to the model index map. +subroutine rotate_OBC_segment_data(segment_in, segment, turns) + type(OBC_segment_type), intent(in) :: segment_in + type(OBC_segment_type), intent(inout) :: segment + integer, intent(in) :: turns + + integer :: n + integer :: num_fields + + + num_fields = segment_in%num_fields + allocate(segment%field(num_fields)) + + segment%num_fields = segment_in%num_fields + do n = 1, num_fields + segment%field(n)%handle = segment_in%field(n)%handle + segment%field(n)%dz_handle = segment_in%field(n)%dz_handle + + if (modulo(turns, 2) /= 0) then + select case (segment_in%field(n)%name) + case ('U') + segment%field(n)%name = 'V' + case ('Uamp') + segment%field(n)%name = 'Vamp' + case ('Uphase') + segment%field(n)%name = 'Vphase' + case ('V') + segment%field(n)%name = 'U' + case ('Vamp') + segment%field(n)%name = 'Uamp' + case ('Vphase') + segment%field(n)%name = 'Uphase' + case ('DVDX') + segment%field(n)%name = 'DUDY' + case ('DUDY') + segment%field(n)%name = 'DVDX' + case default + segment%field(n)%name = segment_in%field(n)%name + end select + else + segment%field(n)%name = segment_in%field(n)%name + endif + + if (allocated(segment_in%field(n)%buffer_src)) then + call allocate_rotated_array(segment_in%field(n)%buffer_src, & + lbound(segment_in%field(n)%buffer_src), turns, & + segment%field(n)%buffer_src) + call rotate_array(segment_in%field(n)%buffer_src, turns, & + segment%field(n)%buffer_src) + endif + + segment%field(n)%nk_src = segment_in%field(n)%nk_src + + if (allocated(segment_in%field(n)%dz_src)) then + call allocate_rotated_array(segment_in%field(n)%dz_src, & + lbound(segment_in%field(n)%dz_src), turns, & + segment%field(n)%dz_src) + call rotate_array(segment_in%field(n)%dz_src, turns, & + segment%field(n)%dz_src) + endif + + segment%field(n)%value = segment_in%field(n)%value + enddo + + segment%temp_segment_data_exists = segment_in%temp_segment_data_exists + segment%salt_segment_data_exists = segment_in%salt_segment_data_exists +end subroutine rotate_OBC_segment_data + +!> \namespace mom_open_boundary +!! This module implements some aspects of internal open boundary +!! conditions in MOM. +!! +!! A small fragment of the grid is shown below: +!! +!! j+1 x ^ x ^ x At x: q, CoriolisBu +!! j+1 > o > o > At ^: v, tauy +!! j x ^ x ^ x At >: u, taux +!! j > o > o > At o: h, bathyT, buoy, tr, T, S, Rml, ustar +!! j-1 x ^ x ^ x +!! i-1 i i+1 At x & ^: +!! i i+1 At > & o: +!! +!! The boundaries always run through q grid points (x). + +end module MOM_open_boundary diff --git a/core/MOM_porous_barriers.F90 b/core/MOM_porous_barriers.F90 new file mode 100644 index 0000000000..8f872ceb15 --- /dev/null +++ b/core/MOM_porous_barriers.F90 @@ -0,0 +1,487 @@ +!> Module for calculating curve fit for porous topography. +!written by sjd +module MOM_porous_barriers + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE +use MOM_error_handler, only : MOM_error, FATAL +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, porous_barrier_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_interface_heights, only : find_eta +use MOM_time_manager, only : time_type +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, post_data +use MOM_file_parser, only : param_file_type, get_param, log_version +use MOM_unit_scaling, only : unit_scale_type +use MOM_debugging, only : hchksum, uvchksum + +implicit none ; private + +public porous_widths_layer, porous_widths_interface, porous_barriers_init + +#include + +!> The control structure for the MOM_porous_barriers module +type, public :: porous_barrier_CS; private + logical :: initialized = .false. !< True if this control structure has been initialized. + type(diag_ctrl), pointer :: & + diag => Null() !< A structure to regulate diagnostic output timing + logical :: debug !< If true, write verbose checksums for debugging purposes. + real :: mask_depth !< The depth shallower than which porous barrier is not applied [Z ~> m] + integer :: eta_interp !< An integer indicating how the interface heights at the velocity + !! points are calculated. Valid values are given by the parameters + !! defined below: MAX, MIN, ARITHMETIC and HARMONIC. + integer :: answer_date !< The vintage of the porous barrier weight function calculations. + !! Values below 20220806 recover the old answers in which the layer + !! averaged weights are not strictly limited by an upper-bound of 1.0 . + !>@{ Diagnostic IDs + integer :: id_por_layer_widthU = -1, id_por_layer_widthV = -1, & + id_por_face_areaU = -1, id_por_face_areaV = -1 + !>@} +end type porous_barrier_CS + +integer :: id_clock_porous_barrier !< CPU clock for porous barrier + +!>@{ Enumeration values for eta interpolation schemes +integer, parameter :: ETA_INTERP_MAX = 1 +integer, parameter :: ETA_INTERP_MIN = 2 +integer, parameter :: ETA_INTERP_ARITH = 3 +integer, parameter :: ETA_INTERP_HARM = 4 +character(len=20), parameter :: ETA_INTERP_MAX_STRING = "MAX" +character(len=20), parameter :: ETA_INTERP_MIN_STRING = "MIN" +character(len=20), parameter :: ETA_INTERP_ARITH_STRING = "ARITHMETIC" +character(len=20), parameter :: ETA_INTERP_HARM_STRING = "HARMONIC" +!>@} + +contains + +!> subroutine to assign porous barrier widths averaged over a layer +subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) + ! Note: eta_bt is not currently used + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic variable + !! used to dilate the layer thicknesses + !! [H ~> m or kg m-2]. + type(porous_barrier_type), intent(inout) :: pbv !< porous barrier fractional cell metrics + type(porous_barrier_CS), intent(in) :: CS !< Control structure for porous barrier + + !local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: eta_u ! Layer interface heights at u points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: eta_v ! Layer interface heights at v points [Z ~> m] + real, dimension(SZIB_(G),SZJB_(G)) :: A_layer_prev ! Integral of fractional open width from the bottom + ! to the previous layer at u or v points [Z ~> m] + logical, dimension(SZIB_(G),SZJB_(G)) :: do_I ! Booleans for calculation at u or v points + ! updated while moving up layers + real :: A_layer ! Integral of fractional open width from bottom to current layer [Z ~> m] + real :: dz_min ! The minimum layer thickness [Z ~> m] + real :: dmask ! The depth below which porous barrier is not applied [Z ~> m] + integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq + + if (.not.CS%initialized) call MOM_error(FATAL, & + "MOM_Porous_barrier: Module must be initialized before it is used.") + + call cpu_clock_begin(id_clock_porous_barrier) + + is = G%isc; ie = G%iec; js = G%jsc; je = G%jec; nk = GV%ke + Isq = G%IscB; Ieq = G%IecB; Jsq = G%JscB; Jeq = G%JecB + + if (CS%answer_date < 20220806) then + dmask = 0.0 + else + dmask = CS%mask_depth + endif + + call calc_eta_at_uv(eta_u, eta_v, CS%eta_interp, dmask, h, tv, G, GV, US) + + dz_min = GV%Angstrom_Z + + ! u-points + do j=js,je ; do I=Isq,Ieq ; do_I(I,j) = .False. ; enddo ; enddo + + do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,nk+1), A_layer_prev(I,j), do_I(I,j)) + endif ; enddo ; enddo + + if (CS%answer_date < 20220806) then + do k=nk,1,-1 ; do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,K), A_layer, do_I(I,j)) + if (eta_u(I,j,K) - eta_u(I,j,K+1) > 0.0) then + pbv%por_face_areaU(I,j,k) = (A_layer - A_layer_prev(I,j)) / (eta_u(I,j,K) - eta_u(I,j,K+1)) + else + pbv%por_face_areaU(I,j,k) = 0.0 + endif + A_layer_prev(I,j) = A_layer + endif ; enddo ; enddo ; enddo + else + do k=nk,1,-1 ; do j=js,je ; do I=Isq,Ieq ; if (do_I(I,j)) then + call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,K), A_layer, do_I(I,j)) + if (eta_u(I,j,K) - (eta_u(I,j,K+1)+dz_min) > 0.0) then + pbv%por_face_areaU(I,j,k) = min(1.0, (A_layer - A_layer_prev(I,j)) / (eta_u(I,j,K) - eta_u(I,j,K+1))) + else + pbv%por_face_areaU(I,j,k) = 0.0 ! use calc_por_interface() might be a better choice + endif + A_layer_prev(I,j) = A_layer + endif ; enddo ; enddo ; enddo + endif + + ! v-points + do J=Jsq,Jeq ; do i=is,ie; do_I(i,J) = .False. ; enddo ; enddo + + do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,nk+1), A_layer_prev(i,J), do_I(i,J)) + endif ; enddo ; enddo + + if (CS%answer_date < 20220806) then + do k=nk,1,-1 ; do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,K), A_layer, do_I(i,J)) + if (eta_v(i,J,K) - eta_v(i,J,K+1) > 0.0) then + pbv%por_face_areaV(i,J,k) = (A_layer - A_layer_prev(i,J)) / (eta_v(i,J,K) - eta_v(i,J,K+1)) + else + pbv%por_face_areaV(i,J,k) = 0.0 + endif + A_layer_prev(i,J) = A_layer + endif ; enddo ; enddo ; enddo + else + do k=nk,1,-1 ; do J=Jsq,Jeq ; do i=is,ie ; if (do_I(i,J)) then + call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,K), A_layer, do_I(i,J)) + if (eta_v(i,J,K) - (eta_v(i,J,K+1)+dz_min) > 0.0) then + pbv%por_face_areaV(i,J,k) = min(1.0, (A_layer - A_layer_prev(i,J)) / (eta_v(i,J,K) - eta_v(i,J,K+1))) + else + pbv%por_face_areaV(i,J,k) = 0.0 ! use calc_por_interface() might be a better choice + endif + A_layer_prev(i,J) = A_layer + endif ; enddo ; enddo ; enddo + endif + + if (CS%debug) then + call uvchksum("Interface height used by porous barrier for layer weights", & + eta_u, eta_v, G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum("Porous barrier layer-averaged weights: por_face_area[UV]", & + pbv%por_face_areaU, pbv%por_face_areaV, G%HI, haloshift=0, & + scalar_pair=.true.) + endif + + if (CS%id_por_face_areaU > 0) call post_data(CS%id_por_face_areaU, pbv%por_face_areaU, CS%diag) + if (CS%id_por_face_areaV > 0) call post_data(CS%id_por_face_areaV, pbv%por_face_areaV, CS%diag) + + call cpu_clock_end(id_clock_porous_barrier) +end subroutine porous_widths_layer + +!> subroutine to assign porous barrier widths at the layer interfaces +subroutine porous_widths_interface(h, tv, G, GV, US, pbv, CS, eta_bt) + ! Note: eta_bt is not currently used + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic variable + !! used to dilate the layer thicknesses + !! [H ~> m or kg m-2]. + type(porous_barrier_type), intent(inout) :: pbv !< porous barrier fractional cell metrics + type(porous_barrier_CS), intent(in) :: CS !< Control structure for porous barrier + + !local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: eta_u ! Layer interface height at u points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: eta_v ! Layer interface height at v points [Z ~> m] + logical, dimension(SZIB_(G),SZJB_(G)) :: do_I ! Booleans for calculation at u or v points + ! updated while moving up layers + real :: dmask ! The depth below which porous barrier is not applied [Z ~> m] + integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq + + if (.not.CS%initialized) call MOM_error(FATAL, & + "MOM_Porous_barrier: Module must be initialized before it is used.") + + call cpu_clock_begin(id_clock_porous_barrier) + + is = G%isc; ie = G%iec; js = G%jsc; je = G%jec; nk = GV%ke + Isq = G%IscB; Ieq = G%IecB; Jsq = G%JscB; Jeq = G%JecB + + if (CS%answer_date < 20220806) then + dmask = 0.0 + else + dmask = CS%mask_depth + endif + + call calc_eta_at_uv(eta_u, eta_v, CS%eta_interp, dmask, h, tv, G, GV, US) + + ! u-points + do j=js,je ; do I=Isq,Ieq + do_I(I,j) = .False. + if (G%porous_DavgU(I,j) < dmask) do_I(I,j) = .True. + enddo ; enddo + + if (CS%answer_date < 20220806) then + do K=1,nk+1 ; do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + call calc_por_interface(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,K), pbv%por_layer_widthU(I,j,K), do_I(I,j)) + endif ; enddo ; enddo ; enddo + else + do K=1,nk+1 ; do j=js,je ; do I=Isq,Ieq ; if (do_I(I,j)) then + call calc_por_interface(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,K), pbv%por_layer_widthU(I,j,K), do_I(I,j)) + endif ; enddo ; enddo ; enddo + endif + + ! v-points + do J=Jsq,Jeq ; do i=is,ie + do_I(i,J) = .False. + if (G%porous_DavgV(i,J) < dmask) do_I(i,J) = .True. + enddo ; enddo + + if (CS%answer_date < 20220806) then + do K=1,nk+1 ; do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + call calc_por_interface(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,K), pbv%por_layer_widthV(i,J,K), do_I(i,J)) + endif ; enddo ; enddo ; enddo + else + do K=1,nk+1 ; do J=Jsq,Jeq ; do i=is,ie ; if (do_I(i,J)) then + call calc_por_interface(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,K), pbv%por_layer_widthV(i,J,K), do_I(i,J)) + endif ; enddo ; enddo ; enddo + endif + + if (CS%debug) then + call uvchksum("Interface height used by porous barrier for interface weights", & + eta_u, eta_v, G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum("Porous barrier weights at the layer-interface: por_layer_width[UV]", & + pbv%por_layer_widthU, pbv%por_layer_widthV, G%HI, & + haloshift=0, scalar_pair=.true.) + endif + + if (CS%id_por_layer_widthU > 0) call post_data(CS%id_por_layer_widthU, pbv%por_layer_widthU, CS%diag) + if (CS%id_por_layer_widthV > 0) call post_data(CS%id_por_layer_widthV, pbv%por_layer_widthV, CS%diag) + + call cpu_clock_end(id_clock_porous_barrier) +end subroutine porous_widths_interface + +subroutine calc_eta_at_uv(eta_u, eta_v, interp, dmask, h, tv, G, GV, US, eta_bt) + !variables needed to call find_eta + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic variable + !! used to dilate the layer thicknesses + !! [H ~> m or kg m-2]. + real, intent(in) :: dmask !< The depth shallower than which + !! porous barrier is not applied [Z ~> m] + integer, intent(in) :: interp !< eta interpolation method + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: eta_u !< Layer interface heights at u points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(out) :: eta_v !< Layer interface heights at v points [Z ~> m] + + ! local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Layer interface heights [Z ~> m]. + real :: dz_neglect ! A negligible height difference [Z ~> m] + integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq + + is = G%isc; ie = G%iec; js = G%jsc; je = G%jec; nk = GV%ke + Isq = G%IscB; Ieq = G%IecB; Jsq = G%JscB; Jeq = G%JecB + + ! currently no treatment for using optional find_eta arguments if present + call find_eta(h, tv, G, GV, US, eta, halo_size=1) + + dz_neglect = GV%dZ_subroundoff + + do K=1,nk+1 + do j=js,je ; do I=Isq,Ieq ; eta_u(I,j,K) = dmask ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; eta_v(i,J,K) = dmask ; enddo ; enddo + enddo + + select case (interp) + case (ETA_INTERP_MAX) ! The shallower interface height + do K=1,nk+1 + do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + eta_u(I,j,K) = max(eta(i,j,K), eta(i+1,j,K)) + endif ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + eta_v(i,J,K) = max(eta(i,j,K), eta(i,j+1,K)) + endif ; enddo ; enddo + enddo + case (ETA_INTERP_MIN) ! The deeper interface height + do K=1,nk+1 + do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + eta_u(I,j,K) = min(eta(i,j,K), eta(i+1,j,K)) + endif ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + eta_v(i,J,K) = min(eta(i,j,K), eta(i,j+1,K)) + endif ; enddo ; enddo + enddo + case (ETA_INTERP_ARITH) ! Arithmetic mean + do K=1,nk+1 + do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + eta_u(I,j,K) = 0.5 * (eta(i,j,K) + eta(i+1,j,K)) + endif ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + eta_v(i,J,K) = 0.5 * (eta(i,j,K) + eta(i,j+1,K)) + endif ; enddo ; enddo + enddo + case (ETA_INTERP_HARM) ! Harmonic mean + do K=1,nk+1 + do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + eta_u(I,j,K) = 2.0 * (eta(i,j,K) * eta(i+1,j,K)) / (eta(i,j,K) + eta(i+1,j,K) + dz_neglect) + endif ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + eta_v(i,J,K) = 2.0 * (eta(i,j,K) * eta(i,j+1,K)) / (eta(i,j,K) + eta(i,j+1,K) + dz_neglect) + endif ; enddo ; enddo + enddo + case default + call MOM_error(FATAL, "porous_widths::calc_eta_at_uv: "//& + "invalid value for eta interpolation method.") + end select +end subroutine calc_eta_at_uv + +!> subroutine to calculate the profile fit (the three parameter fit from Adcroft 2013) +! of the open face area fraction below a certain depth (eta_layer) in a column +subroutine calc_por_layer(D_min, D_max, D_avg, eta_layer, A_layer, do_next) + real, intent(in) :: D_min !< minimum topographic height (deepest) [Z ~> m] + real, intent(in) :: D_max !< maximum topographic height (shallowest) [Z ~> m] + real, intent(in) :: D_avg !< mean topographic height [Z ~> m] + real, intent(in) :: eta_layer !< height of interface [Z ~> m] + real, intent(out) :: A_layer !< frac. open face area of below eta_layer [Z ~> m] + logical, intent(out) :: do_next !< False if eta_layer>D_max + + ! local variables + real :: m ! convenience constant for fit [nondim] + real :: zeta ! normalized vertical coordinate [nondim] + + do_next = .True. + if (eta_layer <= D_min) then + A_layer = 0.0 + elseif (eta_layer > D_max) then + A_layer = eta_layer - D_avg + do_next = .False. + else + m = (D_avg - D_min) / (D_max - D_min) + zeta = (eta_layer - D_min) / (D_max - D_min) + if (m < 0.5) then + A_layer = (D_max - D_min) * ((1.0 - m) * zeta**(1.0 / (1.0 - m))) + elseif (m == 0.5) then + A_layer = (D_max - D_min) * (0.5 * zeta * zeta) + else + A_layer = (D_max - D_min) * (zeta - m + m * ((1.0 - zeta)**(1.0 / m))) + endif + endif +end subroutine calc_por_layer + +!> subroutine to calculate the profile fit (the three parameter fit from Adcroft 2013) +! of the open interface fraction at a certain depth (eta_layer) in a column +subroutine calc_por_interface(D_min, D_max, D_avg, eta_layer, w_layer, do_next) + real, intent(in) :: D_min !< minimum topographic height (deepest) [Z ~> m] + real, intent(in) :: D_max !< maximum topographic height (shallowest) [Z ~> m] + real, intent(in) :: D_avg !< mean topographic height [Z ~> m] + real, intent(in) :: eta_layer !< height of interface [Z ~> m] + real, intent(out) :: w_layer !< frac. open interface width at eta_layer [nondim] + logical, intent(out) :: do_next !< False if eta_layer>D_max + + ! local variables + real :: m, a ! convenience constants for fit [nondim] + real :: zeta ! normalized vertical coordinate [nondim] + + do_next = .True. + if (eta_layer <= D_min) then + w_layer = 0.0 + elseif (eta_layer > D_max) then + w_layer = 1.0 + do_next = .False. + else ! The following option could be refactored for stability and efficiency (with fewer divisions) + m = (D_avg - D_min) / (D_max - D_min) + a = (1.0 - m) / m + zeta = (eta_layer - D_min) / (D_max - D_min) + if (m < 0.5) then + w_layer = zeta**(1.0 / a) + ! Note that this would be safer and more efficent if it were rewritten as: + ! w_layer = zeta**( (D_avg - D_min) / (D_max - D_avg) ) + elseif (m == 0.5) then + w_layer = zeta + else + w_layer = 1.0 - (1.0 - zeta)**a + endif + endif +end subroutine calc_por_interface + +subroutine porous_barriers_init(Time, GV, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< Current model time + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(porous_barrier_CS), intent(inout) :: CS !< Module control structure + + ! local variables + character(len=40) :: mdl = "MOM_porous_barriers" ! This module's name. + character(len=20) :: interp_method ! String storing eta interpolation method + integer :: default_answer_date ! Global answer date + !> This include declares and sets the variable "version". +# include "version_variable.h" + + CS%initialized = .true. + CS%diag => diag + + call log_version(param_file, mdl, version, "", log_to_all=.true., layout=.false., & + debugging=.false.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "PORBAR_ANSWER_DATE", CS%answer_date, & + "The vintage of the porous barrier weight function calculations. Values below "//& + "20220806 recover the old answers in which the layer averaged weights are not "//& + "strictly limited by an upper-bound of 1.0 .", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) + call get_param(param_file, mdl, "PORBAR_MASKING_DEPTH", CS%mask_depth, & + "If the effective average depth at the velocity cell is shallower than this "//& + "number, then porous barrier is not applied at that location. "//& + "PORBAR_MASKING_DEPTH is assumed to be positive below the sea surface.", & + units="m", default=0.0, scale=US%m_to_Z) + ! The sign needs to be inverted to be consistent with the sign convention of Davg_[UV] + CS%mask_depth = -CS%mask_depth + call get_param(param_file, mdl, "PORBAR_ETA_INTERP", interp_method, & + "A string describing the method that decides how the "//& + "interface heights at the velocity points are calculated. "//& + "Valid values are:\n"//& + "\t MAX (the default) - maximum of the adjacent cells \n"//& + "\t MIN - minimum of the adjacent cells \n"//& + "\t ARITHMETIC - arithmetic mean of the adjacent cells \n"//& + "\t HARMONIC - harmonic mean of the adjacent cells \n", & + default=ETA_INTERP_MAX_STRING) + select case (interp_method) + case (ETA_INTERP_MAX_STRING) ; CS%eta_interp = ETA_INTERP_MAX + case (ETA_INTERP_MIN_STRING) ; CS%eta_interp = ETA_INTERP_MIN + case (ETA_INTERP_ARITH_STRING) ; CS%eta_interp = ETA_INTERP_ARITH + case (ETA_INTERP_HARM_STRING) ; CS%eta_interp = ETA_INTERP_HARM + case default + call MOM_error(FATAL, "porous_barriers_init: Unrecognized setting "// & + "#define PORBAR_ETA_INTERP "//trim(interp_method)//" found in input file.") + end select + + CS%id_por_layer_widthU = register_diag_field('ocean_model', 'por_layer_widthU', diag%axesCui, Time, & + 'Porous barrier open width fraction (at the layer interfaces) of the u-faces', 'nondim') + CS%id_por_layer_widthV = register_diag_field('ocean_model', 'por_layer_widthV', diag%axesCvi, Time, & + 'Porous barrier open width fraction (at the layer interfaces) of the v-faces', 'nondim') + CS%id_por_face_areaU = register_diag_field('ocean_model', 'por_face_areaU', diag%axesCuL, Time, & + 'Porous barrier open area fraction (layer averaged) of U-faces', 'nondim') + CS%id_por_face_areaV = register_diag_field('ocean_model', 'por_face_areaV', diag%axesCvL, Time, & + 'Porous barrier open area fraction (layer averaged) of V-faces', 'nondim') + + id_clock_porous_barrier = cpu_clock_id('(Ocean porous barrier)', grain=CLOCK_MODULE) +end subroutine + +end module MOM_porous_barriers diff --git a/core/MOM_stoch_eos.F90 b/core/MOM_stoch_eos.F90 new file mode 100644 index 0000000000..2bd742be6d --- /dev/null +++ b/core/MOM_stoch_eos.F90 @@ -0,0 +1,261 @@ +!> Provides the ocean stochastic equation of state +module MOM_stoch_eos + +! This file is part of MOM6. See LICENSE.md for the license. +use MOM_diag_mediator, only : register_diag_field, post_data, diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL +use MOM_file_parser, only : get_param, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_isopycnal_slopes, only : vert_fill_TS +use MOM_random, only : PRNG, random_2d_constructor, random_2d_norm +use MOM_restart, only : MOM_restart_CS, register_restart_field, is_new_run, query_initialized +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +!use random_numbers_mod, only : getRandomNumbers, initializeRandomNumberStream, randomNumberStream + +implicit none; private +#include + +public MOM_stoch_eos_init +public MOM_stoch_eos_run +public stoch_EOS_register_restarts +public post_stoch_EOS_diags +public MOM_calc_varT + +!> Describes parameters of the stochastic component of the EOS +!! correction, described in Stanley et al. JAMES 2020. +type, public :: MOM_stoch_eos_CS ; private + real, allocatable :: l2_inv(:,:) !< One over sum of the T cell side side lengths squared [L-2 ~> m-2] + real, allocatable :: rgauss(:,:) !< nondimensional random Gaussian [nondim] + real :: tfac=0.27 !< Nondimensional decorrelation time factor, ~1/3.7 [nondim] + real :: amplitude=0.624499 !< Nondimensional standard deviation of Gaussian [nondim] + integer :: seed !< PRNG seed + type(PRNG) :: rn_CS !< PRNG control structure + real, allocatable :: pattern(:,:) !< Random pattern for stochastic EOS [nondim] + real, allocatable :: phi(:,:) !< temporal correlation stochastic EOS [nondim] + logical :: use_stoch_eos!< If true, use the stochastic equation of state (Stanley et al. 2020) + real :: stanley_coeff !< Coefficient correlating the temperature gradient + !! and SGS T variance [nondim]; if <0, turn off scheme in all codes + real :: stanley_a !< a in exp(aX) in stochastic coefficient [nondim] + real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + !>@{ Diagnostic IDs + integer :: id_stoch_eos = -1, id_stoch_phi = -1, id_tvar_sgs = -1 + !>@} + +end type MOM_stoch_eos_CS + +contains + +!> Initializes MOM_stoch_eos module, returning a logical indicating whether this module will be used. +logical function MOM_stoch_eos_init(Time, G, GV, US, param_file, diag, CS, restart_CS) + type(time_type), intent(in) :: Time !< Time for stochastic process + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse + type(diag_ctrl), target, intent(inout) :: diag !< Structure used to control diagnostics + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + + ! local variables + integer :: i,j + + MOM_stoch_eos_init = .false. + + CS%seed = 0 + + call get_param(param_file, "MOM_stoch_eos", "STOCH_EOS", CS%use_stoch_eos, & + "If true, stochastic perturbations are applied "//& + "to the EOS in the PGF.", default=.false.) + call get_param(param_file, "MOM_stoch_eos", "STANLEY_COEFF", CS%stanley_coeff, & + "Coefficient correlating the temperature gradient "//& + "and SGS T variance.", units="nondim", default=-1.0) + call get_param(param_file, "MOM_stoch_eos", "STANLEY_A", CS%stanley_a, & + "Coefficient a which scales chi in stochastic perturbation of the "//& + "SGS T variance.", units="nondim", default=1.0, & + do_not_log=((CS%stanley_coeff<0.0) .or. .not.CS%use_stoch_eos)) + call get_param(param_file, "MOM_stoch_eos", "KD_SMOOTH", CS%kappa_smooth, & + "A diapycnal diffusivity that is used to interpolate "//& + "more sensible values of T & S into thin layers.", & + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T, & + do_not_log=(CS%stanley_coeff<0.0)) + + ! Don't run anything if STANLEY_COEFF < 0 + if (CS%stanley_coeff >= 0.0) then + if (.not.allocated(CS%pattern)) call MOM_error(FATAL, & + "MOM_stoch_eos_CS%pattern is not allocated when it should be, suggesting that "//& + "stoch_EOS_register_restarts() has not been called before MOM_stoch_eos_init().") + + allocate(CS%phi(G%isd:G%ied,G%jsd:G%jed), source=0.0) + allocate(CS%l2_inv(G%isd:G%ied,G%jsd:G%jed), source=0.0) + allocate(CS%rgauss(G%isd:G%ied,G%jsd:G%jed), source=0.0) + call get_param(param_file, "MOM_stoch_eos", "SEED_STOCH_EOS", CS%seed, & + "Specfied seed for random number sequence ", default=0) + call random_2d_constructor(CS%rn_CS, G%HI, Time, CS%seed) + call random_2d_norm(CS%rn_CS, G%HI, CS%rgauss) + ! fill array with approximation of grid area needed for decorrelation time-scale calculation + do j=G%jsc,G%jec + do i=G%isc,G%iec + CS%l2_inv(i,j) = 1.0/(G%dxT(i,j)**2+G%dyT(i,j)**2) + enddo + enddo + + if (.not.query_initialized(CS%pattern, "stoch_eos_pattern", restart_CS) .or. & + is_new_run(restart_CS)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + CS%pattern(i,j) = CS%amplitude*CS%rgauss(i,j) + enddo ; enddo + endif + + !register diagnostics + CS%id_tvar_sgs = register_diag_field('ocean_model', 'tvar_sgs', diag%axesTL, Time, & + 'Parameterized SGS Temperature Variance ', 'None') + if (CS%use_stoch_eos) then + CS%id_stoch_eos = register_diag_field('ocean_model', 'stoch_eos', diag%axesT1, Time, & + 'random pattern for EOS', 'None') + CS%id_stoch_phi = register_diag_field('ocean_model', 'stoch_phi', diag%axesT1, Time, & + 'phi for EOS', 'None') + endif + endif + + ! This module is only used if explicitly enabled or a positive correlation coefficient is set. + MOM_stoch_eos_init = CS%use_stoch_eos .or. (CS%stanley_coeff >= 0.0) + +end function MOM_stoch_eos_init + +!> Register fields related to the stoch_EOS module for resarts +subroutine stoch_EOS_register_restarts(HI, param_file, CS, restart_CS) + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + + call get_param(param_file, "MOM_stoch_eos", "STANLEY_COEFF", CS%stanley_coeff, & + "Coefficient correlating the temperature gradient "//& + "and SGS T variance.", units="nondim", default=-1.0, do_not_log=.true.) + + if (CS%stanley_coeff >= 0.0) then + allocate(CS%pattern(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.0) + call register_restart_field(CS%pattern, "stoch_eos_pattern", .false., restart_CS, & + "Random pattern for stoch EOS", "nondim") + endif + +end subroutine stoch_EOS_register_restarts + +!> Generates a pattern in space and time for the ocean stochastic equation of state +subroutine MOM_stoch_eos_run(G, u, v, delt, Time, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, intent(in) :: delt !< Time step size for AR1 process [T ~> s]. + type(time_type), intent(in) :: Time !< Time for stochastic process + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + + ! local variables + real :: ubar, vbar ! Averaged velocities [L T-1 ~> m s-1] + real :: phi ! A temporal correlation factor [nondim] + integer :: i, j + + ! Return without doing anything if this capability is not enabled. + if (.not.CS%use_stoch_eos) return + + call random_2d_constructor(CS%rn_CS, G%HI, Time, CS%seed) + call random_2d_norm(CS%rn_CS, G%HI, CS%rgauss) + + ! advance AR(1) + do j=G%jsc,G%jec + do i=G%isc,G%iec + ubar = 0.5*(u(I,j,1)*G%mask2dCu(I,j)+u(I-1,j,1)*G%mask2dCu(I-1,j)) + vbar = 0.5*(v(i,J,1)*G%mask2dCv(i,J)+v(i,J-1,1)*G%mask2dCv(i,J-1)) + phi = exp(-delt*CS%tfac*sqrt((ubar**2+vbar**2)*CS%l2_inv(i,j))) + CS%pattern(i,j) = phi*CS%pattern(i,j) + CS%amplitude*sqrt(1-phi**2)*CS%rgauss(i,j) + CS%phi(i,j) = phi + enddo + enddo + +end subroutine MOM_stoch_eos_run + +!> Write out any diagnostics related to this module. +subroutine post_stoch_EOS_diags(CS, tv, diag) + type(MOM_stoch_eos_CS), intent(in) :: CS !< Stochastic control structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(diag_ctrl), intent(inout) :: diag !< Structure to control diagnostics + + if (CS%id_stoch_eos > 0) call post_data(CS%id_stoch_eos, CS%pattern, diag) + if (CS%id_stoch_phi > 0) call post_data(CS%id_stoch_phi, CS%phi, diag) + if (CS%id_tvar_sgs > 0) call post_data(CS%id_tvar_sgs, tv%varT, diag) + +end subroutine post_stoch_EOS_diags + +!> Computes a parameterization of the SGS temperature variance +subroutine MOM_calc_varT(G, GV, US, h, tv, CS, dt) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thickness [H ~> m] + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + real, intent(in) :: dt !< Time increment [T ~> s] + + ! local variables + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & + T, & !> The temperature (or density) [C ~> degC], with the values in + !! in massless layers filled vertically by diffusion. + S !> The filled salinity [S ~> ppt], with the values in + !! in massless layers filled vertically by diffusion. + real :: hl(5) !> Copy of local stencil of H [H ~> m] + real :: dTdi2, dTdj2 !> Differences in T variance [C2 ~> degC2] + integer :: i, j, k + + ! Nothing happens if a negative correlation coefficient is set. + if (CS%stanley_coeff < 0.0) return + + ! This block does a thickness weighted variance calculation and helps control for + ! extreme gradients along layers which are vanished against topography. It is + ! still a poor approximation in the interior when coordinates are strongly tilted. + if (.not. associated(tv%varT)) allocate(tv%varT(G%isd:G%ied, G%jsd:G%jed, GV%ke), source=0.0) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, US, halo_here=1, larger_h_denom=.true.) + + do k=1,G%ke + do j=G%jsc,G%jec + do i=G%isc,G%iec + hl(1) = h(i,j,k) * G%mask2dT(i,j) + hl(2) = h(i-1,j,k) * G%mask2dCu(I-1,j) + hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) + hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) + hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) + + ! SGS variance in i-direction [C2 ~> degC2] + dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & + + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & + ) * G%dxT(i,j) * 0.5 )**2 + ! SGS variance in j-direction [C2 ~> degC2] + dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & + + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & + ) * G%dyT(i,j) * 0.5 )**2 + tv%varT(i,j,k) = CS%stanley_coeff * ( dTdi2 + dTdj2 ) + ! Turn off scheme near land + tv%varT(i,j,k) = tv%varT(i,j,k) * (minval(hl) / (maxval(hl) + GV%H_subroundoff)) + enddo + enddo + enddo + ! if stochastic, perturb + if (CS%use_stoch_eos) then + do k=1,G%ke + do j=G%jsc,G%jec + do i=G%isc,G%iec + tv%varT(i,j,k) = exp(CS%stanley_a * CS%pattern(i,j)) * tv%varT(i,j,k) + enddo + enddo + enddo + endif +end subroutine MOM_calc_varT + +end module MOM_stoch_eos diff --git a/core/MOM_transcribe_grid.F90 b/core/MOM_transcribe_grid.F90 new file mode 100644 index 0000000000..b8e213fa62 --- /dev/null +++ b/core/MOM_transcribe_grid.F90 @@ -0,0 +1,338 @@ +!> Module with routines for copying information from a shared dynamic horizontal +!! grid to an ocean-specific horizontal grid and the reverse. +module MOM_transcribe_grid + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_array_transform, only : rotate_array, rotate_array_pair +use MOM_domains, only : pass_var, pass_vector +use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE, AGRID, BGRID_NE, CORNER +use MOM_dyn_horgrid, only : dyn_horgrid_type, set_derived_dyn_horgrid +use MOM_dyn_horgrid, only : rotate_dyngrid=>rotate_dyn_horgrid +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING +use MOM_grid, only : ocean_grid_type, set_derived_metrics +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +public copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid, rotate_dyngrid + +contains + +!> Copies information from a dynamic (shared) horizontal grid type into an +!! ocean_grid_type. There may also be a change in the reference +!! height for topography between the two grids. +subroutine copy_dyngrid_to_MOM_grid(dG, oG, US) + type(dyn_horgrid_type), intent(in) :: dG !< Common horizontal grid type + type(ocean_grid_type), intent(inout) :: oG !< Ocean grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + integer :: isd, ied, jsd, jed ! Common data domains. + integer :: IsdB, IedB, JsdB, JedB ! Common data domains. + integer :: ido, jdo, Ido2, Jdo2 ! Indexing offsets between the grids. + integer :: Igst, Jgst ! Global starting indices. + integer :: i, j + + ! MOM_grid_init and create_dyn_horgrid are called outside of this routine. + ! This routine copies over the fields that were set by MOM_initialized_fixed. + + ! Determine the indexing offsets between the grids. + ido = dG%idg_offset - oG%idg_offset + jdo = dG%jdg_offset - oG%jdg_offset + + isd = max(oG%isd, dG%isd+ido) ; jsd = max(oG%jsd, dG%jsd+jdo) + ied = min(oG%ied, dG%ied+ido) ; jed = min(oG%jed, dG%jed+jdo) + IsdB = max(oG%IsdB, dG%IsdB+ido) ; JsdB = max(oG%JsdB, dG%JsdB+jdo) + IedB = min(oG%IedB, dG%IedB+ido) ; JedB = min(oG%JedB, dG%JedB+jdo) + + ! Check that the grids conform. + if ((isd > oG%isc) .or. (ied < oG%ied) .or. (jsd > oG%jsc) .or. (jed > oG%jed)) & + call MOM_error(FATAL, "copy_dyngrid_to_MOM_grid called with incompatible grids.") + + do i=isd,ied ; do j=jsd,jed + oG%geoLonT(i,j) = dG%geoLonT(i+ido,j+jdo) + oG%geoLatT(i,j) = dG%geoLatT(i+ido,j+jdo) + oG%dxT(i,j) = dG%dxT(i+ido,j+jdo) + oG%dyT(i,j) = dG%dyT(i+ido,j+jdo) + oG%areaT(i,j) = dG%areaT(i+ido,j+jdo) + oG%bathyT(i,j) = dG%bathyT(i+ido,j+jdo) - oG%Z_ref + + oG%dF_dx(i,j) = dG%dF_dx(i+ido,j+jdo) + oG%dF_dy(i,j) = dG%dF_dy(i+ido,j+jdo) + oG%sin_rot(i,j) = dG%sin_rot(i+ido,j+jdo) + oG%cos_rot(i,j) = dG%cos_rot(i+ido,j+jdo) + oG%mask2dT(i,j) = dG%mask2dT(i+ido,j+jdo) + enddo ; enddo + + do I=IsdB,IedB ; do j=jsd,jed + oG%geoLonCu(I,j) = dG%geoLonCu(I+ido,j+jdo) + oG%geoLatCu(I,j) = dG%geoLatCu(I+ido,j+jdo) + oG%dxCu(I,j) = dG%dxCu(I+ido,j+jdo) + oG%dyCu(I,j) = dG%dyCu(I+ido,j+jdo) + oG%dy_Cu(I,j) = dG%dy_Cu(I+ido,j+jdo) + + oG%porous_DminU(I,j) = dG%porous_DminU(I+ido,j+jdo) - oG%Z_ref + oG%porous_DmaxU(I,j) = dG%porous_DmaxU(I+ido,j+jdo) - oG%Z_ref + oG%porous_DavgU(I,j) = dG%porous_DavgU(I+ido,j+jdo) - oG%Z_ref + + oG%mask2dCu(I,j) = dG%mask2dCu(I+ido,j+jdo) + oG%OBCmaskCu(I,j) = dG%OBCmaskCu(I+ido,j+jdo) + oG%areaCu(I,j) = dG%areaCu(I+ido,j+jdo) + oG%IareaCu(I,j) = dG%IareaCu(I+ido,j+jdo) + enddo ; enddo + + do i=isd,ied ; do J=JsdB,JedB + oG%geoLonCv(i,J) = dG%geoLonCv(i+ido,J+jdo) + oG%geoLatCv(i,J) = dG%geoLatCv(i+ido,J+jdo) + oG%dxCv(i,J) = dG%dxCv(i+ido,J+jdo) + oG%dyCv(i,J) = dG%dyCv(i+ido,J+jdo) + oG%dx_Cv(i,J) = dG%dx_Cv(i+ido,J+jdo) + + oG%porous_DminV(i,J) = dG%porous_DminV(i+ido,J+jdo) - oG%Z_ref + oG%porous_DmaxV(i,J) = dG%porous_DmaxV(i+ido,J+jdo) - oG%Z_ref + oG%porous_DavgV(i,J) = dG%porous_DavgV(i+ido,J+jdo) - oG%Z_ref + + oG%mask2dCv(i,J) = dG%mask2dCv(i+ido,J+jdo) + oG%OBCmaskCv(i,J) = dG%OBCmaskCv(i+ido,J+jdo) + oG%areaCv(i,J) = dG%areaCv(i+ido,J+jdo) + oG%IareaCv(i,J) = dG%IareaCv(i+ido,J+jdo) + enddo ; enddo + + do I=IsdB,IedB ; do J=JsdB,JedB + oG%geoLonBu(I,J) = dG%geoLonBu(I+ido,J+jdo) + oG%geoLatBu(I,J) = dG%geoLatBu(I+ido,J+jdo) + oG%dxBu(I,J) = dG%dxBu(I+ido,J+jdo) + oG%dyBu(I,J) = dG%dyBu(I+ido,J+jdo) + oG%areaBu(I,J) = dG%areaBu(I+ido,J+jdo) + oG%CoriolisBu(I,J) = dG%CoriolisBu(I+ido,J+jdo) + oG%mask2dBu(I,J) = dG%mask2dBu(I+ido,J+jdo) + enddo ; enddo + + oG%bathymetry_at_vel = dG%bathymetry_at_vel + if (oG%bathymetry_at_vel) then + do I=IsdB,IedB ; do j=jsd,jed + oG%Dblock_u(I,j) = dG%Dblock_u(I+ido,j+jdo) - oG%Z_ref + oG%Dopen_u(I,j) = dG%Dopen_u(I+ido,j+jdo) - oG%Z_ref + enddo ; enddo + do i=isd,ied ; do J=JsdB,JedB + oG%Dblock_v(i,J) = dG%Dblock_v(i+ido,J+jdo) - oG%Z_ref + oG%Dopen_v(i,J) = dG%Dopen_v(i+ido,J+jdo) - oG%Z_ref + enddo ; enddo + endif + + oG%gridLonT(oG%isg:oG%ieg) = dG%gridLonT(dG%isg:dG%ieg) + oG%gridLatT(oG%jsg:oG%jeg) = dG%gridLatT(dG%jsg:dG%jeg) + ! The more complicated logic here avoids segmentation faults if one grid uses + ! global symmetric memory while the other does not. Because a northeast grid + ! convention is being used, the upper bounds for each array correspond. + ! Note that the dynamic grid always uses symmetric memory. + Ido2 = dG%IegB-oG%IegB ; Igst = max(oG%IsgB, (dG%isg-1)-Ido2) + Jdo2 = dG%JegB-oG%JegB ; Jgst = max(oG%JsgB, (dG%jsg-1)-Jdo2) + do I=Igst,oG%IegB ; oG%gridLonB(I) = dG%gridLonB(I+Ido2) ; enddo + do J=Jgst,oG%JegB ; oG%gridLatB(J) = dG%gridLatB(J+Jdo2) ; enddo + + ! Copy various scalar variables and strings. + oG%x_axis_units = dG%x_axis_units ; oG%y_axis_units = dG%y_axis_units + oG%x_ax_unit_short = dG%x_ax_unit_short ; oG%y_ax_unit_short = dG%y_ax_unit_short + oG%areaT_global = dG%areaT_global ; oG%IareaT_global = dG%IareaT_global + oG%south_lat = dG%south_lat ; oG%west_lon = dG%west_lon + oG%len_lat = dG%len_lat ; oG%len_lon = dG%len_lon + oG%Rad_Earth = dG%Rad_Earth ; oG%Rad_Earth_L = dG%Rad_Earth_L + oG%max_depth = dG%max_depth + +! Update the halos in case the dynamic grid has smaller halos than the ocean grid. + call pass_var(oG%areaT, oG%Domain) + call pass_var(oG%bathyT, oG%Domain) + call pass_var(oG%geoLonT, oG%Domain) + call pass_var(oG%geoLatT, oG%Domain) + call pass_vector(oG%dxT, oG%dyT, oG%Domain, To_All+Scalar_Pair, AGRID) + call pass_vector(oG%dF_dx, oG%dF_dy, oG%Domain, To_All, AGRID) + call pass_vector(oG%cos_rot, oG%sin_rot, oG%Domain, To_All, AGRID) + call pass_var(oG%mask2dT, oG%Domain) + + call pass_vector(oG%areaCu, oG%areaCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(oG%dyCu, oG%dxCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(oG%dxCu, oG%dyCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(oG%dy_Cu, oG%dx_Cv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(oG%mask2dCu, oG%mask2dCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(oG%OBCmaskCu, oG%OBCmaskCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(oG%IareaCu, oG%IareaCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(oG%IareaCu, oG%IareaCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(oG%geoLatCu, oG%geoLatCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) + + call pass_var(oG%areaBu, oG%Domain, position=CORNER) + call pass_var(oG%geoLonBu, oG%Domain, position=CORNER, inner_halo=oG%isc-isd) + call pass_var(oG%geoLatBu, oG%Domain, position=CORNER) + call pass_vector(oG%dxBu, oG%dyBu, oG%Domain, To_All+Scalar_Pair, BGRID_NE) + call pass_var(oG%CoriolisBu, oG%Domain, position=CORNER) + call pass_var(oG%mask2dBu, oG%Domain, position=CORNER) + + if (oG%bathymetry_at_vel) then + call pass_vector(oG%Dblock_u, oG%Dblock_v, oG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(oG%Dopen_u, oG%Dopen_v, oG%Domain, To_All+Scalar_Pair, CGRID_NE) + endif + + call set_derived_metrics(oG, US) + +end subroutine copy_dyngrid_to_MOM_grid + + +!> Copies information from an ocean_grid_type into a dynamic (shared) +!! horizontal grid type. There may also be a change in the reference +!! height for topography between the two grids. +subroutine copy_MOM_grid_to_dyngrid(oG, dG, US) + type(ocean_grid_type), intent(in) :: oG !< Ocean grid type + type(dyn_horgrid_type), intent(inout) :: dG !< Common horizontal grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + integer :: isd, ied, jsd, jed ! Common data domains. + integer :: IsdB, IedB, JsdB, JedB ! Common data domains. + integer :: ido, jdo, Ido2, Jdo2 ! Indexing offsets between the grids. + integer :: Igst, Jgst ! Global starting indices. + integer :: i, j + + ! MOM_grid_init and create_dyn_horgrid are called outside of this routine. + ! This routine copies over the fields that were set by MOM_initialized_fixed. + + ! Determine the indexing offsets between the grids. + ido = oG%idG_offset - dG%idG_offset + jdo = oG%jdG_offset - dG%jdG_offset + + isd = max(dG%isd, oG%isd+ido) ; jsd = max(dG%jsd, oG%jsd+jdo) + ied = min(dG%ied, oG%ied+ido) ; jed = min(dG%jed, oG%jed+jdo) + IsdB = max(dG%IsdB, oG%IsdB+ido) ; JsdB = max(dG%JsdB, oG%JsdB+jdo) + IedB = min(dG%IedB, oG%IedB+ido) ; JedB = min(dG%JedB, oG%JedB+jdo) + + ! Check that the grids conform. + if ((isd > dG%isc) .or. (ied < dG%ied) .or. (jsd > dG%jsc) .or. (jed > dG%jed)) & + call MOM_error(FATAL, "copy_dyngrid_to_MOM_grid called with incompatible grids.") + + do i=isd,ied ; do j=jsd,jed + dG%geoLonT(i,j) = oG%geoLonT(i+ido,j+jdo) + dG%geoLatT(i,j) = oG%geoLatT(i+ido,j+jdo) + dG%dxT(i,j) = oG%dxT(i+ido,j+jdo) + dG%dyT(i,j) = oG%dyT(i+ido,j+jdo) + dG%areaT(i,j) = oG%areaT(i+ido,j+jdo) + dG%bathyT(i,j) = oG%bathyT(i+ido,j+jdo) + oG%Z_ref + + dG%dF_dx(i,j) = oG%dF_dx(i+ido,j+jdo) + dG%dF_dy(i,j) = oG%dF_dy(i+ido,j+jdo) + dG%sin_rot(i,j) = oG%sin_rot(i+ido,j+jdo) + dG%cos_rot(i,j) = oG%cos_rot(i+ido,j+jdo) + dG%mask2dT(i,j) = oG%mask2dT(i+ido,j+jdo) + enddo ; enddo + + do I=IsdB,IedB ; do j=jsd,jed + dG%geoLonCu(I,j) = oG%geoLonCu(I+ido,j+jdo) + dG%geoLatCu(I,j) = oG%geoLatCu(I+ido,j+jdo) + dG%dxCu(I,j) = oG%dxCu(I+ido,j+jdo) + dG%dyCu(I,j) = oG%dyCu(I+ido,j+jdo) + dG%dy_Cu(I,j) = oG%dy_Cu(I+ido,j+jdo) + + dG%porous_DminU(I,j) = oG%porous_DminU(I+ido,j+jdo) + oG%Z_ref + dG%porous_DmaxU(I,j) = oG%porous_DmaxU(I+ido,j+jdo) + oG%Z_ref + dG%porous_DavgU(I,j) = oG%porous_DavgU(I+ido,j+jdo) + oG%Z_ref + + dG%mask2dCu(I,j) = oG%mask2dCu(I+ido,j+jdo) + dG%OBCmaskCu(I,j) = oG%OBCmaskCu(I+ido,j+jdo) + dG%areaCu(I,j) = oG%areaCu(I+ido,j+jdo) + dG%IareaCu(I,j) = oG%IareaCu(I+ido,j+jdo) + enddo ; enddo + + do i=isd,ied ; do J=JsdB,JedB + dG%geoLonCv(i,J) = oG%geoLonCv(i+ido,J+jdo) + dG%geoLatCv(i,J) = oG%geoLatCv(i+ido,J+jdo) + dG%dxCv(i,J) = oG%dxCv(i+ido,J+jdo) + dG%dyCv(i,J) = oG%dyCv(i+ido,J+jdo) + dG%dx_Cv(i,J) = oG%dx_Cv(i+ido,J+jdo) + + dG%porous_DminV(i,J) = oG%porous_DminU(i+ido,J+jdo) + oG%Z_ref + dG%porous_DmaxV(i,J) = oG%porous_DmaxU(i+ido,J+jdo) + oG%Z_ref + dG%porous_DavgV(i,J) = oG%porous_DavgU(i+ido,J+jdo) + oG%Z_ref + + dG%mask2dCv(i,J) = oG%mask2dCv(i+ido,J+jdo) + dG%OBCmaskCv(i,J) = oG%OBCmaskCv(i+ido,J+jdo) + dG%areaCv(i,J) = oG%areaCv(i+ido,J+jdo) + dG%IareaCv(i,J) = oG%IareaCv(i+ido,J+jdo) + enddo ; enddo + + do I=IsdB,IedB ; do J=JsdB,JedB + dG%geoLonBu(I,J) = oG%geoLonBu(I+ido,J+jdo) + dG%geoLatBu(I,J) = oG%geoLatBu(I+ido,J+jdo) + dG%dxBu(I,J) = oG%dxBu(I+ido,J+jdo) + dG%dyBu(I,J) = oG%dyBu(I+ido,J+jdo) + dG%areaBu(I,J) = oG%areaBu(I+ido,J+jdo) + dG%CoriolisBu(I,J) = oG%CoriolisBu(I+ido,J+jdo) + dG%mask2dBu(I,J) = oG%mask2dBu(I+ido,J+jdo) + enddo ; enddo + + dG%bathymetry_at_vel = oG%bathymetry_at_vel + if (dG%bathymetry_at_vel) then + do I=IsdB,IedB ; do j=jsd,jed + dG%Dblock_u(I,j) = oG%Dblock_u(I+ido,j+jdo) + oG%Z_ref + dG%Dopen_u(I,j) = oG%Dopen_u(I+ido,j+jdo) + oG%Z_ref + enddo ; enddo + do i=isd,ied ; do J=JsdB,JedB + dG%Dblock_v(i,J) = oG%Dblock_v(i+ido,J+jdo) + oG%Z_ref + dG%Dopen_v(i,J) = oG%Dopen_v(i+ido,J+jdo) + oG%Z_ref + enddo ; enddo + endif + + dG%gridLonT(dG%isg:dG%ieg) = oG%gridLonT(oG%isg:oG%ieg) + dG%gridLatT(dG%jsg:dG%jeg) = oG%gridLatT(oG%jsg:oG%jeg) + + ! The more complicated logic here avoids segmentation faults if one grid uses + ! global symmetric memory while the other does not. Because a northeast grid + ! convention is being used, the upper bounds for each array correspond. + ! Note that the dynamic grid always uses symmetric memory. + Ido2 = oG%IegB-dG%IegB ; Igst = max(dG%isg-1, oG%IsgB-Ido2) + Jdo2 = oG%JegB-dG%JegB ; Jgst = max(dG%jsg-1, oG%JsgB-Jdo2) + do I=Igst,dG%IegB ; dG%gridLonB(I) = oG%gridLonB(I+Ido2) ; enddo + do J=Jgst,dG%JegB ; dG%gridLatB(J) = oG%gridLatB(J+Jdo2) ; enddo + + ! Copy various scalar variables and strings. + dG%x_axis_units = oG%x_axis_units ; dG%y_axis_units = oG%y_axis_units + dG%x_ax_unit_short = oG%x_ax_unit_short ; dG%y_ax_unit_short = oG%y_ax_unit_short + dG%areaT_global = oG%areaT_global ; dG%IareaT_global = oG%IareaT_global + dG%south_lat = oG%south_lat ; dG%west_lon = oG%west_lon + dG%len_lat = oG%len_lat ; dG%len_lon = oG%len_lon + dG%Rad_Earth = oG%Rad_Earth ; dG%Rad_Earth_L = oG%Rad_Earth_L + dG%max_depth = oG%max_depth + +! Update the halos in case the dynamic grid has smaller halos than the ocean grid. + call pass_var(dG%areaT, dG%Domain) + call pass_var(dG%bathyT, dG%Domain) + call pass_var(dG%geoLonT, dG%Domain) + call pass_var(dG%geoLatT, dG%Domain) + call pass_vector(dG%dxT, dG%dyT, dG%Domain, To_All+Scalar_Pair, AGRID) + call pass_vector(dG%dF_dx, dG%dF_dy, dG%Domain, To_All, AGRID) + call pass_vector(dG%cos_rot, dG%sin_rot, dG%Domain, To_All, AGRID) + call pass_var(dG%mask2dT, dG%Domain) + + call pass_vector(dG%areaCu, dG%areaCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(dG%dyCu, dG%dxCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(dG%dxCu, dG%dyCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(dG%dy_Cu, dG%dx_Cv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(dG%mask2dCu, dG%mask2dCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(dG%OBCmaskCu, dG%OBCmaskCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(dG%IareaCu, dG%IareaCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(dG%IareaCu, dG%IareaCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(dG%geoLatCu, dG%geoLatCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) + + call pass_var(dG%areaBu, dG%Domain, position=CORNER) + call pass_var(dG%geoLonBu, dG%Domain, position=CORNER, inner_halo=dG%isc-isd) + call pass_var(dG%geoLatBu, dG%Domain, position=CORNER) + call pass_vector(dG%dxBu, dG%dyBu, dG%Domain, To_All+Scalar_Pair, BGRID_NE) + call pass_var(dG%CoriolisBu, dG%Domain, position=CORNER) + call pass_var(dG%mask2dBu, dG%Domain, position=CORNER) + + if (dG%bathymetry_at_vel) then + call pass_vector(dG%Dblock_u, dG%Dblock_v, dG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(dG%Dopen_u, dG%Dopen_v, dG%Domain, To_All+Scalar_Pair, CGRID_NE) + endif + + call set_derived_dyn_horgrid(dG, US) + +end subroutine copy_MOM_grid_to_dyngrid + +end module MOM_transcribe_grid diff --git a/core/MOM_unit_tests.F90 b/core/MOM_unit_tests.F90 new file mode 100644 index 0000000000..bd449d0b39 --- /dev/null +++ b/core/MOM_unit_tests.F90 @@ -0,0 +1,56 @@ +!> Invokes unit tests in all modules that have them +module MOM_unit_tests + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, FATAL, is_root_pe +use MOM_hor_bnd_diffusion, only : near_boundary_unit_tests +use MOM_intrinsic_functions, only : intrinsic_functions_unit_tests +use MOM_mixed_layer_restrat, only : mixedlayer_restrat_unit_tests +use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests +use MOM_random, only : random_unit_tests +use MOM_remapping, only : remapping_unit_tests +use MOM_string_functions, only : string_functions_unit_tests +use MOM_CFC_cap, only : CFC_cap_unit_tests +use MOM_EOS, only : EOS_unit_tests + +implicit none ; private + +public unit_tests + +contains + +!> Calls unit tests for other modules. +!! Note that if a unit test returns true, a FATAL error is triggered. +subroutine unit_tests(verbosity) + ! Arguments + integer, intent(in) :: verbosity !< The verbosity level + ! Local variables + logical :: verbose + + verbose = verbosity>=5 + + if (is_root_pe()) then ! The following need only be tested on 1 PE + if (string_functions_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: string_functions_unit_tests FAILED") + if (EOS_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: EOS_unit_tests FAILED") + if (remapping_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: remapping_unit_tests FAILED") + if (intrinsic_functions_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: intrinsic_functions_unit_tests FAILED") + if (neutral_diffusion_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: neutralDiffusionUnitTests FAILED") + if (random_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: random_unit_tests FAILED") + if (near_boundary_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: near_boundary_unit_tests FAILED") + if (CFC_cap_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: CFC_cap_unit_tests FAILED") + if (mixedlayer_restrat_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: mixedlayer_restrat_unit_tests FAILED") + endif + +end subroutine unit_tests + +end module MOM_unit_tests diff --git a/core/MOM_variables.F90 b/core/MOM_variables.F90 new file mode 100644 index 0000000000..cb20837d3b --- /dev/null +++ b/core/MOM_variables.F90 @@ -0,0 +1,590 @@ +!> Provides transparent structures with groups of MOM6 variables and supporting routines +module MOM_variables + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_array_transform, only : rotate_array, rotate_vector +use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type +use MOM_coupler_types, only : coupler_type_spawn, coupler_type_destructor, coupler_type_initialized +use MOM_coupler_types, only : coupler_type_copy_data +use MOM_debugging, only : hchksum +use MOM_domains, only : MOM_domain_type, get_domain_extent, group_pass_type +use MOM_EOS, only : EOS_type +use MOM_error_handler, only : MOM_error, FATAL +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_types, only : tracer_type + +implicit none ; private + +#include + +public allocate_surface_state, deallocate_surface_state, MOM_thermovar_chksum +public ocean_grid_type, alloc_BT_cont_type, dealloc_BT_cont_type +public rotate_surface_state + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> A structure for creating arrays of pointers to 3D arrays +type, public :: p3d + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array +end type p3d +!> A structure for creating arrays of pointers to 2D arrays +type, public :: p2d + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array +end type p2d + +!> Pointers to various fields which may be used describe the surface state of MOM, and which +!! will be returned to the calling program +type, public :: surface + real, allocatable, dimension(:,:) :: & + SST, & !< The sea surface temperature [C ~> degC]. + SSS, & !< The sea surface salinity [S ~> psu or gSalt/kg]. + sfc_density, & !< The mixed layer density [R ~> kg m-3]. + Hml, & !< The mixed layer depth [Z ~> m]. + u, & !< The mixed layer zonal velocity [L T-1 ~> m s-1]. + v, & !< The mixed layer meridional velocity [L T-1 ~> m s-1]. + sea_lev, & !< The sea level [Z ~> m]. If a reduced surface gravity is + !! used, that is compensated for in sea_lev. + frazil, & !< The energy needed to heat the ocean column to the freezing point during + !! the call to step_MOM [Q R Z ~> J m-2]. + melt_potential, & !< Instantaneous amount of heat that can be used to melt sea ice [Q R Z ~> J m-2]. + !! This is computed w.r.t. surface freezing temperature. + ocean_mass, & !< The total mass of the ocean [R Z ~> kg m-2]. + ocean_heat, & !< The total heat content of the ocean in [C R Z ~> degC kg m-2]. + ocean_salt, & !< The total salt content of the ocean in [1e-3 S R Z ~> kgSalt m-2]. + taux_shelf, & !< The zonal stresses on the ocean under shelves [R L Z T-2 ~> Pa]. + tauy_shelf !< The meridional stresses on the ocean under shelves [R L Z T-2 ~> Pa]. + logical :: T_is_conT = .false. !< If true, the temperature variable SST is actually the + !! conservative temperature in [C ~> degC]. + logical :: S_is_absS = .false. !< If true, the salinity variable SSS is actually the + !! absolute salinity in [S ~> gSalt kg-1]. + type(coupler_2d_bc_type) :: tr_fields !< A structure that may contain an + !! array of named fields describing tracer-related quantities. + !### NOTE: ALL OF THE ARRAYS IN TR_FIELDS USE THE COUPLER'S INDEXING CONVENTION AND HAVE NO + !### HALOS! THIS IS DONE TO CONFORM TO THE TREATMENT IN MOM4, BUT I DON'T LIKE IT! -RWH + logical :: arrays_allocated = .false. !< A flag that indicates whether the surface type + !! has had its memory allocated. +end type surface + +!> Pointers to an assortment of thermodynamic fields that may be available, including +!! potential temperature, salinity, heat capacity, and the equation of state control structure. +type, public :: thermo_var_ptrs + ! If allocated, the following variables have nz layers. + real, pointer :: T(:,:,:) => NULL() !< Potential temperature [C ~> degC]. + real, pointer :: S(:,:,:) => NULL() !< Salinity [PSU] or [gSalt/kg], generically [S ~> ppt]. + real, pointer :: p_surf(:,:) => NULL() !< Ocean surface pressure used in equation of state + !! calculations [R L2 T-2 ~> Pa] + type(EOS_type), pointer :: eqn_of_state => NULL() !< Type that indicates the + !! equation of state to use. + real :: P_Ref !< The coordinate-density reference pressure [R L2 T-2 ~> Pa]. + !! This is the pressure used to calculate Rml from + !! T and S when eqn_of_state is associated. + real :: C_p !< The heat capacity of seawater [Q C-1 ~> J degC-1 kg-1]. + !! When conservative temperature is used, this is + !! constant and exactly 3991.86795711963 J degC-1 kg-1. + logical :: T_is_conT = .false. !< If true, the temperature variable tv%T is + !! actually the conservative temperature [degC]. + logical :: S_is_absS = .false. !< If true, the salinity variable tv%S is + !! actually the absolute salinity in units of [gSalt kg-1]. + real :: min_salinity !< The minimum value of salinity when BOUND_SALINITY=True [S ~> ppt]. + real, allocatable, dimension(:,:,:) :: SpV_avg + !< The layer averaged in situ specific volume [R-1 ~> m3 kg-1]. + integer :: valid_SpV_halo = -1 !< If positive, the valid halo size for SpV_avg, or if negative + !! SpV_avg is not currently set. + + ! These arrays are accumulated fluxes for communication with other components. + real, dimension(:,:), pointer :: frazil => NULL() + !< The energy needed to heat the ocean column to the + !! freezing point since calculate_surface_state was2 + !! last called [Q Z R ~> J m-2]. + real, dimension(:,:), pointer :: salt_deficit => NULL() + !< The salt needed to maintain the ocean column + !! at a minimum salinity of MIN_SALINITY since the last time + !! that calculate_surface_state was called, [S R Z ~> gSalt m-2]. + real, dimension(:,:), pointer :: TempxPmE => NULL() + !< The net inflow of water into the ocean times the + !! temperature at which this inflow occurs since the + !! last call to calculate_surface_state [C R Z ~> degC kg m-2]. + !! This should be prescribed in the forcing fields, but + !! as it often is not, this is a useful heat budget diagnostic. + real, dimension(:,:), pointer :: internal_heat => NULL() + !< Any internal or geothermal heat sources that + !! have been applied to the ocean since the last call to + !! calculate_surface_state [C R Z ~> degC kg m-2]. + ! The following variables are most normally not used but when they are they + ! will be either set by parameterizations or prognostic. + real, pointer :: varT(:,:,:) => NULL() !< SGS variance of potential temperature [C2 ~> degC2]. + real, pointer :: varS(:,:,:) => NULL() !< SGS variance of salinity [S2 ~> ppt2]. + real, pointer :: covarTS(:,:,:) => NULL() !< SGS covariance of salinity and potential + !! temperature [C S ~> degC ppt]. + type(tracer_type), pointer :: tr_T => NULL() !< pointer to temp in tracer registry + type(tracer_type), pointer :: tr_S => NULL() !< pointer to salinty in tracer registry +end type thermo_var_ptrs + +!> Pointers to all of the prognostic variables allocated in MOM_variables.F90 and MOM.F90. +!! +!! It is useful for sending these variables for diagnostics, and in preparation for ensembles +!! later on. All variables have the same names as the local (public) variables +!! they refer to in MOM.F90. +type, public :: ocean_internal_state + real, pointer, dimension(:,:,:) :: & + T => NULL(), & !< Pointer to the temperature state variable [C ~> degC] + S => NULL(), & !< Pointer to the salinity state variable [S ~> ppt] (i.e., PSU or g/kg) + u => NULL(), & !< Pointer to the zonal velocity [L T-1 ~> m s-1] + v => NULL(), & !< Pointer to the meridional velocity [L T-1 ~> m s-1] + h => NULL() !< Pointer to the layer thicknesses [H ~> m or kg m-2] + real, pointer, dimension(:,:,:) :: & + uh => NULL(), & !< Pointer to zonal transports [H L2 T-1 ~> m3 s-1 or kg s-1] + vh => NULL() !< Pointer to meridional transports [H L2 T-1 ~> m3 s-1 or kg s-1] + real, pointer, dimension(:,:,:) :: & + CAu => NULL(), & !< Pointer to the zonal Coriolis and Advective acceleration [L T-2 ~> m s-2] + CAv => NULL(), & !< Pointer to the meridional Coriolis and Advective acceleration [L T-2 ~> m s-2] + PFu => NULL(), & !< Pointer to the zonal Pressure force acceleration [L T-2 ~> m s-2] + PFv => NULL(), & !< Pointer to the meridional Pressure force acceleration [L T-2 ~> m s-2] + diffu => NULL(), & !< Pointer to the zonal acceleration due to lateral viscosity [L T-2 ~> m s-2] + diffv => NULL(), & !< Pointer to the meridional acceleration due to lateral viscosity [L T-2 ~> m s-2] + pbce => NULL(), & !< Pointer to the baroclinic pressure force dependency on free surface movement + !! [L2 T-2 H-1 ~> m s-2 or m4 kg-1 s-2] + u_accel_bt => NULL(), & !< Pointer to the zonal barotropic-solver acceleration [L T-2 ~> m s-2] + v_accel_bt => NULL() !< Pointer to the meridional barotropic-solver acceleration [L T-2 ~> m s-2] + real, pointer, dimension(:,:,:) :: & + u_av => NULL(), & !< Pointer to zonal velocity averaged over the timestep [L T-1 ~> m s-1] + v_av => NULL(), & !< Pointer to meridional velocity averaged over the timestep [L T-1 ~> m s-1] + u_prev => NULL(), & !< Pointer to zonal velocity at the end of the last timestep [L T-1 ~> m s-1] + v_prev => NULL() !< Pointer to meridional velocity at the end of the last timestep [L T-1 ~> m s-1] +end type ocean_internal_state + +!> Pointers to arrays with accelerations, which can later be used for derived diagnostics, like energy balances. +type, public :: accel_diag_ptrs + + ! Each of the following fields has nz layers. + real, pointer, dimension(:,:,:) :: & + diffu => NULL(), & !< Zonal acceleration due to along isopycnal viscosity [L T-2 ~> m s-2] + diffv => NULL(), & !< Meridional acceleration due to along isopycnal viscosity [L T-2 ~> m s-2] + CAu => NULL(), & !< Zonal Coriolis and momentum advection accelerations [L T-2 ~> m s-2] + CAv => NULL(), & !< Meridional Coriolis and momentum advection accelerations [L T-2 ~> m s-2] + PFu => NULL(), & !< Zonal acceleration due to pressure forces [L T-2 ~> m s-2] + PFv => NULL(), & !< Meridional acceleration due to pressure forces [L T-2 ~> m s-2] + du_dt_visc => NULL(), &!< Zonal acceleration due to vertical viscosity [L T-2 ~> m s-2] + dv_dt_visc => NULL(), &!< Meridional acceleration due to vertical viscosity [L T-2 ~> m s-2] + du_dt_visc_gl90 => NULL(), &!< Zonal acceleration due to GL90 vertical viscosity + ! (is included in du_dt_visc) [L T-2 ~> m s-2] + dv_dt_visc_gl90 => NULL(), &!< Meridional acceleration due to GL90 vertical viscosity + ! (is included in dv_dt_visc) [L T-2 ~> m s-2] + du_dt_str => NULL(), & !< Zonal acceleration due to the surface stress (included + !! in du_dt_visc) [L T-2 ~> m s-2] + dv_dt_str => NULL(), & !< Meridional acceleration due to the surface stress (included + !! in dv_dt_visc) [L T-2 ~> m s-2] + du_dt_dia => NULL(), & !< Zonal acceleration due to diapycnal mixing [L T-2 ~> m s-2] + dv_dt_dia => NULL(), & !< Meridional acceleration due to diapycnal mixing [L T-2 ~> m s-2] + u_accel_bt => NULL(), &!< Pointer to the zonal barotropic-solver acceleration [L T-2 ~> m s-2] + v_accel_bt => NULL() !< Pointer to the meridional barotropic-solver acceleration [L T-2 ~> m s-2] + real, pointer, dimension(:,:,:) :: du_other => NULL() + !< Zonal velocity changes due to any other processes that are + !! not due to any explicit accelerations [L T-1 ~> m s-1]. + real, pointer, dimension(:,:,:) :: dv_other => NULL() + !< Meridional velocity changes due to any other processes that are + !! not due to any explicit accelerations [L T-1 ~> m s-1]. + + ! These accelerations are sub-terms included in the accelerations above. + real, pointer :: gradKEu(:,:,:) => NULL() !< gradKEu = - d/dx(u2) [L T-2 ~> m s-2] + real, pointer :: gradKEv(:,:,:) => NULL() !< gradKEv = - d/dy(u2) [L T-2 ~> m s-2] + real, pointer :: rv_x_v(:,:,:) => NULL() !< rv_x_v = rv * v at u [L T-2 ~> m s-2] + real, pointer :: rv_x_u(:,:,:) => NULL() !< rv_x_u = rv * u at v [L T-2 ~> m s-2] + + real, pointer :: diag_hfrac_u(:,:,:) => NULL() !< Fractional layer thickness at u points [nondim] + real, pointer :: diag_hfrac_v(:,:,:) => NULL() !< Fractional layer thickness at v points [nondim] + real, pointer :: diag_hu(:,:,:) => NULL() !< layer thickness at u points, modulated by the viscous + !! remnant and fractional open areas [H ~> m or kg m-2] + real, pointer :: diag_hv(:,:,:) => NULL() !< layer thickness at v points, modulated by the viscous + !! remnant and fractional open areas [H ~> m or kg m-2] + + real, pointer :: visc_rem_u(:,:,:) => NULL() !< viscous remnant at u points [nondim] + real, pointer :: visc_rem_v(:,:,:) => NULL() !< viscous remnant at v points [nondim] + +end type accel_diag_ptrs + +!> Pointers to arrays with transports, which can later be used for derived diagnostics, like energy balances. +type, public :: cont_diag_ptrs + +! Each of the following fields has nz layers. + real, pointer, dimension(:,:,:) :: & + uh => NULL(), & !< Resolved zonal layer thickness fluxes, [H L2 T-1 ~> m3 s-1 or kg s-1] + vh => NULL(), & !< Resolved meridional layer thickness fluxes, [H L2 T-1 ~> m3 s-1 or kg s-1] + uh_smooth => NULL(), & !< Interface height smoothing induced zonal volume fluxes [H L2 T-1 ~> m3 s-1 or kg s-1] + vh_smooth => NULL(), & !< Interface height smoothing induced meridional volume fluxes [H L2 T-1 ~> m3 s-1 or kg s-1] + uhGM => NULL(), & !< Isopycnal height diffusion induced zonal volume fluxes [H L2 T-1 ~> m3 s-1 or kg s-1] + vhGM => NULL() !< Isopycnal height diffusion induced meridional volume fluxes [H L2 T-1 ~> m3 s-1 or kg s-1] + +! Each of the following fields is found at nz+1 interfaces. + real, pointer :: diapyc_vel(:,:,:) => NULL() !< The net diapycnal velocity [H T-1 ~> m s-1 or kg m-2 s-1] + +end type cont_diag_ptrs + +!> Vertical viscosities, drag coefficients, and related fields. +type, public :: vertvisc_type + real :: Prandtl_turb !< The Prandtl number for the turbulent diffusion + !! that is captured in Kd_shear [nondim]. + real, allocatable, dimension(:,:) :: & + bbl_thick_u, & !< The bottom boundary layer thickness at the u-points [Z ~> m]. + bbl_thick_v, & !< The bottom boundary layer thickness at the v-points [Z ~> m]. + kv_bbl_u, & !< The bottom boundary layer viscosity at the u-points [H Z T-1 ~> m2 s-1 or Pa s] + kv_bbl_v, & !< The bottom boundary layer viscosity at the v-points [H Z T-1 ~> m2 s-1 or Pa s] + ustar_BBL, & !< The turbulence velocity in the bottom boundary layer at + !! h points [H T-1 ~> m s-1 or kg m-2 s-1]. + TKE_BBL, & !< A term related to the bottom boundary layer source of turbulent kinetic + !! energy, currently in [H Z2 T-3 ~> m3 s-3 or W m-2]. + taux_shelf, & !< The zonal stresses on the ocean under shelves [R Z L T-2 ~> Pa]. + tauy_shelf !< The meridional stresses on the ocean under shelves [R Z L T-2 ~> Pa]. + real, allocatable, dimension(:,:) :: tbl_thick_shelf_u + !< Thickness of the viscous top boundary layer under ice shelves at u-points [Z ~> m]. + real, allocatable, dimension(:,:) :: tbl_thick_shelf_v + !< Thickness of the viscous top boundary layer under ice shelves at v-points [Z ~> m]. + real, allocatable, dimension(:,:) :: kv_tbl_shelf_u + !< Viscosity in the viscous top boundary layer under ice shelves at + !! u-points [H Z T-1 ~> m2 s-1 or Pa s] + real, allocatable, dimension(:,:) :: kv_tbl_shelf_v + !< Viscosity in the viscous top boundary layer under ice shelves at + !! v-points [H Z T-1 ~> m2 s-1 or Pa s] + real, allocatable, dimension(:,:) :: nkml_visc_u + !< The number of layers in the viscous surface mixed layer at u-points [nondim]. + !! This is not an integer because there may be fractional layers, and it is stored in + !! terms of layers, not depth, to facilitate the movement of the viscous boundary layer + !! with the flow. + real, allocatable, dimension(:,:) :: nkml_visc_v + !< The number of layers in the viscous surface mixed layer at v-points [nondim]. + real, allocatable, dimension(:,:,:) :: & + Ray_u, & !< The Rayleigh drag velocity to be applied to each layer at u-points [H T-1 ~> m s-1 or Pa s m-1]. + Ray_v !< The Rayleigh drag velocity to be applied to each layer at v-points [H T-1 ~> m s-1 or Pa s m-1]. + + ! The following elements are pointers so they can be used as targets for pointers in the restart registry. + real, pointer, dimension(:,:) :: MLD => NULL() !< Instantaneous active mixing layer depth [Z ~> m]. + real, pointer, dimension(:,:) :: sfc_buoy_flx => NULL() !< Surface buoyancy flux (derived) [Z2 T-3 ~> m2 s-3]. + real, pointer, dimension(:,:,:) :: Kd_shear => NULL() + !< The shear-driven turbulent diapycnal diffusivity at the interfaces between layers + !! in tracer columns [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, pointer, dimension(:,:,:) :: Kv_shear => NULL() + !< The shear-driven turbulent vertical viscosity at the interfaces between layers + !! in tracer columns [H Z T-1 ~> m2 s-1 or Pa s] + real, pointer, dimension(:,:,:) :: Kv_shear_Bu => NULL() + !< The shear-driven turbulent vertical viscosity at the interfaces between layers in + !! corner columns [H Z T-1 ~> m2 s-1 or Pa s] + real, pointer, dimension(:,:,:) :: Kv_slow => NULL() + !< The turbulent vertical viscosity component due to "slow" processes (e.g., tidal, + !! background, convection etc) [H Z T-1 ~> m2 s-1 or Pa s] + real, pointer, dimension(:,:,:) :: TKE_turb => NULL() + !< The turbulent kinetic energy per unit mass at the interfaces [Z2 T-2 ~> m2 s-2]. + !! This may be at the tracer or corner points +end type vertvisc_type + +!> Container for information about the summed layer transports +!! and how they will vary as the barotropic velocity is changed. +type, public :: BT_cont_type + real, allocatable :: FA_u_EE(:,:) !< The effective open face area for zonal barotropic transport + !! drawing from locations far to the east [H L ~> m2 or kg m-1]. + real, allocatable :: FA_u_E0(:,:) !< The effective open face area for zonal barotropic transport + !! drawing from nearby to the east [H L ~> m2 or kg m-1]. + real, allocatable :: FA_u_W0(:,:) !< The effective open face area for zonal barotropic transport + !! drawing from nearby to the west [H L ~> m2 or kg m-1]. + real, allocatable :: FA_u_WW(:,:) !< The effective open face area for zonal barotropic transport + !! drawing from locations far to the west [H L ~> m2 or kg m-1]. + real, allocatable :: uBT_WW(:,:) !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], beyond which the + !! marginal open face area is FA_u_WW. uBT_WW must be non-negative. + real, allocatable :: uBT_EE(:,:) !< uBT_EE is a barotropic velocity [L T-1 ~> m s-1], beyond which the + !! marginal open face area is FA_u_EE. uBT_EE must be non-positive. + real, allocatable :: FA_v_NN(:,:) !< The effective open face area for meridional barotropic transport + !! drawing from locations far to the north [H L ~> m2 or kg m-1]. + real, allocatable :: FA_v_N0(:,:) !< The effective open face area for meridional barotropic transport + !! drawing from nearby to the north [H L ~> m2 or kg m-1]. + real, allocatable :: FA_v_S0(:,:) !< The effective open face area for meridional barotropic transport + !! drawing from nearby to the south [H L ~> m2 or kg m-1]. + real, allocatable :: FA_v_SS(:,:) !< The effective open face area for meridional barotropic transport + !! drawing from locations far to the south [H L ~> m2 or kg m-1]. + real, allocatable :: vBT_SS(:,:) !< vBT_SS is the barotropic velocity, [L T-1 ~> m s-1], beyond which the + !! marginal open face area is FA_v_SS. vBT_SS must be non-negative. + real, allocatable :: vBT_NN(:,:) !< vBT_NN is the barotropic velocity, [L T-1 ~> m s-1], beyond which the + !! marginal open face area is FA_v_NN. vBT_NN must be non-positive. + real, allocatable :: h_u(:,:,:) !< An effective thickness at zonal faces, taking into account the effects + !! of vertical viscosity and fractional open areas [H ~> m or kg m-2]. + !! This is primarily used as a non-normalized weight in determining + !! the depth averaged accelerations for the barotropic solver. + real, allocatable :: h_v(:,:,:) !< An effective thickness at meridional faces, taking into account the effects + !! of vertical viscosity and fractional open areas [H ~> m or kg m-2]. + !! This is primarily used as a non-normalized weight in determining + !! the depth averaged accelerations for the barotropic solver. + type(group_pass_type) :: pass_polarity_BT !< Structure for polarity group halo updates + type(group_pass_type) :: pass_FA_uv !< Structure for face area group halo updates +end type BT_cont_type + +!> Container for grids modifying cell metric at porous barriers +! TODO: rename porous_barrier_type to porous_barrier_type +type, public :: porous_barrier_type + ! Each of the following fields has nz layers. + real, allocatable :: por_face_areaU(:,:,:) !< fractional open area of U-faces [nondim] + real, allocatable :: por_face_areaV(:,:,:) !< fractional open area of V-faces [nondim] + ! Each of the following fields is found at nz+1 interfaces. + real, allocatable :: por_layer_widthU(:,:,:) !< fractional open width of U-faces [nondim] + real, allocatable :: por_layer_widthV(:,:,:) !< fractional open width of V-faces [nondim] +end type porous_barrier_type + +contains + +!> Allocates the fields for the surface (return) properties of +!! the ocean model. Unused fields are unallocated. +subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & + gas_fields_ocn, use_meltpot, use_iceshelves, & + omit_frazil) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(surface), intent(inout) :: sfc_state !< ocean surface state type to be allocated. + logical, optional, intent(in) :: use_temperature !< If true, allocate the space for thermodynamic variables. + logical, optional, intent(in) :: do_integrals !< If true, allocate the space for vertically + !! integrated fields. + type(coupler_1d_bc_type), & + optional, intent(in) :: gas_fields_ocn !< If present, this type describes the ocean + !! ocean and surface-ice fields that will participate + !! in the calculation of additional gas or other + !! tracer fluxes, and can be used to spawn related + !! internal variables in the ice model. + logical, optional, intent(in) :: use_meltpot !< If true, allocate the space for melt potential + logical, optional, intent(in) :: use_iceshelves !< If true, allocate the space for the stresses + !! under ice shelves. + logical, optional, intent(in) :: omit_frazil !< If present and false, do not allocate the space to + !! pass frazil fluxes to the coupler + + ! local variables + logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil + integer :: is, ie, js, je, isd, ied, jsd, jed + integer :: isdB, iedB, jsdB, jedB + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isdB = G%isdB ; iedB = G%iedB; jsdB = G%jsdB ; jedB = G%jedB + + use_temp = .true. ; if (present(use_temperature)) use_temp = use_temperature + alloc_integ = .true. ; if (present(do_integrals)) alloc_integ = do_integrals + use_melt_potential = .false. ; if (present(use_meltpot)) use_melt_potential = use_meltpot + alloc_iceshelves = .false. ; if (present(use_iceshelves)) alloc_iceshelves = use_iceshelves + alloc_frazil = .true. ; if (present(omit_frazil)) alloc_frazil = .not.omit_frazil + + if (sfc_state%arrays_allocated) return + + if (use_temp) then + allocate(sfc_state%SST(isd:ied,jsd:jed), source=0.0) + allocate(sfc_state%SSS(isd:ied,jsd:jed), source=0.0) + else + allocate(sfc_state%sfc_density(isd:ied,jsd:jed), source=0.0) + endif + if (use_temp .and. alloc_frazil) then + allocate(sfc_state%frazil(isd:ied,jsd:jed), source=0.0) + endif + allocate(sfc_state%sea_lev(isd:ied,jsd:jed), source=0.0) + allocate(sfc_state%Hml(isd:ied,jsd:jed), source=0.0) + allocate(sfc_state%u(IsdB:IedB,jsd:jed), source=0.0) + allocate(sfc_state%v(isd:ied,JsdB:JedB), source=0.0) + + if (use_melt_potential) then + allocate(sfc_state%melt_potential(isd:ied,jsd:jed), source=0.0) + endif + + if (alloc_integ) then + ! Allocate structures for the vertically integrated ocean_mass, ocean_heat, and ocean_salt. + allocate(sfc_state%ocean_mass(isd:ied,jsd:jed), source=0.0) + if (use_temp) then + allocate(sfc_state%ocean_heat(isd:ied,jsd:jed), source=0.0) + allocate(sfc_state%ocean_salt(isd:ied,jsd:jed), source=0.0) + endif + endif + + if (alloc_iceshelves) then + allocate(sfc_state%taux_shelf(IsdB:IedB,jsd:jed), source=0.0) + allocate(sfc_state%tauy_shelf(isd:ied,JsdB:JedB), source=0.0) + endif + + if (present(gas_fields_ocn)) & + call coupler_type_spawn(gas_fields_ocn, sfc_state%tr_fields, & + (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + + sfc_state%arrays_allocated = .true. + +end subroutine allocate_surface_state + +!> Deallocates the elements of a surface state type. +subroutine deallocate_surface_state(sfc_state) + type(surface), intent(inout) :: sfc_state !< ocean surface state type to be deallocated here. + + if (.not.sfc_state%arrays_allocated) return + + if (allocated(sfc_state%melt_potential)) deallocate(sfc_state%melt_potential) + if (allocated(sfc_state%SST)) deallocate(sfc_state%SST) + if (allocated(sfc_state%SSS)) deallocate(sfc_state%SSS) + if (allocated(sfc_state%sfc_density)) deallocate(sfc_state%sfc_density) + if (allocated(sfc_state%sea_lev)) deallocate(sfc_state%sea_lev) + if (allocated(sfc_state%Hml)) deallocate(sfc_state%Hml) + if (allocated(sfc_state%u)) deallocate(sfc_state%u) + if (allocated(sfc_state%v)) deallocate(sfc_state%v) + if (allocated(sfc_state%ocean_mass)) deallocate(sfc_state%ocean_mass) + if (allocated(sfc_state%ocean_heat)) deallocate(sfc_state%ocean_heat) + if (allocated(sfc_state%ocean_salt)) deallocate(sfc_state%ocean_salt) + call coupler_type_destructor(sfc_state%tr_fields) + + sfc_state%arrays_allocated = .false. + +end subroutine deallocate_surface_state + +!> Rotate the surface state fields from the input to the model indices. +subroutine rotate_surface_state(sfc_state_in, sfc_state, G, turns) + type(surface), intent(in) :: sfc_state_in + type(surface), intent(inout) :: sfc_state + type(ocean_grid_type), intent(in) :: G + integer, intent(in) :: turns + + logical :: use_temperature, do_integrals, use_melt_potential, use_iceshelves + + ! NOTE: Many of these are weak tests, since only one is checked + use_temperature = allocated(sfc_state_in%SST) & + .and. allocated(sfc_state_in%SSS) + use_melt_potential = allocated(sfc_state_in%melt_potential) + do_integrals = allocated(sfc_state_in%ocean_mass) + use_iceshelves = allocated(sfc_state_in%taux_shelf) & + .and. allocated(sfc_state_in%tauy_shelf) + + if (.not. sfc_state%arrays_allocated) then + call allocate_surface_state(sfc_state, G, & + use_temperature=use_temperature, & + do_integrals=do_integrals, & + use_meltpot=use_melt_potential, & + use_iceshelves=use_iceshelves & + ) + sfc_state%arrays_allocated = .true. + endif + + if (use_temperature) then + call rotate_array(sfc_state_in%SST, turns, sfc_state%SST) + call rotate_array(sfc_state_in%SSS, turns, sfc_state%SSS) + else + call rotate_array(sfc_state_in%sfc_density, turns, sfc_state%sfc_density) + endif + + call rotate_array(sfc_state_in%Hml, turns, sfc_state%Hml) + call rotate_vector(sfc_state_in%u, sfc_state_in%v, turns, & + sfc_state%u, sfc_state%v) + call rotate_array(sfc_state_in%sea_lev, turns, sfc_state%sea_lev) + + if (use_melt_potential) then + call rotate_array(sfc_state_in%melt_potential, turns, sfc_state%melt_potential) + endif + + if (do_integrals) then + call rotate_array(sfc_state_in%ocean_mass, turns, sfc_state%ocean_mass) + if (use_temperature) then + call rotate_array(sfc_state_in%ocean_heat, turns, sfc_state%ocean_heat) + call rotate_array(sfc_state_in%ocean_salt, turns, sfc_state%ocean_salt) + call rotate_array(sfc_state_in%SSS, turns, sfc_state%SSS) + endif + endif + + if (use_iceshelves) then + call rotate_vector(sfc_state_in%taux_shelf, sfc_state_in%tauy_shelf, turns, & + sfc_state%taux_shelf, sfc_state%tauy_shelf) + endif + + if (use_temperature .and. allocated(sfc_state_in%frazil)) & + call rotate_array(sfc_state_in%frazil, turns, sfc_state%frazil) + + ! Scalar transfers + sfc_state%T_is_conT = sfc_state_in%T_is_conT + sfc_state%S_is_absS = sfc_state_in%S_is_absS + + ! NOTE: Tracer fields are handled by FMS, so are left unrotated. Any + ! reads/writes to tr_fields must be appropriately rotated. + if (coupler_type_initialized(sfc_state_in%tr_fields)) then + call coupler_type_copy_data(sfc_state_in%tr_fields, sfc_state%tr_fields) + endif +end subroutine rotate_surface_state + +!> Allocates the arrays contained within a BT_cont_type and initializes them to 0. +subroutine alloc_BT_cont_type(BT_cont, G, GV, alloc_faces) + type(BT_cont_type), pointer :: BT_cont !< The BT_cont_type whose elements will be allocated + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + logical, optional, intent(in) :: alloc_faces !< If present and true, allocate + !! memory for effective face thicknesses. + + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (associated(BT_cont)) call MOM_error(FATAL, & + "alloc_BT_cont_type called with an associated BT_cont_type pointer.") + + allocate(BT_cont) + allocate(BT_cont%FA_u_WW(IsdB:IedB,jsd:jed), source=0.0) + allocate(BT_cont%FA_u_W0(IsdB:IedB,jsd:jed), source=0.0) + allocate(BT_cont%FA_u_E0(IsdB:IedB,jsd:jed), source=0.0) + allocate(BT_cont%FA_u_EE(IsdB:IedB,jsd:jed), source=0.0) + allocate(BT_cont%uBT_WW(IsdB:IedB,jsd:jed), source=0.0) + allocate(BT_cont%uBT_EE(IsdB:IedB,jsd:jed), source=0.0) + + allocate(BT_cont%FA_v_SS(isd:ied,JsdB:JedB), source=0.0) + allocate(BT_cont%FA_v_S0(isd:ied,JsdB:JedB), source=0.0) + allocate(BT_cont%FA_v_N0(isd:ied,JsdB:JedB), source=0.0) + allocate(BT_cont%FA_v_NN(isd:ied,JsdB:JedB), source=0.0) + allocate(BT_cont%vBT_SS(isd:ied,JsdB:JedB), source=0.0) + allocate(BT_cont%vBT_NN(isd:ied,JsdB:JedB), source=0.0) + + if (present(alloc_faces)) then ; if (alloc_faces) then + allocate(BT_cont%h_u(IsdB:IedB,jsd:jed,1:nz), source=0.0) + allocate(BT_cont%h_v(isd:ied,JsdB:JedB,1:nz), source=0.0) + endif ; endif + +end subroutine alloc_BT_cont_type + +!> Deallocates the arrays contained within a BT_cont_type. +subroutine dealloc_BT_cont_type(BT_cont) + type(BT_cont_type), pointer :: BT_cont !< The BT_cont_type whose elements will be deallocated. + + if (.not.associated(BT_cont)) return + + deallocate(BT_cont%FA_u_WW) ; deallocate(BT_cont%FA_u_W0) + deallocate(BT_cont%FA_u_E0) ; deallocate(BT_cont%FA_u_EE) + deallocate(BT_cont%uBT_WW) ; deallocate(BT_cont%uBT_EE) + + deallocate(BT_cont%FA_v_SS) ; deallocate(BT_cont%FA_v_S0) + deallocate(BT_cont%FA_v_N0) ; deallocate(BT_cont%FA_v_NN) + deallocate(BT_cont%vBT_SS) ; deallocate(BT_cont%vBT_NN) + + if (allocated(BT_cont%h_u)) deallocate(BT_cont%h_u) + if (allocated(BT_cont%h_v)) deallocate(BT_cont%h_v) + + deallocate(BT_cont) + +end subroutine dealloc_BT_cont_type + +!> Diagnostic checksums on various elements of a thermo_var_ptrs type for debugging. +subroutine MOM_thermovar_chksum(mesg, tv, G, US) + character(len=*), intent(in) :: mesg !< A message that appears in the checksum lines + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Note that for the chksum calls to be useful for reproducing across PE + ! counts, there must be no redundant points, so all variables use is..ie + ! and js...je as their extent. + if (associated(tv%T)) & + call hchksum(tv%T, mesg//" tv%T", G%HI, scale=US%C_to_degC) + if (associated(tv%S)) & + call hchksum(tv%S, mesg//" tv%S", G%HI, scale=US%S_to_ppt) + if (associated(tv%frazil)) & + call hchksum(tv%frazil, mesg//" tv%frazil", G%HI, scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + if (associated(tv%salt_deficit)) & + call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI, scale=US%RZ_to_kg_m2*US%S_to_ppt) + if (associated(tv%TempxPmE)) & + call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI, scale=US%RZ_to_kg_m2*US%C_to_degC) +end subroutine MOM_thermovar_chksum + +end module MOM_variables diff --git a/core/MOM_verticalGrid.F90 b/core/MOM_verticalGrid.F90 new file mode 100644 index 0000000000..b6cc97d943 --- /dev/null +++ b/core/MOM_verticalGrid.F90 @@ -0,0 +1,366 @@ +!> Provides a transparent vertical ocean grid type and supporting routines +module MOM_verticalGrid + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +#include + +public verticalGridInit, verticalGridEnd +public setVerticalGridAxes +public get_flux_units, get_thickness_units, get_tr_flux_units + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Describes the vertical ocean grid, including unit conversion factors +type, public :: verticalGrid_type + + ! Commonly used parameters + integer :: ke !< The number of layers/levels in the vertical + real :: max_depth !< The maximum depth of the ocean [Z ~> m]. + real :: mks_g_Earth !< The gravitational acceleration in unscaled MKS units [m s-2]. + real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. + real :: Rho0 !< The density used in the Boussinesq approximation or nominal + !! density used to convert depths into mass units [R ~> kg m-3]. + + ! Vertical coordinate descriptions for diagnostics and I/O + character(len=40) :: zAxisUnits !< The units that vertical coordinates are written in + character(len=40) :: zAxisLongName !< Coordinate name to appear in files, + !! e.g. "Target Potential Density" or "Height" + real, allocatable, dimension(:) :: sLayer !< Coordinate values of layer centers, in unscaled + !! units that depend on the vertical coordinate, such as [kg m-3] for an + !! isopycnal or some hybrid coordinates, [m] for a Z* coordinate, + !! or [nondim] for a sigma coordinate. + real, allocatable, dimension(:) :: sInterface !< Coordinate values on interfaces, in the same + !! unscale units as sLayer [various]. + integer :: direction = 1 !< Direction defaults to 1, positive up. + + ! The following variables give information about the vertical grid. + logical :: Boussinesq !< If true, make the Boussinesq approximation. + logical :: semi_Boussinesq !< If true, do non-Boussinesq pressure force calculations and + !! use mass-based "thicknesses, but use Rho0 to convert layer thicknesses + !! into certain height changes. This only applies if BOUSSINESQ is false. + real :: Angstrom_H !< A one-Angstrom thickness in the model thickness units [H ~> m or kg m-2]. + real :: Angstrom_Z !< A one-Angstrom thickness in the model depth units [Z ~> m]. + real :: Angstrom_m !< A one-Angstrom thickness [m]. + real :: H_subroundoff !< A thickness that is so small that it can be added to a thickness of + !! Angstrom or larger without changing it at the bit level [H ~> m or kg m-2]. + !! If Angstrom is 0 or exceedingly small, this is negligible compared to 1e-17 m. + real :: dZ_subroundoff !< A thickness in height units that is so small that it can be added to a + !! vertical distance of Angstrom_Z or 1e-17 m without changing it at the bit + !! level [Z ~> m]. This is the height equivalent of H_subroundoff. + real, allocatable, dimension(:) :: & + g_prime, & !< The reduced gravity at each interface [L2 Z-1 T-2 ~> m s-2]. + Rlay !< The target coordinate value (potential density) in each layer [R ~> kg m-3]. + integer :: nkml = 0 !< The number of layers at the top that should be treated + !! as parts of a homogeneous region. + integer :: nk_rho_varies = 0 !< The number of layers at the top where the + !! density does not track any target density. + real :: H_to_kg_m2 !< A constant that translates thicknesses from the units of thickness + !! to kg m-2 [kg m-2 H-1 ~> kg m-3 or 1]. + real :: kg_m2_to_H !< A constant that translates thicknesses from kg m-2 to the units + !! of thickness [H m2 kg-1 ~> m3 kg-1 or 1]. + real :: m_to_H !< A constant that translates distances in m to the units of + !! thickness [H m-1 ~> 1 or kg m-3]. + real :: H_to_m !< A constant that translates distances in the units of thickness + !! to m [m H-1 ~> 1 or m3 kg-1]. + real :: H_to_Pa !< A constant that translates the units of thickness to pressure + !! [Pa H-1 = kg m-1 s-2 H-1 ~> kg m-2 s-2 or m s-2]. + real :: H_to_Z !< A constant that translates thickness units to the units of + !! depth [Z H-1 ~> 1 or m3 kg-1]. + real :: Z_to_H !< A constant that translates depth units to thickness units + !! depth [H Z-1 ~> 1 or kg m-3]. + real :: H_to_RZ !< A constant that translates thickness units to the units of + !! mass per unit area [R Z H-1 ~> kg m-3 or 1]. + real :: RZ_to_H !< A constant that translates mass per unit area units to + !! thickness units [H R-1 Z-1 ~> m3 kg-2 or 1]. + real :: H_to_MKS !< A constant that translates thickness units to its MKS unit + !! (m or kg m-2) based on GV%Boussinesq [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] + real :: m2_s_to_HZ_T !< The combination of conversion factors that converts kinematic viscosities + !! in m2 s-1 to the internal units of the kinematic (in Boussinesq mode) + !! or dynamic viscosity [H Z s T-1 m-2 ~> 1 or kg m-3] + real :: HZ_T_to_m2_s !< The combination of conversion factors that converts the viscosities from + !! their internal representation into a kinematic viscosity in m2 s-1 + !! [T m2 H-1 Z-1 s-1 ~> 1 or m3 kg-1] + real :: HZ_T_to_MKS !< The combination of conversion factors that converts the viscosities from + !! their internal representation into their unnscaled MKS units + !! (m2 s-1 or Pa s), depending on whether the model is Boussinesq + !! [T m2 H-1 Z-1 s-1 ~> 1] or [T Pa s H-1 Z-1 ~> 1] + +end type verticalGrid_type + +contains + +!> Allocates and initializes the ocean model vertical grid structure. +subroutine verticalGridInit( param_file, GV, US ) + type(param_file_type), intent(in) :: param_file !< Parameter file handle/type + type(verticalGrid_type), pointer :: GV !< The container for vertical grid data + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! This routine initializes the verticalGrid_type structure (GV). + ! All memory is allocated but not necessarily set to meaningful values until later. + + ! Local variables + integer :: nk, H_power + real :: H_rescale_factor ! The integer power of 2 by which thicknesses are rescaled [nondim] + real :: rho_Kv ! The density used convert input kinematic viscosities into dynamic viscosities + ! when in non-Boussinesq mode [R ~> kg m-3] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=16) :: mdl = 'MOM_verticalGrid' + + if (associated(GV)) call MOM_error(FATAL, & + 'verticalGridInit: called with an associated GV pointer.') + allocate(GV) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, & + "Parameters providing information about the vertical grid.", & + log_to_all=.true., debugging=.true.) + call get_param(param_file, mdl, "G_EARTH", GV%g_Earth, & + "The gravitational acceleration of the Earth.", & + units="m s-2", default=9.80, scale=US%Z_to_m*US%m_s_to_L_T**2) + call get_param(param_file, mdl, "RHO_0", GV%Rho0, & + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "BOUSSINESQ", GV%Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true.) + call get_param(param_file, mdl, "SEMI_BOUSSINESQ", GV%semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=GV%Boussinesq) + if (GV%Boussinesq) GV%semi_Boussinesq = .true. + call get_param(param_file, mdl, "RHO_KV_CONVERT", Rho_Kv, & + "The density used to convert input vertical distances into thickesses in "//& + "non-BOUSSINESQ mode, and to convert kinematic viscosities into dynamic "//& + "viscosities and similarly for vertical diffusivities. GV%m_to_H is set "//& + "using this value, whereas GV%Z_to_H is set using RHO_0. The default is "//& + "RHO_0, but this can be set separately to demonstrate the independence of the "//& + "non-Boussinesq solutions of the value of RHO_0.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=GV%Boussinesq) + call get_param(param_file, mdl, "ANGSTROM", GV%Angstrom_Z, & + "The minimum layer thickness, usually one-Angstrom.", & + units="m", default=1.0e-10, scale=US%m_to_Z) + call get_param(param_file, mdl, "H_RESCALE_POWER", H_power, & + "An integer power of 2 that is used to rescale the model's "//& + "intenal units of thickness. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) + if (abs(H_power) > 300) call MOM_error(FATAL, "verticalGridInit: "//& + "H_RESCALE_POWER is outside of the valid range of -300 to 300.") + H_rescale_factor = 1.0 + if (H_power /= 0) H_rescale_factor = 2.0**H_power + if (.not.GV%Boussinesq) then + call get_param(param_file, mdl, "H_TO_KG_M2", GV%H_to_kg_m2,& + "A constant that translates thicknesses from the model's "//& + "internal units of thickness to kg m-2.", units="kg m-2 H-1", & + default=1.0) + GV%H_to_kg_m2 = GV%H_to_kg_m2 * H_rescale_factor + else + call get_param(param_file, mdl, "H_TO_M", GV%H_to_m, & + "A constant that translates the model's internal "//& + "units of thickness into m.", units="m H-1", default=1.0) + GV%H_to_m = GV%H_to_m * H_rescale_factor + endif + GV%mks_g_Earth = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth +#ifdef STATIC_MEMORY_ + ! Here NK_ is a macro, while nk is a variable. + call get_param(param_file, mdl, "NK", nk, & + "The number of model layers.", units="nondim", & + default=NK_) + if (nk /= NK_) call MOM_error(FATAL, "verticalGridInit: " // & + "Mismatched number of layers NK_ between MOM_memory.h and param_file") + +#else + call get_param(param_file, mdl, "NK", nk, & + "The number of model layers.", units="nondim", fail_if_missing=.true.) +#endif + GV%ke = nk + + if (GV%Boussinesq) then + GV%H_to_kg_m2 = US%R_to_kg_m3*GV%Rho0 * GV%H_to_m + GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 + GV%m_to_H = 1.0 / GV%H_to_m + GV%H_to_MKS = GV%H_to_m + GV%m2_s_to_HZ_T = GV%m_to_H * US%m_to_Z * US%T_to_s + + GV%H_to_Z = GV%H_to_m * US%m_to_Z + GV%Z_to_H = US%Z_to_m * GV%m_to_H + else + GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 + ! GV%m_to_H = US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H + GV%m_to_H = US%R_to_kg_m3*rho_Kv * GV%kg_m2_to_H + GV%H_to_MKS = GV%H_to_kg_m2 + GV%m2_s_to_HZ_T = US%R_to_kg_m3*rho_Kv * GV%kg_m2_to_H * US%m_to_Z * US%T_to_s + GV%H_to_m = 1.0 / GV%m_to_H + + GV%H_to_Z = US%m_to_Z * ( GV%H_to_kg_m2 / (US%R_to_kg_m3*GV%Rho0) ) + GV%Z_to_H = US%Z_to_m * ( US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H ) + endif + + GV%Angstrom_H = (US%Z_to_m * GV%m_to_H) * GV%Angstrom_Z + GV%Angstrom_m = US%Z_to_m * GV%Angstrom_Z + + GV%H_subroundoff = 1e-20 * max(GV%Angstrom_H, GV%m_to_H*1e-17) + GV%dZ_subroundoff = 1e-20 * max(GV%Angstrom_Z, US%m_to_Z*1e-17) + + GV%H_to_Pa = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth * GV%H_to_kg_m2 + + GV%H_to_RZ = GV%H_to_kg_m2 * US%kg_m3_to_R * US%m_to_Z + GV%RZ_to_H = GV%kg_m2_to_H * US%R_to_kg_m3 * US%Z_to_m + + GV%HZ_T_to_m2_s = 1.0 / GV%m2_s_to_HZ_T + GV%HZ_T_to_MKS = GV%H_to_MKS * US%Z_to_m * US%s_to_T + + ! Note based on the above that for both Boussinsq and non-Boussinesq cases that: + ! GV%Rho0 = GV%Z_to_H * GV%H_to_RZ + ! 1.0/GV%Rho0 = GV%H_to_Z * GV%RZ_to_H + ! This is exact for power-of-2 scaling of the units, regardless of the value of Rho0, but + ! the first term on the right hand side is invertable in Boussinesq mode, but the second + ! is invertable when non-Boussinesq. + + ! Log derivative values. + call log_param(param_file, mdl, "M to THICKNESS", GV%m_to_H*H_rescale_factor, units="H m-1") + call log_param(param_file, mdl, "M to THICKNESS rescaled by 2^-n", GV%m_to_H, units="2^n H m-1") + call log_param(param_file, mdl, "THICKNESS to M rescaled by 2^n", GV%H_to_m, units="2^-n m H-1") + + allocate( GV%sInterface(nk+1) ) + allocate( GV%sLayer(nk) ) + allocate( GV%g_prime(nk+1), source=0.0 ) + allocate( GV%Rlay(nk), source=0.0 ) + +end subroutine verticalGridInit + +!> Returns the model's thickness units, usually m or kg/m^2. +function get_thickness_units(GV) + character(len=48) :: get_thickness_units !< The vertical thickness units + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + ! This subroutine returns the appropriate units for thicknesses, + ! depending on whether the model is Boussinesq or not and the scaling for + ! the vertical thickness. + + if (GV%Boussinesq) then + get_thickness_units = "m" + else + get_thickness_units = "kg m-2" + endif +end function get_thickness_units + +!> Returns the model's thickness flux units, usually m^3/s or kg/s. +function get_flux_units(GV) + character(len=48) :: get_flux_units !< The thickness flux units + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + ! This subroutine returns the appropriate units for thickness fluxes, + ! depending on whether the model is Boussinesq or not and the scaling for + ! the vertical thickness. + + if (GV%Boussinesq) then + get_flux_units = "m3 s-1" + else + get_flux_units = "kg s-1" + endif +end function get_flux_units + +!> Returns the model's tracer flux units. +function get_tr_flux_units(GV, tr_units, tr_vol_conc_units, tr_mass_conc_units) + character(len=48) :: get_tr_flux_units !< The model's flux units + !! for a tracer. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical + !! grid structure. + character(len=*), optional, intent(in) :: tr_units !< Units for a tracer, for example + !! Celsius or PSU. + character(len=*), optional, intent(in) :: tr_vol_conc_units !< The concentration units per unit + !! volume, for example if the units are + !! umol m-3, tr_vol_conc_units would + !! be umol. + character(len=*), optional, intent(in) :: tr_mass_conc_units !< The concentration units per unit + !! mass of sea water, for example if + !! the units are mol kg-1, + !! tr_vol_conc_units would be mol. + + ! This subroutine returns the appropriate units for thicknesses and fluxes, + ! depending on whether the model is Boussinesq or not and the scaling for + ! the vertical thickness. + integer :: cnt + + cnt = 0 + if (present(tr_units)) cnt = cnt+1 + if (present(tr_vol_conc_units)) cnt = cnt+1 + if (present(tr_mass_conc_units)) cnt = cnt+1 + + if (cnt == 0) call MOM_error(FATAL, "get_tr_flux_units: One of the three "//& + "arguments tr_units, tr_vol_conc_units, or tr_mass_conc_units "//& + "must be present.") + if (cnt > 1) call MOM_error(FATAL, "get_tr_flux_units: Only one of "//& + "tr_units, tr_vol_conc_units, and tr_mass_conc_units may be present.") + if (present(tr_units)) then + if (GV%Boussinesq) then + get_tr_flux_units = trim(tr_units)//" m3 s-1" + else + get_tr_flux_units = trim(tr_units)//" kg s-1" + endif + endif + if (present(tr_vol_conc_units)) then + if (GV%Boussinesq) then + get_tr_flux_units = trim(tr_vol_conc_units)//" s-1" + else + get_tr_flux_units = trim(tr_vol_conc_units)//" m-3 kg s-1" + endif + endif + if (present(tr_mass_conc_units)) then + if (GV%Boussinesq) then + get_tr_flux_units = trim(tr_mass_conc_units)//" kg-1 m3 s-1" + else + get_tr_flux_units = trim(tr_mass_conc_units)//" s-1" + endif + endif + +end function get_tr_flux_units + +!> This sets the coordinate data for the "layer mode" of the isopycnal model. +subroutine setVerticalGridAxes( Rlay, GV, scale ) + type(verticalGrid_type), intent(inout) :: GV !< The container for vertical grid data + real, dimension(GV%ke), intent(in) :: Rlay !< The layer target density [R ~> kg m-3] + real, intent(in) :: scale !< A unit scaling factor for Rlay to convert + !! it into the units of sInterface, usually + !! [kg m-3 R-1 ~> 1] when used in layer mode. + ! Local variables + integer :: k, nk + + nk = GV%ke + + GV%zAxisLongName = 'Target Potential Density' + GV%zAxisUnits = 'kg m-3' + do k=1,nk ; GV%sLayer(k) = scale*Rlay(k) ; enddo + if (nk > 1) then + GV%sInterface(1) = scale * (1.5*Rlay(1) - 0.5*Rlay(2)) + do K=2,nk ; GV%sInterface(K) = scale * 0.5*( Rlay(k-1) + Rlay(k) ) ; enddo + GV%sInterface(nk+1) = scale * (1.5*Rlay(nk) - 0.5*Rlay(nk-1)) + else + GV%sInterface(1) = 0.0 ; GV%sInterface(nk+1) = 2.0*scale*Rlay(nk) + endif + +end subroutine setVerticalGridAxes + +!> Deallocates the model's vertical grid structure. +subroutine verticalGridEnd( GV ) + type(verticalGrid_type), pointer :: GV !< The ocean's vertical grid structure + + deallocate( GV%g_prime, GV%Rlay ) + deallocate( GV%sInterface , GV%sLayer ) + deallocate( GV ) + +end subroutine verticalGridEnd + +end module MOM_verticalGrid diff --git a/core/_Baroclinic_Momentum.dox b/core/_Baroclinic_Momentum.dox new file mode 100644 index 0000000000..b342f86bee --- /dev/null +++ b/core/_Baroclinic_Momentum.dox @@ -0,0 +1,37 @@ +/*! \page Baroclinic_Momentum_Equations Baroclinic Momentum Equations + +\section section_BC_momentum Baroclinic Momentum Equations + +The baroclinic momentum equations are the stacked shallow water equations: + +\f[ + \frac{\partial \vec{u}_k}{\partial t} + (f + \nabla_s \times \vec{u}_k) \hat{z} + \times \vec{u}_k = - \frac{\nabla_s p_k}{\rho} - \nabla_s (\phi_k + \frac{1}{2} || + \vec{u}_k ||^2 ) + \frac{\nabla \cdot \tilde{\tau}_k}{\rho} +\f] +\f[ + \frac{\partial h_k}{\partial t} + \nabla_s \cdot (\vec{u}h_k) = 0 +\f] + +The timestepping for these equations is a (quasi?) second-order Runge-Kutta step +for the inertial oscillations and a forward-backward Euler step for the pressure +(gravity) waves. Using the graphical notation from \cite shchepetkin2005, it looks +like: + +\image html timestep_MOM6.png "Graphical notation for timestepping schemes in which the black line represents the ideal solution and the red line shows the actual solution. Phase errors are represented by the grey shapes between the bars normal to the circle." +\image latex timestep_MOM6.png "Graphical notation for timestepping schemes in which the black line represents the ideal solution and the red line shows the actual solution. Phase errors are represented by the grey shapes between the bars normal to the circle." + +The timestep used in ROMS looks instead like: + +\image html timestep_ROMS.png "Graphical notation for the Adams-Bashforth technique used in the ROMS model." +\image latex timestep_ROMS.png "Graphical notation for the Adams-Bashforth technique used in the ROMS model." + +The ROMS timestepping has smaller phase errors, strong damping at high +frequency. The MOM6 use as a global climate model has made the phase +errors of lower priority. However, the phase errors may become more +problematic for future uses of MOM6. While the MOM6 use of the ALE +remapping makes an Adams-Bashforth scheme impractical, there may be a +better timestepping scheme out there for MOM6. Please let the MOM6 +developers know if you would like to work on this problem. + +*/ diff --git a/core/_Barotropic_Baroclinic_Coupling.dox b/core/_Barotropic_Baroclinic_Coupling.dox new file mode 100644 index 0000000000..f8bb366197 --- /dev/null +++ b/core/_Barotropic_Baroclinic_Coupling.dox @@ -0,0 +1,305 @@ +/*! \page Barotropic_Baroclinic_Coupling Barotropic-Baroclinic Coupling + +\brief Time-averaged accelerations + +The barotropic equations are timestepped with a timestep to resolve the surface +gravity waves. With care, the baroclinic timestep only need resolve the inertial +oscillations. The barotropic accelerations are averaged over the many barotropic +timesteps taken between baroclinic steps. At time \f$n\f$, the baroclinic +accelerations are computed. The vertical average of that acceleration is +subtracted off and replaced by the time-averaged acceleration from the group of +barotropic timesteps: + +\f[ + \Delta t \frac{\partial \vec{u}}{\partial t} = \Delta t \left( + \frac{\partial \vec{u}}{\partial t} - \frac{\partial \vec{u}_{BT}}{\partial t} + \right)^n + \Delta t \overline{\frac{\partial \vec{u}_{BT}}{\partial t}}^{\Delta t} +\f] + +Similarly, the velocities used in the tracer equation are a careful blend of the +barotropic and baroclinic solutions: + +\f[ + \Delta t \frac{\partial \theta}{\partial t} + \Delta t \left( \tilde{\vec{u}} + \cdot \nabla \theta + \widetilde{w} \frac{\partial \theta}{\partial z} \right) +\f] +with +\f[ + \tilde{\vec{u}} = \vec{u}_{BC} + \overline{\vec{u}_{BT}}^{\Delta t} +\f] +\f[ + \frac{\partial \widetilde{w}}{\partial z} = - \nabla \cdot \tilde{\vec{u}} +\f] + +\section SSH_Estimates Two estimates of the free surface height + +The vertically discrete, temporally continuous layer continuity equations are: + +\f[ + \frac{\partial h_k}{\partial t} = - \nabla \cdot (\vec{u} h_k) = - \nabla \cdot + \mathbf{F} (u_k, h_k) +\f] + +The relationship between the free surface height and the layer thicknesses +\f$h_k\f$ is: + +\f[ + \eta = \sum_{k=1}^N h_k - D +\f] + +We get an evolution equation for the free surface height: + +\f[ + \frac{\partial \eta}{\partial t} = \sum_{k=1}^N \frac{\partial + h_k}{\partial t} = - \nabla \cdot \sum_{k=1}^N \mathbf{F} (u_k, h_k) +\f] + +If the algorithms for the fluxes in the continuity equations are \em linear in +the velocity, the free surface height can be rewritten as: + +\f[ + \frac{\partial \eta}{\partial t} \&= - \nabla \cdot \sum_{k=1}^N \mathbf{F} (u_k, h_k) + = - \nabla \cdot \sum_{k=1}^N (\vec{u}_k h_k) \\ + \&= - \nabla \cdot \left[ \sum_{k=1}^N h_k \frac{\sum_{k=1}^N (\vec{u}_k h_k)} + {\sum_{k=1}^M k_k} \right] \equiv - \nabla \cdot H \mathbf{U} +\f] +where + +\f[ + \mathbf{U} \equiv \frac{\sum_{k=1}^N (\vec{u}_k h_k)} {\sum_{k=1}^M k_k} +\f] +\f[ + H \equiv \sum_{k=1}^N h_k +\f] +However, ALE models like MOM6 require positive-definite, nonlinear continuity +solvers (MOM6 uses \ref PPM). We need a different way to reconcile this +estimate of free surface height with the one coming from the barotropic equations. +After rejecting several other options, MOM6 is now using the scheme from +\cite hallberg2009. The barotropic update of \f$\eta\f$ is given by: + +\f[ + \frac{\eta^{n+1} - \eta^n}{\Delta t} + \nabla \cdot \left( \overline{UH} \right) = 0 +\f] + +Determine the \f$\Delta U\f$ such that: + +\f[ + \sum_{k=1}^N \mathbf{F} (\tilde{u}_k, h_k) = \left( \overline{UH} \right) +\f] +where +\f[ + \tilde{u}_k = u_k + \Delta U +\f] + +The layer timestep equation becomes: + +\f[ + h_k^{n+1} = h_k^n - \Delta t \nabla \cdot \mathbf{F} (\tilde{u}_k, h_k) +\f] + +This scheme has these properties: + +\li Total mass is conserved layer-wise. +\li Layer equations retain their flux form. +\li Total salt, heat, and other tracers are exactly conserved. +\li Free surface heights exactly agree. +\li Requires (very few) completely local iterations. +\li The velocity corrections are barotropic, and more likely to correspond to the +layers whose flow was deficient than in some older schemes. + +The solution is unique provided that: +\f[ + \frac{\partial}{\partial \tilde{u}_k} \mathbf{F}(\tilde{u}_k, h_k) > 0 +\f] +This is a reasonable requirement for any discretization of the continuity +equation. In the continuous limit, \f$\mathbf{F} (u,h) = uh\f$, so one +interpretation is: +\f[ + \frac{\partial}{\partial \tilde{u}_k} \mathbf{F}(\tilde{u}_k, h_k) = + h_{k,\mbox{Marginal}} +\f] +With the PPM continuity scheme: +\f[ + F_{i+1/2} = \frac{1}{\Delta t} \int_{x_{i+1/2} - u \Delta t}^{x_{i+1/2}} h_i^n + (x) dx +\f] +leads to: +\f[ + \frac{\partial F_{i+1/2}}{\partial u_{i+1/2}} = h_i^n ( x_{i+1/2} - u_{i+1/2} + \Delta t ) \equiv h_{k, \mbox{Marginal}} +\f] +\f$h_i(x) > 0\f$ is already required for positive definiteness. + +Newton's method iterations quickly give \f$\Delta U\f$: +\f[ + \Delta U^{m+1} = \Delta U^m + \frac{\left( \overline{UH} \right) - \sum_{k=1}^N + F(u_k + \Delta U^m, h_k)}{\sum_{k=1}^N h_{k,\mbox{Marginal}}} +\f] + +\subsection subsec_practical How practical is this iterative approach? + +The piecewise parabolic method continuity solver uses two steps: + +\li Set up the positive-definite subgridscale profiles, \f$h_{PPM}(x)\f$. + +\image html h_PPM.png "Piecewise parabolic reconstructions of \f$h(x)\f$." +\imagelatex{h_PPM.png,Piecewise parabolic reconstructions of $h(x)$.,\includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true]} + +\li Integrating the profiles to determine \f$F\f$. Step 1 is typically +\f$\sim 3\f$ times as expensive as step 2. \f$F(u,h)\f$ is piecewise cubic in +\f$u\f$, but often nearly linear. Newton's method iterations converge quickly: + +\image html Newton_PPM.png "Newton's method iterations for finding \f$\\Delta U\f$." +\imagelatex{Newton_PPM.png,Newton's method iterations for finding $\Delta U$.,\includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true]} + +In a global model the sea surface heights converge everywhere to a tolerance of +\f$10^{-6}\f$ m within five iterations. These five iterations add \f$\sim 1.6\f$ +times more CPU time to the PPM continuity solver and the continuity solver is just +12\% of the total model time. + +\subsection bottom_drag A note on bottom drag + +Barotropic accelerations do not lead to barotropic flows after a timestep when +vertical viscosity is taken into account. + +\f[ + u_k^{n+1} = u_k^n + \Delta t A_k + \Delta t \frac{\tau_{k-1/2} - + \tau_{k+1/2}}{h_k} +\f] + +\f[ + \tau_{1/2} = \tau_{Wind} +\f] +\f[ + \tau_{k+1/2} = \nu_{k+1/2} \frac{u_k^{n+1} - u_{k+1}^{n+1}}{h_{k+1/2}} +\f] +\f[ + \tau_{N+1/2} = \nu_{N+1/2} \frac{2 u_N^{n+1}}{h_{N+1/2}} +\f] +\f[ + \gamma_k \equiv \frac{1}{\Delta t} \frac{\partial u_k^{n+1}} + {\overline{\partial A}} +\f] + +A tridiagonal equation for \f$\gamma_k\f$ results, going from 0 for thin layers +near the bottom to 1 far above the bottom. + +\f[ + \gamma_1 = 1 + \frac{1}{h_1} \left[ - \frac{\nu_{3/2} \Delta t}{h_{3/2}} + (\gamma_1 - \gamma_2) \right] +\f] +\f[ + \gamma_k = 1 + \frac{1}{h_k} \left[ \frac{\nu_{k-1/2} \Delta t}{h_{k-1/2}} + (\gamma_{k-1} - \gamma_k) - \frac{\nu_{k+1/2} \Delta t}{h_{k+1/2}} + (\gamma_k - \gamma_{k+1}) \right] +\f] +\f[ + \gamma_N = 1 + \frac{1}{h_N} \left[ \frac{\nu_{N-1/2} \Delta t}{h_{N-1/2}} + (\gamma_{N-1} - \gamma_N) - \frac{2\nu_{N+1/2} \Delta t}{h_{N+1/2}} + \gamma_N \right] +\f] + +In the continuous limit: + +\f[ + \gamma(z) = 1 + \Delta t \frac{d}{dz} \left( \nu \frac{d \gamma}{dz} \right) +\f] +with boundary conditions: +\f[ + \frac{d \gamma}{dz} (0) = 0 +\f] +\f[ + \gamma(-D) = 0 +\f] + +For deep water and constant \f$\nu\f$, we get: +\f[ + \gamma (z) = 1 - \exp \left( - \sqrt{\nu \Delta t} (z + D) \right) +\f] + +\image html bottom_drag.png "The continuous solution for barotropic flow plus a no-slip condition at the bottom." +\image latex bottom_drag.png "The continuous solution for barotropic flow plus a no-slip condition at the bottom." + +We want a scheme in which the split model looks exactly like the unsplit +model would if we had taken all those short 3D timesteps. Rather than +applying a barotropic velocity, we use a barotropic acceleration and +allow the continuity solver to determine the transports consistent with a +no-slip bottom boundary layer and perhaps also a no-slip surface boundary +layer under an ice shelf. + +From above, the barotropic equation is: + +\f[ + \frac{\eta^{n+1} - \eta^n}{\Delta t} + \nabla \cdot \left( \overline{UH} \right) = 0 +\f] +We need to determine the \f$\Delta \overline{A}\f$ such that: +\f[ + \sum_{k=1}^N \mathbf{F} (\tilde{u}_k, h_k) = \left( \overline{UH} \right) +\f] +where +\f[ + \tilde{u}_k = u_k + \gamma_k \Delta \overline{A} \Delta t +\f] + +\section bt-bc_details Additional details about the split time stepping + +\li Transports are used as input and output to the barotropic solver. The continuity +solver is inverted to determine velocities. + +\f[ + \frac{\partial \eta}{\partial t} = \nabla \cdot \overline{U} + M +\f] +\f[ + \overline{U} (\overline{u}) = \frac{1}{\Delta t} \int_0^{\overline{u} \Delta t} + H(x) dx +\f] +\f[ + \overline{u}^n = \overline{U}^{-1} \left( \sum_{k=1}^N U_k^n \right) +\f] +\f[ + u_k^{n+1} = \tilde{u}_k^{n+1} + \Delta \overline{u} +\f] + +We need to find \f$\Delta \overline{u}\f$ such that: + +\f[ + \sum_{k=1}^N U_k \left( \tilde{u}_k^{n+1} + \Delta \overline{u} \right) = + \overline{U}^{n+1} +\f] + +\li Barotropic accelerations are treated as anomalies from the baroclinic state: + +\f[ + \frac{\partial \overline{u}}{\partial t} \&= - f \hat{k} \times (\overline{u} - + \overline{u}_{Cor}) - \nabla \overline{g} (\eta - \eta_{PF}) - \\ + \& \frac{c_D \left( ||u_{Bot}|| + ||u_{Shelf}|| \right)}{\sum_{k=1}^N h_k} + (\overline{u} - \overline{u}_{Drag}) + \frac{\sum_{k=1}^N h_k \frac{\partial + u_k}{\partial t}} {\sum_{k=1}^N h_k} +\f] + +\li Bottom drag (and under ice surface-drag) is treated implicitly. +\li The barotropic continuity solver uses flow-dependent thickness fits which +approximate the sum of the layer thickness transports, to accommodate wetting and +drying. An image of this is shown here: + +\image html bt_bc_thickness.png "The barotropic transports depend on the baroclinic flows and thicknesses." +\image latex bt_bc_thickness.png "The barotropic transports depend on the baroclinic flows and thicknesses." + +\section time-split_summary Summary of MOM6 split time stepping + +\li We use an efficient approach for handling fast modes via simplified 2-d +equations, while the 3-d baroclinic timestep is determined by baroclinic dynamics. + +\li The barotropic solver determines free surface height and time-averaged +depth-integrated transports. + +\li By using anomalies, the MOM6 split solver gives identical answers to an +equivalent unsplit scheme for short timesteps. + +\li This scheme has been demonstrated to work with wetting and drying, as well as +under ice-shelves. + +\li The linear barotropic solver allows MOM6 to automatically set a stable +barotropic timestep (e.g.\ to 98\% of maximum). + +*/ diff --git a/core/_Barotropic_Momentum.dox b/core/_Barotropic_Momentum.dox new file mode 100644 index 0000000000..39442263b0 --- /dev/null +++ b/core/_Barotropic_Momentum.dox @@ -0,0 +1,50 @@ +/*! \page Barotropic_Momentum_Equations Barotropic Momentum Equations + +\brief Barotropic Momentum Equations + +The barotropic equations are timestepped on a relatively short timestep compared to the +rest of the model. Since the timestep constraints for this are known, the barotropic +timestep is computed at runtime. + +The 2-d linear momentum equations with integrated continuity are: + +\f[ + \frac{\partial \eta}{\partial t} + \nabla \cdot \left( ( D + \eta) \vec{u}_{BT} + h_k \right) = P - E +\f] +\f[ + \frac{\partial \vec{u}_{BT}}{\partial t} = - g \nabla \eta - f \hat{z} \times + \vec{u}_{BT} + \vec{F}_{BT} +\f] +where +\f[ + \vec{u}_{BT} \equiv \frac{1}{D + \eta} \int_{-D}^\eta \vec{u}dz +\f] + +and \f$\vec{F}_{BT}\f$ is the barotropic momentum forcing from baroclinic +processes. Note that explicit mass fluxes such as evaporation and +precipitation change the model volume explicitly. + +In the mode splitting between baroclinic and barotropic processes, it is important +to include the contribution of free surface waves on the internal interface +heights on the pressure gradient force, shown here as \f$g_{Eff}\f$: + +\f[ + \frac{\partial p}{\partial z} = -\rho g +\f] +\f[ + g_{Eff} = g + \frac{\partial}{\partial \eta} \left[ \frac{1}{D + \eta} + \int_{-D}^\eta p dz \right] +\f] + +The barotropic momentum equation then becomes: + +\f[ + \frac{\partial \vec{u}_{BT}}{\partial t} + f \hat{z} \times + \vec{u}_{BT} + \frac{1}{\rho_0} \nabla g_{Eff} \eta = \mbox{Residual} +\f] + +Without including the internal wave motion in the barotropic equations, one can +generate instabilities (\cite bleck1990, \cite hallberg1997a). + +*/ diff --git a/core/_Discrete_Coriolis.dox b/core/_Discrete_Coriolis.dox new file mode 100644 index 0000000000..781ae0c752 --- /dev/null +++ b/core/_Discrete_Coriolis.dox @@ -0,0 +1,121 @@ +/*! \page Discrete_Coriolis Discrete Coriolis Term + +\section Coriolis Coriolis Term +In general, the discrete equations are written as simple difference equations +based on the Arakawa C-grid as described in section \ref horizontal_grids. +One of the more interesting exceptions is the Coriolis term. It is computed in the +form shown in \eqref{eq:h-horz-momentum,h-equations,momentum}, or: + +\f[ + \frac{( f + \zeta )}{h} \, \hat{\mathbf{z}} \times h \, \mathbf{u} +\f] + +This term needs to be evaluated at \f$u\f$ points for the \f$v\f$ equation and +vice versa, plus we need to keep the thickness, \f$h\f$, positive definite. +MOM6 contains a number of options for how to compute this term. + +\li SADOURNY75_ENERGY Sadourny \cite sadourny1975 figured out how to +conserve energy or enstrophy but not both. This option is energy conserving. +The term in the \f$u\f$ equation becomes: +\f[ + \frac{1}{4 dx} \left( q_{i,j} (vh_{i+1,j} + vh_{i,j}) + + q_{i,j-1} (vh_{i+1,j-1} + vh_{i,j-1}) \right) +\f] +where \f$q = \frac{f + \zeta}{h}\f$ and \f$h\f$ is an area-weighted +average of the four thicknesses surrounding the \f$q\f$ point, such that +it is guaranteed to be positive definite. + +There is a variant on this scheme with the CORIOLIS_EN_DIS option. If true, +two estimates of the thickness fluxes \f$vh\f$ are used to estimate the Coriolis +term, and the one that dissipates energy relative to the other one +is used. + +\li SADOURNY75_ENSTRO Also from \cite sadourny1975, this option is enstrophy +conserving. +\f[ + \frac{1}{8 dx} ( q_{i,j} + q_{i,j-1} ) ((vh_{i+1,j} + vh_{i,j}) + + (vh_{i+1,j-1} + vh_{i,j-1}) ) +\f] + +\li ARAKAWA_LAMB81 From \cite arakawa1981 is a scheme which is both +energy and enstrophy conserving. Its weaknesses are a large stencil and differing +thickness stencils in the numerator and denominator. +This scheme and several others (with differing values of \f$a, +b, c, d\f$ and \f$ep\f$) are implemented as: +\f{eqnarray}{ + \frac{1}{dx} (a_{i,j} vh_{i+1,j} &+ b_{i,j} vh_{i,j} + + d_{i,j} vh_{i+1,j-1} + c_{i,j} vh_{i,j-1} \\ + &+ ep_{i,j}*uh_{i-1,j} - + ep_{i+1,j}*uh_{i+1,j}) \label{eq:Coriolis_abcd} +\f} +with +\f{eqnarray}{ + a_{i,j} &= \frac{1}{24} (2.0*(q_{i+1,j} + q_{i,j-1}) + (q_{i,j} + q_{i+1,j-1})) \\ + b_{i,j} &= \frac{1}{24} ((q_{i,j} + q_{i-1,j-1}) + 2.0*(q_{i-1,j} + q_{i,j-1})) \\ + c_{i,j} &= \frac{1}{24} (2.0*(q_{i,j} + q_{i-1,j-1}) + (q_{i-1,j} + q_{i,j-1})) \\ + d_{i,j} &= \frac{1}{24} ((q_{i+1,j} + q_{i,j-1}) + 2.0*(q_{i,j} + q_{i+1,j-1})) \\ + ep_{i,j} &= \frac{1}{24}((q_{i,j} - q_{i-1,j-1}) + (q_{i-1,j} - q_{i,j-1})) +\f} + +\li ARAKAWA_HSU90 From \cite arakawa1990 is a scheme which always conserves +energy and conserves enstrophy in the limit of non-divergent flow. This one +has a larger stencil than Sadourny's energy scheme, but it's much better behaved +in terms of handling vanishing layers than Arakawa and Lamb. +This scheme is implemented with: +\f[ + \frac{1}{dx} (a_{i,j} vh_{i+1,j} + b_{i,j} vh_{i,j} + + d_{i,j} vh_{i+1,j-1} + c_{i,j} vh_{i,j-1}) +\f] +and +\f{eqnarray}{ + a_{i,j} &= \frac{1}{12} (q_{i,j} + (q_{i+1,j} + q_{i,j-1})) \\ + b_{i,j} &= \frac{1}{12} (q_{i,j} + (q_{i-1,j} + q_{i,j-1})) \\ + c_{i,j} &= \frac{1}{12} (q_{i,j} + (q_{i-1,j-1} + q_{i,j-1})) \\ + d_{i,j} &= \frac{1}{12} (q_{i,j} + (q_{i+1,j-1} + q_{i,j-1})) +\f} + +\li ARAKAWA_LAMB_BLEND This is a blending of Arakawa and Lamb, Arakawa and Hsu, +and the Sadourny Energy scheme. There are weights CORIOLIS_BLEND_WT_LIN and +CORIOLIS_BLEND_F_EFF_MAX to control this scheme. The equation is the same as for +Arakawa and Lamb \eqref{eq:Coriolis_abcd}, but the values of \f$a, b, c, d\f$ and +\f$ep\f$ differ when the pure Arakawa and Lamb scheme breaks down due to thickness +variations. + +\li ROBUST_ENSTRO An enstrophy-conserving scheme which is robust to vanishing +layers. + +Some of these options also support the BOUND_CORIOLIS flag. If true, +the Coriolis terms in the \f$u\f$ equation are bounded by the four estimates of +\f$\frac{(f+\zeta)}{h}vh\f$ from the four neighboring \f$v\f$ points, and +similarly in the \f$v\f$ equation. This option would have no effect +on the SADOURNY75_ENERGY scheme if it were possible to use centered +difference thickness fluxes. + +Note, if BOUND_CORIOLIS is on, it will also turn on the +BOUND_CORIOLIS_BIHARM option by default. This option uses a viscosity +that increases with the square of the velocity shears, so that the +resulting viscous drag is of comparable magnitude to the Coriolis +terms when the velocity differences between adjacent grid points is +0.5*BOUND_CORIOLIS_VEL. + +\subsection Coriolis_BC Wall boundary conditions + +Two sets of boundary conditions have been coded in the +definition of relative vorticity. These are written as: + +NOSLIP defined (in spherical coordinates): +\f{eqnarray}{ + \mbox{relvort} &= dv/dx \mbox{ (east $\&$ west)}, \mbox{ with } v = 0. \\ + \mbox{relvort} &= -\sec(\phi) * d(u \cos(\phi))/dy \mbox{ (north $\&$ + south)}, \mbox{ with } u = 0. +\f} + +Free slip (NOSLIP not defined): +\f[ + \mbox{relvort} = 0 \mbox{ (all boundaries)} +\f] + +with \f$\phi\f$ defined as latitude. The free slip boundary +condition is much more natural on a C-grid. + +*/ diff --git a/core/_Discrete_OBC.dox b/core/_Discrete_OBC.dox new file mode 100644 index 0000000000..1d0ca4393f --- /dev/null +++ b/core/_Discrete_OBC.dox @@ -0,0 +1,7 @@ +/*! \page Discrete_OBC Discrete Open Boundary Conditions + +\brief Discrete Open Boundary Conditions + + + +*/ diff --git a/core/_Discrete_PG.dox b/core/_Discrete_PG.dox new file mode 100644 index 0000000000..1939b7c79d --- /dev/null +++ b/core/_Discrete_PG.dox @@ -0,0 +1,147 @@ +/*! \page Discrete_PG Discrete Pressure Gradient Term + +\section section_PG Pressure Gradient Term + +Following \cite adcroft2008, the horizontal momentum equation in the general +coordinate \f$r\f$ can be written as: +\f[ + \frac{\partial \vec{u}}{\partial t} + \nabla_r \Phi + \alpha \nabla_r p = \cal{F} +\f] +where the vector \f$\cal{F}\f$ represents all the forcing terms other than the pressure +gradient. Here, \f$\vec{u}\f$ is the horizontal component of the velocity, +\f$\Phi\f$ is the geopotential: +\f[ + \Phi = gz +\f] +\f$\alpha = 1/\rho\f$ is the specific volume and \f$p\f$ is the pressure. The +gradient operator is a gradient along the coordinate surface \f$r\f$. + +MOM6 offers two options, an older one using a Montgomery potential as described in +\cite hallberg1997 and \cite sun1999. However, it can have the instability +described in \cite hallberg2005. The version described here is that in \cite adcroft2008 +and is the recommended option (ANALYTIC_FV_PGF = True). The paper describes the Boussinesq +form while the code supports that and also a non-Boussinesq form. + +In two dimensions (\f$x\f$ and \f$p\f$), we can integrate the zonal +component of the momentum equation above over a finite volume: + +\f{eqnarray}{ + - \int dx \int dp \frac{\partial u}{\partial t} &= \int dx \int dp \left. \frac{\partial + \Phi}{\partial x}\right|_p \\ + &= \int_{p_{br}}^{p_{tr}} \Phi dp + \int_{p_{tr}}^{p_{tl}} \Phi dp + + \int_{p_{tl}}^{p_{bl}} \Phi dp + &+ \int_{p_{bl}}^{p_{br}} \Phi dp \label{eq:PG_loop} +\f} + +We convert to line integrals thanks to the Leibniz rule. +See the figure for the location of the line integral ranges: + +\image html PG_loop.png "Schematic of the finite volume used for integrating the \f$u\f$-component of momentum. The thermodynamic variables \f$\\theta\f$ and \f$s\f$ reside on the sides of the depicted volume and are considered uniform for the vertical extent of the volume but with linear variation in the horizontal. The volume is depicted in \f$(x, p)\f$ space so \f$p\f$ is linear around the volume but \f$\\Phi\f$ can vary arbitrarily along the edges." +\imagelatex{PG_loop.png,Schematic of the finite volume used for integrating the $u$-component of momentum. The thermodynamic variables $\theta$ and $s$ reside on the sides of the depicted volume and are considered uniform for the vertical extent of the volume but with linear variation in the horizontal. The volume is depicted in $(x\, p)$ space so $p$ is linear around the volume but $\Phi$ can vary arbitrarily along the edges.,\includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true]} + +The only approximations made are (i) that the potential temperature \f$\theta\f$ and the +salinity \f$s\f$ can be represented continuously in the vertical within each layer although +discontinuities between layers are allowed and (ii) that \f$\theta\f$ and \f$s\f$ can be +represented continuously along each layer. MOM6 has options for piecewise constant (PCM), +piecewise linear (PLM), and piecewise parabolic (PPM) in the vertical. + +If we use the Wright equation of state (\cite wright1997), we can integrate the above +integrals analytically. This equation of state can be written as: + +\f[ + \alpha(s, \theta, p) = A(s, \theta) + \frac{\lambda(s, \theta)}{P(s, \theta) + p} +\f] + +where \f$A, \lambda\f$ and \f$P\f$ are functions only of \f$s\f$ and \f$\theta\f$. +The integral form of hydrostatic balance is: + +\f[ + \Phi(p_t) - \Phi(p_b) = \int_{p_t}^{p_b} \alpha(s, \theta, p) dp +\f] + +Assuming piecewise constant values for \f$\theta\f$ and \f$s\f$ and the above equation of +state, we get: +\f{eqnarray}{ + \Phi(p_t) - \Phi(p_b) &= \int_{p_t}^{p_b} \alpha(s, \theta, p) dp \\ + &= (p_b - p_t) A + \lambda \ln \left| \frac{P + p_b}{P + p_t} \right| \\ + &= \Delta p \left( A + \frac{\lambda}{P + \overline{p}} \frac{1}{2 \epsilon} \ln \left| + \frac{1 + \epsilon}{1 - \epsilon} \right| \right) \label{eq:PG_vert} +\f} +which is the exact solution for the continuum only if \f$\theta\f$ and \f$s\f$ are uniform +in the interval \f$p_t\f$ to \f$p_b\f$. Here, we have introduced the variables: +\f[ + \Delta p = p_b - p_t +\f] +\f[ + \overline{p} = \frac{1}{2}(p_t + p_b) +\f] +and +\f[ + \epsilon = \frac{\Delta p}{2 (P + \overline{p})} +\f] +We will show later that \f$\epsilon \ll 1\f$. Note the series expansion: + +\f[ + \frac{1}{2 \epsilon} \ln \left| \frac{1 + \epsilon}{1 - \epsilon} \right| = + \sum_{n=1}^\infty \frac{\epsilon^{2n-2}}{2n - 1} = 1 + \frac{\epsilon^2}{3} + + \frac{\epsilon^4}{5} + \cdots \forall |\epsilon | \leq 1 +\f] + +Typical values for the deep ocean with 100 m layer thickness are \f$6 \times 10^8\f$ Pa and +\f$10^6\f$ Pa, respectively, yielding \f$\epsilon \sim 8 \times 10^{-4}\f$ and a +corresponding accuracy in the geopotential height calculation of \f$\frac{\lambda +\epsilon^3}{g} \sim 10^{-5}\f$ m. For this value of \f$\epsilon\f$, the series converges +with just three terms. In MOM6, we use series rather than the intrinsic log function , +since the log is machine dependent and insufficiently accurate. In extreme circumstances, +\f$\Delta p \sim 6 \times 10^7\f$ Pa (limited by the depth of the ocean) for which +\f$\epsilon \sim 0.04\f$ with geopotential height errors of order 1 m. In this case, the +series converges to machine precision with six terms. + +The finite volume acceleration is expression terms of four integrals around the volume, +\f$\int \Phi dp\f$. The side integrals can be calculated by direct integration of +\eqref{eq:PG_vert}, which gives: +\f{eqnarray}{ + \int_{p_t}^{p_b} \Phi dp &= + \Delta p \left( \Phi_b + \frac{1}{2} A \Delta p + \lambda \left( + 1 - \frac{1 - \epsilon}{2 \epsilon} \ln \left| \frac{1 + \epsilon}{1 - \epsilon} + \right| \right) \right) \\ + &= \Delta p \left( \Phi_b + \frac{1}{2} A \Delta p + \lambda \left( + 1 - (1 - \epsilon) \left( 1 + \frac{\epsilon^2}{3} + \frac{\epsilon^4}{5} + \cdots + \right) \right) \right) \\ + &= \Delta p \left( \Phi_b + \frac{1}{2} A \Delta p + \lambda \left( + \epsilon - (1 - \epsilon) \epsilon^2 \left( \frac{1}{3} + \frac{\epsilon^2}{5} + \cdots + \right) \right) \right) +\f} +where \f$\Phi, \Delta p, P, A\f$ and \f$\lambda\f$ are each evaluated on the left or right +side of the volume. + +The top and bottom integrals in \eqref{eq:PG_loop} must allow for the effect of varying +\f$\theta\f$ and \f$s\f$ on \f$A, \lambda\f$ and \f$P\f$. We evaluate these integrals +numerically using sixth-order quadrature; Boole's rule requires evaluating the coefficients +in the equation of state at five points, two of which have already been evaluated for the +side integrals. For efficiency, we linearly interpolate the coefficients \f$A, P\f$ and +\f$\lambda\f$ between the end points, which seems to make very little difference to the +solution. We also verified that tenth-order quadrature makes little difference to the +solution. The values of the top and bottom integrals are carried upward in a +hydrostatic-like integration, obtained as follows: + +\f{eqnarray}{ + \int_{p_{tl}}^{p_{tr}} \Phi_t dp &= (p_{tr} - p_{tl}) \int_0^1 \Phi_t dx \\ + &= (p_{tr} - p_{tl}) \int_0^1 \left( \Phi_b + A(x) \Delta p(x) + \lambda (x) + \ln \left| \frac{1 + \epsilon (x)}{1 - \epsilon (x)} \right| \right) dx \\ + &= (p_{tr} - p_{tl}) \int_0^1 \Phi_b dx \\ + &+ \int_0^1 \Delta p(x) \left( A(x) + \frac{\lambda (x)}{P(x) + \overline{p} (x)} + \sum_{n=1}^\infty \frac{\epsilon^{2n-2}}{2n-1} \right) dx +\f} + +The first integral is either known from the top integral of the layer below or the boundary +condition at the ocean bottom. The second integral is evaluated numerically. + +All the above definite integrals are specific to the Wright equation of state; the use of a +different equation of state requires analytic integration of the appropriate equations. We +have found, however, that high-order numerical integration appears to be sufficient. +Although the numerical implementation is more general (allowing the use of arbitrary +equations of state), it is significantly more expensive and so we advocate the analytic +implementation for efficiency. + +*/ diff --git a/core/_Discrete_grids.dox b/core/_Discrete_grids.dox new file mode 100644 index 0000000000..2387d12857 --- /dev/null +++ b/core/_Discrete_grids.dox @@ -0,0 +1,65 @@ +/*! \page Discrete_Grids Discrete Horizontal and Vertical Grids + +\section horizontal_grids Horizontal grids + +The placement of model variables on the horizontal C-grid is illustrated here: + +\image html Arakawa_C_grid.png "MOM6 uses an Arakawa C grid staggering of variables with a North-East indexing convention." +\image latex Arakawa_C_grid.png "MOM6 uses an Arakawa C grid staggering of variables with a North-East indexing convention." + + +Scalars are located at the \f$h\f$-points, velocities are staggered such that +\f$u\f$-points and \f$v\f$-points are not co-located, and vorticities +are located at \f$q\f$-points. The indexing for points (\f$i,j\f$) in +the logically-rectangular domain is such that \f$i\f$ increases in +the \f$x\f$ direction (eastward for spherical polar coordinates), and +\f$j\f$ increases in the \f$y\f$ direction (northward for spherical polar +coordinates). A \f$q\f$-point with indices (\f$i,j\f$) lies to the upper +right (northeast) of the \f$h\f$-point with the same indices. The index +for the vertical dimension \f$k\f$ increases with depth, although the +vertical coordinate \f$z\f$, measured from the mean surface level \f$z = +0\f$, decreases with depth. + +When the horizontal grid is generated, it is actually computed on the +\"supergrid\" at twice the nominal resolution of the model. The grid file +contains the grid metrics and the areas of this fine grid. The model +then decomposes it into the four staggered grids, along with computing +the grid metrics as shown here: + +\image html Grid_metrics.png "The grid metrics around both \f$h\f$-points and \f$q\f$-points." +\imagelatex{Grid_metrics.png,The grid metrics around both $h$-points and $q$-points.,\includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true]} + +The model carries both the metrics as well as their inverses, for instance, +IdyT = 1/dyT. There are also the areas and the inverse areas for all four grid +locations. areaT and areaBu are the sum of the four areas from the supergrid +surrounding each h-point and each q-point, respectively. The velocity faces can be +partially blocked and their areas are adjusted accordingly, where \f$dy\_Cu\f$ and +\f$dx\_Cv\f$ are the blocked distances at \f$u\f$ and \f$v\f$ points, respectively. + +\f{eqnarray} +\mbox{areaCu}_{i,j} &= dxCu_{i,j} * dy\_Cu_{i,j} \\ +\mbox{areaCv}_{i,j} &= dx\_Cv_{i,j} * dyCv_{i,j} \\ +\mbox{IareaCu}_{i,j} &= 1 / \mbox{areaCu}_{i,j} \\ +\mbox{IareaCv}_{i,j} &= 1 / \mbox{areaCv}_{i,j} +\f} + +The horizontal grids can be spherical, tripole, regional, or cubed sphere. +The default is for grids to be re-entrant in the \f$x\f$-direction; this needs +to be turned off for regional grids. + +\section vertical_grids Vertical grids + +The placement of model variables in the vertical is illustrated here: + +\image html cell_3d.png "The MOM6 interfaces are at vertical location \f$e\f$ which are separated by the layer thicknesses \f$h\f$." +\imagelatex{cell_3d.png,The MOM6 interfaces are at vertical location $e$ which are separated by the layer thicknesses $h$.,\includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true]} + +The vertical coordinate is Lagrangian in that the interfaces between the layers are +free to move up and down with time. The interfaces have target depths or target +densities, depending on the desired vertical coordinate system. They can even have +target sigma values for terrain-following coordinates or you can design a hybrid +coordinate in which different interfaces have differing behavior. In any case, the +interfaces move with the fluid during the dynamic timesteps and then get reset during a +remapping operation. See section \ref ALE_Timestep for details. + +*/ diff --git a/core/_Energetic_consistancy.dox b/core/_Energetic_consistancy.dox new file mode 100644 index 0000000000..e5ac0a5e8a --- /dev/null +++ b/core/_Energetic_consistancy.dox @@ -0,0 +1,5 @@ +/*! \page Energetic_Consistency Energetic Consistency + +\brief Energetic Consistency + +*/ diff --git a/core/_General_coordinate.dox b/core/_General_coordinate.dox new file mode 100644 index 0000000000..6effc4717b --- /dev/null +++ b/core/_General_coordinate.dox @@ -0,0 +1,158 @@ +/*! \page General_Coordinate Generalized vertical coordinate equations + +The ocean equations discretized by MOM6 are formulated using +generalized vertical coordinates. Motivation for using generalized +vertical coordinates, and a full accounting of the ocean equations +written using these coordinates, can be found in Griffies, Adcroft and +Hallberg (2020) \cite Griffies_Adcroft_Hallberg2020. Here we provide +a brief summary. + +Consider a smooth function of space and time, \f$r(x,y,z,t)\f$, that +has a single-signed and non-zero vertical derivative known as the +specific thickness +\f{align} + \partial z/\partial r = (\partial r/\partial z)^{-1} = \mbox{specific thickness.} +\f} +The specific thickness measures the inverse vertical stratification of +the vertical coordinate surfaces. As so constrained, \f$r\f$ can +uniquely prescribe a positiion in the vertical. Consequently, the +ocean equations can be mapped one-to-one from geopotential vertical +coordinates to generalized vertical coordinate. Upon transforming to +\f$r\f$-coordinates, the material time derivative of \f$r\f$ appears +throughout the equations, playing the role of a pseudo-vertical +velocity, and we make use of the following shorthand for this +derivative +\f{align} +\dot{r} = D_{t} r. +\f} + +The Boussinesq hydrostatic ocean equations take the following form using +generalized vertical coordinates (\f$r\f$-coordinates) +\f{align} +\label{html:r-equations}\notag \\ +\rho_o \left[ + \partial_{t} \mathbf{u} + (f + \zeta) \, \hat{\mathbf{z}} \times \mathbf{u} + + \dot{r} \, \partial_{r} \mathbf{u} \right] + &= -\nabla_r \, (p + \rho_{o} \, K) -\rho \nabla_r \Phi + \rho_{o} \, \mathbf{\mathcal{F}} + &\mbox{horizontal momentum} +\label{eq:r-horz-momentum} +\\ +\rho \, \partial_{r} \Phi + \partial_{r}p + &= 0 +&\mbox{hydrostatic} +\label{eq:r-hydrostatic-equation} +\\ + \partial_{t}( z_r) ++ \nabla_r \cdot ( z_r \, \mathbf{u} ) ++ \partial_{r} ( z_r \, \dot{r} ) +&= 0 +&\mbox{specific thickness} +\label{eq:r-non-divergence} +\\ + \partial_{t} ( \theta \, z_r ) ++ \nabla_r \cdot ( \theta z_r \, \mathbf{u} ) ++ \partial_{r} ( \theta \, z_r \, \dot{r} ) +&= z_r \mathbf{\mathcal{N}}_\theta^\gamma +- \partial_{r} J_\theta^{(z)} +&\mbox{potential/Conservative temp} +\label{eq:r-temperature-equation} +\\ +\partial_{t} ( S \, z_r) ++ \nabla_r \cdot ( S \, z_r \, \mathbf{u} ) ++ \partial_{r} ( S \, z_r \, \dot{r} ) +&= z_r \mathbf{\mathcal{N}}_S^\gamma +- \partial_{r} J_S^{(z)} +&\mbox{salinity} +\label{eq:r-salinity-equation} +\\ +\rho &= \rho( S, \theta, -g \rho_0 z ) +&\mbox{equation of state.} +\f} +The time derivatives appearing in these equations are computed with +the generalized vertical coordinate fixed rather than the +geopotential. It is a common misconception that the horizontal +velocity, \f$\mathbf{u}\f$, is rotated to align with constant \f$r\f$ +surfaces. Such is not the case. Rather, the horizontal velocity, +\f$\mathbf{u}\f$, is precisely the same horizontal velocity used with +geopotential coordinates. However, its evolution has here been +formulated using generalized vertical coordinates. + +As a finite volume model, MOM6 is discretized in the vertical by +integrating between surfaces of constant \f$r\f$. The layer thickness +is a basic term appearing in these equations, which results from +integrating the specific thickness over a layer +\f{align} +h = \int z_r \, \mathrm{d}r. +\f} +Correspondingly, the model variables are treated as finite volume +averages over each layer, with full accounting of this finite volume +approach presented in Griffies, Adcroft and Hallberg (2020) +\cite Griffies_Adcroft_Hallberg2020, and with the semi-discrete model +ocean model equations written as follows. +\f{align} +\rho_0 +\left[ \frac{\partial \mathbf{u}}{\partial t} + \frac{( f + \zeta )}{h} \, +\hat{\mathbf{z}} \times h \, \mathbf{u} + \underbrace{ \dot{r} \, +\frac{\partial \mathbf{u}}{\partial r} } +\right] +&= -\nabla_r \, (p + \rho_{0} \, K) - +\rho \nabla_r \, \Phi + \mathbf{\mathcal{F}} +&\mbox{horizontal momentum} +\label{eq:h-horz-momentum} +\\ +\rho \, \delta_r \Phi + \delta_r p +&= 0 +&\mbox{hydrostatic} +\label{eq:h-hydrostatic-equation} +\\ +\frac{\partial h}{\partial t} + \nabla_r \cdot \left( h \, \mathbf{u} \right) + +\underbrace{ \delta_r ( z_r \dot{r} ) } + &= 0 +&\mbox{thickness} +\label{eq:h-thickness-equation} +\\ +\frac{\partial ( \theta \, h )}{\partial t} + \nabla_r \cdot \left( \theta h \, +\mathbf{u} \right) + \underbrace{ \delta_r ( \theta \, z_r \dot{r} ) } +&= +h \mathbf{\mathcal{N}}_\theta^\gamma - \delta_r J_\theta^{(z)} +&\mbox{potential/Conservative temp} +\label{eq:h-temperature-equation} +\\ +\frac{\partial ( S \, h )}{\partial t} + \nabla_r \cdot \left( S \, h \, +\mathbf{u} \right) + \underbrace{ \delta_r ( S \, z_r \dot{r} ) } +&= +h \mathbf{\mathcal{N}}_S^\gamma - \delta_r J_S^{(z)} +&\mbox{salinity} +\label{eq:h-salinity-equation} +\\ +\rho &= \rho\left( S, \theta, -g \rho_0 z(r) \right) +&\mbox{equation of state,} \label{eq:h-equation-of-state} +\f} +where +\f{align} +\delta_{r} = \mathrm{d}r \, (\partial/\partial r) +\f} +is the discrete vertical difference operator. The pressure gradient +accelerations in the momentum equation are written in +continuous-in-the-vertical form for brevity; the exact discretization +is detailed in \cite adcroft2008 and +\cite Griffies_Adcroft_Hallberg2020. The \f$1/h\f$ and \f$h\f$ appearing in +the horizontal momentum equation are carefully handled in the code to +ensure proper cancellation even when the layer thickness goes to zero +i.e., l'Hospital's rule is respected. + +The MOM6 time-stepping algorithm integrates the above layer-averaged +equations forward in time allowing the vertical grid to follow the +motion, i.e. \f$\dot{r}=0\f$, so that the underbraced terms are +dropped. This approach is generally known as a Lagrangian method, with +the Lagrangian approach in MOM6 limited to the vertical +direction. After each Lagrangian step, a regrid step is applied that +generates a new vertical grid of the user's choosing. The ocean state +is then remapped from the old to the new grid. The physical state is +not meant to change during the remap step, yet truncation errors make +remapping imperfect. We employ high-order accurate reconstructions to +minimize errors introduced during the remap step (\cite white2008, +\cite white2009). The connection between time-stepping and remapping +is described in section \ref ALE_Timestep. + +*/ diff --git a/core/_Governing.dox b/core/_Governing.dox new file mode 100644 index 0000000000..466e9d957e --- /dev/null +++ b/core/_Governing.dox @@ -0,0 +1,176 @@ +/*! \page Governing_Equations Governing Equations + +MOM6 is a hydrostatic ocean circulation model that time steps either +the non-Boussinesq ocean equations (where the flow velocity is +divergent: \f$\nabla \cdot \mathbf{v} \ne 0\f$), or the Boussinesq +ocean equations (where velocity is non-divergent: \f$\nabla \cdot +\mathbf{v} = 0\f$). We here display the Boussinesq version since +it is most commonly used (as of 2022). We start by casting the +equations in geopotentiial coordinates prior to transforming to the +generalized vertical coordinates used by MOM6. A more thorough +discussion of these equations, and their finite volume realization +appropriate for MOM6, can be found in Griffies, Adcroft and Hallberg (2020) +\cite Griffies_Adcroft_Hallberg2020. + +The hydrostatic Boussinesq ocean equations, written using geopotential +vertical coordinates, are given by +\f{align} + \rho_o \left[ + D_t \mathbf{u} + f \hat{\mathbf{z}} \times \mathbf{u} + \right] + &= -\rho \, \nabla_z \Phi - \nabla_z p + + \rho_o \, \mathbf{\mathcal{F}} + &\mbox{horizontal momentum} +\\ + \rho \, \partial_{z} \Phi + \partial_{z} p &= 0 &\mbox{hydrostatic} +\\ + \nabla_z \cdotp \mathbf{u} + \partial_{z} w + &= 0 + &\mbox{continuity} +\\ + D_t \theta &= \mathbf{\mathcal{N}}_\theta^\gamma + - \partial_{z} J_\theta^{(z)} + &\mbox{potential or Conservative temp} + \\ + D_t S &= \mathbf{\mathcal{N}}_S^\gamma +- \partial_{z} J_S^{(z)} + &\mbox{salinity} +\\ + \rho &= \rho(S, \theta, z) &\mbox{ equation of state} +\\ + \mathbf{v} &= \mathbf{u} + \hat{\mathbf{z}} \, w &\mbox{velocity field.} +\f} + +The acceleration term, \f$\mathbf{\mathcal{F}}\f$, in the +horizontal momentum equation includes the acceleration due to the +divergence of internal frictional stresses as well as from bottom and +surface boundary stresses. Other notation is described in \ref +Notation. + +The prognostic temperature, \f$\theta\f$, is either potential +temperature or Conservative Temperature, depending on the chosen +equation of state, and \f$S\f$ is the salinity. We generally follow +the discussion of \cite McDougall_etal_2021 for how to interpret the +prognostic temperature and salinity in ocean models. MOM6 has +historically used the Wright (1997) \cite wright1997 equation of state +to compute the in situ density, \f$\rho\f$. However, there +are other options as documented in \ref Equation_of_State. In the +potential temperature and salinity equations, fluxes due to diabatic +processes are indicated by \f$J^{(z)}\f$. Tendencies due to the +convergence of fluxes oriented along neutral directions are indicated +by \f$\mathbf{\mathcal{N}}^\gamma\f$, with our implementation of +neutral diffusion detailed in Shao et al (2020) +\cite Shao_etal_2020. + +The total or material time derivative operator is given by +\f{align} + D_t &\equiv \partial_{t} + \mathbf{v} \cdotp \nabla + \\ + &= \partial_{t} + \mathbf{u} \cdotp \nabla_z + w \, \partial_{z}, +\f} +where the second equality explosed the horizontal and vertical terms. Using the non-divergence condition +on the three-dimensional velocity allows us to write the material time derivative of an arbitrary scalar field, +\f$\psi\f$, into a flux-form equation +\f{align} D_t \psi &= ( \partial_{t} + \mathbf{u} \cdotp \nabla) \, \psi + \\ + &= \partial_{t} \psi + \nabla \cdotp (\mathbf{v} \, \psi) +\\ + &= \partial_{t} \psi + \nabla_z \cdotp ( \mathbf{u} \, \psi) + \partial_{z} ( w \, \psi). +\f} +Discretizing the flux-form scalar equations means that fluxes +transferring scalars between grid cells act in a conservative manner. +Consequently, the domain integrated scalar (e.g., total seawater volume, total +salt content, total potential enthalpy) is affected only via surface and bottom +boundary transport. Such global conservation properties are +maintained by MOM6 to within computational roundoff, with this level +of precision found to be essential for using MOM6 to study +climate. Making use of the flux-form scalar conservation equations +brings the model equations to the form +\f{align} + \rho_o \left[ + D_t \mathbf{u} + f \hat{\mathbf{z}} \times \mathbf{u} + \right] + &= -\rho \, \nabla_z \Phi - \nabla_z p + + \rho_o \, \mathbf{\mathcal{F}} + &\mbox{horizontal momentum} +\\ + \rho \, \partial_{z} \Phi + \partial_{z} p &= 0 &\mbox{hydrostatic} +\\ + \nabla_z \cdotp \mathbf{u} + \partial_{z} w + &= 0 + &\mbox{continuity} +\\ +\partial_{t} \theta + \nabla_z \cdotp (\mathbf{u} \, \theta) + \partial_{z} (w \, \theta) +&= \mathbf{\mathcal{N}}_\theta^\gamma - \partial_{z} J_\theta^{(z)} +&\mbox{potential or Conservative temp} +\\ +\partial_{t} S + \nabla_z \cdotp (\mathbf{u} \, S) + \partial_{z}(w \, S) +&= \mathbf{\mathcal{N}}_S^\gamma -\partial_{z} J_S^{(z)} + &\mbox{salinity} +\\ +\rho &= \rho(S, \theta, z) &\mbox{equation of state.} +\f} + +\section vector_invariant_eqns Vector invariant velocity equation + +MOM6 time steps the horizontal velocity equation in its +vector-invariant form. To derive this equation we make use of the +following vector identity +\f{align} + D_t \mathbf{u} + &= + \partial_t \mathbf{u} + \mathbf{v} \cdotp \nabla \mathbf{u} + \\ + &= + \partial_t \mathbf{u} + \mathbf{u} \cdotp \nabla_z \mathbf{u} + w \partial_z \mathbf{u} + \\ + &= + \partial_t \mathbf{u} + \left( \nabla \times \mathbf{u} \right) \times \mathbf{v} + + \nabla \left|\mathbf{u}\right|^2/2 + \\ + &= + \partial_t \mathbf{u} + w \, \partial_{z} \mathbf{u} + + \zeta \, \hat{\mathbf{z}} \times \mathbf{u} + \nabla_{z} K, +\f} +where we introduced the vertical component to the relative vorticity +\f{align} + \zeta = \hat{\mathbf{z}} \cdot (\nabla \times \mathbf{u}) + = \partial_{x}v - \partial_{y} u, +\label{eq:relative-vorticity-z} +\f} +as well as the kinetic energy per mass contained in the horizontal flow +\f{align} + K = (u^{2} + v^{2})/2. +\label{eq:kinetic-energy-per-mass} +\f} +It is just the horizontal kinetic energy per mass that appears when +making the hydrostatic approximation, whereas a non-hydrostatic fluid +(such as the MITgcm) includes the contribution from vertical motion. With +these identities we are led to the MOM6 flux-form equations of motion in +geopotential coordinates +\f{align} + \rho_{o} \left[ + \partial_t \mathbf{u} + w \, \partial_{z} \mathbf{u} + + (f + \zeta) \hat{\mathbf{z}} \times \mathbf{u} + \right] + &= -\nabla_{z} (p + K) - \rho \, \nabla_{z} \Phi + \rho_{o} \, \mathbf{\mathcal{F}} + &\mbox{vector-inv horz velocity} +\\ + \rho \, \partial_{z} \Phi + \partial_{z} p &= 0 &\mbox{hydrostatic} +\\ + \nabla_z \cdotp \mathbf{u} + \partial_{z} w + &= 0 + &\mbox{continuity} + \\ + \partial_t \theta + \nabla_z \cdotp ( \mathbf{u} \, \theta ) + \partial_z ( w \, \theta ) + &= \mathbf{\mathcal{N}}_\theta^\gamma - \partial_{z} J_\theta^{(z)} + &\mbox{potential/Cons temp} + \\ + \partial_t S + \nabla_z \cdotp ( \mathbf{u} \, S ) + \partial_z (w \, S) + &= \mathbf{\mathcal{N}}_S^\gamma - \partial_{z} J_S^{(z)} + &\mbox{salinity} + \\ + \rho &= \rho(S, \theta, z) &\mbox{equation of state.} +\f} + +*/ diff --git a/core/_Notation.dox b/core/_Notation.dox new file mode 100644 index 0000000000..b91baac5fe --- /dev/null +++ b/core/_Notation.dox @@ -0,0 +1,63 @@ +/*! \page Notation Notation for equations + +\section Symbols Symbols for variables + +\f$z\f$ refers to geopotential elevation (or height), increasing +upward and with \f$z=0\f$ defining the resting ocean surface. Much of +the ocean has \f$z < 0\f$. + +\f$x\f$ and \f$y\f$ are the Cartesian horizontal coordinates. MOM6 + uses generalized orthogonal curvilinear horizontal + coordinates. However, the equations are simpler to write using + Cartesian coordinates, and it is very straightforward to generalize + the horizontal coordinates using the methods in Chapters 20 and 21 of + \cite SMGbook. + +\f$\lambda\f$ and \f$\phi\f$ are the geographic coordinates on a +sphere (longitude and latitude, respectively). + +Horizontal components of velocity are indicated by \f$u\f$ and \f$v\f$ +and vertical component by \f$w\f$. + +\f$p\f$ is the hydrostatic pressure. + +\f$\Phi\f$ is the geopotential. In the absence of tides, the +geopotential is given by \f$\Phi = g z,\f$ whereas more general +expressions hold when including astronomical tide forcing. + +The thermodynamic state variables can be salinity, \f$S\f$, and +potential temperature, \f$\theta\f$. Alternatively, one can choose +the Conservative Temperature if using the TEOS10 equation of state +from \cite TEOS2010. + +\f$\rho\f$ is the in-situ density computed as a function +\f$\rho(S,\theta,p)\f$ for non-Boussinesq ocean or +\f$\rho(S,\theta,p=-g \, \rho_o \, z)\f$ for Boussinesq ocean. See +Young (2010) \cite Young2010 or Section 2.4 of Vallis (2017) +\cite GVbook for reasoning behind the simplified pressure +used in the Boussinesq equation of state. + + + +\section vector_notation Vector notation + +The three-dimensional velocity vector is denoted \f$\mathbf{v}\f$ +and it is decomposed into its horizontal and vertical components according to +\f{align} +\mathbf{v} + = \mathbf{u} + \hat{\mathbf{z}} \, w + = \hat{\mathbf{x}} \, u + \hat{\mathbf{y}} \, v + \hat{\mathbf{z}} \, w, + \f} +where \f$\hat{\mathbf{z}}\f$ is the unit vector pointed in the +upward vertical direction and \f$\mathbf{u} = (u, v, 0)\f$ is the +horizontal component of velocity normal to the vertical. + +The three-dimensional gradient operator is denoted \f$\nabla\f$, and it is decomposed into +its horizontal and vertical components according to +\f{align} +\nabla + = \nabla_z + \hat{\mathbf{z}} \, \partial_z + = \hat{\mathbf{x}} \, \partial_x + \hat{\mathbf{y}} \, \partial_y + \hat{\mathbf{z}} \, \partial_z. + \f} + +*/ diff --git a/core/_PPM.dox b/core/_PPM.dox new file mode 100644 index 0000000000..605f7f95ac --- /dev/null +++ b/core/_PPM.dox @@ -0,0 +1,65 @@ +/*! \page PPM PPM Advection Scheme + +\section section_PPM Advection Scheme + +Following \cite colella1984 and \cite carpenter1990, we use the Piecewise Parabolic +Method (PPM) to represent values within the model cells. Each cell is assumed to +have a piecewise parabolic representation, which is uniquely prescribed by +conservation and the two edge values. This method has the following features: + +\li The PPM approach is conservative. +\li The (unlimited) order of accuracy is determined by the estimates of the edge +values. +\li Monotonicity is ensured by adjusting the edge values to flatten the profile. + +An example is shown in this figure: + +\image html ppm_arc.png The parabolic representation of a field within a cell. +\image latex ppm_arc.png The parabolic representation of a field within a cell. + +\f[ + x'_i \equiv \frac{x - x_{i-1/2}} {\Delta x_i} +\f] + +\f[ + \Delta x_i \equiv x_{i + 1/2} - x_{i- 1/2} +\f] + +\f[ + c \equiv u \Delta t / \Delta x_i +\f] + +\f[ + A_i(x') = a_L + (a_R - a_L) x'_i + a_6 x'_i(1 - x'_i) +\f] + +\f[ + a_6 = 6a_i - 3 (a_R + a_L) +\f] + +\f{eqnarray} + a_i &= \int_0^1 A_i(x'_i) dx'_i = \int_0^1 a_L + (a_R - a_L) x'_i + a_6 x'_i (1 + - x'_i) dx'_i \\ + &= \left[ a_L x'_i + \frac{1}{2} (a_R - a_L) x_i^{\prime 2} + a_6 \left( \frac{1}{2} + x_i^{\prime 2} - \frac{1}{3} x_i^{\prime 3} \right) \right]_0^1 \\ + &= \frac{1}{2} (a_R + a_L) + \frac{1}{6} a_6 +\f} + +\f{eqnarray} + F_{i+1/2} &= \frac{1}{\Delta t} \int_{x_{i + 1/2} - u \Delta t}^{x_{i + 1/2}} + A_i^n(x) dx = + \frac{\Delta x}{\Delta t} \int_{1-c}^1 A_i (x'_i) dx'_i \\ + &= \frac{\Delta x}{\Delta t} \left[ a_L x'_i + \frac{1}{2} (a_R - a_L) + x_i^{\prime 2} + a_6 \left( \frac{1}{2} x_i^{\prime 2} - + \frac{1}{3} x_i^{\prime 3} \right) \right]_{1 - c}^1 \\ + &= \frac{\Delta x}{\Delta t} \left[ a_L c + (a_R - a_L + a_6) \left( c - + \frac{1}{2} c^2 \right) - a_6 \left( c - c^2 + \frac{1}{3} c^3 \right) \right] \\ + &= u \left[ a_R + \frac{1}{2} (a_L - a_R) c + a_6 \left( \frac{1}{2} c - + \frac{1}{3} c^2 \right) \right] +\f} + +The choice of \f$a_L\f$ and \f$a_R\f$ is not unique, but can be done according to +\cite colella1984 (CW84) or \cite huynh1997 (H3) as mentioned in \ref +Tracer_Advection. + +*/ diff --git a/core/_Sea_ice.dox b/core/_Sea_ice.dox new file mode 100644 index 0000000000..232bac1bb8 --- /dev/null +++ b/core/_Sea_ice.dox @@ -0,0 +1,11 @@ +/*! \page Sea_Ice Sea Ice Considerations + +\section section_seaice Sea Ice Considerations + +For realistic domains, it is assumed that MOM6 will be run in a coupled mode, such that either the +sea-ice model or the coupler will be computing atmospheric bulk fluxes and passing them to the ocean. +Likewise, MOM6 can compute the frazil ice formation as described in \ref section_frazil, which it +then passes to the sea-ice model, expecting to get back the rejected brine or melted fresh water in +return. + +*/ diff --git a/core/_Solar_radiation.dox b/core/_Solar_radiation.dox new file mode 100644 index 0000000000..1103c93c3b --- /dev/null +++ b/core/_Solar_radiation.dox @@ -0,0 +1,7 @@ +/*! \page Solar_Radiation Solar Radiation + +\section Jerlov_WT Jerlov water type + +\section Chl_Absorb Absorption by Chlorophyll + +*/ diff --git a/core/_Specifics.dox b/core/_Specifics.dox new file mode 100644 index 0000000000..89e6bf9dbb --- /dev/null +++ b/core/_Specifics.dox @@ -0,0 +1,87 @@ +/*! \page Specifics Specifics + +\section section_Specifics Specifics of the Ocean Model Equations + +We here provide more details of the terms appearing in the ocean model equations described in \ref General_Coordinate. + +\section Horiz_mom_eq Horizontal Momentum Equation + +Equation \eqref{eq:h-horz-momentum,h-equations,momentum} is the horizontal momentum +equation written in its vector-invariant advective form\footnote{The +vector-invariant advective form is commonly used in models such as MOM6 +using an Arakawa C-grid (e.g., see section 10 of \cite griffies2000-2).} +with \f$\mathbf{u} = \hat{\mathbf{x}} \, u + \hat{\mathbf{y}} \, v\f$ +the horizontal velocity, \f$p\f$ the hydrostatic pressure, \f$f\f$ +the Coriolis parameter, and +\f[ +\zeta^{(r)} = \hat{\bf z} \cdot (\nabla_{r}\times \mathbf{u}) +\f] +the vertical component of the vorticity using \f$\nabla_{r}\f$ for the curl operator. The discretization of the Coriolis term is the enstrophy conserving scheme of \cite sadourny1975. The geopotential coordinate, \f$z\f$, has a value \f$z=0\f$ at a resting ocean surface, \f$z=\eta(x,y,t)\f$ at the ocean free surface, and \f$z=-H(x,y)\f$ at the ocean bottom. We use the Boussinesq approximation (volume conserving kinematics) with \f$\rho_{0} = 1035~\mbox{kg}~\mbox{m}^{-3}\f$ the reference density.\footnote{MOM6 has an option for compressible non-Boussinesq flow (mass conserving kinematics). We chose the Boussinesq option largely based on legacy.} Time and horizontal derivatives are computed holding the generalized vertical coordinate fixed rather than the geopotential +\f[ +\frac{\partial}{\partial t} = \left[ \frac{\partial}{\partial t} \right]_{r} \qquad \nabla_{r} = \hat{\mathbf{x}} \left[ \frac{\partial}{\partial x} \right]_{r} + \hat{\mathbf{y}} \left[ \frac{\partial}{\partial y} \right]_{r}. +\f] + +The transport of seawater crossing surfaces of constant \f$r\f$ is measured by the dia-surface velocity component (see section 6.7 of \cite SMGbook) +\f[ +\frac{\partial z}{\partial r} \, \frac{\mathrm{D}r}{\mathrm{D}t} = z_{r} \, \dot{r}, +\f] +with \f$z_{r}\f$ the specific thickness that is assumed one-signed throughout the ocean, and \f$\mathrm{D}/\mathrm{D}t\f$ the material time derivative operator. In the ocean interior where \f$r\f$ is aligned with isopycnals, the dia-surface velocity becomes the diapycnal velocity whose value is directly related to irreversible processes such as mixing that act on potential temperature and salinity. In the unstratified mixed layers, \f$r =z^{*}\f$ so that \f$z_{r} \dot{r} = (\partial z/\partial z^{*}) \, \mathrm{D}z^{*}/\mathrm{D}t\f$, which is close to the familiar vertical velocity component \f$\mathrm{D}z/\mathrm{D}t\f$. + +Viscous dissipation (Laplacian and biharmonic friction following \cite griffies2000) and mechanical boundary forces (winds, bottom stress) contribute to the divergence of the deviatoric (symmetric and trace-free) stress tensor, \f$\boldsymbol{\mathcal{F}} = \nabla \cdot \mathbf{\tau}\f$. MOM6 and the real ocean have no vertical sidewalls, and MOM6 treats all solid-earth boundaries with bottom stress parameterized as a quadratic drag. + +\section hydrostatic_balance Hydrostatic balance + +Equation \eqref{eq:h-hydrostatic-equation,h-equations,hydrostatic} is the discrete version of the hydrostatic balance. The horizontal pressure gradient force is implemented as a contact force following the method of \cite adcroft2008. These equations differ from \cite bleck2002 who uses the Montgomery potential to calculate pressure gradient accelerations. + +\section Thickness_and_tracer Thickness and tracer equations + +Volume conservation appears in the form of a prognostic flux-form layer thickness equation \eqref{eq:h-thickness-equation,h-equations,thickness}, with the non-negative layer thickness given by +\f[ +h = \frac{\partial z}{\partial r} \, \mathrm{d}r, +\f] +where \f$\mathrm{d}r\f$ is the thickness of a layer in \f$r\f$-space (e.g., the +density difference between target density classes or the thickness between +target depths). The layer thickness increases where horizontal thickness +fluxes converge, \f$\nabla_r \cdot \left( h_k \, \mathbf{u} \right) < 0\f$, +and where dia-surface flow converges, \f$\delta_r (z_{r} \, \dot{r} ) < +0\f$. The volume flux \f$h_k \mathbf{u}\f$ is computed using the quasi-third +order PPM scheme (\cite colella1984) using a positive-definite limiter +rather than the monotonic limiter. This last choice avoids limiting of +positive extrema and thus retains third-order accuracy everywhere except +near vanishing layers. + +Transport in the thickness equation is discretized +compatibly with that in the flux-form potential temperature +and salinity equations \eqref{eq:h-temperature-equation,h-equations,potential temperature} and +\eqref{eq:h-salinity-equation,h-equations,salinity}. Compatibility is required to maintain +global and layer integrated conservation properties for volume, heat, and +salt. Tracer reconstruction for transport uses PPM with monotonic limiters +but using third order interpolation for edge values. This reduces the size +of the stencil which helps the computational efficiency of the transport +scheme. The flux convergences, \f$\boldsymbol{\mathcal{N}}_\theta^\gamma\f$ +and \f$\boldsymbol{\mathcal{N}}_S^\gamma\f$, provide subgrid scale +neutral diffusion for the potential temperature and salinity, whereas +\f$\delta_{r}J_{\theta}^{(z)}\f$ and \f$\delta_{r}J_{S}^{(z)}\f$ provide subgrid +scale vertical diffusion as well as boundary fluxes. In the interior, +both subgrid fluxes vanish when their respective tracers are spatially +uniform, thus ensuring that the tracer equation reduces to the thickness +equation when the tracer is uniform. + +Parameterized subgrid scale advection from the submesoscale (\cite fox-kemper2011) and mesoscale (\cite gent1995) parameterizations are combined with the lateral advection of thickness and tracer, thus providing a residual mean advective transport for the scalar fields. Furthermore, we implement subgrid advective terms solely as lateral transports, thus interpreting them as layer bolus transport as appropriate for vertical Lagrangian models rather than a three-dimensional eddy-induced advection as appropriate for vertical Eulerian models (see \cite mcdougall2001 for details). + +\section EOS Equation of state + +The equation of state, \eqref{eq:h-equation-of-state,h-equations,equation of state}, determines in situ density as a function of potential temperature, salinity, and pressure. We evaluate the pressure in the equation of state according to \f$- g \, \rho_{0} \, z\f$. Doing so maintains energetic consistency for the Boussinesq fluid according to section 2.4.3 of \cite GVbook. We make use of the \cite wright1997 equation of state so that \f$\theta\f$ is potential temperature and \f$S\f$ is the practical salinity. Although MOM6 has the more updated equation of state from \cite TEOS2010, the required changes for thermodynamic variables were implemented only after the basic model configuration was developed. Time constraints on model development prompted us to retain usage of \cite wright1997 for OM4. + +The freezing point of seawater is approximated as +\f[ +T_f = -0.054 S - 7.75\times10^{-08} p, +\f] +where \f$p\f$ is in units of Pascals and \f$S\f$ is in units of +\f$1\times10^{-3}\f$. When the local temperature anywhere in the ocean +column falls below the freezing point, the water-equivalent volume of +ice is calculated and the fusion heat locally added back to the ocean +to raise the liquid seawater temperature back to the freezing point. The +frozen water and salt are sent to the sea-ice model. + +*/ diff --git a/core/_Timestep_Overview.dox b/core/_Timestep_Overview.dox new file mode 100644 index 0000000000..a75566303d --- /dev/null +++ b/core/_Timestep_Overview.dox @@ -0,0 +1,10 @@ +/*! \page Timestep_Overview Timestepping Overview + +In MOM6, it is common to have at least four different timesteps: the barotropic +timestep, the baroclinic (momentum dynamics) timestep, the tracer timestep, and the +remapping interval. There can also be a forcing timestep on which model coupling occurs. + +\image html timesteps_4.png "Graphic representation of the various timesteps used by MOM6." +\image latex timesteps_4.png "Graphic representation of the various timesteps used by MOM6." + +*/ diff --git a/diagnostics/MOM_PointAccel.F90 b/diagnostics/MOM_PointAccel.F90 new file mode 100644 index 0000000000..e9c1092ed7 --- /dev/null +++ b/diagnostics/MOM_PointAccel.F90 @@ -0,0 +1,805 @@ +!> Debug accelerations at a given point +!! +!! The two subroutines in this file write out all of the terms +!! in the u- or v-momentum balance at a given point. Usually +!! these subroutines are called after the velocities exceed some +!! threshold, in order to determine which term is culpable. +!! often this is done for debugging purposes. +module MOM_PointAccel + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : diag_ctrl +use MOM_domains, only : pe_here +use MOM_error_handler, only : MOM_error, NOTE +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : open_ASCII_file, APPEND_FILE, MULTIPLE, SINGLE_FILE +use MOM_time_manager, only : time_type, get_time, get_date, set_date, operator(-) +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : ocean_internal_state, accel_diag_ptrs, cont_diag_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public write_u_accel, write_v_accel, PointAccel_init + +!> The control structure for the MOM_PointAccel module +type, public :: PointAccel_CS ; private + character(len=200) :: u_trunc_file !< The complete path to the file in which a column's worth of + !! u-accelerations are written if u-velocity truncations occur. + character(len=200) :: v_trunc_file !< The complete path to the file in which a column's worth of + !! v-accelerations are written if v-velocity truncations occur. + integer :: u_file !< The unit number for an opened u-truncation files, or -1 if it has not yet been opened. + integer :: v_file !< The unit number for an opened v-truncation files, or -1 if it has not yet been opened. + integer :: cols_written !< The number of columns whose output has been + !! written by this PE during the current run. + integer :: max_writes !< The maximum number of times any PE can write out + !! a column's worth of accelerations during a run. + logical :: full_column !< If true, write out the accelerations in all massive layers, + !! otherwise just document the ones with large velocities. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. +! The following are pointers to many of the state variables and accelerations +! that are used to step the physical model forward. They all use the same +! names as the variables they point to in MOM.F90 + real, pointer, dimension(:,:,:) :: & + u_av => NULL(), & !< Time average u-velocity [L T-1 ~> m s-1] + v_av => NULL(), & !< Time average velocity [L T-1 ~> m s-1] + u_prev => NULL(), & !< Previous u-velocity [L T-1 ~> m s-1] + v_prev => NULL(), & !< Previous v-velocity [L T-1 ~> m s-1] + T => NULL(), & !< Temperature [C ~> degC] + S => NULL(), & !< Salinity [S ~> ppt] + u_accel_bt => NULL(), & !< Barotropic u-accelerations [L T-2 ~> m s-2] + v_accel_bt => NULL() !< Barotropic v-accelerations [L T-2 ~> m s-2] +end type PointAccel_CS + +contains + +!> This subroutine writes to an output file all of the accelerations +!! that have been applied to a column of zonal velocities over the +!! previous timestep. This subroutine is called from vertvisc. +subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, str, a, hv) + integer, intent(in) :: I !< The zonal index of the column to be documented. + integer, intent(in) :: j !< The meridional index of the column to be documented. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: um !< The new zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: hin !< The layer thickness [H ~> m or kg m-2]. + type(accel_diag_ptrs), intent(in) :: ADp !< A structure pointing to the various + !! accelerations in the momentum equations. + type(cont_diag_ptrs), intent(in) :: CDp !< A structure with pointers to various terms + !! in the continuity equations. + real, intent(in) :: dt !< The ocean dynamics time step [T ~> s]. + type(PointAccel_CS), pointer :: CS !< The control structure returned by a previous + !! call to PointAccel_init. + real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report [L T-1 ~> m s-1] + real, optional, intent(in) :: str !< The surface wind stress [R L Z T-2 ~> Pa] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc + !! [H T-1 ~> m s-1 or Pa s m-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, + !! from vertvisc [H ~> m or kg m-2]. + + ! Local variables + real :: CFL ! The local velocity-based CFL number [nondim] + real :: Angstrom ! A negligibly small thickness [H ~> m or kg m-2] + real :: du ! A velocity change [L T-1 ~> m s-1] + real :: Inorm(SZK_(GV)) ! The inverse of the normalized velocity change [L T-1 ~> m s-1] + real :: e(SZK_(GV)+1) ! Simple estimates of interface heights based on the sum of thicknesses [m] + real :: h_scale ! A scaling factor for thicknesses [m H-1 ~> 1 or m3 kg-1] + real :: vel_scale ! A scaling factor for velocities [m T s-1 L-1 ~> 1] + real :: uh_scale ! A scaling factor for transport per unit length [m2 T s-1 L-1 H-1 ~> 1 or m3 kg-1] + real :: temp_scale ! A scaling factor for temperatures [degC C-1 ~> 1] + real :: saln_scale ! A scaling factor for salinities [ppt S-1 ~> 1] + integer :: yr, mo, day, hr, minute, sec, yearday + integer :: k, ks, ke + integer :: nz + logical :: do_k(SZK_(GV)+1) + logical :: prev_avail + integer :: file + + Angstrom = GV%Angstrom_H + GV%H_subroundoff + h_scale = GV%H_to_m ; vel_scale = US%L_T_to_m_s ; uh_scale = GV%H_to_m*US%L_T_to_m_s + temp_scale = US%C_to_degC ; saln_scale = US%S_to_ppt + +! if (.not.associated(CS)) return + nz = GV%ke + if (CS%cols_written < CS%max_writes) then + CS%cols_written = CS%cols_written + 1 + + ks = 1 ; ke = nz + do_k(:) = .false. + + ! Open up the file for output if this is the first call. + if (CS%u_file < 0) then + if (len_trim(CS%u_trunc_file) < 1) return + call open_ASCII_file(CS%u_file, trim(CS%u_trunc_file), action=APPEND_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) + if (CS%u_file < 0) then + call MOM_error(NOTE, 'Unable to open file '//trim(CS%u_trunc_file)//'.') + return + endif + endif + file = CS%u_file + + prev_avail = (associated(CS%u_prev) .and. associated(CS%v_prev)) + + ! Determine which layers to write out accelerations for. + do k=1,nz + if (((max(CS%u_av(I,j,k),um(I,j,k)) >= vel_rpt) .or. & + (min(CS%u_av(I,j,k),um(I,j,k)) <= -vel_rpt)) .and. & + ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom)) exit + enddo + ks = k + do k=nz,1,-1 + if (((max(CS%u_av(I,j,k), um(I,j,k)) >= vel_rpt) .or. & + (min(CS%u_av(I,j,k), um(I,j,k)) <= -vel_rpt)) .and. & + ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom)) exit + enddo + ke = k + if (ke < ks) then + ks = 1; ke = nz; write(file,'("U: Unable to set ks & ke.")') + endif + if (CS%full_column) then + ks = 1 ; ke = nz + endif + + call get_date(CS%Time, yr, mo, day, hr, minute, sec) + call get_time((CS%Time - set_date(yr, 1, 1, 0, 0, 0)), sec, yearday) + write (file,'(/,"--------------------------")') + write (file,'(/,"Time ",i5,i4,F6.2," U-velocity violation at ",I4,": ",2(I3), & + & " (",F7.2," E ",F7.2," N) Layers ",I3," to ",I3,". dt = ",1PG10.4)') & + yr, yearday, (REAL(sec)/3600.0), pe_here(), I, j, & + G%geoLonCu(I,j), G%geoLatCu(I,j), ks, ke, US%T_to_s*dt + + if (ks <= GV%nk_rho_varies) ks = 1 + do k=ks,ke + if ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom) do_k(k) = .true. + enddo + + write(file,'(/,"Layers:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(I10," ")', advance='no') (k) ; enddo + write(file,'(/,"u(m): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*um(I,j,k)) ; enddo + if (prev_avail) then + write(file,'(/,"u(mp): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%u_prev(I,j,k)) ; enddo + endif + write(file,'(/,"u(3): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%u_av(I,j,k)) ; enddo + + write(file,'(/,"CFL u: ")', advance='no') + do k=ks,ke ; if (do_k(k)) then + CFL = abs(um(I,j,k)) * dt * G%dy_Cu(I,j) + if (um(I,j,k) < 0.0) then ; CFL = CFL * G%IareaT(i+1,j) + else ; CFL = CFL * G%IareaT(i,j) ; endif + write(file,'(ES10.3," ")', advance='no') CFL + endif ; enddo + write(file,'(/,"CFL0 u:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + abs(um(I,j,k)) * dt * G%IdxCu(I,j) ; enddo + + if (prev_avail) then + write(file,'(/,"du: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (vel_scale*(um(I,j,k)-CS%u_prev(I,j,k))) ; enddo + endif + write(file,'(/,"CAu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%CAu(I,j,k)) ; enddo + write(file,'(/,"PFu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%PFu(I,j,k)) ; enddo + write(file,'(/,"diffu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%diffu(I,j,k)) ; enddo + + if (associated(ADp%gradKEu)) then + write(file,'(/,"KEu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (vel_scale*dt*ADp%gradKEu(I,j,k)) ; enddo + endif + if (associated(ADp%rv_x_v)) then + write(file,'(/,"Coru: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + vel_scale*dt*(ADp%CAu(I,j,k)-ADp%rv_x_v(I,j,k)) ; enddo + endif + if (associated(ADp%du_dt_visc)) then + write(file,'(/,"ubv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + vel_scale*(um(I,j,k) - dt*ADp%du_dt_visc(I,j,k)) ; enddo + write(file,'(/,"duv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (vel_scale*dt*ADp%du_dt_visc(I,j,k)) ; enddo + endif + if (associated(ADp%du_other)) then + write(file,'(/,"du_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (vel_scale*ADp%du_other(I,j,k)) ; enddo + endif + if (present(a)) then + write(file,'(/,"a: ",ES10.3," ")', advance='no') h_scale*a(I,j,ks)*dt + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') (h_scale*a(I,j,K)*dt) ; enddo + endif + if (present(hv)) then + write(file,'(/,"hvel: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hv(I,j,k) ; enddo + endif + if (present(str)) then + write(file,'(/,"Stress: ",ES10.3)', advance='no') vel_scale*US%Z_to_m * (str*dt / GV%Rho0) + endif + + if (associated(CS%u_accel_bt)) then + write(file,'(/,"dubt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (vel_scale*dt*CS%u_accel_bt(I,j,k)) ; enddo + endif + write(file,'(/)') + + write(file,'(/,"h--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i,j-1,k)) ; enddo + write(file,'(/,"h+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i+1,j-1,k)) ; enddo + write(file,'(/,"h-0: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i,j,k)) ; enddo + write(file,'(/,"h+0: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i+1,j,k)) ; enddo + write(file,'(/,"h-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i,j+1,k)) ; enddo + write(file,'(/,"h++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i+1,j+1,k)) ; enddo + + + e(nz+1) = -US%Z_to_m*(G%bathyT(i,j) + G%Z_ref) + do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j,k) ; enddo + write(file,'(/,"e-: ",ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo + + e(nz+1) = -US%Z_to_m*(G%bathyT(i+1,j) + G%Z_ref) + do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i+1,j,k) ; enddo + write(file,'(/,"e+: ",ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo + if (associated(CS%T)) then + write(file,'(/,"T-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') temp_scale*CS%T(i,j,k) ; enddo + write(file,'(/,"T+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') temp_scale*CS%T(i+1,j,k) ; enddo + endif + if (associated(CS%S)) then + write(file,'(/,"S-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') saln_scale*CS%S(i,j,k) ; enddo + write(file,'(/,"S+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') saln_scale*CS%S(i+1,j,k) ; enddo + endif + + if (prev_avail) then + write(file,'(/,"v--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i,J-1,k)) ; enddo + write(file,'(/,"v-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i,J,k)) ; enddo + write(file,'(/,"v+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i+1,J-1,k)) ; enddo + write(file,'(/,"v++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i+1,J,k)) ; enddo + endif + + write(file,'(/,"vh--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (uh_scale*CDp%vh(i,J-1,k)*G%IdxCv(i,J-1)) ; enddo + write(file,'(/," vhC--:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (0.5*CS%v_av(i,j-1,k)*uh_scale*(hin(i,j-1,k) + hin(i,j,k))) ; enddo + if (prev_avail) then + write(file,'(/," vhCp--:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (0.5*CS%v_prev(i,j-1,k)*uh_scale*(hin(i,j-1,k) + hin(i,j,k))) ; enddo + endif + + write(file,'(/,"vh-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (uh_scale*CDp%vh(i,J,k)*G%IdxCv(i,J)) ; enddo + write(file,'(/," vhC-+:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (0.5*CS%v_av(i,J,k)*uh_scale*(hin(i,j,k) + hin(i,j+1,k))) ; enddo + if (prev_avail) then + write(file,'(/," vhCp-+:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (0.5*CS%v_prev(i,J,k)*uh_scale*(hin(i,j,k) + hin(i,j+1,k))) ; enddo + endif + + write(file,'(/,"vh+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (uh_scale*CDp%vh(i+1,J-1,k)*G%IdxCv(i+1,J-1)) ; enddo + write(file,'(/," vhC+-:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (0.5*CS%v_av(i+1,J-1,k)*uh_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))) ; enddo + if (prev_avail) then + write(file,'(/," vhCp+-:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (0.5*CS%v_prev(i+1,J-1,k)*uh_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))) ; enddo + endif + + write(file,'(/,"vh++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (uh_scale*CDp%vh(i+1,J,k)*G%IdxCv(i+1,J)) ; enddo + write(file,'(/," vhC++:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (0.5*CS%v_av(i+1,J,k)*uh_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))) ; enddo + if (prev_avail) then + write(file,'(/," vhCp++:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (0.5*CS%v_av(i+1,J,k)*uh_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))) ; enddo + endif + + write(file,'(/,"D: ",2(ES10.3))') US%Z_to_m*(G%bathyT(i,j) + G%Z_ref), US%Z_to_m*(G%bathyT(i+1,j) + G%Z_ref) + + ! From here on, the normalized accelerations are written. + if (prev_avail) then + do k=ks,ke + du = um(I,j,k) - CS%u_prev(I,j,k) + if (abs(du) < 1.0e-6*US%m_s_to_L_T) du = 1.0e-6*US%m_s_to_L_T + Inorm(k) = 1.0 / du + enddo + + write(file,'(2/,"Norm: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') (vel_scale / Inorm(k)) ; enddo + + write(file,'(/,"du: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + ((um(I,j,k)-CS%u_prev(I,j,k)) * Inorm(k)) ; enddo + + write(file,'(/,"CAu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*ADp%CAu(I,j,k) * Inorm(k)) ; enddo + + write(file,'(/,"PFu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*ADp%PFu(I,j,k) * Inorm(k)) ; enddo + + write(file,'(/,"diffu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*ADp%diffu(I,j,k) * Inorm(k)) ; enddo + + if (associated(ADp%gradKEu)) then + write(file,'(/,"KEu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*ADp%gradKEu(I,j,k) * Inorm(k)) ; enddo + endif + if (associated(ADp%rv_x_v)) then + write(file,'(/,"Coru: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*(ADp%CAu(I,j,k)-ADp%rv_x_v(I,j,k)) * Inorm(k)) ; enddo + endif + if (associated(ADp%du_dt_visc)) then + write(file,'(/,"duv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*ADp%du_dt_visc(I,j,k) * Inorm(k)) ; enddo + endif + if (associated(ADp%du_other)) then + write(file,'(/,"du_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (ADp%du_other(I,j,k) * Inorm(k)) ; enddo + endif + if (associated(CS%u_accel_bt)) then + write(file,'(/,"dubt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*CS%u_accel_bt(I,j,k) * Inorm(k)) ; enddo + endif + endif + + write(file,'(2/)') + + flush(file) + endif + +end subroutine write_u_accel + +!> This subroutine writes to an output file all of the accelerations +!! that have been applied to a column of meridional velocities over +!! the previous timestep. This subroutine is called from vertvisc. +subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, str, a, hv) + integer, intent(in) :: i !< The zonal index of the column to be documented. + integer, intent(in) :: J !< The meridional index of the column to be documented. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vm !< The new meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: hin !< The layer thickness [H ~> m or kg m-2]. + type(accel_diag_ptrs), intent(in) :: ADp !< A structure pointing to the various + !! accelerations in the momentum equations. + type(cont_diag_ptrs), intent(in) :: CDp !< A structure with pointers to various terms in + !! the continuity equations. + real, intent(in) :: dt !< The ocean dynamics time step [T ~> s]. + type(PointAccel_CS), pointer :: CS !< The control structure returned by a previous + !! call to PointAccel_init. + real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report [L T-1 ~> m s-1] + real, optional, intent(in) :: str !< The surface wind stress [R L Z T-2 ~> Pa] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc + !! [H T-1 ~> m s-1 or Pa s m-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, + !! from vertvisc [H ~> m or kg m-2]. + + ! Local variables + real :: CFL ! The local velocity-based CFL number [nondim] + real :: Angstrom ! A negligibly small thickness [H ~> m or kg m-2] + real :: dv ! A velocity change [L T-1 ~> m s-1] + real :: Inorm(SZK_(GV)) ! The inverse of the normalized velocity change [L T-1 ~> m s-1] + real :: e(SZK_(GV)+1) ! Simple estimates of interface heights based on the sum of thicknesses [m] + real :: h_scale ! A scaling factor for thicknesses [m H-1 ~> 1 or m3 kg-1] + real :: vel_scale ! A scaling factor for velocities [m T s-1 L-1 ~> 1] + real :: uh_scale ! A scaling factor for transport per unit length [m2 T s-1 L-1 H-1 ~> 1 or m3 kg-1] + real :: temp_scale ! A scaling factor for temperatures [degC C-1 ~> 1] + real :: saln_scale ! A scaling factor for salinities [ppt S-1 ~> 1] + integer :: yr, mo, day, hr, minute, sec, yearday + integer :: k, ks, ke + integer :: nz + logical :: do_k(SZK_(GV)+1) + logical :: prev_avail + integer :: file + + Angstrom = GV%Angstrom_H + GV%H_subroundoff + h_scale = GV%H_to_m ; vel_scale = US%L_T_to_m_s ; uh_scale = GV%H_to_m*US%L_T_to_m_s + temp_scale = US%C_to_degC ; saln_scale = US%S_to_ppt + +! if (.not.associated(CS)) return + nz = GV%ke + if (CS%cols_written < CS%max_writes) then + CS%cols_written = CS%cols_written + 1 + + ks = 1 ; ke = nz + do_k(:) = .false. + + ! Open up the file for output if this is the first call. + if (CS%v_file < 0) then + if (len_trim(CS%v_trunc_file) < 1) return + call open_ASCII_file(CS%v_file, trim(CS%v_trunc_file), action=APPEND_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) + if (CS%v_file < 0) then + call MOM_error(NOTE, 'Unable to open file '//trim(CS%v_trunc_file)//'.') + return + endif + endif + file = CS%v_file + + prev_avail = (associated(CS%u_prev) .and. associated(CS%v_prev)) + + do k=1,nz + if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= vel_rpt) .or. & + (min(CS%v_av(i,J,k), vm(i,J,k)) <= -vel_rpt)) .and. & + ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom)) exit + enddo + ks = k + do k=nz,1,-1 + if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= vel_rpt) .or. & + (min(CS%v_av(i,J,k), vm(i,J,k)) <= -vel_rpt)) .and. & + ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom)) exit + enddo + ke = k + if (ke < ks) then + ks = 1; ke = nz; write(file,'("V: Unable to set ks & ke.")') + endif + if (CS%full_column) then + ks = 1 ; ke = nz + endif + + call get_date(CS%Time, yr, mo, day, hr, minute, sec) + call get_time((CS%Time - set_date(yr, 1, 1, 0, 0, 0)), sec, yearday) + write (file,'(/,"--------------------------")') + write (file,'(/,"Time ",i5,i4,F6.2," V-velocity violation at ",I4,": ",2(I3), & + & " (",F7.2," E ",F7.2," N) Layers ",I3," to ",I3,". dt = ",1PG10.4)') & + yr, yearday, (REAL(sec)/3600.0), pe_here(), i, J, & + G%geoLonCv(i,J), G%geoLatCv(i,J), ks, ke, US%T_to_s*dt + + if (ks <= GV%nk_rho_varies) ks = 1 + do k=ks,ke + if ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom) do_k(k) = .true. + enddo + + write(file,'(/,"Layers:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(I10," ")', advance='no') (k) ; enddo + write(file,'(/,"v(m): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*vm(i,J,k)) ; enddo + + if (prev_avail) then + write(file,'(/,"v(mp): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i,J,k)) ; enddo + endif + + write(file,'(/,"v(3): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_av(i,J,k)) ; enddo + write(file,'(/,"CFL v: ")', advance='no') + do k=ks,ke ; if (do_k(k)) then + CFL = abs(vm(i,J,k)) * dt * G%dx_Cv(i,J) + if (vm(i,J,k) < 0.0) then ; CFL = CFL * G%IareaT(i,j+1) + else ; CFL = CFL * G%IareaT(i,j) ; endif + write(file,'(ES10.3," ")', advance='no') CFL + endif ; enddo + write(file,'(/,"CFL0 v:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + abs(vm(i,J,k)) * dt * G%IdyCv(i,J) ; enddo + + if (prev_avail) then + write(file,'(/,"dv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (vel_scale*(vm(i,J,k)-CS%v_prev(i,J,k))) ; enddo + endif + + write(file,'(/,"CAv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%CAv(i,J,k)) ; enddo + + write(file,'(/,"PFv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%PFv(i,J,k)) ; enddo + + write(file,'(/,"diffv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%diffv(i,J,k)) ; enddo + + if (associated(ADp%gradKEv)) then + write(file,'(/,"KEv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (vel_scale*dt*ADp%gradKEv(i,J,k)) ; enddo + endif + if (associated(ADp%rv_x_u)) then + write(file,'(/,"Corv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + vel_scale*dt*(ADp%CAv(i,J,k)-ADp%rv_x_u(i,J,k)) ; enddo + endif + if (associated(ADp%dv_dt_visc)) then + write(file,'(/,"vbv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + vel_scale*(vm(i,J,k) - dt*ADp%dv_dt_visc(i,J,k)) ; enddo + + write(file,'(/,"dvv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (vel_scale*dt*ADp%dv_dt_visc(i,J,k)) ; enddo + endif + if (associated(ADp%dv_other)) then + write(file,'(/,"dv_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (vel_scale*ADp%dv_other(i,J,k)) ; enddo + endif + if (present(a)) then + write(file,'(/,"a: ",ES10.3," ")', advance='no') h_scale*a(i,J,ks)*dt + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') (h_scale*a(i,J,K)*dt) ; enddo + endif + if (present(hv)) then + write(file,'(/,"hvel: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hv(i,J,k) ; enddo + endif + if (present(str)) then + write(file,'(/,"Stress: ",ES10.3)', advance='no') vel_scale*US%Z_to_m * (str*dt / GV%Rho0) + endif + + if (associated(CS%v_accel_bt)) then + write(file,'("dvbt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (vel_scale*dt*CS%v_accel_bt(i,J,k)) ; enddo + endif + write(file,'(/)') + + write(file,'("h--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i-1,j,k) ; enddo + write(file,'(/,"h0-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i,j,k) ; enddo + write(file,'(/,"h+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i+1,j,k) ; enddo + write(file,'(/,"h-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i-1,j+1,k) ; enddo + write(file,'(/,"h0+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i,j+1,k) ; enddo + write(file,'(/,"h++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i+1,j+1,k) ; enddo + + e(nz+1) = -US%Z_to_m*(G%bathyT(i,j) + G%Z_ref) + do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j,k) ; enddo + write(file,'(/,"e-: ",ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo + + e(nz+1) = -US%Z_to_m*(G%bathyT(i,j+1) + G%Z_ref) + do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j+1,k) ; enddo + write(file,'(/,"e+: ",ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo + if (associated(CS%T)) then + write(file,'(/,"T-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') temp_scale*CS%T(i,j,k) ; enddo + write(file,'(/,"T+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') temp_scale*CS%T(i,j+1,k) ; enddo + endif + if (associated(CS%S)) then + write(file,'(/,"S-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') saln_scale*CS%S(i,j,k) ; enddo + write(file,'(/,"S+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') saln_scale*CS%S(i,j+1,k) ; enddo + endif + + if (prev_avail) then + write(file,'(/,"u--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I-1,j,k) ; enddo + write(file,'(/,"u-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I-1,j+1,k) ; enddo + write(file,'(/,"u+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I,j,k) ; enddo + write(file,'(/,"u++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I,j+1,k) ; enddo + endif + + write(file,'(/,"uh--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (uh_scale*CDp%uh(I-1,j,k)*G%IdyCu(I-1,j)) ; enddo + write(file,'(/," uhC--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (CS%u_av(I-1,j,k) * uh_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))) ; enddo + if (prev_avail) then + write(file,'(/," uhCp--:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (CS%u_prev(I-1,j,k) * uh_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))) ; enddo + endif + + write(file,'(/,"uh-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (uh_scale*CDp%uh(I-1,j+1,k)*G%IdyCu(I-1,j+1)) ; enddo + write(file,'(/," uhC-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (CS%u_av(I-1,j+1,k) * uh_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))) ; enddo + if (prev_avail) then + write(file,'(/," uhCp-+:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (CS%u_prev(I-1,j+1,k) * uh_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))) ; enddo + endif + + write(file,'(/,"uh+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (uh_scale*CDp%uh(I,j,k)*G%IdyCu(I,j)) ; enddo + write(file,'(/," uhC+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (CS%u_av(I,j,k) * uh_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))) ; enddo + if (prev_avail) then + write(file,'(/," uhCp+-:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (CS%u_prev(I,j,k) * uh_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))) ; enddo + endif + + write(file,'(/,"uh++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (uh_scale*CDp%uh(I,j+1,k)*G%IdyCu(I,j+1)) ; enddo + write(file,'(/," uhC++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (CS%u_av(I,j+1,k) * uh_scale*0.5*(hin(i,j+1,k) + hin(i+1,j+1,k))) ; enddo + if (prev_avail) then + write(file,'(/," uhCp++:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & + (CS%u_prev(I,j+1,k) * uh_scale*0.5*(hin(i,j+1,k) + hin(i+1,j+1,k))) ; enddo + endif + + write(file,'(/,"D: ",2(ES10.3))') US%Z_to_m*(G%bathyT(i,j) + G%Z_ref), US%Z_to_m*(G%bathyT(i,j+1) + G%Z_ref) + + ! From here on, the normalized accelerations are written. + if (prev_avail) then + do k=ks,ke + dv = vm(i,J,k) - CS%v_prev(i,J,k) + if (abs(dv) < 1.0e-6*US%m_s_to_L_T) dv = 1.0e-6*US%m_s_to_L_T + Inorm(k) = 1.0 / dv + enddo + + write(file,'(2/,"Norm: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') (vel_scale / Inorm(k)) ; enddo + write(file,'(/,"dv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + ((vm(i,J,k)-CS%v_prev(i,J,k)) * Inorm(k)) ; enddo + write(file,'(/,"CAv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*ADp%CAv(i,J,k) * Inorm(k)) ; enddo + write(file,'(/,"PFv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*ADp%PFv(i,J,k) * Inorm(k)) ; enddo + write(file,'(/,"diffv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*ADp%diffv(i,J,k) * Inorm(k)) ; enddo + + if (associated(ADp%gradKEu)) then + write(file,'(/,"KEv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*ADp%gradKEv(i,J,k) * Inorm(k)) ; enddo + endif + if (associated(ADp%rv_x_u)) then + write(file,'(/,"Corv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*(ADp%CAv(i,J,k)-ADp%rv_x_u(i,J,k)) * Inorm(k)) ; enddo + endif + if (associated(ADp%dv_dt_visc)) then + write(file,'(/,"dvv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*ADp%dv_dt_visc(i,J,k) * Inorm(k)) ; enddo + endif + if (associated(ADp%dv_other)) then + write(file,'(/,"dv_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (ADp%dv_other(i,J,k) * Inorm(k)) ; enddo + endif + if (associated(CS%v_accel_bt)) then + write(file,'(/,"dvbt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & + (dt*CS%v_accel_bt(i,J,k) * Inorm(k)) ; enddo + endif + endif + + write(file,'(2/)') + + flush(file) + endif + +end subroutine write_v_accel + +!> This subroutine initializes the parameters regulating how truncations are logged. +subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) + type(ocean_internal_state), & + target, intent(in) :: MIS !< For "MOM Internal State" a set of pointers + !! to the fields and accelerations that make + !! up the ocean's physical state. + type(time_type), target, intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(directories), intent(in) :: dirs !< A structure containing several relevant + !! directory paths. + type(PointAccel_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_PointAccel" ! This module's name. + + if (associated(CS)) return + allocate(CS) + + CS%diag => diag ; CS%Time => Time + + CS%T => MIS%T ; CS%S => MIS%S + CS%u_accel_bt => MIS%u_accel_bt ; CS%v_accel_bt => MIS%v_accel_bt + CS%u_prev => MIS%u_prev ; CS%v_prev => MIS%v_prev + CS%u_av => MIS%u_av; if (.not.associated(MIS%u_av)) CS%u_av => MIS%u(:,:,:) + CS%v_av => MIS%v_av; if (.not.associated(MIS%v_av)) CS%v_av => MIS%v(:,:,:) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "", debugging=.true.) + call get_param(param_file, mdl, "U_TRUNC_FILE", CS%u_trunc_file, & + "The absolute path to the file where the accelerations "//& + "leading to zonal velocity truncations are written. \n"//& + "Leave this empty for efficiency if this diagnostic is "//& + "not needed.", default="", debuggingParam=.true.) + call get_param(param_file, mdl, "V_TRUNC_FILE", CS%v_trunc_file, & + "The absolute path to the file where the accelerations "//& + "leading to meridional velocity truncations are written. \n"//& + "Leave this empty for efficiency if this diagnostic is "//& + "not needed.", default="", debuggingParam=.true.) + call get_param(param_file, mdl, "MAX_TRUNC_FILE_SIZE_PER_PE", CS%max_writes, & + "The maximum number of columns of truncations that any PE "//& + "will write out during a run.", default=50, debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_FULL_COLUMN", CS%full_column, & + "If true, write out the accelerations in all massive layers; otherwise "//& + "just document the ones with large velocities.", & + default=.false., debuggingParam=.true.) + + if (len_trim(dirs%output_directory) > 0) then + if (len_trim(CS%u_trunc_file) > 0) & + CS%u_trunc_file = trim(dirs%output_directory)//trim(CS%u_trunc_file) + if (len_trim(CS%v_trunc_file) > 0) & + CS%v_trunc_file = trim(dirs%output_directory)//trim(CS%v_trunc_file) + call log_param(param_file, mdl, "output_dir/U_TRUNC_FILE", CS%u_trunc_file, debuggingParam=.true.) + call log_param(param_file, mdl, "output_dir/V_TRUNC_FILE", CS%v_trunc_file, debuggingParam=.true.) + endif + CS%u_file = -1 ; CS%v_file = -1 ; CS%cols_written = 0 + +end subroutine PointAccel_init + +end module MOM_PointAccel diff --git a/diagnostics/MOM_debugging.F90 b/diagnostics/MOM_debugging.F90 new file mode 100644 index 0000000000..15e555ee37 --- /dev/null +++ b/diagnostics/MOM_debugging.F90 @@ -0,0 +1,983 @@ +!> Provides checksumming functions for debugging +!! +!! This module contains subroutines that perform various error checking and +!! debugging functions for MOM6. This routine is similar to it counterpart in +!! the SIS2 code, except for the use of the ocean_grid_type and by keeping them +!! separate we retain the ability to set up MOM6 and SIS2 debugging separately. +module MOM_debugging + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_checksums, only : hchksum, Bchksum, qchksum, uvchksum, hchksum_pair +use MOM_checksums, only : is_NaN, chksum, MOM_checksums_init +use MOM_coms, only : PE_here, root_PE, num_PEs +use MOM_coms, only : min_across_PEs, max_across_PEs, reproducing_sum +use MOM_domains, only : pass_vector, pass_var, pe_here +use MOM_domains, only : BGRID_NE, AGRID, To_All, Scalar_Pair +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : log_version, param_file_type, get_param +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type + +implicit none ; private + +public :: check_redundant_C, check_redundant_B, check_redundant_T, check_redundant +public :: vec_chksum, vec_chksum_C, vec_chksum_B, vec_chksum_A +public :: MOM_debugging_init, totalStuff, totalTandS +public :: check_column_integral, check_column_integrals + +! These interfaces come from MOM_checksums. +public :: hchksum, Bchksum, qchksum, is_NaN, chksum, uvchksum, hchksum_pair + +!> Check for consistency between the duplicated points of a C-grid vector +interface check_redundant + module procedure check_redundant_vC3d, check_redundant_vC2d +end interface check_redundant +!> Check for consistency between the duplicated points of a C-grid vector +interface check_redundant_C + module procedure check_redundant_vC3d, check_redundant_vC2d +end interface check_redundant_C +!> Check for consistency between the duplicated points of a B-grid vector or scalar +interface check_redundant_B + module procedure check_redundant_vB3d, check_redundant_vB2d + module procedure check_redundant_sB3d, check_redundant_sB2d +end interface check_redundant_B +!> Check for consistency between the duplicated points of an A-grid vector or scalar +interface check_redundant_T + module procedure check_redundant_sT3d, check_redundant_sT2d + module procedure check_redundant_vT3d, check_redundant_vT2d +end interface check_redundant_T + +!> Do checksums on the components of a C-grid vector +interface vec_chksum + module procedure chksum_vec_C3d, chksum_vec_C2d +end interface vec_chksum +!> Do checksums on the components of a C-grid vector +interface vec_chksum_C + module procedure chksum_vec_C3d, chksum_vec_C2d +end interface vec_chksum_C +!> Do checksums on the components of a B-grid vector +interface vec_chksum_B + module procedure chksum_vec_B3d, chksum_vec_B2d +end interface vec_chksum_B +!> Do checksums on the components of an A-grid vector +interface vec_chksum_A + module procedure chksum_vec_A3d, chksum_vec_A2d +end interface vec_chksum_A + +! Note: these parameters are module data but ONLY used when debugging and +! so can violate the thread-safe requirement of no module/global data. +integer :: max_redundant_prints = 100 !< Maximum number of times to write redundant messages +integer :: redundant_prints(3) = 0 !< Counters for controlling redundant printing +logical :: debug = .false. !< Write out verbose debugging data +logical :: debug_chksums = .true. !< Perform checksums on arrays +logical :: debug_redundant = .true. !< Check redundant values on PE boundaries + +contains + +!> MOM_debugging_init initializes the MOM_debugging module, and sets +!! the parameters that control which checks are active for MOM6. +subroutine MOM_debugging_init(param_file) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_debugging" ! This module's name. + + call log_version(param_file, mdl, version, debugging=.true.) + call get_param(param_file, mdl, "DEBUG", debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_CHKSUMS", debug_chksums, & + "If true, checksums are performed on arrays in the "//& + "various vec_chksum routines.", default=debug, & + debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_REDUNDANT", debug_redundant, & + "If true, debug redundant data points during calls to "//& + "the various vec_chksum routines.", default=debug, & + debuggingParam=.true.) + + call MOM_checksums_init(param_file) + +end subroutine MOM_debugging_init + +!> Check for consistency between the duplicated points of a 3-D C-grid vector +subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, & + direction, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + + ! Local variables + character(len=24) :: mesg_k + integer :: k + + do k=1,size(u_comp,3) + if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k + elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k + elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k + else ; write(mesg_k,'(" Layer",i9," ")') k ; endif + + call check_redundant_vC2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), & + v_comp(:,:,k), G, is, ie, js, je, direction, unscale) + enddo +end subroutine check_redundant_vC3d + +!> Check for consistency between the duplicated points of a 2-D C-grid vector +subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & + direction, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input vector while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of u_comp [A ~> a] + real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of v_comp [A ~> a] + real :: u_resym(G%IsdB:G%IedB,G%jsd:G%jed) ! A reconstructed symmetric version of u_comp [A ~> a] + real :: v_resym(G%isd:G%ied,G%JsdB:G%JedB) ! A reconstructed symmetric version of v_comp [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] + character(len=128) :: mesg2 + integer :: i, j, is_ch, ie_ch, js_ch, je_ch + integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.(present(is) .or. present(ie) .or. present(js) .or. present(je))) then + ! This only works with symmetric memory, so otherwise return. + if ((isd == IsdB) .and. (jsd == JsdB)) return + endif + + sc = 1.0 ; if (present(unscale)) sc = unscale + + do i=isd,ied ; do j=jsd,jed + u_nonsym(i,j) = u_comp(i,j) ; v_nonsym(i,j) = v_comp(i,j) + enddo ; enddo + + if (.not.associated(G%Domain_aux)) call MOM_error(FATAL," check_redundant"//& + " called with a non-associated auxiliary domain the grid type.") + call pass_vector(u_nonsym, v_nonsym, G%Domain_aux, direction) + + do I=IsdB,IedB ; do j=jsd,jed ; u_resym(I,j) = u_comp(I,j) ; enddo ; enddo + do i=isd,ied ; do J=JsdB,JedB ; v_resym(i,J) = v_comp(i,J) ; enddo ; enddo + do i=isd,ied ; do j=jsd,jed + u_resym(i,j) = u_nonsym(i,j) ; v_resym(i,j) = v_nonsym(i,j) + enddo ; enddo + call pass_vector(u_resym, v_resym, G%Domain, direction) + + is_ch = Isq ; ie_ch = Ieq ; js_ch = Jsq ; je_ch = Jeq + if (present(is)) is_ch = is ; if (present(ie)) ie_ch = ie + if (present(js)) js_ch = js ; if (present(js)) je_ch = je + + do i=is_ch,ie_ch ; do j=js_ch+1,je_ch + if (u_resym(i,j) /= u_comp(i,j) .and. & + redundant_prints(3) < max_redundant_prints) then + write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", & + & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & + sc*u_comp(i,j), sc*u_resym(i,j), sc*(u_comp(i,j)-u_resym(i,j)), i, j, pe_here() + write(0,'(A130)') trim(mesg)//trim(mesg2) + redundant_prints(3) = redundant_prints(3) + 1 + endif + enddo ; enddo + do i=is_ch+1,ie_ch ; do j=js_ch,je_ch + if (v_resym(i,j) /= v_comp(i,j) .and. & + redundant_prints(3) < max_redundant_prints) then + write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & + & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & + sc*v_comp(i,j), sc*v_resym(i,j), sc*(v_comp(i,j)-v_resym(i,j)), i, j, & + G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() + write(0,'(A155)') trim(mesg)//trim(mesg2) + redundant_prints(3) = redundant_prints(3) + 1 + endif + enddo ; enddo + +end subroutine check_redundant_vC2d + +!> Check for consistency between the duplicated points of a 3-D scalar at corner points +subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: array !< The array to be checked for consistency in + !! arbitrary, possibly rescaled units [A ~> a] + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + + ! Local variables + character(len=24) :: mesg_k + integer :: k + + do k=1,size(array,3) + if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k + elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k + elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k + else ; write(mesg_k,'(" Layer",i9," ")') k ; endif + + call check_redundant_sB2d(trim(mesg)//trim(mesg_k), array(:,:,k), & + G, is, ie, js, je, unscale) + enddo +end subroutine check_redundant_sB3d + +!> Check for consistency between the duplicated points of a 2-D scalar at corner points +subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: array !< The array to be checked for consistency in + !! arbitrary, possibly rescaled units [A ~> a] + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: a_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of array [A ~> a] + real :: a_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) ! A reconstructed symmetric version of array [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] + character(len=128) :: mesg2 + integer :: i, j, is_ch, ie_ch, js_ch, je_ch + integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.(present(is) .or. present(ie) .or. present(js) .or. present(je))) then + ! This only works with symmetric memory, so otherwise return. + if ((isd == IsdB) .and. (jsd == JsdB)) return + endif + + sc = 1.0 ; if (present(unscale)) sc = unscale + + do i=isd,ied ; do j=jsd,jed + a_nonsym(i,j) = array(i,j) + enddo ; enddo + + if (.not.associated(G%Domain_aux)) call MOM_error(FATAL," check_redundant"//& + " called with a non-associated auxiliary domain the grid type.") + call pass_vector(a_nonsym, a_nonsym, G%Domain_aux, & + direction=To_All+Scalar_Pair, stagger=BGRID_NE) + + do I=IsdB,IedB ; do J=JsdB,JedB ; a_resym(I,J) = array(I,J) ; enddo ; enddo + do i=isd,ied ; do j=jsd,jed + a_resym(i,j) = a_nonsym(i,j) + enddo ; enddo + call pass_vector(a_resym, a_resym, G%Domain, direction=To_All+Scalar_Pair, & + stagger=BGRID_NE) + + is_ch = Isq ; ie_ch = Ieq ; js_ch = Jsq ; je_ch = Jeq + if (present(is)) is_ch = is ; if (present(ie)) ie_ch = ie + if (present(js)) js_ch = js ; if (present(js)) je_ch = je + + do i=is_ch,ie_ch ; do j=js_ch,je_ch + if (a_resym(i,j) /= array(i,j) .and. & + redundant_prints(2) < max_redundant_prints) then + write(mesg2,'(" Redundant points",2(1pe12.4)," differ by ", & + & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & + sc*array(i,j), sc*a_resym(i,j), sc*(array(i,j)-a_resym(i,j)), i, j, pe_here() + write(0,'(A130)') trim(mesg)//trim(mesg2) + redundant_prints(2) = redundant_prints(2) + 1 + endif + enddo ; enddo + +end subroutine check_redundant_sB2d + +!> Check for consistency between the duplicated points of a 3-D B-grid vector +subroutine check_redundant_vB3d(mesg, u_comp, v_comp, G, is, ie, js, je, & + direction, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + character(len=24) :: mesg_k + integer :: k + + do k=1,size(u_comp,3) + if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k + elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k + elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k + else ; write(mesg_k,'(" Layer",i9," ")') k ; endif + + call check_redundant_vB2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), & + v_comp(:,:,k), G, is, ie, js, je, direction, unscale) + enddo +end subroutine check_redundant_vB3d + +!> Check for consistency between the duplicated points of a 2-D B-grid vector +subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & + direction, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input vector while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of u_comp [A ~> a] + real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of v_comp [A ~> a] + real :: u_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) ! A reconstructed symmetric version of u_comp [A ~> a] + real :: v_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) ! A reconstructed symmetric version of v_comp [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] + character(len=128) :: mesg2 + integer :: i, j, is_ch, ie_ch, js_ch, je_ch + integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.(present(is) .or. present(ie) .or. present(js) .or. present(je))) then + ! This only works with symmetric memory, so otherwise return. + if ((isd == IsdB) .and. (jsd == JsdB)) return + endif + + sc = 1.0 ; if (present(unscale)) sc = unscale + + do i=isd,ied ; do j=jsd,jed + u_nonsym(i,j) = u_comp(i,j) ; v_nonsym(i,j) = v_comp(i,j) + enddo ; enddo + + if (.not.associated(G%Domain_aux)) call MOM_error(FATAL," check_redundant"//& + " called with a non-associated auxiliary domain the grid type.") + call pass_vector(u_nonsym, v_nonsym, G%Domain_aux, direction, stagger=BGRID_NE) + + do I=IsdB,IedB ; do J=JsdB,JedB + u_resym(I,J) = u_comp(I,J) ; v_resym(I,J) = v_comp(I,J) + enddo ; enddo + do i=isd,ied ; do j=jsd,jed + u_resym(i,j) = u_nonsym(i,j) ; v_resym(i,j) = v_nonsym(i,j) + enddo ; enddo + call pass_vector(u_resym, v_resym, G%Domain, direction, stagger=BGRID_NE) + + is_ch = Isq ; ie_ch = Ieq ; js_ch = Jsq ; je_ch = Jeq + if (present(is)) is_ch = is ; if (present(ie)) ie_ch = ie + if (present(js)) js_ch = js ; if (present(js)) je_ch = je + + do i=is_ch,ie_ch ; do j=js_ch,je_ch + if (u_resym(i,j) /= u_comp(i,j) .and. & + redundant_prints(2) < max_redundant_prints) then + write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", & + & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & + sc*u_comp(i,j), sc*u_resym(i,j), sc*(u_comp(i,j)-u_resym(i,j)), i, j, pe_here() + write(0,'(A130)') trim(mesg)//trim(mesg2) + redundant_prints(2) = redundant_prints(2) + 1 + endif + enddo ; enddo + do i=is_ch,ie_ch ; do j=js_ch,je_ch + if (v_resym(i,j) /= v_comp(i,j) .and. & + redundant_prints(2) < max_redundant_prints) then + write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & + & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & + sc*v_comp(i,j), sc*v_resym(i,j), sc*(v_comp(i,j)-v_resym(i,j)), i, j, & + G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() + write(0,'(A155)') trim(mesg)//trim(mesg2) + redundant_prints(2) = redundant_prints(2) + 1 + endif + enddo ; enddo + +end subroutine check_redundant_vB2d + +!> Check for consistency between the duplicated points of a 3-D scalar at tracer points +subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:,:), intent(in) :: array !< The array to be checked for consistency in + !! arbitrary, possibly rescaled units [A ~> a] + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + character(len=24) :: mesg_k + integer :: k + + do k=1,size(array,3) + if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k + elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k + elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k + else ; write(mesg_k,'(" Layer",i9," ")') k ; endif + + call check_redundant_sT2d(trim(mesg)//trim(mesg_k), array(:,:,k), & + G, is, ie, js, je, unscale) + enddo +end subroutine check_redundant_sT3d + + +!> Check for consistency between the duplicated points of a 2-D scalar at tracer points +subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:), intent(in) :: array !< The array to be checked for consistency in + !! arbitrary, possibly rescaled units [A ~> a] + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: a_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A version of array with halo points updated by message passing [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] + character(len=128) :: mesg2 + + integer :: i, j, is_ch, ie_ch, js_ch, je_ch + integer :: isd, ied, jsd, jed + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + is_ch = G%isc ; ie_ch = G%iec ; js_ch = G%jsc ; je_ch = G%jec + if (present(is)) is_ch = is ; if (present(ie)) ie_ch = ie + if (present(js)) js_ch = js ; if (present(js)) je_ch = je + + sc = 1.0 ; if (present(unscale)) sc = unscale + + ! This only works on points outside of the standard computational domain. + if ((is_ch == G%isc) .and. (ie_ch == G%iec) .and. & + (js_ch == G%jsc) .and. (je_ch == G%jec)) return + + do i=isd,ied ; do j=jsd,jed + a_nonsym(i,j) = array(i,j) + enddo ; enddo + + call pass_var(a_nonsym, G%Domain) + + do i=is_ch,ie_ch ; do j=js_ch,je_ch + if (a_nonsym(i,j) /= array(i,j) .and. & + redundant_prints(1) < max_redundant_prints) then + write(mesg2,'(" Redundant points",2(1pe12.4)," differ by ", & + & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & + sc*array(i,j), sc*a_nonsym(i,j), sc*(array(i,j)-a_nonsym(i,j)), i, j, pe_here() + write(0,'(A130)') trim(mesg)//trim(mesg2) + redundant_prints(1) = redundant_prints(1) + 1 + endif + enddo ; enddo + +end subroutine check_redundant_sT2d + +!> Check for consistency between the duplicated points of a 3-D A-grid vector +subroutine check_redundant_vT3d(mesg, u_comp, v_comp, G, is, ie, js, je, & + direction, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + character(len=24) :: mesg_k + integer :: k + + do k=1,size(u_comp,3) + if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k + elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k + elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k + else ; write(mesg_k,'(" Layer",i9," ")') k ; endif + + call check_redundant_vT2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), & + v_comp(:,:,k), G, is, ie, js, je, direction, unscale) + enddo +end subroutine check_redundant_vT3d + +!> Check for consistency between the duplicated points of a 2-D A-grid vector +subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & + direction, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input vector while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A version of u_comp with halo points updated by message passing [A ~> a] + real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A version of v_comp with halo points updated by message passing [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] + character(len=128) :: mesg2 + + integer :: i, j, is_ch, ie_ch, js_ch, je_ch + integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + is_ch = G%isc ; ie_ch = G%iec ; js_ch = G%jsc ; je_ch = G%jec + if (present(is)) is_ch = is ; if (present(ie)) ie_ch = ie + if (present(js)) js_ch = js ; if (present(js)) je_ch = je + + sc = 1.0 ; if (present(unscale)) sc = unscale + + ! This only works on points outside of the standard computational domain. + if ((is_ch == G%isc) .and. (ie_ch == G%iec) .and. & + (js_ch == G%jsc) .and. (je_ch == G%jec)) return + + do i=isd,ied ; do j=jsd,jed + u_nonsym(i,j) = u_comp(i,j) ; v_nonsym(i,j) = v_comp(i,j) + enddo ; enddo + + call pass_vector(u_nonsym, v_nonsym, G%Domain, direction, stagger=AGRID) + + do i=is_ch,ie_ch ; do j=js_ch+1,je_ch + if (u_nonsym(i,j) /= u_comp(i,j) .and. & + redundant_prints(1) < max_redundant_prints) then + write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", & + & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & + sc*u_comp(i,j), sc*u_nonsym(i,j), sc*(u_comp(i,j)-u_nonsym(i,j)), i, j, pe_here() + write(0,'(A130)') trim(mesg)//trim(mesg2) + redundant_prints(1) = redundant_prints(1) + 1 + endif + enddo ; enddo + do i=is_ch+1,ie_ch ; do j=js_ch,je_ch + if (v_nonsym(i,j) /= v_comp(i,j) .and. & + redundant_prints(1) < max_redundant_prints) then + write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & + & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & + sc*v_comp(i,j), sc*v_nonsym(i,j), sc*(v_comp(i,j)-v_nonsym(i,j)), i, j, & + G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() + write(0,'(A155)') trim(mesg)//trim(mesg2) + redundant_prints(1) = redundant_prints(1) + 1 + endif + enddo ; enddo + +end subroutine check_redundant_vT2d + + +! It appears that none of the other routines in this file are ever called. + +!> Do a checksum and redundant point check on a 3d C-grid vector. +subroutine chksum_vec_C3d(mesg, u_comp, v_comp, G, halos, scalars, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + integer, optional, intent(in) :: halos !< The width of halos to check (default 0) + logical, optional, intent(in) :: scalars !< If true this is a pair of + !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + logical :: are_scalars + are_scalars = .false. ; if (present(scalars)) are_scalars = scalars + + if (debug_chksums) then + call uvchksum(mesg, u_comp, v_comp, G%HI, halos, scale=unscale) + endif + if (debug_redundant) then + if (are_scalars) then + call check_redundant_C(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) + else + call check_redundant_C(mesg, u_comp, v_comp, G, unscale=unscale) + endif + endif + +end subroutine chksum_vec_C3d + +!> Do a checksum and redundant point check on a 2d C-grid vector. +subroutine chksum_vec_C2d(mesg, u_comp, v_comp, G, halos, scalars, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + integer, optional, intent(in) :: halos !< The width of halos to check (default 0) + logical, optional, intent(in) :: scalars !< If true this is a pair of + !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + logical :: are_scalars + are_scalars = .false. ; if (present(scalars)) are_scalars = scalars + + if (debug_chksums) then + call uvchksum(mesg, u_comp, v_comp, G%HI, halos, scale=unscale) + endif + if (debug_redundant) then + if (are_scalars) then + call check_redundant_C(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) + else + call check_redundant_C(mesg, u_comp, v_comp, G, unscale=unscale) + endif + endif + +end subroutine chksum_vec_C2d + +!> Do a checksum and redundant point check on a 3d B-grid vector. +subroutine chksum_vec_B3d(mesg, u_comp, v_comp, G, halos, scalars, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + integer, optional, intent(in) :: halos !< The width of halos to check (default 0) + logical, optional, intent(in) :: scalars !< If true this is a pair of + !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + logical :: are_scalars + are_scalars = .false. ; if (present(scalars)) are_scalars = scalars + + if (debug_chksums) then + call Bchksum(u_comp, mesg//"(u)", G%HI, halos, scale=unscale) + call Bchksum(v_comp, mesg//"(v)", G%HI, halos, scale=unscale) + endif + if (debug_redundant) then + if (are_scalars) then + call check_redundant_B(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) + else + call check_redundant_B(mesg, u_comp, v_comp, G, unscale=unscale) + endif + endif + +end subroutine chksum_vec_B3d + +! Do a checksum and redundant point check on a 2d B-grid vector. +subroutine chksum_vec_B2d(mesg, u_comp, v_comp, G, halos, scalars, symmetric, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + integer, optional, intent(in) :: halos !< The width of halos to check (default 0) + logical, optional, intent(in) :: scalars !< If true this is a pair of + !! scalars that are being checked. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the + !! full symmetric computational domain. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + logical :: are_scalars + are_scalars = .false. ; if (present(scalars)) are_scalars = scalars + + if (debug_chksums) then + call Bchksum(u_comp, mesg//"(u)", G%HI, halos, symmetric=symmetric, scale=unscale) + call Bchksum(v_comp, mesg//"(v)", G%HI, halos, symmetric=symmetric, scale=unscale) + endif + if (debug_redundant) then + if (are_scalars) then + call check_redundant_B(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) + else + call check_redundant_B(mesg, u_comp, v_comp, G, unscale=unscale) + endif + endif + +end subroutine chksum_vec_B2d + +!> Do a checksum and redundant point check on a 3d C-grid vector. +subroutine chksum_vec_A3d(mesg, u_comp, v_comp, G, halos, scalars, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + integer, optional, intent(in) :: halos !< The width of halos to check (default 0) + logical, optional, intent(in) :: scalars !< If true this is a pair of + !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + logical :: are_scalars + are_scalars = .false. ; if (present(scalars)) are_scalars = scalars + + if (debug_chksums) then + call hchksum(u_comp, mesg//"(u)", G%HI, halos, scale=unscale) + call hchksum(v_comp, mesg//"(v)", G%HI, halos, scale=unscale) + endif + if (debug_redundant) then + if (are_scalars) then + call check_redundant_T(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) + else + call check_redundant_T(mesg, u_comp, v_comp, G, unscale=unscale) + endif + endif + +end subroutine chksum_vec_A3d + +!> Do a checksum and redundant point check on a 2d C-grid vector. +subroutine chksum_vec_A2d(mesg, u_comp, v_comp, G, halos, scalars, unscale) + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + integer, optional, intent(in) :: halos !< The width of halos to check (default 0) + logical, optional, intent(in) :: scalars !< If true this is a pair of + !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables + logical :: are_scalars + are_scalars = .false. ; if (present(scalars)) are_scalars = scalars + + if (debug_chksums) then + call hchksum(u_comp, mesg//"(u)", G%HI, halos, scale=unscale) + call hchksum(v_comp, mesg//"(v)", G%HI, halos, scale=unscale) + endif + if (debug_redundant) then + if (are_scalars) then + call check_redundant_T(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) + else + call check_redundant_T(mesg, u_comp, v_comp, G, unscale=unscale) + endif + endif + +end subroutine chksum_vec_A2d + +!> This function returns the sum over computational domain of all +!! processors of hThick*stuff, where stuff is a 3-d array at tracer points. +function totalStuff(HI, hThick, areaT, stuff) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: hThick !< The array of thicknesses to use as weights [m] + real, dimension(HI%isd:,HI%jsd:), intent(in) :: areaT !< The array of cell areas [m2] + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: stuff !< The array of stuff to be summed in arbitrary units [a] + real :: totalStuff !< the globally integrated amount of stuff [a m3] + ! Local variables + real, dimension(HI%isc:HI%iec, HI%jsc:HI%jec) :: tmp_for_sum ! The column integrated amount of stuff in a cell [a m3] + integer :: i, j, k, nz + + nz = size(hThick,3) + tmp_for_sum(:,:) = 0.0 + do k=1,nz ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + tmp_for_sum(i,j) = tmp_for_sum(i,j) + hThick(i,j,k) * stuff(i,j,k) * areaT(i,j) + enddo ; enddo ; enddo + totalStuff = reproducing_sum(tmp_for_sum) + +end function totalStuff + +!> This subroutine display the total thickness, temperature and salinity +!! as well as the change since the last call. +subroutine totalTandS(HI, hThick, areaT, temperature, salinity, mesg) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: hThick !< The array of thicknesses to use as weights [m] + real, dimension(HI%isd:,HI%jsd:), intent(in) :: areaT !< The array of cell areas [m2] + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: temperature !< The temperature field to sum [degC] + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: salinity !< The salinity field to sum [ppt] + character(len=*), intent(in) :: mesg !< An identifying message + ! NOTE: This subroutine uses "save" data which is not thread safe and is purely for + ! extreme debugging without a proper debugger. + real, save :: totalH = 0. ! The total ocean volume, saved for the next call [m3] + real, save :: totalT = 0. ! The total volume integrated ocean temperature, saved for the next call [degC m3] + real, save :: totalS = 0. ! The total volume integrated ocean salinity, saved for the next call [ppt m3] + ! Local variables + logical, save :: firstCall = .true. + real, dimension(HI%isc:HI%iec, HI%jsc:HI%jec) :: tmp_for_sum ! The volume of each column [m3] + real :: thisH, delH ! The total ocean volume and the change from the last call [m3] + real :: thisT, delT ! The current total volume integrated temperature and the change from the last call [degC m3] + real :: thisS, delS ! The current total volume integrated salinity and the change from the last call [ppt m3] + integer :: i, j, k, nz + + nz = size(hThick,3) + tmp_for_sum(:,:) = 0.0 + do k=1,nz ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + tmp_for_sum(i,j) = tmp_for_sum(i,j) + hThick(i,j,k) * areaT(i,j) + enddo ; enddo ; enddo + thisH = reproducing_sum(tmp_for_sum) + thisT = totalStuff(HI, hThick, areaT, temperature) + thisS = totalStuff(HI, hThick, areaT, salinity) + + if (is_root_pe()) then + if (firstCall) then + totalH = thisH ; totalT = thisT ; totalS = thisS + write(0,*) 'Totals H,T,S:',thisH,thisT,thisS,' ',mesg + firstCall = .false. + else + delH = thisH - totalH + delT = thisT - totalT + delS = thisS - totalS + totalH = thisH ; totalT = thisT ; totalS = thisS + write(0,*) 'Tot/del H,T,S:',thisH,thisT,thisS,delH,delT,delS,' ',mesg + endif + endif + +end subroutine totalTandS + +!> Returns false if the column integral of a given quantity is within roundoff +logical function check_column_integral(nk, field, known_answer) + integer, intent(in) :: nk !< Number of levels in column + real, dimension(nk), intent(in) :: field !< Field to be summed [arbitrary] + real, optional, intent(in) :: known_answer !< If present is the expected sum [arbitrary], + !! If missing, assumed zero + ! Local variables + real :: u_sum ! The vertical sum of the field [arbitrary] + real :: error ! An estimate of the roundoff error in the sum [arbitrary] + real :: expected ! The expected vertical sum [arbitrary] + integer :: k + + u_sum = field(1) + error = 0. + + ! Reintegrate and sum roundoff errors + do k=2,nk + u_sum = u_sum + field(k) + error = error + EPSILON(u_sum)*MAX(ABS(u_sum),ABS(field(k))) + enddo + + ! Assign expected answer to either the optional input or 0 + if (present(known_answer)) then + expected = known_answer + else + expected = 0. + endif + + ! Compare the column integrals against calculated roundoff error + if (abs(u_sum-expected) > error) then + check_column_integral = .true. + else + check_column_integral = .false. + endif + +end function check_column_integral + +!> Returns false if the column integrals of two given quantities are within roundoff of each other +logical function check_column_integrals(nk_1, field_1, nk_2, field_2, missing_value) + integer, intent(in) :: nk_1 !< Number of levels in field 1 + integer, intent(in) :: nk_2 !< Number of levels in field 2 + real, dimension(nk_1), intent(in) :: field_1 !< First field to be summed [arbitrary] + real, dimension(nk_2), intent(in) :: field_2 !< Second field to be summed [arbitrary] + real, optional, intent(in) :: missing_value !< If column contains missing values, + !! mask them from the sum [arbitrary] + ! Local variables + real :: u1_sum, u2_sum ! The vertical sums of the two fields [arbitrary] + real :: error1, error2 ! Estimates of the roundoff errors in the sums [arbitrary] + real :: misval ! The missing value flag, indicating elements that are to be omitted + ! from the sums [arbitrary] + integer :: k + + ! Assign missing value + if (present(missing_value)) then + misval = missing_value + else + misval = 0. + endif + + u1_sum = field_1(1) + error1 = 0. + + ! Reintegrate and sum roundoff errors + do k=2,nk_1 + if (field_1(k) /= misval) then + u1_sum = u1_sum + field_1(k) + error1 = error1 + EPSILON(u1_sum)*MAX(ABS(u1_sum),ABS(field_1(k))) + endif + enddo + + u2_sum = field_2(1) + error2 = 0. + + ! Reintegrate and sum roundoff errors + do k=2,nk_2 + if (field_2(k) /= misval) then + u2_sum = u2_sum + field_2(k) + error2 = error2 + EPSILON(u2_sum)*MAX(ABS(u2_sum),ABS(field_2(k))) + endif + enddo + + ! Compare the column integrals against calculated roundoff error + if (abs(u1_sum-u2_sum) > (error1+error2)) then + check_column_integrals = .true. + else + check_column_integrals = .false. + endif + +end function check_column_integrals + +end module MOM_debugging diff --git a/diagnostics/MOM_diagnostics.F90 b/diagnostics/MOM_diagnostics.F90 new file mode 100644 index 0000000000..aeb25bc351 --- /dev/null +++ b/diagnostics/MOM_diagnostics.F90 @@ -0,0 +1,2307 @@ +!> Calculates any requested diagnostic quantities +!! that are not calculated in the various subroutines. +!! Diagnostic quantities are requested by allocating them memory. +module MOM_diagnostics + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : reproducing_sum +use MOM_coupler_types, only : coupler_type_send_data +use MOM_density_integrals, only : int_density_dz +use MOM_diag_mediator, only : post_data, get_diag_time_end +use MOM_diag_mediator, only : post_product_u, post_product_sum_u +use MOM_diag_mediator, only : post_product_v, post_product_sum_v +use MOM_diag_mediator, only : register_diag_field, register_scalar_field +use MOM_diag_mediator, only : register_static_field, diag_register_area_ids +use MOM_diag_mediator, only : diag_ctrl, time_type, safe_alloc_ptr +use MOM_diag_mediator, only : diag_get_volume_cell_measure_dm_id +use MOM_diag_mediator, only : diag_grid_storage +use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids, diag_copy_storage_to_diag +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : To_North, To_East +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : cons_temp_to_pot_temp, abs_saln_to_prac_saln +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : find_eta +use MOM_spatial_means, only : global_area_mean, global_layer_mean +use MOM_spatial_means, only : global_volume_mean, global_area_integral +use MOM_tracer_registry, only : tracer_registry_type, post_tracer_transport_diagnostics +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, ocean_internal_state, p3d +use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, surface +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units, get_flux_units +use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init + +implicit none ; private + +#include + +public calculate_diagnostic_fields, register_time_deriv, write_static_fields +public find_eta +public register_surface_diags, post_surface_dyn_diags, post_surface_thermo_diags +public register_transport_diags, post_transport_diagnostics +public MOM_diagnostics_init, MOM_diagnostics_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> The control structure for the MOM_diagnostics module +type, public :: diagnostics_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + real :: mono_N2_column_fraction = 0. !< The lower fraction of water column over which N2 is limited as + !! monotonic for the purposes of calculating the equivalent + !! barotropic wave speed [nondim]. + real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of + !! calculating the equivalent barotropic wave speed [H ~> m or kg m-2]. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + + ! following arrays store diagnostics calculated here and unavailable outside. + + ! following fields have nz layers. + real, allocatable :: du_dt(:,:,:) !< net i-acceleration [L T-2 ~> m s-2] + real, allocatable :: dv_dt(:,:,:) !< net j-acceleration [L T-2 ~> m s-2] + real, allocatable :: dh_dt(:,:,:) !< thickness rate of change [H T-1 ~> m s-1 or kg m-2 s-1] + + logical :: KE_term_on !< If true, at least one diagnostic term in the KE budget is in use. + + !>@{ Diagnostic IDs + integer :: id_u = -1, id_v = -1, id_h = -1 + integer :: id_usq = -1, id_vsq = -1, id_uv = -1 + integer :: id_e = -1, id_e_D = -1 + integer :: id_du_dt = -1, id_dv_dt = -1 + ! integer :: id_hf_du_dt = -1, id_hf_dv_dt = -1 + integer :: id_h_du_dt = -1, id_h_dv_dt = -1 + integer :: id_hf_du_dt_2d = -1, id_hf_dv_dt_2d = -1 + integer :: id_col_ht = -1, id_dh_dt = -1 + integer :: id_KE = -1, id_dKEdt = -1 + integer :: id_PE_to_KE = -1, id_KE_BT = -1 + integer :: id_KE_Coradv = -1, id_KE_adv = -1 + integer :: id_KE_visc = -1, id_KE_stress = -1 + integer :: id_KE_visc_gl90 = -1 + integer :: id_KE_horvisc = -1, id_KE_dia = -1 + integer :: id_uh_Rlay = -1, id_vh_Rlay = -1 + integer :: id_uhGM_Rlay = -1, id_vhGM_Rlay = -1 + integer :: id_h_Rlay = -1, id_Rd1 = -1 + integer :: id_Rml = -1, id_Rcv = -1 + integer :: id_cg1 = -1, id_cfl_cg1 = -1 + integer :: id_cfl_cg1_x = -1, id_cfl_cg1_y = -1 + integer :: id_cg_ebt = -1, id_Rd_ebt = -1 + integer :: id_p_ebt = -1 + integer :: id_temp_int = -1, id_salt_int = -1 + integer :: id_mass_wt = -1, id_col_mass = -1 + integer :: id_masscello = -1, id_masso = -1 + integer :: id_volcello = -1 + integer :: id_Tpot = -1, id_Sprac = -1 + integer :: id_tob = -1, id_sob = -1 + integer :: id_thetaoga = -1, id_soga = -1 + integer :: id_sosga = -1, id_tosga = -1 + integer :: id_temp_layer_ave = -1, id_salt_layer_ave = -1 + integer :: id_pbo = -1 + integer :: id_thkcello = -1, id_rhoinsitu = -1 + integer :: id_rhopot0 = -1, id_rhopot2 = -1 + integer :: id_drho_dT = -1, id_drho_dS = -1 + integer :: id_h_pre_sync = -1 + integer :: id_tosq = -1, id_sosq = -1 + + !>@} + type(wave_speed_CS) :: wave_speed !< Wave speed control struct + + type(p3d) :: var_ptr(MAX_FIELDS_) !< pointers to variables used in the calculation + !! of time derivatives + type(p3d) :: deriv(MAX_FIELDS_) !< Time derivatives of various fields + type(p3d) :: prev_val(MAX_FIELDS_) !< Previous values of variables used in the calculation + !! of time derivatives + !< previous values of variables used in calculation of time derivatives + integer :: nlay(MAX_FIELDS_) !< The number of layers in each diagnostics + integer :: num_time_deriv = 0 !< The number of time derivative diagnostics + + type(group_pass_type) :: pass_KE_uv !< A handle used for group halo passes + +end type diagnostics_CS + + +!> A structure with diagnostic IDs of the surface and integrated variables +type, public :: surface_diag_IDs ; private + !>@{ Diagnostic IDs for 2-d surface and bottom flux and state fields + !Diagnostic IDs for 2-d surface and bottom fields + integer :: id_zos = -1, id_zossq = -1 + integer :: id_volo = -1, id_speed = -1 + integer :: id_ssh = -1, id_ssh_ga = -1 + integer :: id_sst = -1, id_sst_sq = -1, id_sstcon = -1 + integer :: id_sss = -1, id_sss_sq = -1, id_sssabs = -1 + integer :: id_ssu = -1, id_ssv = -1 + + ! Diagnostic IDs for heat and salt flux fields + integer :: id_fraz = -1 + integer :: id_salt_deficit = -1 + integer :: id_Heat_PmE = -1 + integer :: id_intern_heat = -1 + !>@} +end type surface_diag_IDs + + +!> A structure with diagnostic IDs of mass transport related diagnostics +type, public :: transport_diag_IDs ; private + !>@{ Diagnostics for tracer horizontal transport + integer :: id_uhtr = -1, id_umo = -1, id_umo_2d = -1 + integer :: id_vhtr = -1, id_vmo = -1, id_vmo_2d = -1 + integer :: id_dynamics_h = -1, id_dynamics_h_tendency = -1 + !>@} +end type transport_diag_IDs + + +contains +!> Diagnostics not more naturally calculated elsewhere are computed here. +subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & + dt, diag_pre_sync, G, GV, US, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: uh !< Transport through zonal faces = u*h*dy, + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vh !< Transport through meridional faces = v*h*dx, + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + type(accel_diag_ptrs), intent(in) :: ADp !< structure with pointers to + !! accelerations in momentum equation. + type(cont_diag_ptrs), intent(in) :: CDp !< structure with pointers to + !! terms in continuity equation. + real, dimension(:,:), pointer :: p_surf !< A pointer to the surface pressure [R L2 T-2 ~> Pa]. + !! If p_surf is not associated, it is the same + !! as setting the surface pressure to 0. + real, intent(in) :: dt !< The time difference since the last + !! call to this subroutine [T ~> s]. + type(diag_grid_storage), intent(in) :: diag_pre_sync !< Target grids from previous timestep + type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a + !! previous call to diagnostics_init. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: uv ! u x v at h-points [L2 T-2 ~> m2 s-2] + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb + + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Interface heights, either relative to a reference + ! geopotential or the seafloor [Z ~> m]. + real :: Rcv(SZI_(G),SZJ_(G),SZK_(GV)) ! Coordinate variable potential density [R ~> kg m-3]. + real :: work_3d(SZI_(G),SZJ_(G),SZK_(GV)) ! A 3-d temporary work array in various units + ! including [nondim] and [H ~> m or kg m-2]. + real :: uh_tmp(SZIB_(G),SZJ_(G),SZK_(GV)) ! A temporary zonal transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vh_tmp(SZI_(G),SZJB_(G),SZK_(GV)) ! A temporary meridional transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: mass_cell(SZI_(G),SZJ_(G)) ! The vertically integrated mass in a grid cell [kg] + real :: rho_in_situ(SZI_(G)) ! In situ density [R ~> kg m-3] + real :: cg1(SZI_(G),SZJ_(G)) ! First baroclinic gravity wave speed [L T-1 ~> m s-1] + real :: Rd1(SZI_(G),SZJ_(G)) ! First baroclinic deformation radius [L ~> m] + real :: CFL_cg1(SZI_(G),SZJ_(G)) ! CFL for first baroclinic gravity wave speed, either based on the + ! overall grid spacing or just one direction [nondim] + + + ! tmp array for surface properties + real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS [R L2 T-2 ~> Pa] + real :: wt, wt_p ! The fractional weights of two successive values when interpolating from + ! a list [nondim], scaled so that wt + wt_p = 1. + real :: f2_h ! Squared Coriolis parameter at to h-points [T-2 ~> s-2] + real :: mag_beta ! Magnitude of the gradient of f [T-1 L-1 ~> s-1 m-1] + real :: absurdly_small_freq2 ! Frequency squared used to avoid division by 0 [T-2 ~> s-2] + + integer :: k_list + + real, dimension(SZK_(GV)) :: temp_layer_ave ! The average temperature in a layer [C ~> degC] + real, dimension(SZK_(GV)) :: salt_layer_ave ! The average salinity in a layer [S ~> ppt] + real :: thetaoga ! The volume mean potential temperature [C ~> degC] + real :: soga ! The volume mean ocean salinity [S ~> ppt] + real :: masso ! The total mass of the ocean [kg] + real :: tosga ! The area mean sea surface temperature [C ~> degC] + real :: sosga ! The area mean sea surface salinity [S ~> ppt] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + nz = GV%ke ; nkmb = GV%nk_rho_varies + + ! This value is roughly (pi / (the age of the universe) )^2. + absurdly_small_freq2 = 1e-34*US%T_to_s**2 + + if (.not. CS%initialized) call MOM_error(FATAL, & + "calculate_diagnostic_fields: Module must be initialized before used.") + + call calculate_derivs(dt, G, CS) + + if (dt > 0.0) then + call diag_save_grids(CS%diag) + call diag_copy_storage_to_diag(CS%diag, diag_pre_sync) + + if (CS%id_h_pre_sync > 0) & + call post_data(CS%id_h_pre_sync, diag_pre_sync%h_state, CS%diag, alt_h=diag_pre_sync%h_state) + + if (CS%id_du_dt>0) call post_data(CS%id_du_dt, CS%du_dt, CS%diag, alt_h=diag_pre_sync%h_state) + + if (CS%id_dv_dt>0) call post_data(CS%id_dv_dt, CS%dv_dt, CS%diag, alt_h=diag_pre_sync%h_state) + + if (CS%id_dh_dt>0) call post_data(CS%id_dh_dt, CS%dh_dt, CS%diag, alt_h=diag_pre_sync%h_state) + + !! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_du(dv)_dt are commented because there is no clarity on proper remapping grid option. + ! The code is retained for debugging purposes in the future. + !if (CS%id_hf_du_dt > 0) then + ! call post_product_u(CS%id_hf_du_dt, CS%du_dt, ADp%diag_hfrac_u, G, nz, CS%diag, alt_h=diag_pre_sync%h_state) + !if (CS%id_hf_dv_dt > 0) & + ! call post_product_v(CS%id_hf_dv_dt, CS%dv_dt, ADp%diag_hfrac_v, G, nz, CS%diag, alt_h=diag_pre_sync%h_state) + + if (CS%id_hf_du_dt_2d > 0) & + call post_product_sum_u(CS%id_hf_du_dt_2d, CS%du_dt, ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_dv_dt_2d > 0) & + call post_product_sum_v(CS%id_hf_dv_dt_2d, CS%dv_dt, ADp%diag_hfrac_v, G, nz, CS%diag) + + if (CS%id_h_du_dt > 0) & + call post_product_u(CS%id_h_du_dt, CS%du_dt, ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_dv_dt > 0) & + call post_product_v(CS%id_h_dv_dt, CS%dv_dt, ADp%diag_hv, G, nz, CS%diag) + + call diag_restore_grids(CS%diag) + + call calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS) + endif + + ! smg: is the following robust to ALE? It seems a bit opaque. + ! If the model is NOT in isopycnal mode then nkmb=0. But we need all the + ! following diagnostics to treat all layers as variable density, so we set + ! nkmb = nz, on the expectation that loops nkmb+1,nz will not iterate. + ! This behavior is ANSI F77 but some compiler options can force at least + ! one iteration that would break the following one-line workaround! + if (nkmb==0 .and. nz > 1) nkmb = nz + + if (CS%id_u > 0) call post_data(CS%id_u, u, CS%diag) + + if (CS%id_v > 0) call post_data(CS%id_v, v, CS%diag) + + if (CS%id_h > 0) call post_data(CS%id_h, h, CS%diag) + + if (CS%id_usq > 0) call post_product_u(CS%id_usq, u, u, G, nz, CS%diag) + + if (CS%id_vsq > 0) call post_product_v(CS%id_vsq, v, v, G, nz, CS%diag) + + if (CS%id_uv > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + uv(i,j,k) = (0.5*(u(I-1,j,k) + u(I,j,k))) * & + (0.5*(v(i,J-1,k) + v(i,J,k))) + enddo ; enddo ; enddo + call post_data(CS%id_uv, uv, CS%diag) + endif + + ! Find the interface heights, relative either to a reference height or to the bottom [Z ~> m]. + if (CS%id_e > 0) then + call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref) + if (CS%id_e > 0) call post_data(CS%id_e, eta, CS%diag) + if (CS%id_e_D > 0) then + do k=1,nz+1 ; do j=js,je ; do i=is,ie + eta(i,j,k) = eta(i,j,k) + (G%bathyT(i,j) + G%Z_ref) + enddo ; enddo ; enddo + call post_data(CS%id_e_D, eta, CS%diag) + endif + elseif (CS%id_e_D > 0) then + call find_eta(h, tv, G, GV, US, eta) + do k=1,nz+1 ; do j=js,je ; do i=is,ie + eta(i,j,k) = eta(i,j,k) + G%bathyT(i,j) + enddo ; enddo ; enddo + call post_data(CS%id_e_D, eta, CS%diag) + endif + + ! mass per area of grid cell (for Boussinesq, use Rho0) + if (CS%id_masscello > 0) then + call post_data(CS%id_masscello, h, CS%diag) + endif + + ! mass of liquid ocean (for Bouss, use Rho0). The reproducing sum requires the use of MKS units. + if (CS%id_masso > 0) then + mass_cell(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + mass_cell(i,j) = mass_cell(i,j) + (GV%H_to_kg_m2*h(i,j,k)) * US%L_to_m**2*G%areaT(i,j) + enddo ; enddo ; enddo + masso = reproducing_sum(mass_cell) + call post_data(CS%id_masso, masso, CS%diag) + endif + + ! diagnose thickness/volumes of grid cells [Z ~> m] and [m3] + if (CS%id_thkcello>0 .or. CS%id_volcello>0) then + if (GV%Boussinesq) then ! thkcello = h for Boussinesq + if (CS%id_thkcello > 0) then ; if (GV%H_to_Z == 1.0) then + call post_data(CS%id_thkcello, h, CS%diag) + else + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = GV%H_to_Z*h(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_thkcello, work_3d, CS%diag) + endif ; endif + if (CS%id_volcello > 0) then ! volcello = h*area for Boussinesq + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = ( GV%H_to_Z*h(i,j,k) ) * US%Z_to_m*US%L_to_m**2*G%areaT(i,j) + enddo ; enddo ; enddo + call post_data(CS%id_volcello, work_3d, CS%diag) + endif + else ! thkcello = dp/(rho*g) for non-Boussinesq + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + if (associated(p_surf)) then ! Pressure loading at top of surface layer [R L2 T-2 ~> Pa] + do i=is,ie + pressure_1d(i) = p_surf(i,j) + enddo + else + do i=is,ie + pressure_1d(i) = 0.0 + enddo + endif + do k=1,nz ! Integrate vertically downward for pressure + do i=is,ie ! Pressure for EOS at the layer center [R L2 T-2 ~> Pa] + pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k) + enddo + ! Store in-situ density [R ~> kg m-3] in work_3d + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, rho_in_situ, & + tv%eqn_of_state, EOSdom) + do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d + work_3d(i,j,k) = (GV%H_to_RZ*h(i,j,k)) / rho_in_situ(i) + enddo + do i=is,ie ! Pressure for EOS at the bottom interface [R L2 T-2 ~> Pa] + pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k) + enddo + enddo ! k + enddo ! j + if (CS%id_thkcello > 0) call post_data(CS%id_thkcello, work_3d, CS%diag) + if (CS%id_volcello > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie ! volcello = dp/(rho*g)*area for non-Boussinesq + work_3d(i,j,k) = US%Z_to_m*US%L_to_m**2*G%areaT(i,j) * work_3d(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_volcello, work_3d, CS%diag) + endif + endif + endif + + ! Calculate additional, potentially derived temperature diagnostics + if (tv%T_is_conT) then + ! Internal T&S variables are conservative temperature & absolute salinity, + ! so they need to converted to potential temperature and practical salinity + ! for some diagnostics using TEOS-10 function calls. + if ((CS%id_Tpot > 0) .or. (CS%id_tob > 0) .or. (CS%id_tosq > 0)) then + EOSdom(:) = EOS_domain(G%HI) + do k=1,nz ; do j=js,je + call cons_temp_to_pot_temp(tv%T(:,j,k), tv%S(:,j,k), work_3d(:,j,k), tv%eqn_of_state, EOSdom) + enddo ; enddo + if (CS%id_Tpot > 0) call post_data(CS%id_Tpot, work_3d, CS%diag) + if (CS%id_tob > 0) call post_data(CS%id_tob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT) + if (CS%id_tosq > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = work_3d(i,j,k)*work_3d(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_tosq, work_3d, CS%diag) + endif + endif + else + ! Internal T&S variables are potential temperature & practical salinity + if (CS%id_tob > 0) call post_data(CS%id_tob, tv%T(:,:,nz), CS%diag, mask=G%mask2dT) + if (CS%id_tosq > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = tv%T(i,j,k)*tv%T(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_tosq, work_3d, CS%diag) + endif + endif + + ! Calculate additional, potentially derived salinity diagnostics + if (tv%S_is_absS) then + ! Internal T&S variables are conservative temperature & absolute salinity, + ! so they need to converted to potential temperature and practical salinity + ! for some diagnostics using TEOS-10 function calls. + if ((CS%id_Sprac > 0) .or. (CS%id_sob > 0) .or. (CS%id_sosq >0)) then + EOSdom(:) = EOS_domain(G%HI) + do k=1,nz ; do j=js,je + call abs_saln_to_prac_saln(tv%S(:,j,k), work_3d(:,j,k), tv%eqn_of_state, EOSdom) + enddo ; enddo + if (CS%id_Sprac > 0) call post_data(CS%id_Sprac, work_3d, CS%diag) + if (CS%id_sob > 0) call post_data(CS%id_sob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT) + if (CS%id_sosq > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = work_3d(i,j,k)*work_3d(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_sosq, work_3d, CS%diag) + endif + endif + else + ! Internal T&S variables are potential temperature & practical salinity + if (CS%id_sob > 0) call post_data(CS%id_sob, tv%S(:,:,nz), CS%diag, mask=G%mask2dT) + if (CS%id_sosq > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = tv%S(i,j,k)*tv%S(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_sosq, work_3d, CS%diag) + endif + endif + + ! volume mean potential temperature + if (CS%id_thetaoga>0) then + thetaoga = global_volume_mean(tv%T, h, G, GV, tmp_scale=US%C_to_degC) + call post_data(CS%id_thetaoga, thetaoga, CS%diag) + endif + + ! area mean SST + if (CS%id_tosga > 0) then + tosga = global_area_mean(tv%T(:,:,1), G, tmp_scale=US%C_to_degC) + call post_data(CS%id_tosga, tosga, CS%diag) + endif + + ! volume mean salinity + if (CS%id_soga>0) then + soga = global_volume_mean(tv%S, h, G, GV, tmp_scale=US%S_to_ppt) + call post_data(CS%id_soga, soga, CS%diag) + endif + + ! area mean SSS + if (CS%id_sosga > 0) then + sosga = global_area_mean(tv%S(:,:,1), G, tmp_scale=US%S_to_ppt) + call post_data(CS%id_sosga, sosga, CS%diag) + endif + + ! layer mean potential temperature + if (CS%id_temp_layer_ave>0) then + temp_layer_ave = global_layer_mean(tv%T, h, G, GV, tmp_scale=US%C_to_degC) + call post_data(CS%id_temp_layer_ave, temp_layer_ave, CS%diag) + endif + + ! layer mean salinity + if (CS%id_salt_layer_ave>0) then + salt_layer_ave = global_layer_mean(tv%S, h, G, GV, tmp_scale=US%S_to_ppt) + call post_data(CS%id_salt_layer_ave, salt_layer_ave, CS%diag) + endif + + call calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) + + if ((CS%id_Rml > 0) .or. (CS%id_Rcv > 0) .or. (CS%id_h_Rlay > 0) .or. & + (CS%id_uh_Rlay > 0) .or. (CS%id_vh_Rlay > 0) .or. & + (CS%id_uhGM_Rlay > 0) .or. (CS%id_vhGM_Rlay > 0)) then + + if (associated(tv%eqn_of_state)) then + EOSdom(:) = EOS_domain(G%HI, halo=1) + pressure_1d(:) = tv%P_Ref + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-1,je+1 + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), tv%eqn_of_state, & + EOSdom) + enddo ; enddo + else ! Rcv should not be used much in this case, so fill in sensible values. + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + Rcv(i,j,k) = GV%Rlay(k) + enddo ; enddo ; enddo + endif + if (CS%id_Rml > 0) call post_data(CS%id_Rml, Rcv, CS%diag) + if (CS%id_Rcv > 0) call post_data(CS%id_Rcv, Rcv, CS%diag) + + if (CS%id_h_Rlay > 0) then + ! Here work_3d is used for the layer thicknesses in potential density coordinates [H ~> m or kg m-2]. + k_list = nz/2 + !$OMP parallel do default(shared) private(wt,wt_p) firstprivate(k_list) + do j=js,je + do k=1,nkmb ; do i=is,ie + work_3d(i,j,k) = 0.0 + enddo ; enddo + do k=nkmb+1,nz ; do i=is,ie + work_3d(i,j,k) = h(i,j,k) + enddo ; enddo + do k=1,nkmb ; do i=is,ie + call find_weights(GV%Rlay, Rcv(i,j,k), k_list, nz, wt, wt_p) + work_3d(i,j,k_list) = work_3d(i,j,k_list) + h(i,j,k)*wt + work_3d(i,j,k_list+1) = work_3d(i,j,k_list+1) + h(i,j,k)*wt_p + enddo ; enddo + enddo + + call post_data(CS%id_h_Rlay, work_3d, CS%diag) + endif + + if (CS%id_uh_Rlay > 0) then + ! Calculate zonal transports in potential density coordinates [H L2 T-1 ~> m3 s-1 or kg s-1]. + k_list = nz/2 + !$OMP parallel do default(shared) private(wt,wt_p) firstprivate(k_list) + do j=js,je + do k=1,nkmb ; do I=Isq,Ieq + uh_tmp(I,j,k) = 0.0 + enddo ; enddo + do k=nkmb+1,nz ; do I=Isq,Ieq + uh_tmp(I,j,k) = uh(I,j,k) + enddo ; enddo + k_list = nz/2 + do k=1,nkmb ; do I=Isq,Ieq + call find_weights(GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i+1,j,k)), k_list, nz, wt, wt_p) + uh_tmp(I,j,k_list) = uh_tmp(I,j,k_list) + uh(I,j,k)*wt + uh_tmp(I,j,k_list+1) = uh_tmp(I,j,k_list+1) + uh(I,j,k)*wt_p + enddo ; enddo + enddo + + call post_data(CS%id_uh_Rlay, uh_tmp, CS%diag) + endif + + if (CS%id_vh_Rlay > 0) then + ! Calculate meridional transports in potential density coordinates [H L2 T-1 ~> m3 s-1 or kg s-1]. + k_list = nz/2 + !$OMP parallel do default(shared) private(wt,wt_p) firstprivate(k_list) + do J=Jsq,Jeq + do k=1,nkmb ; do i=is,ie + vh_tmp(i,J,k) = 0.0 + enddo ; enddo + do k=nkmb+1,nz ; do i=is,ie + vh_tmp(i,J,k) = vh(i,J,k) + enddo ; enddo + do k=1,nkmb ; do i=is,ie + call find_weights(GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i,j+1,k)), k_list, nz, wt, wt_p) + vh_tmp(i,J,k_list) = vh_tmp(i,J,k_list) + vh(i,J,k)*wt + vh_tmp(i,J,k_list+1) = vh_tmp(i,J,k_list+1) + vh(i,J,k)*wt_p + enddo ; enddo + enddo + + call post_data(CS%id_vh_Rlay, vh_tmp, CS%diag) + endif + + if ((CS%id_uhGM_Rlay > 0) .and. associated(CDp%uhGM)) then + ! Calculate zonal Gent-McWilliams transports in potential density + ! coordinates [H L2 T-1 ~> m3 s-1 or kg s-1]. + k_list = nz/2 + !$OMP parallel do default(shared) private(wt,wt_p) firstprivate(k_list) + do j=js,je + do k=1,nkmb ; do I=Isq,Ieq + uh_tmp(I,j,k) = 0.0 + enddo ; enddo + do k=nkmb+1,nz ; do I=Isq,Ieq + uh_tmp(I,j,k) = CDp%uhGM(I,j,k) + enddo ; enddo + do k=1,nkmb ; do I=Isq,Ieq + call find_weights(GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i+1,j,k)), k_list, nz, wt, wt_p) + uh_tmp(I,j,k_list) = uh_tmp(I,j,k_list) + CDp%uhGM(I,j,k)*wt + uh_tmp(I,j,k_list+1) = uh_tmp(I,j,k_list+1) + CDp%uhGM(I,j,k)*wt_p + enddo ; enddo + enddo + + if (CS%id_uhGM_Rlay > 0) call post_data(CS%id_uhGM_Rlay, uh_tmp, CS%diag) + endif + + if ((CS%id_vhGM_Rlay > 0) .and. associated(CDp%vhGM)) then + ! Calculate meridional Gent-McWilliams transports in potential density + ! coordinates [H L2 T-1 ~> m3 s-1 or kg s-1]. + k_list = nz/2 + !$OMP parallel do default(shared) private(wt,wt_p) firstprivate(k_list) + do J=Jsq,Jeq + do k=1,nkmb ; do i=is,ie + vh_tmp(i,J,k) = 0.0 + enddo ; enddo + do k=nkmb+1,nz ; do i=is,ie + vh_tmp(i,J,k) = CDp%vhGM(i,J,k) + enddo ; enddo + do k=1,nkmb ; do i=is,ie + call find_weights(GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i,j+1,k)), k_list, nz, wt, wt_p) + vh_tmp(i,J,k_list) = vh_tmp(i,J,k_list) + CDp%vhGM(i,J,k)*wt + vh_tmp(i,J,k_list+1) = vh_tmp(i,J,k_list+1) + CDp%vhGM(i,J,k)*wt_p + enddo ; enddo + enddo + + if (CS%id_vhGM_Rlay > 0) call post_data(CS%id_vhGM_Rlay, vh_tmp, CS%diag) + endif + endif + + if (associated(tv%eqn_of_state)) then + EOSdom(:) = EOS_domain(G%HI) + if (CS%id_rhopot0 > 0) then + pressure_1d(:) = 0. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & + tv%eqn_of_state, EOSdom) + enddo ; enddo + if (CS%id_rhopot0 > 0) call post_data(CS%id_rhopot0, Rcv, CS%diag) + endif + if (CS%id_rhopot2 > 0) then + pressure_1d(:) = 2.0e7*US%Pa_to_RL2_T2 ! 2000 dbars + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & + tv%eqn_of_state, EOSdom) + enddo ; enddo + if (CS%id_rhopot2 > 0) call post_data(CS%id_rhopot2, Rcv, CS%diag) + endif + if (CS%id_rhoinsitu > 0) then + !$OMP parallel do default(shared) private(pressure_1d) + do j=js,je + pressure_1d(:) = 0. ! Start at p=0 Pa at surface + do k=1,nz + pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure in middle of layer k + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & + tv%eqn_of_state, EOSdom) + pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure at bottom of layer k + enddo + enddo + if (CS%id_rhoinsitu > 0) call post_data(CS%id_rhoinsitu, Rcv, CS%diag) + endif + + if (CS%id_drho_dT > 0 .or. CS%id_drho_dS > 0) then + !$OMP parallel do default(shared) private(pressure_1d) + do j=js,je + pressure_1d(:) = 0. ! Start at p=0 Pa at surface + do k=1,nz + pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure in middle of layer k + ! To avoid storing more arrays, put drho_dT into Rcv, and drho_dS into work3d + call calculate_density_derivs(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, & + Rcv(:,j,k), work_3d(:,j,k), tv%eqn_of_state, EOSdom) + pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure at bottom of layer k + enddo + enddo + if (CS%id_drho_dT > 0) call post_data(CS%id_drho_dT, Rcv, CS%diag) + if (CS%id_drho_dS > 0) call post_data(CS%id_drho_dS, work_3d, CS%diag) + endif + endif + + if ((CS%id_cg1>0) .or. (CS%id_Rd1>0) .or. (CS%id_cfl_cg1>0) .or. & + (CS%id_cfl_cg1_x>0) .or. (CS%id_cfl_cg1_y>0)) then + call wave_speed(h, tv, G, GV, US, cg1, CS%wave_speed) + if (CS%id_cg1>0) call post_data(CS%id_cg1, cg1, CS%diag) + if (CS%id_Rd1>0) then + !$OMP parallel do default(shared) private(f2_h,mag_beta) + do j=js,je ; do i=is,ie + ! Blend the equatorial deformation radius with the standard one. + f2_h = absurdly_small_freq2 + 0.25 * & + ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) + mag_beta = sqrt(0.5 * ( & + (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & + ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & + (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & + ((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2) )) + Rd1(i,j) = cg1(i,j) / sqrt(f2_h + cg1(i,j) * mag_beta) + + enddo ; enddo + call post_data(CS%id_Rd1, Rd1, CS%diag) + endif + if (CS%id_cfl_cg1>0) then + do j=js,je ; do i=is,ie + CFL_cg1(i,j) = (dt*cg1(i,j)) * (G%IdxT(i,j) + G%IdyT(i,j)) + enddo ; enddo + call post_data(CS%id_cfl_cg1, CFL_cg1, CS%diag) + endif + if (CS%id_cfl_cg1_x>0) then + do j=js,je ; do i=is,ie + CFL_cg1(i,j) = (dt*cg1(i,j)) * G%IdxT(i,j) + enddo ; enddo + call post_data(CS%id_cfl_cg1_x, CFL_cg1, CS%diag) + endif + if (CS%id_cfl_cg1_y>0) then + do j=js,je ; do i=is,ie + CFL_cg1(i,j) = (dt*cg1(i,j)) * G%IdyT(i,j) + enddo ; enddo + call post_data(CS%id_cfl_cg1_y, CFL_cg1, CS%diag) + endif + endif + if ((CS%id_cg_ebt>0) .or. (CS%id_Rd_ebt>0) .or. (CS%id_p_ebt>0)) then + if (CS%id_p_ebt>0) then + ! Here work_3d is used for the equivalent barotropic modal structure [nondim]. + work_3d(:,:,:) = 0.0 + call wave_speed(h, tv, G, GV, US, cg1, CS%wave_speed, use_ebt_mode=.true., & + mono_N2_column_fraction=CS%mono_N2_column_fraction, & + mono_N2_depth=CS%mono_N2_depth, modal_structure=work_3d) + call post_data(CS%id_p_ebt, work_3d, CS%diag) + else + call wave_speed(h, tv, G, GV, US, cg1, CS%wave_speed, use_ebt_mode=.true., & + mono_N2_column_fraction=CS%mono_N2_column_fraction, & + mono_N2_depth=CS%mono_N2_depth) + endif + if (CS%id_cg_ebt>0) call post_data(CS%id_cg_ebt, cg1, CS%diag) + if (CS%id_Rd_ebt>0) then + !$OMP parallel do default(shared) private(f2_h,mag_beta) + do j=js,je ; do i=is,ie + ! Blend the equatorial deformation radius with the standard one. + f2_h = absurdly_small_freq2 + 0.25 * & + ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) + mag_beta = sqrt(0.5 * ( & + (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & + ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & + (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & + ((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2) )) + Rd1(i,j) = cg1(i,j) / sqrt(f2_h + cg1(i,j) * mag_beta) + + enddo ; enddo + call post_data(CS%id_Rd_ebt, Rd1, CS%diag) + endif + endif + +end subroutine calculate_diagnostic_fields + +!> This subroutine finds the location of R_in in an increasing ordered +!! list, Rlist, returning as k the element such that +!! Rlist(k) <= R_in < Rlist(k+1), and where wt and wt_p are the linear +!! weights that should be assigned to elements k and k+1. +subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) + real, dimension(:), & + intent(in) :: Rlist !< The list of target densities [R ~> kg m-3] + real, intent(in) :: R_in !< The density being inserted into Rlist [R ~> kg m-3] + integer, intent(inout) :: k !< The value of k such that Rlist(k) <= R_in < Rlist(k+1) + !! The input value is a first guess + integer, intent(in) :: nz !< The number of layers in Rlist + real, intent(out) :: wt !< The weight of layer k for interpolation [nondim] + real, intent(out) :: wt_p !< The weight of layer k+1 for interpolation [nondim] + + ! This subroutine finds location of R_in in an increasing ordered + ! list, Rlist, returning as k the element such that + ! Rlist(k) <= R_in < Rlist(k+1), and where wt and wt_p are the linear + ! weights that should be assigned to elements k and k+1. + + integer :: k_upper, k_lower, k_new, inc + + ! First, bracket the desired point. + if ((k < 1) .or. (k > nz)) k = nz/2 + + k_upper = k ; k_lower = k ; inc = 1 + if (R_in < Rlist(k)) then + do + k_lower = max(k_lower-inc, 1) + if ((k_lower == 1) .or. (R_in >= Rlist(k_lower))) exit + k_upper = k_lower + inc = inc*2 + enddo + else + do + k_upper = min(k_upper+inc, nz) + if ((k_upper == nz) .or. (R_in < Rlist(k_upper))) exit + k_lower = k_upper + inc = inc*2 + enddo + endif + + if ((k_lower == 1) .and. (R_in <= Rlist(k_lower))) then + k = 1 ; wt = 1.0 ; wt_p = 0.0 + elseif ((k_upper == nz) .and. (R_in >= Rlist(k_upper))) then + k = nz-1 ; wt = 0.0 ; wt_p = 1.0 + else + do + if (k_upper <= k_lower+1) exit + k_new = (k_upper + k_lower) / 2 + if (R_in < Rlist(k_new)) then + k_upper = k_new + else + k_lower = k_new + endif + enddo + +! Uncomment this as a code check +! if ((R_in < Rlist(k_lower)) .or. (R_in >= Rlist(k_upper)) .or. (k_upper-k_lower /= 1)) & +! write (*,*) "Error: ",R_in," is not between R(",k_lower,") = ", & +! Rlist(k_lower)," and R(",k_upper,") = ",Rlist(k_upper),"." + k = k_lower + wt = (Rlist(k_upper) - R_in) / (Rlist(k_upper) - Rlist(k_lower)) + wt_p = 1.0 - wt + + endif + +end subroutine find_weights + +!> This subroutine calculates vertical integrals of several tracers, along +!! with the mass-weight of these tracers, the total column mass, and the +!! carefully calculated column height. +subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(:,:), pointer :: p_surf !< A pointer to the surface pressure [R L2 T-2 ~> Pa]. + !! If p_surf is not associated, it is the same + !! as setting the surface pressure to 0. + type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a + !! previous call to diagnostics_init. + + real, dimension(SZI_(G),SZJ_(G)) :: & + z_top, & ! Height of the top of a layer or the ocean [Z ~> m]. + z_bot, & ! Height of the bottom of a layer (for id_mass) or the + ! (positive) depth of the ocean (for id_col_ht) [Z ~> m]. + mass, & ! integrated mass of the water column [R Z ~> kg m-2]. For + ! non-Boussinesq models this is rho*dz. For Boussinesq + ! models, this is either the integral of in-situ density + ! (rho*dz for col_mass) or reference density (Rho_0*dz for mass_wt). + btm_pres,&! The pressure at the ocean bottom, or CMIP variable 'pbo'. + ! This is the column mass multiplied by gravity plus the pressure + ! at the ocean surface [R L2 T-2 ~> Pa]. + dpress, & ! Change in hydrostatic pressure across a layer [R L2 T-2 ~> Pa]. + tr_int ! vertical integral of a tracer times density, + ! (Rho_0 in a Boussinesq model) [Conc R Z ~> Conc kg m-2]. + real :: IG_Earth ! Inverse of gravitational acceleration [T2 Z L-2 ~> s2 m-1]. + + integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (CS%id_mass_wt > 0) then + do j=js,je ; do i=is,ie ; mass(i,j) = 0.0 ; enddo ; enddo + do k=1,nz ; do j=js,je ; do i=is,ie + mass(i,j) = mass(i,j) + GV%H_to_RZ*h(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_mass_wt, mass, CS%diag) + endif + + if (CS%id_temp_int > 0) then + do j=js,je ; do i=is,ie ; tr_int(i,j) = 0.0 ; enddo ; enddo + do k=1,nz ; do j=js,je ; do i=is,ie + tr_int(i,j) = tr_int(i,j) + (GV%H_to_RZ*h(i,j,k))*tv%T(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_temp_int, tr_int, CS%diag) + endif + + if (CS%id_salt_int > 0) then + do j=js,je ; do i=is,ie ; tr_int(i,j) = 0.0 ; enddo ; enddo + do k=1,nz ; do j=js,je ; do i=is,ie + tr_int(i,j) = tr_int(i,j) + (GV%H_to_RZ*h(i,j,k))*tv%S(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_salt_int, tr_int, CS%diag) + endif + + if (CS%id_col_ht > 0) then + call find_eta(h, tv, G, GV, US, z_top) + do j=js,je ; do i=is,ie + z_bot(i,j) = z_top(i,j) + G%bathyT(i,j) + enddo ; enddo + call post_data(CS%id_col_ht, z_bot, CS%diag) + endif + + ! NOTE: int_density_z expects z_top and z_btm values from [ij]sq to [ij]eq+1 + if (CS%id_col_mass > 0 .or. CS%id_pbo > 0) then + do j=js,je ; do i=is,ie ; mass(i,j) = 0.0 ; enddo ; enddo + if (GV%Boussinesq) then + if (associated(tv%eqn_of_state)) then + IG_Earth = 1.0 / GV%g_Earth + do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1 + z_bot(i,j) = 0.0 + enddo ; enddo + do k=1,nz + do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1 + z_top(i,j) = z_bot(i,j) + z_bot(i,j) = z_top(i,j) - GV%H_to_Z*h(i,j,k) + enddo ; enddo + call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, & + G%HI, tv%eqn_of_state, US, dpress) + do j=js,je ; do i=is,ie + mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth + enddo ; enddo + enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + mass(i,j) = mass(i,j) + (GV%H_to_Z*GV%Rlay(k))*h(i,j,k) + enddo ; enddo ; enddo + endif + else + do k=1,nz ; do j=js,je ; do i=is,ie + mass(i,j) = mass(i,j) + GV%H_to_RZ*h(i,j,k) + enddo ; enddo ; enddo + endif + if (CS%id_col_mass > 0) then + call post_data(CS%id_col_mass, mass, CS%diag) + endif + if (CS%id_pbo > 0) then + do j=js,je ; do i=is,ie ; btm_pres(i,j) = 0.0 ; enddo ; enddo + ! 'pbo' is defined as the sea water pressure at the sea floor + ! pbo = (mass * g) + p_surf + ! where p_surf is the sea water pressure at sea water surface. + do j=js,je ; do i=is,ie + btm_pres(i,j) = GV%g_Earth * mass(i,j) + if (associated(p_surf)) then + btm_pres(i,j) = btm_pres(i,j) + p_surf(i,j) + endif + enddo ; enddo + call post_data(CS%id_pbo, btm_pres, CS%diag) + endif + endif + +end subroutine calculate_vertical_integrals + +!> This subroutine calculates terms in the mechanical energy budget. +subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: uh !< Transport through zonal faces=u*h*dy, + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vh !< Transport through merid faces=v*h*dx, + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + type(accel_diag_ptrs), intent(in) :: ADp !< Structure pointing to accelerations in momentum equation. + type(cont_diag_ptrs), intent(in) :: CDp !< Structure pointing to terms in continuity equations. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a previous call to + !! diagnostics_init. + + ! Local variables + real :: KE(SZI_(G),SZJ_(G),SZK_(GV)) ! Kinetic energy per unit mass [L2 T-2 ~> m2 s-2] + real :: KE_term(SZI_(G),SZJ_(G),SZK_(GV)) ! A term in the kinetic energy budget + ! [H L2 T-3 ~> m3 s-3 or W m-2] + real :: KE_u(SZIB_(G),SZJ_(G)) ! The area integral of a KE term in a layer at u-points + ! [H L4 T-3 ~> m5 s-3 or W] + real :: KE_v(SZI_(G),SZJB_(G)) ! The area integral of a KE term in a layer at v-points + ! [H L4 T-3 ~> m5 s-3 or W] + real :: KE_h(SZI_(G),SZJ_(G)) ! A KE term contribution at tracer points + ! [H L2 T-3 ~> m3 s-3 or W m-2] + + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (.not.(CS%KE_term_on .or. (CS%id_KE > 0))) return + + do j=js-1,je ; do i=is-1,ie + KE_u(I,j) = 0.0 ; KE_v(i,J) = 0.0 + enddo ; enddo + + do k=1,nz ; do j=js,je ; do i=is,ie + KE(i,j,k) = ((u(I,j,k) * u(I,j,k) + u(I-1,j,k) * u(I-1,j,k)) & + + (v(i,J,k) * v(i,J,k) + v(i,J-1,k) * v(i,J-1,k))) * 0.25 + enddo ; enddo ; enddo + if (CS%id_KE > 0) call post_data(CS%id_KE, KE, CS%diag) + + if (CS%KE_term_on .and. .not.G%symmetric) then + call create_group_pass(CS%pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) + endif + + if (CS%id_dKEdt > 0) then + ! Calculate the time derivative of the layer KE [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * CS%du_dt(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * CS%dv_dt(i,J,k) + enddo ; enddo + do j=js,je ; do i=is,ie + KE_h(i,j) = KE(i,j,k) * CS%dh_dt(i,j,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & + * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + enddo ; enddo + enddo + call post_data(CS%id_dKEdt, KE_term, CS%diag) + endif + + if (CS%id_PE_to_KE > 0) then + ! Calculate the potential energy to KE term [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%PFu(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%PFv(i,J,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + enddo ; enddo + enddo + if (CS%id_PE_to_KE > 0) call post_data(CS%id_PE_to_KE, KE_term, CS%diag) + endif + + if (CS%id_KE_BT > 0) then + ! Calculate the barotropic contribution to KE term [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%u_accel_bt(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%v_accel_bt(i,J,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + enddo ; enddo + enddo + call post_data(CS%id_KE_BT, KE_term, CS%diag) + endif + + if (CS%id_KE_Coradv > 0) then + ! Calculate the KE source from the combined Coriolis and advection terms [H L2 T-3 ~> m3 s-3 or W m-2]. + ! The Coriolis source should be zero, but is not due to truncation errors. There should be + ! near-cancellation of the global integral of this spurious Coriolis source. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%CAu(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%CAv(i,J,k) + enddo ; enddo + do j=js,je ; do i=is,ie + KE_h(i,j) = -KE(i,j,k) * G%IareaT(i,j) & + * (uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & + * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + enddo ; enddo + enddo + call post_data(CS%id_KE_Coradv, KE_term, CS%diag) + endif + + if (CS%id_KE_adv > 0) then + ! Calculate the KE source from along-layer advection [H L2 T-3 ~> m3 s-3 or W m-2]. + ! NOTE: All terms in KE_adv are multiplied by -1, which can easily produce + ! negative zeros and may signal a reproducibility issue over land. + ! We resolve this by re-initializing and only evaluating over water points. + KE_u(:,:) = 0. ; KE_v(:,:) = 0. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + if (G%mask2dCu(i,j) /= 0.) & + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%gradKEu(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + if (G%mask2dCv(i,j) /= 0.) & + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%gradKEv(i,J,k) + enddo ; enddo + do j=js,je ; do i=is,ie + KE_h(i,j) = -KE(i,j,k) * G%IareaT(i,j) & + * (uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & + * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + enddo ; enddo + enddo + call post_data(CS%id_KE_adv, KE_term, CS%diag) + endif + + if (CS%id_KE_visc > 0) then + ! Calculate the KE source from vertical viscosity [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_visc(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%dv_dt_visc(i,J,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + enddo ; enddo + enddo + call post_data(CS%id_KE_visc, KE_term, CS%diag) + endif + + if (CS%id_KE_visc_gl90 > 0) then + ! Calculate the KE source from GL90 vertical viscosity [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_visc_gl90(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%dv_dt_visc_gl90(i,J,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) + enddo ; enddo + enddo + call post_data(CS%id_KE_visc_gl90, KE_term, CS%diag) + endif + + if (CS%id_KE_stress > 0) then + ! Calculate the KE source from surface stress (included in KE_visc) [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_str(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%dv_dt_str(i,J,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) * & + ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) + enddo ; enddo + enddo + call post_data(CS%id_KE_stress, KE_term, CS%diag) + endif + + if (CS%id_KE_horvisc > 0) then + ! Calculate the KE source from horizontal viscosity [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%diffu(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%diffv(i,J,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + enddo ; enddo + enddo + call post_data(CS%id_KE_horvisc, KE_term, CS%diag) + endif + + if (CS%id_KE_dia > 0) then + ! Calculate the KE source from diapycnal diffusion [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_dia(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%dv_dt_dia(i,J,k) + enddo ; enddo + do j=js,je ; do i=is,ie + KE_h(i,j) = KE(i,j,k) * (CDp%diapyc_vel(i,j,k) - CDp%diapyc_vel(i,j,k+1)) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & + * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + enddo ; enddo + enddo + call post_data(CS%id_KE_dia, KE_term, CS%diag) + endif + +end subroutine calculate_energy_diagnostics + +!> This subroutine registers fields to calculate a diagnostic time derivative. +subroutine register_time_deriv(lb, f_ptr, deriv_ptr, CS) + integer, intent(in), dimension(3) :: lb !< Lower index bound of f_ptr + real, dimension(lb(1):,lb(2):,:), target :: f_ptr + !< Time derivative operand, in arbitrary units [A ~> a] + real, dimension(lb(1):,lb(2):,:), target :: deriv_ptr + !< Time derivative of f_ptr, in units derived from + !! the arbitrary units of f_ptr [A T-1 ~> a s-1] + type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by previous call to + !! diagnostics_init. + + ! This subroutine registers fields to calculate a diagnostic time derivative. + ! NOTE: Lower bound is required for grid indexing in calculate_derivs(). + ! We assume that the vertical axis is 1-indexed. + + integer :: m !< New index of deriv_ptr in CS%deriv + integer :: ub(3) !< Upper index bound of f_ptr, based on shape. + + if (.not.CS%initialized) call MOM_error(FATAL, & + "register_time_deriv: Module must be initialized before it is used.") + + if (CS%num_time_deriv >= MAX_FIELDS_) then + call MOM_error(WARNING,"MOM_diagnostics: Attempted to register more than " // & + "MAX_FIELDS_ diagnostic time derivatives via register_time_deriv.") + return + endif + + m = CS%num_time_deriv+1 ; CS%num_time_deriv = m + + ub(:) = lb(:) + shape(f_ptr) - 1 + + CS%nlay(m) = size(f_ptr, 3) + CS%deriv(m)%p => deriv_ptr + allocate(CS%prev_val(m)%p(lb(1):ub(1), lb(2):ub(2), CS%nlay(m))) + + CS%var_ptr(m)%p => f_ptr + CS%prev_val(m)%p(:,:,:) = f_ptr(:,:,:) + +end subroutine register_time_deriv + +!> This subroutine calculates all registered time derivatives. +subroutine calculate_derivs(dt, G, CS) + real, intent(in) :: dt !< The time interval over which differences occur [T ~> s]. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by previous call to + !! diagnostics_init. + +! This subroutine calculates all registered time derivatives. + real :: Idt ! The inverse timestep [T-1 ~> s-1] + integer :: i, j, k, m + + if (dt > 0.0) then ; Idt = 1.0/dt + else ; return ; endif + + ! Because the field is unknown, its grid index bounds are also unknown. + ! Additionally, two of the fields (dudt, dvdt) require calculation of spatial + ! derivatives when computing d(KE)/dt. This raises issues in non-symmetric + ! mode, where the symmetric boundaries (west, south) may not be updated. + + ! For this reason, we explicitly loop from isc-1:iec and jsc-1:jec, in order + ! to force boundary value updates, even though it may not be strictly valid + ! for all fields. Note this assumes a halo, and that it has been updated. + + do m=1,CS%num_time_deriv + do k=1,CS%nlay(m) ; do j=G%jsc-1,G%jec ; do i=G%isc-1,G%iec + CS%deriv(m)%p(i,j,k) = (CS%var_ptr(m)%p(i,j,k) - CS%prev_val(m)%p(i,j,k)) * Idt + CS%prev_val(m)%p(i,j,k) = CS%var_ptr(m)%p(i,j,k) + enddo ; enddo ; enddo + enddo + +end subroutine calculate_derivs + +!> This routine posts diagnostics of various dynamic ocean surface quantities, +!! including velocities, speed and sea surface height, at the time the ocean +!! state is reported back to the caller +subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh) + type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: ssh !< Time mean surface height without corrections + !! for ice displacement [Z ~> m] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: speed ! The surface speed [L T-1 ~> m s-1] + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if (IDs%id_ssh > 0) & + call post_data(IDs%id_ssh, ssh, diag, mask=G%mask2dT) + + if (IDs%id_ssu > 0) & + call post_data(IDs%id_ssu, sfc_state%u, diag, mask=G%mask2dCu) + + if (IDs%id_ssv > 0) & + call post_data(IDs%id_ssv, sfc_state%v, diag, mask=G%mask2dCv) + + if (IDs%id_speed > 0) then + do j=js,je ; do i=is,ie + speed(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & + 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2)) + enddo ; enddo + call post_data(IDs%id_speed, speed, diag, mask=G%mask2dT) + endif + +end subroutine post_surface_dyn_diags + + +!> This routine posts diagnostics of various ocean surface and integrated +!! quantities at the time the ocean state is reported back to the caller +subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv, & + ssh, ssh_ibc) + type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + 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(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + real, intent(in) :: dt_int !< total time step associated with these diagnostics [T ~> s]. + type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh !< Time mean surface height without corrections + !! for ice displacement [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh_ibc !< Time mean surface height with corrections + !! for ice displacement and the inverse barometer [Z ~> m] + + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array [various] + real, dimension(SZI_(G),SZJ_(G)) :: & + zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh [Z ~> m] + real :: I_time_int ! The inverse of the time interval [T-1 ~> s-1]. + real :: zos_area_mean ! Global area mean sea surface height [Z ~> m] + real :: volo ! Total volume of the ocean [m3] + real :: ssh_ga ! Global ocean area weighted mean sea seaface height [Z ~> m] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + ! area mean SSH + if (IDs%id_ssh_ga > 0) then + ssh_ga = global_area_mean(ssh, G, tmp_scale=US%Z_to_m) + call post_data(IDs%id_ssh_ga, ssh_ga, diag) + endif + + ! post the dynamic sea level, zos, and zossq. + ! zos is ave_ssh with sea ice inverse barometer removed, and with zero global area mean. + if (IDs%id_zos > 0 .or. IDs%id_zossq > 0) then + zos_area_mean = global_area_mean(ssh_ibc, G, tmp_scale=US%Z_to_m) + do j=js,je ; do i=is,ie + zos(i,j) = ssh_ibc(i,j) - G%mask2dT(i,j)*zos_area_mean + enddo ; enddo + if (IDs%id_zos > 0) call post_data(IDs%id_zos, zos, diag, mask=G%mask2dT) + if (IDs%id_zossq > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = zos(i,j)*zos(i,j) + enddo ; enddo + call post_data(IDs%id_zossq, work_2d, diag, mask=G%mask2dT) + endif + endif + + ! post total volume of the liquid ocean + if (IDs%id_volo > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = G%mask2dT(i,j) * (ssh(i,j) + G%bathyT(i,j)) + enddo ; enddo + volo = global_area_integral(work_2d, G, scale=US%Z_to_m) + call post_data(IDs%id_volo, volo, diag) + endif + + ! Use Adcroft's rule of reciprocals; it does the right thing here. + I_time_int = 0.0 ; if (dt_int > 0.0) I_time_int = 1.0 / dt_int + + ! post time-averaged rate of frazil formation + if (associated(tv%frazil) .and. (IDs%id_fraz > 0)) then + do j=js,je ; do i=is,ie + work_2d(i,j) = tv%frazil(i,j) * I_time_int + enddo ; enddo + call post_data(IDs%id_fraz, work_2d, diag, mask=G%mask2dT) + endif + + ! post time-averaged salt deficit + if (associated(tv%salt_deficit) .and. (IDs%id_salt_deficit > 0)) then + do j=js,je ; do i=is,ie + work_2d(i,j) = tv%salt_deficit(i,j) * I_time_int + enddo ; enddo + call post_data(IDs%id_salt_deficit, work_2d, diag, mask=G%mask2dT) + endif + + ! post temperature of P-E+R + if (associated(tv%TempxPmE) .and. (IDs%id_Heat_PmE > 0)) then + do j=js,je ; do i=is,ie + work_2d(i,j) = tv%TempxPmE(i,j) * (tv%C_p * I_time_int) + enddo ; enddo + call post_data(IDs%id_Heat_PmE, work_2d, diag, mask=G%mask2dT) + endif + + ! post geothermal heating or internal heat source/sinks + if (associated(tv%internal_heat) .and. (IDs%id_intern_heat > 0)) then + do j=js,je ; do i=is,ie + work_2d(i,j) = tv%internal_heat(i,j) * (tv%C_p * I_time_int) + enddo ; enddo + call post_data(IDs%id_intern_heat, work_2d, diag, mask=G%mask2dT) + endif + + if (tv%T_is_conT) then + ! Internal T&S variables are conservative temperature & absolute salinity + if (IDs%id_sstcon > 0) call post_data(IDs%id_sstcon, sfc_state%SST, diag, mask=G%mask2dT) + ! Use TEOS-10 function calls convert T&S diagnostics from conservative temp + ! to potential temperature. + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + call cons_temp_to_pot_temp(sfc_state%SST(:,j), sfc_state%SSS(:,j), work_2d(:,j), tv%eqn_of_state, EOSdom) + enddo + if (IDs%id_sst > 0) call post_data(IDs%id_sst, work_2d, diag, mask=G%mask2dT) + else + ! Internal T&S variables are potential temperature & practical salinity + if (IDs%id_sst > 0) call post_data(IDs%id_sst, sfc_state%SST, diag, mask=G%mask2dT) + endif + + if (tv%S_is_absS) then + ! Internal T&S variables are conservative temperature & absolute salinity + if (IDs%id_sssabs > 0) call post_data(IDs%id_sssabs, sfc_state%SSS, diag, mask=G%mask2dT) + ! Use TEOS-10 function calls convert T&S diagnostics from absolute salinity + ! to practical salinity. + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + call abs_saln_to_prac_saln(sfc_state%SSS(:,j), work_2d(:,j), tv%eqn_of_state, EOSdom) + enddo + if (IDs%id_sss > 0) call post_data(IDs%id_sss, work_2d, diag, mask=G%mask2dT) + else + ! Internal T&S variables are potential temperature & practical salinity + if (IDs%id_sss > 0) call post_data(IDs%id_sss, sfc_state%SSS, diag, mask=G%mask2dT) + endif + + if (IDs%id_sst_sq > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = sfc_state%SST(i,j)*sfc_state%SST(i,j) + enddo ; enddo + call post_data(IDs%id_sst_sq, work_2d, diag, mask=G%mask2dT) + endif + if (IDs%id_sss_sq > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = sfc_state%SSS(i,j)*sfc_state%SSS(i,j) + enddo ; enddo + call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT) + endif + + call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) + +end subroutine post_surface_thermo_diags + + +!> This routine posts diagnostics of the transports, including the subgridscale +!! contributions. +subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dyn, & + diag, dt_trans, Reg) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uhtr !< Accumulated zonal thickness fluxes + !! used to advect tracers [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vhtr !< Accumulated meridional thickness fluxes + !! used to advect tracers [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< The updated layer thicknesses [H ~> m or kg m-2] + type(transport_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + type(diag_grid_storage), intent(inout) :: diag_pre_dyn !< Stored grids from before dynamics + type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output + real, intent(in) :: dt_trans !< total time step associated with the transports [T ~> s]. + type(tracer_registry_type), pointer :: Reg !< Pointer to the tracer registry + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G)) :: umo2d ! Diagnostics of integrated mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZI_(G),SZJB_(G)) :: vmo2d ! Diagnostics of integrated mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: umo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vmo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tend ! Change in layer thickness due to dynamics + ! [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: Idt ! The inverse of the time interval [T-1 ~> s-1] + real :: H_to_RZ_dt ! A conversion factor from accumulated transports to fluxes + ! [R Z H-1 T-1 ~> kg m-3 s-1 or s-1]. + integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + Idt = 1. / dt_trans + H_to_RZ_dt = GV%H_to_RZ * Idt + + call diag_save_grids(diag) + call diag_copy_storage_to_diag(diag, diag_pre_dyn) + + if (IDs%id_umo_2d > 0) then + umo2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=is-1,ie + umo2d(I,j) = umo2d(I,j) + uhtr(I,j,k) * H_to_RZ_dt + enddo ; enddo ; enddo + call post_data(IDs%id_umo_2d, umo2d, diag) + endif + if (IDs%id_umo > 0) then + ! Convert to kg/s. + do k=1,nz ; do j=js,je ; do I=is-1,ie + umo(I,j,k) = uhtr(I,j,k) * H_to_RZ_dt + enddo ; enddo ; enddo + call post_data(IDs%id_umo, umo, diag, alt_h=diag_pre_dyn%h_state) + endif + if (IDs%id_vmo_2d > 0) then + vmo2d(:,:) = 0.0 + do k=1,nz ; do J=js-1,je ; do i=is,ie + vmo2d(i,J) = vmo2d(i,J) + vhtr(i,J,k) * H_to_RZ_dt + enddo ; enddo ; enddo + call post_data(IDs%id_vmo_2d, vmo2d, diag) + endif + if (IDs%id_vmo > 0) then + ! Convert to kg/s. + do k=1,nz ; do J=js-1,je ; do i=is,ie + vmo(i,J,k) = vhtr(i,J,k) * H_to_RZ_dt + enddo ; enddo ; enddo + call post_data(IDs%id_vmo, vmo, diag, alt_h=diag_pre_dyn%h_state) + endif + + if (IDs%id_uhtr > 0) call post_data(IDs%id_uhtr, uhtr, diag, alt_h=diag_pre_dyn%h_state) + if (IDs%id_vhtr > 0) call post_data(IDs%id_vhtr, vhtr, diag, alt_h=diag_pre_dyn%h_state) + if (IDs%id_dynamics_h > 0) call post_data(IDs%id_dynamics_h, diag_pre_dyn%h_state, diag, & + alt_h=diag_pre_dyn%h_state) + ! Post the change in thicknesses + if (IDs%id_dynamics_h_tendency > 0) then + h_tend(:,:,:) = 0. + do k=1,nz ; do j=js,je ; do i=is,ie + h_tend(i,j,k) = (h(i,j,k) - diag_pre_dyn%h_state(i,j,k))*Idt + enddo ; enddo ; enddo + call post_data(IDs%id_dynamics_h_tendency, h_tend, diag, alt_h=diag_pre_dyn%h_state) + endif + + call post_tracer_transport_diagnostics(G, GV, Reg, diag_pre_dyn%h_state, diag) + + call diag_restore_grids(diag) + +end subroutine post_transport_diagnostics + +!> This subroutine registers various diagnostics and allocates space for fields +!! that other diagnostics depend upon. +subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag, CS, tv) + type(ocean_internal_state), intent(in) :: MIS !< For "MOM Internal State" a set of pointers to + !! the fields and accelerations that make up the + !! ocean's internal physical state. + type(accel_diag_ptrs), intent(inout) :: ADp !< Structure with pointers to momentum equation + !! terms. + type(cont_diag_ptrs), intent(inout) :: CDp !< Structure with pointers to continuity + !! equation terms. + type(time_type), intent(in) :: Time !< Current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(diag_ctrl), target, intent(inout) :: diag !< Structure to regulate diagnostic output. + type(diagnostics_CS), intent(inout) :: CS !< Diagnostic control struct + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + + ! Local variables + real :: wave_speed_min ! A floor in the first mode speed below which 0 is returned [L T-1 ~> m s-1] + real :: wave_speed_tol ! The fractional tolerance for finding the wave speeds [nondim] + real :: convert_H ! A conversion factor from internal thickness units to the appropriate + ! MKS units (m or kg m-2) for thicknesses depending on whether the + ! Boussinesq approximation is being made [m H-1 or kg m-2 H-1 ~> 1] + logical :: better_speed_est ! If true, use a more robust estimate of the first + ! mode wave speed as the starting point for iterations. + logical :: split ! True if using the barotropic-baroclinic split algorithm + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. + character(len=48) :: thickness_units, flux_units + logical :: use_temperature, adiabatic + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use + ! for remapping. Values below 20190101 recover the remapping + ! answers from 2018, while higher values use more robust + ! forms of the same remapping expressions. + + CS%initialized = .true. + + CS%diag => diag + use_temperature = associated(tv%T) + call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., do_not_log=.true.) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DIAG_EBT_MONO_N2_COLUMN_FRACTION", CS%mono_N2_column_fraction, & + "The lower fraction of water column over which N2 is limited as monotonic "// & + "for the purposes of calculating the equivalent barotropic wave speed.", & + units='nondim', default=0.) + call get_param(param_file, mdl, "DIAG_EBT_MONO_N2_DEPTH", CS%mono_N2_depth, & + "The depth below which N2 is limited as monotonic for the "// & + "purposes of calculating the equivalent barotropic wave speed.", & + units='m', scale=GV%m_to_H, default=-1.) + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & + "The fractional tolerance for finding the wave speeds.", & + units="nondim", default=0.001) + !### Set defaults so that wave_speed_min*wave_speed_tol >= 1e-9 m s-1 + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_MIN", wave_speed_min, & + "A floor in the first mode speed below which 0 used instead.", & + units="m s-1", default=0.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_BETTER_EST", better_speed_est, & + "If true, use a more robust estimate of the first mode wave speed as the "//& + "starting point for iterations.", default=.true.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) + + call get_param(param_file, mdl, "SPLIT", split, default=.true., do_not_log=.true.) + + thickness_units = get_thickness_units(GV) + flux_units = get_flux_units(GV) + convert_H = GV%H_to_MKS + + CS%id_masscello = register_diag_field('ocean_model', 'masscello', diag%axesTL, & + Time, 'Mass per unit area of liquid ocean grid cell', 'kg m-2', conversion=GV%H_to_kg_m2, & + standard_name='sea_water_mass_per_unit_area', v_extensive=.true.) + + CS%id_masso = register_scalar_field('ocean_model', 'masso', Time, & + diag, 'Mass of liquid ocean', 'kg', standard_name='sea_water_mass') + + CS%id_thkcello = register_diag_field('ocean_model', 'thkcello', diag%axesTL, Time, & + long_name='Cell Thickness', standard_name='cell_thickness', & + units='m', conversion=US%Z_to_m, v_extensive=.true.) + CS%id_h_pre_sync = register_diag_field('ocean_model', 'h_pre_sync', diag%axesTL, Time, & + long_name='Cell thickness from the previous timestep', & + units=thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) + + ! Note that CS%id_volcello would normally be registered here but because it is a "cell measure" and + ! must be registered first. We earlier stored the handle of volcello but need it here for posting + ! by this module. + CS%id_volcello = diag_get_volume_cell_measure_dm_id(diag) + + if (use_temperature) then + if (tv%T_is_conT) then + CS%id_Tpot = register_diag_field('ocean_model', 'temp', diag%axesTL, & + Time, 'Potential Temperature', 'degC', conversion=US%C_to_degC) + endif + if (tv%S_is_absS) then + CS%id_Sprac = register_diag_field('ocean_model', 'salt', diag%axesTL, & + Time, 'Salinity', 'psu', conversion=US%S_to_ppt) + endif + + CS%id_tob = register_diag_field('ocean_model','tob', diag%axesT1, Time, & + long_name='Sea Water Potential Temperature at Sea Floor', & + standard_name='sea_water_potential_temperature_at_sea_floor', & + units='degC', conversion=US%C_to_degC) + CS%id_sob = register_diag_field('ocean_model','sob',diag%axesT1, Time, & + long_name='Sea Water Salinity at Sea Floor', & + standard_name='sea_water_salinity_at_sea_floor', & + units='psu', conversion=US%S_to_ppt) + + CS%id_tosq = register_diag_field('ocean_model', 'tosq', diag%axesTL, & + Time, 'Square of Potential Temperature', 'degC2', conversion=US%C_to_degC**2, & + standard_name='Potential Temperature Squared') + CS%id_sosq = register_diag_field('ocean_model', 'sosq', diag%axesTL, & + Time, 'Square of Salinity', 'psu2', conversion=US%S_to_ppt**2, & + standard_name='Salinity Squared') + + CS%id_temp_layer_ave = register_diag_field('ocean_model', 'temp_layer_ave', & + diag%axesZL, Time, 'Layer Average Ocean Temperature', units='degC', conversion=US%C_to_degC) + CS%id_salt_layer_ave = register_diag_field('ocean_model', 'salt_layer_ave', & + diag%axesZL, Time, 'Layer Average Ocean Salinity', units='psu', conversion=US%S_to_ppt) + + CS%id_thetaoga = register_scalar_field('ocean_model', 'thetaoga', & + Time, diag, 'Global Mean Ocean Potential Temperature', units='degC', conversion=US%C_to_degC, & + standard_name='sea_water_potential_temperature') + CS%id_soga = register_scalar_field('ocean_model', 'soga', & + Time, diag, 'Global Mean Ocean Salinity', units='psu', conversion=US%S_to_ppt, & + standard_name='sea_water_salinity') + + CS%id_tosga = register_scalar_field('ocean_model', 'sst_global', Time, diag, & + long_name='Global Area Average Sea Surface Temperature', & + units='degC', conversion=US%C_to_degC, standard_name='sea_surface_temperature', & + cmor_field_name='tosga', cmor_standard_name='sea_surface_temperature', & + cmor_long_name='Sea Surface Temperature') + CS%id_sosga = register_scalar_field('ocean_model', 'sss_global', Time, diag, & + long_name='Global Area Average Sea Surface Salinity', & + units='psu', conversion=US%S_to_ppt, standard_name='sea_surface_salinity', & + cmor_field_name='sosga', cmor_standard_name='sea_surface_salinity', & + cmor_long_name='Sea Surface Salinity') + endif + + CS%id_u = register_diag_field('ocean_model', 'u', diag%axesCuL, Time, & + 'Zonal velocity', 'm s-1', conversion=US%L_T_to_m_s, cmor_field_name='uo', & + cmor_standard_name='sea_water_x_velocity', cmor_long_name='Sea Water X Velocity') + CS%id_v = register_diag_field('ocean_model', 'v', diag%axesCvL, Time, & + 'Meridional velocity', 'm s-1', conversion=US%L_T_to_m_s, cmor_field_name='vo', & + cmor_standard_name='sea_water_y_velocity', cmor_long_name='Sea Water Y Velocity') + CS%id_usq = register_diag_field('ocean_model', 'usq', diag%axesCuL, Time, & + 'Zonal velocity squared', 'm2 s-2', conversion=US%L_T_to_m_s**2) + CS%id_vsq = register_diag_field('ocean_model', 'vsq', diag%axesCvL, Time, & + 'Meridional velocity squared', 'm2 s-2', conversion=US%L_T_to_m_s**2) + CS%id_uv = register_diag_field('ocean_model', 'uv', diag%axesTL, Time, & + 'Product between zonal and meridional velocities at h-points', & + 'm2 s-2', conversion=US%L_T_to_m_s**2) + CS%id_h = register_diag_field('ocean_model', 'h', diag%axesTL, Time, & + 'Layer Thickness', thickness_units, v_extensive=.true., conversion=convert_H) + + CS%id_e = register_diag_field('ocean_model', 'e', diag%axesTi, Time, & + 'Interface Height Relative to Mean Sea Level', 'm', conversion=US%Z_to_m) + CS%id_e_D = register_diag_field('ocean_model', 'e_D', diag%axesTi, Time, & + 'Interface Height above the Seafloor', 'm', conversion=US%Z_to_m) + + CS%id_Rml = register_diag_field('ocean_model', 'Rml', diag%axesTL, Time, & + 'Mixed Layer Coordinate Potential Density', 'kg m-3', conversion=US%R_to_kg_m3) + + CS%id_Rcv = register_diag_field('ocean_model', 'Rho_cv', diag%axesTL, Time, & + 'Coordinate Potential Density', 'kg m-3', conversion=US%R_to_kg_m3) + + CS%id_rhopot0 = register_diag_field('ocean_model', 'rhopot0', diag%axesTL, Time, & + 'Potential density referenced to surface', 'kg m-3', conversion=US%R_to_kg_m3) + CS%id_rhopot2 = register_diag_field('ocean_model', 'rhopot2', diag%axesTL, Time, & + 'Potential density referenced to 2000 dbar', 'kg m-3', conversion=US%R_to_kg_m3) + CS%id_rhoinsitu = register_diag_field('ocean_model', 'rhoinsitu', diag%axesTL, Time, & + 'In situ density', 'kg m-3', conversion=US%R_to_kg_m3) + CS%id_drho_dT = register_diag_field('ocean_model', 'drho_dT', diag%axesTL, Time, & + 'Partial derivative of rhoinsitu with respect to temperature (alpha)', & + 'kg m-3 degC-1', conversion=US%R_to_kg_m3*US%degC_to_C) + CS%id_drho_dS = register_diag_field('ocean_model', 'drho_dS', diag%axesTL, Time, & + 'Partial derivative of rhoinsitu with respect to salinity (beta)', & + 'kg^2 g-1 m-3', conversion=US%R_to_kg_m3*US%ppt_to_S) + + CS%id_du_dt = register_diag_field('ocean_model', 'dudt', diag%axesCuL, Time, & + 'Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + + CS%id_dv_dt = register_diag_field('ocean_model', 'dvdt', diag%axesCvL, Time, & + 'Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + + CS%id_dh_dt = register_diag_field('ocean_model', 'dhdt', diag%axesTL, Time, & + 'Thickness tendency', trim(thickness_units)//" s-1", conversion=convert_H*US%s_to_T, v_extensive=.true.) + + !CS%id_hf_du_dt = register_diag_field('ocean_model', 'hf_dudt', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2, & + ! v_extensive=.true.) + + !CS%id_hf_dv_dt = register_diag_field('ocean_model', 'hf_dvdt', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2, & + ! v_extensive=.true.) + + CS%id_hf_du_dt_2d = register_diag_field('ocean_model', 'hf_dudt_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + + CS%id_hf_dv_dt_2d = register_diag_field('ocean_model', 'hf_dvdt_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + + CS%id_h_du_dt = register_diag_field('ocean_model', 'h_du_dt', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration', 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + + CS%id_h_dv_dt = register_diag_field('ocean_model', 'h_dv_dt', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration', 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + + ! layer thickness variables + !if (GV%nk_rho_varies > 0) then + CS%id_h_Rlay = register_diag_field('ocean_model', 'h_rho', diag%axesTL, Time, & + 'Layer thicknesses in pure potential density coordinates', & + thickness_units, conversion=convert_H) + + CS%id_uh_Rlay = register_diag_field('ocean_model', 'uh_rho', diag%axesCuL, Time, & + 'Zonal volume transport in pure potential density coordinates', & + flux_units, conversion=US%L_to_m**2*US%s_to_T*convert_H) + + CS%id_vh_Rlay = register_diag_field('ocean_model', 'vh_rho', diag%axesCvL, Time, & + 'Meridional volume transport in pure potential density coordinates', & + flux_units, conversion=US%L_to_m**2*US%s_to_T*convert_H) + + CS%id_uhGM_Rlay = register_diag_field('ocean_model', 'uhGM_rho', diag%axesCuL, Time, & + 'Zonal volume transport due to interface height diffusion in pure potential '//& + 'density coordinates', flux_units, conversion=US%L_to_m**2*US%s_to_T*convert_H) + + CS%id_vhGM_Rlay = register_diag_field('ocean_model', 'vhGM_rho', diag%axesCvL, Time, & + 'Meridional volume transport due to interface height diffusion in pure potential '//& + 'density coordinates', flux_units, conversion=US%L_to_m**2*US%s_to_T*convert_H) + !endif + + + ! terms in the kinetic energy budget + CS%id_KE = register_diag_field('ocean_model', 'KE', diag%axesTL, Time, & + 'Layer kinetic energy per unit mass', & + 'm2 s-2', conversion=US%L_T_to_m_s**2) + CS%id_dKEdt = register_diag_field('ocean_model', 'dKE_dt', diag%axesTL, Time, & + 'Kinetic Energy Tendency of Layer', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_PE_to_KE = register_diag_field('ocean_model', 'PE_to_KE', diag%axesTL, Time, & + 'Potential to Kinetic Energy Conversion of Layer', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + if (split) then + CS%id_KE_BT = register_diag_field('ocean_model', 'KE_BT', diag%axesTL, Time, & + 'Barotropic contribution to Kinetic Energy', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + endif + CS%id_KE_Coradv = register_diag_field('ocean_model', 'KE_Coradv', diag%axesTL, Time, & + 'Kinetic Energy Source from Coriolis and Advection', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_KE_adv = register_diag_field('ocean_model', 'KE_adv', diag%axesTL, Time, & + 'Kinetic Energy Source from Advection', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_KE_visc = register_diag_field('ocean_model', 'KE_visc', diag%axesTL, Time, & + 'Kinetic Energy Source from Vertical Viscosity and Stresses', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_KE_visc_gl90 = register_diag_field('ocean_model', 'KE_visc_gl90', diag%axesTL, Time, & + 'Kinetic Energy Source from GL90 Vertical Viscosity', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_KE_stress = register_diag_field('ocean_model', 'KE_stress', diag%axesTL, Time, & + 'Kinetic Energy Source from Surface Stresses or Body Wind Stress', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_KE_horvisc = register_diag_field('ocean_model', 'KE_horvisc', diag%axesTL, Time, & + 'Kinetic Energy Source from Horizontal Viscosity', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + if (.not. adiabatic) then + CS%id_KE_dia = register_diag_field('ocean_model', 'KE_dia', diag%axesTL, Time, & + 'Kinetic Energy Source from Diapycnal Diffusion', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + endif + + ! gravity wave CFLs + CS%id_cg1 = register_diag_field('ocean_model', 'cg1', diag%axesT1, Time, & + 'First baroclinic gravity wave speed', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_Rd1 = register_diag_field('ocean_model', 'Rd1', diag%axesT1, Time, & + 'First baroclinic deformation radius', 'm', conversion=US%L_to_m) + CS%id_cfl_cg1 = register_diag_field('ocean_model', 'CFL_cg1', diag%axesT1, Time, & + 'CFL of first baroclinic gravity wave = dt*cg1*(1/dx+1/dy)', 'nondim') + CS%id_cfl_cg1_x = register_diag_field('ocean_model', 'CFL_cg1_x', diag%axesT1, Time, & + 'i-component of CFL of first baroclinic gravity wave = dt*cg1*/dx', 'nondim') + CS%id_cfl_cg1_y = register_diag_field('ocean_model', 'CFL_cg1_y', diag%axesT1, Time, & + 'j-component of CFL of first baroclinic gravity wave = dt*cg1*/dy', 'nondim') + CS%id_cg_ebt = register_diag_field('ocean_model', 'cg_ebt', diag%axesT1, Time, & + 'Equivalent barotropic gravity wave speed', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_Rd_ebt = register_diag_field('ocean_model', 'Rd_ebt', diag%axesT1, Time, & + 'Equivalent barotropic deformation radius', 'm', conversion=US%L_to_m) + CS%id_p_ebt = register_diag_field('ocean_model', 'p_ebt', diag%axesTL, Time, & + 'Equivalent barotropic modal strcuture', 'nondim') + + if ((CS%id_cg1>0) .or. (CS%id_Rd1>0) .or. (CS%id_cfl_cg1>0) .or. & + (CS%id_cfl_cg1_x>0) .or. (CS%id_cfl_cg1_y>0) .or. & + (CS%id_cg_ebt>0) .or. (CS%id_Rd_ebt>0) .or. (CS%id_p_ebt>0)) then + call wave_speed_init(CS%wave_speed, remap_answer_date=remap_answer_date, & + better_speed_est=better_speed_est, min_speed=wave_speed_min, & + wave_speed_tol=wave_speed_tol) + endif + + CS%id_mass_wt = register_diag_field('ocean_model', 'mass_wt', diag%axesT1, Time, & + 'The column mass for calculating mass-weighted average properties', 'kg m-2', conversion=US%RZ_to_kg_m2) + + if (use_temperature) then + CS%id_temp_int = register_diag_field('ocean_model', 'temp_int', diag%axesT1, Time, & + 'Density weighted column integrated potential temperature', & + 'degC kg m-2', conversion=US%C_to_degC*US%RZ_to_kg_m2, & + cmor_field_name='opottempmint', & + cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_potential_temperature', & + cmor_standard_name='Depth integrated density times potential temperature') + + CS%id_salt_int = register_diag_field('ocean_model', 'salt_int', diag%axesT1, Time, & + 'Density weighted column integrated salinity', & + 'psu kg m-2', conversion=US%S_to_ppt*US%RZ_to_kg_m2, & + cmor_field_name='somint', & + cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_salinity', & + cmor_standard_name='Depth integrated density times salinity') + endif + + CS%id_col_mass = register_diag_field('ocean_model', 'col_mass', diag%axesT1, Time, & + 'The column integrated in situ density', 'kg m-2', conversion=US%RZ_to_kg_m2) + + CS%id_col_ht = register_diag_field('ocean_model', 'col_height', diag%axesT1, Time, & + 'The height of the water column', 'm', conversion=US%Z_to_m) + CS%id_pbo = register_diag_field('ocean_model', 'pbo', diag%axesT1, Time, & + long_name='Sea Water Pressure at Sea Floor', standard_name='sea_water_pressure_at_sea_floor', & + units='Pa', conversion=US%RL2_T2_to_Pa) + + ! Register time derivatives and allocate memory for diagnostics that need + ! access from across several modules. + call set_dependent_diagnostics(MIS, ADp, CDp, G, GV, CS) + +end subroutine MOM_diagnostics_init + + +!> Register diagnostics of the surface state and integrated quantities +subroutine register_surface_diags(Time, G, US, IDs, diag, tv) + type(time_type), intent(in) :: Time !< current model time + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. + type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + + ! Vertically integrated, budget, and surface state diagnostics + IDs%id_volo = register_scalar_field('ocean_model', 'volo', Time, diag, & + long_name='Total volume of liquid ocean', units='m3', & + standard_name='sea_water_volume') + IDs%id_zos = register_diag_field('ocean_model', 'zos', diag%axesT1, Time, & + standard_name = 'sea_surface_height_above_geoid', & + long_name= 'Sea surface height above geoid', units='m', conversion=US%Z_to_m) + IDs%id_zossq = register_diag_field('ocean_model', 'zossq', diag%axesT1, Time, & + standard_name='square_of_sea_surface_height_above_geoid', & + long_name='Square of sea surface height above geoid', units='m2', conversion=US%Z_to_m**2) + IDs%id_ssh = register_diag_field('ocean_model', 'SSH', diag%axesT1, Time, & + 'Sea Surface Height', 'm', conversion=US%Z_to_m) + IDs%id_ssh_ga = register_scalar_field('ocean_model', 'ssh_ga', Time, diag, & + long_name='Area averaged sea surface height', units='m', conversion=US%Z_to_m, & + standard_name='area_averaged_sea_surface_height') + IDs%id_ssu = register_diag_field('ocean_model', 'SSU', diag%axesCu1, Time, & + 'Sea Surface Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) + IDs%id_ssv = register_diag_field('ocean_model', 'SSV', diag%axesCv1, Time, & + 'Sea Surface Meridional Velocity', 'm s-1', conversion=US%L_T_to_m_s) + IDs%id_speed = register_diag_field('ocean_model', 'speed', diag%axesT1, Time, & + 'Sea Surface Speed', 'm s-1', conversion=US%L_T_to_m_s) + + if (associated(tv%T)) then + IDs%id_sst = register_diag_field('ocean_model', 'SST', diag%axesT1, Time, & + 'Sea Surface Temperature', 'degC', conversion=US%C_to_degC, & + cmor_field_name='tos', cmor_long_name='Sea Surface Temperature', & + cmor_standard_name='sea_surface_temperature') + IDs%id_sst_sq = register_diag_field('ocean_model', 'SST_sq', diag%axesT1, Time, & + 'Sea Surface Temperature Squared', 'degC2', conversion=US%C_to_degC**2, & + cmor_field_name='tossq', cmor_long_name='Square of Sea Surface Temperature ', & + cmor_standard_name='square_of_sea_surface_temperature') + IDs%id_sss = register_diag_field('ocean_model', 'SSS', diag%axesT1, Time, & + 'Sea Surface Salinity', 'psu', conversion=US%S_to_ppt, & + cmor_field_name='sos', cmor_long_name='Sea Surface Salinity', & + cmor_standard_name='sea_surface_salinity') + IDs%id_sss_sq = register_diag_field('ocean_model', 'SSS_sq', diag%axesT1, Time, & + 'Sea Surface Salinity Squared', 'psu2', conversion=US%S_to_ppt**2, & + cmor_field_name='sossq', cmor_long_name='Square of Sea Surface Salinity ', & + cmor_standard_name='square_of_sea_surface_salinity') + if (tv%T_is_conT) then + IDs%id_sstcon = register_diag_field('ocean_model', 'conSST', diag%axesT1, Time, & + 'Sea Surface Conservative Temperature', 'Celsius', conversion=US%C_to_degC) + endif + if (tv%S_is_absS) then + IDs%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & + 'Sea Surface Absolute Salinity', 'g kg-1', conversion=US%S_to_ppt) + endif + if (associated(tv%frazil)) then + IDs%id_fraz = register_diag_field('ocean_model', 'frazil', diag%axesT1, Time, & + 'Heat from frazil formation', 'W m-2', conversion=US%QRZ_T_to_W_m2, & + cmor_field_name='hfsifrazil', & + cmor_standard_name='heat_flux_into_sea_water_due_to_frazil_ice_formation', & + cmor_long_name='Heat Flux into Sea Water due to Frazil Ice Formation') + endif + endif + + IDs%id_salt_deficit = register_diag_field('ocean_model', 'salt_deficit', diag%axesT1, Time, & + 'Salt source in ocean required to supply excessive ice salt fluxes', & + 'ppt kg m-2 s-1', conversion=US%S_to_ppt*US%RZ_T_to_kg_m2s) + IDs%id_Heat_PmE = register_diag_field('ocean_model', 'Heat_PmE', diag%axesT1, Time, & + 'Heat flux into ocean from mass flux into ocean', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) + IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time, & + 'Heat flux into ocean from geothermal or other internal sources', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) + +end subroutine register_surface_diags + +!> Register certain diagnostics related to transports +subroutine register_transport_diags(Time, G, GV, US, IDs, diag) + type(time_type), intent(in) :: Time !< current model time + 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(transport_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. + type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output + + character(len=48) :: thickness_units, accum_flux_units + + thickness_units = get_thickness_units(GV) + if (GV%Boussinesq) then + accum_flux_units = "m3" + else + accum_flux_units = "kg" + endif + + ! Diagnostics related to tracer and mass transport + IDs%id_uhtr = register_diag_field('ocean_model', 'uhtr', diag%axesCuL, Time, & + 'Accumulated zonal thickness fluxes to advect tracers', & + accum_flux_units, y_cell_method='sum', v_extensive=.true., conversion=GV%H_to_MKS*US%L_to_m**2) + IDs%id_vhtr = register_diag_field('ocean_model', 'vhtr', diag%axesCvL, Time, & + 'Accumulated meridional thickness fluxes to advect tracers', & + accum_flux_units, x_cell_method='sum', v_extensive=.true., conversion=GV%H_to_MKS*US%L_to_m**2) + IDs%id_umo = register_diag_field('ocean_model', 'umo', & + diag%axesCuL, Time, 'Ocean Mass X Transport', & + 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & + standard_name='ocean_mass_x_transport', y_cell_method='sum', v_extensive=.true.) + IDs%id_vmo = register_diag_field('ocean_model', 'vmo', & + diag%axesCvL, Time, 'Ocean Mass Y Transport', & + 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & + standard_name='ocean_mass_y_transport', x_cell_method='sum', v_extensive=.true.) + IDs%id_umo_2d = register_diag_field('ocean_model', 'umo_2d', & + diag%axesCu1, Time, 'Ocean Mass X Transport Vertical Sum', & + 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & + standard_name='ocean_mass_x_transport_vertical_sum', y_cell_method='sum') + IDs%id_vmo_2d = register_diag_field('ocean_model', 'vmo_2d', & + diag%axesCv1, Time, 'Ocean Mass Y Transport Vertical Sum', & + 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & + standard_name='ocean_mass_y_transport_vertical_sum', x_cell_method='sum') + IDs%id_dynamics_h = register_diag_field('ocean_model','dynamics_h', & + diag%axesTl, Time, 'Layer thicknesses prior to horizontal dynamics', & + thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) + IDs%id_dynamics_h_tendency = register_diag_field('ocean_model','dynamics_h_tendency', & + diag%axesTl, Time, 'Change in layer thicknesses due to horizontal dynamics', & + trim(thickness_units)//" s-1", conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) + +end subroutine register_transport_diags + +!> Offers the static fields in the ocean grid type for output via the diag_manager. +subroutine write_static_fields(G, GV, US, tv, diag) + 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(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output + + ! Local variables + real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array [Z ~> m] + integer :: id, i, j + logical :: use_temperature + + id = register_static_field('ocean_model', 'geolat', diag%axesT1, & + 'Latitude of tracer (T) points', 'degrees_north') + if (id > 0) call post_data(id, G%geoLatT, diag, .true.) + + id = register_static_field('ocean_model', 'geolon', diag%axesT1, & + 'Longitude of tracer (T) points', 'degrees_east') + if (id > 0) call post_data(id, G%geoLonT, diag, .true.) + + id = register_static_field('ocean_model', 'geolat_c', diag%axesB1, & + 'Latitude of corner (Bu) points', 'degrees_north', interp_method='none') + if (id > 0) call post_data(id, G%geoLatBu, diag, .true.) + + id = register_static_field('ocean_model', 'geolon_c', diag%axesB1, & + 'Longitude of corner (Bu) points', 'degrees_east', interp_method='none') + if (id > 0) call post_data(id, G%geoLonBu, diag, .true.) + + id = register_static_field('ocean_model', 'geolat_v', diag%axesCv1, & + 'Latitude of meridional velocity (Cv) points', 'degrees_north', interp_method='none') + if (id > 0) call post_data(id, G%geoLatCv, diag, .true.) + + id = register_static_field('ocean_model', 'geolon_v', diag%axesCv1, & + 'Longitude of meridional velocity (Cv) points', 'degrees_east', interp_method='none') + if (id > 0) call post_data(id, G%geoLonCv, diag, .true.) + + id = register_static_field('ocean_model', 'geolat_u', diag%axesCu1, & + 'Latitude of zonal velocity (Cu) points', 'degrees_north', interp_method='none') + if (id > 0) call post_data(id, G%geoLatCu, diag, .true.) + + id = register_static_field('ocean_model', 'geolon_u', diag%axesCu1, & + 'Longitude of zonal velocity (Cu) points', 'degrees_east', interp_method='none') + if (id > 0) call post_data(id, G%geoLonCu, diag, .true.) + + id = register_static_field('ocean_model', 'area_t', diag%axesT1, & + 'Surface area of tracer (T) cells', 'm2', conversion=US%L_to_m**2, & + cmor_field_name='areacello', cmor_standard_name='cell_area', & + cmor_long_name='Ocean Grid-Cell Area', & + x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') + if (id > 0) then + call post_data(id, G%areaT, diag, .true.) + call diag_register_area_ids(diag, id_area_t=id) + endif + + id = register_static_field('ocean_model', 'area_u', diag%axesCu1, & + 'Surface area of x-direction flow (U) cells', 'm2', conversion=US%L_to_m**2, & + cmor_field_name='areacello_cu', cmor_standard_name='cell_area', & + cmor_long_name='Ocean Grid-Cell Area', & + x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') + if (id > 0) call post_data(id, G%areaCu, diag, .true.) + + id = register_static_field('ocean_model', 'area_v', diag%axesCv1, & + 'Surface area of y-direction flow (V) cells', 'm2', conversion=US%L_to_m**2, & + cmor_field_name='areacello_cv', cmor_standard_name='cell_area', & + cmor_long_name='Ocean Grid-Cell Area', & + x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') + if (id > 0) call post_data(id, G%areaCv, diag, .true.) + + id = register_static_field('ocean_model', 'area_q', diag%axesB1, & + 'Surface area of B-grid flow (Q) cells', 'm2', conversion=US%L_to_m**2, & + cmor_field_name='areacello_bu', cmor_standard_name='cell_area', & + cmor_long_name='Ocean Grid-Cell Area', & + x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') + if (id > 0) call post_data(id, G%areaBu, diag, .true.) + + id = register_static_field('ocean_model', 'depth_ocean', diag%axesT1, & + 'Depth of the ocean at tracer points', 'm', conversion=US%Z_to_m, & + standard_name='sea_floor_depth_below_geoid', & + cmor_field_name='deptho', cmor_long_name='Sea Floor Depth', & + cmor_standard_name='sea_floor_depth_below_geoid', area=diag%axesT1%id_area, & + x_cell_method='mean', y_cell_method='mean', area_cell_method='mean') + if (id > 0) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; work_2d(i,j) = G%bathyT(i,j)+G%Z_ref ; enddo ; enddo + call post_data(id, work_2d, diag, .true., mask=G%mask2dT) + endif + + id = register_static_field('ocean_model', 'wet', diag%axesT1, & + '0 if land, 1 if ocean at tracer points', 'none', area=diag%axesT1%id_area) + if (id > 0) call post_data(id, G%mask2dT, diag, .true.) + + id = register_static_field('ocean_model', 'wet_c', diag%axesB1, & + '0 if land, 1 if ocean at corner (Bu) points', 'none', interp_method='none') + if (id > 0) call post_data(id, G%mask2dBu, diag, .true.) + + id = register_static_field('ocean_model', 'wet_u', diag%axesCu1, & + '0 if land, 1 if ocean at zonal velocity (Cu) points', 'none', interp_method='none') + if (id > 0) call post_data(id, G%mask2dCu, diag, .true.) + + id = register_static_field('ocean_model', 'wet_v', diag%axesCv1, & + '0 if land, 1 if ocean at meridional velocity (Cv) points', 'none', interp_method='none') + if (id > 0) call post_data(id, G%mask2dCv, diag, .true.) + + id = register_static_field('ocean_model', 'Coriolis', diag%axesB1, & + 'Coriolis parameter at corner (Bu) points', 's-1', interp_method='none', conversion=US%s_to_T) + if (id > 0) call post_data(id, G%CoriolisBu, diag, .true.) + + id = register_static_field('ocean_model', 'dxt', diag%axesT1, & + 'Delta(x) at thickness/tracer points (meter)', 'm', interp_method='none', conversion=US%L_to_m) + if (id > 0) call post_data(id, G%dxT, diag, .true.) + + id = register_static_field('ocean_model', 'dyt', diag%axesT1, & + 'Delta(y) at thickness/tracer points (meter)', 'm', interp_method='none', conversion=US%L_to_m) + if (id > 0) call post_data(id, G%dyT, diag, .true.) + + id = register_static_field('ocean_model', 'dxCu', diag%axesCu1, & + 'Delta(x) at u points (meter)', 'm', interp_method='none', conversion=US%L_to_m) + if (id > 0) call post_data(id, G%dxCu, diag, .true.) + + id = register_static_field('ocean_model', 'dyCu', diag%axesCu1, & + 'Delta(y) at u points (meter)', 'm', interp_method='none', conversion=US%L_to_m) + if (id > 0) call post_data(id, G%dyCu, diag, .true.) + + id = register_static_field('ocean_model', 'dxCv', diag%axesCv1, & + 'Delta(x) at v points (meter)', 'm', interp_method='none', conversion=US%L_to_m) + if (id > 0) call post_data(id, G%dxCv, diag, .true.) + + id = register_static_field('ocean_model', 'dyCv', diag%axesCv1, & + 'Delta(y) at v points (meter)', 'm', interp_method='none', conversion=US%L_to_m) + if (id > 0) call post_data(id, G%dyCv, diag, .true.) + + id = register_static_field('ocean_model', 'dyCuo', diag%axesCu1, & + 'Open meridional grid spacing at u points (meter)', 'm', interp_method='none', conversion=US%L_to_m) + if (id > 0) call post_data(id, G%dy_Cu, diag, .true.) + + id = register_static_field('ocean_model', 'dxCvo', diag%axesCv1, & + 'Open zonal grid spacing at v points (meter)', 'm', interp_method='none', conversion=US%L_to_m) + if (id > 0) call post_data(id, G%dx_Cv, diag, .true.) + + id = register_static_field('ocean_model', 'sin_rot', diag%axesT1, & + 'sine of the clockwise angle of the ocean grid north to true north', 'none') + if (id > 0) call post_data(id, G%sin_rot, diag, .true.) + + id = register_static_field('ocean_model', 'cos_rot', diag%axesT1, & + 'cosine of the clockwise angle of the ocean grid north to true north', 'none') + if (id > 0) call post_data(id, G%cos_rot, diag, .true.) + + + ! This static diagnostic is from CF 1.8, and is the fraction of a cell + ! covered by ocean, given as a percentage (poorly named). + id = register_static_field('ocean_model', 'area_t_percent', diag%axesT1, & + 'Percentage of cell area covered by ocean', '%', conversion=100.0, & + cmor_field_name='sftof', cmor_standard_name='SeaAreaFraction', & + cmor_long_name='Sea Area Fraction', & + x_cell_method='mean', y_cell_method='mean', area_cell_method='mean') + if (id > 0) call post_data(id, G%mask2dT, diag, .true.) + + + id = register_static_field('ocean_model','Rho_0', diag%axesNull, & + 'mean ocean density used with the Boussinesq approximation', & + 'kg m-3', conversion=US%R_to_kg_m3, cmor_field_name='rhozero', & + cmor_standard_name='reference_sea_water_density_for_boussinesq_approximation', & + cmor_long_name='reference sea water density for boussinesq approximation') + if (id > 0) call post_data(id, GV%Rho0, diag, .true.) + + use_temperature = associated(tv%T) + if (use_temperature) then + id = register_static_field('ocean_model','C_p', diag%axesNull, & + 'heat capacity of sea water', 'J kg-1 K-1', conversion=US%Q_to_J_kg*US%degC_to_C, & + cmor_field_name='cpocean', & + cmor_standard_name='specific_heat_capacity_of_sea_water', & + cmor_long_name='specific_heat_capacity_of_sea_water') + if (id > 0) call post_data(id, tv%C_p, diag, .true.) + endif + +end subroutine write_static_fields + + +!> This subroutine sets up diagnostics upon which other diagnostics depend. +subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, GV, CS) + type(ocean_internal_state), intent(in) :: MIS !< For "MOM Internal State" a set of pointers to + !! the fields and accelerations making up ocean + !! internal physical state. + type(accel_diag_ptrs), intent(inout) :: ADp !< Structure pointing to accelerations in + !! momentum equation. + type(cont_diag_ptrs), intent(inout) :: CDp !< Structure pointing to terms in continuity + !! equation. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(diagnostics_CS), intent(inout) :: CS !< Pointer to the control structure for this + !! module. + + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + ! Allocate and register time derivatives. + if ( ( (CS%id_du_dt>0) .or. (CS%id_dKEdt > 0) .or. & + ! (CS%id_hf_du_dt > 0) .or. & + (CS%id_h_du_dt > 0) .or. (CS%id_hf_du_dt_2d > 0) ) .and. & + (.not. allocated(CS%du_dt)) ) then + allocate(CS%du_dt(IsdB:IedB,jsd:jed,nz), source=0.) + call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) + endif + if ( ( (CS%id_dv_dt>0) .or. (CS%id_dKEdt > 0) .or. & + ! (CS%id_hf_dv_dt > 0) .or. & + (CS%id_h_dv_dt > 0) .or. (CS%id_hf_dv_dt_2d > 0) ) .and. & + (.not. allocated(CS%dv_dt)) ) then + allocate(CS%dv_dt(isd:ied,JsdB:JedB,nz), source=0.) + call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) + endif + if ( ( (CS%id_dh_dt>0) .or. (CS%id_dKEdt > 0) ) .and. & + (.not. allocated(CS%dh_dt)) ) then + allocate(CS%dh_dt(isd:ied,jsd:jed,nz), source=0.) + call register_time_deriv(lbound(MIS%h), MIS%h, CS%dh_dt, CS) + endif + + ! Allocate memory for other dependent diagnostics. + if (CS%id_KE_adv > 0) then + call safe_alloc_ptr(ADp%gradKEu,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%gradKEv,isd,ied,JsdB,JedB,nz) + endif + if (CS%id_KE_visc > 0) then + call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + endif + if (CS%id_KE_visc_gl90 > 0) then + call safe_alloc_ptr(ADp%du_dt_visc_gl90,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%dv_dt_visc_gl90,isd,ied,JsdB,JedB,nz) + endif + if (CS%id_KE_stress > 0) then + call safe_alloc_ptr(ADp%du_dt_str,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%dv_dt_str,isd,ied,JsdB,JedB,nz) + endif + + if (CS%id_KE_dia > 0) then + call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(CDp%diapyc_vel,isd,ied,jsd,jed,nz+1) + endif + + CS%KE_term_on = ((CS%id_dKEdt > 0) .or. (CS%id_PE_to_KE > 0) .or. (CS%id_KE_BT > 0) .or. & + (CS%id_KE_Coradv > 0) .or. (CS%id_KE_adv > 0) .or. (CS%id_KE_visc > 0) .or. & + (CS%id_KE_visc_gl90 > 0) .or. (CS%id_KE_stress > 0) .or. (CS%id_KE_horvisc > 0) .or. & + (CS%id_KE_dia > 0)) + + if (CS%id_h_du_dt > 0) call safe_alloc_ptr(ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + if (CS%id_h_dv_dt > 0) call safe_alloc_ptr(ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + if (CS%id_hf_du_dt_2d > 0) call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + if (CS%id_hf_dv_dt_2d > 0) call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + ! if (CS%id_hf_du_dt > 0) call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + ! if (CS%id_hf_dv_dt > 0) call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + if (CS%id_uhGM_Rlay > 0) call safe_alloc_ptr(CDp%uhGM,IsdB,IedB,jsd,jed,nz) + if (CS%id_vhGM_Rlay > 0) call safe_alloc_ptr(CDp%vhGM,isd,ied,JsdB,JedB,nz) + +end subroutine set_dependent_diagnostics + +!> Deallocate memory associated with the diagnostics module +subroutine MOM_diagnostics_end(CS, ADp, CDp) + type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a + !! previous call to diagnostics_init. + type(accel_diag_ptrs), intent(inout) :: ADp !< structure with pointers to + !! accelerations in momentum equation. + type(cont_diag_ptrs), intent(inout) :: CDp !< Structure pointing to terms in continuity + !! equation. + integer :: m + + if (allocated(CS%dh_dt)) deallocate(CS%dh_dt) + if (allocated(CS%dv_dt)) deallocate(CS%dv_dt) + if (allocated(CS%du_dt)) deallocate(CS%du_dt) + + if (associated(ADp%gradKEu)) deallocate(ADp%gradKEu) + if (associated(ADp%gradKEv)) deallocate(ADp%gradKEv) + if (associated(ADp%du_dt_visc)) deallocate(ADp%du_dt_visc) + if (associated(ADp%dv_dt_visc)) deallocate(ADp%dv_dt_visc) + if (associated(ADp%du_dt_str)) deallocate(ADp%du_dt_str) + if (associated(ADp%dv_dt_str)) deallocate(ADp%dv_dt_str) + if (associated(ADp%du_dt_dia)) deallocate(ADp%du_dt_dia) + if (associated(ADp%dv_dt_dia)) deallocate(ADp%dv_dt_dia) + if (associated(ADp%du_other)) deallocate(ADp%du_other) + if (associated(ADp%dv_other)) deallocate(ADp%dv_other) + + if (associated(ADp%diag_hfrac_u)) deallocate(ADp%diag_hfrac_u) + if (associated(ADp%diag_hfrac_v)) deallocate(ADp%diag_hfrac_v) + + ! NOTE: [uv]hGM may be allocated either here or the thickness diffuse module + if (associated(CDp%uhGM)) deallocate(CDp%uhGM) + if (associated(CDp%vhGM)) deallocate(CDp%vhGM) + if (associated(CDp%diapyc_vel)) deallocate(CDp%diapyc_vel) + + do m=1,CS%num_time_deriv ; deallocate(CS%prev_val(m)%p) ; enddo +end subroutine MOM_diagnostics_end + +end module MOM_diagnostics diff --git a/diagnostics/MOM_obsolete_diagnostics.F90 b/diagnostics/MOM_obsolete_diagnostics.F90 new file mode 100644 index 0000000000..ddfe0452a0 --- /dev/null +++ b/diagnostics/MOM_obsolete_diagnostics.F90 @@ -0,0 +1,82 @@ +!> Provides a mechanism for recording diagnostic variables that are no longer +!! valid, along with their replacement name if appropriate. +module MOM_obsolete_diagnostics + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : diag_ctrl, found_in_diagtable +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : param_file_type, log_version, get_param + +implicit none ; private + +#include + +public register_obsolete_diagnostics + +contains + +!> Scan through the diag_table searching for obsolete parameters and issue informational +!! messages and optionallly a FATAL error. +subroutine register_obsolete_diagnostics(param_file, diag) + type(param_file_type), intent(in) :: param_file !< The parameter file handle. + type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. +! This include declares and sets the variable "version". +#include "version_variable.h" + ! Local variables + character(len=40) :: mdl = "MOM_obsolete_diagnostics" !< This module's name. + logical :: foundEntry, causeFatal + integer :: errType + + call log_version(param_file, mdl, version) + call get_param(param_file, mdl, "OBSOLETE_DIAGNOSTIC_IS_FATAL", causeFatal, & + "If an obsolete diagnostic variable appears in the diag_table, "// & + "cause a FATAL error rather than issue a WARNING.", default=.true.) + + foundEntry = .false. + ! Each obsolete entry, with replacement name is available. + if (diag_found(diag, 'Net_Heat', 'net_heat_surface or net_heat_coupler')) foundEntry = .true. + if (diag_found(diag, 'PmE', 'PRCmE')) foundEntry = .true. + if (diag_found(diag, 'froz_precip', 'fprec')) foundEntry = .true. + if (diag_found(diag, 'liq_precip', 'lprec')) foundEntry = .true. + if (diag_found(diag, 'virt_precip', 'vprec')) foundEntry = .true. + if (diag_found(diag, 'froz_runoff', 'frunoff')) foundEntry = .true. + if (diag_found(diag, 'liq_runoff', 'lrunoff')) foundEntry = .true. + if (diag_found(diag, 'calving_heat_content', 'heat_content_frunoff')) foundEntry = .true. + if (diag_found(diag, 'precip_heat_content', 'heat_content_lprec')) foundEntry = .true. + if (diag_found(diag, 'evap_heat_content', 'heat_content_massout')) foundEntry = .true. + if (diag_found(diag, 'runoff_heat_content', 'heat_content_lrunoff')) foundEntry = .true. + if (diag_found(diag, 'latent_fprec')) foundEntry = .true. + if (diag_found(diag, 'latent_calve')) foundEntry = .true. + if (diag_found(diag, 'heat_rest', 'heat_restore')) foundEntry = .true. + if (diag_found(diag, 'KPP_dTdt', 'KPP_NLT_dTdt')) foundEntry = .true. + if (diag_found(diag, 'KPP_dSdt', 'KPP_NLT_dSdt')) foundEntry = .true. + + if (causeFatal) then; errType = FATAL + else ; errType = WARNING ; endif + if (foundEntry .and. is_root_pe()) & + call MOM_error(errType, 'MOM_obsolete_diagnostics: Obsolete diagnostics found in diag_table.') + +end subroutine register_obsolete_diagnostics + +!> Determines whether an obsolete parameter appears in the diag_table. +logical function diag_found(diag, varName, newVarName) + type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. + character(len=*), intent(in) :: varName !< The obsolete diagnostic name + character(len=*), optional, intent(in) :: newVarName !< The valid name of this diagnostic + + diag_found = found_in_diagtable(diag, varName) + + if (diag_found .and. is_root_pe()) then + if (present(newVarName)) then + call MOM_error(WARNING, 'MOM_obsolete_params: '//'diag_table entry "'// & + trim(varName)//'" found. Use ''"'//trim(newVarName)//'" instead.' ) + else + call MOM_error(WARNING, 'MOM_obsolete_params: '//'diag_table entry "'// & + trim(varName)//'" is obsolete.' ) + endif + endif + +end function diag_found + +end module MOM_obsolete_diagnostics diff --git a/diagnostics/MOM_obsolete_params.F90 b/diagnostics/MOM_obsolete_params.F90 new file mode 100644 index 0000000000..2567e7591b --- /dev/null +++ b/diagnostics/MOM_obsolete_params.F90 @@ -0,0 +1,292 @@ +!> Methods for testing for, and list of, obsolete run-time parameters. +module MOM_obsolete_params + +! This file is part of MOM6. See LICENSE.md for the license. +! This module was first conceived and written by Robert Hallberg, July 2010. + +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : read_param, log_version, param_file_type + +implicit none ; private + +#include + +public find_obsolete_params +public obsolete_logical, obsolete_int, obsolete_real, obsolete_char + +contains + +!> Scans input parameter file for list obsolete parameters. +subroutine find_obsolete_params(param_file) + type(param_file_type), intent(in) :: param_file !< Structure containing parameter file data. + ! Local variables + character(len=40) :: mdl = "find_obsolete_params" ! This module's name. +! This include declares and sets the variable "version". +#include "version_variable.h" + integer :: l_seg, nseg + logical :: test_logic, split + character(len=40) :: temp_string + + if (.not.is_root_pe()) return + + call obsolete_logical(param_file, "BLOCKED_ANALYTIC_FV_PGF", & + hint="BLOCKED_ANALYTIC_FV_PGF is no longer available.") + + call obsolete_logical(param_file, "ADD_KV_SLOW", & + hint="This option is no longer needed, nor supported.") + + call obsolete_char(param_file, "OBC_CONFIG", & + hint="Instead use OBC_USER_CONFIG and use the new segments protocol.") + call obsolete_char(param_file, "READ_OBC_ETA", & + hint="Instead use OBC_SEGMENT_XXX_DATA.") + call obsolete_char(param_file, "READ_OBC_UV", & + hint="Instead use OBC_SEGMENT_XXX_DATA.") + call obsolete_char(param_file, "READ_OBC_TS", & + hint="Instead use OBC_SEGMENT_XXX_DATA.") + call obsolete_char(param_file, "EXTEND_OBC_SEGMENTS", & + hint="This option is no longer needed, nor supported.") + call obsolete_char(param_file, "MEKE_VISCOSITY_COEFF", & + hint="This option has been replaced by MEKE_VISCOSITY_COEFF_KU and \n" //& + " MEKE_VISCOSITY_COEFF_AU. Please set these parameters instead.") + nseg = 0 + call read_param(param_file, "OBC_NUMBER_OF_SEGMENTS", nseg) + do l_seg = 1,nseg + write(temp_string(1:22),"('OBC_SEGMENT_',i3.3,'_TNUDGE')") l_seg + call obsolete_real(param_file, temp_string, & + hint="Instead use OBC_SEGMENT_xxx_VELOCITY_NUDGING_TIMESCALES.") + enddo + + call obsolete_logical(param_file, "CONVERT_THICKNESS_UNITS", .true.) + call obsolete_logical(param_file, "MASK_MASSLESS_TRACERS", .false.) + + call obsolete_logical(param_file, "SALT_REJECT_BELOW_ML", .false.) + call obsolete_logical(param_file, "MLE_USE_MLD_AVE_BUG", .false.) + call obsolete_logical(param_file, "CORRECT_DENSITY", .true.) + call obsolete_char(param_file, "WINDSTRESS_STAGGER", warning_val="C", & + hint="Use WIND_STAGGER instead.") + + call obsolete_char(param_file, "DIAG_REMAP_Z_GRID_DEF", & + hint="Use NUM_DIAG_COORDS, DIAG_COORDS and DIAG_COORD_DEF_Z") + + call obsolete_real(param_file, "VSTAR_SCALE_FACTOR", hint="Use EPBL_VEL_SCALE_FACTOR instead.") + + call obsolete_real(param_file, "VSTAR_SCALE_COEF") + call obsolete_real(param_file, "ZSTAR_RIGID_SURFACE_THRESHOLD") + call obsolete_logical(param_file, "HENYEY_IGW_BACKGROUND_NEW") + + call obsolete_real(param_file, "SLIGHT_DZ_SURFACE") + call obsolete_int(param_file, "SLIGHT_NZ_SURFACE_FIXED") + call obsolete_real(param_file, "SLIGHT_SURFACE_AVG_DEPTH") + call obsolete_real(param_file, "SLIGHT_NLAY_TO_INTERIOR") + call obsolete_logical(param_file, "SLIGHT_FIX_HALOCLINES") + call obsolete_real(param_file, "HALOCLINE_FILTER_LENGTH") + call obsolete_real(param_file, "HALOCLINE_STRAT_TOL") + + ! Test for inconsistent parameter settings. + split = .true. ; test_logic = .false. + call read_param(param_file,"SPLIT",split) + call read_param(param_file,"DYNAMIC_SURFACE_PRESSURE",test_logic) + if (test_logic .and. .not.split) call MOM_ERROR(FATAL, & + "find_obsolete_params: #define DYNAMIC_SURFACE_PRESSURE is not yet "//& + "implemented without #define SPLIT.") + call obsolete_char(param_file, "CONTINUITY_SCHEME", warning_val="PPM", & + hint="Only one continuity scheme is available so this need not be specified.") + call obsolete_real(param_file, "ETA_TOLERANCE_AUX", only_warn=.true.) + call obsolete_real(param_file, "BT_MASS_SOURCE_LIMIT", 0.0) + call obsolete_real(param_file, "FIRST_GUESS_SURFACE_LAYER_DEPTH") + call obsolete_logical(param_file, "CORRECT_SURFACE_LAYER_AVERAGE") + call obsolete_int(param_file, "SEAMOUNT_LENGTH_SCALE", hint="Use SEAMOUNT_X_LENGTH_SCALE instead.") + call obsolete_int(param_file, "USE_LATERAL_BOUNDARY_DIFFUSION", & + hint="Use USE_HORIZONTAL_BOUNDARY_DIFFUSION instead.") + + call obsolete_logical(param_file, "MSTAR_FIXED", hint="Instead use MSTAR_MODE.") + call obsolete_logical(param_file, "USE_VISBECK_SLOPE_BUG", .false.) + call obsolete_logical(param_file, "Use_PP81", hint="get_param is case sensitive so use USE_PP81.") + + call obsolete_logical(param_file, "ALLOW_CLOCKS_IN_OMP_LOOPS", .true.) + call obsolete_logical(param_file, "LARGE_FILE_SUPPORT", .true.) + call obsolete_real(param_file, "MIN_Z_DIAG_INTERVAL") + call obsolete_char(param_file, "Z_OUTPUT_GRID_FILE") + + call read_param(param_file, "INTERPOLATE_SPONGE_TIME_SPACE", test_logic) + call obsolete_logical(param_file, "NEW_SPONGES", warning_val=test_logic, & + hint="Use INTERPOLATE_SPONGE_TIME_SPACE instead.") + + call obsolete_logical(param_file, "SMOOTH_RI", hint="Instead use N_SMOOTH_RI.") + + call obsolete_logical(param_file, "TIDE_USE_SAL_SCALAR", hint="Use SAL_SCALAR_APPROX instead.") + call obsolete_logical(param_file, "TIDAL_SAL_SHT", hint="Use SAL_HARMONICS instead.") + call obsolete_int(param_file, "TIDAL_SAL_SHT_DEGREE", hint="Use SAL_HARMONICS_DEGREE instead.") + call obsolete_real(param_file, "RHO_E", hint="Use RHO_SOLID_EARTH instead.") + call obsolete_logical(param_file, "DEFAULT_2018_ANSWERS", hint="Instead use DEFAULT_ANSWER_DATE.") + + call obsolete_logical(param_file, "SURFACE_FORCING_2018_ANSWERS", & + hint="Instead use SURFACE_FORCING_ANSWER_DATE.") + call obsolete_logical(param_file, "WIND_GYRES_2018_ANSWERS", & + hint="Instead use WIND_GYRES_ANSWER_DATE.") + + call obsolete_logical(param_file, "BAROTROPIC_2018_ANSWERS", & + hint="Instead use BAROTROPIC_ANSWER_DATE.") + call obsolete_logical(param_file, "EPBL_2018_ANSWERS", hint="Instead use EPBL_ANSWER_DATE.") + call obsolete_logical(param_file, "HOR_REGRID_2018_ANSWERS", & + hint="Instead use HOR_REGRID_ANSWER_DATE.") + call obsolete_logical(param_file, "HOR_VISC_2018_ANSWERS", & + hint="Instead use HOR_VISC_ANSWER_DATE.") + call obsolete_logical(param_file, "IDL_HURR_2018_ANSWERS", & + hint="Instead use IDL_HURR_ANSWER_DATE.") + call obsolete_logical(param_file, "MEKE_GEOMETRIC_2018_ANSWERS", & + hint="Instead use MEKE_GEOMETRIC_ANSWER_DATE.") + call obsolete_logical(param_file, "ODA_2018_ANSWERS", hint="Instead use ODA_ANSWER_DATE.") + call obsolete_logical(param_file, "OPTICS_2018_ANSWERS", hint="Instead use OPTICS_ANSWER_DATE.") + call obsolete_logical(param_file, "REGULARIZE_LAYERS_2018_ANSWERS", & + hint="Instead use REGULARIZE_LAYERS_ANSWER_DATE.") + call obsolete_logical(param_file, "REMAPPING_2018_ANSWERS", & + hint="Instead use REMAPPING_ANSWER_DATE.") + call obsolete_logical(param_file, "SET_DIFF_2018_ANSWERS", & + hint="Instead use SET_DIFF_ANSWER_DATE.") + call obsolete_logical(param_file, "SET_VISC_2018_ANSWERS", & + hint="Instead use SET_VISC_ANSWER_DATE.") + call obsolete_logical(param_file, "SURFACE_2018_ANSWERS", hint="Instead use SURFACE_ANSWER_DATE.") + call obsolete_logical(param_file, "TIDAL_MIXING_2018_ANSWERS", & + hint="Instead use TIDAL_MIXING_ANSWER_DATE.") + call obsolete_logical(param_file, "VERT_FRICTION_2018_ANSWERS", & + hint="Instead use VERT_FRICTION_ANSWER_DATE.") + + ! Write the file version number to the model log. + call log_version(param_file, mdl, version) + +end subroutine find_obsolete_params + +!> Test for presence of obsolete LOGICAL in parameter file. +subroutine obsolete_logical(param_file, varname, warning_val, hint) + type(param_file_type), intent(in) :: param_file !< Structure containing parameter file data. + character(len=*), intent(in) :: varname !< Name of obsolete LOGICAL parameter. + logical, optional, intent(in) :: warning_val !< An allowed value that causes a warning instead of an error. + character(len=*), optional, intent(in) :: hint !< A hint to the user about what to do. + ! Local variables + logical :: test_logic, fatal_err + character(len=128) :: hint_msg + + test_logic = .false. ; call read_param(param_file, varname, test_logic) + fatal_err = .true. + if (present(warning_val)) fatal_err = (warning_val .neqv. .true.) + hint_msg = " " ; if (present(hint)) hint_msg = hint + + if (test_logic) then + if (fatal_err) then + call MOM_ERROR(FATAL, "MOM_obsolete_params: "//trim(varname)// & + " is an obsolete run-time flag, and should not be used. "// & + trim(hint_msg)) + else + call MOM_ERROR(WARNING, "MOM_obsolete_params: "//trim(varname)// & + " is an obsolete run-time flag. "//trim(hint_msg)) + endif + endif + + test_logic = .true. ; call read_param(param_file, varname, test_logic) + fatal_err = .true. + if (present(warning_val)) fatal_err = (warning_val .neqv. .false.) + + if (.not.test_logic) then + if (fatal_err) then + call MOM_ERROR(FATAL, "MOM_obsolete_params: "//trim(varname)// & + " is an obsolete run-time flag, and should not be used. "// & + trim(hint_msg)) + else + call MOM_ERROR(WARNING, "MOM_obsolete_params: "//trim(varname)// & + " is an obsolete run-time flag. "//trim(hint_msg)) + endif + endif + +end subroutine obsolete_logical + +!> Test for presence of obsolete STRING in parameter file. +subroutine obsolete_char(param_file, varname, warning_val, hint) + type(param_file_type), intent(in) :: param_file !< Structure containing parameter file data. + character(len=*), intent(in) :: varname !< Name of obsolete STRING parameter. + character(len=*), optional, intent(in) :: warning_val !< An allowed value that causes a warning instead of an error. + character(len=*), optional, intent(in) :: hint !< A hint to the user about what to do. + ! Local variables + character(len=200) :: test_string, hint_msg + logical :: only_warn + + test_string = ''; call read_param(param_file, varname, test_string) + hint_msg = " " ; if (present(hint)) hint_msg = hint + + if (len_trim(test_string) > 0) then + only_warn = .false. + if (present(warning_val)) then ! Check if test_string and warning_val are the same. + if (len_trim(warning_val) == len_trim(test_string)) then + if (index(trim(test_string), trim(warning_val)) == 1) only_warn = .true. + endif + endif + + if (only_warn) then + call MOM_ERROR(WARNING, & + "MOM_obsolete_params: "//trim(varname)// & + " is an obsolete run-time flag. "//trim(hint_msg)) + else + call MOM_ERROR(FATAL, & + "MOM_obsolete_params: "//trim(varname)// & + " is an obsolete run-time flag, and should not be used. "//trim(hint_msg)) + endif + endif +end subroutine obsolete_char + +!> Test for presence of obsolete REAL in parameter file. +subroutine obsolete_real(param_file, varname, warning_val, hint, only_warn) + type(param_file_type), intent(in) :: param_file !< Structure containing parameter file data. + character(len=*), intent(in) :: varname !< Name of obsolete REAL parameter. + real, optional, intent(in) :: warning_val !< An allowed value that causes a warning instead of an error. + character(len=*), optional, intent(in) :: hint !< A hint to the user about what to do. + logical, optional, intent(in) :: only_warn !< If present and true, issue warnings instead of fatal errors. + + ! Local variables + real :: test_val, warn_val + logical :: issue_warning + character(len=128) :: hint_msg + + test_val = -9e35; call read_param(param_file, varname, test_val) + warn_val = -9e35; if (present(warning_val)) warn_val = warning_val + hint_msg = " " ; if (present(hint)) hint_msg = hint + issue_warning = .false. ; if (present(only_warn)) issue_warning = only_warn + + if (test_val /= -9e35) then + if ((test_val == warn_val) .or. issue_warning) then + call MOM_ERROR(WARNING, "MOM_obsolete_params: "//trim(varname)// & + " is an obsolete run-time flag. "//trim(hint_msg)) + else + call MOM_ERROR(FATAL, "MOM_obsolete_params: "//trim(varname)// & + " is an obsolete run-time flag, and should not be used. "// & + trim(hint_msg)) + endif + endif +end subroutine obsolete_real + +!> Test for presence of obsolete INTEGER in parameter file. +subroutine obsolete_int(param_file, varname, warning_val, hint) + type(param_file_type), intent(in) :: param_file !< Structure containing parameter file data. + character(len=*), intent(in) :: varname !< Name of obsolete INTEGER parameter. + integer, optional, intent(in) :: warning_val !< An allowed value that causes a warning instead of an error. + character(len=*), optional, intent(in) :: hint !< A hint to the user about what to do. + ! Local variables + integer :: test_val, warn_val + character(len=128) :: hint_msg + + test_val = -123456788; call read_param(param_file, varname, test_val) + warn_val = -123456788; if (present(warning_val)) warn_val = warning_val + hint_msg = " " ; if (present(hint)) hint_msg = hint + + if (test_val /= -123456788) then + if (test_val == warn_val) then + call MOM_ERROR(WARNING, "MOM_obsolete_params: "//trim(varname)// & + " is an obsolete run-time flag. "//trim(hint_msg)) + else + call MOM_ERROR(FATAL, "MOM_obsolete_params: "//trim(varname)// & + " is an obsolete run-time flag, and should not be used. "// & + trim(hint_msg)) + endif + endif +end subroutine obsolete_int + +end module MOM_obsolete_params diff --git a/diagnostics/MOM_spatial_means.F90 b/diagnostics/MOM_spatial_means.F90 new file mode 100644 index 0000000000..60ad8dfba5 --- /dev/null +++ b/diagnostics/MOM_spatial_means.F90 @@ -0,0 +1,639 @@ +!> Functions and routines to take area, volume, mass-weighted, layerwise, zonal or meridional means +module MOM_spatial_means + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=) +use MOM_coms, only : EFP_to_real, real_to_EFP, EFP_sum_across_PEs +use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real +use MOM_coms, only : query_EFP_overflow_error, reset_EFP_overflow_error +use MOM_error_handler, only : MOM_error, NOTE, WARNING, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public :: global_i_mean, global_j_mean +public :: global_area_mean, global_area_mean_u, global_area_mean_v, global_layer_mean +public :: global_area_integral +public :: global_volume_mean, global_mass_integral, global_mass_int_EFP +public :: adjust_area_mean_to_zero + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. +! The functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + +contains + +!> Return the global area mean of a variable. This uses reproducing sums. +function global_area_mean(var, G, scale, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to average in + !! arbitrary, possibly rescaled units [A ~> a] + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the variable + !! that is reversed in the return value [a A-1 ~> 1] + real :: global_area_mean ! The mean of the variable in arbitrary unscaled units [a] or scaled units [A ~> a] + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [a m2] + real :: scalefac ! An overall scaling factor for the areas and variable [a m2 A-1 L-2 ~> 1] + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale ; if (present(scale)) scalefac = scalefac * scale + + tmpForSumming(:,:) = 0. + do j=js,je ; do i=is,ie + tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) + enddo ; enddo + + global_area_mean = reproducing_sum(tmpForSumming) * G%IareaT_global + + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_area_mean = global_area_mean / temp_scale + +end function global_area_mean + +!> Return the global area mean of a variable. This uses reproducing sums. +function global_area_mean_v(var, G, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: var !< The variable to average in + !! arbitrary, possibly rescaled units [A ~> a] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that converts it back to unscaled + !! (e.g., mks) units to enable the use of the + !! reproducing sums [a A-1 ~> 1], but is reversed + !! before output so that the return value has + !! the same units as var + + real :: global_area_mean_v ! The mean of the variable in the same arbitrary units as var [A ~> a] + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [a m2] + real :: scalefac ! An overall scaling factor for the areas and variable [a m2 A-1 L-2 ~> 1] + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] + integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB + + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale + + tmpForSumming(:,:) = 0. + do J=js,je ; do i=is,ie + tmpForSumming(i,j) = G%areaT(i,j) * scalefac * & + (var(i,J) * G%mask2dCv(i,J) + var(i,J-1) * G%mask2dCv(i,J-1)) / & + max(1.e-20, G%mask2dCv(i,J)+G%mask2dCv(i,J-1)) + enddo ; enddo + global_area_mean_v = reproducing_sum(tmpForSumming) * G%IareaT_global + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_area_mean_v = global_area_mean_v / temp_scale + +end function global_area_mean_v + +!> Return the global area mean of a variable on U grid. This uses reproducing sums. +function global_area_mean_u(var, G, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: var !< The variable to average in + !! arbitrary, possibly rescaled units [A ~> a] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that converts it back to unscaled + !! (e.g., mks) units to enable the use of the + !! reproducing sums [a A-1 ~> 1], but is reversed + !! before output so that the return value has + !! the same units as var + real :: global_area_mean_u ! The mean of the variable in the same arbitrary units as var [A ~> a] + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [a m2] + real :: scalefac ! An overall scaling factor for the areas and variable [a m2 A-1 L-2 ~> 1] + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] + integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB + + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale + + tmpForSumming(:,:) = 0. + do j=js,je ; do i=is,ie + tmpForSumming(i,j) = G%areaT(i,j) * scalefac * & + (var(I,j) * G%mask2dCu(I,j) + var(I-1,j) * G%mask2dCu(I-1,j)) / & + max(1.e-20, G%mask2dCu(I,j)+G%mask2dCu(I-1,j)) + enddo ; enddo + global_area_mean_u = reproducing_sum(tmpForSumming) * G%IareaT_global + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_area_mean_u = global_area_mean_u / temp_scale + +end function global_area_mean_u + +!> Return the global area integral of a variable, by default using the masked area from the +!! grid, but an alternate could be used instead. This uses reproducing sums. +function global_area_integral(var, G, scale, area, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to integrate in + !! arbitrary, possibly rescaled units [A ~> a] + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: area !< The alternate area to use, including + !! any required masking [L2 ~> m2]. + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value [a A-1 ~> 1] + real :: global_area_integral !< The returned area integral, usually in the units of var times an area, + !! [a m2] or [A m2 ~> a m2] depending on which optional arguments are provided + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [a m2] + real :: scalefac ! An overall scaling factor for the areas and variable. + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale ; if (present(scale)) scalefac = scalefac * scale + + tmpForSumming(:,:) = 0. + if (present(area)) then + do j=js,je ; do i=is,ie + tmpForSumming(i,j) = var(i,j) * (scalefac * area(i,j)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) + enddo ; enddo + endif + + global_area_integral = reproducing_sum(tmpForSumming) + + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_area_integral = global_area_integral / temp_scale + +end function global_area_integral + +!> Return the layerwise global thickness-weighted mean of a variable. This uses reproducing sums. +function global_layer_mean(var, h, G, GV, scale, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: var !< The variable to average in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value [a A-1 ~> 1] + real, dimension(SZK_(GV)) :: global_layer_mean !< The mean of the variable in the arbitrary scaled [A] + !! or unscaled [a] units of var, depending on which optional + !! arguments are provided + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(G%isc:G%iec,G%jsc:G%jec,SZK_(GV)) :: tmpForSumming ! An unscaled cell integral [a m3] or [a kg] + real, dimension(G%isc:G%iec,G%jsc:G%jec,SZK_(GV)) :: weight ! The volume or mass of each cell, depending on + ! whether the model is Boussinesq, used as a weight [m3] or [kg] + type(EFP_type), dimension(2*SZK_(GV)) :: laysums + real, dimension(SZK_(GV)) :: global_temp_scalar ! The global integral of the tracer in each layer [a m3] or [a kg] + real, dimension(SZK_(GV)) :: global_weight_scalar ! The global integral of the volume or mass of each + ! layer [m3] or [kg] + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = temp_scale ; if (present(scale)) scalefac = scale * temp_scale + tmpForSumming(:,:,:) = 0. ; weight(:,:,:) = 0. + + do k=1,nz ; do j=js,je ; do i=is,ie + weight(i,j,k) = (GV%H_to_MKS * h(i,j,k)) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j)) + tmpForSumming(i,j,k) = scalefac * var(i,j,k) * weight(i,j,k) + enddo ; enddo ; enddo + + global_temp_scalar = reproducing_sum(tmpForSumming, EFP_lay_sums=laysums(1:nz), only_on_PE=.true.) + global_weight_scalar = reproducing_sum(weight, EFP_lay_sums=laysums(nz+1:2*nz), only_on_PE=.true.) + call EFP_sum_across_PEs(laysums, 2*nz) + + do k=1,nz + global_layer_mean(k) = EFP_to_real(laysums(k)) / (temp_scale * EFP_to_real(laysums(nz+k))) + enddo + +end function global_layer_mean + +!> Find the global thickness-weighted mean of a variable. This uses reproducing sums. +function global_volume_mean(var, h, G, GV, scale, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: var !< The variable being averaged in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value [a A-1 ~> 1] + real :: global_volume_mean !< The thickness-weighted average of var in the arbitrary scaled [A] or + !! unscaled [a] units of var, depending on which optional arguments are provided + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: weight_here ! The volume or mass of a grid cell [m3] or [kg] + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! The volume integral of the variable in a column [a m3] or [a kg] + real, dimension(SZI_(G),SZJ_(G)) :: sum_weight ! The volume or mass of each column of water [m3] or [kg] + integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = temp_scale ; if (present(scale)) scalefac = temp_scale * scale + tmpForSumming(:,:) = 0. ; sum_weight(:,:) = 0. + + do k=1,nz ; do j=js,je ; do i=is,ie + weight_here = (GV%H_to_MKS * h(i,j,k)) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j)) + tmpForSumming(i,j) = tmpForSumming(i,j) + scalefac * var(i,j,k) * weight_here + sum_weight(i,j) = sum_weight(i,j) + weight_here + enddo ; enddo ; enddo + global_volume_mean = (reproducing_sum(tmpForSumming)) / & + (temp_scale * reproducing_sum(sum_weight)) + +end function global_volume_mean + + +!> Find the global mass-weighted integral of a variable. This uses reproducing sums. +function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: var !< The variable being integrated in + !! arbitrary, possibly rescaled units [A ~> a] + logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only done + !! on the local PE, and it is _not_ order invariant. + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value [a A-1 ~> 1] + real :: global_mass_integral !< The mass-weighted integral of var (or 1) in + !! kg times the arbitrary units of var [kg a] or [kg A ~> kg a] + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! The mass-weighted integral of the variable in a column [kg a] + real :: scalefac ! An overall scaling factor for the cell mass and variable [a kg A-1 H-1 L-2 ~> kg m-3 or 1] + real :: temp_scale ! A temporary scaling factor [1] or [a A-1 ~> 1] + logical :: global_sum ! If true do the sum globally, but if false only do the sum on the current PE. + integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale ; if (present(scale)) scalefac = scalefac * scale + tmpForSumming(:,:) = 0.0 + + if (present(var)) then + do k=1,nz ; do j=js,je ; do i=is,ie + tmpForSumming(i,j) = tmpForSumming(i,j) + var(i,j,k) * & + ((GV%H_to_kg_m2 * h(i,j,k)) * (scalefac*G%areaT(i,j) * G%mask2dT(i,j))) + enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + tmpForSumming(i,j) = tmpForSumming(i,j) + & + ((GV%H_to_kg_m2 * h(i,j,k)) * (scalefac*G%areaT(i,j) * G%mask2dT(i,j))) + enddo ; enddo ; enddo + endif + global_sum = .true. ; if (present(on_PE_only)) global_sum = .not.on_PE_only + if (global_sum) then + global_mass_integral = reproducing_sum(tmpForSumming) + else + global_mass_integral = 0.0 + do j=js,je ; do i=is,ie + global_mass_integral = global_mass_integral + tmpForSumming(i,j) + enddo ; enddo + endif + + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_mass_integral = global_mass_integral / temp_scale + +end function global_mass_integral + +!> Find the global mass-weighted order invariant integral of a variable in mks units, +!! returning the value as an EFP_type. This uses reproducing sums. +function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: var !< The variable being integrated in + !! arbitrary, possibly rescaled units [A ~> a] + logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only done + !! on the local PE, but it is still order invariant. + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + type(EFP_type) :: global_mass_int_EFP !< The mass-weighted integral of var (or 1) in + !! kg times the arbitrary units of var [kg a] + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSum ! The mass-weighted integral of the variable in a column [kg a] + real :: scalefac ! An overall scaling factor for the cell mass and variable [a kg A-1 H-1 L-2 ~> kg m-3 or 1] + integer :: i, j, k, is, ie, js, je, nz, isr, ier, jsr, jer + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) + + scalefac = GV%H_to_kg_m2 * G%US%L_to_m**2 + if (present(scale)) scalefac = scale * scalefac + + tmpForSum(:,:) = 0.0 + if (present(var)) then + do k=1,nz ; do j=js,je ; do i=is,ie + tmpForSum(i,j) = tmpForSum(i,j) + var(i,j,k) * & + ((scalefac * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j))) + enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + tmpForSum(i,j) = tmpForSum(i,j) + & + ((scalefac * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j))) + enddo ; enddo ; enddo + endif + + global_mass_int_EFP = reproducing_sum_EFP(tmpForSum, isr, ier, jsr, jer, only_on_PE=on_PE_only) + +end function global_mass_int_EFP + + +!> Determine the global mean of a field along rows of constant i, returning it +!! in a 1-d array using the local indexing. This uses reproducing sums. +subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(SZJ_(G)), intent(out) :: i_mean !< Global mean of array along its i-axis [a] or [A ~> a] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: mask !< An array used for weighting the i-mean [nondim] + real, optional, intent(in) :: scale !< A rescaling factor for the output variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal + !! calculations that is removed from the output [a A-1 ~> 1] + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + type(EFP_type), allocatable, dimension(:) :: asum ! The masked sum of the variable in each row [a] + type(EFP_type), allocatable, dimension(:) :: mask_sum ! The sum of the mask values in each row [nondim] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: unscale ! A factor for undoing any internal rescaling before output [A a-1 ~> 1] + real :: mask_sum_r ! The sum of the mask values in a row [nondim] + integer :: is, ie, js, je, idg_off, jdg_off + integer :: i, j + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + idg_off = G%idg_offset ; jdg_off = G%jdg_offset + + scalefac = 1.0 ; if (present(scale)) scalefac = scale + unscale = 1.0 + if (present(tmp_scale)) then ; if (tmp_scale /= 0.0) then + scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale + endif ; endif + call reset_EFP_overflow_error() + + allocate(asum(G%jsg:G%jeg)) + if (present(mask)) then + allocate(mask_sum(G%jsg:G%jeg)) + + do j=G%jsg,G%jeg + asum(j) = real_to_EFP(0.0) ; mask_sum(j) = real_to_EFP(0.0) + enddo + + do j=js,je ; do i=is,ie + asum(j+jdg_off) = asum(j+jdg_off) + real_to_EFP(scalefac*array(i,j)*mask(i,j)) + mask_sum(j+jdg_off) = mask_sum(j+jdg_off) + real_to_EFP(mask(i,j)) + enddo ; enddo + + if (query_EFP_overflow_error()) call MOM_error(FATAL, & + "global_i_mean overflow error occurred before sums across PEs.") + + call EFP_sum_across_PEs(asum(G%jsg:G%jeg), G%jeg-G%jsg+1) + call EFP_sum_across_PEs(mask_sum(G%jsg:G%jeg), G%jeg-G%jsg+1) + + if (query_EFP_overflow_error()) call MOM_error(FATAL, & + "global_i_mean overflow error occurred during sums across PEs.") + + do j=js,je + mask_sum_r = EFP_to_real(mask_sum(j+jdg_off)) + if (mask_sum_r == 0.0 ) then ; i_mean(j) = 0.0 ; else + i_mean(j) = EFP_to_real(asum(j+jdg_off)) / mask_sum_r + endif + enddo + + deallocate(mask_sum) + else + do j=G%jsg,G%jeg ; asum(j) = real_to_EFP(0.0) ; enddo + + do j=js,je ; do i=is,ie + asum(j+jdg_off) = asum(j+jdg_off) + real_to_EFP(scalefac*array(i,j)) + enddo ; enddo + + if (query_EFP_overflow_error()) call MOM_error(FATAL, & + "global_i_mean overflow error occurred before sum across PEs.") + + call EFP_sum_across_PEs(asum(G%jsg:G%jeg), G%jeg-G%jsg+1) + + if (query_EFP_overflow_error()) call MOM_error(FATAL, & + "global_i_mean overflow error occurred during sum across PEs.") + + do j=js,je + i_mean(j) = EFP_to_real(asum(j+jdg_off)) / real(G%ieg-G%isg+1) + enddo + endif + + if (unscale /= 1.0) then ; do j=js,je ; i_mean(j) = unscale*i_mean(j) ; enddo ; endif + + deallocate(asum) + +end subroutine global_i_mean + +!> Determine the global mean of a field along rows of constant j, returning it +!! in a 1-d array using the local indexing. This uses reproducing sums. +subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(SZI_(G)), intent(out) :: j_mean !< Global mean of array along its j-axis [a] or [A ~> a] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: mask !< An array used for weighting the j-mean + real, optional, intent(in) :: scale !< A rescaling factor for the output variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal + !! calculations that is removed from the output [a A-1 ~> 1] + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + type(EFP_type), allocatable, dimension(:) :: asum ! The masked sum of the variable in each row [a] + type(EFP_type), allocatable, dimension(:) :: mask_sum ! The sum of the mask values in each row [nondim] + real :: mask_sum_r ! The sum of the mask values in a row [nondim] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: unscale ! A factor for undoing any internal rescaling before output [A a-1 ~> 1] + integer :: is, ie, js, je, idg_off, jdg_off + integer :: i, j + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + idg_off = G%idg_offset ; jdg_off = G%jdg_offset + + scalefac = 1.0 ; if (present(scale)) scalefac = scale + unscale = 1.0 + if (present(tmp_scale)) then ; if (tmp_scale /= 0.0) then + scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale + endif ; endif + call reset_EFP_overflow_error() + + allocate(asum(G%isg:G%ieg)) + if (present(mask)) then + allocate (mask_sum(G%isg:G%ieg)) + + do i=G%isg,G%ieg + asum(i) = real_to_EFP(0.0) ; mask_sum(i) = real_to_EFP(0.0) + enddo + + do i=is,ie ; do j=js,je + asum(i+idg_off) = asum(i+idg_off) + real_to_EFP(scalefac*array(i,j)*mask(i,j)) + mask_sum(i+idg_off) = mask_sum(i+idg_off) + real_to_EFP(mask(i,j)) + enddo ; enddo + + if (query_EFP_overflow_error()) call MOM_error(FATAL, & + "global_j_mean overflow error occurred before sums across PEs.") + + call EFP_sum_across_PEs(asum(G%isg:G%ieg), G%ieg-G%isg+1) + call EFP_sum_across_PEs(mask_sum(G%isg:G%ieg), G%ieg-G%isg+1) + + if (query_EFP_overflow_error()) call MOM_error(FATAL, & + "global_j_mean overflow error occurred during sums across PEs.") + + do i=is,ie + mask_sum_r = EFP_to_real(mask_sum(i+idg_off)) + if (mask_sum_r == 0.0 ) then ; j_mean(i) = 0.0 ; else + j_mean(i) = EFP_to_real(asum(i+idg_off)) / mask_sum_r + endif + enddo + + deallocate(mask_sum) + else + do i=G%isg,G%ieg ; asum(i) = real_to_EFP(0.0) ; enddo + + do i=is,ie ; do j=js,je + asum(i+idg_off) = asum(i+idg_off) + real_to_EFP(scalefac*array(i,j)) + enddo ; enddo + + if (query_EFP_overflow_error()) call MOM_error(FATAL, & + "global_j_mean overflow error occurred before sum across PEs.") + + call EFP_sum_across_PEs(asum(G%isg:G%ieg), G%ieg-G%isg+1) + + if (query_EFP_overflow_error()) call MOM_error(FATAL, & + "global_j_mean overflow error occurred during sum across PEs.") + + do i=is,ie + j_mean(i) = EFP_to_real(asum(i+idg_off)) / real(G%jeg-G%jsg+1) + enddo + endif + + if (unscale /= 1.0) then ; do i=is,ie ; j_mean(i) = unscale*j_mean(i) ; enddo ; endif + + deallocate(asum) + +end subroutine global_j_mean + +!> Adjust 2d array such that area mean is zero without moving the zero contour +subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) + type(ocean_grid_type), intent(in) :: G !< Grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: array !< 2D array to be adjusted in + !! arbitrary, possibly rescaled units [A ~> a] + real, optional, intent(out) :: scaling !< The scaling factor used [nondim] + real, optional, intent(in) :: unit_scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: posVals, negVals ! The positive or negative values in a cell or 0 [a] + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: areaXposVals, areaXnegVals ! The cell area integral of the values [m2 a] + type(EFP_type), dimension(2) :: areaInt_EFP ! An EFP version integral of the values on the current PE [m2 a] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: I_scalefac ! The Adcroft reciprocal of scalefac [A a-1 ~> 1] + real :: areaIntPosVals, areaIntNegVals ! The global area integral of the positive and negative values [m2 a] + real :: posScale, negScale ! The scaling factor to apply to positive or negative values [nondim] + integer :: i,j + + scalefac = 1.0 ; if (present(unit_scale)) scalefac = unit_scale + I_scalefac = 0.0 ; if (scalefac /= 0.0) I_scalefac = 1.0 / scalefac + + ! areaXposVals(:,:) = 0. ! This zeros out halo points. + ! areaXnegVals(:,:) = 0. ! This zeros out halo points. + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + posVals(i,j) = max(0., scalefac*array(i,j)) + areaXposVals(i,j) = G%US%L_to_m**2*G%areaT(i,j) * posVals(i,j) + negVals(i,j) = min(0., scalefac*array(i,j)) + areaXnegVals(i,j) = G%US%L_to_m**2*G%areaT(i,j) * negVals(i,j) + enddo ; enddo + + ! Combining the sums like this avoids separate blocking global sums. + areaInt_EFP(1) = reproducing_sum_EFP( areaXposVals, only_on_PE=.true. ) + areaInt_EFP(2) = reproducing_sum_EFP( areaXnegVals, only_on_PE=.true. ) + call EFP_sum_across_PEs(areaInt_EFP, 2) + areaIntPosVals = EFP_to_real( areaInt_EFP(1) ) + areaIntNegVals = EFP_to_real( areaInt_EFP(2) ) + + posScale = 0.0 ; negScale = 0.0 + if ((areaIntPosVals>0.).and.(areaIntNegVals<0.)) then ! Only adjust if possible + if (areaIntPosVals>-areaIntNegVals) then ! Scale down positive values + posScale = - areaIntNegVals / areaIntPosVals + do j=G%jsc,G%jec ; do i=G%isc,G%iec + array(i,j) = ((posScale * posVals(i,j)) + negVals(i,j)) * I_scalefac + enddo ; enddo + elseif (areaIntPosVals<-areaIntNegVals) then ! Scale down negative values + negScale = - areaIntPosVals / areaIntNegVals + do j=G%jsc,G%jec ; do i=G%isc,G%iec + array(i,j) = (posVals(i,j) + (negScale * negVals(i,j))) * I_scalefac + enddo ; enddo + endif + endif + if (present(scaling)) scaling = posScale - negScale + +end subroutine adjust_area_mean_to_zero + +end module MOM_spatial_means diff --git a/diagnostics/MOM_sum_output.F90 b/diagnostics/MOM_sum_output.F90 new file mode 100644 index 0000000000..fb95b79a91 --- /dev/null +++ b/diagnostics/MOM_sum_output.F90 @@ -0,0 +1,1406 @@ +!> Reports integrated quantities for monitoring the model state +module MOM_sum_output + +! This file is part of MOM6. See LICENSE.md for the license. + +use iso_fortran_env, only : int64 +use MOM_checksums, only : is_NaN +use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs, field_chksum +use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real, real_to_EFP +use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_sum_across_PEs +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : find_eta +use MOM_io, only : create_MOM_file, reopen_MOM_file +use MOM_io, only : MOM_infra_file, MOM_netcdf_file, MOM_field +use MOM_io, only : file_exists, slasher, vardesc, var_desc, MOM_write_field +use MOM_io, only : field_size, read_variable, read_attribute, open_ASCII_file, stdout +use MOM_io, only : axis_info, set_axis_info, delete_axis_info, get_filename_appendix +use MOM_io, only : attribute_info, set_attribute_info, delete_attribute_info +use MOM_io, only : APPEND_FILE, SINGLE_FILE, WRITEONLY_FILE +use MOM_time_manager, only : time_type, get_time, get_date, set_time, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) +use MOM_time_manager, only : get_calendar_type, time_type_to_real, NO_CALENDAR +use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_stocks +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public write_energy, accumulate_net_input +public MOM_sum_output_init, MOM_sum_output_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +integer, parameter :: NUM_FIELDS = 17 !< Number of diagnostic fields +character (*), parameter :: depth_chksum_attr = "bathyT_checksum" + !< Checksum attribute name of G%bathyT + !! over the compute domain +character (*), parameter :: area_chksum_attr = "mask2dT_areaT_checksum" + !< Checksum attribute of name of + !! G%mask2dT * G%areaT over the compute + !! domain + +!> A list of depths and corresponding globally integrated ocean area at each +!! depth and the ocean volume below each depth. +type :: Depth_List + integer :: listsize !< length of the list <= niglobal*njglobal + 1 + real, allocatable, dimension(:) :: depth !< A list of depths [Z ~> m] + real, allocatable, dimension(:) :: area !< The cross-sectional area of the ocean at that depth [L2 ~> m2] + real, allocatable, dimension(:) :: vol_below !< The ocean volume below that depth [Z L2 ~> m3] +end type Depth_List + +!> The control structure for the MOM_sum_output module +type, public :: sum_output_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + + type(Depth_List) :: DL !< The sorted depth list. + + integer, allocatable, dimension(:) :: lH + !< This saves the entry in DL with a volume just + !! less than the volume of fluid below the interface. + logical :: do_APE_calc !< If true, calculate the available potential energy of the + !! interfaces. Disabling this reduces the memory footprint of + !! high-PE-count models dramatically. + logical :: read_depth_list !< Read the depth list from a file if it exists + !! and write it if it doesn't. + character(len=200) :: depth_list_file !< The name of the depth list file. + real :: D_list_min_inc !< The minimum increment [Z ~> m], between the depths of the + !! entries in the depth-list file, 0 by default. + logical :: require_depth_list_chksum + !< Require matching checksums in Depth_list.nc when reading + !! the file. + logical :: update_depth_list_chksum + !< Automatically update the Depth_list.nc file if the + !! checksums are missing or do not match current values. + logical :: use_temperature !< If true, temperature and salinity are state variables. + type(EFP_type) :: fresh_water_in_EFP !< The total mass of fresh water added by surface fluxes on + !! this PE since the last time that write_energy was called [kg]. + type(EFP_type) :: net_salt_in_EFP !< The total salt added by surface fluxes on this PE since + !! the last time that write_energy was called [ppt kg]. + type(EFP_type) :: net_heat_in_EFP !< The total heat added by surface fluxes on this PE since + !! the last time that write_energy was called [J]. + type(EFP_type) :: heat_prev_EFP !< The total amount of heat in the ocean the last + !! time that write_energy was called [J]. + type(EFP_type) :: salt_prev_EFP !< The total amount of salt in the ocean the last + !! time that write_energy was called [ppt kg]. + type(EFP_type) :: mass_prev_EFP !< The total ocean mass the last time that + !! write_energy was called [kg]. + real :: dt_in_T !< The baroclinic dynamics time step [T ~> s]. + + type(time_type) :: energysavedays !< The interval between writing the energies + !! and other integral quantities of the run. + type(time_type) :: energysavedays_geometric !< The starting interval for computing a geometric + !! progression of time deltas between calls to + !! write_energy. This interval will increase by a factor of 2. + !! after each call to write_energy. + logical :: energysave_geometric !< Logical to control whether calls to write_energy should + !! follow a geometric progression + type(time_type) :: write_energy_time !< The next time to write to the energy file. + type(time_type) :: geometric_end_time !< Time at which to stop the geometric progression + !! of calls to write_energy and revert to the standard + !! energysavedays interval + + real :: timeunit !< The length of the units for the time axis and certain input parameters + !! including ENERGYSAVEDAYS [s]. + + logical :: date_stamped_output !< If true, use dates (not times) in messages to stdout. + type(time_type) :: Start_time !< The start time of the simulation. + ! Start_time is set in MOM_initialization.F90 + integer, pointer :: ntrunc => NULL() !< The number of times the velocity has been + !! truncated since the last call to write_energy. + real :: max_Energy !< The maximum permitted energy per unit mass. If there is + !! more energy than this, the model should stop [L2 T-2 ~> m2 s-2]. + integer :: maxtrunc !< The number of truncations per energy save + !! interval at which the run is stopped. + logical :: write_stocks !< If true, write the integrated tracer amounts + !! to stdout when the energy files are written. + integer :: previous_calls = 0 !< The number of times write_energy has been called. + integer :: prev_n = 0 !< The value of n from the last call. + type(MOM_netcdf_file) :: fileenergy_nc !< The file handle for the netCDF version of the energy file. + integer :: fileenergy_ascii !< The unit number of the ascii version of the energy file. + type(MOM_field), dimension(NUM_FIELDS+MAX_FIELDS_) :: & + fields !< fieldtype variables for the output fields. + character(len=200) :: energyfile !< The name of the energy file with path. +end type sum_output_CS + +contains + +!> MOM_sum_output_init initializes the parameters and settings for the MOM_sum_output module. +subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & + Input_start_time, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + character(len=*), intent(in) :: directory !< The directory where the energy file goes. + integer, target, intent(inout) :: ntrnc !< The integer that stores the number of times + !! the velocity has been truncated since the + !! last call to write_energy. + type(time_type), intent(in) :: Input_start_time !< The start time of the simulation. + type(Sum_output_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module. + ! Local variables + real :: maxvel ! The maximum permitted velocity [L T-1 ~> m s-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_sum_output" ! This module's name. + character(len=200) :: energyfile ! The name of the energy file. + character(len=32) :: filename_appendix = '' ! FMS appendix to filename for ensemble runs + + if (associated(CS)) then + call MOM_error(WARNING, "MOM_sum_output_init called with associated control structure.") + return + endif + allocate(CS) + + CS%initialized = .true. + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "CALCULATE_APE", CS%do_APE_calc, & + "If true, calculate the available potential energy of "//& + "the interfaces. Setting this to false reduces the "//& + "memory footprint of high-PE-count models dramatically.", & + default=.true.) + call get_param(param_file, mdl, "WRITE_STOCKS", CS%write_stocks, & + "If true, write the integrated tracer amounts to stdout "//& + "when the energy files are written.", default=.true.) + call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & + "If true, Temperature and salinity are used as state "//& + "variables.", default=.true.) + call get_param(param_file, mdl, "DT", CS%dt_in_T, & + "The (baroclinic) dynamics time step.", & + units="s", scale=US%s_to_T, fail_if_missing=.true.) + call get_param(param_file, mdl, "MAXTRUNC", CS%maxtrunc, & + "The run will be stopped, and the day set to a very "//& + "large value if the velocity is truncated more than "//& + "MAXTRUNC times between energy saves. Set MAXTRUNC to 0 "//& + "to stop if there is any truncation of velocities.", & + units="truncations save_interval-1", default=0) + + call get_param(param_file, mdl, "MAX_ENERGY", CS%max_Energy, & + "The maximum permitted average energy per unit mass; the "//& + "model will be stopped if there is more energy than "//& + "this. If zero or negative, this is set to 10*MAXVEL^2.", & + units="m2 s-2", default=0.0, scale=US%m_s_to_L_T**2) + if (CS%max_Energy <= 0.0) then + call get_param(param_file, mdl, "MAXVEL", maxvel, & + "The maximum velocity allowed before the velocity "//& + "components are truncated.", units="m s-1", default=3.0e8, scale=US%m_s_to_L_T) + CS%max_Energy = 10.0 * maxvel**2 + call log_param(param_file, mdl, "MAX_ENERGY as used", CS%max_Energy, & + units="m2 s-2", unscale=US%L_T_to_m_s**2) + endif + + call get_param(param_file, mdl, "ENERGYFILE", energyfile, & + "The file to use to write the energies and globally "//& + "summed diagnostics.", default="ocean.stats") + + !query fms_io if there is a filename_appendix (for ensemble runs) + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + energyfile = trim(energyfile) //'.'//trim(filename_appendix) + endif + + CS%energyfile = trim(slasher(directory))//trim(energyfile) + call log_param(param_file, mdl, "output_path/ENERGYFILE", CS%energyfile) +#ifdef STATSLABEL + CS%energyfile = trim(CS%energyfile)//"."//trim(adjustl(STATSLABEL)) +#endif + + call get_param(param_file, mdl, "DATE_STAMPED_STDOUT", CS%date_stamped_output, & + "If true, use dates (not times) in messages to stdout", & + default=.true.) + ! Note that the units of CS%Timeunit are the MKS units of [s]. + call get_param(param_file, mdl, "TIMEUNIT", CS%Timeunit, & + "The time unit in seconds a number of input fields", & + units="s", default=86400.0) + if (CS%Timeunit < 0.0) CS%Timeunit = 86400.0 + + if (CS%do_APE_calc) then + call get_param(param_file, mdl, "READ_DEPTH_LIST", CS%read_depth_list, & + "Read the depth list from a file if it exists or "//& + "create that file otherwise.", default=.false.) + call get_param(param_file, mdl, "DEPTH_LIST_MIN_INC", CS%D_list_min_inc, & + "The minimum increment between the depths of the "//& + "entries in the depth-list file.", & + units="m", default=1.0E-10, scale=US%m_to_Z) + if (CS%read_depth_list) then + call get_param(param_file, mdl, "DEPTH_LIST_FILE", CS%depth_list_file, & + "The name of the depth list file.", default="Depth_list.nc") + if (scan(CS%depth_list_file,'/') == 0) & + CS%depth_list_file = trim(slasher(directory))//trim(CS%depth_list_file) + + call get_param(param_file, mdl, "REQUIRE_DEPTH_LIST_CHECKSUMS", & + CS%require_depth_list_chksum, & + "Require that matching checksums be in Depth_list.nc "//& + "when reading the file.", default=.true.) + if (.not. CS%require_depth_list_chksum) & + call get_param(param_file, mdl, "UPDATE_DEPTH_LIST_CHECKSUMS", & + CS%update_depth_list_chksum, & + "Automatically update the Depth_list.nc file if the "//& + "checksums are missing or do not match current values.", & + default=.false.) + endif + + allocate(CS%lH(GV%ke)) + call depth_list_setup(G, GV, US, CS%DL, CS) + else + CS%DL%listsize = 1 + endif + + call get_param(param_file, mdl, "ENERGYSAVEDAYS",CS%energysavedays, & + "The interval in units of TIMEUNIT between saves of the "//& + "energies of the run and other globally summed diagnostics.",& + default=set_time(0,days=1), timeunit=CS%Timeunit) + call get_param(param_file, mdl, "ENERGYSAVEDAYS_GEOMETRIC",CS%energysavedays_geometric, & + "The starting interval in units of TIMEUNIT for the first call "//& + "to save the energies of the run and other globally summed diagnostics. "//& + "The interval increases by a factor of 2. after each call to write_energy.",& + default=set_time(seconds=0), timeunit=CS%Timeunit) + + if ((time_type_to_real(CS%energysavedays_geometric) > 0.) .and. & + (CS%energysavedays_geometric < CS%energysavedays)) then + CS%energysave_geometric = .true. + else + CS%energysave_geometric = .false. + endif + + CS%Start_time = Input_start_time + CS%ntrunc => ntrnc + +end subroutine MOM_sum_output_init + +!> MOM_sum_output_end deallocates memory used by the MOM_sum_output module. +subroutine MOM_sum_output_end(CS) + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. + if (associated(CS)) then + if (CS%do_APE_calc) then + deallocate(CS%DL%depth, CS%DL%area, CS%DL%vol_below) + deallocate(CS%lH) + endif + + deallocate(CS) + endif +end subroutine MOM_sum_output_end + +!> This subroutine calculates and writes the total model energy, the energy and +!! mass of each layer, and other globally integrated physical quantities. +subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forcing) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + type(time_type), intent(in) :: day !< The current model time. + integer, intent(in) :: n !< The time step number of the + !! current execution. + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. + type(tracer_flow_control_CS), pointer :: tracer_CSp !< Control structure with the tree of + !! all registered tracer packages + type(time_type), optional, intent(in) :: dt_forcing !< The forcing time step + + ! Local variables + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! The height of interfaces [Z ~> m]. + real :: areaTm(SZI_(G),SZJ_(G)) ! A masked version of areaT [L2 ~> m2]. + real :: KE(SZK_(GV)) ! The total kinetic energy of a layer [J]. + real :: PE(SZK_(GV)+1)! The available potential energy of an interface [J]. + real :: KE_tot ! The total kinetic energy [J]. + real :: PE_tot ! The total available potential energy [J]. + real :: Z_0APE(SZK_(GV)+1) ! The uniform depth which overlies the same + ! volume as is below an interface [Z ~> m]. + real :: H_0APE(SZK_(GV)+1) ! A version of Z_0APE, converted to m, usually positive [m]. + real :: toten ! The total kinetic & potential energies of + ! all layers [J] (i.e. kg m2 s-2). + real :: En_mass ! The total kinetic and potential energies divided by + ! the total mass of the ocean [m2 s-2]. + real :: vol_lay(SZK_(GV)) ! The volume of fluid in a layer [Z L2 ~> m3]. + real :: volbelow ! The volume of all layers beneath an interface [Z L2 ~> m3]. + real :: mass_lay(SZK_(GV)) ! The mass of fluid in a layer [kg]. + real :: mass_tot ! The total mass of the ocean [kg]. + real :: vol_tot ! The total ocean volume [m3]. + real :: mass_chg ! The change in total ocean mass of fresh water since + ! the last call to this subroutine [kg]. + real :: mass_anom ! The change in fresh water that cannot be accounted for + ! by the surface fluxes [kg]. + real :: Salt ! The total amount of salt in the ocean [ppt kg]. + real :: Salt_chg ! The change in total ocean salt since the last call + ! to this subroutine [ppt kg]. + real :: Salt_anom ! The change in salt that cannot be accounted for by + ! the surface fluxes [ppt kg]. + real :: salin ! The mean salinity of the ocean [ppt]. + real :: salin_anom ! The change in total salt that cannot be accounted for by + ! the surface fluxes divided by total mass [ppt]. + real :: Heat ! The total amount of Heat in the ocean [J]. + real :: Heat_chg ! The change in total ocean heat since the last call to this subroutine [J]. + real :: Heat_anom ! The change in heat that cannot be accounted for by the surface fluxes [J]. + real :: temp ! The mean potential temperature of the ocean [degC]. + real :: temp_anom ! The change in total heat that cannot be accounted for + ! by the surface fluxes, divided by the total heat + ! capacity of the ocean [degC]. + real :: hint ! The deviation of an interface from H [Z ~> m]. + real :: hbot ! 0 if the basin is deeper than H, or the + ! height of the basin depth over H otherwise [Z ~> m]. + ! This makes PE only include real fluid. + real :: hbelow ! The depth of fluid in all layers beneath an interface [Z ~> m]. + type(EFP_type) :: & + mass_EFP, & ! The total mass of the ocean in extended fixed point form [kg]. + salt_EFP, & ! The total amount of salt in the ocean in extended fixed point form [ppt kg]. + heat_EFP, & ! The total amount of heat in the ocean in extended fixed point form [J]. + salt_chg_EFP, & ! The change in total ocean salt since the last call to this subroutine [ppt kg]. + heat_chg_EFP, & ! The change in total ocean heat since the last call to this subroutine [J]. + mass_chg_EFP, & ! The change in total ocean mass of fresh water since + ! the last call to this subroutine [kg]. + salt_anom_EFP, & ! The change in salt that cannot be accounted for by the surface + ! fluxes [ppt kg]. + heat_anom_EFP, & ! The change in heat that cannot be accounted for by the surface fluxes [J]. + mass_anom_EFP ! The change in fresh water that cannot be accounted for by the surface + ! fluxes [kg]. + type(EFP_type), dimension(5) :: EFP_list ! An array of EFP types for joint global sums. + real :: CFL_Iarea ! Direction-based inverse area used in CFL test [L-2 ~> m-2]. + real :: CFL_trans ! A transport-based definition of the CFL number [nondim]. + real :: CFL_lin ! A simpler definition of the CFL number [nondim]. + real :: max_CFL(2) ! The maxima of the CFL numbers [nondim]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + tmp1 ! A temporary array used in reproducing sums [various] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + PE_pt ! The potential energy at each point [J]. + real, dimension(SZI_(G),SZJ_(G)) :: & + Temp_int, Salt_int ! Layer and cell integrated heat and salt [J] and [g Salt]. + real :: HL2_to_kg ! A conversion factor from a thickness-volume to mass [kg H-1 L-2 ~> kg m-3 or 1] + real :: KE_scale_factor ! The combination of unit rescaling factors in the kinetic energy + ! calculation [kg T2 H-1 L-2 s-2 ~> kg m-3 or 1] + real :: PE_scale_factor ! The combination of unit rescaling factors in the potential energy + ! calculation [kg T2 R-1 Z-1 L-2 s-2 ~> 1] + integer :: num_nc_fields ! The number of fields that will actually go into + ! the NetCDF file. + integer :: i, j, k, is, ie, js, je, nz, m, Isq, Ieq, Jsq, Jeq, isr, ier, jsr, jer + integer :: li, lbelow, labove ! indices of deep_area_vol, used to find Z_0APE. + ! lbelow & labove are lower & upper limits for li + ! in the search for the entry in lH to use. + integer :: start_of_day, num_days + real :: reday ! Time in units given by CS%Timeunit, but often [days] + character(len=240) :: energypath_nc + character(len=200) :: mesg + character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str + logical :: date_stamped + type(time_type) :: dt_force ! A time_type version of the forcing timestep. + ! The units of the tracer stock vary between tracers, with [conc] given explicitly by Tr_units. + real :: Tr_stocks(MAX_FIELDS_) ! The total amounts of each of the registered tracers [kg conc] + real :: Tr_min(MAX_FIELDS_) ! The global minimum unmasked value of the tracers [conc] + real :: Tr_max(MAX_FIELDS_) ! The global maximum unmasked value of the tracers [conc] + real :: Tr_min_x(MAX_FIELDS_) ! The x-positions of the global tracer minima + ! in the units of G%geoLonT, often [degrees_E] or [km] + real :: Tr_min_y(MAX_FIELDS_) ! The y-positions of the global tracer minima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: Tr_min_z(MAX_FIELDS_) ! The z-positions of the global tracer minima [layer] + real :: Tr_max_x(MAX_FIELDS_) ! The x-positions of the global tracer maxima + ! in the units of G%geoLonT, often [degrees_E] or [km] + real :: Tr_max_y(MAX_FIELDS_) ! The y-positions of the global tracer maxima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: Tr_max_z(MAX_FIELDS_) ! The z-positions of the global tracer maxima [layer] + logical :: Tr_minmax_avail(MAX_FIELDS_) ! A flag indicating whether the global minimum and + ! maximum information are available for each of the tracers + character(len=40), dimension(MAX_FIELDS_) :: & + Tr_names, & ! The short names for each of the tracers + Tr_units ! The units for each of the tracers + integer :: nTr_stocks ! The total number of tracers in all registered tracer packages + integer :: iyear, imonth, iday, ihour, iminute, isecond, itick ! For call to get_date() + + ! A description for output of each of the fields. + type(vardesc) :: vars(NUM_FIELDS+MAX_FIELDS_) + + ! write_energy_time is the next integral multiple of energysavedays. + dt_force = set_time(seconds=2) ; if (present(dt_forcing)) dt_force = dt_forcing + if (CS%previous_calls == 0) then + if (CS%energysave_geometric) then + if (CS%energysavedays_geometric < CS%energysavedays) then + CS%write_energy_time = day + CS%energysavedays_geometric + CS%geometric_end_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + else + CS%write_energy_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + endif + else + CS%write_energy_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + endif + elseif (day + (dt_force/2) <= CS%write_energy_time) then + return ! Do not write this step + else ! Determine the next write time before proceeding + if (CS%energysave_geometric) then + if (CS%write_energy_time + CS%energysavedays_geometric >= & + CS%geometric_end_time) then + CS%write_energy_time = CS%geometric_end_time + CS%energysave_geometric = .false. ! stop geometric progression + else + CS%write_energy_time = CS%write_energy_time + CS%energysavedays_geometric + endif + CS%energysavedays_geometric = CS%energysavedays_geometric*2 + else + CS%write_energy_time = CS%write_energy_time + CS%energysavedays + endif + endif + + num_nc_fields = 17 + if (.not.CS%use_temperature) num_nc_fields = 11 + vars(1) = var_desc("Ntrunc","Nondim","Number of Velocity Truncations",'1','1') + vars(2) = var_desc("En","Joules","Total Energy",'1','1') + vars(3) = var_desc("APE","Joules","Total Interface APE",'1','i') + vars(4) = var_desc("KE","Joules","Total Layer KE",'1','L') + vars(5) = var_desc("H0","meter","Zero APE Depth of Interface",'1','i') + vars(6) = var_desc("Mass_lay","kg","Total Layer Mass",'1','L') + vars(7) = var_desc("Mass","kg","Total Mass",'1','1') + vars(8) = var_desc("Mass_chg","kg","Total Mass Change between Entries",'1','1') + vars(9) = var_desc("Mass_anom","kg","Anomalous Total Mass Change",'1','1') + vars(10) = var_desc("max_CFL_trans","Nondim","Maximum finite-volume CFL",'1','1') + vars(11) = var_desc("max_CFL_lin","Nondim","Maximum finite-difference CFL",'1','1') + if (CS%use_temperature) then + vars(12) = var_desc("Salt","kg","Total Salt",'1','1') + vars(13) = var_desc("Salt_chg","kg","Total Salt Change between Entries",'1','1') + vars(14) = var_desc("Salt_anom","kg","Anomalous Total Salt Change",'1','1') + vars(15) = var_desc("Heat","Joules","Total Heat",'1','1') + vars(16) = var_desc("Heat_chg","Joules","Total Heat Change between Entries",'1','1') + vars(17) = var_desc("Heat_anom","Joules","Anomalous Total Heat Change",'1','1') + endif + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) + + HL2_to_kg = GV%H_to_kg_m2*US%L_to_m**2 + + if (.not.associated(CS)) call MOM_error(FATAL, & + "write_energy: Module must be initialized before it is used.") + + if (.not.CS%initialized) call MOM_error(FATAL, & + "write_energy: Module must be initialized before it is used.") + + do j=js,je ; do i=is,ie + areaTm(i,j) = G%mask2dT(i,j)*G%areaT(i,j) + enddo ; enddo + + if (GV%Boussinesq) then + tmp1(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + tmp1(i,j,k) = h(i,j,k) * (HL2_to_kg*areaTm(i,j)) + enddo ; enddo ; enddo + + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) + do k=1,nz ; vol_lay(k) = (US%m_to_L**2*GV%H_to_Z/GV%H_to_kg_m2)*mass_lay(k) ; enddo + else + tmp1(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) + enddo ; enddo ; enddo + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) + + if (CS%do_APE_calc) then + call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref) + do k=1,nz ; do j=js,je ; do i=is,ie + tmp1(i,j,k) = US%Z_to_m*US%L_to_m**2*(eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) + enddo ; enddo ; enddo + vol_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=vol_lay) + do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2 * vol_lay(k) ; enddo + endif + endif ! Boussinesq + + nTr_stocks = 0 + Tr_minmax_avail(:) = .false. + call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & + stock_units=Tr_units, num_stocks=nTr_stocks,& + got_min_max=Tr_minmax_avail, global_min=Tr_min, global_max=Tr_max, & + xgmin=Tr_min_x, ygmin=Tr_min_y, zgmin=Tr_min_z,& + xgmax=Tr_max_x, ygmax=Tr_max_y, zgmax=Tr_max_z) + if (nTr_stocks > 0) then + do m=1,nTr_stocks + vars(num_nc_fields+m) = var_desc(Tr_names(m), units=Tr_units(m), & + longname=Tr_names(m), hor_grid='1', z_grid='1') + enddo + num_nc_fields = num_nc_fields + nTr_stocks + endif + + if (CS%previous_calls == 0) then + + CS%mass_prev_EFP = mass_EFP + CS%fresh_water_in_EFP = real_to_EFP(0.0) + if (CS%use_temperature) then + CS%net_salt_in_EFP = real_to_EFP(0.0) ; CS%net_heat_in_EFP = real_to_EFP(0.0) + endif + + ! Reopen or create a text output file, with an explanatory header line. + if (is_root_pe()) then + if (day > CS%Start_time) then + call open_ASCII_file(CS%fileenergy_ascii, trim(CS%energyfile), action=APPEND_FILE) + else + call open_ASCII_file(CS%fileenergy_ascii, trim(CS%energyfile), action=WRITEONLY_FILE) + if (abs(CS%timeunit - 86400.0) < 1.0) then + if (CS%use_temperature) then + write(CS%fileenergy_ascii,'(" Step,",7x,"Day, Truncs, & + &Energy/Mass, Maximum CFL, Mean Sea Level, Total Mass, Mean Salin, & + &Mean Temp, Frac Mass Err, Salin Err, Temp Err")') + write(CS%fileenergy_ascii,'(12x,"[days]",17x,"[m2 s-2]",11x,"[Nondim]",7x,"[m]",13x,& + &"[kg]",9x,"[PSU]",6x,"[degC]",7x,"[Nondim]",8x,"[PSU]",8x,"[degC]")') + else + write(CS%fileenergy_ascii,'(" Step,",7x,"Day, Truncs, & + &Energy/Mass, Maximum CFL, Mean sea level, Total Mass, Frac Mass Err")') + write(CS%fileenergy_ascii,'(12x,"[days]",17x,"[m2 s-2]",11x,"[Nondim]",8x,"[m]",13x,& + &"[kg]",11x,"[Nondim]")') + endif + else + if ((CS%timeunit >= 0.99) .and. (CS%timeunit < 1.01)) then + time_units = " [seconds] " + elseif ((CS%timeunit >= 3599.0) .and. (CS%timeunit < 3601.0)) then + time_units = " [hours] " + elseif ((CS%timeunit >= 86399.0) .and. (CS%timeunit < 86401.0)) then + time_units = " [days] " + elseif ((CS%timeunit >= 3.0e7) .and. (CS%timeunit < 3.2e7)) then + time_units = " [years] " + else + write(time_units,'(9x,"[",es8.2," s] ")') CS%timeunit + endif + + if (CS%use_temperature) then + write(CS%fileenergy_ascii,'(" Step,",7x,"Time, Truncs, & + &Energy/Mass, Maximum CFL, Mean Sea Level, Total Mass, Mean Salin, & + &Mean Temp, Frac Mass Err, Salin Err, Temp Err")') + write(CS%fileenergy_ascii,'(A25,10x,"[m2 s-2]",11x,"[Nondim]",7x,"[m]",13x,& + &"[kg]",9x,"[PSU]",6x,"[degC]",7x,"[Nondim]",8x,"[PSU]",6x,& + &"[degC]")') time_units + else + write(CS%fileenergy_ascii,'(" Step,",7x,"Time, Truncs, & + &Energy/Mass, Maximum CFL, Mean sea level, Total Mass, Frac Mass Err")') + write(CS%fileenergy_ascii,'(A25,10x,"[m2 s-2]",11x,"[Nondim]",8x,"[m]",13x,& + &"[kg]",11x,"[Nondim]")') time_units + endif + endif + endif + + energypath_nc = trim(CS%energyfile) // ".nc" + if (day > CS%Start_time) then + call reopen_MOM_file(CS%fileenergy_nc, trim(energypath_nc), vars, & + num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, G=G, GV=GV) + else + call create_MOM_file(CS%fileenergy_nc, trim(energypath_nc), vars, & + num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, G=G, GV=GV) + endif + endif + endif + + if (CS%do_APE_calc) then + lbelow = 1 ; volbelow = 0.0 + do k=nz,1,-1 + volbelow = volbelow + vol_lay(k) + if ((volbelow >= CS%DL%vol_below(CS%lH(k))) .and. & + (volbelow < CS%DL%vol_below(CS%lH(k)+1))) then + li = CS%lH(k) + else + labove=CS%DL%listsize + li = (labove + lbelow) / 2 + do while (li > lbelow) + if (volbelow < CS%DL%vol_below(li)) then ; labove = li + else ; lbelow = li ; endif + li = (labove + lbelow) / 2 + enddo + CS%lH(k) = li + endif + lbelow = li + Z_0APE(K) = CS%DL%depth(li) - (volbelow - CS%DL%vol_below(li)) / CS%DL%area(li) + enddo + Z_0APE(nz+1) = CS%DL%depth(2) + + ! Calculate the Available Potential Energy integrated over each interface. With a nonlinear + ! equation of state or with a bulk mixed layer this calculation is only approximate. + ! With an ALE model this does not make sense and should be revisited. + PE_scale_factor = US%RZ_to_kg_m2*US%L_to_m**2*US%L_T_to_m_s**2 + PE_pt(:,:,:) = 0.0 + if (GV%Boussinesq) then + do j=js,je ; do i=is,ie + hbelow = 0.0 + do K=nz,1,-1 + hbelow = hbelow + h(i,j,k) * GV%H_to_Z + hint = Z_0APE(K) + (hbelow - (G%bathyT(i,j) + G%Z_ref)) + hbot = Z_0APE(K) - (G%bathyT(i,j) + G%Z_ref) + hbot = (hbot + ABS(hbot)) * 0.5 + PE_pt(i,j,K) = (0.5 * PE_scale_factor * areaTm(i,j)) * (GV%Rho0*GV%g_prime(K)) * & + (hint * hint - hbot * hbot) + enddo + enddo ; enddo + elseif (GV%semi_Boussinesq) then + do j=js,je ; do i=is,ie + do K=nz,1,-1 + hint = Z_0APE(K) + eta(i,j,K) ! eta and H_0 have opposite signs. + hbot = max(Z_0APE(K) - (G%bathyT(i,j) + G%Z_ref), 0.0) + PE_pt(i,j,K) = (0.5 * PE_scale_factor * areaTm(i,j) * (GV%Rho0*GV%g_prime(K))) * & + (hint * hint - hbot * hbot) + enddo + enddo ; enddo + else + do j=js,je ; do i=is,ie + do K=nz,2,-1 + hint = Z_0APE(K) + eta(i,j,K) ! eta and H_0 have opposite signs. + hbot = max(Z_0APE(K) - (G%bathyT(i,j) + G%Z_ref), 0.0) + PE_pt(i,j,K) = (0.25 * PE_scale_factor * areaTm(i,j) * & + ((GV%Rlay(k)+GV%Rlay(k-1))*GV%g_prime(K))) * & + (hint * hint - hbot * hbot) + enddo + hint = Z_0APE(1) + eta(i,j,1) ! eta and H_0 have opposite signs. + hbot = max(Z_0APE(1) - (G%bathyT(i,j) + G%Z_ref), 0.0) + PE_pt(i,j,1) = (0.5 * PE_scale_factor * areaTm(i,j) * (GV%Rlay(1)*GV%g_prime(1))) * & + (hint * hint - hbot * hbot) + enddo ; enddo + endif + + PE_tot = reproducing_sum(PE_pt, isr, ier, jsr, jer, sums=PE) + do k=1,nz+1 ; H_0APE(K) = US%Z_to_m*Z_0APE(K) ; enddo + else + PE_tot = 0.0 + do k=1,nz+1 ; PE(K) = 0.0 ; H_0APE(K) = 0.0 ; enddo + endif + +! Calculate the Kinetic Energy integrated over each layer. + KE_scale_factor = HL2_to_kg*US%L_T_to_m_s**2 + tmp1(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + tmp1(i,j,k) = (0.25 * KE_scale_factor * (areaTm(i,j) * h(i,j,k))) * & + ((u(I-1,j,k)**2 + u(I,j,k)**2) + (v(i,J-1,k)**2 + v(i,J,k)**2)) + enddo ; enddo ; enddo + + KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=KE) + + toten = KE_tot + PE_tot + + Salt = 0.0 ; Heat = 0.0 + if (CS%use_temperature) then + Temp_int(:,:) = 0.0 ; Salt_int(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + Salt_int(i,j) = Salt_int(i,j) + US%S_to_ppt*tv%S(i,j,k) * & + (h(i,j,k)*(HL2_to_kg * areaTm(i,j))) + Temp_int(i,j) = Temp_int(i,j) + (US%Q_to_J_kg*tv%C_p * tv%T(i,j,k)) * & + (h(i,j,k)*(HL2_to_kg * areaTm(i,j))) + enddo ; enddo ; enddo + salt_EFP = reproducing_sum_EFP(Salt_int, isr, ier, jsr, jer, only_on_PE=.true.) + heat_EFP = reproducing_sum_EFP(Temp_int, isr, ier, jsr, jer, only_on_PE=.true.) + + ! Combining the sums avoids multiple blocking all-PE updates. + EFP_list(1) = salt_EFP ; EFP_list(2) = heat_EFP ; EFP_list(3) = CS%fresh_water_in_EFP + EFP_list(4) = CS%net_salt_in_EFP ; EFP_list(5) = CS%net_heat_in_EFP + call EFP_sum_across_PEs(EFP_list, 5) + ! Return the globally summed values to the original variables. + salt_EFP = EFP_list(1) ; heat_EFP = EFP_list(2) ; CS%fresh_water_in_EFP = EFP_list(3) + CS%net_salt_in_EFP = EFP_list(4) ; CS%net_heat_in_EFP = EFP_list(5) + + Salt = EFP_to_real(salt_EFP) + Heat = EFP_to_real(heat_EFP) + else + call EFP_sum_across_PEs(CS%fresh_water_in_EFP) + endif + +! Calculate the maximum CFL numbers. + max_CFL(1:2) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + CFL_Iarea = G%IareaT(i,j) + if (u(I,j,k) < 0.0) & + CFL_Iarea = G%IareaT(i+1,j) + + CFL_trans = abs(u(I,j,k) * CS%dt_in_T) * (G%dy_Cu(I,j) * CFL_Iarea) + CFL_lin = abs(u(I,j,k) * CS%dt_in_T) * G%IdxCu(I,j) + max_CFL(1) = max(max_CFL(1), CFL_trans) + max_CFL(2) = max(max_CFL(2), CFL_lin) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + CFL_Iarea = G%IareaT(i,j) + if (v(i,J,k) < 0.0) & + CFL_Iarea = G%IareaT(i,j+1) + + CFL_trans = abs(v(i,J,k) * CS%dt_in_T) * (G%dx_Cv(i,J) * CFL_Iarea) + CFL_lin = abs(v(i,J,k) * CS%dt_in_T) * G%IdyCv(i,J) + max_CFL(1) = max(max_CFL(1), CFL_trans) + max_CFL(2) = max(max_CFL(2), CFL_lin) + enddo ; enddo ; enddo + + call sum_across_PEs(CS%ntrunc) + + call max_across_PEs(max_CFL, 2) + + if (CS%use_temperature) then + if (CS%previous_calls == 0) then + CS%salt_prev_EFP = salt_EFP ; CS%heat_prev_EFP = heat_EFP + endif + Salt_chg_EFP = Salt_EFP - CS%salt_prev_EFP + Salt_chg = EFP_to_real(Salt_chg_EFP) + Salt_anom_EFP = Salt_chg_EFP - CS%net_salt_in_EFP + Salt_anom = EFP_to_real(Salt_anom_EFP) + Heat_chg_EFP = Heat_EFP - CS%heat_prev_EFP + Heat_chg = EFP_to_real(Heat_chg_EFP) + Heat_anom_EFP = Heat_chg_EFP - CS%net_heat_in_EFP + Heat_anom = EFP_to_real(Heat_anom_EFP) + endif + + mass_chg_EFP = mass_EFP - CS%mass_prev_EFP + mass_anom_EFP = mass_chg_EFP - CS%fresh_water_in_EFP + mass_anom = EFP_to_real(mass_anom_EFP) + if (CS%use_temperature .and. .not.GV%Boussinesq) then + ! net_salt_input needs to be converted from ppt m s-1 to kg m-2 s-1. + mass_anom = mass_anom - 0.001*EFP_to_real(CS%net_salt_in_EFP) + endif + mass_chg = EFP_to_real(mass_chg_EFP) + + if (CS%use_temperature) then + salin = Salt / mass_tot + salin_anom = Salt_anom / mass_tot + ! salin_chg = Salt_chg / mass_tot + temp = heat / (mass_tot*US%Q_to_J_kg*US%degC_to_C*tv%C_p) + temp_anom = Heat_anom / (mass_tot*US%Q_to_J_kg*US%degC_to_C*tv%C_p) + endif + En_mass = toten / mass_tot + + call get_time(day, start_of_day, num_days) + date_stamped = (CS%date_stamped_output .and. (get_calendar_type() /= NO_CALENDAR)) + if (date_stamped) & + call get_date(day, iyear, imonth, iday, ihour, iminute, isecond, itick) + if (abs(CS%timeunit - 86400.0) < 1.0) then + reday = REAL(num_days)+ (REAL(start_of_day)/86400.0) + mesg_intro = "MOM Day " + else + reday = REAL(num_days)*(86400.0/CS%timeunit) + & + REAL(start_of_day)/abs(CS%timeunit) + mesg_intro = "MOM Time " + endif + if (reday < 1.0e8) then ; write(day_str, '(F12.3)') reday + elseif (reday < 1.0e11) then ; write(day_str, '(F15.3)') reday + else ; write(day_str, '(ES15.9)') reday ; endif + + if (n < 1000000) then ; write(n_str, '(I6)') n + elseif (n < 10000000) then ; write(n_str, '(I7)') n + elseif (n < 100000000) then ; write(n_str, '(I8)') n + else ; write(n_str, '(I10)') n ; endif + + if (date_stamped) then + write(date_str,'("MOM Date",i7,2("/",i2.2)," ",i2.2,2(":",i2.2))') & + iyear, imonth, iday, ihour, iminute, isecond + else + date_str = trim(mesg_intro)//trim(day_str) + endif + + if (is_root_pe()) then ! Only the root PE actually writes anything. + if (CS%use_temperature) then + write(stdout,'(A," ",A,": En ",ES12.6, ", MaxCFL ", F8.5, ", Mass ", & + & ES18.12, ", Salt ", F15.11,", Temp ", F15.11)') & + trim(date_str), trim(n_str), En_mass, max_CFL(1), mass_tot, salin, temp + else + write(stdout,'(A," ",A,": En ",ES12.6, ", MaxCFL ", F8.5, ", Mass ", & + & ES18.12)') & + trim(date_str), trim(n_str), En_mass, max_CFL(1), mass_tot + endif + + if (CS%use_temperature) then + write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, & + &", CFL ", F8.5, ", SL ",& + &es11.4,", M ",ES11.5,", S",f8.4,", T",f8.4,& + &", Me ",ES9.2,", Se ",ES9.2,", Te ",ES9.2)') & + trim(n_str), trim(day_str), CS%ntrunc, En_mass, max_CFL(1), & + -H_0APE(1), mass_tot, salin, temp, mass_anom/mass_tot, salin_anom, & + temp_anom + else + write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, & + &", CFL ", F8.5, ", SL ",& + &ES11.4,", Mass ",ES11.5,", Me ",ES9.2)') & + trim(n_str), trim(day_str), CS%ntrunc, En_mass, max_CFL(1), & + -H_0APE(1), mass_tot, mass_anom/mass_tot + endif + + if (CS%ntrunc > 0) then + write(stdout,'(A," Energy/Mass:",ES12.5," Truncations ",I0)') & + trim(date_str), En_mass, CS%ntrunc + endif + + if (CS%write_stocks) then + write(stdout,'(" Total Energy: ",Z16.16,ES24.16)') toten, toten + write(stdout,'(" Total Mass: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & + mass_tot, mass_chg, mass_anom, mass_anom/mass_tot + if (CS%use_temperature) then + if (Salt == 0.) then + write(stdout,'(" Total Salt: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5)') & + Salt*0.001, Salt_chg*0.001, Salt_anom*0.001 + else + write(stdout,'(" Total Salt: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & + Salt*0.001, Salt_chg*0.001, Salt_anom*0.001, Salt_anom/Salt + endif + if (Heat == 0.) then + write(stdout,'(" Total Heat: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5)') & + Heat, Heat_chg, Heat_anom + else + write(stdout,'(" Total Heat: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & + Heat, Heat_chg, Heat_anom, Heat_anom/Heat + endif + endif + do m=1,nTr_stocks + + write(stdout,'(" Total ",a,": ",ES24.16,1X,a)') & + trim(Tr_names(m)), Tr_stocks(m), trim(Tr_units(m)) + + if (Tr_minmax_avail(m)) then + write(stdout,'(64X,"Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + Tr_min(m),Tr_min_x(m),Tr_min_y(m),Tr_min_z(m) + write(stdout,'(64X,"Global Max:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + Tr_max(m),Tr_max_x(m),Tr_max_y(m),Tr_max_z(m) + endif + + enddo + endif + + call CS%fileenergy_nc%write_field(CS%fields(1), real(CS%ntrunc), reday) + call CS%fileenergy_nc%write_field(CS%fields(2), toten, reday) + call CS%fileenergy_nc%write_field(CS%fields(3), PE, reday) + call CS%fileenergy_nc%write_field(CS%fields(4), KE, reday) + call CS%fileenergy_nc%write_field(CS%fields(5), H_0APE, reday) + call CS%fileenergy_nc%write_field(CS%fields(6), mass_lay, reday) + + call CS%fileenergy_nc%write_field(CS%fields(7), mass_tot, reday) + call CS%fileenergy_nc%write_field(CS%fields(8), mass_chg, reday) + call CS%fileenergy_nc%write_field(CS%fields(9), mass_anom, reday) + call CS%fileenergy_nc%write_field(CS%fields(10), max_CFL(1), reday) + call CS%fileenergy_nc%write_field(CS%fields(11), max_CFL(2), reday) + if (CS%use_temperature) then + call CS%fileenergy_nc%write_field(CS%fields(12), 0.001*Salt, reday) + call CS%fileenergy_nc%write_field(CS%fields(13), 0.001*salt_chg, reday) + call CS%fileenergy_nc%write_field(CS%fields(14), 0.001*salt_anom, reday) + call CS%fileenergy_nc%write_field(CS%fields(15), Heat, reday) + call CS%fileenergy_nc%write_field(CS%fields(16), heat_chg, reday) + call CS%fileenergy_nc%write_field(CS%fields(17), heat_anom, reday) + do m=1,nTr_stocks + call CS%fileenergy_nc%write_field(CS%fields(17+m), Tr_stocks(m), reday) + enddo + else + do m=1,nTr_stocks + call CS%fileenergy_nc%write_field(CS%fields(11+m), Tr_stocks(m), reday) + enddo + endif + + call CS%fileenergy_nc%flush() + endif ! Only the root PE actually writes anything. + + if (is_NaN(En_mass)) then + call MOM_error(FATAL, "write_energy : NaNs in total model energy forced model termination.") + elseif (En_mass > US%L_T_to_m_s**2*CS%max_Energy) then + write(mesg,'("Energy per unit mass of ",ES11.4," exceeds ",ES11.4)') & + En_mass, US%L_T_to_m_s**2*CS%max_Energy + call MOM_error(FATAL, "write_energy : Excessive energy per unit mass forced model termination.") + endif + if (CS%ntrunc>CS%maxtrunc) then + call MOM_error(FATAL, "write_energy : Ocean velocity has been truncated too many times.") + endif + CS%ntrunc = 0 + CS%previous_calls = CS%previous_calls + 1 + + CS%mass_prev_EFP = mass_EFP ; CS%fresh_water_in_EFP = real_to_EFP(0.0) + if (CS%use_temperature) then + CS%salt_prev_EFP = Salt_EFP ; CS%net_salt_in_EFP = real_to_EFP(0.0) + CS%heat_prev_EFP = Heat_EFP ; CS%net_heat_in_EFP = real_to_EFP(0.0) + endif + +end subroutine write_energy + +!> This subroutine accumulates the net input of volume, salt and heat, through +!! the ocean surface for use in diagnosing conservation. +subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) + type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible + !! forcing fields. Unused fields are unallocated. + type(surface), intent(in) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, intent(in) :: dt !< The amount of time over which to average [T ~> s]. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Sum_output_CS), pointer :: CS !< The control structure returned by a previous call + !! to MOM_sum_output_init. + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + FW_in, & ! The net fresh water input, integrated over a timestep [kg]. + salt_in, & ! The total salt added by surface fluxes, integrated + ! over a time step [ppt kg]. + heat_in ! The total heat added by surface fluxes, integrated + ! over a time step [J]. + real :: RZL2_to_kg ! A combination of scaling factors for mass [kg R-1 Z-1 L-2 ~> 1] + real :: QRZL2_to_J ! A combination of scaling factors for heat [J Q-1 R-1 Z-1 L-2 ~> 1] + + type(EFP_type) :: & + FW_in_EFP, & ! The net fresh water input, integrated over a timestep + ! and summed over space [kg]. + salt_in_EFP, & ! The total salt added by surface fluxes, integrated + ! over a time step and summed over space [ppt kg]. + heat_in_EFP ! The total heat added by boundary fluxes, integrated + ! over a time step and summed over space [J]. + + integer :: i, j, is, ie, js, je, isr, ier, jsr, jer + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + RZL2_to_kg = US%L_to_m**2*US%RZ_to_kg_m2 + QRZL2_to_J = RZL2_to_kg*US%Q_to_J_kg + + FW_in(:,:) = 0.0 + if (associated(fluxes%evap)) then + if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then + do j=js,je ; do i=is,ie + FW_in(i,j) = RZL2_to_kg * dt*G%areaT(i,j)*(fluxes%evap(i,j) + & + (((fluxes%lprec(i,j) + fluxes%vprec(i,j)) + fluxes%lrunoff(i,j)) + & + (fluxes%fprec(i,j) + fluxes%frunoff(i,j)))) + enddo ; enddo + else + call MOM_error(WARNING, & + "accumulate_net_input called with associated evap field, but no precip field.") + endif + endif + + if (associated(fluxes%seaice_melt)) then ; do j=js,je ; do i=is,ie + FW_in(i,j) = FW_in(i,j) + RZL2_to_kg*dt * & + G%areaT(i,j) * fluxes%seaice_melt(i,j) + enddo ; enddo ; endif + + salt_in(:,:) = 0.0 ; heat_in(:,:) = 0.0 + if (CS%use_temperature) then + + if (associated(fluxes%sw)) then ; do j=js,je ; do i=is,ie + heat_in(i,j) = heat_in(i,j) + dt * QRZL2_to_J * G%areaT(i,j) * (fluxes%sw(i,j) + & + (fluxes%lw(i,j) + (fluxes%latent(i,j) + fluxes%sens(i,j)))) + enddo ; enddo ; endif + + if (associated(fluxes%seaice_melt_heat)) then ; do j=js,je ; do i=is,ie + heat_in(i,j) = heat_in(i,j) + dt * QRZL2_to_J * G%areaT(i,j) * & + fluxes%seaice_melt_heat(i,j) + enddo ; enddo ; endif + + ! smg: new code + ! include heat content from water transport across ocean surface +! if (associated(fluxes%heat_content_lprec)) then ; do j=js,je ; do i=is,ie +! heat_in(i,j) = heat_in(i,j) + dt * QRZL2_to_J * G%areaT(i,j) * & +! (fluxes%heat_content_lprec(i,j) + (fluxes%heat_content_fprec(i,j) & +! + (fluxes%heat_content_lrunoff(i,j) + (fluxes%heat_content_frunoff(i,j) & +! + (fluxes%heat_content_cond(i,j) + (fluxes%heat_content_vprec(i,j) & +! + fluxes%heat_content_massout(i,j))))))) +! enddo ; enddo ; endif + + ! smg: old code + if (associated(fluxes%heat_content_evap)) then + do j=js,je ; do i=is,ie + heat_in(i,j) = heat_in(i,j) + dt * QRZL2_to_J * G%areaT(i,j) * & + (fluxes%heat_content_evap(i,j) + fluxes%heat_content_lprec(i,j) + & + fluxes%heat_content_cond(i,j) + fluxes%heat_content_fprec(i,j) + & + fluxes%heat_content_lrunoff(i,j) + fluxes%heat_content_frunoff(i,j)) + enddo ; enddo + elseif (associated(tv%TempxPmE)) then + do j=js,je ; do i=is,ie + heat_in(i,j) = heat_in(i,j) + (tv%C_p * QRZL2_to_J*G%areaT(i,j)) * tv%TempxPmE(i,j) + enddo ; enddo + elseif (associated(fluxes%evap)) then + do j=js,je ; do i=is,ie + heat_in(i,j) = heat_in(i,j) + (US%Q_to_J_kg*tv%C_p * sfc_state%SST(i,j)) * FW_in(i,j) + enddo ; enddo + endif + + ! The following heat sources may or may not be used. + if (associated(tv%internal_heat)) then + do j=js,je ; do i=is,ie + heat_in(i,j) = heat_in(i,j) + (tv%C_p * QRZL2_to_J*G%areaT(i,j)) * tv%internal_heat(i,j) + enddo ; enddo + endif + if (associated(tv%frazil)) then ; do j=js,je ; do i=is,ie + heat_in(i,j) = heat_in(i,j) + QRZL2_to_J * G%areaT(i,j) * tv%frazil(i,j) + enddo ; enddo ; endif + if (associated(fluxes%heat_added)) then ; do j=js,je ; do i=is,ie + heat_in(i,j) = heat_in(i,j) + QRZL2_to_J * dt*G%areaT(i,j) * fluxes%heat_added(i,j) + enddo ; enddo ; endif +! if (associated(sfc_state%sw_lost)) then ; do j=js,je ; do i=is,ie +! heat_in(i,j) = heat_in(i,j) - US%L_to_m**2*G%areaT(i,j) * sfc_state%sw_lost(i,j) +! enddo ; enddo ; endif + + if (associated(fluxes%salt_flux)) then ; do j=js,je ; do i=is,ie + ! integrate salt_flux in [R Z T-1 ~> kgSalt m-2 s-1] to give [ppt kg] + salt_in(i,j) = RZL2_to_kg * dt * & + G%areaT(i,j)*(1000.0*fluxes%salt_flux(i,j)) + enddo ; enddo ; endif + endif + + if ((CS%use_temperature) .or. associated(fluxes%lprec) .or. & + associated(fluxes%evap)) then + ! The on-PE sums are stored here, but the sums across PEs are deferred to + ! the next call to write_energy to avoid extra barriers. + isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) + FW_in_EFP = reproducing_sum_EFP(FW_in, isr, ier, jsr, jer, only_on_PE=.true.) + heat_in_EFP = reproducing_sum_EFP(heat_in, isr, ier, jsr, jer, only_on_PE=.true.) + salt_in_EFP = reproducing_sum_EFP(salt_in, isr, ier, jsr, jer, only_on_PE=.true.) + + CS%fresh_water_in_EFP = CS%fresh_water_in_EFP + FW_in_EFP + CS%net_salt_in_EFP = CS%net_salt_in_EFP + salt_in_EFP + CS%net_heat_in_EFP = CS%net_heat_in_EFP + heat_in_EFP + endif + +end subroutine accumulate_net_input + +!> This subroutine sets up an ordered list of depths, along with the +!! cross sectional areas at each depth and the volume of fluid deeper +!! than each depth. This might be read from a previously created file +!! or it might be created anew. (For now only new creation occurs. +subroutine depth_list_setup(G, GV, US, DL, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Depth_List), intent(inout) :: DL !< The list of depths, areas and volumes to set up + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. + ! Local variables + logical :: valid_DL_read + integer :: k + + if (CS%read_depth_list) then + if (file_exists(CS%depth_list_file)) then + if (CS%update_depth_list_chksum) then + call read_depth_list(G, US, DL, CS%depth_list_file, & + require_chksum=CS%require_depth_list_chksum, file_matches=valid_DL_read) + else + call read_depth_list(G, US, DL, CS%depth_list_file, require_chksum=CS%require_depth_list_chksum) + valid_DL_read = .true. ! Otherwise there would have been a fatal error. + endif + else + if (is_root_pe()) call MOM_error(NOTE, "depth_list_setup: "// & + trim(CS%depth_list_file)//" does not exist. Creating a new file.") + valid_DL_read = .false. + endif + + if (.not.valid_DL_read) then + call create_depth_list(G, DL, CS%D_list_min_inc) + call write_depth_list(G, US, DL, CS%depth_list_file) + endif + else + call create_depth_list(G, DL, CS%D_list_min_inc) + endif + + do k=1,GV%ke + CS%lH(k) = DL%listsize-1 + enddo + +end subroutine depth_list_setup + +!> create_depth_list makes an ordered list of depths, along with the cross +!! sectional areas at each depth and the volume of fluid deeper than each depth. +subroutine create_depth_list(G, DL, min_depth_inc) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(Depth_List), intent(inout) :: DL !< The list of depths, areas and volumes to create + real, intent(in) :: min_depth_inc !< The minimum increment between depths in the list [Z ~> m] + + ! Local variables + real, dimension(G%Domain%niglobal*G%Domain%njglobal + 1) :: & + Dlist, & !< The global list of bottom depths [Z ~> m]. + AreaList !< The global list of cell areas [L2 ~> m2]. + integer, dimension(G%Domain%niglobal*G%Domain%njglobal+1) :: & + indx2 !< The position of an element in the original unsorted list. + real :: Dnow !< The depth now being considered for sorting [Z ~> m]. + real :: Dprev !< The most recent depth that was considered [Z ~> m]. + real :: vol !< The running sum of open volume below a depth [Z L2 ~> m3]. + real :: area !< The open area at the current depth [L2 ~> m2]. + real :: D_list_prev !< The most recent depth added to the list [Z ~> m]. + logical :: add_to_list !< This depth should be included as an entry on the list. + + integer :: ir, indxt + integer :: mls, list_size + integer :: list_pos, i_global, j_global + integer :: i, j, k, kl + + mls = G%Domain%niglobal*G%Domain%njglobal + +! Need to collect the global data from compute domains to a 1D array for sorting. + Dlist(:) = 0.0 + Arealist(:) = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! Set global indices that start the global domain at 1 (Fortran convention). + j_global = j + G%jdg_offset - (G%jsg-1) + i_global = i + G%idg_offset - (G%isg-1) + + list_pos = (j_global-1)*G%Domain%niglobal + i_global + Dlist(list_pos) = G%bathyT(i,j) + G%Z_ref + Arealist(list_pos) = G%mask2dT(i,j) * G%areaT(i,j) + enddo ; enddo + + ! These sums reproduce across PEs because the arrays are only nonzero on one PE. + call sum_across_PEs(Dlist, mls+1) + call sum_across_PEs(Arealist, mls+1) + + do j=1,mls+1 ; indx2(j) = j ; enddo + k = mls / 2 + 1 ; ir = mls + do + if (k > 1) then + k = k - 1 + indxt = indx2(k) + Dnow = Dlist(indxt) + else + indxt = indx2(ir) + Dnow = Dlist(indxt) + indx2(ir) = indx2(1) + ir = ir - 1 + if (ir == 1) then ; indx2(1) = indxt ; exit ; endif + endif + i=k ; j=k*2 + do ; if (j > ir) exit + if (j < ir .AND. Dlist(indx2(j)) < Dlist(indx2(j+1))) j = j + 1 + if (Dnow < Dlist(indx2(j))) then ; indx2(i) = indx2(j) ; i = j ; j = j + i + else ; j = ir+1 ; endif + enddo + indx2(i) = indxt + enddo + +! At this point, the lists should perhaps be culled to save memory. +! Culling: (1) identical depths (e.g. land) - take the last one. +! (2) the topmost and bottommost depths are always saved. +! (3) very close depths +! (4) equal volume changes. + + ! Count the unique elements in the list. + D_list_prev = Dlist(indx2(mls)) + list_size = 2 + do k=mls-1,1,-1 + if (Dlist(indx2(k)) < D_list_prev-min_depth_inc) then + list_size = list_size + 1 + D_list_prev = Dlist(indx2(k)) + endif + enddo + + DL%listsize = list_size+1 + allocate(DL%depth(DL%listsize), DL%area(DL%listsize), DL%vol_below(DL%listsize)) + + vol = 0.0 ; area = 0.0 + Dprev = Dlist(indx2(mls)) + D_list_prev = Dprev + + kl = 0 + do k=mls,1,-1 + i = indx2(k) + vol = vol + area * (Dprev - Dlist(i)) + area = area + AreaList(i) + + add_to_list = .false. + if ((kl == 0) .or. (k==1)) then + add_to_list = .true. + elseif (Dlist(indx2(k-1)) < D_list_prev-min_depth_inc) then + add_to_list = .true. + D_list_prev = Dlist(indx2(k-1)) + endif + + if (add_to_list) then + kl = kl+1 + DL%depth(kl) = Dlist(i) + DL%area(kl) = area + DL%vol_below(kl) = vol + endif + Dprev = Dlist(i) + enddo + + do while (kl+1 < DL%listsize) + ! I don't understand why this is needed... RWH + kl = kl+1 + DL%vol_below(kl) = DL%vol_below(kl-1) * 1.000001 + DL%area(kl) = DL%area(kl-1) + DL%depth(kl) = DL%depth(kl-1) + enddo + + DL%vol_below(DL%listsize) = DL%vol_below(DL%listsize-1) * 1000.0 + DL%area(DL%listsize) = DL%area(DL%listsize-1) + DL%depth(DL%listsize) = DL%depth(DL%listsize-1) + +end subroutine create_depth_list + +!> This subroutine writes out the depth list to the specified file. +subroutine write_depth_list(G, US, DL, filename) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Depth_List), intent(in) :: DL !< The list of depths, areas and volumes to write + character(len=*), intent(in) :: filename !< The path to the depth list file to write. + + ! Local variables + type(vardesc), dimension(:), allocatable :: & + vars ! Types that described the staggering and metadata for the fields + type(MOM_field), dimension(:), allocatable :: & + fields ! Types with metadata about the variables that will be written + type(axis_info), dimension(:), allocatable :: & + extra_axes ! Descriptors for extra axes that might be used + type(attribute_info), dimension(:), allocatable :: & + global_atts ! Global attributes and their values + type(MOM_netcdf_file) :: IO_handle ! The I/O handle of the fileset + character(len=16) :: depth_chksum, area_chksum + + ! All ranks are required to compute the global checksum + call get_depth_list_checksums(G, US, depth_chksum, area_chksum) + + if (.not.is_root_pe()) return + + allocate(vars(3)) + allocate(fields(3)) + allocate(extra_axes(1)) + allocate(global_atts(2)) + + call set_axis_info(extra_axes(1), "list", ax_size=DL%listsize) + vars(1) = var_desc("depth", "m", "Sorted depth", '1', dim_names=(/"list"/), fixed=.true.) + vars(2) = var_desc("area", "m2", "Open area at depth", '1', dim_names=(/"list"/), fixed=.true.) + vars(3) = var_desc("vol_below", "m3", "Open volume below depth", '1', dim_names=(/"list"/), fixed=.true.) + call set_attribute_info(global_atts(1), depth_chksum_attr, depth_chksum) + call set_attribute_info(global_atts(2), area_chksum_attr, area_chksum) + + call create_MOM_file(IO_handle, filename, vars, 3, fields, SINGLE_FILE, & + extra_axes=extra_axes, global_atts=global_atts) + call MOM_write_field(IO_handle, fields(1), DL%depth, scale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(2), DL%area, scale=US%L_to_m**2) + call MOM_write_field(IO_handle, fields(3), DL%vol_below, scale=US%Z_to_m*US%L_to_m**2) + + call delete_axis_info(extra_axes) + call delete_attribute_info(global_atts) + deallocate(vars, extra_axes, fields, global_atts) + call IO_handle%close() +end subroutine write_depth_list + +!> This subroutine reads in the depth list from the specified file +!! and allocates the memory within and sets up DL. +subroutine read_depth_list(G, US, DL, filename, require_chksum, file_matches) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Depth_List), intent(inout) :: DL !< The list of depths, areas and volumes + character(len=*), intent(in) :: filename !< The path to the depth list file to read. + logical, intent(in) :: require_chksum !< If true, missing or mismatched depth + !! and area checksums result in a fatal error. + logical, optional, intent(out) :: file_matches !< If present, this indicates whether the file + !! has been read with matching depth and area checksums + + ! Local variables + character(len=240) :: var_msg + integer :: list_size, ndim, sizes(4) + character(len=:), allocatable :: depth_file_chksum, area_file_chksum + character(len=16) :: depth_grid_chksum, area_grid_chksum + logical :: depth_att_found, area_att_found + + ! Check bathymetric consistency between this configuration and the depth list file. + call read_attribute(filename, depth_chksum_attr, depth_file_chksum, found=depth_att_found) + call read_attribute(filename, area_chksum_attr, area_file_chksum, found=area_att_found) + + if ((.not.depth_att_found) .or. (.not.area_att_found)) then + var_msg = trim(filename) // " checksums are missing;" + if (require_chksum) then + call MOM_error(FATAL, trim(var_msg) // " aborting.") + elseif (present(file_matches)) then + call MOM_error(WARNING, trim(var_msg) // " updating file.") + file_matches = .false. + return + else + call MOM_error(WARNING, trim(var_msg) // " some diagnostics may not be reproducible.") + endif + else + call get_depth_list_checksums(G, US, depth_grid_chksum, area_grid_chksum) + + if ((trim(depth_grid_chksum) /= trim(depth_file_chksum)) .or. & + (trim(area_grid_chksum) /= trim(area_file_chksum)) ) then + var_msg = trim(filename) // " checksums do not match;" + if (require_chksum) then + call MOM_error(FATAL, trim(var_msg) // " aborting.") + elseif (present(file_matches)) then + call MOM_error(WARNING, trim(var_msg) // " updating file.") + file_matches = .false. + return + else + call MOM_error(WARNING, trim(var_msg) // " some diagnostics may not be reproducible.") + endif + endif + endif + if (allocated(area_file_chksum)) deallocate(area_file_chksum) + if (allocated(depth_file_chksum)) deallocate(depth_file_chksum) + + ! Get the length of the list. + call field_size(filename, "depth", sizes, ndims=ndim) + if (ndim /= 1) call MOM_ERROR(FATAL, "MOM_sum_output read_depth_list: depth in "//& + trim(filename)//" has too many or too few dimensions.") + list_size = sizes(1) + + DL%listsize = list_size + allocate(DL%depth(list_size), DL%area(list_size), DL%vol_below(list_size)) + + call read_variable(filename, "depth", DL%depth, scale=US%m_to_Z) + call read_variable(filename, "area", DL%area, scale=US%m_to_L**2) + call read_variable(filename, "vol_below", DL%vol_below, scale=US%m_to_Z*US%m_to_L**2) + + if (present(file_matches)) file_matches = .true. + +end subroutine read_depth_list + + +!> Return the checksums required to verify DEPTH_LIST_FILE contents. +!! +!! This function computes checksums for the bathymetry (G%bathyT) and masked +!! area (mask2dT * areaT) fields of the model grid G, which are used to compute +!! the depth list. A difference in checksum indicates that a different method +!! was used to compute the grid data, and that any results using the depth +!! list, such as APE, will not be reproducible. +!! +!! Checksums are saved as hexadecimal strings, in order to avoid potential +!! datatype issues with netCDF attributes. +subroutine get_depth_list_checksums(G, US, depth_chksum, area_chksum) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + character(len=16), intent(out) :: depth_chksum !< Depth checksum hexstring + character(len=16), intent(out) :: area_chksum !< Area checksum hexstring + + integer :: i, j + real, allocatable :: field(:,:) ! A temporary array for output converted to MKS units [m] or [m2] + + allocate(field(G%isc:G%iec, G%jsc:G%jec)) + + ! Depth checksum + do j=G%jsc,G%jec ; do i=G%isc,G%iec + field(i,j) = US%Z_to_m*(G%bathyT(i,j) + G%Z_ref) + enddo ; enddo + write(depth_chksum, '(Z16)') field_chksum(field(:,:)) + + ! Area checksum + do j=G%jsc,G%jec ; do i=G%isc,G%iec + field(i,j) = G%mask2dT(i,j) * US%L_to_m**2*G%areaT(i,j) + enddo ; enddo + write(area_chksum, '(Z16)') field_chksum(field(:,:)) + + deallocate(field) +end subroutine get_depth_list_checksums + +!> \namespace mom_sum_output +!! +!! By Robert Hallberg, April 1994 - June 2002 +!! +!! This file contains the subroutine (write_energy) that writes +!! horizontally integrated quantities, such as energies and layer +!! volumes, and other summary information to an output file. Some +!! of these quantities (APE or resting interface height) are defined +!! relative to the global histogram of topography. The subroutine +!! that compiles that histogram (depth_list_setup) is also included +!! in this file. +!! +!! In addition, if the number of velocity truncations since the +!! previous call to write_energy exceeds maxtrunc or the total energy +!! exceeds a very large threshold, a fatal termination is triggered. + +end module MOM_sum_output diff --git a/diagnostics/MOM_wave_speed.F90 b/diagnostics/MOM_wave_speed.F90 new file mode 100644 index 0000000000..5caf47a51c --- /dev/null +++ b/diagnostics/MOM_wave_speed.F90 @@ -0,0 +1,1757 @@ +!> Routines for calculating baroclinic wave speeds +module MOM_wave_speed + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : log_version +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h, interpolate_column +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs, calculate_specific_vol_derivs + +implicit none ; private + +#include + +public wave_speed, wave_speeds, wave_speed_init, wave_speed_set_param + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure for MOM_wave_speed +type, public :: wave_speed_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: use_ebt_mode = .false. !< If true, calculate the equivalent barotropic wave speed instead + !! of the first baroclinic wave speed. + !! This parameter controls the default behavior of wave_speed() which + !! can be overridden by optional arguments. + logical :: better_cg1_est = .false. !< If true, use an improved estimate of the first mode + !! internal wave speed. + real :: mono_N2_column_fraction = 0. !< The lower fraction of water column over which N2 is limited as + !! monotonic for the purposes of calculating the equivalent barotropic + !! wave speed [nondim]. This parameter controls the default behavior of + !! wave_speed() which can be overridden by optional arguments. + real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of + !! calculating the equivalent barotropic wave speed [H ~> m or kg m-2]. + !! If this parameter is negative, this limiting does not occur. + !! This parameter controls the default behavior of wave_speed() which + !! can be overridden by optional arguments. + real :: min_speed2 = 0. !< The minimum mode 1 internal wave speed squared [L2 T-2 ~> m2 s-2] + real :: wave_speed_tol = 0.001 !< The fractional tolerance with which to solve for the wave + !! speeds [nondim] + real :: c1_thresh = -1.0 !< A minimal value of the first mode internal wave speed + !! below which all higher mode speeds are not calculated but + !! are simply reported as 0 [L T-1 ~> m s-1]. A non-negative + !! value must be specified via a call to wave_speed_init for + !! the subroutine wave_speeds to be used (but not wave_speed). + type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic + !! mode structure. + integer :: remap_answer_date = 99991231 !< The vintage of the order of arithmetic and expressions to use + !! for remapping. Values below 20190101 recover the remapping + !! answers from 2018, while higher values use more robust + !! forms of the same remapping expressions. + type(diag_ctrl), pointer :: diag !< Diagnostics control structure +end type wave_speed_CS + +contains + +!> Calculates the wave speed of the first baroclinic mode. +subroutine wave_speed(h, tv, G, GV, US, cg1, CS, halo_size, use_ebt_mode, mono_N2_column_fraction, & + mono_N2_depth, modal_structure) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed [L T-1 ~> m s-1] + type(wave_speed_CS), intent(in) :: CS !< Wave speed control struct + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate wave speeds + logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent + !! barotropic mode instead of the first baroclinic mode. + real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction + !! of water column over which N2 is limited as monotonic + !! for the purposes of calculating vertical modal structure [nondim]. + real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as + !! monotonic for the purposes of calculating vertical + !! modal structure [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: modal_structure !< Normalized model structure [nondim] + + ! Local variables + real, dimension(SZK_(GV)+1) :: & + dRho_dT, & ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + pres, & ! Interface pressure [R L2 T-2 ~> Pa] + T_int, & ! Temperature interpolated to interfaces [C ~> degC] + S_int, & ! Salinity interpolated to interfaces [S ~> ppt] + H_top, & ! The distance of each filtered interface from the ocean surface [H ~> m or kg m-2] + H_bot, & ! The distance of each filtered interface from the bottom [H ~> m or kg m-2] + gprime ! The reduced gravity across each interface [L2 H-1 T-2 ~> m s-2 or m4 s-1 kg-1]. + real, dimension(SZK_(GV)) :: & + Igl, Igu ! The inverse of the reduced gravity across an interface times + ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. + real, dimension(SZK_(GV),SZI_(G)) :: & + Hf, & ! Layer thicknesses after very thin layers are combined [H ~> m or kg m-2] + Tf, & ! Layer temperatures after very thin layers are combined [C ~> degC] + Sf, & ! Layer salinities after very thin layers are combined [S ~> ppt] + Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] + real, dimension(SZK_(GV)) :: & + Hc, & ! A column of layer thicknesses after convective instabilities are removed [H ~> m or kg m-2] + Tc, & ! A column of layer temperatures after convective instabilities are removed [C ~> degC] + Sc, & ! A column of layer salinities after convective instabilities are removed [S ~> ppt] + Rc ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] + real :: I_Htot ! The inverse of the total filtered thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: det, ddet ! Determinant of the eigen system and its derivative with lam. Because the + ! units of the eigenvalue change with the number of layers and because of the + ! dynamic rescaling that is used to keep det in a numerically representable range, + ! the units of of det are hard to interpret, but det/ddet is always in units + ! of [T2 L-2 ~> s2 m-2] + real :: lam ! The eigenvalue [T2 L-2 ~> s2 m-2] + real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s2 m-2] + real :: lam0 ! The first guess of the eigenvalue [T2 L-2 ~> s2 m-2] + real :: H_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] + real, dimension(SZI_(G)) :: & + htot, hmin, & ! Thicknesses [H ~> m or kg m-2] + H_here, & ! A thickness [H ~> m or kg m-2] + HxT_here, & ! A layer integrated temperature [C H ~> degC m or degC kg m-2] + HxS_here, & ! A layer integrated salinity [S H ~> ppt m or ppt kg m-2] + HxR_here ! A layer integrated density [R H ~> kg m-2 or kg2 m-5] + real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] + real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] + real :: cg1_est ! An initial estimate of the squared first mode speed [L2 T-2 ~> m2 s-2] + real :: I_Hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R H ~> kg m-2 or kg2 m-5] + real :: dSpVxh_sum ! The sum of specific volume differences across interfaces times + ! thicknesses [R-1 H ~> m4 kg-1 or m], negative for stable stratification. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant and + ! its derivative with lam between rows of the Thomas algorithm solver [L2 s2 T-2 m-2 ~> nondim]. + ! The exact value should not matter for the final result if it is an even power of 2. + real :: tol_Hfrac ! Layers that together are smaller than this fraction of + ! the total water column can be merged for efficiency [nondim]. + real :: min_h_frac ! tol_Hfrac divided by the total number of layers [nondim]. + real :: tol_solve ! The fractional tolerance with which to solve for the wave speeds [nondim] + real :: tol_merge ! The fractional change in estimated wave speed that is allowed + ! when deciding to merge layers in the calculation [nondim] + real :: rescale ! A rescaling factor to control the magnitude of the determinant [nondim] + real :: I_rescale ! The reciprocal of the rescaling factor to control the magnitude of the determinant [nondim] + integer :: kf(SZI_(G)) ! The number of active layers after filtering. + integer, parameter :: max_itt = 10 + real :: lam_it(max_itt) ! The guess at the eignevalue with each iteration [T2 L-2 ~> s2 m-2] + real :: det_it(max_itt), ddet_it(max_itt) ! The determinant of the matrix and its derivative with lam + ! with each iteration. Because of all of the dynamic rescaling of the determinant + ! between rows, its units are not easily interpretable, but the ratio of det/ddet + ! always has units of [T2 L-2 ~> s2 m-2] + logical :: use_EOS ! If true, density or specific volume is calculated from T & S using an equation of state. + logical :: nonBous ! If true, do not make the Boussinesq approximation. + logical :: better_est ! If true, use an improved estimate of the first mode internal wave speed. + logical :: merge ! If true, merge the current layer with the one above. + integer :: kc ! The number of layers in the column after merging + integer :: i, j, k, k2, itt, is, ie, js, je, nz, halo + real :: hw ! The mean of the adjacent layer thicknesses [H ~> m or kg m-2] + real :: sum_hc ! The sum of the layer thicknesses [H ~> m or kg m-2] + real :: gp ! A limited local copy of gprime [L2 H-1 T-2 ~> m s-2 or m4 s-1 kg-1] + real :: N2min ! A minimum buoyancy frequency, including a slope rescaling factor [L2 H-2 T-2 ~> s-2 or m6 kg-2 s-2] + logical :: below_mono_N2_frac ! True if an interface is below the fractional depth where N2 should not increase. + logical :: below_mono_N2_depth ! True if an interface is below the absolute depth where N2 should not increase. + logical :: l_use_ebt_mode, calc_modal_structure + real :: l_mono_N2_column_fraction ! A local value of mono_N2_column_fraction [nondim] + real :: l_mono_N2_depth ! A local value of mono_N2_column_depth [H ~> m or kg m-2] + real :: mode_struct(SZK_(GV)) ! The mode structure [nondim], but it is also temporarily + ! in units of [L2 T-2 ~> m2 s-2] after it is modified inside of tdma6. + real :: ms_min, ms_max ! The minimum and maximum mode structure values returned from tdma6 [L2 T-2 ~> m2 s-2] + real :: ms_sq ! The sum of the square of the values returned from tdma6 [L4 T-4 ~> m4 s-4] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ; halo = 0 + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed / wave_speed: "// & + "Module must be initialized before it is used.") + + if (present(halo_size)) then + halo = halo_size + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + endif + + l_use_ebt_mode = CS%use_ebt_mode + if (present(use_ebt_mode)) l_use_ebt_mode = use_ebt_mode + l_mono_N2_column_fraction = CS%mono_N2_column_fraction + if (present(mono_N2_column_fraction)) l_mono_N2_column_fraction = mono_N2_column_fraction + l_mono_N2_depth = CS%mono_N2_depth + if (present(mono_N2_depth)) l_mono_N2_depth = mono_N2_depth + calc_modal_structure = l_use_ebt_mode + if (present(modal_structure)) calc_modal_structure = .true. + if (calc_modal_structure) then + do k=1,nz ; do j=js,je ; do i=is,ie + modal_structure(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif + + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) + H_to_pres = GV%H_to_RZ * GV%g_Earth + ! Note that g_Rho0 = H_to_pres / GV%Rho0**2 + if (.not.nonBous) g_Rho0 = GV%g_Earth*GV%H_to_Z / GV%Rho0 + use_EOS = associated(tv%eqn_of_state) + + better_est = CS%better_cg1_est + + if (better_est) then + tol_solve = CS%wave_speed_tol + tol_Hfrac = 0.1*tol_solve ; tol_merge = tol_solve / real(nz) + else + tol_solve = 0.001 ; tol_Hfrac = 0.0001 ; tol_merge = 0.001 + endif + + ! The rescaling below can control the growth of the determinant provided that + ! (tol_merge*cg1_min2/c2_scale > I_rescale). For default values, this suggests a stable lower + ! bound on min_speed of sqrt(nz/(tol_solve*rescale)) or 3e2/1024**2 = 2.9e-4 m/s for 90 layers. + ! The upper bound on the rate of increase in the determinant is g'H/c2_scale < rescale or in the + ! worst possible oceanic case of g'H < 0.5*10m/s2*1e4m = 5.e4 m2/s2 < 1024**2*c2_scale, suggesting + ! that c2_scale can safely be set to 1/(16*1024**2), which would decrease the stable floor on + ! min_speed to ~6.9e-8 m/s for 90 layers or 2.33e-7 m/s for 1000 layers. + cg1_min2 = CS%min_speed2 + rescale = 1024.0**4 ; I_rescale = 1.0/rescale + c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. + + min_h_frac = tol_Hfrac / real(nz) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,tv,use_EOS,nonBous, & + !$OMP CS,min_h_frac,calc_modal_structure,l_use_ebt_mode, & + !$OMP modal_structure,l_mono_N2_column_fraction,l_mono_N2_depth, & + !$OMP H_to_pres,cg1,g_Rho0,rescale,I_rescale,cg1_min2, & + !$OMP better_est,tol_solve,tol_merge,c2_scale) + do j=js,je + ! First merge very thin layers with the one above (or below if they are + ! at the top). This also transposes the row order so that columns can + ! be worked upon one at a time. + do i=is,ie ; htot(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo + + do i=is,ie + hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 + HxT_here(i) = 0.0 ; HxS_here(i) = 0.0 ; HxR_here(i) = 0.0 + enddo + if (use_EOS) then + do k=1,nz ; do i=is,ie + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then + Hf(kf(i),i) = H_here(i) + Tf(kf(i),i) = HxT_here(i) / H_here(i) + Sf(kf(i),i) = HxS_here(i) / H_here(i) + kf(i) = kf(i) + 1 + + ! Start a new layer + H_here(i) = h(i,j,k) + HxT_here(i) = h(i,j,k) * tv%T(i,j,k) + HxS_here(i) = h(i,j,k) * tv%S(i,j,k) + else + H_here(i) = H_here(i) + h(i,j,k) + HxT_here(i) = HxT_here(i) + h(i,j,k) * tv%T(i,j,k) + HxS_here(i) = HxS_here(i) + h(i,j,k) * tv%S(i,j,k) + endif + enddo ; enddo + do i=is,ie ; if (H_here(i) > 0.0) then + Hf(kf(i),i) = H_here(i) + Tf(kf(i),i) = HxT_here(i) / H_here(i) + Sf(kf(i),i) = HxS_here(i) / H_here(i) + endif ; enddo + else ! .not. (use_EOS) + do k=1,nz ; do i=is,ie + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then + Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) + kf(i) = kf(i) + 1 + + ! Start a new layer + H_here(i) = h(i,j,k) + HxR_here(i) = h(i,j,k)*GV%Rlay(k) + else + H_here(i) = H_here(i) + h(i,j,k) + HxR_here(i) = HxR_here(i) + h(i,j,k)*GV%Rlay(k) + endif + enddo ; enddo + do i=is,ie ; if (H_here(i) > 0.0) then + Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) + endif ; enddo + 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.0) then + if (use_EOS) then + pres(1) = 0.0 ; H_top(1) = 0.0 + do K=2,kf(i) + pres(K) = pres(K-1) + H_to_pres*Hf(k-1,i) + T_int(K) = 0.5*(Tf(k,i)+Tf(k-1,i)) + S_int(K) = 0.5*(Sf(k,i)+Sf(k-1,i)) + H_top(K) = H_top(K-1) + Hf(k-1,i) + enddo + if (nonBous) then + call calculate_specific_vol_derivs(T_int, S_int, pres, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + else + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + endif + + ! Sum the reduced gravities to find out how small a density difference is negligibly small. + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 + if (better_est) then + ! This is an estimate that is correct for the non-EBT mode for 2 or 3 layers, or for + ! clusters of massless layers at interfaces that can be grouped into 2 or 3 layers. + ! For a uniform stratification and a huge number of layers uniformly distributed in + ! density, this estimate is too large (as is desired) by a factor of pi^2/6 ~= 1.64. + if (H_top(kf(i)) > 0.0) then + I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. + H_bot(kf(i)+1) = 0.0 + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif + endif + else + ! This estimate is problematic in that it goes like 1/nz for a large number of layers, + ! but it is an overestimate (as desired) for a small number of layers, by at a factor + ! of (H1+H2)**2/(H1*H2) >= 4 for two thick layers. + if (nonBous) then + do K=2,kf(i) + dSpVxh_sum = dSpVxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif + endif + else ! .not. (use_EOS) + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 + if (better_est) then + H_top(1) = 0.0 + do K=2,kf(i) ; H_top(K) = H_top(K-1) + Hf(k-1,i) ; enddo + if (H_top(kf(i)) > 0.0) then + I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. + H_bot(kf(i)+1) = 0.0 + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, (Rf(k-1,i)-Rf(k,i)) / (Rf(k,i)*Rf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif + endif + else + if (nonBous) then + do K=2,kf(i) + dSpVxh_sum = dSpVxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + min(0.0, (Rf(k-1,i)-Rf(k,i)) / (Rf(k,i)*Rf(k-1,i))) + enddo + else + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif + endif + endif ! use_EOS + + if (nonBous) then + ! Note that dSpVxh_sum is negative for stable stratification. + cg1_est = H_to_pres * abs(dSpVxh_sum) + else + cg1_est = g_Rho0 * drxh_sum + endif + + ! Find gprime across each internal interface, taking care of convective instabilities by + ! merging layers. If the estimated wave speed is too small, simply return zero. + if (cg1_est <= cg1_min2) then + cg1(i,j) = 0.0 + if (present(modal_structure)) modal_structure(i,j,:) = 0. + else + ! Merge layers to eliminate convective instabilities or exceedingly + ! small reduced gravities. Merging layers reduces the estimated wave speed by + ! (rho(2)-rho(1))*h(1)*h(2) / H_tot. + if (use_EOS) then + kc = 1 + Hc(1) = Hf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) + do k=2,kf(i) + if (better_est .and. nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + ((Hc(kc) * Hf(k,i))*I_Htot) < abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then + merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & + ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + elseif (nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + (Hc(kc) + Hf(k,i)) < abs(2.0 * tol_merge * dSpVxh_sum)) + else + merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & + (Hc(kc) + Hf(k,i)) < 2.0 * tol_merge*drxh_sum) + endif + if (merge) then + ! Merge this layer with the one above and backtrack. + I_Hnew = 1.0 / (Hc(kc) + Hf(k,i)) + Tc(kc) = (Hc(kc)*Tc(kc) + Hf(k,i)*Tf(k,i)) * I_Hnew + Sc(kc) = (Hc(kc)*Sc(kc) + Hf(k,i)*Sf(k,i)) * I_Hnew + Hc(kc) = (Hc(kc) + Hf(k,i)) + ! Backtrack to remove any convective instabilities above... Note + ! that the tolerance is a factor of two larger, to avoid limit how + ! far back we go. + do K2=kc,2,-1 + if (better_est .and. nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + ((Hc(k2) * Hc(k2-1))*I_Htot) < abs(tol_merge * dSpVxh_sum) ) + elseif (better_est) then + merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & + ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + elseif (nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + (Hc(k2) + Hc(k2-1)) < abs(tol_merge * dSpVxh_sum) ) + else + merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & + (Hc(k2) + Hc(k2-1)) < tol_merge*drxh_sum) + endif + if (merge) then + ! Merge the two bottommost layers. At this point kc = k2. + I_Hnew = 1.0 / (Hc(kc) + Hc(kc-1)) + Tc(kc-1) = (Hc(kc)*Tc(kc) + Hc(kc-1)*Tc(kc-1)) * I_Hnew + Sc(kc-1) = (Hc(kc)*Sc(kc) + Hc(kc-1)*Sc(kc-1)) * I_Hnew + Hc(kc-1) = (Hc(kc) + Hc(kc-1)) + kc = kc - 1 + else ; exit ; endif + enddo + else + ! Add a new layer to the column. + kc = kc + 1 + if (nonBous) then + dSpV_dS(Kc) = dSpV_dS(K) ; dSpV_dT(Kc) = dSpV_dT(K) + else + drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) + endif + Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) + endif + enddo + ! At this point there are kc layers and the gprimes should be positive. + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (dSpV_dT(K)*(Tc(k-1)-Tc(k)) + dSpV_dS(K)*(Sc(k-1)-Sc(k))) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) + enddo + endif + else ! .not. (use_EOS) + ! Do the same with density directly... + kc = 1 + Hc(1) = Hf(1,i) ; Rc(1) = Rf(1,i) + do k=2,kf(i) + if (nonBous .and. better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (nonBous) then + merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0*tol_merge*drxh_sum) + else + merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol_merge*drxh_sum) + endif + if (merge) then + ! Merge this layer with the one above and backtrack. + Rc(kc) = (Hc(kc)*Rc(kc) + Hf(k,i)*Rf(k,i)) / (Hc(kc) + Hf(k,i)) + Hc(kc) = (Hc(kc) + Hf(k,i)) + ! Backtrack to remove any convective instabilities above... Note + ! that the tolerance is a factor of two larger, to avoid limit how + ! far back we go. + do k2=kc,2,-1 + if (nonBous .and. better_est) then + merge = ((Rc(k2) - Rc(k2-1)) * ((Hc(kc) * Hf(k,i))*I_Htot) < & + (Rc(k2-1)*Rc(k2)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (nonBous) then + merge = ((Rc(k2) - Rc(k2-1)) * (Hc(kc) + Hf(k,i)) < & + (Rc(k2-1)*Rc(k2)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then + merge = ((Rc(k2)-Rc(k2-1)) * ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + else + merge = ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol_merge*drxh_sum) + endif + if (merge) then + ! Merge the two bottommost layers. At this point kc = k2. + Rc(kc-1) = (Hc(kc)*Rc(kc) + Hc(kc-1)*Rc(kc-1)) / (Hc(kc) + Hc(kc-1)) + Hc(kc-1) = (Hc(kc) + Hc(kc-1)) + kc = kc - 1 + else ; exit ; endif + enddo + else + ! Add a new layer to the column. + kc = kc + 1 + Rc(kc) = Rf(k,i) ; Hc(kc) = Hf(k,i) + endif + enddo + ! At this point there are kc layers and the gprimes should be positive. + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (Rc(k) - Rc(k-1)) / (Rc(k) * Rc(k-1)) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) + enddo + endif + endif ! use_EOS + + ! Sum the contributions from all of the interfaces to give an over-estimate + ! of the first-mode wave speed. Also populate Igl and Igu which are the + ! non-leading diagonals of the tridiagonal matrix. + if (kc >= 2) then + speed2_tot = 0.0 + if (better_est) then + H_top(1) = 0.0 ; H_bot(kc+1) = 0.0 + do K=2,kc+1 ; H_top(K) = H_top(K-1) + Hc(k-1) ; enddo + do K=kc,2,-1 ; H_bot(K) = H_bot(K+1) + Hc(k) ; enddo + I_Htot = 0.0 ; if (H_top(kc+1) > 0.0) I_Htot = 1.0 / H_top(kc+1) + endif + + if (l_use_ebt_mode) then + Igu(1) = 0. ! Neumann condition for pressure modes + sum_hc = Hc(1) + N2min = gprime(2)/Hc(1) + + below_mono_N2_frac = .false. + below_mono_N2_depth = .false. + do k=2,kc + hw = 0.5*(Hc(k-1)+Hc(k)) + gp = gprime(K) + + if (l_mono_N2_column_fraction>0. .or. l_mono_N2_depth>=0.) then + ! Determine whether N2 estimates should not be allowed to increase with depth. + if (l_mono_N2_column_fraction>0.) then + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + below_mono_N2_frac = ((G%bathyT(i,j)+G%Z_ref) - GV%H_to_Z*sum_hc < & + l_mono_N2_column_fraction*(G%bathyT(i,j)+G%Z_ref)) + else + below_mono_N2_frac = (htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i)) + endif + endif + if (l_mono_N2_depth >= 0.) below_mono_N2_depth = (sum_hc > l_mono_N2_depth) + + if ( (gp > N2min*hw) .and. (below_mono_N2_frac .or. below_mono_N2_depth) ) then + ! Filters out regions where N2 increases with depth, but only in a lower fraction + ! of the water column or below a certain depth. + gp = N2min * hw + else + N2min = gp / hw + endif + endif + + Igu(k) = 1.0/(gp*Hc(k)) + Igl(k-1) = 1.0/(gp*Hc(k-1)) + sum_hc = sum_hc + Hc(k) + + if (better_est) then + ! Estimate that the ebt_mode is sqrt(2) times the speed of the flat bottom modes. + speed2_tot = speed2_tot + 2.0 * gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) + else ! The ebt_mode wave should be faster than the flat-bottom mode, so 0.707 should be > 1? + speed2_tot = speed2_tot + gprime(K)*(Hc(k-1)+Hc(k))*0.707 + endif + enddo + !Igl(kc) = 0. ! Neumann condition for pressure modes + Igl(kc) = 2.*Igu(kc) ! Dirichlet condition for pressure modes + else ! .not. l_use_ebt_mode + do K=2,kc + Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) + if (better_est) then + speed2_tot = speed2_tot + gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) + else + speed2_tot = speed2_tot + gprime(K)*(Hc(k-1)+Hc(k)) + endif + enddo + endif + + if (calc_modal_structure) then + mode_struct(:) = 0. + mode_struct(1:kc) = 1. ! Uniform flow, first guess + endif + + ! Under estimate the first eigenvalue (overestimate the speed) to start with. + if (calc_modal_structure) then + lam0 = 0.5 / speed2_tot ; lam = lam0 + else + lam0 = 1.0 / speed2_tot ; lam = lam0 + endif + ! Find the determinant and its derivative with lam. + do itt=1,max_itt + lam_it(itt) = lam + if (l_use_ebt_mode) then + ! This initialization of det,ddet imply Neumann boundary conditions for horizontal + ! velocity or pressure modes, so that first 3 rows of the matrix are + ! / b(1)-lam igl(1) 0 0 0 ... \ + ! | igu(2) b(2)-lam igl(2) 0 0 ... | + ! | 0 igu(3) b(3)-lam igl(3) 0 ... | + ! The last two rows of the pressure equation matrix are + ! | ... 0 igu(kc-1) b(kc-1)-lam igl(kc-1) | + ! \ ... 0 0 igu(kc) b(kc)-lam / + call tridiag_det(Igu, Igl, 1, kc, lam, det, ddet, row_scale=c2_scale) + else + ! This initialization of det,ddet imply Dirichlet boundary conditions for vertical + ! velocity modes, so that first 3 rows of the matrix are + ! / b(2)-lam igl(2) 0 0 0 ... | + ! | igu(3) b(3)-lam igl(3) 0 0 ... | + ! | 0 igu(4) b(4)-lam igl(4) 0 ... | + ! The last three rows of the w equation matrix are + ! | ... 0 igu(kc-2) b(kc-2)-lam igl(kc-2) 0 | + ! | ... 0 0 igu(kc-1) b(kc-1)-lam igl(kc-1) | + ! \ ... 0 0 0 igu(kc) b(kc)-lam / + call tridiag_det(Igu, Igl, 2, kc, lam, det, ddet, row_scale=c2_scale) + endif + ! Use Newton's method iteration to find a new estimate of lam. + det_it(itt) = det ; ddet_it(itt) = ddet + + if ((ddet >= 0.0) .or. (-det > -0.5*lam*ddet)) then + ! lam was not an under-estimate, as intended, so Newton's method + ! may not be reliable; lam must be reduced, but not by more + ! than half. + lam = 0.5 * lam + dlam = -lam + else ! Newton's method is OK. + dlam = - det / ddet + lam = lam + dlam + endif + + if (calc_modal_structure) then + call tdma6(kc, Igu, Igl, lam, mode_struct) + ! Note that tdma6 changes the units of mode_struct to [L2 T-2 ~> m2 s-2] + ms_min = mode_struct(1) + ms_max = mode_struct(1) + ms_sq = mode_struct(1)**2 + do k = 2,kc + ms_min = min(ms_min, mode_struct(k)) + ms_max = max(ms_max, mode_struct(k)) + ms_sq = ms_sq + mode_struct(k)**2 + enddo + if (ms_min<0. .and. ms_max>0.) then ! Any zero crossings => lam is too high + lam = 0.5 * ( lam - dlam ) + dlam = -lam + mode_struct(1:kc) = abs(mode_struct(1:kc)) / sqrt( ms_sq ) + else + mode_struct(1:kc) = mode_struct(1:kc) / sqrt( ms_sq ) + endif + ! After the nondimensionalization above, mode_struct is once again [nondim] + endif + + if (abs(dlam) < tol_solve*lam) exit + enddo + + cg1(i,j) = 0.0 + if (lam > 0.0) cg1(i,j) = 1.0 / sqrt(lam) + + if (present(modal_structure)) then + if (mode_struct(1)/=0.) then ! Normalize + mode_struct(1:kc) = mode_struct(1:kc) / mode_struct(1) + else + mode_struct(1:kc)=0. + endif + + if (CS%remap_answer_date < 20190101) then + call remapping_core_h(CS%remapping_CS, kc, Hc(:), mode_struct, & + nz, h(i,j,:), modal_structure(i,j,:), & + 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) + else + call remapping_core_h(CS%remapping_CS, kc, Hc(:), mode_struct, & + nz, h(i,j,:), modal_structure(i,j,:), & + GV%H_subroundoff, GV%H_subroundoff) + endif + endif + else + cg1(i,j) = 0.0 + if (present(modal_structure)) modal_structure(i,j,:) = 0. + endif + endif ! cg1 /= 0.0 + else + cg1(i,j) = 0.0 ! This is a land point. + if (present(modal_structure)) modal_structure(i,j,:) = 0. + endif ; enddo ! i-loop + enddo ! j-loop + +end subroutine wave_speed + +!> Solve a non-symmetric tridiagonal problem with the sum of the upper and lower diagonals minus a +!! scalar contribution as the leading diagonal. +!! This uses the Thomas algorithm rather than the Hallberg algorithm since the matrix is not symmetric. +subroutine tdma6(n, a, c, lam, y) + integer, intent(in) :: n !< Number of rows of matrix + real, dimension(:), intent(in) :: a !< Lower diagonal [T2 L-2 ~> s2 m-2] + real, dimension(:), intent(in) :: c !< Upper diagonal [T2 L-2 ~> s2 m-2] + real, intent(in) :: lam !< Scalar subtracted from leading diagonal [T2 L-2 ~> s2 m-2] + real, dimension(:), intent(inout) :: y !< RHS on entry [A ~> a], result on exit [A L2 T-2 ~> a m2 s-2] + + ! Local variables + real :: lambda ! A temporary variable in [T2 L-2 ~> s2 m-2] + real :: beta(n) ! A temporary variable in [T2 L-2 ~> s2 m-2] + real :: I_beta(n) ! A temporary variable in [L2 T-2 ~> m2 s-2] + real :: yy(n) ! A temporary variable with the same units as y on entry [A ~> a] + integer :: k, m + + lambda = lam + beta(1) = (a(1)+c(1)) - lambda + if (beta(1)==0.) then ! lam was chosen too perfectly + ! Change lambda and redo this first row + lambda = (1. + 1.e-5) * lambda + beta(1) = (a(1)+c(1)) - lambda + endif + I_beta(1) = 1. / beta(1) + yy(1) = y(1) + do k = 2, n + beta(k) = ( (a(k)+c(k)) - lambda ) - a(k) * c(k-1) * I_beta(k-1) + ! Perhaps the following 0 needs to become a tolerance to handle underflow? + if (beta(k)==0.) then ! lam was chosen too perfectly + ! Change lambda and redo everything up to row k + lambda = (1. + 1.e-5) * lambda + I_beta(1) = 1. / ( (a(1)+c(1)) - lambda ) + do m = 2, k + I_beta(m) = 1. / ( ( (a(m)+c(m)) - lambda ) - a(m) * c(m-1) * I_beta(m-1) ) + yy(m) = y(m) + a(m) * yy(m-1) * I_beta(m-1) + enddo + else + I_beta(k) = 1. / beta(k) + endif + yy(k) = y(k) + a(k) * yy(k-1) * I_beta(k-1) + enddo + ! The units of y change by a factor of [L2 T-2 ~> m2 s-2] in the following lines. + y(n) = yy(n) * I_beta(n) + do k = n-1, 1, -1 + y(k) = ( yy(k) + c(k) * y(k+1) ) * I_beta(k) + enddo + +end subroutine tdma6 + +!> Calculates the wave speeds for the first few barolinic modes. +subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_struct_max, u_struct_bot, Nb, int_w2, & + int_U2, int_N2w2, halo_size) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + integer, intent(in) :: nmodes !< Number of modes + type(wave_speed_CS), intent(in) :: CS !< Wave speed control struct + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1,nmodes),intent(out) :: w_struct !< Wave vertical velocity profile [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV),nmodes),intent(out) :: u_struct !< Wave horizontal velocity profile + !! [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: cn !< Waves speeds [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: u_struct_max !< Maximum of wave horizontal velocity + !! profile [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: u_struct_bot !< Bottom value of wave horizontal + !! velocity profile [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Nb !< Bottom value of buoyancy freqency + !! [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_w2 !< depth-integrated vertical velocity + !! profile squared [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_U2 !< depth-integrated horizontal velocity + !! profile squared [H Z-2 ~> m-1 or kg m-4] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_N2w2 !< depth-integrated buoyancy frequency + !! times vertical velocity profile + !! squared [H T-2 ~> m s-2 or kg m-2 s-2] + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate wave speeds + + ! Local variables + real, dimension(SZK_(GV)+1) :: & + dRho_dT, & ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + pres, & ! Interface pressure [R L2 T-2 ~> Pa] + T_int, & ! Temperature interpolated to interfaces [C ~> degC] + S_int, & ! Salinity interpolated to interfaces [S ~> ppt] + H_top, & ! The distance of each filtered interface from the ocean surface [H ~> m or kg m-2] + H_bot, & ! The distance of each filtered interface from the bottom [H ~> m or kg m-2] + gprime, & ! The reduced gravity across each interface [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + N2 ! The buoyancy freqency squared [T-2 ~> s-2] + real, dimension(SZK_(GV),SZI_(G)) :: & + Hf, & ! Layer thicknesses after very thin layers are combined [H ~> m or kg m-2] + dzf, & ! Layer vertical extents after very thin layers are combined [Z ~> m] + Tf, & ! Layer temperatures after very thin layers are combined [C ~> degC] + Sf, & ! Layer salinities after very thin layers are combined [S ~> ppt] + Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] + real, dimension(SZI_(G),SZK_(GV)) :: & + dz_2d ! Height change across layers [Z ~> m] + real, dimension(SZK_(GV)) :: & + Igl, Igu, & ! The inverse of the reduced gravity across an interface times + ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. + Hc, & ! A column of layer thicknesses after convective instabilities are removed [H ~> m or kg m-2] + dzc, & ! A column of layer vertical extents after convective instabilities are removed [Z ~> m] + Tc, & ! A column of layer temperatures after convective instabilities are removed [C ~> degC] + Sc, & ! A column of layer salinities after convective instabilities are removed [S ~> ppt] + Rc ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] + real :: I_Htot ! The inverse of the total filtered thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant and its + ! derivative with lam between rows of the Thomas algorithm solver [L2 s2 T-2 m-2 ~> nondim]. + ! The exact value should not matter for the final result if it is an even power of 2. + real :: det, ddet ! Determinant of the eigen system and its derivative with lam. Because the + ! units of the eigenvalue change with the number of layers and because of the + ! dynamic rescaling that is used to keep det in a numerically representable range, + ! the units of of det are hard to interpret, but det/ddet is always in units + ! of [T2 L-2 ~> s2 m-2] + real :: lam_1 ! approximate mode-1 eigenvalue [T2 L-2 ~> s2 m-2] + real :: lam_n ! approximate mode-n eigenvalue [T2 L-2 ~> s2 m-2] + real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s2 m-2] + real :: lamMin ! minimum lam value for root searching range [T2 L-2 ~> s2 m-2] + real :: lamMax ! maximum lam value for root searching range [T2 L-2 ~> s2 m-2] + real :: lamInc ! width of moving window for root searching [T2 L-2 ~> s2 m-2] + real :: det_l, ddet_l ! determinant of the eigensystem and its derivative with lam at the lower + ! end of the range of values bracketing a particular root, in dynamically + ! rescaled units that may differ from the other det variables, but such + ! that the units of det_l/ddet_l are [T2 L-2 ~> s2 m-2] + real :: det_r, ddet_r ! determinant and its derivative with lam at the lower end of the + ! bracket in arbitrarily rescaled units, but such that the units of + ! det_r/ddet_r are [T2 L-2 ~> s2 m-2] + real :: det_sub, ddet_sub ! determinant and its derivative with lam at a subinterval endpoint that + ! is a candidate for a new bracket endpoint in arbitrarily rescaled units, + ! but such that the units of det_sub/ddet_sub are [T2 L-2 ~> s2 m-2] + real :: xl, xr ! lam guesses at left and right of window [T2 L-2 ~> s2 m-2] + real :: xl_sub ! lam guess at left of subinterval window [T2 L-2 ~> s2 m-2] + real, dimension(nmodes) :: & + xbl, xbr ! lam guesses bracketing a zero-crossing (root) [T2 L-2 ~> s2 m-2] + integer :: numint ! number of widows (intervals) in root searching range + integer :: nrootsfound ! number of extra roots found (not including 1st root) + real :: H_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] + real, dimension(SZI_(G)) :: & + htot, hmin, & ! Thicknesses [H ~> m or kg m-2] + H_here, & ! A layer thickness [H ~> m or kg m-2] + dz_here, & ! A layer vertical extent [Z ~> m] + HxT_here, & ! A layer integrated temperature [C H ~> degC m or degC kg m-2] + HxS_here, & ! A layer integrated salinity [S H ~> ppt m or ppt kg m-2] + HxR_here ! A layer integrated density [R H ~> kg m-2 or kg2 m-5] + real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] + real :: speed2_min ! minimum mode speed (squared) to consider in root searching [L2 T-2 ~> m2 s-2] + real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] + real :: cg1_est ! An initial estimate of the squared first mode speed [L2 T-2 ~> m2 s-2] + real, parameter :: reduct_factor = 0.5 ! A factor used in setting speed2_min [nondim] + real :: I_Hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R H ~> kg m-2 or kg2 m-5] + real :: dSpVxh_sum ! The sum of specific volume differences across interfaces times + ! thicknesses [R-1 H ~> m4 kg-1 or m], negative for stable stratification. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 pr m7 s-2 kg-1]. + real :: tol_Hfrac ! Layers that together are smaller than this fraction of + ! the total water column can be merged for efficiency [nondim]. + real :: min_h_frac ! tol_Hfrac divided by the total number of layers [nondim]. + real :: tol_solve ! The fractional tolerance with which to solve for the wave speeds [nondim]. + real :: tol_merge ! The fractional change in estimated wave speed that is allowed + ! when deciding to merge layers in the calculation [nondim] + integer :: kf(SZI_(G)) ! The number of active layers after filtering. + integer, parameter :: max_itt = 30 + logical :: use_EOS ! If true, density or specific volume is calculated from T & S using the equation of state. + logical :: nonBous ! If true, do not make the Boussinesq approximation. + logical :: better_est ! If true, use an improved estimate of the first mode internal wave speed. + logical :: merge ! If true, merge the current layer with the one above. + integer :: nsub ! number of subintervals used for root finding + integer, parameter :: sub_it_max = 4 + ! maximum number of times to subdivide interval + ! for root finding (# intervals = 2**sub_it_max) + logical :: sub_rootfound ! if true, subdivision has located root + integer :: kc ! The number of layers in the column after merging + integer :: sub, sub_it + integer :: i, j, k, k2, itt, is, ie, js, je, nz, iint, m, halo + real, dimension(SZK_(GV)+1) :: modal_structure !< Normalized model structure [nondim] + real, dimension(SZK_(GV)) :: modal_structure_fder !< Normalized model structure [Z-1 ~> m-1] + real :: mode_struct(SZK_(GV)+1) ! The mode structure [nondim], but it is also temporarily + ! in units of [L2 T-2 ~> m2 s-2] after it is modified inside of tdma6. + real :: mode_struct_fder(SZK_(GV)) ! The mode structure 1st derivative [Z-1 ~> m-1], but it is also temporarily + ! in units of [Z-1 L2 T-2 ~> m s-2] after it is modified inside of tdma6. + real :: mode_struct_sq(SZK_(GV)+1) ! The square of mode structure [nondim] + real :: mode_struct_fder_sq(SZK_(GV)) ! The square of mode structure 1st derivative [Z-2 ~> m-2] + + + real :: ms_min, ms_max ! The minimum and maximum mode structure values returned from tdma6 [L2 T-2 ~> m2 s-2] + real :: ms_sq ! The sum of the square of the values returned from tdma6 [L4 T-4 ~> m4 s-4] + real :: w2avg ! A total for renormalization [H L4 T-4 ~> m5 s-4 or kg m2 s-4] + real, parameter :: a_int = 0.5 ! Integral total for normalization [nondim] + real :: renorm ! Normalization factor [T2 L-2 ~> s2 m-2] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ; halo = 0 + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed / wave_speeds: "// & + "Module must be initialized before it is used.") + + if (present(halo_size)) then + halo = halo_size + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + endif + + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) + H_to_pres = GV%H_to_RZ * GV%g_Earth + if (.not.nonBous) g_Rho0 = GV%g_Earth * GV%H_to_Z / GV%Rho0 + use_EOS = associated(tv%eqn_of_state) + + if (CS%c1_thresh < 0.0) & + call MOM_error(FATAL, "INTERNAL_WAVE_CG1_THRESH must be set to a non-negative "//& + "value via wave_speed_init for wave_speeds to be used.") + c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. + + better_est = CS%better_cg1_est + if (better_est) then + tol_solve = CS%wave_speed_tol + tol_Hfrac = 0.1*tol_solve ; tol_merge = tol_solve / real(nz) + else + tol_solve = 0.001 ; tol_Hfrac = 0.0001 ; tol_merge = 0.001 + endif + cg1_min2 = CS%min_speed2 + + ! Zero out all local values. Values over land or for columns that are too weakly stratified + ! are not changed from this zero value. + cn(:,:,:) = 0.0 + u_struct_max(:,:,:) = 0.0 + u_struct_bot(:,:,:) = 0.0 + Nb(:,:) = 0.0 + int_w2(:,:,:) = 0.0 + int_N2w2(:,:,:) = 0.0 + int_U2(:,:,:) = 0.0 + u_struct(:,:,:,:) = 0.0 + w_struct(:,:,:,:) = 0.0 + + min_h_frac = tol_Hfrac / real(nz) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,CS,use_EOS,nonBous, & + !$OMP min_h_frac,H_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2, & + !$OMP better_est,tol_solve,tol_merge,c2_scale) + do j=js,je + ! First merge very thin layers with the one above (or below if they are + ! at the top). This also transposes the row order so that columns can + ! be worked upon one at a time. + do i=is,ie ; htot(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo + + call thickness_to_dz(h, tv, dz_2d, j, G, GV, halo_size=halo) + + do i=is,ie + hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 ; dz_here(i) = 0.0 + HxT_here(i) = 0.0 ; HxS_here(i) = 0.0 ; HxR_here(i) = 0.0 + enddo + if (use_EOS) then + do k=1,nz ; do i=is,ie + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then + Hf(kf(i),i) = H_here(i) + dzf(kf(i),i) = dz_here(i) + Tf(kf(i),i) = HxT_here(i) / H_here(i) + Sf(kf(i),i) = HxS_here(i) / H_here(i) + kf(i) = kf(i) + 1 + + ! Start a new layer + H_here(i) = h(i,j,k) + dz_here(i) = dz_2d(i,k) + HxT_here(i) = h(i,j,k)*tv%T(i,j,k) + HxS_here(i) = h(i,j,k)*tv%S(i,j,k) + else + H_here(i) = H_here(i) + h(i,j,k) + dz_here(i) = dz_here(i) + dz_2d(i,k) + HxT_here(i) = HxT_here(i) + h(i,j,k)*tv%T(i,j,k) + HxS_here(i) = HxS_here(i) + h(i,j,k)*tv%S(i,j,k) + endif + enddo ; enddo + do i=is,ie ; if (H_here(i) > 0.0) then + Hf(kf(i),i) = H_here(i) + dzf(kf(i),i) = dz_here(i) + Tf(kf(i),i) = HxT_here(i) / H_here(i) + Sf(kf(i),i) = HxS_here(i) / H_here(i) + endif ; enddo + else ! .not. (use_EOS) + do k=1,nz ; do i=is,ie + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then + Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) + dzf(kf(i),i) = dz_here(i) + kf(i) = kf(i) + 1 + + ! Start a new layer + H_here(i) = h(i,j,k) + dz_here(i) = dz_2d(i,k) + HxR_here(i) = h(i,j,k)*GV%Rlay(k) + else + H_here(i) = H_here(i) + h(i,j,k) + dz_here(i) = dz_here(i) + dz_2d(i,k) + HxR_here(i) = HxR_here(i) + h(i,j,k)*GV%Rlay(k) + endif + enddo ; enddo + do i=is,ie ; if (H_here(i) > 0.0) then + Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) + dzf(kf(i),i) = dz_here(i) + endif ; enddo + endif + + ! 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.0) then + if (use_EOS) then + pres(1) = 0.0 ; H_top(1) = 0.0 + do K=2,kf(i) + pres(K) = pres(K-1) + H_to_pres*Hf(k-1,i) + T_int(K) = 0.5*(Tf(k,i)+Tf(k-1,i)) + S_int(K) = 0.5*(Sf(k,i)+Sf(k-1,i)) + H_top(K) = H_top(K-1) + Hf(k-1,i) + enddo + if (nonBous) then + call calculate_specific_vol_derivs(T_int, S_int, pres, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + else + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + endif + + ! Sum the reduced gravities to find out how small a density difference is negligibly small. + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 + if (better_est) then + ! This is an estimate that is correct for the non-EBT mode for 2 or 3 layers, or for + ! clusters of massless layers at interfaces that can be grouped into 2 or 3 layers. + ! For a uniform stratification and a huge number of layers uniformly distributed in + ! density, this estimate is too large (as is desired) by a factor of pi^2/6 ~= 1.64. + if (H_top(kf(i)) > 0.0) then + I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. + H_bot(kf(i)+1) = 0.0 + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif + endif + else + ! This estimate is problematic in that it goes like 1/nz for a large number of layers, + ! but it is an overestimate (as desired) for a small number of layers, by at a factor + ! of (H1+H2)**2/(H1*H2) >= 4 for two thick layers. + if (nonBous) then + do K=2,kf(i) + dSpVxh_sum = dSpVxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif + endif + else ! Not use_EOS + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 + if (better_est) then + H_top(1) = 0.0 + do K=2,kf(i) ; H_top(K) = H_top(K-1) + Hf(k-1,i) ; enddo + if (H_top(kf(i)) > 0.0) then + I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. + H_bot(kf(i)+1) = 0.0 + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, (Rf(k-1,i)-Rf(k,i)) / (Rf(k,i)*Rf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif + endif + else + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif + endif + + if (nonBous) then + ! Note that dSpVxh_sum is negative for stable stratification. + cg1_est = H_to_pres * abs(dSpVxh_sum) + else + cg1_est = g_Rho0 * drxh_sum + endif + + ! Find gprime across each internal interface, taking care of convective + ! instabilities by merging layers. + if (cg1_est > cg1_min2) then + ! Merge layers to eliminate convective instabilities or exceedingly + ! small reduced gravities. Merging layers reduces the estimated wave speed by + ! (rho(2)-rho(1))*h(1)*h(2) / H_tot. + if (use_EOS) then + kc = 1 + Hc(1) = Hf(1,i) ; dzc(1) = dzf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) + do k=2,kf(i) + if (better_est .and. nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + ((Hc(kc) * Hf(k,i))*I_Htot) < abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then + merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & + ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + elseif (nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + (Hc(kc) + Hf(k,i)) < abs(2.0 * tol_merge * dSpVxh_sum)) + else + merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & + (Hc(kc) + Hf(k,i)) < 2.0 * tol_merge*drxh_sum) + endif + if (merge) then + ! Merge this layer with the one above and backtrack. + I_Hnew = 1.0 / (Hc(kc) + Hf(k,i)) + Tc(kc) = (Hc(kc)*Tc(kc) + Hf(k,i)*Tf(k,i)) * I_Hnew + Sc(kc) = (Hc(kc)*Sc(kc) + Hf(k,i)*Sf(k,i)) * I_Hnew + Hc(kc) = Hc(kc) + Hf(k,i) + dzc(kc) = dzc(kc) + dzf(k,i) + ! Backtrack to remove any convective instabilities above... Note + ! that the tolerance is a factor of two larger, to avoid limit how + ! far back we go. + do K2=kc,2,-1 + if (better_est .and. nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + ((Hc(k2) * Hc(k2-1))*I_Htot) < abs(tol_merge * dSpVxh_sum) ) + elseif (better_est) then + merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & + ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + elseif (nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + (Hc(k2) + Hc(k2-1)) < abs(tol_merge * dSpVxh_sum) ) + else + merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & + (Hc(k2) + Hc(k2-1)) < tol_merge*drxh_sum) + endif + if (merge) then + ! Merge the two bottommost layers. At this point kc = k2. + I_Hnew = 1.0 / (Hc(kc) + Hc(kc-1)) + Tc(kc-1) = (Hc(kc)*Tc(kc) + Hc(kc-1)*Tc(kc-1)) * I_Hnew + Sc(kc-1) = (Hc(kc)*Sc(kc) + Hc(kc-1)*Sc(kc-1)) * I_Hnew + Hc(kc-1) = Hc(kc) + Hc(kc-1) + dzc(kc-1) = dzc(kc) + dzc(kc-1) + kc = kc - 1 + else ; exit ; endif + enddo + else + ! Add a new layer to the column. + kc = kc + 1 + if (nonBous) then + dSpV_dS(Kc) = dSpV_dS(K) ; dSpV_dT(Kc) = dSpV_dT(K) + else + drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) + endif + Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) ; dzc(kc) = dzf(k,i) + endif + enddo + ! At this point there are kc layers and the gprimes should be positive. + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (dSpV_dT(K)*(Tc(k-1)-Tc(k)) + dSpV_dS(K)*(Sc(k-1)-Sc(k))) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) + enddo + endif + else ! .not. (use_EOS) + ! Do the same with density directly... + kc = 1 + Hc(1) = Hf(1,i) ; dzc(1) = dzf(1,i) ; Rc(1) = Rf(1,i) + do k=2,kf(i) + if (nonBous .and. better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (nonBous) then + merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0*tol_merge*drxh_sum) + else + merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol_merge*drxh_sum) + endif + if (merge) then + ! Merge this layer with the one above and backtrack. + Rc(kc) = (Hc(kc)*Rc(kc) + Hf(k,i)*Rf(k,i)) / (Hc(kc) + Hf(k,i)) + Hc(kc) = Hc(kc) + Hf(k,i) + dzc(kc) = dzc(kc) + dzf(k,i) + ! Backtrack to remove any convective instabilities above... Note + ! that the tolerance is a factor of two larger, to avoid limit how + ! far back we go. + do k2=kc,2,-1 + if (better_est) then + merge = ((Rc(k2)-Rc(k2-1)) * ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + else + merge = ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol_merge*drxh_sum) + endif + if (merge) then + ! Merge the two bottommost layers. At this point kc = k2. + Rc(kc-1) = (Hc(kc)*Rc(kc) + Hc(kc-1)*Rc(kc-1)) / (Hc(kc) + Hc(kc-1)) + Hc(kc-1) = Hc(kc) + Hc(kc-1) + dzc(kc-1) = dzc(kc) + dzc(kc-1) + kc = kc - 1 + else ; exit ; endif + enddo + else + ! Add a new layer to the column. + kc = kc + 1 + Rc(kc) = Rf(k,i) ; Hc(kc) = Hf(k,i) ; dzc(kc) = dzf(k,i) + endif + enddo + ! At this point there are kc layers and the gprimes should be positive. + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (Rc(k) - Rc(k-1)) / (Rc(k) * Rc(k-1)) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) + enddo + endif + endif ! use_EOS + + !-----------------NOW FIND WAVE SPEEDS--------------------------------------- + ! ig = i + G%idg_offset ; jg = j + G%jdg_offset + ! Sum the contributions from all of the interfaces to give an over-estimate + ! of the first-mode wave speed. Also populate Igl and Igu which are the + ! non-leading diagonals of the tridiagonal matrix. + if (kc >= 2) then + ! initialize speed2_tot + speed2_tot = 0.0 + if (better_est) then + H_top(1) = 0.0 ; H_bot(kc+1) = 0.0 + do K=2,kc+1 ; H_top(K) = H_top(K-1) + Hc(k-1) ; enddo + do K=kc,2,-1 ; H_bot(K) = H_bot(K+1) + Hc(k) ; enddo + I_Htot = 0.0 ; if (H_top(kc+1) > 0.0) I_Htot = 1.0 / H_top(kc+1) + endif + + ! Calculate Igu, Igl, depth, and N2 at each interior interface + ! [excludes surface (K=1) and bottom (K=kc+1)] + Igl(:) = 0. + Igu(:) = 0. + N2(:) = 0. + + do K=2,kc + Igl(K) = 1.0 / (gprime(K)*Hc(k)) ; Igu(K) = 1.0 / (gprime(K)*Hc(k-1)) + if (nonBous) then + N2(K) = 2.0*US%L_to_Z**2*gprime(K) * (Hc(k) + Hc(k-1)) / & ! Units are [T-2 ~> s-2] + (dzc(k) + dzc(k-1))**2 + else + N2(K) = 2.0*US%L_to_Z**2*GV%Z_to_H*gprime(K) / (dzc(k) + dzc(k-1)) ! Units are [T-2 ~> s-2] + endif + if (better_est) then + speed2_tot = speed2_tot + gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) + else + speed2_tot = speed2_tot + gprime(K)*(Hc(k-1)+Hc(k)) + endif + enddo + + ! Set stratification for surface and bottom (setting equal to nearest interface for now) + N2(1) = N2(2) ; N2(kc+1) = N2(kc) + ! set bottom stratification + Nb(i,j) = sqrt(N2(kc+1)) + + ! Under estimate the first eigenvalue (overestimate the speed) to start with. + lam_1 = 1.0 / speed2_tot + + ! init and first guess for mode structure + mode_struct(:) = 0. + mode_struct_fder(:) = 0. + mode_struct(2:kc) = 1. ! Uniform flow, first guess + modal_structure(:) = 0. + modal_structure_fder(:) = 0. + + ! Find the first eigen value + do itt=1,max_itt + ! calculate the determinant of (A-lam_1*I) + call tridiag_det(Igu, Igl, 2, kc, lam_1, det, ddet, row_scale=c2_scale) + + ! If possible, use Newton's method iteration to find a new estimate of lam_1 + !det = det_it(itt) ; ddet = ddet_it(itt) + if ((ddet >= 0.0) .or. (-det > -0.5*lam_1*ddet)) then + ! lam_1 was not an under-estimate, as intended, so Newton's method + ! may not be reliable; lam_1 must be reduced, but not by more than half. + lam_1 = 0.5 * lam_1 + dlam = -lam_1 + else ! Newton's method is OK. + dlam = - det / ddet + lam_1 = lam_1 + dlam + endif + + call tdma6(kc-1, Igu(2:kc), Igl(2:kc), lam_1, mode_struct(2:kc)) + ! Note that tdma6 changes the units of mode_struct to [L2 T-2 ~> m2 s-2] + ! apply BC + mode_struct(1) = 0. + mode_struct(kc+1) = 0. + + ! renormalization of the integral of the profile + w2avg = 0.0 + do k=1,kc + w2avg = w2avg + 0.5*(mode_struct(K)**2+mode_struct(K+1)**2)*Hc(k) ! [H L4 T-4] + enddo + renorm = sqrt(htot(i)*a_int/w2avg) ! [T2 L-2] + do K=1,kc+1 ; mode_struct(K) = renorm * mode_struct(K) ; enddo + ! after renorm, mode_struct is again [nondim] + if (abs(dlam) < tol_solve*lam_1) exit + enddo + + if (lam_1 > 0.0) cn(i,j,1) = 1.0 / sqrt(lam_1) + + ! sign of wave structure is irrelevant, flip to positive if needed + if (mode_struct(2)<0.) then + mode_struct(2:kc) = -1. * mode_struct(2:kc) + endif + + ! vertical derivative of w at interfaces lives on the layer points + do k=1,kc + mode_struct_fder(k) = (mode_struct(k) - mode_struct(k+1)) / dzc(k) + enddo + + ! boundary condition for derivative is no-gradient + do k=kc+1,nz + mode_struct_fder(k) = mode_struct_fder(kc) + enddo + + ! now save maximum value and bottom value + u_struct_bot(i,j,1) = mode_struct_fder(kc) + u_struct_max(i,j,1) = maxval(abs(mode_struct_fder(1:kc))) + + ! Calculate terms for vertically integrated energy equation + do k=1,kc + mode_struct_fder_sq(k) = mode_struct_fder(k)**2 + enddo + do K=1,kc+1 + mode_struct_sq(K) = mode_struct(K)**2 + enddo + + ! sum over layers for quantities defined on layer + do k=1,kc + int_U2(i,j,1) = int_U2(i,j,1) + mode_struct_fder_sq(k) * Hc(k) + enddo + + ! vertical integration with Trapezoidal rule for values at interfaces + do K=1,kc + int_w2(i,j,1) = int_w2(i,j,1) + 0.5*(mode_struct_sq(K)+mode_struct_sq(K+1)) * Hc(k) + int_N2w2(i,j,1) = int_N2w2(i,j,1) + 0.5*(mode_struct_sq(K)*N2(K) + & + mode_struct_sq(K+1)*N2(K+1)) * Hc(k) + enddo + + ! for w (diag) interpolate onto all interfaces + call interpolate_column(kc, Hc(1:kc), mode_struct(1:kc+1), & + nz, h(i,j,:), modal_structure(:), .false.) + + ! for u (remap) onto all layers + call remapping_core_h(CS%remapping_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & + nz, h(i,j,:), modal_structure_fder(:), & + GV%H_subroundoff, GV%H_subroundoff) + + ! write the wave structure + do k=1,nz+1 + w_struct(i,j,k,1) = modal_structure(k) + enddo + + do k=1,nz + u_struct(i,j,k,1) = modal_structure_fder(k) + enddo + + ! Find other eigen values if c1 is of significant magnitude, > cn_thresh + nrootsfound = 0 ! number of extra roots found (not including 1st root) + if ((nmodes > 1) .and. (kc >= nmodes+1) .and. (cn(i,j,1) > CS%c1_thresh)) then + ! Set the the range to look for the other desired eigen values + ! set min value just greater than the 1st root (found above) + lamMin = lam_1*(1.0 + tol_solve) + ! set max value based on a low guess at wavespeed for highest mode + speed2_min = (reduct_factor*cn(i,j,1)/real(nmodes))**2 + lamMax = 1.0 / speed2_min + ! set width of interval (not sure about this - BDM) + lamInc = 0.5*lam_1 + ! set number of intervals within search range + numint = nint((lamMax - lamMin)/lamInc) + + ! Find intervals containing zero-crossings (roots) of the determinant + ! that are beyond the first root + + ! find det_l of first interval (det at left endpoint) + call tridiag_det(Igu, Igl, 2, kc, lamMin, det_l, ddet_l, row_scale=c2_scale) + ! move interval window looking for zero-crossings************************ + do iint=1,numint + xr = lamMin + lamInc * iint + xl = xr - lamInc + call tridiag_det(Igu, Igl, 2, kc, xr, det_r, ddet_r, row_scale=c2_scale) + if (det_l*det_r < 0.0) then ! if function changes sign + if (det_l*ddet_l < 0.0) then ! if function at left is headed to zero + nrootsfound = nrootsfound + 1 + xbl(nrootsfound) = xl + xbr(nrootsfound) = xr + else + ! function changes sign but has a local max/min in interval, + ! try subdividing interval as many times as necessary (or sub_it_max). + ! loop that increases number of subintervals: + !call MOM_error(WARNING, "determinant changes sign"// & + ! "but has a local max/min in interval;"//& + ! " reduce increment in lam.") + ! begin subdivision loop ------------------------------------------- + sub_rootfound = .false. ! initialize + do sub_it=1,sub_it_max + nsub = 2**sub_it ! number of subintervals; nsub=2,4,8,... + ! loop over each subinterval: + do sub=1,nsub-1,2 ! only check odds; sub = 1; 1,3; 1,3,5,7;... + xl_sub = xl + lamInc/(nsub)*sub + call tridiag_det(Igu, Igl, 2, kc, xl_sub, det_sub, ddet_sub, & + row_scale=c2_scale) + if (det_sub*det_r < 0.0) then ! if function changes sign + if (det_sub*ddet_sub < 0.0) then ! if function at left is headed to zero + sub_rootfound = .true. + nrootsfound = nrootsfound + 1 + xbl(nrootsfound) = xl_sub + xbr(nrootsfound) = xr + exit ! exit sub loop + endif ! headed toward zero + endif ! sign change + enddo ! sub-loop + if (sub_rootfound) exit ! root has been found, exit sub_it loop + ! Otherwise, function changes sign but has a local max/min in one of the + ! sub intervals, try subdividing again unless sub_it_max has been reached. + if (sub_it == sub_it_max) then + call MOM_error(WARNING, "wave_speed: root not found "// & + " after sub_it_max subdivisions of original"// & + " interval.") + endif ! sub_it == sub_it_max + enddo ! sub_it-loop------------------------------------------------- + endif ! det_l*ddet_l < 0.0 + endif ! det_l*det_r < 0.0 + ! exit iint-loop if all desired roots have been found + if (nrootsfound >= nmodes-1) then + ! exit if all additional roots found + exit + elseif (iint == numint) then + ! oops, lamMax not large enough - could add code to increase (BDM) + ! set unfound modes to zero for now (BDM) + ! cn(i,j,nrootsfound+2:nmodes) = 0.0 + else + ! else shift interval and keep looking until nmodes or numint is reached + det_l = det_r + ddet_l = ddet_r + endif + enddo ! iint-loop + + ! Use Newton's method to find the roots within the identified windows + do m=1,nrootsfound ! loop over the root-containing widows (excluding 1st mode) + lam_n = xbl(m) ! first guess is left edge of window + + ! init and first guess for mode structure + mode_struct(:) = 0. + mode_struct_fder(:) = 0. + mode_struct(2:kc) = 1. ! Uniform flow, first guess + modal_structure(:) = 0. + modal_structure_fder(:) = 0. + + do itt=1,max_itt + ! calculate the determinant of (A-lam_n*I) + call tridiag_det(Igu, Igl, 2, kc, lam_n, det, ddet, row_scale=c2_scale) + ! Use Newton's method to find a new estimate of lam_n + dlam = - det / ddet + lam_n = lam_n + dlam + + call tdma6(kc-1, Igu(2:kc), Igl(2:kc), lam_n, mode_struct(2:kc)) + ! Note that tdma6 changes the units of mode_struct to [L2 T-2 ~> m2 s-2] + ! apply BC + mode_struct(1) = 0. + mode_struct(kc+1) = 0. + + ! renormalization of the integral of the profile + w2avg = 0.0 + do k=1,kc + w2avg = w2avg + 0.5*(mode_struct(K)**2+mode_struct(K+1)**2)*Hc(k) + enddo + renorm = sqrt(htot(i)*a_int/w2avg) + do K=1,kc+1 ; mode_struct(K) = renorm * mode_struct(K) ; enddo + + if (abs(dlam) < tol_solve*lam_1) exit + enddo ! itt-loop + + ! calculate nth mode speed + if (lam_n > 0.0) cn(i,j,m+1) = 1.0 / sqrt(lam_n) + + ! sign is irrelevant, flip to positive if needed + if (mode_struct(2)<0.) then + mode_struct(2:kc) = -1. * mode_struct(2:kc) + endif + + ! derivative of vertical profile (i.e. dw/dz) is evaluated at the layer point + do k=1,kc + mode_struct_fder(k) = (mode_struct(k) - mode_struct(k+1)) / dzc(k) + enddo + + ! boundary condition for 1st derivative is no-gradient + do k=kc+1,nz + mode_struct_fder(k) = mode_struct_fder(kc) + enddo + + ! now save maximum value and bottom value + u_struct_bot(i,j,m) = mode_struct_fder(kc) + u_struct_max(i,j,m) = maxval(abs(mode_struct_fder(1:kc))) + + ! Calculate terms for vertically integrated energy equation + do k=1,kc + mode_struct_fder_sq(k) = mode_struct_fder(k)**2 + enddo + do K=1,kc+1 + mode_struct_sq(K) = mode_struct(K)**2 + enddo + + ! sum over layers for integral of quantities defined at layer points + do k=1,kc + int_U2(i,j,m) = int_U2(i,j,m) + mode_struct_fder_sq(k) * Hc(k) + enddo + + ! vertical integration with Trapezoidal rule for quantities on interfaces + do K=1,kc + int_w2(i,j,m) = int_w2(i,j,m) + 0.5*(mode_struct_sq(K)+mode_struct_sq(K+1)) * Hc(k) + int_N2w2(i,j,m) = int_N2w2(i,j,m) + 0.5*(mode_struct_sq(K)*N2(K) + & + mode_struct_sq(K+1)*N2(K+1)) * Hc(k) + enddo + + ! for w (diag) interpolate onto all interfaces + call interpolate_column(kc, Hc(1:kc), mode_struct(1:kc+1), & + nz, h(i,j,:), modal_structure(:), .false.) + + ! for u (remap) onto all layers + call remapping_core_h(CS%remapping_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & + nz, h(i,j,:), modal_structure_fder(:), & + GV%H_subroundoff, GV%H_subroundoff) + + ! write the wave structure + ! note that m=1 solves for 2nd mode,... + do k=1,nz+1 + w_struct(i,j,k,m+1) = modal_structure(k) + enddo + + do k=1,nz + u_struct(i,j,k,m+1) = modal_structure_fder(k) + enddo + + enddo ! n-loop + endif ! if nmodes>1 .and. kc>nmodes .and. c1>c1_thresh + endif ! if more than 2 layers + endif ! if drxh_sum < 0 + endif ! if not land + enddo ! i-loop + enddo ! j-loop + +end subroutine wave_speeds + +!> Calculate the determinant of a tridiagonal matrix with diagonals a,b-lam,c and its derivative +!! with lam, where lam is constant across rows. Only the ratio of det to its derivative and their +!! signs are typically used, so internal rescaling by consistent factors are used to avoid +!! over- or underflow. +subroutine tridiag_det(a, c, ks, ke, lam, det, ddet, row_scale) + real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry unused) [T2 L-2 ~> s2 m-2] + real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry unused) [T2 L-2 ~> s2 m-2] + integer, intent(in) :: ks !< Starting index to use in determinant + integer, intent(in) :: ke !< Ending index to use in determinant + real, intent(in) :: lam !< Value subtracted from b [T2 L-2 ~> s2 m-2] + real, intent(out):: det !< Determinant of the matrix in dynamically rescaled units that + !! depend on the number of rows and the cumulative magnitude of + !! det and are therefore difficult to interpret, but the units + !! of det/ddet are always in [T2 L-2 ~> s2 m-2] + real, intent(out):: ddet !< Derivative of determinant with lam in units that are dynamically + !! rescaled along with those of det, such that the units of + !! det/ddet are always in [T2 L-2 ~> s2 m-2] + real, intent(in) :: row_scale !< A scaling factor of the rows of the matrix to + !! limit the growth of the determinant [L2 s2 T-2 m-2 ~> 1] + ! Local variables + real :: detKm1, detKm2 ! Cumulative value of the determinant for the previous two layers in units + ! that vary with the number of layers that have been worked on [various] + real :: ddetKm1, ddetKm2 ! Derivative of the cumulative determinant with lam for the previous two + ! layers [various], but the units of detKm1/ddetKm1 are [T2 L-2 ~> s2 m-2] + real, parameter :: rescale = 1024.0**4 ! max value of determinant allowed before rescaling [nondim] + real :: I_rescale ! inverse of rescale [nondim] + integer :: k ! row (layer interface) index + + I_rescale = 1.0 / rescale + + detKm1 = 1.0 ; ddetKm1 = 0.0 + det = (a(ks)+c(ks)) - lam ; ddet = -1.0 + do k=ks+1,ke + ! Shift variables and rescale rows to avoid over- or underflow. + detKm2 = row_scale*detKm1 ; ddetKm2 = row_scale*ddetKm1 + detKm1 = row_scale*det ; ddetKm1 = row_scale*ddet + + det = ((a(k)+c(k))-lam)*detKm1 - (a(k)*c(k-1))*detKm2 + ddet = ((a(k)+c(k))-lam)*ddetKm1 - (a(k)*c(k-1))*ddetKm2 - detKm1 + + ! Rescale det & ddet if det is getting too large or too small. + if (abs(det) > rescale) then + det = I_rescale*det ; detKm1 = I_rescale*detKm1 + ddet = I_rescale*ddet ; ddetKm1 = I_rescale*ddetKm1 + elseif (abs(det) < I_rescale) then + det = rescale*det ; detKm1 = rescale*detKm1 + ddet = rescale*ddet ; ddetKm1 = rescale*ddetKm1 + endif + enddo + +end subroutine tridiag_det + +!> Initialize control structure for MOM_wave_speed +subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & + remap_answer_date, better_speed_est, min_speed, wave_speed_tol, c1_thresh) + type(wave_speed_CS), intent(inout) :: CS !< Wave speed control struct + logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent + !! barotropic mode instead of the first baroclinic mode. + real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over + !! which N2 is limited as monotonic for the purposes of + !! calculating the vertical modal structure [nondim]. + real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited + !! as monotonic for the purposes of calculating the + !! vertical modal structure [H ~> m or kg m-2]. + logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions + !! that recover the remapping answers from 2018. Otherwise + !! use more robust but mathematically equivalent expressions. + integer, optional, intent(in) :: remap_answer_date !< The vintage of the order of arithmetic and expressions + !! to use for remapping. Values below 20190101 recover the remapping + !! answers from 2018, while higher values use more robust + !! forms of the same remapping expressions. + logical, optional, intent(in) :: better_speed_est !< If true, use a more robust estimate of the first + !! mode speed as the starting point for iterations. + real, optional, intent(in) :: min_speed !< If present, set a floor in the first mode speed + !! below which 0 is returned [L T-1 ~> m s-1]. + real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the + !! wave speeds [nondim] + real, optional, intent(in) :: c1_thresh !< A minimal value of the first mode internal wave speed + !! below which all higher mode speeds are not calculated but are + !! simply reported as 0 [L T-1 ~> m s-1]. A non-negative value + !! must be specified for wave_speeds to be used (but not wave_speed). + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_wave_speed" ! This module's name. + + CS%initialized = .true. + + ! Write all relevant parameters to the model log. + call log_version(mdl, version) + + call wave_speed_set_param(CS, use_ebt_mode=use_ebt_mode, mono_N2_column_fraction=mono_N2_column_fraction, & + mono_N2_depth=mono_N2_depth, better_speed_est=better_speed_est, & + min_speed=min_speed, wave_speed_tol=wave_speed_tol, & + remap_answers_2018=remap_answers_2018, remap_answer_date=remap_answer_date, & + c1_thresh=c1_thresh) + + ! The remap_answers_2018 argument here is irrelevant, because remapping is hard-coded to use PLM. + call initialize_remapping(CS%remapping_CS, 'PLM', boundary_extrapolation=.false., & + answer_date=CS%remap_answer_date) + +end subroutine wave_speed_init + +!> Sets internal parameters for MOM_wave_speed +subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & + remap_answer_date, better_speed_est, min_speed, wave_speed_tol, c1_thresh) + type(wave_speed_CS), intent(inout) :: CS + !< Control structure for MOM_wave_speed + logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent + !! barotropic mode instead of the first baroclinic mode. + real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over + !! which N2 is limited as monotonic for the purposes of + !! calculating the vertical modal structure [nondim]. + real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited + !! as monotonic for the purposes of calculating the + !! vertical modal structure [H ~> m or kg m-2]. + logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions + !! that recover the remapping answers from 2018. Otherwise + !! use more robust but mathematically equivalent expressions. + integer, optional, intent(in) :: remap_answer_date !< The vintage of the order of arithmetic and expressions + !! to use for remapping. Values below 20190101 recover the remapping + !! answers from 2018, while higher values use more robust + !! forms of the same remapping expressions. + logical, optional, intent(in) :: better_speed_est !< If true, use a more robust estimate of the first + !! mode speed as the starting point for iterations. + real, optional, intent(in) :: min_speed !< If present, set a floor in the first mode speed + !! below which 0 is returned [L T-1 ~> m s-1]. + real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the + !! wave speeds [nondim] + real, optional, intent(in) :: c1_thresh !< A minimal value of the first mode internal wave speed + !! below which all higher mode speeds are not calculated but are + !! simply reported as 0 [L T-1 ~> m s-1]. A non-negative value + !! must be specified for wave_speeds to be used (but not wave_speed). + + if (present(use_ebt_mode)) CS%use_ebt_mode = use_ebt_mode + if (present(mono_N2_column_fraction)) CS%mono_N2_column_fraction = mono_N2_column_fraction + if (present(mono_N2_depth)) CS%mono_N2_depth = mono_N2_depth + if (present(remap_answers_2018)) then + if (remap_answers_2018) then + CS%remap_answer_date = 20181231 + else + CS%remap_answer_date = 20190101 + endif + endif + if (present(remap_answer_date)) CS%remap_answer_date = remap_answer_date + if (present(better_speed_est)) CS%better_cg1_est = better_speed_est + if (present(min_speed)) CS%min_speed2 = min_speed**2 + if (present(wave_speed_tol)) CS%wave_speed_tol = wave_speed_tol + if (present(c1_thresh)) CS%c1_thresh = c1_thresh + +end subroutine wave_speed_set_param + +!> \namespace mom_wave_speed + +!! +!! Subroutine wave_speed() solves for the first baroclinic mode wave speed. (It could +!! solve for all the wave speeds, but the iterative approach taken here means +!! that this is not particularly efficient.) +!! +!! If `e(k)` is the perturbation interface height, this means solving for the +!! smallest eigenvalue (`lam` = 1/c^2) of the system +!! +!! \verbatim +!! -Igu(k)*e(k-1) + (Igu(k)+Igl(k)-lam)*e(k) - Igl(k)*e(k+1) = 0.0 +!! \endverbatim +!! +!! with rigid lid boundary conditions e(1) = e(nz+1) = 0.0 giving +!! +!! \verbatim +!! (Igu(2)+Igl(2)-lam)*e(2) - Igl(2)*e(3) = 0.0 +!! -Igu(nz)*e(nz-1) + (Igu(nz)+Igl(nz)-lam)*e(nz) = 0.0 +!! \endverbatim +!! +!! Here +!! \verbatim +!! Igl(k) = 1.0/(gprime(K)*h(k)) ; Igu(k) = 1.0/(gprime(K)*h(k-1)) +!! \endverbatim +!! +!! Alternately, these same eigenvalues can be found from the second smallest +!! eigenvalue of the Montgomery potential (M(k)) calculation: +!! +!! \verbatim +!! -Igl(k)*M(k-1) + (Igl(k)+Igu(k+1)-lam)*M(k) - Igu(k+1)*M(k+1) = 0.0 +!! \endverbatim +!! +!! with rigid lid and flat bottom boundary conditions +!! +!! \verbatim +!! (Igu(2)-lam)*M(1) - Igu(2)*M(2) = 0.0 +!! -Igl(nz)*M(nz-1) + (Igl(nz)-lam)*M(nz) = 0.0 +!! \endverbatim +!! +!! Note that the barotropic mode has been eliminated from the rigid lid +!! interface height equations, hence the matrix is one row smaller. Without +!! the rigid lid, the top boundary condition is simpler to implement with +!! the M equations. + +end module MOM_wave_speed diff --git a/equation_of_state/MOM_EOS.F90 b/equation_of_state/MOM_EOS.F90 new file mode 100644 index 0000000000..7a9de49573 --- /dev/null +++ b/equation_of_state/MOM_EOS.F90 @@ -0,0 +1,2529 @@ +!> Provides subroutines for quantities specific to the equation of state +module MOM_EOS + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS_base_type, only : EOS_base +use MOM_EOS_linear, only : linear_EOS, avg_spec_vol_linear +use MOM_EOS_linear, only : int_density_dz_linear, int_spec_vol_dp_linear +use MOM_EOS_Wright, only : buggy_Wright_EOS, avg_spec_vol_buggy_Wright +use MOM_EOS_Wright, only : int_density_dz_wright, int_spec_vol_dp_wright +use MOM_EOS_Wright_full, only : Wright_full_EOS, avg_spec_vol_Wright_full +use MOM_EOS_Wright_full, only : int_density_dz_wright_full, int_spec_vol_dp_wright_full +use MOM_EOS_Wright_red, only : Wright_red_EOS, avg_spec_vol_Wright_red +use MOM_EOS_Wright_red, only : int_density_dz_wright_red, int_spec_vol_dp_wright_red +use MOM_EOS_Jackett06, only : Jackett06_EOS +use MOM_EOS_UNESCO, only : UNESCO_EOS +use MOM_EOS_Roquet_rho, only : Roquet_rho_EOS +use MOM_EOS_Roquet_SpV, only : Roquet_SpV_EOS +use MOM_EOS_TEOS10, only : TEOS10_EOS +use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_temperature_convert, only : poTemp_to_consTemp, consTemp_to_poTemp +use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero +use MOM_TFreeze, only : calculate_TFreeze_teos10, calculate_TFreeze_TEOS_poly +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : stdout, stderr +use MOM_string_functions, only : uppercase +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +public EOS_domain +public EOS_init +public EOS_manual_init +public EOS_quadrature +public EOS_use_linear +public EOS_fit_range +public EOS_unit_tests +public analytic_int_density_dz +public analytic_int_specific_vol_dp +public average_specific_vol +public calculate_compress +public calculate_density_elem +public calculate_density +public calculate_density_derivs +public calculate_density_second_derivs +public calculate_spec_vol +public calculate_specific_vol_derivs +public calculate_TFreeze +public convert_temp_salt_for_TEOS10 +public cons_temp_to_pot_temp +public abs_saln_to_prac_saln +public gsw_sp_from_sr +public gsw_pt_from_ct +public query_compressible +public get_EOS_name + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Calculates density of sea water from T, S and P +interface calculate_density + module procedure calculate_density_scalar + module procedure calculate_density_1d + module procedure calculate_stanley_density_scalar + module procedure calculate_stanley_density_1d +end interface calculate_density + +!> Calculates specific volume of sea water from T, S and P +interface calculate_spec_vol + module procedure calc_spec_vol_scalar + module procedure calc_spec_vol_1d +end interface calculate_spec_vol + +!> Calculate the derivatives of density with temperature and salinity from T, S, and P +interface calculate_density_derivs + module procedure calculate_density_derivs_scalar, calculate_density_derivs_array + module procedure calculate_density_derivs_1d +end interface calculate_density_derivs + +!> Calculate the derivatives of specific volume with temperature and salinity from T, S, and P +interface calculate_specific_vol_derivs + module procedure calc_spec_vol_derivs_1d +end interface calculate_specific_vol_derivs + +!> Calculates the second derivatives of density with various combinations of temperature, +!! salinity, and pressure from T, S and P +interface calculate_density_second_derivs + module procedure calculate_density_second_derivs_scalar, calculate_density_second_derivs_1d +end interface calculate_density_second_derivs + +!> Calculates the freezing point of sea water from T, S and P +interface calculate_TFreeze + module procedure calculate_TFreeze_scalar, calculate_TFreeze_1d, calculate_TFreeze_array +end interface calculate_TFreeze + +!> Calculates the compressibility of water from T, S, and P +interface calculate_compress + module procedure calculate_compress_scalar, calculate_compress_1d +end interface calculate_compress + +!> A control structure for the equation of state +type, public :: EOS_type ; private + integer :: form_of_EOS = 0 !< The equation of state to use. + integer :: form_of_TFreeze = 0 !< The expression for the potential temperature + !! of the freezing point. + logical :: EOS_quadrature !< If true, always use the generic (quadrature) + !! code for the integrals of density. + logical :: Compressible = .true. !< If true, in situ density is a function of pressure. +! The following parameters are used with the linear equation of state only. + real :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3] + real :: dRho_dT !< The partial derivative of density with temperature [kg m-3 degC-1] + real :: dRho_dS !< The partial derivative of density with salinity [kg m-3 ppt-1] +! The following parameters are use with the linear expression for the freezing +! point only. + real :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC] + real :: dTFr_dS !< The derivative of freezing point with salinity [degC ppt-1] + real :: dTFr_dp !< The derivative of freezing point with pressure [degC Pa-1] + + logical :: use_Wright_2nd_deriv_bug = .false. !< If true, use a separate subroutine that + !! retains a buggy version of the calculations of the second + !! derivative of density with temperature and with temperature and + !! pressure. This bug is corrected in the default version. + +! Unit conversion factors (normally used for dimensional testing but could also allow for +! change of units of arguments to functions) + real :: m_to_Z = 1. !< A constant that translates distances in meters to the units of depth [Z m-1 ~> 1] + real :: kg_m3_to_R = 1. !< A constant that translates kilograms per meter cubed to the + !! units of density [R m3 kg-1 ~> 1] + real :: R_to_kg_m3 = 1. !< A constant that translates the units of density to + !! kilograms per meter cubed [kg m-3 R-1 ~> 1] + real :: RL2_T2_to_Pa = 1.!< Convert pressures from R L2 T-2 to Pa [Pa T2 R-1 L-2 ~> 1] + real :: L_T_to_m_s = 1. !< Convert lateral velocities from L T-1 to m s-1 [m T s-1 L-1 ~> 1] + real :: degC_to_C = 1. !< A constant that translates degrees Celsius to the units of temperature [C degC-1 ~> 1] + real :: C_to_degC = 1. !< A constant that translates the units of temperature to degrees Celsius [degC C-1 ~> 1] + real :: ppt_to_S = 1. !< A constant that translates parts per thousand to the units of salinity [S ppt-1 ~> 1] + real :: S_to_ppt = 1. !< A constant that translates the units of salinity to parts per thousand [ppt S-1 ~> 1] + + !> The instance of the actual equation of state + class(EOS_base), allocatable :: type + +end type EOS_type + +! The named integers that might be stored in eqn_of_state_type%form_of_EOS. +integer, parameter, public :: EOS_LINEAR = 1 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_UNESCO = 2 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_WRIGHT = 3 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_WRIGHT_FULL = 4 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_WRIGHT_REDUCED = 5 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_TEOS10 = 6 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_ROQUET_RHO = 7 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_ROQUET_SPV = 8 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_JACKETT06 = 9 !< A named integer specifying an equation of state +!> A list of all the available EOS +integer, dimension(9), public :: list_of_EOS = (/ EOS_LINEAR, EOS_UNESCO, & + EOS_WRIGHT, EOS_WRIGHT_FULL, EOS_WRIGHT_REDUCED, & + EOS_TEOS10, EOS_ROQUET_RHO, EOS_ROQUET_SPV, EOS_JACKETT06 /) + +character*(12), parameter :: EOS_LINEAR_STRING = "LINEAR" !< A string for specifying the equation of state +character*(12), parameter :: EOS_UNESCO_STRING = "UNESCO" !< A string for specifying the equation of state +character*(12), parameter :: EOS_JACKETT_STRING = "JACKETT_MCD" !< A string for specifying the equation of state +character*(12), parameter :: EOS_WRIGHT_STRING = "WRIGHT" !< A string for specifying the equation of state +character*(16), parameter :: EOS_WRIGHT_RED_STRING = "WRIGHT_REDUCED" !< A string for specifying the equation of state +character*(12), parameter :: EOS_WRIGHT_FULL_STRING = "WRIGHT_FULL" !< A string for specifying the equation of state +character*(12), parameter :: EOS_TEOS10_STRING = "TEOS10" !< A string for specifying the equation of state +character*(12), parameter :: EOS_NEMO_STRING = "NEMO" !< A string for specifying the equation of state +character*(12), parameter :: EOS_ROQUET_RHO_STRING = "ROQUET_RHO" !< A string for specifying the equation of state +character*(12), parameter :: EOS_ROQUET_SPV_STRING = "ROQUET_SPV" !< A string for specifying the equation of state +character*(12), parameter :: EOS_JACKETT06_STRING = "JACKETT_06" !< A string for specifying the equation of state +character*(12), parameter :: EOS_DEFAULT = EOS_WRIGHT_STRING !< The default equation of state + +integer, parameter :: TFREEZE_LINEAR = 1 !< A named integer specifying a freezing point expression +integer, parameter :: TFREEZE_MILLERO = 2 !< A named integer specifying a freezing point expression +integer, parameter :: TFREEZE_TEOS10 = 3 !< A named integer specifying a freezing point expression +integer, parameter :: TFREEZE_TEOSPOLY = 4 !< A named integer specifying a freezing point expression +character*(10), parameter :: TFREEZE_LINEAR_STRING = "LINEAR" !< A string for specifying the freezing point expression +character*(10), parameter :: TFREEZE_MILLERO_STRING = "MILLERO_78" !< A string for specifying the + !! freezing point expression +character*(10), parameter :: TFREEZE_TEOSPOLY_STRING = "TEOS_POLY" !< A string for specifying the + !! freezing point expression +character*(10), parameter :: TFREEZE_TEOS10_STRING = "TEOS10" !< A string for specifying the freezing point expression + +contains + +!> Density of sea water (in-situ if pressure is local) [R ~> kg m-3] +!! +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. The pressure and +!! density can be rescaled with the values stored in EOS. If the scale argument is present the density +!! scaling uses the product of the two scaling factors. +real elemental function calculate_density_elem(EOS, T, S, pressure, rho_ref, scale) + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, optional, intent(in) :: rho_ref !< A reference density [R ~> kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale output density in + !! combination with scaling stored in EOS [various] + real :: Ta ! An array of temperatures [degC] + real :: Sa ! An array of salinities [ppt] + real :: pres ! An mks version of the pressure to use [Pa] + real :: rho_mks ! An mks version of the density to be returned [kg m-3] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + + pres = EOS%RL2_T2_to_Pa * pressure + Ta = EOS%C_to_degC * T + Sa = EOS%S_to_ppt * S + + if (present(rho_ref)) then + rho_mks = EOS%type%density_anomaly_elem(Ta, Sa, pres, EOS%R_to_kg_m3*rho_ref) + else + rho_mks = EOS%type%density_elem(Ta, Sa, pres) + endif + + ! Rescale the output density to the desired units. + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + calculate_density_elem = rho_scale * rho_mks + +end function calculate_density_elem + +!> Calls the appropriate subroutine to calculate density of sea water for scalar inputs. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. The pressure and +!! density can be rescaled with the values stored in EOS. If the scale argument is present the density +!! scaling uses the product of the two scaling factors. +subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale) + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, intent(out) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(in) :: rho_ref !< A reference density [R ~> kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale output density in + !! combination with scaling stored in EOS [various] + + real :: Ta ! An array of temperatures [degC] + real :: Sa ! An array of salinities [ppt] + real :: pres ! An mks version of the pressure to use [Pa] + real :: rho_mks ! An mks version of the density to be returned [kg m-3] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + + pres = EOS%RL2_T2_to_Pa * pressure + Ta = EOS%C_to_degC * T + Sa = EOS%S_to_ppt * S + + if (present(rho_ref)) then + rho_mks = EOS%type%density_anomaly_elem(Ta, Sa, pres, EOS%R_to_kg_m3*rho_ref) + else + rho_mks = EOS%type%density_elem(Ta, Sa, pres) + endif + + ! Rescale the output density to the desired units. + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + rho = rho_scale * rho_mks + +end subroutine calculate_density_scalar + +!> Calls the appropriate subroutine to calculate density of sea water for scalar inputs +!! including the variance of T, S and covariance of T-S. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. The +!! density can be rescaled using rho_ref. +subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, rho, EOS, rho_ref, scale) + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [C2 ~> degC2] + real, intent(in) :: TScov !< Covariance of potential temperature and salinity [C S ~> degC ppt] + real, intent(in) :: Svar !< Variance of salinity [S2 ~> ppt2] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, intent(out) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(in) :: rho_ref !< A reference density [R ~> kg m-3]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale output density in + !! combination with scaling stored in EOS [various] + ! Local variables + real :: d2RdTT ! Second derivative of density with temperature [R C-2 ~> kg m-3 degC-2] + real :: d2RdST ! Second derivative of density with temperature and salinity [R S-1 C-1 ~> kg m-3 degC-1 ppt-1] + real :: d2RdSS ! Second derivative of density with salinity [R S-2 ~> kg m-3 ppt-2] + real :: d2RdSp ! Second derivative of density with salinity and pressure [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + real :: d2RdTp ! Second derivative of density with temperature and pressure [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] + + call calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref) + call calculate_density_second_derivs_scalar(T, S, pressure, d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP, EOS) + + ! Equation 25 of Stanley et al., 2020. + rho = rho + ( 0.5 * d2RdTT * Tvar + ( d2RdST * TScov + 0.5 * d2RdSS * Svar ) ) + + if (present(scale)) rho = rho * scale + +end subroutine calculate_stanley_density_scalar + +!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs, +!! potentially limiting the domain of indices that are worked on. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: rho_ref !< A reference density [R ~> kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling stored in EOS [various] + ! Local variables + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, dimension(size(rho)) :: pres ! Pressure converted to [Pa] + real, dimension(size(rho)) :: Ta ! Temperature converted to [degC] + real, dimension(size(rho)) :: Sa ! Salinity converted to [ppt] + integer :: i, is, ie, npts + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(rho) ; npts = 1 + ie - is + endif + + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%R_to_kg_m3 == 1.0) .and. & + (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + call EOS%type%calculate_density_array(T, S, pressure, rho, is, npts, rho_ref=rho_ref) + else ! This is the same as above, but with some extra work to rescale variables. + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + if (present(rho_ref)) then + call EOS%type%calculate_density_array(Ta, Sa, pres, rho, is, npts, rho_ref=EOS%R_to_kg_m3*rho_ref) + else + call EOS%type%calculate_density_array(Ta, Sa, pres, rho, is, npts) + endif + endif + + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then ; do i=is,ie + rho(i) = rho_scale * rho(i) + enddo ; endif + +end subroutine calculate_density_1d + +!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs +!! including the variance of T, S and covariance of T-S, +!! potentially limiting the domain of indices that are worked on. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, EOS, dom, rho_ref, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature [C2 ~> degC2] + real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [C S ~> degC ppt] + real, dimension(:), intent(in) :: Svar !< Variance of salinity [S2 ~> ppt2] + real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: rho_ref !< A reference density [R ~> kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling stored in EOS [various] + ! Local variables + real, dimension(size(T)) :: & + d2RdTT, & ! Second derivative of density with temperature [R C-2 ~> kg m-3 degC-2] + d2RdST, & ! Second derivative of density with temperature and salinity [R S-1 C-1 ~> kg m-3 degC-1 ppt-1] + d2RdSS, & ! Second derivative of density with salinity [R S-2 ~> kg m-3 ppt-2] + d2RdSp, & ! Second derivative of density with salinity and pressure [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + d2RdTp ! Second derivative of density with temperature and pressure [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] + integer :: i, is, ie, npts + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(rho) ; npts = 1 + ie - is + endif + + call calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref) + call calculate_density_second_derivs_1d(T, S, pressure, d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP, EOS, dom) + + ! Equation 25 of Stanley et al., 2020. + do i=is,ie + rho(i) = rho(i) + ( 0.5 * d2RdTT(i) * Tvar(i) + ( d2RdST(i) * TScov(i) + 0.5 * d2RdSS(i) * Svar(i) ) ) + enddo + + if (present(scale)) then ; if (scale /= 1.0) then ; do i=is,ie + rho(i) = scale * rho(i) + enddo ; endif ; endif + +end subroutine calculate_stanley_density_1d + +!> Calls the appropriate subroutine to calculate the specific volume of sea water +!! for 1-D array inputs. +subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref, scale) + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< salinity [ppt] + real, dimension(:), intent(in) :: pressure !< pressure [Pa] + real, dimension(:), intent(inout) :: specvol !< in situ specific volume [kg m-3] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific + !! volume in combination with scaling stored in EOS [various] + + real, dimension(size(specvol)) :: rho ! Density [kg m-3] + integer :: j + + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_spec_vol_array: EOS%form_of_EOS is not valid.") + + call EOS%type%calculate_spec_vol_array(T, S, pressure, specvol, start, npts, spv_ref) + + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + specvol(j) = scale * specvol(j) + enddo ; endif ; endif + +end subroutine calculate_spec_vol_array + +!> Calls the appropriate subroutine to calculate specific volume of sea water +!! for scalar inputs. +subroutine calc_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, scale) + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, intent(out) :: specvol !< In situ or potential specific volume [R-1 ~> m3 kg-1] + !! or other units determined by the scale argument + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(in) :: spv_ref !< A reference specific volume [R-1 ~> m3 kg-1] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific + !! volume in combination with scaling stored in EOS [various] + + real, dimension(1) :: Ta ! Rescaled single element array version of temperature [degC] + real, dimension(1) :: Sa ! Rescaled single element array version of salinity [ppt] + real, dimension(1) :: pres ! Rescaled single element array version of pressure [Pa] + real, dimension(1) :: spv ! Rescaled single element array version of specific volume [m3 kg-1] + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] + + pres(1) = EOS%RL2_T2_to_Pa * pressure + Ta(1) = EOS%C_to_degC * T ; Sa(1) = EOS%S_to_ppt * S + + if (present(spv_ref)) then + call calculate_spec_vol_array(Ta, Sa, pres, spv, 1, 1, EOS, EOS%kg_m3_to_R*spv_ref) + else + call calculate_spec_vol_array(Ta, Sa, pres, spv, 1, 1, EOS) + endif + specvol = spv(1) + + spv_scale = EOS%R_to_kg_m3 + if (present(scale)) spv_scale = spv_scale * scale + if (spv_scale /= 1.0) then + specvol = spv_scale * specvol + endif + +end subroutine calc_spec_vol_scalar + +!> Calls the appropriate subroutine to calculate the specific volume of sea water for 1-D array +!! inputs, potentially limiting the domain of indices that are worked on. +subroutine calc_spec_vol_1d(T, S, pressure, specvol, EOS, dom, spv_ref, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: specvol !< In situ specific volume [R-1 ~> m3 kg-1] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: spv_ref !< A reference specific volume [R-1 ~> m3 kg-1] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale + !! output specific volume in combination with + !! scaling stored in EOS [various] + ! Local variables + real, dimension(size(T)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(T)) :: Sa ! Salinity converted to [ppt] + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + integer :: i, is, ie, npts + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(specvol) ; npts = 1 + ie - is + endif + + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%kg_m3_to_R == 1.0) .and. & + (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + call calculate_spec_vol_array(T, S, pressure, specvol, is, npts, EOS, spv_ref) + else ! This is the same as above, but with some extra work to rescale variables. + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + if (present(spv_ref)) then + call calculate_spec_vol_array(Ta, Sa, pres, specvol, is, npts, EOS, EOS%kg_m3_to_R*spv_ref) + else + ! There is rescaling of variables, but spv_ref is not present. Passing a 0 value of spv_ref + ! changes answers at roundoff for some equations of state, like Wright and UNESCO. + call calculate_spec_vol_array(Ta, Sa, pres, specvol, is, npts, EOS) + endif + endif + + spv_scale = EOS%R_to_kg_m3 + if (present(scale)) spv_scale = spv_scale * scale + if (spv_scale /= 1.0) then ; do i=is,ie + specvol(i) = spv_scale * specvol(i) + enddo ; endif + +end subroutine calc_spec_vol_1d + + +!> Calls the appropriate subroutine to calculate the freezing point for scalar inputs. +subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS, pres_scale, scale_from_EOS) + real, intent(in) :: S !< Salinity, [ppt] or [S ~> ppt] depending on scale_from_EOS + real, intent(in) :: pressure !< Pressure, in [Pa] or [R L2 T-2 ~> Pa] depending on + !! pres_scale or scale_from_EOS + real, intent(out) :: T_fr !< Freezing point potential temperature referenced to the + !! surface [degC] or [C ~> degC] depending on scale_from_EOS + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + logical, optional, intent(in) :: scale_from_EOS !< If present true use the dimensional scaling + !! factors stored in EOS. Omission is the same .false. + + ! Local variables + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: S_scale ! A factor to convert salinity to units of ppt [ppt S-1 ~> 1] + + p_scale = 1.0 ; S_scale = 1.0 + if (present(pres_scale)) p_scale = pres_scale + if (present(scale_from_EOS)) then ; if (scale_from_EOS) then + p_scale = EOS%RL2_T2_to_Pa + S_scale = EOS%S_to_ppt + endif ; endif + + select case (EOS%form_of_TFreeze) + case (TFREEZE_LINEAR) + call calculate_TFreeze_linear(S_scale*S, p_scale*pressure, T_fr, EOS%TFr_S0_P0, & + EOS%dTFr_dS, EOS%dTFr_dp) + case (TFREEZE_MILLERO) + call calculate_TFreeze_Millero(S_scale*S, p_scale*pressure, T_fr) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(S_scale*S, p_scale*pressure, T_fr) + case (TFREEZE_TEOS10) + call calculate_TFreeze_teos10(S_scale*S, p_scale*pressure, T_fr) + case default + call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") + end select + + if (present(scale_from_EOS)) then ; if (scale_from_EOS) then + T_fr = EOS%degC_to_C * T_fr + endif ; endif + +end subroutine calculate_TFreeze_scalar + +!> Calls the appropriate subroutine to calculate the freezing point for a 1-D array. +subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_scale) + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure, in [Pa] or [R L2 T-2 ~> Pa] depending on pres_scale + real, dimension(:), intent(inout) :: T_fr !< Freezing point potential temperature referenced + !! to the surface [degC] + integer, intent(in) :: start !< Starting index within the array + integer, intent(in) :: npts !< The number of values to calculate + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + + ! Local variables + real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + integer :: j + + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + + if (p_scale == 1.0) then + select case (EOS%form_of_TFreeze) + case (TFREEZE_LINEAR) + call calculate_TFreeze_linear(S, pressure, T_fr, start, npts, & + EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) + case (TFREEZE_MILLERO) + call calculate_TFreeze_Millero(S, pressure, T_fr, start, npts) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(S, pressure, T_fr, start, npts) + case (TFREEZE_TEOS10) + call calculate_TFreeze_teos10(S, pressure, T_fr, start, npts) + case default + call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") + end select + else + do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo + select case (EOS%form_of_TFreeze) + case (TFREEZE_LINEAR) + call calculate_TFreeze_linear(S, pres, T_fr, start, npts, & + EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) + case (TFREEZE_MILLERO) + call calculate_TFreeze_Millero(S, pres, T_fr, start, npts) + case (TFREEZE_TEOS10) + call calculate_TFreeze_teos10(S, pres, T_fr, start, npts) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(S, pres, T_fr, start, npts) + case default + call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") + end select + endif + +end subroutine calculate_TFreeze_array + +!> Calls the appropriate subroutine to calculate the freezing point for a 1-D array, taking +!! dimensionally rescaled arguments with factors stored in EOS. +subroutine calculate_TFreeze_1d(S, pressure, T_fr, EOS, dom) + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: T_fr !< Freezing point potential temperature referenced + !! to the surface [C ~> degC] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + + ! Local variables + real, dimension(size(T_fr)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T_fr)) :: Sa ! Salinity converted to [ppt] + integer :: i, is, ie, npts + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(T_Fr) ; npts = 1 + ie - is + endif + + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + select case (EOS%form_of_TFreeze) + case (TFREEZE_LINEAR) + call calculate_TFreeze_linear(S, pressure, T_fr, is, npts, & + EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) + case (TFREEZE_MILLERO) + call calculate_TFreeze_Millero(S, pressure, T_fr, is, npts) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(S, pressure, T_fr, is, npts) + case (TFREEZE_TEOS10) + call calculate_TFreeze_teos10(S, pressure, T_fr, is, npts) + case default + call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") + end select + else + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + select case (EOS%form_of_TFreeze) + case (TFREEZE_LINEAR) + call calculate_TFreeze_linear(Sa, pres, T_fr, is, npts, & + EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) + case (TFREEZE_MILLERO) + call calculate_TFreeze_Millero(Sa, pres, T_fr, is, npts) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(Sa, pres, T_fr, is, npts) + case (TFREEZE_TEOS10) + call calculate_TFreeze_teos10(Sa, pres, T_fr, is, npts) + case default + call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") + end select + endif + + if (EOS%degC_to_C /= 1.0) then + do i=is,ie ; T_fr(i) = EOS%degC_to_C * T_fr(i) ; enddo + endif + +end subroutine calculate_TFreeze_1d + + +!> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. +subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(inout) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] or other units determined + !! by the optional scale argument + real, dimension(:), intent(inout) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 ppt-1] or other units determined + !! by the optional scale argument + integer, intent(in) :: start !< Starting index within the array + integer, intent(in) :: npts !< The number of values to calculate + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling stored in EOS [various] + + ! Local variables + integer :: j + + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") + + call EOS%type%calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts) + + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + drho_dT(j) = scale * drho_dT(j) + drho_dS(j) = scale * drho_dS(j) + enddo ; endif ; endif + +end subroutine calculate_density_derivs_array + + +!> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. +subroutine calculate_density_derivs_1d(T, S, pressure, drho_dT, drho_dS, EOS, dom, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: drho_dT !< The partial derivative of density with potential + !! temperature [R C-1 ~> kg m-3 degC-1] + real, dimension(:), intent(inout) :: drho_dS !< The partial derivative of density with salinity + !! [R S-1 ~> kg m-3 ppt-1] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling stored in EOS [various] + ! Local variables + real, dimension(size(drho_dT)) :: pres ! Pressure converted to [Pa] + real, dimension(size(drho_dT)) :: Ta ! Temperature converted to [degC] + real, dimension(size(drho_dT)) :: Sa ! Salinity converted to [ppt] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] + real :: dRdS_scale ! A factor to convert drho_dS to the desired units [R ppt m3 S-1 kg-1 ~> 1] + integer :: i, is, ie, npts + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(drho_dT) ; npts = 1 + ie - is + endif + + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + call calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, is, npts, EOS) + else + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + call calculate_density_derivs_array(Ta, Sa, pres, drho_dT, drho_dS, is, npts, EOS) + endif + + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + dRdT_scale = rho_scale * EOS%C_to_degC + dRdS_scale = rho_scale * EOS%S_to_ppt + if ((dRdT_scale /= 1.0) .or. (dRdS_scale /= 1.0)) then ; do i=is,ie + drho_dT(i) = dRdT_scale * drho_dT(i) + drho_dS(i) = dRdS_scale * drho_dS(i) + enddo ; endif + +end subroutine calculate_density_derivs_1d + + +!> Calls the appropriate subroutines to calculate density derivatives by promoting a scalar +!! to a one-element array +subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS, scale) + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [R C-1 ~> kg m-3 degC-1] or other + !! units determined by the optional scale argument + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [R S-1 ~> kg m-3 ppt-1] or other units + !! determined by the optional scale argument + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling stored in EOS [various] + ! Local variables + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] + real :: dRdS_scale ! A factor to convert drho_dS to the desired units [R ppt m3 S-1 kg-1 ~> 1] + real :: pres(1) ! Pressure converted to [Pa] + real :: Ta(1) ! Temperature converted to [degC] + real :: Sa(1) ! Salinity converted to [ppt] + real :: dR_dT(1) ! A copy of drho_dT in mks units [kg m-3 degC-1] + real :: dR_dS(1) ! A copy of drho_dS in mks units [kg m-3 ppt-1] + + pres(1) = EOS%RL2_T2_to_Pa*pressure + Ta(1) = EOS%C_to_degC * T + Sa(1) = EOS%S_to_ppt * S + + call EOS%type%calculate_density_derivs_scalar(Ta(1), Sa(1), pres(1), drho_dT, drho_dS) + + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + dRdT_scale = rho_scale * EOS%C_to_degC + dRdS_scale = rho_scale * EOS%S_to_ppt + if ((dRdT_scale /= 1.0) .or. (dRdS_scale /= 1.0)) then + drho_dT = dRdT_scale * drho_dT + drho_dS = dRdS_scale * drho_dS + endif + +end subroutine calculate_density_derivs_scalar + +!> Calls the appropriate subroutine to calculate density second derivatives for 1-D array inputs. +subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, & + drho_dS_dP, drho_dT_dP, EOS, dom, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: drho_dS_dS !< Partial derivative of beta with respect to S + !! [R S-2 ~> kg m-3 ppt-2] + real, dimension(:), intent(inout) :: drho_dS_dT !< Partial derivative of beta with respect to T + !! [R S-1 C-1 ~> kg m-3 ppt-1 degC-1] + real, dimension(:), intent(inout) :: drho_dT_dT !< Partial derivative of alpha with respect to T + !! [R C-2 ~> kg m-3 degC-2] + real, dimension(:), intent(inout) :: drho_dS_dP !< Partial derivative of beta with respect to pressure + !! [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + real, dimension(:), intent(inout) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure + !! [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling stored in EOS [various] + ! Local variables + real, dimension(size(T)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(T)) :: Sa ! Salinity converted to [ppt] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + integer :: i, is, ie, npts + + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_density_second_derivs: EOS%form_of_EOS is not valid.") + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(T) ; npts = 1 + ie - is + endif + + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + call EOS%type%calculate_density_second_derivs_array(T, S, pressure, & + drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + else + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + call EOS%type%calculate_density_second_derivs_array(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + endif + + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then ; do i=is,ie + drho_dS_dS(i) = rho_scale * drho_dS_dS(i) + drho_dS_dT(i) = rho_scale * drho_dS_dT(i) + drho_dT_dT(i) = rho_scale * drho_dT_dT(i) + drho_dS_dP(i) = rho_scale * drho_dS_dP(i) + drho_dT_dP(i) = rho_scale * drho_dT_dP(i) + enddo ; endif + + if (EOS%RL2_T2_to_Pa /= 1.0) then ; do i=is,ie + drho_dS_dP(i) = EOS%RL2_T2_to_Pa * drho_dS_dP(i) + drho_dT_dP(i) = EOS%RL2_T2_to_Pa * drho_dT_dP(i) + enddo ; endif + + if (EOS%C_to_degC /= 1.0) then ; do i=is,ie + drho_dS_dT(i) = EOS%C_to_degC * drho_dS_dT(i) + drho_dT_dT(i) = EOS%C_to_degC**2 * drho_dT_dT(i) + drho_dT_dP(i) = EOS%C_to_degC * drho_dT_dP(i) + enddo ; endif + + if (EOS%S_to_ppt /= 1.0) then ; do i=is,ie + drho_dS_dS(i) = EOS%S_to_ppt**2 * drho_dS_dS(i) + drho_dS_dT(i) = EOS%S_to_ppt * drho_dS_dT(i) + drho_dS_dP(i) = EOS%S_to_ppt * drho_dS_dP(i) + enddo ; endif + +end subroutine calculate_density_second_derivs_1d + +!> Calls the appropriate subroutine to calculate density second derivatives for scalar inputs. +subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, & + drho_dS_dP, drho_dT_dP, EOS, scale) + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S + !! [R S-2 ~> kg m-3 ppt-2] + real, intent(out) :: drho_dS_dT !< Partial derivative of beta with respect to T + !! [R S-1 C-1 ~> kg m-3 ppt-1 degC-1] + real, intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T + !! [R C-2 ~> kg m-3 degC-2] + real, intent(out) :: drho_dS_dP !< Partial derivative of beta with respect to pressure + !! [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + real, intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure + !! [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling stored in EOS [various] + ! Local variables + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: pres ! Pressure converted to [Pa] + real :: Ta ! Temperature converted to [degC] + real :: Sa ! Salinity converted to [ppt] + + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_density_second_derivs: EOS%form_of_EOS is not valid.") + + pres = EOS%RL2_T2_to_Pa*pressure + Ta = EOS%C_to_degC * T + Sa = EOS%S_to_ppt * S + + call EOS%type%calculate_density_second_derivs_scalar(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) + + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then + drho_dS_dS = rho_scale * drho_dS_dS + drho_dS_dT = rho_scale * drho_dS_dT + drho_dT_dT = rho_scale * drho_dT_dT + drho_dS_dP = rho_scale * drho_dS_dP + drho_dT_dP = rho_scale * drho_dT_dP + endif + + if (EOS%RL2_T2_to_Pa /= 1.0) then + drho_dS_dP = EOS%RL2_T2_to_Pa * drho_dS_dP + drho_dT_dP = EOS%RL2_T2_to_Pa * drho_dT_dP + endif + + if (EOS%C_to_degC /= 1.0) then + drho_dS_dT = EOS%C_to_degC * drho_dS_dT + drho_dT_dT = EOS%C_to_degC**2 * drho_dT_dT + drho_dT_dP = EOS%C_to_degC * drho_dT_dP + endif + + if (EOS%S_to_ppt /= 1.0) then + drho_dS_dS = EOS%S_to_ppt**2 * drho_dS_dS + drho_dS_dT = EOS%S_to_ppt * drho_dS_dT + drho_dS_dP = EOS%S_to_ppt * drho_dS_dP + endif + +end subroutine calculate_density_second_derivs_scalar + +!> Calls the appropriate subroutine to calculate specific volume derivatives for an array. +subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential + !! temperature [m3 kg-1 degC-1] + real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity + !! [m3 kg-1 ppt-1] + integer, intent(in) :: start !< Starting index within the array + integer, intent(in) :: npts !< The number of values to calculate + type(EOS_type), intent(in) :: EOS !< Equation of state structure + + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_spec_vol_derivs_array: EOS%form_of_EOS is not valid.") + + call EOS%type%calculate_specvol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts) + +end subroutine calculate_spec_vol_derivs_array + +!> Calls the appropriate subroutine to calculate specific volume derivatives for 1-d array inputs, +!! potentially limiting the domain of indices that are worked on. +subroutine calc_spec_vol_derivs_1d(T, S, pressure, dSV_dT, dSV_dS, EOS, dom, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential + !! temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity + !! [R-1 S-1 ~> m3 kg-1 ppt-1] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific + !! volume in combination with scaling stored in EOS [various] + + ! Local variables + real, dimension(size(T)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(T)) :: Sa ! Salinity converted to [ppt] + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] + real :: dSVdT_scale ! A factor to convert dSV_dT to the desired units [kg degC R-1 C-1 m-3 ~> 1] + real :: dSVdS_scale ! A factor to convert dSV_dS to the desired units [kg ppt R-1 S-1 m-3 ~> 1] + integer :: i, is, ie, npts + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(dSV_dT) ; npts = 1 + ie - is + endif + + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + call calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, is, npts, EOS) + else + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + call calculate_spec_vol_derivs_array(Ta, Sa, pres, dSV_dT, dSV_dS, is, npts, EOS) + endif + + spv_scale = EOS%R_to_kg_m3 + if (present(scale)) spv_scale = spv_scale * scale + dSVdT_scale = spv_scale * EOS%C_to_degC + dSVdS_scale = spv_scale * EOS%S_to_ppt + if ((dSVdT_scale /= 1.0) .or. (dSVdS_scale /= 1.0)) then ; do i=is,ie + dSV_dT(i) = dSVdT_scale * dSV_dT(i) + dSV_dS(i) = dSVdS_scale * dSV_dS(i) + enddo ; endif + +end subroutine calc_spec_vol_derivs_1d + + +!> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array +!! inputs. The inputs and outputs use dimensionally rescaled units. +subroutine calculate_compress_1d(T, S, pressure, rho, drho_dp, EOS, dom) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: rho !< In situ density [R ~> kg m-3] + real, dimension(:), intent(inout) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [T2 L-2 ~> s2 m-2] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + + ! Local variables + real, dimension(size(T)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(T)) :: Sa ! Salinity converted to [ppt] + integer :: i, is, ie, npts + + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_compress_1d: EOS%form_of_EOS is not valid.") + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(rho) ; npts = 1 + ie - is + endif + + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + + call EOS%type%calculate_compress_array(Ta, Sa, pres, rho, drho_dp, is, npts) + + if (EOS%kg_m3_to_R /= 1.0) then ; do i=is,ie + rho(i) = EOS%kg_m3_to_R * rho(i) + enddo ; endif + if (EOS%L_T_to_m_s /= 1.0) then ; do i=is,ie + drho_dp(i) = EOS%L_T_to_m_s**2 * drho_dp(i) + enddo ; endif + +end subroutine calculate_compress_1d + +!> Calculate density and compressibility for a scalar. This just promotes the scalar to an array +!! with a singleton dimension and calls calculate_compress_1d. The inputs and outputs use +!! dimensionally rescaled units. +subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, intent(out) :: rho !< In situ density [R ~> kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure (also the + !! inverse of the square of sound speed) [T2 L-2 ~> s2 m-2] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + + ! Local variables + ! These arrays use the same units as their counterparts in calculate_compress_1d. + real, dimension(1) :: pa ! Pressure in a size-1 1d array [R L2 T-2 ~> Pa] + real, dimension(1) :: Ta ! Temperature in a size-1 1d array [C ~> degC] + real, dimension(1) :: Sa ! Salinity in a size-1 1d array [S ~> ppt] + real, dimension(1) :: rhoa ! In situ density in a size-1 1d array [R ~> kg m-3] + real, dimension(1) :: drho_dpa ! The partial derivative of density with pressure (also the + ! inverse of the square of sound speed) in a 1d array [T2 L-2 ~> s2 m-2] + + Ta(1) = T ; Sa(1) = S ; pa(1) = pressure + + call calculate_compress_1d(Ta, Sa, pa, rhoa, drho_dpa, EOS) + rho = rhoa(1) ; drho_dp = drho_dpa(1) + +end subroutine calculate_compress_scalar + +!> Calls the appropriate subroutine to calculate the layer averaged specific volume either using +!! Boole's rule quadrature or analytical and nearly-analytical averages in pressure. +subroutine average_specific_vol(T, S, p_t, dp, SpV_avg, EOS, dom, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [R-1 ~> m3 kg-1] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale + !! output specific volume in combination with + !! scaling stored in EOS [various] + + ! Local variables + real, dimension(size(T)) :: pres ! Layer-top pressure converted to [Pa] + real, dimension(size(T)) :: dpres ! Pressure change converted to [Pa] + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(T)) :: Sa ! Salinity converted to [ppt] + real :: T5(5) ! Temperatures at five quadrature points [C ~> degC] + real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] + real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + integer :: i, n, is, ie, npts + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(T) ; npts = 1 + ie - is + endif + + if (EOS%EOS_quadrature) then + do i=is,ie + do n=1,5 + T5(n) = T(i) ; S5(n) = S(i) + p5(n) = p_t(i) + 0.25*real(5-n)*dp(i) + enddo + call calculate_spec_vol(T5, S5, p5, a5, EOS) + + ! Use Boole's rule to estimate the average specific volume. + SpV_avg(i) = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) + enddo + elseif ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call avg_spec_vol_linear(T, S, p_t, dp, SpV_avg, is, npts, EOS%Rho_T0_S0, & + EOS%dRho_dT, EOS%dRho_dS) + case (EOS_WRIGHT) + call avg_spec_vol_buggy_wright(T, S, p_t, dp, SpV_avg, is, npts) + case (EOS_WRIGHT_FULL) + call avg_spec_vol_wright_full(T, S, p_t, dp, SpV_avg, is, npts) + case (EOS_WRIGHT_REDUCED) + call avg_spec_vol_wright_red(T, S, p_t, dp, SpV_avg, is, npts) + case default + call MOM_error(FATAL, "No analytic average specific volume option is available with this EOS!") + end select + else + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * p_t(i) + dpres(i) = EOS%RL2_T2_to_Pa * dp(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call avg_spec_vol_linear(Ta, Sa, pres, dpres, SpV_avg, is, npts, EOS%Rho_T0_S0, & + EOS%dRho_dT, EOS%dRho_dS) + case (EOS_WRIGHT) + call avg_spec_vol_buggy_wright(Ta, Sa, pres, dpres, SpV_avg, is, npts) + case (EOS_WRIGHT_FULL) + call avg_spec_vol_wright_full(Ta, Sa, pres, dpres, SpV_avg, is, npts) + case (EOS_WRIGHT_REDUCED) + call avg_spec_vol_wright_red(Ta, Sa, pres, dpres, SpV_avg, is, npts) + case default + call MOM_error(FATAL, "No analytic average specific volume option is available with this EOS!") + end select + endif + + spv_scale = EOS%R_to_kg_m3 + if (EOS%EOS_quadrature) spv_scale = 1.0 + if (present(scale)) spv_scale = spv_scale * scale + if (spv_scale /= 1.0) then ; do i=is,ie + SpV_avg(i) = spv_scale * SpV_avg(i) + enddo ; endif + +end subroutine average_specific_vol + +!> Return the range of temperatures, salinities and pressures for which the equation of state that +!! is being used has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range(EOS, T_min, T_max, S_min, S_max, p_min, p_max) + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(out) :: T_min !< The minimum temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum salinity over which this EoS is fitted [ppt] + real, optional, intent(out) :: S_max !< The maximum salinity over which this EoS is fitted [ppt] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_compress: EOS%form_of_EOS is not valid.") + + call EOS%type%EoS_fit_range(T_min, T_max, S_min, S_max, p_min, p_max) + +end subroutine EoS_fit_range + + +!> This subroutine returns a two point integer array indicating the domain of i-indices +!! to work on in EOS calls based on information from a hor_index type +function EOS_domain(HI, halo) result(EOSdom) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. + integer, dimension(2) :: EOSdom !< The index domain that the EOS will work on, taking into account + !! that the arrays inside the EOS routines will start at 1. + + ! Local variables + integer :: halo_sz + + halo_sz = 0 ; if (present(halo)) halo_sz = halo + + EOSdom(1) = HI%isc - (HI%isd-1) - halo_sz + EOSdom(2) = HI%iec - (HI%isd-1) + halo_sz + +end function EOS_domain + +!> Calls the appropriate subroutine to calculate analytical and nearly-analytical +!! integrals in pressure across layers of geopotential anomalies, which are +!! required for calculating the finite-volume form pressure accelerations in a +!! non-Boussinesq model. There are essentially no free assumptions, apart from the +!! use of Boole's rule to do the horizontal integrals, and from a truncation in the +!! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] + !! The calculation is mathematically identical with different values of + !! alpha_ref, but this reduces the effects of roundoff. + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the + !! geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of the layer divided by + !! the x grid spacing [L2 T-2 ~> m2 s-2] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of the layer divided by + !! the y grid spacing [L2 T-2 ~> m2 s-2] + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, optional, intent(in) :: dP_tiny !< A miniscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + + ! Local variables + real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] + real :: dRdS_scale ! A factor to convert drho_dS to the desired units [R ppt m3 S-1 kg-1 ~> 1] + + + ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical + ! integration be used instead of analytic. This is a safety check. + if (EOS%EOS_quadrature) call MOM_error(FATAL, "EOS_quadrature is set!") + + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + dRdT_scale = EOS%kg_m3_to_R * EOS%C_to_degC + dRdS_scale = EOS%kg_m3_to_R * EOS%S_to_ppt + call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & + dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, dza, & + intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + case (EOS_WRIGHT) + call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & + inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) + case (EOS_WRIGHT_FULL) + call int_spec_vol_dp_wright_full(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & + inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) + case (EOS_WRIGHT_REDUCED) + call int_spec_vol_dp_wright_red(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & + inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) + case default + call MOM_error(FATAL, "No analytic integration option is available with this EOS!") + end select + +end subroutine analytic_int_specific_vol_dp + +!> This subroutine calculates analytical and nearly-analytical integrals of +!! pressure anomalies across layers, which are required for calculating the +!! finite-volume form pressure accelerations in a Boussinesq model. +subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p) + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is + !! subtracted out to reduce the magnitude of each of the + !! integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly + !! across the layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the + !! layer of the pressure anomaly relative to the + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + + ! Local variables + real :: rho_scale ! A multiplicative factor by which to scale density from kg m-3 to the + ! desired units [R m3 kg-1 ~> 1] + real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] + real :: dRdS_scale ! A factor to convert drho_dS to the desired units [R ppt m3 S-1 kg-1 ~> 1] + real :: pres_scale ! A multiplicative factor to convert pressure into Pa [Pa T2 R-1 L-2 ~> 1] + + ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical + ! integration be used instead of analytic. This is a safety check. + if (EOS%EOS_quadrature) call MOM_error(FATAL, "EOS_quadrature is set!") + + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + rho_scale = EOS%kg_m3_to_R + dRdT_scale = EOS%kg_m3_to_R * EOS%C_to_degC + dRdS_scale = EOS%kg_m3_to_R * EOS%S_to_ppt + if ((rho_scale /= 1.0) .or. (dRdT_scale /= 1.0) .or. (dRdS_scale /= 1.0)) then + call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + rho_scale*EOS%Rho_T0_S0, dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + else + call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + endif + case (EOS_WRIGHT) + rho_scale = EOS%kg_m3_to_R + pres_scale = EOS%RL2_T2_to_Pa + if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then + call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dz_neglect, useMassWghtInterp, rho_scale, pres_scale, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) + else + call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + endif + case (EOS_WRIGHT_FULL) + rho_scale = EOS%kg_m3_to_R + pres_scale = EOS%RL2_T2_to_Pa + if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then + call int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dz_neglect, useMassWghtInterp, rho_scale, pres_scale, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) + else + call int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + endif + case (EOS_WRIGHT_REDUCED) + rho_scale = EOS%kg_m3_to_R + pres_scale = EOS%RL2_T2_to_Pa + if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then + call int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dz_neglect, useMassWghtInterp, rho_scale, pres_scale, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) + else + call int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + endif + case default + call MOM_error(FATAL, "No analytic integration option is available with this EOS!") + end select + +end subroutine analytic_int_density_dz + +!> Returns true if the equation of state is compressible (i.e. has pressure dependence) +logical function query_compressible(EOS) + type(EOS_type), intent(in) :: EOS !< Equation of state structure + + query_compressible = EOS%compressible +end function query_compressible + +!> Returns the string identifying the equation of state with enumeration "id" +function get_EOS_name(id) result (eos_name) + integer, optional, intent(in) :: id !< Enumerated ID + character(:), allocatable :: eos_name !< The name of the EOS + + select case (id) + case (EOS_LINEAR) + eos_name = EOS_LINEAR_STRING + case (EOS_UNESCO) + eos_name = EOS_UNESCO_STRING + case (EOS_WRIGHT) + eos_name = EOS_WRIGHT_STRING + case (EOS_WRIGHT_REDUCED) + eos_name = EOS_WRIGHT_RED_STRING + case (EOS_WRIGHT_FULL) + eos_name = EOS_WRIGHT_FULL_STRING + case (EOS_TEOS10) + eos_name = EOS_TEOS10_STRING + case (EOS_ROQUET_RHO) + eos_name = EOS_ROQUET_RHO_STRING + case (EOS_ROQUET_SPV) + eos_name = EOS_ROQUET_SPV_STRING + case (EOS_JACKETT06) + eos_name = EOS_JACKETT06_STRING + case default + call MOM_error(FATAL, "get_EOS_name: something went wrong internally - enumeration is not valid.") + end select + +end function get_EOS_name + +!> Initializes EOS_type by allocating and reading parameters. The scaling factors in +!! US are stored in EOS for later use. +subroutine EOS_init(param_file, EOS, US) + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(EOS_type), intent(inout) :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + optional :: US + ! Local variables +# include "version_variable.h" + character(len=40) :: mdl = "MOM_EOS" ! This module's name. + character(len=12) :: TFREEZE_DEFAULT ! The default freezing point expression + character(len=40) :: tmpstr + logical :: EOS_quad_default + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "EQN_OF_STATE", tmpstr, & + "EQN_OF_STATE determines which ocean equation of state should be used. "//& + 'Currently, the valid choices are "LINEAR", "UNESCO", "JACKETT_MCD", '//& + '"WRIGHT", "WRIGHT_REDUCED", "WRIGHT_FULL", "NEMO", "ROQUET_RHO", "ROQUET_SPV" '//& + 'and "TEOS10". This is only used if USE_EOS is true.', default=EOS_DEFAULT) + select case (uppercase(tmpstr)) + case (EOS_LINEAR_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR) + case (EOS_UNESCO_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_UNESCO) + case (EOS_JACKETT_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_UNESCO) + case (EOS_WRIGHT_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_WRIGHT) + case (EOS_WRIGHT_RED_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_WRIGHT_REDUCED) + case (EOS_WRIGHT_FULL_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_WRIGHT_FULL) + case (EOS_TEOS10_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_TEOS10) + case (EOS_NEMO_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_ROQUET_RHO) + case (EOS_ROQUET_RHO_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_ROQUET_RHO) + case (EOS_ROQUET_SPV_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_ROQUET_SPV) + case (EOS_JACKETT06_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_JACKETT06) + case default + call MOM_error(FATAL, "interpret_eos_selection: EQN_OF_STATE "//& + trim(tmpstr) // " in input file is invalid.") + end select + call MOM_mesg('interpret_eos_selection: equation of state set to "' // & + trim(tmpstr)//'"', 5) + + if (EOS%form_of_EOS == EOS_LINEAR) then + EOS%Compressible = .false. + call get_param(param_file, mdl, "RHO_T0_S0", EOS%Rho_T0_S0, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& + "this is the density at T=0, S=0.", units="kg m-3", default=1000.0) + call get_param(param_file, mdl, "DRHO_DT", EOS%dRho_dT, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& + "this is the partial derivative of density with "//& + "temperature.", units="kg m-3 K-1", default=-0.2) + call get_param(param_file, mdl, "DRHO_DS", EOS%dRho_dS, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& + "this is the partial derivative of density with salinity.", & + units="kg m-3 ppt-1", default=0.8) + call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR, Rho_T0_S0=EOS%Rho_T0_S0, dRho_dT=EOS%dRho_dT, dRho_dS=EOS%dRho_dS) + endif + if (EOS%form_of_EOS == EOS_WRIGHT) then + call get_param(param_file, mdl, "USE_WRIGHT_2ND_DERIV_BUG", EOS%use_Wright_2nd_deriv_bug, & + "If true, use a bug in the calculation of the second derivatives of density "//& + "with temperature and with temperature and pressure that causes some terms "//& + "to be only 2/3 of what they should be.", default=.false.) + endif + + EOS_quad_default = .not.((EOS%form_of_EOS == EOS_LINEAR) .or. & + (EOS%form_of_EOS == EOS_WRIGHT) .or. & + (EOS%form_of_EOS == EOS_WRIGHT_REDUCED) .or. & + (EOS%form_of_EOS == EOS_WRIGHT_FULL)) + call get_param(param_file, mdl, "EOS_QUADRATURE", EOS%EOS_quadrature, & + "If true, always use the generic (quadrature) code "//& + "code for the integrals of density.", default=EOS_quad_default) + + TFREEZE_DEFAULT = TFREEZE_LINEAR_STRING + if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_ROQUET_RHO .or. & + EOS%form_of_EOS == EOS_ROQUET_SPV)) & + TFREEZE_DEFAULT = TFREEZE_TEOS10_STRING + call get_param(param_file, mdl, "TFREEZE_FORM", tmpstr, & + "TFREEZE_FORM determines which expression should be "//& + "used for the freezing point. Currently, the valid "//& + 'choices are "LINEAR", "MILLERO_78", "TEOS_POLY", "TEOS10"', & + default=TFREEZE_DEFAULT) + select case (uppercase(tmpstr)) + case (TFREEZE_LINEAR_STRING) + EOS%form_of_TFreeze = TFREEZE_LINEAR + case (TFREEZE_MILLERO_STRING) + EOS%form_of_TFreeze = TFREEZE_MILLERO + case (TFREEZE_TEOSPOLY_STRING) + EOS%form_of_TFreeze = TFREEZE_TEOSPOLY + case (TFREEZE_TEOS10_STRING) + EOS%form_of_TFreeze = TFREEZE_TEOS10 + case default + call MOM_error(FATAL, "interpret_eos_selection: TFREEZE_FORM "//& + trim(tmpstr) // "in input file is invalid.") + end select + + if (EOS%form_of_TFreeze == TFREEZE_LINEAR) then + call get_param(param_file, mdl, "TFREEZE_S0_P0",EOS%TFr_S0_P0, & + "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& + "this is the freezing potential temperature at "//& + "S=0, P=0.", units="degC", default=0.0) + call get_param(param_file, mdl, "DTFREEZE_DS",EOS%dTFr_dS, & + "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& + "this is the derivative of the freezing potential "//& + "temperature with salinity.", & + units="degC ppt-1", default=-0.054) + call get_param(param_file, mdl, "DTFREEZE_DP",EOS%dTFr_dP, & + "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& + "this is the derivative of the freezing potential "//& + "temperature with pressure.", & + units="degC Pa-1", default=0.0) + endif + + if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_ROQUET_RHO .or. & + EOS%form_of_EOS == EOS_ROQUET_SPV) .and. & + .not.((EOS%form_of_TFreeze == TFREEZE_TEOS10) .or. (EOS%form_of_TFreeze == TFREEZE_TEOSPOLY)) ) then + call MOM_error(FATAL, "interpret_eos_selection: EOS_TEOS10 or EOS_ROQUET_RHO or EOS_ROQUET_SPV "//& + "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 or TFREEZE_TEOSPOLY.") + endif + + ! Unit conversions + EOS%m_to_Z = 1. ; if (present(US)) EOS%m_to_Z = US%m_to_Z + EOS%kg_m3_to_R = 1. ; if (present(US)) EOS%kg_m3_to_R = US%kg_m3_to_R + EOS%R_to_kg_m3 = 1. ; if (present(US)) EOS%R_to_kg_m3 = US%R_to_kg_m3 + EOS%RL2_T2_to_Pa = 1. ; if (present(US)) EOS%RL2_T2_to_Pa = US%RL2_T2_to_Pa + EOS%L_T_to_m_s = 1. ; if (present(US)) EOS%L_T_to_m_s = US%L_T_to_m_s + EOS%degC_to_C = 1. ; if (present(US)) EOS%degC_to_C = US%degC_to_C + EOS%C_to_degC = 1. ; if (present(US)) EOS%C_to_degC = US%C_to_degC + EOS%ppt_to_S = 1. ; if (present(US)) EOS%ppt_to_S = US%ppt_to_S + EOS%S_to_ppt = 1. ; if (present(US)) EOS%S_to_ppt = US%S_to_ppt + +end subroutine EOS_init + +!> Manually initialized an EOS type (intended for unit testing of routines which need a specific EOS) +subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & + Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp, & + use_Wright_2nd_deriv_bug) + type(EOS_type), intent(inout) :: EOS !< Equation of state structure + integer, optional, intent(in) :: form_of_EOS !< A coded integer indicating the equation of state to use. + integer, optional, intent(in) :: form_of_TFreeze !< A coded integer indicating the expression for + !! the potential temperature of the freezing point. + logical, optional, intent(in) :: EOS_quadrature !< If true, always use the generic (quadrature) + !! code for the integrals of density. + logical, optional, intent(in) :: Compressible !< If true, in situ density is a function of pressure. + real , optional, intent(in) :: Rho_T0_S0 !< Density at T=0 degC and S=0 ppt [kg m-3] + real , optional, intent(in) :: drho_dT !< Partial derivative of density with temperature + !! in [kg m-3 degC-1] + real , optional, intent(in) :: dRho_dS !< Partial derivative of density with salinity + !! in [kg m-3 ppt-1] + real , optional, intent(in) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC] + real , optional, intent(in) :: dTFr_dS !< The derivative of freezing point with salinity + !! in [degC ppt-1] + real , optional, intent(in) :: dTFr_dp !< The derivative of freezing point with pressure + !! in [degC Pa-1] + logical, optional, intent(in) :: use_Wright_2nd_deriv_bug !< Allow the Wright 2nd deriv bug + + if (present(form_of_EOS)) then + EOS%form_of_EOS = form_of_EOS + if (allocated(EOS%type)) deallocate(EOS%type) ! Needed during testing which re-initializes + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + allocate(linear_EOS :: EOS%type) + case (EOS_UNESCO) + allocate(UNESCO_EOS :: EOS%type) + case (EOS_WRIGHT) + allocate(buggy_Wright_EOS :: EOS%type) + case (EOS_WRIGHT_FULL) + allocate(Wright_full_EOS :: EOS%type) + case (EOS_WRIGHT_REDUCED) + allocate(Wright_red_EOS :: EOS%type) + case (EOS_JACKETT06) + allocate(Jackett06_EOS :: EOS%type) + case (EOS_TEOS10) + allocate(TEOS10_EOS :: EOS%type) + case (EOS_ROQUET_RHO) + allocate(Roquet_rho_EOS :: EOS%type) + case (EOS_ROQUET_SPV) + allocate(Roquet_SpV_EOS :: EOS%type) + end select + select type (t => EOS%type) + type is (linear_EOS) + call t%set_params_linear(Rho_T0_S0, dRho_dT, dRho_dS) + end select + endif + if (present(form_of_TFreeze)) EOS%form_of_TFreeze = form_of_TFreeze + if (present(EOS_quadrature )) EOS%EOS_quadrature = EOS_quadrature + if (present(Compressible )) EOS%Compressible = Compressible + if (present(Rho_T0_S0 )) EOS%Rho_T0_S0 = Rho_T0_S0 + if (present(drho_dT )) EOS%drho_dT = drho_dT + if (present(dRho_dS )) EOS%dRho_dS = dRho_dS + if (present(TFr_S0_P0 )) EOS%TFr_S0_P0 = TFr_S0_P0 + if (present(dTFr_dS )) EOS%dTFr_dS = dTFr_dS + if (present(dTFr_dp )) EOS%dTFr_dp = dTFr_dp + if (present(use_Wright_2nd_deriv_bug)) EOS%use_Wright_2nd_deriv_bug = use_Wright_2nd_deriv_bug + +end subroutine EOS_manual_init + +!> Set equation of state structure (EOS) to linear with given coefficients +!! +!! \note This routine is primarily for testing and allows a local copy of the +!! EOS_type (EOS argument) to be set to use the linear equation of state +!! independent from the rest of the model. +subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) + real, intent(in) :: Rho_T0_S0 !< Density at T=0 degC and S=0 ppt [kg m-3] + real, intent(in) :: dRho_dT !< Partial derivative of density with temperature [kg m-3 degC-1] + real, intent(in) :: dRho_dS !< Partial derivative of density with salinity [kg m-3 ppt-1] + logical, optional, intent(in) :: use_quadrature !< If true, always use the generic (quadrature) + !! code for the integrals of density. + type(EOS_type), intent(inout) :: EOS !< Equation of state structure + + call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR, Rho_T0_S0=Rho_T0_S0, dRho_dT=dRho_dT, dRho_dS=dRho_dS) + EOS%Compressible = .false. + EOS%EOS_quadrature = .false. + if (present(use_quadrature)) EOS%EOS_quadrature = use_quadrature + +end subroutine EOS_use_linear + + +!> Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 +subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) + integer, intent(in) :: kd !< The number of layers to work on + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & + intent(inout) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & + intent(inout) :: S !< Salinity [S ~> ppt] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & + intent(in) :: mask_z !< 3d mask regulating which points to convert [nondim] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + + real, parameter :: Sref_Sprac = (35.16504/35.0) ! The TEOS 10 conversion factor to go from + ! practical salinity to reference salinity [PSU ppt-1] + integer :: i, j, k + + if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_ROQUET_RHO) .and. & + (EOS%form_of_EOS /= EOS_ROQUET_SPV)) return + + do k=1,kd ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + if (mask_z(i,j,k) >= 1.0) then + S(i,j,k) = Sref_Sprac * S(i,j,k) + T(i,j,k) = EOS%degC_to_C*poTemp_to_consTemp(EOS%C_to_degC*T(i,j,k), EOS%S_to_ppt*S(i,j,k)) + endif + enddo ; enddo ; enddo +end subroutine convert_temp_salt_for_TEOS10 + + +!> Converts an array of conservative temperatures to potential temperatures. The input arguments +!! use the dimensionally rescaling as specified within the EOS type. The output potential +!! temperature uses this same scaling, but this can be replaced by the factor given by scale. +subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale) + real, dimension(:), intent(in) :: T !< Conservative temperature [C ~> degC] + real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] + real, dimension(:), intent(inout) :: poTemp !< The potential temperature with a reference pressure + !! of 0 Pa, [C ~> degC] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale the output + !! potential temperature in place of with scaling stored + !! in EOS. A value of 1.0 returns temperatures in [degC], + !! while the default is equivalent to EOS%degC_to_C. + + ! Local variables + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(S)) :: Sa ! Salinity converted to [ppt] + real :: T_scale ! A factor to convert potential temperature from degC to the desired units [C degC-1 ~> 1] + integer :: i, is, ie + + if (present(dom)) then + is = dom(1) ; ie = dom(2) + else + is = 1 ; ie = size(T) + endif + + if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + poTemp(is:ie) = consTemp_to_poTemp(T(is:ie), S(is:ie)) + else + do i=is,ie + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + poTemp(is:ie) = consTemp_to_poTemp(Ta(is:ie), Sa(is:ie)) + endif + + T_scale = EOS%degC_to_C + if (present(scale)) T_scale = scale + if (T_scale /= 1.0) then ; do i=is,ie + poTemp(i) = T_scale * poTemp(i) + enddo ; endif + +end subroutine cons_temp_to_pot_temp + + +!> Converts an array of potential temperatures to conservative temperatures. The input arguments +!! use the dimensionally rescaling as specified within the EOS type. The output potential +!! temperature uses this same scaling, but this can be replaced by the factor given by scale. +subroutine pot_temp_to_cons_temp(T, S, consTemp, EOS, dom, scale) + real, dimension(:), intent(in) :: T !< Potential temperature [C ~> degC] + real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] + real, dimension(:), intent(inout) :: consTemp !< The conservative temperature [C ~> degC] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale the output + !! potential temperature in place of with scaling stored + !! in EOS. A value of 1.0 returns temperatures in [degC], + !! while the default is equivalent to EOS%degC_to_C. + + ! Local variables + real, dimension(size(T)) :: Tp ! Potential temperature converted to [degC] + real, dimension(size(S)) :: Sa ! Absolute salinity converted to [ppt] + real :: T_scale ! A factor to convert potential temperature from degC to the desired units [C degC-1 ~> 1] + integer :: i, is, ie + + if (present(dom)) then + is = dom(1) ; ie = dom(2) + else + is = 1 ; ie = size(T) + endif + + + if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + consTemp(is:ie) = poTemp_to_consTemp(T(is:ie), S(is:ie)) + else + do i=is,ie + Tp(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + consTemp(is:ie) = poTemp_to_consTemp(Tp(is:ie), Sa(is:ie)) + endif + + T_scale = EOS%degC_to_C + if (present(scale)) T_scale = scale + if (T_scale /= 1.0) then ; do i=is,ie + consTemp(i) = T_scale * consTemp(i) + enddo ; endif + +end subroutine pot_temp_to_cons_temp + + +!> Converts an array of absolute salinity to practical salinity. The input arguments +!! use the dimensionally rescaling as specified within the EOS type. The output potential +!! temperature uses this same scaling, but this can be replaced by the factor given by scale. +subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale) + real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] + real, dimension(:), intent(inout) :: prSaln !< Practical salinity [S ~> PSU] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale the output + !! practical salinities in place of with scaling stored + !! in EOS. A value of 1.0 returns salinities in [PSU], + !! while the default is equivalent to EOS%ppt_to_S. + + ! Local variables + real, dimension(size(S)) :: Sa ! Salinity converted to [ppt] + real :: S_scale ! A factor to convert practical salinity from ppt to the desired units [S PSU-1 ~> 1] + real, parameter :: Sprac_Sref = (35.0/35.16504) ! The TEOS 10 conversion factor to go from + ! reference salinity to practical salinity [PSU ppt-1] + integer :: i, is, ie + + if (present(dom)) then + is = dom(1) ; ie = dom(2) + else + is = 1 ; ie = size(S) + endif + + if (present(scale)) then + S_scale = Sprac_Sref * scale + do i=is,ie + prSaln(i) = S_scale * S(i) + enddo + else + do i=is,ie + prSaln(i) = Sprac_Sref * S(i) + enddo + endif + +end subroutine abs_saln_to_prac_saln + + +!> Converts an array of absolute salinity to practical salinity. The input arguments +!! use the dimensionally rescaling as specified within the EOS type. The output potential +!! temperature uses this same scaling, but this can be replaced by the factor given by scale. +subroutine prac_saln_to_abs_saln(S, absSaln, EOS, dom, scale) + real, dimension(:), intent(in) :: S !< Practical salinity [S ~> PSU] + real, dimension(:), intent(inout) :: absSaln !< Absolute salinity [S ~> ppt] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale the output + !! absolute salnities in place of with scaling stored + !! in EOS. A value of 1.0 returns salinities in [ppt], + !! while the default is equivalent to EOS%ppt_to_S. + + ! Local variables + real, dimension(size(S)) :: Sp ! Salinity converted to [ppt] + real :: S_scale ! A factor to convert absolute salinity from ppt to the desired units [S ppt-1 ~> 1] + real, parameter :: Sref_Sprac = (35.16504/35.0) ! The TEOS 10 conversion factor to go from + ! practical salinity to reference salinity [PSU ppt-1] + integer :: i, is, ie + + if (present(dom)) then + is = dom(1) ; ie = dom(2) + else + is = 1 ; ie = size(S) + endif + + if (present(scale)) then + S_scale = Sref_Sprac * scale + do i=is,ie + absSaln(i) = S_scale * S(i) + enddo + else + do i=is,ie + absSaln(i) = Sref_Sprac * S(i) + enddo + endif + +end subroutine prac_saln_to_abs_saln + + +!> Return value of EOS_quadrature +logical function EOS_quadrature(EOS) + type(EOS_type), intent(in) :: EOS !< Equation of state structure + + EOS_quadrature = EOS%EOS_quadrature + +end function EOS_quadrature + +!> Runs unit tests for consistency on the equations of state. +!! This should only be called from a single/root thread. +!! It returns True if any test fails, otherwise it returns False. +logical function EOS_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + type(EOS_type) :: EOS_tmp + logical :: fail + + if (verbose) write(stdout,*) '==== MOM_EOS: EOS_unit_tests ====' + EOS_unit_tests = .false. ! Normally return false + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_TEOS10) + fail = test_TS_conversion_consistency(T_cons=9.989811727177308, S_abs=35.16504, & + T_pot=10.0, S_prac=35.0, EOS=EOS_tmp, verbose=verbose) + if (verbose .and. fail) call MOM_error(WARNING, "Some EOS variable conversions tests have failed.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_UNESCO) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "UNESCO", & + rho_check=1027.54345796120*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "UNESCO EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_FULL) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_FULL", & + rho_check=1027.55177447616*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) + if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_FULL EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_REDUCED) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_REDUCED", & + rho_check=1027.54303596346*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) + if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_REDUCED EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + ! This test is deliberately outside of the fit range for WRIGHT_REDUCED, and it results in the expected warnings. + ! call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_REDUCED) + ! fail = test_EOS_consistency(25.0, 15.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_REDUCED", & + ! rho_check=1012.625699301455*EOS_tmp%kg_m3_to_R) + ! if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_REDUCED EOS has failed some self-consistency tests.") + ! EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT, use_Wright_2nd_deriv_bug=.true.) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT", & + rho_check=1027.54303596346*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) + ! These last test is a known failure and since MPI is not necessarily initializaed when running these tests + ! we need to avoid flagging the fails. + !if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT EOS has failed some self-consistency tests.") + !EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_RHO) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "ROQUET_RHO", & + rho_check=1027.42385663668*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "ROQUET_RHO EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_SPV) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "ROQUET_SPV", & + rho_check=1027.42387475199*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "ROQUET_SPV EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_JACKETT06) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "JACKETT06", & + rho_check=1027.539690758425*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "JACKETT06 EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + ! The TEOS10 equation of state is not passing the self consistency tests for dho_dS_dp due + ! to a bug (a missing division by the square root of offset-salinity) on line 111 of + ! pkg/GSW-Fortan/toolbox/gsw_specvol_second_derivatives.f90. This bug has been highlighted in an + ! issue posted to the TEOS-10/GSW-Fortran page at github.com/TEOS-10/GSW-Fortran/issues/26, and + ! it will be corrected by github.com/mom-ocean/GSW-Fortran/pull/1 . + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_TEOS10) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "TEOS10", skip_2nd=.true., & + rho_check=1027.42355961492*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "TEOS10 EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_RHO) + fail = test_EOS_consistency(10.0, 30.0, 1.0e7, EOS_tmp, verbose, "ROQUET_RHO", & + rho_check=1027.45140117152*EOS_tmp%kg_m3_to_R) + ! The corresponding check value published by Roquet et al. (2015) is 1027.45140 [kg m-3]. + if (verbose .and. fail) call MOM_error(WARNING, "Roquet_rho EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_SPV) + fail = test_EOS_consistency(10.0, 30.0, 1.0e7, EOS_tmp, verbose, "ROQUET_SPV", & + spv_check=9.73282046614623e-04*EOS_tmp%R_to_kg_m3) + ! The corresponding check value here published by Roquet et al. (2015) is 9.732819628e-04 [m3 kg-1], + ! but the order of arithmetic there was not completely specified with parentheses. + if (verbose .and. fail) call MOM_error(WARNING, "ROQUET_SPV EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_LINEAR, Rho_T0_S0=1000.0, drho_dT=-0.2, dRho_dS=0.8) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "LINEAR", & + rho_check=1023.0*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) + if (verbose .and. fail) call MOM_error(WARNING, "LINEAR EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + ! Test the freezing point calculations + + call EOS_manual_init(EOS_tmp, form_of_TFreeze=TFREEZE_LINEAR, TFr_S0_P0=0.0, dTFr_dS=-0.054, & + dTFr_dP=-7.6e-8) + fail = test_TFr_consistency(35.0, 1.0e7, EOS_tmp, verbose, "LINEAR", TFr_check=-2.65*EOS_tmp%degC_to_C) + if (verbose .and. fail) call MOM_error(WARNING, "LINEAR TFr has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_TFreeze=TFREEZE_MILLERO) + fail = test_TFr_consistency(35.0, 1.0e7, EOS_tmp, verbose, "MILLERO_78", & + TFr_check=-2.69730134114106*EOS_tmp%degC_to_C) + if (verbose .and. fail) call MOM_error(WARNING, "MILLERO_78 TFr has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_TFreeze=TFREEZE_TEOS10) + fail = test_TFr_consistency(35.0, 1.0e7, EOS_tmp, verbose, "TEOS10", & + TFr_check=-2.69099996992861*EOS_tmp%degC_to_C) + if (verbose .and. fail) call MOM_error(WARNING, "TEOS10 TFr has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_TFreeze=TFREEZE_TEOSPOLY) + fail = test_TFr_consistency(35.0, 1.0e7, EOS_tmp, verbose, "TEOS_POLY", & + TFr_check=-2.691165259327735*EOS_tmp%degC_to_C) + if (verbose .and. fail) call MOM_error(WARNING, "TEOS_POLY TFr has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + if (EOS_unit_tests) then + call MOM_error(WARNING, "EOS_unit_tests: One or more EOS tests have failed!") + else + if (verbose) call MOM_mesg("EOS_unit_tests: All EOS consistency tests have passed.") + endif + +end function EOS_unit_tests + +logical function test_TS_conversion_consistency(T_cons, S_abs, T_pot, S_prac, EOS, verbose) & + result(inconsistent) + real, intent(in) :: T_cons !< Conservative temperature [degC] + real, intent(in) :: S_abs !< Absolute salinity [g kg-1] + real, intent(in) :: T_pot !< Potential temperature [degC] + real, intent(in) :: S_prac !< Practical salinity [PSU] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + logical, intent(in) :: verbose !< If true, write results to stdout + + ! Local variables + real :: Sabs(1) ! Absolute or reference salinity [g kg-1] + real :: Sprac(1) ! Practical salinity [PSU] + real :: Stest(1) ! A converted salinity [ppt] + real :: Tcons(1) ! Conservative temperature [degC] + real :: Tpot(1) ! Potential temperature [degC] + real :: Ttest(1) ! A converted temperature [degC] + real :: Stol ! Roundoff error on a typical value of salinities [ppt] + real :: Ttol ! Roundoff error on a typical value of temperatures [degC] + logical :: test_OK ! True if a particular test is consistent. + logical :: OK ! True if all checks so far are consistent. + integer :: i, j, n + + OK = .true. + + ! Copy scalar input values into the corresponding arrays + Sabs(1) = S_abs ; Sprac(1) = S_prac ; Tcons(1) = T_cons ; Tpot(1) = T_pot + + ! Set tolerances for the conversions. + Ttol = 2.0 * 400.0*epsilon(Ttol) + Stol = 35.0 * 400.0*epsilon(Stol) + + ! Check that the converted salinities agree + call abs_saln_to_prac_saln(Sabs, Stest, EOS) + test_OK = (abs(Stest(1) - Sprac(1)) <= Stol) + if (verbose) call write_check_msg("MOM6 Sprac", Stest(1), Sprac(1), Stol, test_OK) + OK = OK .and. test_OK + + call prac_saln_to_abs_saln(Sprac, Stest, EOS) + test_OK = (abs(Stest(1) - Sabs(1)) <= Stol) + if (verbose) call write_check_msg("MOM6 Sabs", Stest(1), Sabs(1), Stol, test_OK) + OK = OK .and. test_OK + + call cons_temp_to_pot_temp(Tcons, Sabs, Ttest, EOS) + test_OK = (abs(Ttest(1) - Tpot(1)) <= Ttol) + if (verbose) call write_check_msg("MOM6 Tpot", Ttest(1), Tpot(1), Ttol, test_OK) + OK = OK .and. test_OK + + call pot_temp_to_cons_temp(Tpot, Sabs, Ttest, EOS) + test_OK = (abs(Ttest(1) - Tcons(1)) <= Ttol) + if (verbose) call write_check_msg("MOM6 Tcons", Ttest(1), Tcons(1), Ttol, test_OK) + OK = OK .and. test_OK + + inconsistent = .not.OK +end function test_TS_conversion_consistency + +logical function test_TFr_consistency(S_test, p_test, EOS, verbose, EOS_name, TFr_check) & + result(inconsistent) + real, intent(in) :: S_test !< Salinity or absolute salinity [S ~> ppt] + real, intent(in) :: p_test !< Pressure [R L2 T-2 ~> Pa] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), intent(in) :: EOS_name !< A name used in error messages to describe the EoS + real, optional, intent(in) :: TFr_check !< A check value for the Freezing point [C ~> degC] + + ! Local variables + real, dimension(-3:3,-3:3) :: S ! Salinities at the test value and perturbed points [S ~> ppt] + real, dimension(-3:3,-3:3) :: P ! Pressures at the test value and perturbed points [R L2 T-2 ~> Pa] + real, dimension(-3:3,-3:3,2) :: TFr ! Freezing point at the test value and perturbed points [C ~> degC] + character(len=200) :: mesg + real :: dS ! Magnitude of salinity perturbations [S ~> ppt] + real :: dp ! Magnitude of pressure perturbations [R L2 T-2 ~> Pa] + ! real :: tol ! The nondimensional tolerance from roundoff [nondim] + real :: TFr_tol ! Roundoff error on a typical value of TFreeze [C ~> degC] + logical :: test_OK ! True if a particular test is consistent. + logical :: OK ! True if all checks so far are consistent. + integer :: i, j, n + + OK = .true. + + dS = 0.5*EOS%ppt_to_S ! Salinity perturbations [S ~> ppt] + dp = 10.0e4 / EOS%RL2_T2_to_Pa ! Pressure perturbations [R L2 T-2 ~> Pa] + + ! TEOS 10 requires a tolerance that is ~20 times larger than other freezing point + ! expressions because it lacks parentheses. + TFr_tol = 2.0*EOS%degC_to_C * 400.0*epsilon(TFr_tol) + + do n=1,2 + ! Calculate density values with a wide enough stencil to estimate first and second derivatives + ! with up to 6th order accuracy. Doing this twice with different sizes of perturbations allows + ! the evaluation of whether the finite differences are converging to the calculated values at a + ! rate that is consistent with the order of accuracy of the finite difference forms, and hence + ! the consistency of the calculated values. + do j=-3,3 ; do i=-3,3 + S(i,j) = max(S_test + n*dS*i, 0.0) + p(i,j) = max(p_test + n*dp*j, 0.0) + enddo ; enddo + do j=-3,3 + call calculate_TFreeze(S(:,j), p(:,j), TFr(:,j,n), EOS) + enddo + enddo + + ! Check that the freezing point agrees with the provided check value + if (present(TFr_check)) then + test_OK = (abs(TFr_check - TFr(0,0,1)) <= TFr_tol) + OK = OK .and. test_OK + if (verbose) call write_check_msg(trim(EOS_name)//" TFr", TFr(0,0,1), TFr_check, Tfr_tol, test_OK) + endif + + inconsistent = .not.OK +end function test_TFr_consistency + +!> Write a message indicating how well a value matches its check value. +subroutine write_check_msg(var_name, val, val_chk, val_tol, test_OK) + character(len=*), intent(in) :: var_name !< The name of the variable being tested. + real, intent(in) :: val !< The value being checked [various] + real, intent(in) :: val_chk !< The value being checked [various] + real, intent(in) :: val_tol !< The value being checked [various] + logical, intent(in) :: test_OK !< True if the values are within their tolerance + + character(len=200) :: mesg + + write(mesg, '(ES24.16," vs. ",ES24.16,", diff=",ES12.4,", tol=",ES12.4)') & + val, val_chk, val-val_chk, val_tol + if (test_OK) then + write(stdout,*) trim(var_name)//" agrees with its check value :"//trim(mesg) + else + write(stderr,*) trim(var_name)//" disagrees with its check value :"//trim(mesg) + endif +end subroutine write_check_msg + +!> Test an equation of state for self-consistency and consistency with check values, returning false +!! if it is consistent by all tests, and true if it fails any test. +logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & + EOS_name, rho_check, spv_check, skip_2nd, avg_Sv_check) result(inconsistent) + real, intent(in) :: T_test !< Potential temperature or conservative temperature [C ~> degC] + real, intent(in) :: S_test !< Salinity or absolute salinity [S ~> ppt] + real, intent(in) :: p_test !< Pressure [R L2 T-2 ~> Pa] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), intent(in) :: EOS_name !< A name used in error messages to describe the EoS + real, optional, intent(in) :: rho_check !< A check value for the density [R ~> kg m-3] + real, optional, intent(in) :: spv_check !< A check value for the specific volume [R-1 ~> m3 kg-1] + logical, optional, intent(in) :: skip_2nd !< If present and true, do not check the 2nd derivatives. + logical, optional, intent(in) :: avg_Sv_check !< If present and true, compare analytical and numerical + !! quadrature estimates of the layer-averaged specific volume. + + ! Local variables + real, dimension(-3:3,-3:3,-3:3) :: T ! Temperatures at the test value and perturbed points [C ~> degC] + real, dimension(-3:3,-3:3,-3:3) :: S ! Salinities at the test value and perturbed points [S ~> ppt] + real, dimension(-3:3,-3:3,-3:3) :: P ! Pressures at the test value and perturbed points [R L2 T-2 ~> Pa] + real, dimension(-3:3,-3:3,-3:3,2) :: rho ! Densities relative to rho_ref at the test value and + ! perturbed points [R ~> kg m-3] + real, dimension(-3:3,-3:3,-3:3,2) :: spv ! Specific volumes relative to spv_ref at the test value and + ! perturbed points [R-1 ~> m3 kg-1] + real :: dT ! Magnitude of temperature perturbations [C ~> degC] + real :: dS ! Magnitude of salinity perturbations [S ~> ppt] + real :: dp ! Magnitude of pressure perturbations [R L2 T-2 ~> Pa] + real :: rho_ref ! A reference density that is extracted for greater accuracy [R ~> kg m-3] + real :: spv_ref ! A reference specific volume that is extracted for greater accuracy [R-1 ~> m3 kg-1] + real :: rho_nooff ! Density with no reference offset [R ~> kg m-3] + real :: spv_nooff ! Specific volume with no reference offset [R-1 ~> m3 kg-1] + real :: drho_dT ! The partial derivative of density with potential + ! temperature [R C-1 ~> kg m-3 degC-1] + real :: drho_dS ! The partial derivative of density with salinity + ! in [R S-1 ~> kg m-3 ppt-1] + real :: drho_dp ! The partial derivative of density with pressure (also the + ! inverse of the square of sound speed) [T2 L-2 ~> s2 m-2] + real :: dSV_dT(1) ! The partial derivative of specific volume with potential + ! temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real :: dSV_dS(1) ! The partial derivative of specific volume with salinity + ! [R-1 S-1 ~> m3 kg-1 ppt-1] + real :: SpV_avg_a(1) ! The pressure-averaged specific volume determined analytically [R-1 ~> m3 kg-1] + real :: SpV_avg_q(1) ! The pressure-averaged specific volume determined via quadrature [R-1 ~> m3 kg-1] + real :: drho_dS_dS ! Second derivative of density with respect to S [R S-2 ~> kg m-3 ppt-2] + real :: drho_dS_dT ! Second derivative of density with respect to T and S [R S-1 C-1 ~> kg m-3 ppt-1 degC-1] + real :: drho_dT_dT ! Second derivative of density with respect to T [R C-2 ~> kg m-3 degC-2] + real :: drho_dS_dP ! Second derivative of density with respect to salinity and pressure + ! [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + real :: drho_dT_dP ! Second derivative of density with respect to temperature and pressure + ! [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] + + real :: drho_dT_fd(2) ! Two 6th order finite difference estimates of the partial derivative of density + ! with potential temperature [R C-1 ~> kg m-3 degC-1] + real :: drho_dS_fd(2) ! Two 6th order finite difference estimates of the partial derivative of density + ! with salinity [R S-1 ~> kg m-3 ppt-1] + real :: drho_dp_fd(2) ! Two 6th order finite difference estimates of the partial derivative of density + ! with pressure (also the inverse of the square of sound speed) [T2 L-2 ~> s2 m-2] + real :: dSV_dT_fd(2) ! Two 6th order finite difference estimates of the partial derivative of + ! specific volume with potential temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real :: dSV_dS_fd(2) ! Two 6th order finite difference estimates of the partial derivative of + ! specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + real :: drho_dS_dS_fd(2) ! Two 6th order finite difference estimates of the second derivative of + ! density with respect to salinity [R S-2 ~> kg m-3 ppt-2] + real :: drho_dS_dT_fd(2) ! Two 6th order finite difference estimates of the second derivative of density + ! with respect to temperature and salinity [R S-1 C-1 ~> kg m-3 ppt-1 degC-1] + real :: drho_dT_dT_fd(2) ! Two 6th order finite difference estimates of the second derivative of + ! density with respect to temperature [R C-2 ~> kg m-3 degC-2] + real :: drho_dS_dP_fd(2) ! Two 6th order finite difference estimates of the second derivative of density + ! with respect to salinity and pressure [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + real :: drho_dT_dP_fd(2) ! Two 6th order finite difference estimates of the second derivative of density + ! with respect to temperature and pressure [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] + real :: rho_tmp ! A temporary copy of the situ density [R ~> kg m-3] + real :: tol ! The nondimensional tolerance from roundoff [nondim] + real :: r_tol ! Roundoff error on a typical value of density anomaly [R ~> kg m-3] + real :: sv_tol ! Roundoff error on a typical value of specific volume anomaly [R-1 ~> m3 kg-1] + real :: tol_here ! The tolerance for each check, in various units [various] + real :: T_min, T_max ! The minimum and maximum temperature over which this EoS is fitted [degC] + real :: S_min, S_max ! The minimum and maximum temperature over which this EoS is fitted [ppt] + real :: p_min, p_max ! The minimum and maximum temperature over which this EoS is fitted [Pa] + real :: count_fac ! A factor in the roundoff estimates based on the factors in the numerator and + ! denominator in the finite difference derivative expression [nondim] + real :: count_fac2 ! A factor in the roundoff estimates based on the factors in the numerator and + ! denominator in the finite difference second derivative expression [nondim] + character(len=200) :: mesg + type(EOS_type) :: EOS_tmp + logical :: test_OK ! True if a particular test is consistent. + logical :: OK ! True if all checks so far are consistent. + logical :: test_2nd ! If true, do tests on the 2nd derivative calculations + logical :: test_avg_Sv ! If true, compare numerical and analytical estimates of the vertically + ! averaged specific volume + integer :: order ! The order of accuracy of the centered finite difference estimates (2, 4 or 6). + integer :: i, j, k, n + + test_2nd = .true. ; if (present(skip_2nd)) test_2nd = .not.skip_2nd + test_avg_Sv = .false. ; if (present(avg_Sv_check)) test_avg_Sv = avg_Sv_check + + dT = 0.1*EOS%degC_to_C ! Temperature perturbations [C ~> degC] + dS = 0.5*EOS%ppt_to_S ! Salinity perturbations [S ~> ppt] + dp = 10.0e4 / EOS%RL2_T2_to_Pa ! Pressure perturbations [R L2 T-2 ~> Pa] + + r_tol = 50.0*EOS%kg_m3_to_R * 10.*epsilon(r_tol) + sv_tol = 5.0e-5*EOS%R_to_kg_m3 * 10.*epsilon(sv_tol) + rho_ref = 1000.0*EOS%kg_m3_to_R + spv_ref = 1.0 / rho_ref + + order = 4 ! This should be 2, 4 or 6. + + ! Check whether the consistency test is being applied outside of the value range of this EoS. + call EoS_fit_range(EOS, T_min, T_max, S_min, S_max, p_min, p_max) + if ((T_test < T_min) .or. (T_test > T_max)) then + write(mesg, '(ES12.4," [degC] which is outside of the fit range of ",ES12.4," to ",ES12.4)') T_test, T_min, T_max + call MOM_error(WARNING, trim(EOS_name)//" is being evaluated at a temperature of "//trim(mesg)) + endif + if ((S_test < S_min) .or. (S_test > S_max)) then + write(mesg, '(ES12.4," [ppt] which is outside of the fit range of ",ES12.4," to ",ES12.4)') S_test, S_min, S_max + call MOM_error(WARNING, trim(EOS_name)//" is being evaluated at a salinity of "//trim(mesg)) + endif + if ((p_test < p_min) .or. (p_test > p_max)) then + write(mesg, '(ES12.4," [Pa] which is outside of the fit range of ",ES12.4," to ",ES12.4)') p_test, p_min, p_max + call MOM_error(WARNING, trim(EOS_name)//" is being evaluated at a pressure of "//trim(mesg)) + endif + + do n=1,2 + ! Calculate density values with a wide enough stencil to estimate first and second derivatives + ! with up to 6th order accuracy. Doing this twice with different sizes of perturbations allows + ! the evaluation of whether the finite differences are converging to the calculated values at a + ! rate that is consistent with the order of accuracy of the finite difference forms, and hence + ! the consistency of the calculated values. + do k=-3,3 ; do j=-3,3 ; do i=-3,3 + T(i,j,k) = T_test + n*dT*i + S(i,j,k) = S_test + n*dS*j + p(i,j,k) = p_test + n*dp*k + enddo ; enddo ; enddo + do k=-3,3 ; do j=-3,3 + call calculate_density(T(:,j,k), S(:,j,k), p(:,j,k), rho(:,j,k,n), EOS, rho_ref=rho_ref) + call calculate_spec_vol(T(:,j,k), S(:,j,k), p(:,j,k), spv(:,j,k,n), EOS, spv_ref=spv_ref) + enddo ; enddo + + drho_dT_fd(n) = first_deriv(rho(:,0,0,n), n*dT, order) + drho_dS_fd(n) = first_deriv(rho(0,:,0,n), n*dS, order) + drho_dp_fd(n) = first_deriv(rho(0,0,:,n), n*dp, order) + dSV_dT_fd(n) = first_deriv(spv(:,0,0,n), n*dT, order) + dSV_dS_fd(n) = first_deriv(spv(0,:,0,n), n*dS, order) + if (test_2nd) then + drho_dT_dT_fd(n) = second_deriv(rho(:,0,0,n), n*dT, order) + drho_dS_dS_fd(n) = second_deriv(rho(0,:,0,n), n*dS, order) + drho_dS_dT_fd(n) = derivs_2d(rho(:,:,0,n), n**2*dT*dS, order) + drho_dT_dP_fd(n) = derivs_2d(rho(:,0,:,n), n**2*dT*dP, order) + drho_dS_dP_fd(n) = derivs_2d(rho(0,:,:,n), n**2*dS*dP, order) + endif + enddo + + call calculate_density_derivs(T(0,0,0), S(0,0,0), p(0,0,0), drho_dT, drho_dS, EOS) + ! The first indices here are "0:0" because there is no scalar form of calculate_specific_vol_derivs. + call calculate_specific_vol_derivs(T(0:0,0,0), S(0:0,0,0), p(0:0,0,0), dSV_dT, dSV_dS, EOS) + if (test_2nd) & + call calculate_density_second_derivs(T(0,0,0), S(0,0,0), p(0,0,0), & + drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, EOS) + call calculate_compress(T(0,0,0), S(0,0,0), p(0,0,0), rho_tmp, drho_dp, EOS) + + if (test_avg_Sv) then + EOS_tmp = EOS + call EOS_manual_init(EOS_tmp, EOS_quadrature=.false.) + call average_specific_vol(T(0:0,0,0), S(0:0,0,0), p(0:0,0,0), p(0:0,0,0), SpV_avg_a, EOS_tmp) + call EOS_manual_init(EOS_tmp, EOS_quadrature=.true.) + call average_specific_vol(T(0:0,0,0), S(0:0,0,0), p(0:0,0,0), p(0:0,0,0), SpV_avg_q, EOS_tmp) + endif + + OK = .true. + + tol = 1000.0*epsilon(tol) + + ! Check that the density agrees with the provided check value + if (present(rho_check)) then + test_OK = (abs(rho_check - (rho_ref + rho(0,0,0,1))) < tol*(rho_ref + rho(0,0,0,1))) + OK = OK .and. test_OK + if (verbose) & + call write_check_msg(trim(EOS_name)//" rho", rho_ref+rho(0,0,0,1), rho_check, tol*rho(0,0,0,1), test_OK) + endif + + ! Check that the specific volume agrees with the provided check value or the inverse of density + if (present(spv_check)) then + test_OK = (abs(spv_check - (spv_ref + spv(0,0,0,1))) < tol*abs(spv_ref + spv(0,0,0,1))) + if (verbose) & + call write_check_msg(trim(EOS_name)//" spv", spv_ref+spv(0,0,0,1), spv_check, tol*spv(0,0,0,1), test_OK) + OK = OK .and. test_OK + else + test_OK = (abs((rho_ref+rho(0,0,0,1)) * (spv_ref + spv(0,0,0,1)) - 1.0) < tol) + OK = OK .and. test_OK + if (verbose) then + write(mesg, '(ES16.8," and ",ES16.8,", ratio - 1 = ",ES16.8)') & + rho_ref+rho(0,0,0,1), 1.0/(spv_ref + spv(0,0,0,1)), & + (rho_ref+rho(0,0,0,1)) * (spv_ref + spv(0,0,0,1)) - 1.0 + if (test_OK) then + write(stdout,*) "The values of "//trim(EOS_name)//" rho and 1/spv agree. "//trim(mesg) + else + write(stderr,*) "The values of "//trim(EOS_name)//" rho and 1/spv disagree. "//trim(mesg) + endif + endif + endif + + ! Check that the densities are consistent when the reference value is extracted + call calculate_density(T(0,0,0), S(0,0,0), p(0,0,0), rho_nooff, EOS) + test_OK = (abs(rho_nooff - (rho_ref + rho(0,0,0,1))) < tol*rho_nooff) + OK = OK .and. test_OK + if (verbose .and. .not.test_OK) then + write(mesg, '(ES24.16," vs. ",ES24.16," with tolerance ",ES12.4)') & + rho_ref+rho(0,0,0,1), rho_nooff, tol*rho_nooff + write(stderr,*) "For "//trim(EOS_name)//& + " rho with and without a reference value disagree: "//trim(mesg) + endif + + ! Check that the specific volumes are consistent when the reference value is extracted + call calculate_spec_vol(T(0,0,0), S(0,0,0), p(0,0,0), spv_nooff, EOS) + test_OK = (abs(spv_nooff - (spv_ref + spv(0,0,0,1))) < tol*rho_nooff) + OK = OK .and. test_OK + if (verbose .and. .not.test_OK) then + write(mesg, '(ES24.16," vs. ",ES24.16," with tolerance ",ES12.4)') & + spv_ref + spv(0,0,0,1), spv_nooff, tol*spv_nooff + write(stderr,*) "For "//trim(EOS_name)//& + " spv with and without a reference value disagree: "//trim(mesg) + endif + + ! Account for the factors of terms in the numerator and denominator when estimating roundoff + if (order == 6) then + count_fac = 110.0/60.0 ; count_fac2 = 1088.0/180.0 + elseif (order == 4) then ! Use values appropriate for 4th order schemes. + count_fac = 18.0/12.0 ; count_fac2 = 64.0/12.0 + else ! Use values appropriate for 2nd order schemes. + count_fac = 2.0/2.0 ; count_fac2 = 4.0 + endif + + ! Check for the rate of convergence expected with a 4th or 6th order accurate discretization + ! with a 20% margin of error and a tolerance for contributions from roundoff. + tol_here = tol*abs(drho_dT) + count_fac*r_tol/dT + OK = OK .and. check_FD(drho_dT, drho_dT_fd, tol_here, verbose, trim(EOS_name)//" drho_dT", order) + tol_here = tol*abs(drho_dS) + count_fac*r_tol/dS + OK = OK .and. check_FD(drho_dS, drho_dS_fd, tol_here, verbose, trim(EOS_name)//" drho_dS", order) + tol_here = tol*abs(drho_dp) + count_fac*r_tol/dp + OK = OK .and. check_FD(drho_dp, drho_dp_fd, tol_here, verbose, trim(EOS_name)//" drho_dp", order) + tol_here = tol*abs(dSV_dT(1)) + count_fac*sv_tol/dT + OK = OK .and. check_FD(dSV_dT(1), dSV_dT_fd, tol_here, verbose, trim(EOS_name)//" dSV_dT", order) + tol_here = tol*abs(dSV_dS(1)) + count_fac*sv_tol/dS + OK = OK .and. check_FD(dSV_dS(1), dSV_dS_fd, tol_here, verbose, trim(EOS_name)//" dSV_dS", order) + if (test_2nd) then + tol_here = tol*abs(drho_dT_dT) + count_fac2*r_tol/dT**2 + OK = OK .and. check_FD(drho_dT_dT, drho_dT_dT_fd, tol_here, verbose, trim(EOS_name)//" drho_dT_dT", order) + ! The curvature in salinity is relatively weak, so looser tolerances are needed for some forms of EOS? + tol_here = 10.0*(tol*abs(drho_dS_dS) + count_fac2*r_tol/dS**2) + OK = OK .and. check_FD(drho_dS_dS, drho_dS_dS_fd, tol_here, verbose, trim(EOS_name)//" drho_dS_dS", order) + tol_here = tol*abs(drho_dS_dT) + count_fac**2*r_tol/(dS*dT) + OK = OK .and. check_FD(drho_dS_dT, drho_dS_dT_fd, tol_here, verbose, trim(EOS_name)//" drho_dS_dT", order) + tol_here = tol*abs(drho_dT_dP) + count_fac**2*r_tol/(dT*dp) + OK = OK .and. check_FD(drho_dT_dP, drho_dT_dP_fd, tol_here, verbose, trim(EOS_name)//" drho_dT_dP", order) + tol_here = tol*abs(drho_dS_dP) + count_fac**2*r_tol/(dS*dp) + OK = OK .and. check_FD(drho_dS_dP, drho_dS_dP_fd, tol_here, verbose, trim(EOS_name)//" drho_dS_dP", order) + endif + + if (test_avg_Sv) then + tol_here = 0.5*tol*(abs(SpV_avg_a(1)) + abs(SpV_avg_q(1))) + test_OK = (abs(SpV_avg_a(1) - SpV_avg_q(1)) < tol_here) + if (verbose) then + write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & + SpV_avg_a(1), SpV_avg_q(1), SpV_avg_a(1) - SpV_avg_q(1), & + 2.0*(SpV_avg_a(1) - SpV_avg_q(1)) / (abs(SpV_avg_a(1)) + abs(SpV_avg_q(1)) + tiny(SpV_avg_a(1))), & + tol_here + if (verbose .and. .not.test_OK) then + write(stderr,*) "The values of "//trim(EOS_name)//" SpV_avg disagree. "//trim(mesg) + elseif (verbose) then + write(stdout,*) "The values of "//trim(EOS_name)//" SpV_avg agree: "//trim(mesg) + endif + endif + OK = OK .and. test_OK + endif + + inconsistent = .not.OK + + contains + + !> Return a finite difference estimate of the first derivative of a field in arbitrary units [A B-1] + real function first_deriv(R, dx, order) + real, intent(in) :: R(-3:3) !< The field whose derivative is being taken, in arbitrary units [A] + real, intent(in) :: dx !< The spacing in parameter space, in different arbitrary units [B] + integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) + + if (order == 6) then ! Find a 6th order accurate first derivative on a regular grid. + first_deriv = (45.0*(R(1)-R(-1)) + (-9.0*(R(2)-R(-2)) + (R(3)-R(-3))) ) / (60.0 * dx) + elseif (order == 4) then ! Find a 4th order accurate first derivative on a regular grid. + first_deriv = (8.0*(R(1)-R(-1)) - (R(2)-R(-2)) ) / (12.0 * dx) + else ! Find a 2nd order accurate first derivative on a regular grid. + first_deriv = (R(1)-R(-1)) / (2.0 * dx) + endif + end function first_deriv + + !> Return a finite difference estimate of the second derivative of a field in arbitrary units [A B-2] + real function second_deriv(R, dx, order) + real, intent(in) :: R(-3:3) !< The field whose derivative is being taken, in arbitrary units [A] + real, intent(in) :: dx !< The spacing in parameter space, in different arbitrary units [B] + integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) + + if (order == 6) then ! Find a 6th order accurate second derivative on a regular grid. + second_deriv = ( -490.0*R(0) + (270.0*(R(1)+R(-1)) + (-27.0*(R(2)+R(-2)) + 2.0*(R(3)+R(-3))) )) / (180.0 * dx**2) + elseif (order == 4) then ! Find a 4th order accurate second derivative on a regular grid. + second_deriv = ( -30.0*R(0) + (16.0*(R(1)+R(-1)) - (R(2)+R(-2))) ) / (12.0 * dx**2) + else ! Find a 2nd order accurate second derivative on a regular grid. + second_deriv = ( -2.0*R(0) + (R(1)+R(-1)) ) / dx**2 + endif + end function second_deriv + + !> Return a finite difference estimate of the second derivative with respect to two different + !! parameters of a field in arbitrary units [A B-1 C-1] + real function derivs_2d(R, dxdy, order) + real, intent(in) :: R(-3:3,-3:3) !< The field whose derivative is being taken in arbitrary units [A] + real, intent(in) :: dxdy !< The spacing in two directions in parameter space in different arbitrary units [B C] + integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) + + real :: dRdx(-3:3) ! The first derivative in one direction times the grid spacing in that direction [A] + integer :: i + + do i=-3,3 + dRdx(i) = first_deriv(R(:,i), 1.0, order) + enddo + derivs_2d = first_deriv(dRdx, dxdy, order) + + end function derivs_2d + + !> Check for the rate of convergence expected with a finite difference discretization + !! with a 20% margin of error and a tolerance for contributions from roundoff. + logical function check_FD(val, val_fd, tol, verbose, field_name, order) + real, intent(in) :: val !< The derivative being checked, in arbitrary units [arbitrary] + real, intent(in) :: val_fd(2) !< Two finite difference estimates of val taken with a spacing + !! in parameter space and twice this spacing, in the same + !! arbitrary units as val [arbitrary] + real, intent(in) :: tol !< An estimated fractional tolerance due to roundoff [arbitrary] + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), intent(in) :: field_name !< A name used to describe the field in error messages + integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) + + character(len=200) :: mesg + + check_FD = ( abs(val_fd(1) - val) < (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) ) + + ! write(mesg, '(ES16.8," and ",ES16.8," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & + write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & + val, val_fd(1), val - val_fd(1), & + 2.0*(val - val_fd(1)) / (abs(val) + abs(val_fd(1)) + tiny(val)), & + (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) + ! This message is useful for debugging the two estimates: + ! write(mesg, '(ES16.8," and ",ES16.8," or ",ES16.8," differ by ",2ES16.8," (",2ES10.2"), tol=",ES16.8)') & + ! val, val_fd(1), val_fd(2), val - val_fd(1), val - val_fd(2), & + ! 2.0*(val - val_fd(1)) / (abs(val) + abs(val_fd(1)) + tiny(val)), & + ! 2.0*(val - val_fd(2)) / (abs(val) + abs(val_fd(2)) + tiny(val)), & + ! (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) + if (verbose .and. .not.check_FD) then + write(stderr,*) "The values of "//trim(field_name)//" disagree. "//trim(mesg) + elseif (verbose) then + write(stdout,*) "The values of "//trim(field_name)//" agree: "//trim(mesg) + endif + end function check_FD + +end function test_EOS_consistency + +end module MOM_EOS + +!> \namespace mom_eos +!! +!! The MOM_EOS module is a wrapper for various equations of state (i.e. Linear, Wright, +!! Wright_full, Wright_red, UNESCO, TEOS10, Roquet_SpV or Roquet_rho) and provides a uniform +!! interface to the rest of the model independent of which equation of state is being used. diff --git a/equation_of_state/MOM_EOS_Jackett06.F90 b/equation_of_state/MOM_EOS_Jackett06.F90 new file mode 100644 index 0000000000..1ef7456e96 --- /dev/null +++ b/equation_of_state/MOM_EOS_Jackett06.F90 @@ -0,0 +1,508 @@ +!> The equation of state using the Jackett et al 2006 expressions that are often used in Hycom +module MOM_EOS_Jackett06 + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS_base_type, only : EOS_base + +implicit none ; private + +public Jackett06_EOS + +!>@{ Parameters in the Jackett et al. equation of state, which is a fit to the Fiestel (2003) +! equation of state for the range: -2 < theta < 40 [degC], 0 < S < 42 [PSU], 0 < p < 1e8 [Pa]. +! The notation here is for terms in the numerator of the expression for density of +! RNabc for terms proportional to S**a * T**b * P**c, and terms in the denominator as RDabc. +! For terms proportional to S**1.5, 6 is used in this notation. + +! --- coefficients for 25-term rational function sigloc(). +real, parameter :: & + RN000 = 9.9984085444849347d+02, & ! Density numerator constant coefficient [kg m-3] + RN001 = 1.1798263740430364d-06, & ! Density numerator P coefficient [kg m-3 Pa-1] + RN002 = -2.5862187075154352d-16, & ! Density numerator P^2 coefficient [kg m-3 Pa-2] + RN010 = 7.3471625860981584d+00, & ! Density numerator T coefficient [kg m-3 degC-1] + RN020 = -5.3211231792841769d-02, & ! Density numerator T^2 coefficient [kg m-3 degC-2] + RN021 = 9.8920219266399117d-12, & ! Density numerator T^2 P coefficient [kg m-3 degC-2 Pa-1] + RN022 = -3.2921414007960662d-20, & ! Density numerator T^2 P^2 coefficient [kg m-3 degC-2 Pa-2] + RN030 = 3.6492439109814549d-04, & ! Density numerator T^3 coefficient [kg m-3 degC-3] + RN100 = 2.5880571023991390d+00, & ! Density numerator S coefficient [kg m-3 PSU-1] + RN101 = 4.6996642771754730d-10, & ! Density numerator S P coefficient [kg m-3 PSU-1 Pa-1] + RN110 = -6.7168282786692355d-03, & ! Density numerator S T coefficient [kg m-3 degC-1 PSU-1] + RN200 = 1.9203202055760151d-03, & ! Density numerator S^2 coefficient [kg m-3] + + RD001 = 6.7103246285651894d-10, & ! Density denominator P coefficient [Pa-1] + RD010 = 7.2815210113327091d-03, & ! Density denominator T coefficient [degC-1] + RD013 = -9.1534417604289062d-30, & ! Density denominator T P^3 coefficient [degC-1 Pa-3] + RD020 = -4.4787265461983921d-05, & ! Density denominator T^2 coefficient [degC-2] + RD030 = 3.3851002965802430d-07, & ! Density denominator T^3 coefficient [degC-3] + RD032 = -2.4461698007024582d-25, & ! Density denominator T^3 P^2 coefficient [degC-3 Pa-2] + RD040 = 1.3651202389758572d-10, & ! Density denominator T^4 coefficient [degC-4] + RD100 = 1.7632126669040377d-03, & ! Density denominator S coefficient [PSU-1] + RD110 = -8.8066583251206474d-06, & ! Density denominator S T coefficient [degC-1 PSU-1] + RD130 = -1.8832689434804897d-10, & ! Density denominator S T^3 coefficient [degC-3 PSU-1] + RD600 = 5.7463776745432097d-06, & ! Density denominator S^1.5 coefficient [PSU-1.5] + RD620 = 1.4716275472242334d-09 ! Density denominator S^1.5 T^2 coefficient [degC-2 PSU-1.5] +!>@} + +!> The EOS_base implementation of the Jackett et al, 2006, equation of state +type, extends (EOS_base) :: Jackett06_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Jackett06 + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Jackett06 + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Jackett06 + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Jackett06 + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Jackett06 + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Jackett06 + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Jackett06 + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Jackett06 + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Jackett06 + +end type Jackett06_EOS + +contains + +!> In situ density of sea water using Jackett et al., 2006 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Jackett06(this, T, S, pressure) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< Pressure [Pa]. + + ! Local variables + real :: num_STP ! State dependent part of the numerator of the rational expresion + ! for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: den_STP ! State dependent part of the denominator of the rational expresion + ! for density [nondim] + real :: I_den ! The inverse of the denominator of the rational expresion for density [nondim] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num_STP = (T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + I_den = 1.0 / den + + density_elem_Jackett06 = (RN000 + num_STP)*I_den + +end function density_elem_Jackett06 + +!> In situ density anomaly of sea water using Jackett et al., 2006 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Jackett06(this, T, S, pressure, rho_ref) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< Pressure [Pa]. + real, intent(in) :: rho_ref !< A reference density [kg m-3]. + + ! Local variables + real :: num_STP ! State dependent part of the numerator of the rational expresion + ! for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: den_STP ! State dependent part of the denominator of the rational expresion + ! for density [nondim] + real :: I_den ! The inverse of the denominator of the rational expresion for density [nondim] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + real :: rho0 ! The surface density of fresh water at 0 degC, perhaps less the refernce density [kg m-3] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num_STP = (T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + I_den = 1.0 / den + + rho0 = RN000 - rho_ref*den + + density_anomaly_elem_Jackett06 = (rho0 + num_STP)*I_den + +end function density_anomaly_elem_Jackett06 + +!> In situ specific volume of sea water using Jackett et al., 2006 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Jackett06(this, T, S, pressure) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + + ! Local variables + real :: num_STP ! State dependent part of the numerator of the rational expresion + ! for density (not specific volume) [kg m-3] + real :: den_STP ! State dependent part of the denominator of the rational expresion + ! for density (not specific volume) [nondim] + real :: I_num ! The inverse of the numerator of the rational expresion for density [nondim] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num_STP = (T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) + den_STP = (T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) + I_num = 1.0 / (RN000 + num_STP) + + spec_vol_elem_Jackett06 = (1.0 + den_STP) * I_num + +end function spec_vol_elem_Jackett06 + +!> In situ specific volume anomaly of sea water using Jackett et al., 2006 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Jackett06(this, T, S, pressure, spv_ref) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + ! Local variables + real :: num_STP ! State dependent part of the numerator of the rational expresion + ! for density (not specific volume) [kg m-3] + real :: den_STP ! State dependent part of the denominator of the rational expresion + ! for density (not specific volume) [nondim] + real :: I_num ! The inverse of the numerator of the rational expresion for density [nondim] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num_STP = (T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) + den_STP = (T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) + I_num = 1.0 / (RN000 + num_STP) + + ! This form is slightly more complicated, but it cancels the leading terms better. + spec_vol_anomaly_elem_Jackett06 = ((1.0 - spv_ref*RN000) + (den_STP - spv_ref*num_STP)) * I_num + +end function spec_vol_anomaly_elem_Jackett06 + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using Jackett et al., 2006 +elemental subroutine calculate_density_derivs_elem_Jackett06(this, T, S, pressure, drho_dT, drho_dS) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + ! Local variables + real :: num ! Numerator of the rational expresion for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: I_denom2 ! The inverse of the square of the denominator of the rational expression + ! for density [nondim] + real :: dnum_dT ! The derivative of num with potential temperature [kg m-3 degC-1] + real :: dnum_dS ! The derivative of num with salinity [kg m-3 PSU-1] + real :: dden_dT ! The derivative of den with potential temperature [degC-1] + real :: dden_dS ! The derivative of den with salinity PSU-1] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num = RN000 + ((T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) ) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + + dnum_dT = ((RN010 + T*(2.*RN020 + T*(3.*RN030))) + S*RN110) + & + pressure*T*(2.*RN021 + pressure*(2.*RN022)) + dnum_dS = (RN100 + (T*RN110 + S*(2.*RN200))) + pressure*RN101 + dden_dT = ((RD010 + T*((2.*RD020) + T*((3.*RD030) + T*(4.*RD040)))) + & + S*((RD110 + T2*(3.*RD130)) + S1_2*T*(2.*RD620)) ) + & + pressure**2*(T2*3.*RD032 + pressure*RD013) + dden_dS = RD100 + (T*(RD110 + T2*RD130) + S1_2*(1.5*RD600 + T2*(1.5*RD620))) + I_denom2 = 1.0 / den**2 + + ! rho = num / den + drho_dT = (dnum_dT * den - num * dden_dT) * I_denom2 + drho_dS = (dnum_dS * den - num * dden_dS) * I_denom2 + +end subroutine calculate_density_derivs_elem_Jackett06 + +!> Calculate second derivatives of density with respect to temperature, salinity, and pressure, +!! using Jackett et al., 2006 +elemental subroutine calculate_density_second_derivs_elem_Jackett06(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + ! Local variables + real :: num ! Numerator of the rational expresion for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: I_num2 ! The inverse of the square of the numerator of the rational expression + ! for density [nondim] + real :: dnum_dT ! The derivative of num with potential temperature [kg m-3 degC-1] + real :: dnum_dS ! The derivative of num with salinity [kg m-3 PSU-1] + real :: dden_dT ! The derivative of den with potential temperature [degC-1] + real :: dden_dS ! The derivative of den with salinity PSU-1] + real :: dnum_dp ! The derivative of num with pressure [kg m-3 dbar-1] + real :: dden_dp ! The derivative of det with pressure [dbar-1] + real :: d2num_dT2 ! The second derivative of num with potential temperature [kg m-3 degC-2] + real :: d2num_dT_dS ! The second derivative of num with potential temperature and + ! salinity [kg m-3 degC-1 PSU-1] + real :: d2num_dS2 ! The second derivative of num with salinity [kg m-3 PSU-2] + real :: d2num_dT_dp ! The second derivative of num with potential temperature and + ! pressure [kg m-3 degC-1 dbar-1] + real :: d2num_dS_dp ! The second derivative of num with salinity and + ! pressure [kg m-3 PSU-1 dbar-1] + real :: d2den_dT2 ! The second derivative of den with potential temperature [degC-2] + real :: d2den_dT_dS ! The second derivative of den with potential temperature and salinity [degC-1 PSU-1] + real :: d2den_dS2 ! The second derivative of den with salinity [PSU-2] + real :: d2den_dT_dp ! The second derivative of den with potential temperature and pressure [degC-1 dbar-1] + real :: d2den_dS_dp ! The second derivative of den with salinity and pressure [PSU-1 dbar-1] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + real :: I_s12 ! The inverse of the square root of salinity [PSU-1/2] + real :: I_denom2 ! The inverse of the square of the denominator of the rational expression + ! for density [nondim] + real :: I_denom3 ! The inverse of the cube of the denominator of the rational expression + ! for density [nondim] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num = RN000 + ((T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) ) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + ! rho = num*I_den + + dnum_dT = ((RN010 + T*(2.*RN020 + T*(3.*RN030))) + S*RN110) + & + pressure*T*(2.*RN021 + pressure*(2.*RN022)) + dnum_dS = (RN100 + (T*RN110 + S*(2.*RN200))) + pressure*RN101 + dnum_dp = RN001 + ((T2*RN021 + S*RN101) + pressure*(2.*RN002 + T2*(2.*RN022))) + d2num_dT2 = 2.*RN020 + T*(6.*RN030) + pressure*(2.*RN021 + pressure*(2.*RN022)) + d2num_dT_dS = RN110 + d2num_dS2 = 2.*RN200 + d2num_dT_dp = T*(2.*RN021 + pressure*(4.*RN022)) + d2num_dS_dp = RN101 + + dden_dT = ((RD010 + T*((2.*RD020) + T*((3.*RD030) + T*(4.*RD040)))) + & + S*((RD110 + T2*(3.*RD130)) + S1_2*T*(2.*RD620)) ) + & + pressure**2*(T2*3.*RD032 + pressure*RD013) + dden_dS = RD100 + (T*(RD110 + T2*RD130) + S1_2*(1.5*RD600 + T2*(1.5*RD620))) + dden_dp = RD001 + pressure*T*(T2*(2.*RD032) + pressure*(3.*RD013)) + + d2den_dT2 = (((2.*RD020) + T*((6.*RD030) + T*(12.*RD040))) + & + S*(T*(6.*RD130) + S1_2*(2.*RD620)) ) + pressure**2*(T*(6.*RD032)) + d2den_dT_dS = (RD110 + T2*3.*RD130) + (T*S1_2)*(3.0*RD620) + d2den_dT_dp = pressure*(T2*(6.*RD032) + pressure*(3.*RD013)) + d2den_dS_dp = 0.0 + + ! The Jackett et al. 2006 equation of state is a fit to density, but it chooses a form that + ! exhibits a singularity in the second derivatives with salinity for fresh water. To avoid + ! this, the square root of salinity can be treated with a floor such that the contribution from + ! the S**1.5 terms to both the surface density and the secant bulk modulus are lost to roundoff. + ! This salinity is given by (~1e-16/RD600)**(2/3) ~= 7e-8 PSU, or S1_2 ~= 2.6e-4 + I_S12 = 1.0 / (max(S1_2, 1.0e-4)) + d2den_dS2 = (0.75*RD600 + T2*(0.75*RD620)) * I_S12 + + I_denom3 = 1.0 / den**3 + + ! In deriving the following, it is useful to note that: + ! drho_dp = (dnum_dp * den - num * dden_dp) / den**2 + ! drho_dT = (dnum_dT * den - num * dden_dT) / den**2 + ! drho_dS = (dnum_dS * den - num * dden_dS) / den**2 + drho_dS_dS = (den*(den*d2num_dS2 - 2.*dnum_dS*dden_dS) + num*(2.*dden_dS**2 - den*d2den_dS2)) * I_denom3 + drho_dS_dt = (den*(den*d2num_dT_dS - (dnum_dT*dden_dS + dnum_dS*dden_dT)) + & + num*(2.*dden_dT*dden_dS - den*d2den_dT_dS)) * I_denom3 + drho_dT_dT = (den*(den*d2num_dT2 - 2.*dnum_dT*dden_dT) + num*(2.*dden_dT**2 - den*d2den_dT2)) * I_denom3 + + drho_dS_dp = (den*(den*d2num_dS_dp - (dnum_dp*dden_dS + dnum_dS*dden_dp)) + & + num*(2.*dden_dS*dden_dp - den*d2den_dS_dp)) * I_denom3 + drho_dT_dp = (den*(den*d2num_dT_dp - (dnum_dp*dden_dT + dnum_dT*dden_dp)) + & + num*(2.*dden_dT*dden_dp - den*d2den_dT_dp)) * I_denom3 + +end subroutine calculate_density_second_derivs_elem_Jackett06 + +!> Calculate second derivatives of density with respect to temperature, salinity, and pressure, +!! using Jackett et al., 2006 +elemental subroutine calculate_specvol_derivs_elem_Jackett06(this, T, S, pressure, dSV_dT, dSV_dS) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + + ! Local variables + real :: num ! Numerator of the rational expresion for density (not specific volume) [kg m-3] + real :: den ! Denominator of the rational expresion for density (not specific volume) [nondim] + real :: I_num2 ! The inverse of the square of the numerator of the rational expression + ! for density [nondim] + real :: dnum_dT ! The derivative of num with potential temperature [kg m-3 degC-1] + real :: dnum_dS ! The derivative of num with salinity [kg m-3 PSU-1] + real :: dden_dT ! The derivative of den with potential temperature [degC-1] + real :: dden_dS ! The derivative of den with salinity PSU-1] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num = RN000 + ((T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) ) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + + dnum_dT = ((RN010 + T*(2.*RN020 + T*(3.*RN030))) + S*RN110) + & + pressure*T*(2.*RN021 + pressure*(2.*RN022)) + dnum_dS = (RN100 + (T*RN110 + S*(2.*RN200))) + pressure*RN101 + dden_dT = ((RD010 + T*((2.*RD020) + T*((3.*RD030) + T*(4.*RD040)))) + & + S*((RD110 + T2*(3.*RD130)) + S1_2*T*(2.*RD620)) ) + & + pressure**2*(T2*3.*RD032 + pressure*RD013) + dden_dS = RD100 + (T*(RD110 + T2*RD130) + S1_2*(1.5*RD600 + T2*(1.5*RD620))) + I_num2 = 1.0 / num**2 + + ! SV = den / num + dSV_dT = (num * dden_dT - dnum_dT * den) * I_num2 + dSV_dS = (num * dden_dS - dnum_dS * den) * I_num2 + +end subroutine calculate_specvol_derivs_elem_Jackett06 + +!> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) +!! at the given salinity, potential temperature and pressure using Jackett et al., 2006 +elemental subroutine calculate_compress_elem_Jackett06(this, T, S, pressure, rho, drho_dp) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] + ! Local variables + real :: num ! Numerator of the rational expresion for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: I_den ! The inverse of the denominator of the rational expression for density [nondim] + real :: dnum_dp ! The derivative of num with pressure [kg m-3 dbar-1] + real :: dden_dp ! The derivative of den with pressure [dbar-1] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + integer :: j + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num = RN000 + ((T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) ) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + dnum_dp = RN001 + ((T2*RN021 + S*RN101) + pressure*(2.*RN002 + T2*(2.*RN022))) + dden_dp = RD001 + pressure*T*(T2*(2.*RD032) + pressure*(3.*RD013)) + + I_den = 1.0 / den + rho = num * I_den + drho_dp = (dnum_dp * den - num * dden_dp) * I_den**2 + +end subroutine calculate_compress_elem_Jackett06 + +!> Return the range of temperatures, salinities and pressures for which the Jackett et al. (2006) +!! equation of state has been fitted to observations. Care should be taken when applying this +!! equation of state outside of its fit range. +subroutine EoS_fit_range_Jackett06(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + ! Note that the actual fit range is given for the surface range of temperatures and salinities, + ! but Jackett et al. use a more limited range of properties at higher pressures. + if (present(T_min)) T_min = -4.5 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 8.5e7 + +end subroutine EoS_fit_range_Jackett06 + + +!> \namespace mom_eos_Jackett06 +!! +!! \section section_EOS_Jackett06 Jackett et al. 2006 (Hycom-25-term) equation of state +!! +!! Jackett et al. (2006) provide an approximation for the in situ density as a function of +!! potential temperature, salinity, and pressure. This 25 term equation of state is +!! frequently used in Hycom for a potential density, at which point it only has 17 terms +!! and so is commonly called the "17-term equation of state" there. Here the full expressions +!! for the in situ densities are used. +!! +!! The functional form of this equation of state includes terms proportional to salinity to the +!! 3/2 power. This introduces a singularity in the second derivative of density with salinity +!! at a salinity of 0, but this has been addressed here by setting a floor of 1e-8 PSU on the +!! salinity that is used in the denominator of these second derivative expressions. This value +!! was chosen to imply a contribution that is smaller than numerical roundoff in the expression for +!! density, which is the field for which the Jackett et al. equation of state was originally derived. +!! +!! \subsection section_EOS_Jackett06_references References +!! +!! Jackett, D., T. McDougall, R. Feistel, D. Wright and S. Griffies (2006), +!! Algorithms for density, potential temperature, conservative +!! temperature, and the freezing temperature of seawater, JAOT +!! doi.org/10.1175/JTECH1946.1 + +end module MOM_EOS_Jackett06 diff --git a/equation_of_state/MOM_EOS_Roquet_SpV.F90 b/equation_of_state/MOM_EOS_Roquet_SpV.F90 new file mode 100644 index 0000000000..205b6e2b55 --- /dev/null +++ b/equation_of_state/MOM_EOS_Roquet_SpV.F90 @@ -0,0 +1,774 @@ +!> The equation of state for specific volume (SpV) using the expressions of Roquet et al. 2015 +module MOM_EOS_Roquet_Spv + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS_base_type, only : EOS_base + +implicit none ; private + +public Roquet_SpV_EOS + +real, parameter :: Pa2kb = 1.e-8 !< Conversion factor between Pa and kbar [kbar Pa-1] +!>@{ Parameters in the Roquet specific volume polynomial equation of state +real, parameter :: rdeltaS = 24. ! An offset to salinity before taking its square root [g kg-1] +real, parameter :: r1_S0 = 0.875/35.16504 ! The inverse of a plausible range of oceanic salinities [kg g-1] +real, parameter :: I_Ts = 0.025 ! The inverse of a plausible range of oceanic temperatures [degC-1] +! The following are the coefficients of the fit to the reference density profile (rho00p) as a function of +! pressure (P), with a contribution R0c * P**(c+1). The nomenclature follows Roquet. +real, parameter :: V00 = -4.4015007269e-05*Pa2kb ! SpV00p P coef. [m3 kg-1 Pa-1] +real, parameter :: V01 = 6.9232335784e-06*Pa2kb**2 ! SpV00p P**2 coef. [m3 kg-1 Pa-2] +real, parameter :: V02 = -7.5004675975e-07*Pa2kb**3 ! SpV00p P**3 coef. [m3 kg-1 Pa-3] +real, parameter :: V03 = 1.7009109288e-08*Pa2kb**4 ! SpV00p P**4 coef. [m3 kg-1 Pa-4] +real, parameter :: V04 = -1.6884162004e-08*Pa2kb**5 ! SpV00p P**5 coef. [m3 kg-1 Pa-5] +real, parameter :: V05 = 1.9613503930e-09*Pa2kb**6 ! SpV00p P**6 coef. [m3 kg-1 Pa-6] + +! The following terms are contributions to specific volume (SpV) as a function of the square root of +! normalized absolute salinity with an offset (zs), temperature (T) and pressure (P), with a contribution +! SPVabc * zs**a * T**b * P**c. The numbers here are copied directly from Roquet et al. (2015), but +! the expressions here do not use the same nondimensionalization for pressure or temperature as they do. +real, parameter :: SPV000 = 1.0772899069e-03 ! Constant SpV contribution [m3 kg-1] +real, parameter :: SPV100 = -3.1263658781e-04 ! SpV zs coef. [m3 kg-1] +real, parameter :: SPV200 = 6.7615860683e-04 ! SpV zs**2 coef. [m3 kg-1] +real, parameter :: SPV300 = -8.6127884515e-04 ! SpV zs**3 coef. [m3 kg-1] +real, parameter :: SPV400 = 5.9010812596e-04 ! SpV zs**4 coef. [m3 kg-1] +real, parameter :: SPV500 = -2.1503943538e-04 ! SpV zs**5 coef. [m3 kg-1] +real, parameter :: SPV600 = 3.2678954455e-05 ! SpV zs**6 coef. [m3 kg-1] +real, parameter :: SPV010 = -1.4949652640e-05*I_Ts ! SpV T coef. [m3 kg-1 degC-1] +real, parameter :: SPV110 = 3.1866349188e-05*I_Ts ! SpV zs * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV210 = -3.8070687610e-05*I_Ts ! SpV zs**2 * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV310 = 2.9818473563e-05*I_Ts ! SpV zs**3 * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV410 = -1.0011321965e-05*I_Ts ! SpV zs**4 * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV510 = 1.0751931163e-06*I_Ts ! SpV zs**5 * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV020 = 2.7546851539e-05*I_Ts**2 ! SpV T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV120 = -3.6597334199e-05*I_Ts**2 ! SpV zs * T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV220 = 3.4489154625e-05*I_Ts**2 ! SpV zs**2 * T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV320 = -1.7663254122e-05*I_Ts**2 ! SpV zs**3 * T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV420 = 3.5965131935e-06*I_Ts**2 ! SpV zs**4 * T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV030 = -1.6506828994e-05*I_Ts**3 ! SpV T**3 coef. [m3 kg-1 degC-3] +real, parameter :: SPV130 = 2.4412359055e-05*I_Ts**3 ! SpV zs * T**3 coef. [m3 kg-1 degC-3] +real, parameter :: SPV230 = -1.4606740723e-05*I_Ts**3 ! SpV zs**2 * T**3 coef. [m3 kg-1 degC-3] +real, parameter :: SPV330 = 2.3293406656e-06*I_Ts**3 ! SpV zs**3 * T**3 coef. [m3 kg-1 degC-3] +real, parameter :: SPV040 = 6.7896174634e-06*I_Ts**4 ! SpV T**4 coef. [m3 kg-1 degC-4] +real, parameter :: SPV140 = -8.7951832993e-06*I_Ts**4 ! SpV zs * T**4 coef. [m3 kg-1 degC-4] +real, parameter :: SPV240 = 4.4249040774e-06*I_Ts**4 ! SpV zs**2 * T**4 coef. [m3 kg-1 degC-4] +real, parameter :: SPV050 = -7.2535743349e-07*I_Ts**5 ! SpV T**5 coef. [m3 kg-1 degC-5] +real, parameter :: SPV150 = -3.4680559205e-07*I_Ts**5 ! SpV zs * T**5 coef. [m3 kg-1 degC-5] +real, parameter :: SPV060 = 1.9041365570e-07*I_Ts**6 ! SpV T**6 coef. [m3 kg-1 degC-6] +real, parameter :: SPV001 = -1.6889436589e-05*Pa2kb ! SpV P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV101 = 2.1106556158e-05*Pa2kb ! SpV zs * P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV201 = -2.1322804368e-05*Pa2kb ! SpV zs**2 * P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV301 = 1.7347655458e-05*Pa2kb ! SpV zs**3 * P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV401 = -4.3209400767e-06*Pa2kb ! SpV zs**4 * P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV011 = 1.5355844621e-05*(I_Ts*Pa2kb) ! SpV T * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: SPV111 = 2.0914122241e-06*(I_Ts*Pa2kb) ! SpV zs * T * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: SPV211 = -5.7751479725e-06*(I_Ts*Pa2kb) ! SpV zs**2 * T * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: SPV311 = 1.0767234341e-06*(I_Ts*Pa2kb) ! SpV zs**3 * T * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: SPV021 = -9.6659393016e-06*(I_Ts**2*Pa2kb) ! SpV T**2 * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: SPV121 = -7.0686982208e-07*(I_Ts**2*Pa2kb) ! SpV zs * T**2 * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: SPV221 = 1.4488066593e-06*(I_Ts**2*Pa2kb) ! SpV zs**2 * T**2 * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: SPV031 = 3.1134283336e-06*(I_Ts**3*Pa2kb) ! SpV T**3 * P coef. [m3 kg-1 degC-3 Pa-1] +real, parameter :: SPV131 = 7.9562529879e-08*(I_Ts**3*Pa2kb) ! SpV zs * T**3 * P coef. [m3 kg-1 degC-3 Pa-1] +real, parameter :: SPV041 = -5.6590253863e-07*(I_Ts**4*Pa2kb) ! SpV T**4 * P coef. [m3 kg-1 degC-4 Pa-1] +real, parameter :: SPV002 = 1.0500241168e-06*Pa2kb**2 ! SpV P**2 coef. [m3 kg-1 Pa-2] +real, parameter :: SPV102 = 1.9600661704e-06*Pa2kb**2 ! SpV zs * P**2 coef. [m3 kg-1 Pa-2] +real, parameter :: SPV202 = -2.1666693382e-06*Pa2kb**2 ! SpV zs**2 * P**2 coef. [m3 kg-1 Pa-2] +real, parameter :: SPV012 = -3.8541359685e-06*(I_Ts*Pa2kb**2) ! SpV T * P**2 coef. [m3 kg-1 degC-1 Pa-2] +real, parameter :: SPV112 = 1.0157632247e-06*(I_Ts*Pa2kb**2) ! SpV zs * T * P**2 coef. [m3 kg-1 degC-1 Pa-2] +real, parameter :: SPV022 = 1.7178343158e-06*(I_Ts**2*Pa2kb**2) ! SpV T**2 * P**2 coef. [m3 kg-1 degC-2 Pa-2] +real, parameter :: SPV003 = -4.1503454190e-07*Pa2kb**3 ! SpV P**3 coef. [m3 kg-1 Pa-3] +real, parameter :: SPV103 = 3.5627020989e-07*Pa2kb**3 ! SpV zs * P**3 coef. [m3 kg-1 Pa-3] +real, parameter :: SPV013 = -1.1293871415e-07*(I_Ts*Pa2kb**3) ! SpV T * P**3 coef. [m3 kg-1 degC-1 Pa-3] + +real, parameter :: ALP000 = SPV010 ! Constant in the dSpV_dT fit [m3 kg-1 degC-1] +real, parameter :: ALP100 = SPV110 ! dSpV_dT fit zs coef. [m3 kg-1 degC-1] +real, parameter :: ALP200 = SPV210 ! dSpV_dT fit zs**2 coef. [m3 kg-1 degC-1] +real, parameter :: ALP300 = SPV310 ! dSpV_dT fit zs**3 coef. [m3 kg-1 degC-1] +real, parameter :: ALP400 = SPV410 ! dSpV_dT fit zs**4 coef. [m3 kg-1 degC-1] +real, parameter :: ALP500 = SPV510 ! dSpV_dT fit zs**5 coef. [m3 kg-1 degC-1] +real, parameter :: ALP010 = 2.*SPV020 ! dSpV_dT fit T coef. [m3 kg-1 degC-2] +real, parameter :: ALP110 = 2.*SPV120 ! dSpV_dT fit zs * T coef. [m3 kg-1 degC-2] +real, parameter :: ALP210 = 2.*SPV220 ! dSpV_dT fit zs**2 * T coef. [m3 kg-1 degC-2] +real, parameter :: ALP310 = 2.*SPV320 ! dSpV_dT fit zs**3 * T coef. [m3 kg-1 degC-2] +real, parameter :: ALP410 = 2.*SPV420 ! dSpV_dT fit zs**4 * T coef. [m3 kg-1 degC-2] +real, parameter :: ALP020 = 3.*SPV030 ! dSpV_dT fit T**2 coef. [m3 kg-1 degC-3] +real, parameter :: ALP120 = 3.*SPV130 ! dSpV_dT fit zs * T**2 coef. [m3 kg-1 degC-3] +real, parameter :: ALP220 = 3.*SPV230 ! dSpV_dT fit zs**2 * T**2 coef. [m3 kg-1 degC-3] +real, parameter :: ALP320 = 3.*SPV330 ! dSpV_dT fit zs**3 * T**2 coef. [m3 kg-1 degC-3] +real, parameter :: ALP030 = 4.*SPV040 ! dSpV_dT fit T**3 coef. [m3 kg-1 degC-4] +real, parameter :: ALP130 = 4.*SPV140 ! dSpV_dT fit zs * T**3 coef. [m3 kg-1 degC-4] +real, parameter :: ALP230 = 4.*SPV240 ! dSpV_dT fit zs**2 * T**3 coef. [m3 kg-1 degC-4] +real, parameter :: ALP040 = 5.*SPV050 ! dSpV_dT fit T**4 coef. [m3 kg-1 degC-5] +real, parameter :: ALP140 = 5.*SPV150 ! dSpV_dT fit zs* * T**4 coef. [m3 kg-1 degC-5] +real, parameter :: ALP050 = 6.*SPV060 ! dSpV_dT fit T**5 coef. [m3 kg-1 degC-6] +real, parameter :: ALP001 = SPV011 ! dSpV_dT fit P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: ALP101 = SPV111 ! dSpV_dT fit zs * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: ALP201 = SPV211 ! dSpV_dT fit zs**2 * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: ALP301 = SPV311 ! dSpV_dT fit zs**3 * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: ALP011 = 2.*SPV021 ! dSpV_dT fit T * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: ALP111 = 2.*SPV121 ! dSpV_dT fit zs * T * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: ALP211 = 2.*SPV221 ! dSpV_dT fit zs**2 * T * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: ALP021 = 3.*SPV031 ! dSpV_dT fit T**2 * P coef. [m3 kg-1 degC-3 Pa-1] +real, parameter :: ALP121 = 3.*SPV131 ! dSpV_dT fit zs * T**2 * P coef. [m3 kg-1 degC-3 Pa-1] +real, parameter :: ALP031 = 4.*SPV041 ! dSpV_dT fit T**3 * P coef. [m3 kg-1 degC-4 Pa-1] +real, parameter :: ALP002 = SPV012 ! dSpV_dT fit P**2 coef. [m3 kg-1 degC-1 Pa-2] +real, parameter :: ALP102 = SPV112 ! dSpV_dT fit zs * P**2 coef. [m3 kg-1 degC-1 Pa-2] +real, parameter :: ALP012 = 2.*SPV022 ! dSpV_dT fit T * P**2 coef. [m3 kg-1 degC-2 Pa-2] +real, parameter :: ALP003 = SPV013 ! dSpV_dT fit P**3 coef. [m3 kg-1 degC-1 Pa-3] + +real, parameter :: BET000 = 0.5*SPV100*r1_S0 ! Constant in the dSpV_dS fit [m3 kg-1 ppt-1] +real, parameter :: BET100 = SPV200*r1_S0 ! dSpV_dS fit zs coef. [m3 kg-1 ppt-1] +real, parameter :: BET200 = 1.5*SPV300*r1_S0 ! dSpV_dS fit zs**2 coef. [m3 kg-1 ppt-1] +real, parameter :: BET300 = 2.0*SPV400*r1_S0 ! dSpV_dS fit zs**3 coef. [m3 kg-1 ppt-1] +real, parameter :: BET400 = 2.5*SPV500*r1_S0 ! dSpV_dS fit zs**4 coef. [m3 kg-1 ppt-1] +real, parameter :: BET500 = 3.0*SPV600*r1_S0 ! dSpV_dS fit zs**5 coef. [m3 kg-1 ppt-1] +real, parameter :: BET010 = 0.5*SPV110*r1_S0 ! dSpV_dS fit T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET110 = SPV210*r1_S0 ! dSpV_dS fit zs * T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET210 = 1.5*SPV310*r1_S0 ! dSpV_dS fit zs**2 * T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET310 = 2.0*SPV410*r1_S0 ! dSpV_dS fit zs**3 * T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET410 = 2.5*SPV510*r1_S0 ! dSpV_dS fit zs**4 * T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET020 = 0.5*SPV120*r1_S0 ! dSpV_dS fit T**2 coef. [m3 kg-1 ppt-1 degC-2] +real, parameter :: BET120 = SPV220*r1_S0 ! dSpV_dS fit zs * T**2 coef. [m3 kg-1 ppt-1 degC-2] +real, parameter :: BET220 = 1.5*SPV320*r1_S0 ! dSpV_dS fit zs**2 * T**2 coef. [m3 kg-1 ppt-1 degC-2] +real, parameter :: BET320 = 2.0*SPV420*r1_S0 ! dSpV_dS fit zs**3 * T**2 coef. [m3 kg-1 ppt-1 degC-2] +real, parameter :: BET030 = 0.5*SPV130*r1_S0 ! dSpV_dS fit T**3 coef. [m3 kg-1 ppt-1 degC-3] +real, parameter :: BET130 = SPV230*r1_S0 ! dSpV_dS fit zs * T**3 coef. [m3 kg-1 ppt-1 degC-3] +real, parameter :: BET230 = 1.5*SPV330*r1_S0 ! dSpV_dS fit zs**2 * T**3 coef. [m3 kg-1 ppt-1 degC-3] +real, parameter :: BET040 = 0.5*SPV140*r1_S0 ! dSpV_dS fit T**4 coef. [m3 kg-1 ppt-1 degC-4] +real, parameter :: BET140 = SPV240*r1_S0 ! dSpV_dS fit zs * T**4 coef. [m3 kg-1 ppt-1 degC-4] +real, parameter :: BET050 = 0.5*SPV150*r1_S0 ! dSpV_dS fit T**5 coef. [m3 kg-1 ppt-1 degC-5] +real, parameter :: BET001 = 0.5*SPV101*r1_S0 ! dSpV_dS fit P coef. [m3 kg-1 ppt-1 Pa-1] +real, parameter :: BET101 = SPV201*r1_S0 ! dSpV_dS fit zs * P coef. [m3 kg-1 ppt-1 Pa-1] +real, parameter :: BET201 = 1.5*SPV301*r1_S0 ! dSpV_dS fit zs**2 * P coef. [m3 kg-1 ppt-1 Pa-1] +real, parameter :: BET301 = 2.0*SPV401*r1_S0 ! dSpV_dS fit zs**3 * P coef. [m3 kg-1 ppt-1 Pa-1] +real, parameter :: BET011 = 0.5*SPV111*r1_S0 ! dSpV_dS fit T * P coef. [m3 kg-1 ppt-1 degC-1 Pa-1] +real, parameter :: BET111 = SPV211*r1_S0 ! dSpV_dS fit zs * T * P coef. [m3 kg-1 ppt-1 degC-1 Pa-1] +real, parameter :: BET211 = 1.5*SPV311*r1_S0 ! dSpV_dS fit zs**2 * T * P coef. [m3 kg-1 ppt-1 degC-1 Pa-1] +real, parameter :: BET021 = 0.5*SPV121*r1_S0 ! dSpV_dS fit T**2 * P coef. [m3 kg-1 ppt-1 degC-2 Pa-1] +real, parameter :: BET121 = SPV221*r1_S0 ! dSpV_dS fit zs * T**2 * P coef. [m3 kg-1 ppt-1 degC-2 Pa-1] +real, parameter :: BET031 = 0.5*SPV131*r1_S0 ! dSpV_dS fit T**3 * P coef. [m3 kg-1 ppt-1 degC-3 Pa-1] +real, parameter :: BET002 = 0.5*SPV102*r1_S0 ! dSpV_dS fit P**2 coef. [m3 kg-1 ppt-1 Pa-2] +real, parameter :: BET102 = SPV202*r1_S0 ! dSpV_dS fit zs * P**2 coef. [m3 kg-1 ppt-1 Pa-2] +real, parameter :: BET012 = 0.5*SPV112*r1_S0 ! dSpV_dS fit T * P**2 coef. [m3 kg-1 ppt-1 degC-1 Pa-2] +real, parameter :: BET003 = 0.5*SPV103*r1_S0 ! dSpV_dS fit P**3 coef. [m3 kg-1 ppt-1 Pa-3] +!>@} + +!> The EOS_base implementation of the Roquet et al., 2015, equation of state +type, extends (EOS_base) :: Roquet_SpV_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Roquet_SpV + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Roquet_SpV + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Roquet_SpV + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Roquet_SpV + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Roquet_SpV + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Roquet_SpV + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Roquet_SpV + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Roquet_SpV + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Roquet_SpV + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_Roquet_SpV + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_Roquet_SpV + +end type Roquet_SpV_EOS + +contains + +!> Roquet et al. in situ specific volume of sea water [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Roquet_SpV(this, T, S, pressure) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< pressure [Pa] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: SV_00p ! A pressure-dependent but temperature and salinity independent contribution to + ! specific volume at the reference temperature and salinity [m3 kg-1] + real :: SV_TS ! Specific volume without a pressure-dependent contribution [m3 kg-1] + real :: SV_TS0 ! A contribution to specific volume from temperature and salinity anomalies at + ! the surface pressure [m3 kg-1] + real :: SV_TS1 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure [m3 kg-1 Pa-1] + real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**2 [m3 kg-1 Pa-2] + real :: SV_TS3 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**3 [m3 kg-1 Pa-3] + real :: SV_0S0 ! Salinity dependent specific volume at the surface pressure and zero temperature [m3 kg-1] + + ! The following algorithm was published by Roquet et al. (2015), intended for use in non-Boussinesq ocean models. + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + SV_TS3 = SPV003 + (zs*SPV103 + zt*SPV013) + SV_TS2 = SPV002 + (zs*(SPV102 + zs*SPV202) & + + zt*(SPV012 + (zs*SPV112 + zt*SPV022)) ) + SV_TS1 = SPV001 + (zs*(SPV101 + zs*(SPV201 + zs*(SPV301 + zs*SPV401))) & + + zt*(SPV011 + (zs*(SPV111 + zs*(SPV211 + zs*SPV311)) & + + zt*(SPV021 + (zs*(SPV121 + zs*SPV221) & + + zt*(SPV031 + (zs*SPV131 + zt*SPV041)) )) )) ) + SV_TS0 = zt*(SPV010 & + + (zs*(SPV110 + zs*(SPV210 + zs*(SPV310 + zs*(SPV410 + zs*SPV510)))) & + + zt*(SPV020 + (zs*(SPV120 + zs*(SPV220 + zs*(SPV320 + zs*SPV420))) & + + zt*(SPV030 + (zs*(SPV130 + zs*(SPV230 + zs*SPV330)) & + + zt*(SPV040 + (zs*(SPV140 + zs*SPV240) & + + zt*(SPV050 + (zs*SPV150 + zt*SPV060)) )) )) )) ) ) + + SV_0S0 = SPV000 + zs*(SPV100 + zs*(SPV200 + zs*(SPV300 + zs*(SPV400 + zs*(SPV500 + zs*SPV600))))) + + SV_00p = zp*(V00 + zp*(V01 + zp*(V02 + zp*(V03 + zp*(V04 + zp*V05))))) + + SV_TS = (SV_TS0 + SV_0S0) + zp*(SV_TS1 + zp*(SV_TS2 + zp*SV_TS3)) + spec_vol_elem_Roquet_SpV = SV_TS + SV_00p ! In situ specific volume [m3 kg-1] + +end function spec_vol_elem_Roquet_SpV + +!> Roquet et al. in situ specific volume anomaly of sea water [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Roquet_SpV(this, T, S, pressure, spv_ref) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< pressure [Pa] + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: SV_00p ! A pressure-dependent but temperature and salinity independent contribution to + ! specific volume at the reference temperature and salinity [m3 kg-1] + real :: SV_TS ! Specific volume without a pressure-dependent contribution [m3 kg-1] + real :: SV_TS0 ! A contribution to specific volume from temperature and salinity anomalies at + ! the surface pressure [m3 kg-1] + real :: SV_TS1 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure [m3 kg-1 Pa-1] + real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**2 [m3 kg-1 Pa-2] + real :: SV_TS3 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**3 [m3 kg-1 Pa-3] + real :: SV_0S0 ! Salinity dependent specific volume at the surface pressure and zero temperature [m3 kg-1] + + ! The following algorithm was published by Roquet et al. (2015), intended for use in non-Boussinesq ocean models. + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + SV_TS3 = SPV003 + (zs*SPV103 + zt*SPV013) + SV_TS2 = SPV002 + (zs*(SPV102 + zs*SPV202) & + + zt*(SPV012 + (zs*SPV112 + zt*SPV022)) ) + SV_TS1 = SPV001 + (zs*(SPV101 + zs*(SPV201 + zs*(SPV301 + zs*SPV401))) & + + zt*(SPV011 + (zs*(SPV111 + zs*(SPV211 + zs*SPV311)) & + + zt*(SPV021 + (zs*(SPV121 + zs*SPV221) & + + zt*(SPV031 + (zs*SPV131 + zt*SPV041)) )) )) ) + SV_TS0 = zt*(SPV010 & + + (zs*(SPV110 + zs*(SPV210 + zs*(SPV310 + zs*(SPV410 + zs*SPV510)))) & + + zt*(SPV020 + (zs*(SPV120 + zs*(SPV220 + zs*(SPV320 + zs*SPV420))) & + + zt*(SPV030 + (zs*(SPV130 + zs*(SPV230 + zs*SPV330)) & + + zt*(SPV040 + (zs*(SPV140 + zs*SPV240) & + + zt*(SPV050 + (zs*SPV150 + zt*SPV060)) )) )) )) ) ) + + SV_0S0 = SPV000 + zs*(SPV100 + zs*(SPV200 + zs*(SPV300 + zs*(SPV400 + zs*(SPV500 + zs*SPV600))))) + + SV_00p = zp*(V00 + zp*(V01 + zp*(V02 + zp*(V03 + zp*(V04 + zp*V05))))) + + SV_0S0 = SV_0S0 - spv_ref + + SV_TS = (SV_TS0 + SV_0S0) + zp*(SV_TS1 + zp*(SV_TS2 + zp*SV_TS3)) + spec_vol_anomaly_elem_Roquet_SpV = SV_TS + SV_00p ! In situ specific volume [m3 kg-1] + +end function spec_vol_anomaly_elem_Roquet_SpV + +!> Roquet in situ density [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Roquet_SpV(this, T, S, pressure) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + + ! Local variables + real :: spv ! The specific volume [m3 kg-1] + + spv = spec_vol_elem_Roquet_SpV(this, T, S, pressure) + density_elem_Roquet_SpV = 1.0 / spv ! In situ density [kg m-3] + +end function density_elem_Roquet_SpV + +!> Roquet in situ density anomaly [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Roquet_SpV(this, T, S, pressure, rho_ref) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + real :: spv ! The specific volume [m3 kg-1] + + spv = spec_vol_anomaly_elem_Roquet_SpV(this, T, S, pressure, spv_ref=1.0/rho_ref) + density_anomaly_elem_Roquet_SpV = -rho_ref**2*spv / (rho_ref*spv + 1.0) ! In situ density [kg m-3] + +end function density_anomaly_elem_Roquet_SpV + +!> Return the partial derivatives of specific volume with temperature and salinity for 1-d array +!! inputs and outputs, using the specific volume polynomial fit from Roquet et al. (2015). +elemental subroutine calculate_specvol_derivs_elem_Roquet_SpV(this, T, S, pressure, dSV_dT, dSV_dS) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! conservative temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! absolute salinity [m3 kg-1 ppt-1] + + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: dSVdzt0 ! A contribution to the partial derivative of specific volume with temperature + ! from temperature anomalies at the surface pressure [m3 kg-1 degC-1] + real :: dSVdzt1 ! A contribution to the partial derivative of specific volume with temperature + ! that is proportional to pressure [m3 kg-1 degC-1 Pa-1] + real :: dSVdzt2 ! A contribution to the partial derivative of specific volume with temperature + ! that is proportional to pressure**2 [m3 kg-1 degC-1 Pa-2] + real :: dSVdzt3 ! A contribution to the partial derivative of specific volume with temperature + ! that is proportional to pressure**3 [m3 kg-1 degC-1 Pa-3] + real :: dSVdzs0 ! A contribution to the partial derivative of specific volume with + ! salinity [m3 kg-1 ppt-1] from temperature anomalies at the surface pressure + real :: dSVdzs1 ! A contribution to the partial derivative of specific volume with + ! salinity [m3 kg-1 ppt-1 Pa-1] proportional to pressure + real :: dSVdzs2 ! A contribution to the partial derivative of specific volume with + ! salinity [m3 kg-1 ppt-1 Pa-2] proportional to pressure**2 + real :: dSVdzs3 ! A contribution to the partial derivative of specific volume with + ! salinity [m3 kg-1 ppt-1 Pa-3] proportional to pressure**3 + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + ! Find the partial derivative of specific volume with temperature + dSVdzt3 = ALP003 + dSVdzt2 = ALP002 + (zs*ALP102 + zt*ALP012) + dSVdzt1 = ALP001 + (zs*(ALP101 + zs*(ALP201 + zs*ALP301)) & + + zt*(ALP011 + (zs*(ALP111 + zs*ALP211) & + + zt*(ALP021 + (zs*ALP121 + zt*ALP031)) )) ) + dSVdzt0 = ALP000 + (zs*(ALP100 + zs*(ALP200 + zs*(ALP300 + zs*(ALP400 + zs*ALP500)))) & + + zt*(ALP010 + (zs*(ALP110 + zs*(ALP210 + zs*(ALP310 + zs*ALP410))) & + + zt*(ALP020 + (zs*(ALP120 + zs*(ALP220 + zs*ALP320)) & + + zt*(ALP030 + (zt*(ALP040 + (zs*ALP140 + zt*ALP050)) & + + zs*(ALP130 + zs*ALP230) )) )) )) ) + + dSV_dT = dSVdzt0 + zp*(dSVdzt1 + zp*(dSVdzt2 + zp*dSVdzt3)) + + ! Find the partial derivative of specific volume with salinity + dSVdzs3 = BET003 + dSVdzs2 = BET002 + (zs*BET102 + zt*BET012) + dSVdzs1 = BET001 + (zs*(BET101 + zs*(BET201 + zs*BET301)) & + + zt*(BET011 + (zs*(BET111 + zs*BET211) & + + zt*(BET021 + (zs*BET121 + zt*BET031)) )) ) + dSVdzs0 = BET000 + (zs*(BET100 + zs*(BET200 + zs*(BET300 + zs*(BET400 + zs*BET500)))) & + + zt*(BET010 + (zs*(BET110 + zs*(BET210 + zs*(BET310 + zs*BET410))) & + + zt*(BET020 + (zs*(BET120 + zs*(BET220 + zs*BET320)) & + + zt*(BET030 + (zt*(BET040 + (zs*BET140 + zt*BET050)) & + + zs*(BET130 + zs*BET230) )) )) )) ) + + ! The division by zs here is because zs = sqrt(S + S0), so dSV_dS = dzs_dS * dSV_dzs = (0.5 / zs) * dSV_dzs + dSV_dS = (dSVdzs0 + zp*(dSVdzs1 + zp*(dSVdzs2 + zp * dSVdzs3))) / zs + +end subroutine calculate_specvol_derivs_elem_Roquet_SpV + +!> Compute an array of derivatives of densities of sea water with temperature (drho_dT in [kg m-3 degC-1]) +!! and salinity (drho_dS in [kg m-3 ppt-1]) from absolute salinity (S [g kg-1]), conservative temperature +!! (T [degC]) and pressure [Pa], using the specific volume polynomial fit from Roquet et al. (2015). +elemental subroutine calculate_density_derivs_elem_Roquet_SpV(this, T, S, pressure, drho_dT, drho_dS) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with + !! conservative temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with + !! absolute salinity [kg m-3 ppt-1] + + ! Local variables + real :: dSV_dT ! The partial derivative of specific volume with + ! conservative temperature [m3 kg-1 degC-1] + real :: dSV_dS ! The partial derivative of specific volume with + ! absolute salinity [m3 kg-1 ppt-1] + real :: specvol ! The specific volume [m3 kg-1] + real :: rho ! The in situ density [kg m-3] + + call this%calculate_specvol_derivs_elem(T, S, pressure, dSV_dT, dSV_dS) + + specvol = this%spec_vol_elem(T, S, pressure) + rho = 1.0 / specvol + drho_dT = -dSv_dT * rho**2 + drho_dS = -dSv_dS * rho**2 + +end subroutine calculate_density_derivs_elem_Roquet_SpV + +!> Compute the in situ density of sea water (rho in [kg m-3]) and the compressibility +!! (drho/dp = C_sound^-2, stored as drho_dp [s2 m-2]) from absolute salinity (sal [g kg-1]), +!! conservative temperature (T [degC]), and pressure [Pa], using the specific volume +!! polynomial fit from Roquet et al. (2015). +elemental subroutine calculate_compress_elem_Roquet_SpV(this, T, S, pressure, rho, drho_dp) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: dSV_00p_dp ! Derivative of the pressure-dependent reference specific volume profile with + ! pressure [m3 kg-1 Pa-1] + real :: dSV_TS_dp ! Derivative of the specific volume anomaly from the reference profile with + ! pressure [m3 kg-1 Pa-1] + real :: SV_00p ! A pressure-dependent but temperature and salinity independent contribution to + ! specific volume at the reference temperature and salinity [m3 kg-1] + real :: SV_TS ! specific volume without a pressure-dependent contribution [m3 kg-1] + real :: SV_TS0 ! A contribution to specific volume from temperature and salinity anomalies at + ! the surface pressure [m3 kg-1] + real :: SV_TS1 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure [m3 kg-1 Pa-1] + real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**2 [m3 kg-1 Pa-2] + real :: SV_TS3 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**3 [m3 kg-1 Pa-3] + real :: SV_0S0 ! Salinity dependent specific volume at the surface pressure and zero temperature [m3 kg-1] + real :: dSpecVol_dp ! The partial derivative of specific volume with pressure [m3 kg-1 Pa-1] + + ! The following algorithm was published by Roquet et al. (2015), intended for use + ! with NEMO, but it is not necessarily the algorithm used in NEMO ocean model. + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + SV_TS3 = SPV003 + (zs*SPV103 + zt*SPV013) + SV_TS2 = SPV002 + (zs*(SPV102 + zs*SPV202) & + + zt*(SPV012 + (zs*SPV112 + zt*SPV022)) ) + SV_TS1 = SPV001 + (zs*(SPV101 + zs*(SPV201 + zs*(SPV301 + zs*SPV401))) & + + zt*(SPV011 + (zs*(SPV111 + zs*(SPV211 + zs*SPV311)) & + + zt*(SPV021 + (zs*(SPV121 + zs*SPV221) & + + zt*(SPV031 + (zs*SPV131 + zt*SPV041)) )) )) ) + + SV_TS0 = zt*(SPV010 & + + (zs*(SPV110 + zs*(SPV210 + zs*(SPV310 + zs*(SPV410 + zs*SPV510)))) & + + zt*(SPV020 + (zs*(SPV120 + zs*(SPV220 + zs*(SPV320 + zs*SPV420))) & + + zt*(SPV030 + (zs*(SPV130 + zs*(SPV230 + zs*SPV330)) & + + zt*(SPV040 + (zs*(SPV140 + zs*SPV240) & + + zt*(SPV050 + (zs*SPV150 + zt*SPV060)) )) )) )) ) ) + + SV_0S0 = SPV000 + zs*(SPV100 + zs*(SPV200 + zs*(SPV300 + zs*(SPV400 + zs*(SPV500 + zs*SPV600))))) + + SV_00p = zp*(V00 + zp*(V01 + zp*(V02 + zp*(V03 + zp*(V04 + zp*V05))))) + + SV_TS = (SV_TS0 + SV_0S0) + zp*(SV_TS1 + zp*(SV_TS2 + zp*SV_TS3)) + ! specvol = SV_TS + SV_00p ! In situ specific volume [m3 kg-1] + rho = 1.0 / (SV_TS + SV_00p) ! In situ density [kg m-3] + + dSV_00p_dp = V00 + zp*(2.*V01 + zp*(3.*V02 + zp*(4.*V03 + zp*(5.*V04 + zp*(6.*V05))))) + dSV_TS_dp = SV_TS1 + zp*(2.*SV_TS2 + zp*(3.*SV_TS3)) + dSpecVol_dp = dSV_TS_dp + dSV_00p_dp ! [m3 kg-1 Pa-1] + drho_dp = -dSpecVol_dp * rho**2 ! Compressibility [s2 m-2] + +end subroutine calculate_compress_elem_Roquet_SpV + +!> Second derivatives of specific volume with respect to temperature, salinity, and pressure for a +!! 1-d array inputs and outputs using the specific volume polynomial fit from Roquet et al. (2015). +elemental subroutine calc_spec_vol_second_derivs_elem_Roquet_SpV(T, S, P, & + dSV_ds_ds, dSV_ds_dt, dSV_dt_dt, dSV_ds_dp, dSV_dt_dp) + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: P !< Pressure [Pa] + real, intent(inout) :: dSV_ds_ds !< Second derivative of specific volume with respect + !! to salinity [m3 kg-1 ppt-2] + real, intent(inout) :: dSV_ds_dt !< Second derivative of specific volume with respect + !! to salinity and temperature [m3 kg-1 ppt-1 degC-1] + real, intent(inout) :: dSV_dt_dt !< Second derivative of specific volume with respect + !! to temperature [m3 kg-1 degC-2] + real, intent(inout) :: dSV_ds_dp !< Second derivative of specific volume with respect to pressure + !! and salinity [m3 kg-1 ppt-1 Pa-1] + real, intent(inout) :: dSV_dt_dp !< Second derivative of specific volume with respect to pressure + !! and temperature [m3 kg-1 degC-1 Pa-1] + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: I_s ! The inverse of zs [nondim] + real :: d2SV_p0 ! A contribution to one of the second derivatives that is independent of pressure [various] + real :: d2SV_p1 ! A contribution to one of the second derivatives that is proportional to pressure [various] + real :: d2SV_p2 ! A contribution to one of the second derivatives that is proportional to pressure**2 [various] + real :: d2SV_p3 ! A contribution to one of the second derivatives that is proportional to pressure**3 [various] + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = P + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + I_s = 1.0 / zs + + ! Find dSV_ds_ds + d2SV_p3 = -SPV103*I_s**2 + d2SV_p2 = -(SPV102 + zt*SPV112)*I_s**2 + d2SV_p1 = (3.*SPV301 + (zt*(3.*SPV311) + zs*(8.*SPV401))) & + - ( SPV101 + zt*(SPV111 + zt*(SPV121 + zt*SPV131)) )*I_s**2 + d2SV_p0 = (3.*SPV300 + (zs*(8.*SPV400 + zs*(15.*SPV500 + zs*(24.*SPV600))) & + + zt*(3.*SPV310 + (zs*(8.*SPV410 + zs*(15.*SPV510)) & + + zt*(3.*SPV320 + (zs*(8.*SPV420) + zt*(3.*SPV330))) )) )) & + - (SPV100 + zt*(SPV110 + zt*(SPV120 + zt*(SPV130 + zt*(SPV140 + zt*SPV150)))) )*I_s**2 + dSV_dS_dS = (0.5*r1_S0)**2 * ((d2SV_p0 + zp*(d2SV_p1 + zp*(d2SV_p2 + zp*d2SV_p3))) * I_s) + + ! Find dSV_ds_dt + d2SV_p2 = SPV112 + d2SV_p1 = SPV111 + (zs*(2.*SPV211 + zs*(3.*SPV311)) & + + zt*(2.*SPV121 + (zs*(4.*SPV221) + zt*(3.*SPV131))) ) + d2SV_p0 = SPV110 + (zs*(2.*SPV210 + zs*(3.*SPV310 + zs*(4.*SPV410 + zs*(5.*SPV510)))) & + + zt*(2.*SPV120 + (zs*(4.*SPV220 + zs*(6.*SPV320 + zs*(8.*SPV420))) & + + zt*(3.*SPV130 + (zs*(6.*SPV230 + zs*(9.*SPV330)) & + + zt*(4.*SPV140 + (zs*(8.*SPV240) & + + zt*(5.*SPV150))) )) )) ) + dSV_ds_dt = (0.5*r1_S0) * ((d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * I_s) + + ! Find dSV_dt_dt + d2SV_p2 = 2.*SPV022 + d2SV_p1 = 2.*SPV021 + (zs*(2.*SPV121 + zs*(2.*SPV221)) & + + zt*(6.*SPV031 + (zs*(6.*SPV131) + zt*(12.*SPV041))) ) + d2SV_p0 = 2.*SPV020 + (zs*(2.*SPV120 + zs*( 2.*SPV220 + zs*( 2.*SPV320 + zs * (2.*SPV420)))) & + + zt*(6.*SPV030 + (zs*( 6.*SPV130 + zs*( 6.*SPV230 + zs * (6.*SPV330))) & + + zt*(12.*SPV040 + (zs*(12.*SPV140 + zs *(12.*SPV240)) & + + zt*(20.*SPV050 + (zs*(20.*SPV150) & + + zt*(30.*SPV060) )) )) )) ) + dSV_dt_dt = d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2) + + ! Find dSV_ds_dp + d2SV_p2 = 3.*SPV103 + d2SV_p1 = 2.*SPV102 + (zs*(4.*SPV202) + zt*(2.*SPV112)) + d2SV_p0 = SPV101 + (zs*(2.*SPV201 + zs*(3.*SPV301 + zs*(4.*SPV401))) & + + zt*(SPV111 + (zs*(2.*SPV211 + zs*(3.*SPV311)) & + + zt*( SPV121 + (zs*(2.*SPV221) + zt*SPV131)) )) ) + dSV_ds_dp = ((d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * I_s) * (0.5*r1_S0) + + ! Find dSV_dt_dp + d2SV_p2 = 3.*SPV013 + d2SV_p1 = 2.*SPV012 + (zs*(2.*SPV112) + zt*(4.*SPV022)) + d2SV_p0 = SPV011 + (zs*(SPV111 + zs*( SPV211 + zs* SPV311)) & + + zt*(2.*SPV021 + (zs*(2.*SPV121 + zs*(2.*SPV221)) & + + zt*(3.*SPV031 + (zs*(3.*SPV131) + zt*(4.*SPV041))) )) ) + dSV_dt_dp = d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2) + +end subroutine calc_spec_vol_second_derivs_elem_Roquet_SpV + +!> Second derivatives of density with respect to temperature, salinity, and pressure for a +!! 1-d array inputs and outputs using the specific volume polynomial fit from Roquet et al. (2015). +elemental subroutine calculate_density_second_derivs_elem_Roquet_SpV(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Second derivative of density with respect + !! to salinity [kg m-3 ppt-2] + real, intent(inout) :: drho_ds_dt !< Second derivative of density with respect + !! to salinity and temperature [kg m-3 ppt-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Second derivative of density with respect + !! to temperature [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Second derivative of density with respect to pressure + !! and salinity [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] + real, intent(inout) :: drho_dt_dp !< Second derivative of density with respect to pressure + !! and temperature [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + ! Local variables + real :: rho ! The in situ density [kg m-3] + real :: drho_dp ! The partial derivative of density with pressure + ! (also the inverse of the square of sound speed) [s2 m-2] + real :: dSV_dT ! The partial derivative of specific volume with + ! conservative temperature [m3 kg-1 degC-1] + real :: dSV_dS ! The partial derivative of specific volume with + ! absolute salinity [m3 kg-1 ppt-1] + real :: dSV_ds_ds ! Second derivative of specific volume with respect + ! to salinity [m3 kg-1 ppt-2] + real :: dSV_ds_dt ! Second derivative of specific volume with respect + ! to salinity and temperature [m3 kg-1 ppt-1 degC-1] + real :: dSV_dt_dt ! Second derivative of specific volume with respect + ! to temperature [m3 kg-1 degC-2] + real :: dSV_ds_dp ! Second derivative of specific volume with respect to pressure + ! and salinity [m3 kg-1 ppt-1 Pa-1] + real :: dSV_dt_dp ! Second derivative of specific volume with respect to pressure + ! and temperature [m3 kg-1 degC-1 Pa-1] + + call calc_spec_vol_second_derivs_elem_Roquet_SpV(T, S, pressure, & + dSV_ds_ds, dSV_ds_dt, dSV_dt_dt, dSV_ds_dp, dSV_dt_dp) + call this%calculate_specvol_derivs_elem(T, S, pressure, dSV_dT, dSV_dS) + call this%calculate_compress_elem(T, S, pressure, rho, drho_dp) + + ! Find drho_ds_ds + drho_dS_dS = rho**2 * (2.0*rho*dSV_dS**2 - dSV_dS_dS) + + ! Find drho_ds_dt + drho_ds_dt = rho**2 * (2.0*rho*(dSV_dT*dSV_dS) - dSV_dS_dT) + + ! Find drho_dt_dt + drho_dT_dT = rho**2 * (2.0*rho*dSV_dT**2 - dSV_dT_dT) + + ! Find drho_ds_dp + drho_ds_dp = -rho * (2.0*dSV_dS * drho_dp + rho * dSV_dS_dp) + + ! Find drho_dt_dp + drho_dt_dp = -rho * (2.0*dSV_dT * drho_dp + rho * dSV_dT_dp) + +end subroutine calculate_density_second_derivs_elem_Roquet_SpV + +!> Return the range of temperatures, salinities and pressures for which the Roquet et al. (2015) +!! expression for specific volume has been fitted to observations. Care should be taken when +!! applying this equation of state outside of its fit range. +subroutine EoS_fit_range_Roquet_SpV(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: S_max !< The maximum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -6.0 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_Roquet_SpV + +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_Roquet_SpV(this, T, S, pressure, rho, start, npts, rho_ref) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_Roquet_SpV(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_Roquet_SpV(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_Roquet_SpV + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_Roquet_SpV(this, T, S, pressure, specvol, start, npts, spv_ref) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_Roquet_SpV(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_Roquet_SpV(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_Roquet_SpV + +!> \namespace mom_eos_Roquet_SpV +!! +!! \section section_EOS_Roquet_SpV NEMO equation of state +!! +!! Fabien Roquet and colleagues developed this equation of state using a simple polynomial fit +!! to the TEOS-10 equation of state expressions for specific, for efficiency when used with a +!! non-Boussinesq ocean model. This particular equation of state is a balance between an +!! accuracy that matches the TEOS-10 density to better than observational uncertainty with a +!! polynomial form that can be evaluated quickly despite having 55 terms. +!! +!! \subsection section_EOS_Roquet_Spv_references References +!! +!! Roquet, F., Madec, G., McDougall, T. J., and Barker, P. M., 2015: +!! Accurate polynomial expressions for the density and specific volume +!! of seawater using the TEOS-10 standard. Ocean Modelling, 90:29-43. + +end module MOM_EOS_Roquet_Spv diff --git a/equation_of_state/MOM_EOS_Roquet_rho.F90 b/equation_of_state/MOM_EOS_Roquet_rho.F90 new file mode 100644 index 0000000000..1a5cc7b49c --- /dev/null +++ b/equation_of_state/MOM_EOS_Roquet_rho.F90 @@ -0,0 +1,689 @@ +!> The equation of state using the expressions of Roquet et al. (2015) that are used in NEMO +module MOM_EOS_Roquet_rho + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS_base_type, only : EOS_base + +implicit none ; private + +public Roquet_rho_EOS + +real, parameter :: Pa2kb = 1.e-8 !< Conversion factor between Pa and kbar [kbar Pa-1] +!>@{ Parameters in the Roquet_rho (Roquet density) equation of state +real, parameter :: rdeltaS = 32. ! An offset to salinity before taking its square root [g kg-1] +real, parameter :: r1_S0 = 0.875/35.16504 ! The inverse of a plausible range of oceanic salinities [kg g-1] +real, parameter :: I_Ts = 0.025 ! The inverse of a plausible range of oceanic temperatures [degC-1] + +! The following are the coefficients of the fit to the reference density profile (rho00p) as a function of +! pressure (P), with a contribution R0c * P**(c+1). The nomenclature follows Roquet. +real, parameter :: R00 = 4.6494977072e+01*Pa2kb ! rho00p P coef. [kg m-3 Pa-1] +real, parameter :: R01 = -5.2099962525*Pa2kb**2 ! rho00p P**2 coef. [kg m-3 Pa-2] +real, parameter :: R02 = 2.2601900708e-01*Pa2kb**3 ! rho00p P**3 coef. [kg m-3 Pa-3] +real, parameter :: R03 = 6.4326772569e-02*Pa2kb**4 ! rho00p P**4 coef. [kg m-3 Pa-4] +real, parameter :: R04 = 1.5616995503e-02*Pa2kb**5 ! rho00p P**5 coef. [kg m-3 Pa-5] +real, parameter :: R05 = -1.7243708991e-03*Pa2kb**6 ! rho00p P**6 coef. [kg m-3 Pa-6] + +! The following are coefficients of contributions to density as a function of the square root +! of normalized salinity with an offset (zs), temperature (T) and pressure (P), with a contribution +! EOSabc * zs**a * T**b * P**c. The numbers here are copied directly from Roquet et al. (2015), but +! the expressions here do not use the same nondimensionalization for pressure or temperature as they do. +real, parameter :: EOS000 = 8.0189615746e+02 ! A constant density contribution [kg m-3] +real, parameter :: EOS100 = 8.6672408165e+02 ! EoS zs coef. [kg m-3] +real, parameter :: EOS200 = -1.7864682637e+03 ! EoS zs**2 coef. [kg m-3] +real, parameter :: EOS300 = 2.0375295546e+03 ! EoS zs**3 coef. [kg m-3] +real, parameter :: EOS400 = -1.2849161071e+03 ! EoS zs**4 coef. [kg m-3] +real, parameter :: EOS500 = 4.3227585684e+02 ! EoS zs**5 coef. [kg m-3] +real, parameter :: EOS600 = -6.0579916612e+01 ! EoS zs**6 coef. [kg m-3] +real, parameter :: EOS010 = 2.6010145068e+01*I_Ts ! EoS T coef. [kg m-3 degC-1] +real, parameter :: EOS110 = -6.5281885265e+01*I_Ts ! EoS zs * T coef. [kg m-3 degC-1] +real, parameter :: EOS210 = 8.1770425108e+01*I_Ts ! EoS zs**2 * T coef. [kg m-3 degC-1] +real, parameter :: EOS310 = -5.6888046321e+01*I_Ts ! EoS zs**3 * T coef. [kg m-3 degC-1] +real, parameter :: EOS410 = 1.7681814114e+01*I_Ts ! EoS zs**2 * T coef. [kg m-3 degC-1] +real, parameter :: EOS510 = -1.9193502195*I_Ts ! EoS zs**5 * T coef. [kg m-3 degC-1] +real, parameter :: EOS020 = -3.7074170417e+01*I_Ts**2 ! EoS T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS120 = 6.1548258127e+01*I_Ts**2 ! EoS zs * T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS220 = -6.0362551501e+01*I_Ts**2 ! EoS zs**2 * T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS320 = 2.9130021253e+01*I_Ts**2 ! EoS zs**3 * T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS420 = -5.4723692739*I_Ts**2 ! EoS zs**4 * T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS030 = 2.1661789529e+01*I_Ts**3 ! EoS T**3 coef. [kg m-3 degC-3] +real, parameter :: EOS130 = -3.3449108469e+01*I_Ts**3 ! EoS zs * T**3 coef. [kg m-3 degC-3] +real, parameter :: EOS230 = 1.9717078466e+01*I_Ts**3 ! EoS zs**2 * T**3 coef. [kg m-3 degC-3] +real, parameter :: EOS330 = -3.1742946532*I_Ts**3 ! EoS zs**3 * T**3 coef. [kg m-3 degC-3] +real, parameter :: EOS040 = -8.3627885467*I_Ts**4 ! EoS T**4 coef. [kg m-3 degC-4] +real, parameter :: EOS140 = 1.1311538584e+01*I_Ts**4 ! EoS zs * T**4 coef. [kg m-3 degC-4] +real, parameter :: EOS240 = -5.3563304045*I_Ts**4 ! EoS zs**2 * T**4 coef. [kg m-3 degC-4] +real, parameter :: EOS050 = 5.4048723791e-01*I_Ts**5 ! EoS T**5 coef. [kg m-3 degC-5] +real, parameter :: EOS150 = 4.8169980163e-01*I_Ts**5 ! EoS zs * T**5 coef. [kg m-3 degC-5] +real, parameter :: EOS060 = -1.9083568888e-01*I_Ts**6 ! EoS T**6 [kg m-3 degC-6] +real, parameter :: EOS001 = 1.9681925209e+01*Pa2kb ! EoS P coef. [kg m-3 Pa-1] +real, parameter :: EOS101 = -4.2549998214e+01*Pa2kb ! EoS zs * P coef. [kg m-3 Pa-1] +real, parameter :: EOS201 = 5.0774768218e+01*Pa2kb ! EoS zs**2 * P coef. [kg m-3 Pa-1] +real, parameter :: EOS301 = -3.0938076334e+01*Pa2kb ! EoS zs**3 * P coef. [kg m-3 Pa-1] +real, parameter :: EOS401 = 6.6051753097*Pa2kb ! EoS zs**4 * P coef. [kg m-3 Pa-1] +real, parameter :: EOS011 = -1.3336301113e+01*(I_Ts*Pa2kb) ! EoS T * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: EOS111 = -4.4870114575*(I_Ts*Pa2kb) ! EoS zs * T * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: EOS211 = 5.0042598061*(I_Ts*Pa2kb) ! EoS zs**2 * T * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: EOS311 = -6.5399043664e-01*(I_Ts*Pa2kb) ! EoS zs**3 * T * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: EOS021 = 6.7080479603*(I_Ts**2*Pa2kb) ! EoS T**2 * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: EOS121 = 3.5063081279*(I_Ts**2*Pa2kb) ! EoS zs * T**2 * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: EOS221 = -1.8795372996*(I_Ts**2*Pa2kb) ! EoS zs**2 * T**2 * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: EOS031 = -2.4649669534*(I_Ts**3*Pa2kb) ! EoS T**3 * P coef. [kg m-3 degC-3 Pa-1] +real, parameter :: EOS131 = -5.5077101279e-01*(I_Ts**3*Pa2kb) ! EoS zs * T**3 * P coef. [kg m-3 degC-3 Pa-1] +real, parameter :: EOS041 = 5.5927935970e-01*(I_Ts**4*Pa2kb) ! EoS T**4 * P coef. [kg m-3 degC-4 Pa-1] +real, parameter :: EOS002 = 2.0660924175*Pa2kb**2 ! EoS P**2 coef. [kg m-3 Pa-2] +real, parameter :: EOS102 = -4.9527603989*Pa2kb**2 ! EoS zs * P**2 coef. [kg m-3 Pa-2] +real, parameter :: EOS202 = 2.5019633244*Pa2kb**2 ! EoS zs**2 * P**2 coef. [kg m-3 Pa-2] +real, parameter :: EOS012 = 2.0564311499*(I_Ts*Pa2kb**2) ! EoS T * P**2 coef. [kg m-3 degC-1 Pa-2] +real, parameter :: EOS112 = -2.1311365518e-01*(I_Ts*Pa2kb**2) ! EoS zs * T * P**2 coef. [kg m-3 degC-1 Pa-2] +real, parameter :: EOS022 = -1.2419983026*(I_Ts**2*Pa2kb**2) ! EoS T**2 * P**2 coef. [kg m-3 degC-2 Pa-2] +real, parameter :: EOS003 = -2.3342758797e-02*Pa2kb**3 ! EoS P**3 coef. [kg m-3 Pa-3] +real, parameter :: EOS103 = -1.8507636718e-02*Pa2kb**3 ! EoS zs * P**3 coef. [kg m-3 Pa-3] +real, parameter :: EOS013 = 3.7969820455e-01*(I_Ts*Pa2kb**3) ! EoS T * P**3 coef. [kg m-3 degC-1 Pa-3] + +real, parameter :: ALP000 = EOS010 ! Constant in the drho_dT fit [kg m-3 degC-1] +real, parameter :: ALP100 = EOS110 ! drho_dT fit zs coef. [kg m-3 degC-1] +real, parameter :: ALP200 = EOS210 ! drho_dT fit zs**2 coef. [kg m-3 degC-1] +real, parameter :: ALP300 = EOS310 ! drho_dT fit zs**3 coef. [kg m-3 degC-1] +real, parameter :: ALP400 = EOS410 ! drho_dT fit zs**4 coef. [kg m-3 degC-1] +real, parameter :: ALP500 = EOS510 ! drho_dT fit zs**5 coef. [kg m-3 degC-1] +real, parameter :: ALP010 = 2.*EOS020 ! drho_dT fit T coef. [kg m-3 degC-2] +real, parameter :: ALP110 = 2.*EOS120 ! drho_dT fit zs * T coef. [kg m-3 degC-2] +real, parameter :: ALP210 = 2.*EOS220 ! drho_dT fit zs**2 * T coef. [kg m-3 degC-2] +real, parameter :: ALP310 = 2.*EOS320 ! drho_dT fit zs**3 * T coef. [kg m-3 degC-2] +real, parameter :: ALP410 = 2.*EOS420 ! drho_dT fit zs**4 * T coef. [kg m-3 degC-2] +real, parameter :: ALP020 = 3.*EOS030 ! drho_dT fit T**2 coef. [kg m-3 degC-3] +real, parameter :: ALP120 = 3.*EOS130 ! drho_dT fit zs * T**2 coef. [kg m-3 degC-3] +real, parameter :: ALP220 = 3.*EOS230 ! drho_dT fit zs**2 * T**2 coef. [kg m-3 degC-3] +real, parameter :: ALP320 = 3.*EOS330 ! drho_dT fit zs**3 * T**2 coef. [kg m-3 degC-3] +real, parameter :: ALP030 = 4.*EOS040 ! drho_dT fit T**3 coef. [kg m-3 degC-4] +real, parameter :: ALP130 = 4.*EOS140 ! drho_dT fit zs * T**3 coef. [kg m-3 degC-4] +real, parameter :: ALP230 = 4.*EOS240 ! drho_dT fit zs**2 * T**3 coef. [kg m-3 degC-4] +real, parameter :: ALP040 = 5.*EOS050 ! drho_dT fit T**4 coef. [kg m-3 degC-5] +real, parameter :: ALP140 = 5.*EOS150 ! drho_dT fit zs* * T**4 coef. [kg m-3 degC-5] +real, parameter :: ALP050 = 6.*EOS060 ! drho_dT fit T**5 coef. [kg m-3 degC-6] +real, parameter :: ALP001 = EOS011 ! drho_dT fit P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: ALP101 = EOS111 ! drho_dT fit zs * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: ALP201 = EOS211 ! drho_dT fit zs**2 * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: ALP301 = EOS311 ! drho_dT fit zs**3 * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: ALP011 = 2.*EOS021 ! drho_dT fit T * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: ALP111 = 2.*EOS121 ! drho_dT fit zs * T * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: ALP211 = 2.*EOS221 ! drho_dT fit zs**2 * T * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: ALP021 = 3.*EOS031 ! drho_dT fit T**2 * P coef. [kg m-3 degC-3 Pa-1] +real, parameter :: ALP121 = 3.*EOS131 ! drho_dT fit zs * T**2 * P coef. [kg m-3 degC-3 Pa-1] +real, parameter :: ALP031 = 4.*EOS041 ! drho_dT fit T**3 * P coef. [kg m-3 degC-4 Pa-1] +real, parameter :: ALP002 = EOS012 ! drho_dT fit P**2 coef. [kg m-3 degC-1 Pa-2] +real, parameter :: ALP102 = EOS112 ! drho_dT fit zs * P**2 coef. [kg m-3 degC-1 Pa-2] +real, parameter :: ALP012 = 2.*EOS022 ! drho_dT fit T * P**2 coef. [kg m-3 degC-2 Pa-2] +real, parameter :: ALP003 = EOS013 ! drho_dT fit P**3 coef. [kg m-3 degC-1 Pa-3] + +real, parameter :: BET000 = 0.5*EOS100*r1_S0 ! Constant in the drho_dS fit [kg m-3 ppt-1] +real, parameter :: BET100 = EOS200*r1_S0 ! drho_dS fit zs coef. [kg m-3 ppt-1] +real, parameter :: BET200 = 1.5*EOS300*r1_S0 ! drho_dS fit zs**2 coef. [kg m-3 ppt-1] +real, parameter :: BET300 = 2.0*EOS400*r1_S0 ! drho_dS fit zs**3 coef. [kg m-3 ppt-1] +real, parameter :: BET400 = 2.5*EOS500*r1_S0 ! drho_dS fit zs**4 coef. [kg m-3 ppt-1] +real, parameter :: BET500 = 3.0*EOS600*r1_S0 ! drho_dS fit zs**5 coef. [kg m-3 ppt-1] +real, parameter :: BET010 = 0.5*EOS110*r1_S0 ! drho_dS fit T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET110 = EOS210*r1_S0 ! drho_dS fit zs * T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET210 = 1.5*EOS310*r1_S0 ! drho_dS fit zs**2 * T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET310 = 2.0*EOS410*r1_S0 ! drho_dS fit zs**3 * T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET410 = 2.5*EOS510*r1_S0 ! drho_dS fit zs**4 * T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET020 = 0.5*EOS120*r1_S0 ! drho_dS fit T**2 coef. [kg m-3 ppt-1 degC-2] +real, parameter :: BET120 = EOS220*r1_S0 ! drho_dS fit zs * T**2 coef. [kg m-3 ppt-1 degC-2] +real, parameter :: BET220 = 1.5*EOS320*r1_S0 ! drho_dS fit zs**2 * T**2 coef. [kg m-3 ppt-1 degC-2] +real, parameter :: BET320 = 2.0*EOS420*r1_S0 ! drho_dS fit zs**3 * T**2 coef. [kg m-3 ppt-1 degC-2] +real, parameter :: BET030 = 0.5*EOS130*r1_S0 ! drho_dS fit T**3 coef. [kg m-3 ppt-1 degC-3] +real, parameter :: BET130 = EOS230*r1_S0 ! drho_dS fit zs * T**3 coef. [kg m-3 ppt-1 degC-3] +real, parameter :: BET230 = 1.5*EOS330*r1_S0 ! drho_dS fit zs**2 * T**3 coef. [kg m-3 ppt-1 degC-3] +real, parameter :: BET040 = 0.5*EOS140*r1_S0 ! drho_dS fit T**4 coef. [kg m-3 ppt-1 degC-4] +real, parameter :: BET140 = EOS240*r1_S0 ! drho_dS fit zs * T**4 coef. [kg m-3 ppt-1 degC-4] +real, parameter :: BET050 = 0.5*EOS150*r1_S0 ! drho_dS fit T**5 coef. [kg m-3 ppt-1 degC-5] +real, parameter :: BET001 = 0.5*EOS101*r1_S0 ! drho_dS fit P coef. [kg m-3 ppt-1 Pa-1] +real, parameter :: BET101 = EOS201*r1_S0 ! drho_dS fit zs * P coef. [kg m-3 ppt-1 Pa-1] +real, parameter :: BET201 = 1.5*EOS301*r1_S0 ! drho_dS fit zs**2 * P coef. [kg m-3 ppt-1 Pa-1] +real, parameter :: BET301 = 2.0*EOS401*r1_S0 ! drho_dS fit zs**3 * P coef. [kg m-3 ppt-1 Pa-1] +real, parameter :: BET011 = 0.5*EOS111*r1_S0 ! drho_dS fit T * P coef. [kg m-3 ppt-1 degC-1 Pa-1] +real, parameter :: BET111 = EOS211*r1_S0 ! drho_dS fit zs * T * P coef. [kg m-3 ppt-1 degC-1 Pa-1] +real, parameter :: BET211 = 1.5*EOS311*r1_S0 ! drho_dS fit zs**2 * T * P coef. [kg m-3 ppt-1 degC-1 Pa-1] +real, parameter :: BET021 = 0.5*EOS121*r1_S0 ! drho_dS fit T**2 * P coef. [kg m-3 ppt-1 degC-2 Pa-1] +real, parameter :: BET121 = EOS221*r1_S0 ! drho_dS fit zs * T**2 * P coef. [kg m-3 ppt-1 degC-2 Pa-1] +real, parameter :: BET031 = 0.5*EOS131*r1_S0 ! drho_dS fit T**3 * P coef. [kg m-3 ppt-1 degC-3 Pa-1] +real, parameter :: BET002 = 0.5*EOS102*r1_S0 ! drho_dS fit P**2 coef. [kg m-3 ppt-1 Pa-2] +real, parameter :: BET102 = EOS202*r1_S0 ! drho_dS fit zs * P**2 coef. [kg m-3 ppt-1 Pa-2] +real, parameter :: BET012 = 0.5*EOS112*r1_S0 ! drho_dS fit T * P**2 coef. [kg m-3 ppt-1 degC-1 Pa-2] +real, parameter :: BET003 = 0.5*EOS103*r1_S0 ! drho_dS fit P**3 coef. [kg m-3 ppt-1 Pa-3] +!>@} + +!> The EOS_base implementation of the Roquet et al., 2015, equation of state +type, extends (EOS_base) :: Roquet_rho_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Roquet_rho + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Roquet_rho + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Roquet_rho + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Roquet_rho + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Roquet_rho + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Roquet_rho + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Roquet_rho + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Roquet_rho + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Roquet_rho + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_Roquet_rho + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_Roquet_rho + +end type Roquet_rho_EOS + +contains + +!> In situ density of sea water from Roquet et al., 2015 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Roquet_rho(this, T, S, pressure) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: rho00p ! A pressure-dependent but temperature and salinity independent contribution to + ! density at the reference temperature and salinity [kg m-3] + real :: rhoTS ! Density without a pressure-dependent contribution [kg m-3] + real :: rhoTS0 ! A contribution to density from temperature and salinity anomalies at the + ! surface pressure [kg m-3] + real :: rhoTS1 ! A density contribution proportional to pressure [kg m-3 Pa-1] + real :: rhoTS2 ! A density contribution proportional to pressure**2 [kg m-3 Pa-2] + real :: rhoTS3 ! A density contribution proportional to pressure**3 [kg m-3 Pa-3] + real :: rho0S0 ! Salinity dependent density at the surface pressure and zero temperature [kg m-3] + + ! The following algorithm was published by Roquet et al. (2015), intended for use with NEMO. + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + rhoTS3 = EOS003 + (zs*EOS103 + zt*EOS013) + rhoTS2 = EOS002 + (zs*(EOS102 + zs*EOS202) & + + zt*(EOS012 + (zs*EOS112 + zt*EOS022)) ) + rhoTS1 = EOS001 + (zs*(EOS101 + zs*(EOS201 + zs*(EOS301 + zs*EOS401))) & + + zt*(EOS011 + (zs*(EOS111 + zs*(EOS211 + zs*EOS311)) & + + zt*(EOS021 + (zs*(EOS121 + zs*EOS221) & + + zt*(EOS031 + (zs*EOS131 + zt*EOS041)) )) )) ) + rhoTS0 = zt*(EOS010 & + + (zs*(EOS110 + zs*(EOS210 + zs*(EOS310 + zs*(EOS410 + zs*EOS510)))) & + + zt*(EOS020 + (zs*(EOS120 + zs*(EOS220 + zs*(EOS320 + zs*EOS420))) & + + zt*(EOS030 + (zs*(EOS130 + zs*(EOS230 + zs*EOS330)) & + + zt*(EOS040 + (zs*(EOS140 + zs*EOS240) & + + zt*(EOS050 + (zs*EOS150 + zt*EOS060)) )) )) )) ) ) + + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) + + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) + + rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) + density_elem_Roquet_rho = rhoTS + rho00p ! In situ density [kg m-3] + +end function density_elem_Roquet_rho + +!> In situ density anomaly of sea water from Roquet et al., 2015 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Roquet_rho(this, T, S, pressure, rho_ref) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: rho00p ! A pressure-dependent but temperature and salinity independent contribution to + ! density at the reference temperature and salinity [kg m-3] + real :: rhoTS ! Density without a pressure-dependent contribution [kg m-3] + real :: rhoTS0 ! A contribution to density from temperature and salinity anomalies at the + ! surface pressure [kg m-3] + real :: rhoTS1 ! A density contribution proportional to pressure [kg m-3 Pa-1] + real :: rhoTS2 ! A density contribution proportional to pressure**2 [kg m-3 Pa-2] + real :: rhoTS3 ! A density contribution proportional to pressure**3 [kg m-3 Pa-3] + real :: rho0S0 ! Salinity dependent density at the surface pressure and zero temperature [kg m-3] + + ! The following algorithm was published by Roquet et al. (2015), intended for use with NEMO. + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + rhoTS3 = EOS003 + (zs*EOS103 + zt*EOS013) + rhoTS2 = EOS002 + (zs*(EOS102 + zs*EOS202) & + + zt*(EOS012 + (zs*EOS112 + zt*EOS022)) ) + rhoTS1 = EOS001 + (zs*(EOS101 + zs*(EOS201 + zs*(EOS301 + zs*EOS401))) & + + zt*(EOS011 + (zs*(EOS111 + zs*(EOS211 + zs*EOS311)) & + + zt*(EOS021 + (zs*(EOS121 + zs*EOS221) & + + zt*(EOS031 + (zs*EOS131 + zt*EOS041)) )) )) ) + rhoTS0 = zt*(EOS010 & + + (zs*(EOS110 + zs*(EOS210 + zs*(EOS310 + zs*(EOS410 + zs*EOS510)))) & + + zt*(EOS020 + (zs*(EOS120 + zs*(EOS220 + zs*(EOS320 + zs*EOS420))) & + + zt*(EOS030 + (zs*(EOS130 + zs*(EOS230 + zs*EOS330)) & + + zt*(EOS040 + (zs*(EOS140 + zs*EOS240) & + + zt*(EOS050 + (zs*EOS150 + zt*EOS060)) )) )) )) ) ) + + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) + + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) + + rho0S0 = rho0S0 - rho_ref + + rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) + density_anomaly_elem_Roquet_rho = rhoTS + rho00p ! In situ density [kg m-3] + +end function density_anomaly_elem_Roquet_rho + +!> In situ specific volume of sea water from Roquet et al., 2015 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Roquet_rho(this, T, S, pressure) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + + spec_vol_elem_Roquet_rho = 1. / density_elem_Roquet_rho(this, T, S, pressure) + +end function spec_vol_elem_Roquet_rho + +!> In situ specific volume anomaly of sea water from Roquet et al., 2015 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Roquet_rho(this, T, S, pressure, spv_ref) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + spec_vol_anomaly_elem_Roquet_rho = 1. / density_elem_Roquet_rho(this, T, S, pressure) + spec_vol_anomaly_elem_Roquet_rho = spec_vol_anomaly_elem_Roquet_rho - spv_ref + +end function spec_vol_anomaly_elem_Roquet_rho + +!> For a given thermodynamic state, calculate the derivatives of density with conservative +!! temperature and absolute salinity, using the density polynomial fit EOS from Roquet et al. (2015). +elemental subroutine calculate_density_derivs_elem_Roquet_rho(this, T, S, pressure, drho_dT, drho_dS) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 ppt-1] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: dRdzt0 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] + ! from temperature anomalies at the surface pressure + real :: dRdzt1 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1 Pa-1] + ! proportional to pressure + real :: dRdzt2 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1 Pa-2] + ! proportional to pressure**2 + real :: dRdzt3 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1 Pa-3] + ! proportional to pressure**3 + real :: dRdzs0 ! A contribution to the partial derivative of density with + ! salinity [kg m-3 ppt-1] from temperature anomalies at the surface pressure + real :: dRdzs1 ! A contribution to the partial derivative of density with + ! salinity [kg m-3 ppt-1 Pa-1] proportional to pressure + real :: dRdzs2 ! A contribution to the partial derivative of density with + ! salinity [kg m-3 ppt-1 Pa-2] proportional to pressure**2 + real :: dRdzs3 ! A contribution to the partial derivative of density with + ! salinity [kg m-3 ppt-1 Pa-3] proportional to pressure**3 + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + ! Find the partial derivative of density with temperature + dRdzt3 = ALP003 + dRdzt2 = ALP002 + (zs*ALP102 + zt*ALP012) + dRdzt1 = ALP001 + (zs*(ALP101 + zs*(ALP201 + zs*ALP301)) & + + zt*(ALP011 + (zs*(ALP111 + zs*ALP211) & + + zt*(ALP021 + (zs*ALP121 + zt*ALP031)) )) ) + dRdzt0 = ALP000 + (zs*(ALP100 + zs*(ALP200 + zs*(ALP300 + zs*(ALP400 + zs*ALP500)))) & + + zt*(ALP010 + (zs*(ALP110 + zs*(ALP210 + zs*(ALP310 + zs*ALP410))) & + + zt*(ALP020 + (zs*(ALP120 + zs*(ALP220 + zs*ALP320)) & + + zt*(ALP030 + (zt*(ALP040 + (zs*ALP140 + zt*ALP050)) & + + zs*(ALP130 + zs*ALP230) )) )) )) ) + + drho_dT = dRdzt0 + zp*(dRdzt1 + zp*(dRdzt2 + zp*dRdzt3)) + + ! Find the partial derivative of density with salinity + dRdzs3 = BET003 + dRdzs2 = BET002 + (zs*BET102 + zt*BET012) + dRdzs1 = BET001 + (zs*(BET101 + zs*(BET201 + zs*BET301)) & + + zt*(BET011 + (zs*(BET111 + zs*BET211) & + + zt*(BET021 + (zs*BET121 + zt*BET031)) )) ) + dRdzs0 = BET000 + (zs*(BET100 + zs*(BET200 + zs*(BET300 + zs*(BET400 + zs*BET500)))) & + + zt*(BET010 + (zs*(BET110 + zs*(BET210 + zs*(BET310 + zs*BET410))) & + + zt*(BET020 + (zs*(BET120 + zs*(BET220 + zs*BET320)) & + + zt*(BET030 + (zt*(BET040 + (zs*BET140 + zt*BET050)) & + + zs*(BET130 + zs*BET230) )) )) )) ) + + ! The division by zs here is because zs = sqrt(S + S0), so drho_dS = dzs_dS * drho_dzs = (0.5 / zs) * drho_dzs + drho_dS = (dRdzs0 + zp*(dRdzs1 + zp*(dRdzs2 + zp * dRdzs3))) / zs + +end subroutine calculate_density_derivs_elem_Roquet_rho + +!> Second derivatives of density with respect to temperature, salinity, and pressure +elemental subroutine calculate_density_second_derivs_elem_Roquet_rho(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 ppt-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 ppt-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: I_s ! The inverse of zs [nondim] + real :: d2R_p0 ! A contribution to one of the second derivatives that is independent of pressure [various] + real :: d2R_p1 ! A contribution to one of the second derivatives that is proportional to pressure [various] + real :: d2R_p2 ! A contribution to one of the second derivatives that is proportional to pressure**2 [various] + real :: d2R_p3 ! A contribution to one of the second derivatives that is proportional to pressure**3 [various] + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + I_s = 1.0 / zs + + ! Find drho_ds_ds + d2R_p3 = -EOS103*I_s**2 + d2R_p2 = -(EOS102 + zt*EOS112)*I_s**2 + d2R_p1 = (3.*EOS301 + (zt*(3.*EOS311) + zs*(8.*EOS401))) & + - ( EOS101 + zt*(EOS111 + zt*(EOS121 + zt*EOS131)) )*I_s**2 + d2R_p0 = (3.*EOS300 + (zs*(8.*EOS400 + zs*(15.*EOS500 + zs*(24.*EOS600))) & + + zt*(3.*EOS310 + (zs*(8.*EOS410 + zs*(15.*EOS510)) & + + zt*(3.*EOS320 + (zs*(8.*EOS420) + zt*(3.*EOS330))) )) )) & + - (EOS100 + zt*(EOS110 + zt*(EOS120 + zt*(EOS130 + zt*(EOS140 + zt*EOS150)))) )*I_s**2 + drho_dS_dS = (0.5*r1_S0)**2 * ((d2R_p0 + zp*(d2R_p1 + zp*(d2R_p2 + zp*d2R_p3))) * I_s) + + ! Find drho_ds_dt + d2R_p2 = EOS112 + d2R_p1 = EOS111 + (zs*(2.*EOS211 + zs*(3.*EOS311)) & + + zt*(2.*EOS121 + (zs*(4.*EOS221) + zt*(3.*EOS131))) ) + d2R_p0 = EOS110 + (zs*(2.*EOS210 + zs*(3.*EOS310 + zs*(4.*EOS410 + zs*(5.*EOS510)))) & + + zt*(2.*EOS120 + (zs*(4.*EOS220 + zs*(6.*EOS320 + zs*(8.*EOS420))) & + + zt*(3.*EOS130 + (zs*(6.*EOS230 + zs*(9.*EOS330)) & + + zt*(4.*EOS140 + (zs*(8.*EOS240) & + + zt*(5.*EOS150))) )) )) ) + drho_ds_dt = (0.5*r1_S0) * ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) + + ! Find drho_dt_dt + d2R_p2 = 2.*EOS022 + d2R_p1 = 2.*EOS021 + (zs*(2.*EOS121 + zs*(2.*EOS221)) & + + zt*(6.*EOS031 + (zs*(6.*EOS131) + zt*(12.*EOS041))) ) + d2R_p0 = 2.*EOS020 + (zs*(2.*EOS120 + zs*( 2.*EOS220 + zs*( 2.*EOS320 + zs * (2.*EOS420)))) & + + zt*(6.*EOS030 + (zs*( 6.*EOS130 + zs*( 6.*EOS230 + zs * (6.*EOS330))) & + + zt*(12.*EOS040 + (zs*(12.*EOS140 + zs *(12.*EOS240)) & + + zt*(20.*EOS050 + (zs*(20.*EOS150) & + + zt*(30.*EOS060) )) )) )) ) + drho_dt_dt = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) + + ! Find drho_ds_dp + d2R_p2 = 3.*EOS103 + d2R_p1 = 2.*EOS102 + (zs*(4.*EOS202) + zt*(2.*EOS112)) + d2R_p0 = EOS101 + (zs*(2.*EOS201 + zs*(3.*EOS301 + zs*(4.*EOS401))) & + + zt*(EOS111 + (zs*(2.*EOS211 + zs*(3.*EOS311)) & + + zt*( EOS121 + (zs*(2.*EOS221) + zt*EOS131)) )) ) + drho_ds_dp = ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) * (0.5*r1_S0) + + ! Find drho_dt_dp + d2R_p2 = 3.*EOS013 + d2R_p1 = 2.*EOS012 + (zs*(2.*EOS112) + zt*(4.*EOS022)) + d2R_p0 = EOS011 + (zs*(EOS111 + zs*( EOS211 + zs* EOS311)) & + + zt*(2.*EOS021 + (zs*(2.*EOS121 + zs*(2.*EOS221)) & + + zt*(3.*EOS031 + (zs*(3.*EOS131) + zt*(4.*EOS041))) )) ) + drho_dt_dp = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) + +end subroutine calculate_density_second_derivs_elem_Roquet_rho + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the density polynomial fit EOS from Roquet et al. (2015). +elemental subroutine calculate_specvol_derivs_elem_Roquet_rho(this, T, S, pressure, dSV_dT, dSV_dS) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 ppt-1] + ! Local variables + real :: rho ! In situ density [kg m-3] + real :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] + real :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] + + call this%calculate_density_derivs_elem(T, S, pressure, drho_dT, drho_dS) + rho = this%density_elem(T, S, pressure) + dSV_dT = -dRho_DT/(rho**2) + dSV_dS = -dRho_DS/(rho**2) + +end subroutine calculate_specvol_derivs_elem_Roquet_rho + +!> Compute the in situ density of sea water (rho in [kg m-3]) and the compressibility +!! (drho/dp = C_sound^-2, stored as drho_dp [s2 m-2]) from absolute salinity (sal [g kg-1]), +!! conservative temperature (T [degC]), and pressure [Pa], using the density polynomial +!! fit EOS from Roquet et al. (2015). +elemental subroutine calculate_compress_elem_Roquet_rho(this, T, S, pressure, rho, drho_dp) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: drho00p_dp ! Derivative of the pressure-dependent reference density profile with pressure [kg m-3 Pa-1] + real :: drhoTS_dp ! Derivative of the density anomaly from the reference profile with pressure [kg m-3 Pa-1] + real :: rho00p ! The pressure-dependent (but temperature and salinity independent) reference + ! density profile [kg m-3] + real :: rhoTS ! Density anomaly from the reference profile [kg m-3] + real :: rhoTS0 ! A contribution to density from temperature and salinity anomalies at the + ! surface pressure [kg m-3] + real :: rhoTS1 ! A density contribution proportional to pressure [kg m-3 Pa-1] + real :: rhoTS2 ! A density contribution proportional to pressure**2 [kg m-3 Pa-2] + real :: rhoTS3 ! A density contribution proportional to pressure**3 [kg m-3 Pa-3] + real :: rho0S0 ! Salinity dependent density at the surface pressure and zero temperature [kg m-3] + + ! The following algorithm was published by Roquet et al. (2015), intended for use with NEMO. + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + rhoTS3 = EOS003 + (zs*EOS103 + zt*EOS013) + rhoTS2 = EOS002 + (zs*(EOS102 + zs*EOS202) & + + zt*(EOS012 + (zs*EOS112 + zt*EOS022)) ) + rhoTS1 = EOS001 + (zs*(EOS101 + zs*(EOS201 + zs*(EOS301 + zs*EOS401))) & + + zt*(EOS011 + (zs*(EOS111 + zs*(EOS211 + zs*EOS311)) & + + zt*(EOS021 + (zs*(EOS121 + zs*EOS221) & + + zt*(EOS031 + (zs*EOS131 + zt*EOS041)) )) )) ) + + rhoTS0 = zt*(EOS010 & + + (zs*(EOS110 + zs*(EOS210 + zs*(EOS310 + zs*(EOS410 + zs*EOS510)))) & + + zt*(EOS020 + (zs*(EOS120 + zs*(EOS220 + zs*(EOS320 + zs*EOS420))) & + + zt*(EOS030 + (zs*(EOS130 + zs*(EOS230 + zs*EOS330)) & + + zt*(EOS040 + (zs*(EOS140 + zs*EOS240) & + + zt*(EOS050 + (zs*EOS150 + zt*EOS060)) )) )) )) ) ) + + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) + + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) + + rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) + rho = rhoTS + rho00p ! In situ density [kg m-3] + + drho00p_dp = R00 + zp*(2.*R01 + zp*(3.*R02 + zp*(4.*R03 + zp*(5.*R04 + zp*(6.*R05))))) + drhoTS_dp = rhoTS1 + zp*(2.*rhoTS2 + zp*(3.*rhoTS3)) + drho_dp = drhoTS_dp + drho00p_dp ! Compressibility [s2 m-2] + +end subroutine calculate_compress_elem_Roquet_rho + +!> Return the range of temperatures, salinities and pressures for which the Roquet et al. (2015) +!! expression for in situ density has been fitted to observations. Care should be taken when +!! applying this equation of state outside of its fit range. +subroutine EoS_fit_range_Roquet_rho(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: S_max !< The maximum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -6.0 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_Roquet_rho + +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_Roquet_rho(this, T, S, pressure, rho, start, npts, rho_ref) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_Roquet_rho(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_Roquet_rho(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_Roquet_rho + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_Roquet_rho(this, T, S, pressure, specvol, start, npts, spv_ref) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_Roquet_rho(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_Roquet_rho(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_Roquet_rho + +!> \namespace mom_eos_Roquet_rho +!! +!! \section section_EOS_Roquet_rho Roquet_rho equation of state +!! +!! Fabien Roquet and colleagues developed this equation of state using a simple polynomial fit +!! to the TEOS-10 equation of state, for efficiency when used in the NEMO ocean model. Fabien +!! Roquet also graciously provided the MOM6 team with the original code implementing this +!! equation of state, although it has since been modified and extended to have capabilities +!! mirroring those available with other equations of state in MOM6. This particular equation +!! of state is a balance between an accuracy that matches the TEOS-10 density to better than +!! observational uncertainty with a polynomial form that can be evaluated quickly despite having +!! 52 terms. +!! +!! \subsection section_EOS_Roquet_rho_references References +!! +!! Roquet, F., Madec, G., McDougall, T. J., and Barker, P. M., 2015: +!! Accurate polynomial expressions for the density and specific volume +!! of seawater using the TEOS-10 standard. Ocean Modelling, 90:29-43. + +end module MOM_EOS_Roquet_rho diff --git a/equation_of_state/MOM_EOS_TEOS10.F90 b/equation_of_state/MOM_EOS_TEOS10.F90 new file mode 100644 index 0000000000..3f138e20bb --- /dev/null +++ b/equation_of_state/MOM_EOS_TEOS10.F90 @@ -0,0 +1,278 @@ +!> The equation of state using the TEOS10 expressions +module MOM_EOS_TEOS10 + +! This file is part of MOM6. See LICENSE.md for the license. + +use gsw_mod_toolbox, only : gsw_sp_from_sr, gsw_pt_from_ct +use gsw_mod_toolbox, only : gsw_rho, gsw_specvol +use gsw_mod_toolbox, only : gsw_rho_first_derivatives, gsw_specvol_first_derivatives +use gsw_mod_toolbox, only : gsw_rho_second_derivatives +use MOM_EOS_base_type, only : EOS_base + +implicit none ; private + +public gsw_sp_from_sr, gsw_pt_from_ct +public TEOS10_EOS + +real, parameter :: Pa2db = 1.e-4 !< The conversion factor from Pa to dbar [dbar Pa-1] + +!> The EOS_base implementation of the TEOS10 equation of state +type, extends (EOS_base) :: TEOS10_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_TEOS10 + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_TEOS10 + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_TEOS10 + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_TEOS10 + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_TEOS10 + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_TEOS10 + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_TEOS10 + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_TEOS10 + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_TEOS10 + +end type TEOS10_EOS + +contains + +!> GSW in situ density [kg m-3] +real elemental function density_elem_TEOS10(this, T, S, pressure) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pressure !< pressure [Pa]. + + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA +! if (S < -1.0e-10) then ! Can we assume safely that this is a missing value? +! density_elem_TEOS10 = 1000.0 +! else +! density_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) +! endif + + density_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) + +end function density_elem_TEOS10 + +!> GSW in situ density anomaly [kg m-3] +real elemental function density_anomaly_elem_TEOS10(this, T, S, pressure, rho_ref) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(in) :: rho_ref !< A reference density [kg m-3]. + + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA +! if (S < -1.0e-10) then ! Can we assume safely that this is a missing value? +! density_elem_TEOS10 = 1000.0 +! else +! density_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) +! endif + + density_anomaly_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) + density_anomaly_elem_TEOS10 = density_anomaly_elem_TEOS10 - rho_ref + +end function density_anomaly_elem_TEOS10 + +!> GSW in situ specific volume [m3 kg-1] +real elemental function spec_vol_elem_TEOS10(this, T, S, pressure) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pressure !< pressure [Pa]. + + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA +! if (S < -1.0e-10) then ! Can we assume safely that this is a missing value? +! spec_vol_elem_TEOS10 = 0.001 +! else +! spec_vol_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) +! endif + + spec_vol_elem_TEOS10 = gsw_specvol(S, T, pressure * Pa2db) + +end function spec_vol_elem_TEOS10 + +!> GSW in situ specific volume anomaly [m3 kg-1] +real elemental function spec_vol_anomaly_elem_TEOS10(this, T, S, pressure, spv_ref) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA +! if (S < -1.0e-10) then ! Can we assume safely that this is a missing value? +! spec_vol_elem_TEOS10 = 0.001 +! else +! spec_vol_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) +! endif + + spec_vol_anomaly_elem_TEOS10 = gsw_specvol(S, T, pressure * Pa2db) - spv_ref + +end function spec_vol_anomaly_elem_TEOS10 + +!> For a given thermodynamic state, calculate the derivatives of density with conservative +!! temperature and absolute salinity, using the TEOS10 expressions. +elemental subroutine calculate_density_derivs_elem_TEOS10(this, T, S, pressure, drho_dT, drho_dS) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + ! Local variables + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] + + !Conversions + zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity + zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp + zp = pressure* Pa2db !Convert pressure from Pascal to decibar + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA + !if (S < -1.0e-10) then !Can we assume safely that this is a missing value? + ! drho_dT = 0.0 ; drho_dS = 0.0 + !else + call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS, drho_dct=drho_dT) + !endif + +end subroutine calculate_density_derivs_elem_TEOS10 + +!> Calculate the 5 second derivatives of the equation of state for scalar inputs +elemental subroutine calculate_density_second_derivs_elem_TEOS10(this, T, S, pressure, & + drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + ! Local variables + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] + + !Conversions + zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity + zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp + zp = pressure* Pa2db !Convert pressure from Pascal to decibar + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA + !if (S < -1.0e-10) then !Can we assume safely that this is a missing value? + ! drho_dS_dS = 0.0 ; drho_dS_dT = 0.0 ; drho_dT_dT = 0.0 + ! drho_dS_dP = 0.0 ; drho_dT_dP = 0.0 + !else + call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS, rho_sa_ct=drho_dS_dT, & + rho_ct_ct=drho_dT_dT, rho_sa_p=drho_dS_dP, rho_ct_p=drho_dT_dP) + !endif + +end subroutine calculate_density_second_derivs_elem_TEOS10 + +!> For a given thermodynamic state, calculate the derivatives of specific volume with conservative +!! temperature and absolute salinity, using the TEOS10 expressions. +elemental subroutine calculate_specvol_derivs_elem_TEOS10(this, T, S, pressure, dSV_dT, dSV_dS) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + ! Local variables + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] + + !Conversions + zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity + zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp + zp = pressure* Pa2db !Convert pressure from Pascal to decibar + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA + !if (S < -1.0e-10) then !Can we assume safely that this is a missing value? + ! dSV_dT = 0.0 ; dSV_dS = 0.0 + !else + call gsw_specvol_first_derivatives(zs,zt,zp, v_sa=dSV_dS, v_ct=dSV_dT) + !endif + +end subroutine calculate_specvol_derivs_elem_TEOS10 + +!> This subroutine computes the in situ density of sea water (rho in +!! [kg m-3]) and the compressibility (drho/dp = C_sound^-2) +!! (drho_dp [s2 m-2]) from absolute salinity (sal [g kg-1]), +!! conservative temperature (T [degC]), and pressure [Pa]. It uses the +!! subroutines from TEOS10 website +elemental subroutine calculate_compress_elem_TEOS10(this, T, S, pressure, rho, drho_dp) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] + + ! Local variables + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] + + !Conversions + zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity + zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp + zp = pressure* Pa2db !Convert pressure from Pascal to decibar + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA + !if (S < -1.0e-10) then !Can we assume safely that this is a missing value? + ! rho = 1000.0 ; drho_dp = 0.0 + !else + rho = gsw_rho(zs,zt,zp) + call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp) + !endif + +end subroutine calculate_compress_elem_TEOS10 + +!> Return the range of temperatures, salinities and pressures for which the TEOS-10 +!! equation of state has been fitted to observations. Care should be taken when +!! applying this equation of state outside of its fit range. +subroutine EoS_fit_range_teos10(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: S_max !< The maximum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -6.0 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_teos10 + +!> \namespace mom_eos_teos10 +!! +!! \section section_EOS_TEOS10 TEOS10 equation of state +!! +!! The TEOS10 equation of state is implemented via the GSW toolbox. We recommend using the +!! Roquet et al. forms of this equation of state. + +end module MOM_EOS_TEOS10 diff --git a/equation_of_state/MOM_EOS_UNESCO.F90 b/equation_of_state/MOM_EOS_UNESCO.F90 new file mode 100644 index 0000000000..6051c0fb0a --- /dev/null +++ b/equation_of_state/MOM_EOS_UNESCO.F90 @@ -0,0 +1,584 @@ +!> The equation of state using the Jackett and McDougall fits to the UNESCO EOS +module MOM_EOS_UNESCO + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS_base_type, only : EOS_base + +implicit none ; private + +public UNESCO_EOS + +!>@{ Parameters in the UNESCO equation of state, as published in appendix A3 of Gill, 1982. +! The following constants are used to calculate rho0, the density of seawater at 1 atmosphere pressure. +! The notation is Rab for the contribution to rho0 from S^a*T^b, with 6 used for the 1.5 power. +real, parameter :: R00 = 999.842594 ! A coefficient in the fit for rho0 [kg m-3] +real, parameter :: R01 = 6.793952e-2 ! A coefficient in the fit for rho0 [kg m-3 degC-1] +real, parameter :: R02 = -9.095290e-3 ! A coefficient in the fit for rho0 [kg m-3 degC-2] +real, parameter :: R03 = 1.001685e-4 ! A coefficient in the fit for rho0 [kg m-3 degC-3] +real, parameter :: R04 = -1.120083e-6 ! A coefficient in the fit for rho0 [kg m-3 degC-4] +real, parameter :: R05 = 6.536332e-9 ! A coefficient in the fit for rho0 [kg m-3 degC-5] +real, parameter :: R10 = 0.824493 ! A coefficient in the fit for rho0 [kg m-3 PSU-1] +real, parameter :: R11 = -4.0899e-3 ! A coefficient in the fit for rho0 [kg m-3 degC-1 PSU-1] +real, parameter :: R12 = 7.6438e-5 ! A coefficient in the fit for rho0 [kg m-3 degC-2 PSU-1] +real, parameter :: R13 = -8.2467e-7 ! A coefficient in the fit for rho0 [kg m-3 degC-3 PSU-1] +real, parameter :: R14 = 5.3875e-9 ! A coefficient in the fit for rho0 [kg m-3 degC-4 PSU-1] +real, parameter :: R60 = -5.72466e-3 ! A coefficient in the fit for rho0 [kg m-3 PSU-1.5] +real, parameter :: R61 = 1.0227e-4 ! A coefficient in the fit for rho0 [kg m-3 degC-1 PSU-1.5] +real, parameter :: R62 = -1.6546e-6 ! A coefficient in the fit for rho0 [kg m-3 degC-2 PSU-1.5] +real, parameter :: R20 = 4.8314e-4 ! A coefficient in the fit for rho0 [kg m-3 PSU-2] + +! The following constants are used to calculate the secant bulk modulus. +! The notation here is Sabc for terms proportional to S^a*T^b*P^c, with 6 used for the 1.5 power. +! Note that these values differ from those in Appendix 3 of Gill (1982) because the expressions +! from Jackett and MacDougall (1995) use potential temperature, rather than in situ temperature. +real, parameter :: S000 = 1.965933e4 ! A coefficient in the secant bulk modulus fit [bar] +real, parameter :: S010 = 1.444304e2 ! A coefficient in the secant bulk modulus fit [bar degC-1] +real, parameter :: S020 = -1.706103 ! A coefficient in the secant bulk modulus fit [bar degC-2] +real, parameter :: S030 = 9.648704e-3 ! A coefficient in the secant bulk modulus fit [bar degC-3] +real, parameter :: S040 = -4.190253e-5 ! A coefficient in the secant bulk modulus fit [bar degC-4] +real, parameter :: S100 = 52.84855 ! A coefficient in the secant bulk modulus fit [bar PSU-1] +real, parameter :: S110 = -3.101089e-1 ! A coefficient in the secant bulk modulus fit [bar degC-1 PSU-1] +real, parameter :: S120 = 6.283263e-3 ! A coefficient in the secant bulk modulus fit [bar degC-2 PSU-1] +real, parameter :: S130 = -5.084188e-5 ! A coefficient in the secant bulk modulus fit [bar degC-3 PSU-1] +real, parameter :: S600 = 3.886640e-1 ! A coefficient in the secant bulk modulus fit [bar PSU-1.5] +real, parameter :: S610 = 9.085835e-3 ! A coefficient in the secant bulk modulus fit [bar degC-1 PSU-1.5] +real, parameter :: S620 = -4.619924e-4 ! A coefficient in the secant bulk modulus fit [bar degC-2 PSU-1.5] + +real, parameter :: S001 = 3.186519 ! A coefficient in the secant bulk modulus fit [nondim] +real, parameter :: S011 = 2.212276e-2 ! A coefficient in the secant bulk modulus fit [degC-1] +real, parameter :: S021 = -2.984642e-4 ! A coefficient in the secant bulk modulus fit [degC-2] +real, parameter :: S031 = 1.956415e-6 ! A coefficient in the secant bulk modulus fit [degC-3] +real, parameter :: S101 = 6.704388e-3 ! A coefficient in the secant bulk modulus fit [PSU-1] +real, parameter :: S111 = -1.847318e-4 ! A coefficient in the secant bulk modulus fit [degC-1 PSU-1] +real, parameter :: S121 = 2.059331e-7 ! A coefficient in the secant bulk modulus fit [degC-2 PSU-1] +real, parameter :: S601 = 1.480266e-4 ! A coefficient in the secant bulk modulus fit [PSU-1.5] + +real, parameter :: S002 = 2.102898e-4 ! A coefficient in the secant bulk modulus fit [bar-1] +real, parameter :: S012 = -1.202016e-5 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1] +real, parameter :: S022 = 1.394680e-7 ! A coefficient in the secant bulk modulus fit [bar-1 degC-2] +real, parameter :: S102 = -2.040237e-6 ! A coefficient in the secant bulk modulus fit [bar-1 PSU-1] +real, parameter :: S112 = 6.128773e-8 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1 PSU-1] +real, parameter :: S122 = 6.207323e-10 ! A coefficient in the secant bulk modulus fit [bar-1 degC-2 PSU-1] +!>@} + +!> The EOS_base implementation of the UNESCO equation of state +type, extends (EOS_base) :: UNESCO_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_UNESCO + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_UNESCO + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_UNESCO + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_UNESCO + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_UNESCO + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_UNESCO + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_UNESCO + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_UNESCO + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_UNESCO + +end type UNESCO_EOS + +contains + +!> In situ density as fit by Jackett and McDougall, 1995 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_UNESCO(this, T, S, pressure) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: sig0 ! The anomaly of rho0 from R00 [kg m-3] + real :: ks ! The secant bulk modulus [bar] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). + sig0 = ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + rho0 = R00 + sig0 + + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. + ks = (S000 + ( t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + + density_elem_UNESCO = rho0*ks / (ks - p1) + +end function density_elem_UNESCO + +!> In situ density anomaly as fit by Jackett and McDougall, 1995 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_UNESCO(this, T, S, pressure, rho_ref) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: sig0 ! The anomaly of rho0 from R00 [kg m-3] + real :: ks ! The secant bulk modulus [bar] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). + sig0 = ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + rho0 = R00 + sig0 + + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. + ks = (S000 + ( t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + + density_anomaly_elem_UNESCO = ((R00 - rho_ref)*ks + (sig0*ks + p1*rho_ref)) / (ks - p1) + +end function density_anomaly_elem_UNESCO + +!> In situ specific volume as fit by Jackett and McDougall, 1995 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_UNESCO(this, T, S, pressure) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2]l553 + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. + ks = (S000 + ( t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + + spec_vol_elem_UNESCO = (ks - p1) / (rho0*ks) + +end function spec_vol_elem_UNESCO + +!> In situ specific volume anomaly as fit by Jackett and McDougall, 1995 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_UNESCO(this, T, S, pressure, spv_ref) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. + ks = (S000 + ( t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + + spec_vol_anomaly_elem_UNESCO = (ks*(1.0 - (rho0*spv_ref)) - p1) / (rho0*ks) + +end function spec_vol_anomaly_elem_UNESCO + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). +elemental subroutine calculate_density_derivs_elem_UNESCO(this, T, S, pressure, drho_dT, drho_dS) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + real :: drho0_dT ! Derivative of rho0 with T [kg m-3 degC-1] + real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1] + real :: dks_dT ! Derivative of ks with T [bar degC-1] + real :: dks_dS ! Derivative of ks with S [bar psu-1] + real :: I_denom ! 1.0 / (ks - p1) [bar-1] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0) and its derivatives with temperature and salinity + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + drho0_dT = R01 + ( t1*(2.0*R02 + t1*(3.0*R03 + t1*(4.0*R04 + t1*(5.0*R05)))) + & + s1*(R11 + (t1*(2.0*R12 + t1*(3.0*R13 + t1*(4.0*R14))) + & + s12*(R61 + t1*(2.0*R62)) )) ) + drho0_dS = R10 + ( t1*(R11 + t1*(R12 + t1*(R13 + t1*R14))) + & + (1.5*(s12*(R60 + t1*(R61 + t1*R62))) + s1*(2.0*R20)) ) + + ! Compute the secant bulk modulus and its derivatives with temperature and salinity + ks = ( S000 + (t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620)))) ) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + dks_dT = ( S010 + (t1*(2.0*S020 + t1*(3.0*S030 + t1*(4.0*S040))) + & + s1*((S110 + t1*(2.0*S120 + t1*(3.0*S130))) + s12*(S610 + t1*(2.0*S620)))) ) + & + p1*(((S011 + t1*(2.0*S021 + t1*(3.0*S031))) + s1*(S111 + t1*(2.0*S121)) ) + & + p1*(S012 + t1*(2.0*S022) + s1*(S112 + t1*(2.0*S122))) ) + dks_dS = ( S100 + (t1*(S110 + t1*(S120 + t1*S130)) + 1.5*(s12*(S600 + t1*(S610 + t1*S620)))) ) + & + p1*((S101 + t1*(S111 + t1*S121) + s12*(1.5*S601)) + & + p1*(S102 + t1*(S112 + t1*S122)) ) + + I_denom = 1.0 / (ks - p1) + drho_dT = (ks*drho0_dT - dks_dT*((rho0*p1)*I_denom)) * I_denom + drho_dS = (ks*drho0_dS - dks_dS*((rho0*p1)*I_denom)) * I_denom + +end subroutine calculate_density_derivs_elem_UNESCO + +!> Calculate second derivatives of density with respect to temperature, salinity, and pressure, +!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995) +elemental subroutine calculate_density_second_derivs_elem_UNESCO(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: I_s12 ! The inverse of the square root of salinity [PSU-1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: drho0_dT ! Derivative of rho0 with T [kg m-3 degC-1] + real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1] + real :: d2rho0_dS2 ! Second derivative of rho0 with salinity [kg m-3 PSU-1] + real :: d2rho0_dSdT ! Second derivative of rho0 with temperature and salinity [kg m-3 degC-1 PSU-1] + real :: d2rho0_dT2 ! Second derivative of rho0 with temperature [kg m-3 degC-2] + real :: ks ! The secant bulk modulus [bar] + real :: ks_0 ! The secant bulk modulus at zero pressure [bar] + real :: ks_1 ! The linear pressure dependence of the secant bulk modulus at zero pressure [nondim] + real :: ks_2 ! The quadratic pressure dependence of the secant bulk modulus at zero pressure [bar-1] + real :: dks_dp ! The derivative of the secant bulk modulus with pressure [nondim] + real :: dks_dT ! Derivative of the secant bulk modulus with temperature [bar degC-1] + real :: dks_dS ! Derivative of the secant bulk modulus with salinity [bar psu-1] + real :: d2ks_dT2 ! Second derivative of the secant bulk modulus with temperature [bar degC-2] + real :: d2ks_dSdT ! Second derivative of the secant bulk modulus with salinity and temperature [bar psu-1 degC-1] + real :: d2ks_dS2 ! Second derivative of the secant bulk modulus with salinity [bar psu-2] + real :: d2ks_dSdp ! Second derivative of the secant bulk modulus with salinity and pressure [psu-1] + real :: d2ks_dTdp ! Second derivative of the secant bulk modulus with temperature and pressure [degC-1] + real :: I_denom ! The inverse of the denominator of the expression for density [bar-1] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + ! The UNESCO equation of state is a fit to density, but it chooses a form that exhibits a + ! singularity in the second derivatives with salinity for fresh water. To avoid this, the + ! square root of salinity can be treated with a floor such that the contribution from the + ! S**1.5 terms to both the surface density and the secant bulk modulus are lost to roundoff. + ! This salinity is given by (~1e-16*S000/S600)**(2/3) ~= 3e-8 PSU, or S12 ~= 1.7e-4 + I_s12 = 1.0 / (max(s12, 1.0e-4)) + + ! Calculate the density at sea level pressure and its derivatives + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + drho0_dT = R01 + ( t1*(2.0*R02 + t1*(3.0*R03 + t1*(4.0*R04 + t1*(5.0*R05)))) + & + s1*(R11 + ( t1*(2.0*R12 + t1*(3.0*R13 + t1*(4.0*R14))) + & + s12*(R61 + t1*(2.0*R62)) ) ) ) + drho0_dS = R10 + ( t1*(R11 + t1*(R12 + t1*(R13 + t1*R14))) + & + (1.5*(s12*(R60 + t1*(R61 + t1*R62))) + s1*(2.0*R20)) ) + d2rho0_dS2 = 0.75*(R60 + t1*(R61 + t1*R62))*I_s12 + 2.0*R20 + d2rho0_dSdT = R11 + ( t1*(2.0*R12 + t1*(3.0*R13 + t1*(4.0*R14))) + s12*(1.5*R61 + t1*(3.0*R62)) ) + d2rho0_dT2 = 2.0*R02 + ( t1*(6.0*R03 + t1*(12.0*R04 + t1*(20.0*R05))) + & + s1*((2.0*R12 + t1*(6.0*R13 + t1*(12.0*R14))) + s12*(2.0*R62)) ) + + ! Calculate the secant bulk modulus and its derivatives + ks_0 = S000 + ( t1*( S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) ) + ks_1 = S001 + ( t1*( S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) ) + ks_2 = S002 + ( t1*( S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) ) + + ks = ks_0 + p1*(ks_1 + p1*ks_2) + dks_dp = ks_1 + 2.0*p1*ks_2 + dks_dT = (S010 + ( t1*(2.0*S020 + t1*(3.0*S030 + t1*(4.0*S040))) + & + s1*((S110 + t1*(2.0*S120 + t1*(3.0*S130))) + s12*(S610 + t1*(2.0*S620))) )) + & + p1*((S011 + t1*(2.0*S021 + t1*(3.0*S031)) + s1*(S111 + t1*(2.0*S121))) + & + p1*(S012 + t1*(2.0*S022) + s1*(S112 + t1*(2.0*S122)))) + dks_dS = (S100 + ( t1*(S110 + t1*(S120 + t1*S130)) + 1.5*(s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*((S101 + t1*(S111 + t1*S121) + s12*(1.5*S601)) + & + p1*(S102 + t1*(S112 + t1*S122))) + d2ks_dS2 = 0.75*((S600 + t1*(S610 + t1*S620)) + p1*S601)*I_s12 + d2ks_dSdT = (S110 + ( t1*(2.0*S120 + t1*(3.0*S130)) + s12*(1.5*S610 + t1*(3.0*S620)) )) + & + p1*((S111 + t1*(2.0*S121)) + p1*(S112 + t1*(2.0*S122))) + d2ks_dT2 = 2.0*(S020 + ( t1*(3.0*S030 + t1*(6.0*S040)) + s1*((S120 + t1*(3.0*S130)) + s12*S620) )) + & + 2.0*p1*((S021 + (t1*(3.0*S031) + s1*S121)) + p1*(S022 + s1*S122)) + + d2ks_dSdp = (S101 + (t1*(S111 + t1*S121) + s12*(1.5*S601))) + & + 2.0*p1*(S102 + t1*(S112 + t1*S122)) + d2ks_dTdp = (S011 + (t1*(2.0*S021 + t1*(3.0*S031)) + s1*(S111 + t1*(2.0*S121)))) + & + 2.0*p1*(S012 + t1*(2.0*S022) + s1*(S112 + t1*(2.0*S122))) + I_denom = 1.0 / (ks - p1) + + ! Expressions for density and its first derivatives are copied here for reference: + ! rho = rho0*ks * I_denom + ! drho_dT = I_denom*(ks*drho0_dT - p1*rho0*I_denom*dks_dT) + ! drho_dS = I_denom*(ks*drho0_dS - p1*rho0*I_denom*dks_dS) + ! drho_dp = 1.0e-5 * (rho0 * I_denom**2) * (ks - dks_dp*p1) + + ! Finally calculate the second derivatives + drho_dS_dS = I_denom * ( ks*d2rho0_dS2 - (p1*I_denom) * & + (2.0*drho0_dS*dks_dS + rho0*(d2ks_dS2 - 2.0*dks_dS**2*I_denom)) ) + drho_dS_dT = I_denom * (ks * d2rho0_dSdT - (p1*I_denom) * & + ((drho0_dT*dks_dS + drho0_dS*dks_dT) + & + rho0*(d2ks_dSdT - 2.0*(dks_dS*dks_dT)*I_denom)) ) + drho_dT_dT = I_denom * ( ks*d2rho0_dT2 - (p1*I_denom) * & + (2.0*drho0_dT*dks_dT + rho0*(d2ks_dT2 - 2.0*dks_dT**2*I_denom)) ) + + ! The factor of 1.0e-5 is because pressure here is in bars, not Pa. + drho_dS_dp = (1.0e-5 * I_denom**2) * ( (ks*drho0_dS - rho0*dks_dS) - & + p1*( (dks_dp*drho0_dS + rho0*d2ks_dSdp) - & + 2.0*(rho0*dks_dS) * ((dks_dp - 1.0)*I_denom) ) ) + drho_dT_dp = (1.0e-5 * I_denom**2) * ( (ks*drho0_dT - rho0*dks_dT) - & + p1*( (dks_dp*drho0_dT + rho0*d2ks_dTdp) - & + 2.0*(rho0*dks_dT) * ((dks_dp - 1.0)*I_denom) ) ) + +end subroutine calculate_density_second_derivs_elem_UNESCO + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). +elemental subroutine calculate_specvol_derivs_elem_UNESCO(this, T, S, pressure, dSV_dT, dSV_dS) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + real :: drho0_dT ! Derivative of rho0 with T [kg m-3 degC-1] + real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1] + real :: dks_dT ! Derivative of ks with T [bar degC-1] + real :: dks_dS ! Derivative of ks with S [bar psu-1] + real :: I_denom2 ! 1.0 / (rho0*ks)**2 [m6 kg-2 bar-2] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0) and its derivatives with temperature and salinity + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + drho0_dT = R01 + ( t1*(2.0*R02 + t1*(3.0*R03 + t1*(4.0*R04 + t1*(5.0*R05)))) + & + s1*(R11 + (t1*(2.0*R12 + t1*(3.0*R13 + t1*(4.0*R14))) + & + s12*(R61 + t1*(2.0*R62)) )) ) + drho0_dS = R10 + ( t1*(R11 + t1*(R12 + t1*(R13 + t1*R14))) + & + (1.5*(s12*(R60 + t1*(R61 + t1*R62))) + s1*(2.0*R20)) ) + + ! Compute the secant bulk modulus and its derivatives with temperature and salinity + ks = ( S000 + (t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620)))) ) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + dks_dT = ( S010 + (t1*(2.0*S020 + t1*(3.0*S030 + t1*(4.0*S040))) + & + s1*((S110 + t1*(2.0*S120 + t1*(3.0*S130))) + s12*(S610 + t1*(2.0*S620)))) ) + & + p1*(((S011 + t1*(2.0*S021 + t1*(3.0*S031))) + s1*(S111 + t1*(2.0*S121)) ) + & + p1*(S012 + t1*(2.0*S022) + s1*(S112 + t1*(2.0*S122))) ) + dks_dS = ( S100 + (t1*(S110 + t1*(S120 + t1*S130)) + 1.5*(s12*(S600 + t1*(S610 + t1*S620)))) ) + & + p1*((S101 + t1*(S111 + t1*S121) + s12*(1.5*S601)) + & + p1*(S102 + t1*(S112 + t1*S122)) ) + + ! specvol = (ks - p1) / (rho0*ks) = 1/rho0 - p1/(rho0*ks) + I_denom2 = 1.0 / (rho0*ks)**2 + dSV_dT = ((p1*rho0)*dks_dT + ((p1 - ks)*ks)*drho0_dT) * I_denom2 + dSV_dS = ((p1*rho0)*dks_dS + ((p1 - ks)*ks)*drho0_dS) * I_denom2 + +end subroutine calculate_specvol_derivs_elem_UNESCO + +!> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) +!! at the given salinity, potential temperature and pressure using the UNESCO (1981) +!! equation of state, as refit by Jackett and McDougall (1995). +elemental subroutine calculate_compress_elem_UNESCO(this, T, S, pressure, rho, drho_dp) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + real :: ks_0 ! The secant bulk modulus at zero pressure [bar] + real :: ks_1 ! The linear pressure dependence of the secant bulk modulus at zero pressure [nondim] + real :: ks_2 ! The quadratic pressure dependence of the secant bulk modulus at zero pressure [bar-1] + real :: dks_dp ! The derivative of the secant bulk modulus with pressure [nondim] + real :: I_denom ! 1.0 / (ks - p1) [bar-1] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). + + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + + ! Calculate the secant bulk modulus and its derivative with pressure. + ks_0 = S000 + ( t1*( S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) ) + ks_1 = S001 + ( t1*( S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) ) + ks_2 = S002 + ( t1*( S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) ) + + ks = ks_0 + p1*(ks_1 + p1*ks_2) + dks_dp = ks_1 + 2.0*p1*ks_2 + I_denom = 1.0 / (ks - p1) + + ! Compute the in situ density, rho(s,theta,p), and its derivative with pressure. + rho = rho0*ks * I_denom + ! The factor of 1.0e-5 is because pressure here is in bars, not Pa. + drho_dp = 1.0e-5 * ((rho0 * (ks - p1*dks_dp)) * I_denom**2) + +end subroutine calculate_compress_elem_UNESCO + +!> Return the range of temperatures, salinities and pressures for which Jackett and McDougall (1995) +!! refit the UNESCO equation of state has been fitted to observations. Care should be taken when +!! applying this equation of state outside of its fit range. +subroutine EoS_fit_range_UNESCO(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -2.5 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_UNESCO + +!> \namespace mom_eos_UNESCO +!! +!! \section section_EOS_UNESCO UNESCO (Jackett & McDougall) equation of state +!! +!! The UNESCO (1981) equation of state is an internationally defined standard fit valid over the +!! range of pressures up to 10000 dbar, temperatures between the freezing point and 40 degC, and +!! salinities between 0 and 42 PSU. Unfortunately, these expressions used in situ temperatures, +!! whereas ocean models (including MOM6) effectively use potential temperatures as their state +!! variables. To avoid needing multiple conversions, Jackett and McDougall (1995) refit the +!! UNESCO equation of state to take potential temperature as a state variable, over the same +!! valid range and functional form as the original UNESCO expressions. It is this refit from +!! Jackett and McDougall (1995) that is coded up in this module. +!! +!! The functional form of the equation of state includes terms proportional to salinity to the +!! 3/2 power. This introduces a singularity in the second derivative of density with salinity +!! at a salinity of 0, but this has been addressed here by setting a floor of 1e-8 PSU on the +!! salinity that is used in the denominator of these second derivative expressions. This value +!! was chosen to imply a contribution that is smaller than numerical roundoff in the expression +!! for density, which is the field for which the UNESCO equation of state was originally derived. +!! +!! Originally coded in 1999 by J. Stephens, revised in 2023 to unambiguously specify the order +!! of arithmetic with parenthesis in every real sum of three or more terms. +!! +!! \subsection section_EOS_UNESCO_references References +!! +!! Gill, A. E., 1982: Atmosphere-Ocean Dynamics. Academic Press, 662 pp. +!! +!! Jackett, D. and T. McDougall, 1995: Minimal adjustment of hydrographic profiles to +!! achieve static stability. J. Atmos. Ocean. Tech., 12, 381-389. +!! +!! UNESCO, 1981: Tenth report of the joint panel on oceanographic tables and standards. +!! UNESCO Technical Papers in Marine Sci. No. 36, UNESCO, Paris. + +end module MOM_EOS_UNESCO diff --git a/equation_of_state/MOM_EOS_Wright.F90 b/equation_of_state/MOM_EOS_Wright.F90 new file mode 100644 index 0000000000..8b6d6495d1 --- /dev/null +++ b/equation_of_state/MOM_EOS_Wright.F90 @@ -0,0 +1,948 @@ +!> The equation of state using a poor implementation (missing parenthesis and bugs) of the +!! reduced range Wright 1997 expressions +module MOM_EOS_Wright + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS_base_type, only : EOS_base +use MOM_hor_index, only : hor_index_type + +implicit none ; private + +public buggy_Wright_EOS +public int_density_dz_wright, int_spec_vol_dp_wright +public avg_spec_vol_buggy_Wright + +!>@{ Parameters in the Wright equation of state using the reduced range formula, which is a fit to the UNESCO +! equation of state for the restricted range: -2 < theta < 30 [degC], 28 < S < 38 [PSU], 0 < p < 5e7 [Pa]. + + ! Note that a0/a1 ~= 2028 [degC] ; a0/a2 ~= -6343 [PSU] + ! b0/b1 ~= 165 [degC] ; b0/b4 ~= 974 [PSU] + ! c0/c1 ~= 216 [degC] ; c0/c4 ~= -740 [PSU] +real, parameter :: a0 = 7.057924e-4 ! A parameter in the Wright alpha_0 fit [m3 kg-1] +real, parameter :: a1 = 3.480336e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 degC-1] +real, parameter :: a2 = -1.112733e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 PSU-1] +real, parameter :: b0 = 5.790749e8 ! A parameter in the Wright p_0 fit [Pa] +real, parameter :: b1 = 3.516535e6 ! A parameter in the Wright p_0 fit [Pa degC-1] +real, parameter :: b2 = -4.002714e4 ! A parameter in the Wright p_0 fit [Pa degC-2] +real, parameter :: b3 = 2.084372e2 ! A parameter in the Wright p_0 fit [Pa degC-3] +real, parameter :: b4 = 5.944068e5 ! A parameter in the Wright p_0 fit [Pa PSU-1] +real, parameter :: b5 = -9.643486e3 ! A parameter in the Wright p_0 fit [Pa degC-1 PSU-1] +real, parameter :: c0 = 1.704853e5 ! A parameter in the Wright lambda fit [m2 s-2] +real, parameter :: c1 = 7.904722e2 ! A parameter in the Wright lambda fit [m2 s-2 degC-1] +real, parameter :: c2 = -7.984422 ! A parameter in the Wright lambda fit [m2 s-2 degC-2] +real, parameter :: c3 = 5.140652e-2 ! A parameter in the Wright lambda fit [m2 s-2 degC-3] +real, parameter :: c4 = -2.302158e2 ! A parameter in the Wright lambda fit [m2 s-2 PSU-1] +real, parameter :: c5 = -3.079464 ! A parameter in the Wright lambda fit [m2 s-2 degC-1 PSU-1] +!>@} + +!> The EOS_base implementation of the Wright 1997 equation of state with some bugs +type, extends (EOS_base) :: buggy_Wright_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_buggy_Wright + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_buggy_Wright + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_buggy_Wright + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_buggy_Wright + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_buggy_Wright + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_buggy_Wright + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_buggy_Wright + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_buggy_Wright + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_buggy_Wright + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_buggy_Wright + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_buggy_Wright + +end type buggy_Wright_EOS + +contains + +!> In situ density of sea water using a buggy implementation of Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_buggy_Wright(this, T, S, pressure) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + + al0 = (a0 + a1*T) +a2*S + p0 = (b0 + b4*S) + T * (b1 + T*(b2 + b3*T) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*(c2 + c3*T) + c5*S) + density_elem_buggy_Wright = (pressure + p0) / (lambda + al0*(pressure + p0)) + +end function density_elem_buggy_Wright + +!> In situ density anomaly of sea water using a buggy implementation of Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_buggy_Wright(this, T, S, pressure, rho_ref) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(in) :: rho_ref !< A reference density [kg m-3]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_TS ! The contributions of temperature and salinity to lambda [m2 s-2] + real :: pa_000 ! A corrected offset to the pressure, including contributions from rho_ref [Pa] + + pa_000 = (b0*(1.0 - a0*rho_ref) - rho_ref*c0) + al_TS = a1*T +a2*S + al0 = a0 + al_TS + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lam_TS = c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) + + ! The following two expressions are mathematically equivalent. + ! wright_density = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref + density_anomaly_elem_buggy_Wright = & + (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & + ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) + +end function density_anomaly_elem_buggy_Wright + +!> In situ specific volume of sea water using a buggy implementation of Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_buggy_Wright(this, T, S, pressure) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + + al0 = (a0 + a1*T) +a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) + + spec_vol_elem_buggy_Wright = (lambda + al0*(pressure + p0)) / (pressure + p0) + +end function spec_vol_elem_buggy_Wright + +!> In situ specific volume anomaly of sea water using a buggy implementation of Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_buggy_Wright(this, T, S, pressure, spv_ref) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + + al0 = (a0 + a1*T) +a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) + + spec_vol_anomaly_elem_buggy_Wright = (lambda + (al0 - spv_ref)*(pressure + p0)) / (pressure + p0) + +end function spec_vol_anomaly_elem_buggy_Wright + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using the buggy implementation of the equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_derivs_elem_buggy_Wright(this, T, S, pressure, drho_dT, drho_dS) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + + al0 = (a0 + a1*T) + a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) + + I_denom2 = 1.0 / (lambda + al0*(pressure + p0)) + I_denom2 = I_denom2 *I_denom2 + drho_dT = I_denom2 * & + (lambda* (b1 + T*(2.0*b2 + 3.0*b3*T) + b5*S) - & + (pressure+p0) * ( (pressure+p0)*a1 + & + (c1 + T*(c2*2.0 + c3*3.0*T) + c5*S) )) + drho_dS = I_denom2 * (lambda* (b4 + b5*T) - & + (pressure+p0) * ( (pressure+p0)*a2 + (c4 + c5*T) )) + +end subroutine calculate_density_derivs_elem_buggy_Wright + +!> Second derivatives of density with respect to temperature, salinity, and pressure, +!! using the poor implementation of the equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_second_derivs_elem_buggy_Wright(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + ! Local variables + real :: z0, z1 ! Local work variables [Pa] + real :: z2, z4 ! Local work variables [m2 s-2] + real :: z3, z5 ! Local work variables [Pa degC-1] + real :: z6, z8 ! Local work variables [m2 s-2 degC-1] + real :: z7 ! A local work variable [m2 s-2 PSU-1] + real :: z9 ! A local work variable [m3 kg-1] + real :: z10 ! A local work variable [Pa PSU-1] + real :: z11 ! A local work variable [Pa m2 s-2 PSU-1] = [kg m s-4 PSU-1] + real :: z2_2 ! A local work variable [m4 s-4] + real :: z2_3 ! A local work variable [m6 s-6] + + ! Based on the above expression with common terms factored, there probably exists a more numerically stable + ! and/or efficient expression + + z0 = T*(b1 + b5*S + T*(b2 + b3*T)) + z1 = (b0 + pressure + b4*S + z0) + z3 = (b1 + b5*S + T*(2.*b2 + 2.*b3*T)) ! BUG: This should be z3 = b1 + b5*S + T*(2.*b2 + 3.*b3*T) + z4 = (c0 + c4*S + T*(c1 + c5*S + T*(c2 + c3*T))) + z5 = (b1 + b5*S + T*(b2 + b3*T) + T*(b2 + 2.*b3*T)) + z6 = c1 + c5*S + T*(c2 + c3*T) + T*(c2 + 2.*c3*T) + z7 = (c4 + c5*T + a2*z1) + z8 = (c1 + c5*S + T*(2.*c2 + 3.*c3*T) + a1*z1) + z9 = (a0 + a2*S + a1*T) + z10 = (b4 + b5*T) + z11 = (z10*z4 - z1*z7) + z2 = (c0 + c4*S + T*(c1 + c5*S + T*(c2 + c3*T)) + z9*z1) + z2_2 = z2*z2 + z2_3 = z2_2*z2 + + drho_ds_ds = (z10*(c4 + c5*T) - a2*z10*z1 - z10*z7)/z2_2 - (2.*(c4 + c5*T + z9*z10 + a2*z1)*z11)/z2_3 + drho_ds_dt = (z10*z6 - z1*(c5 + a2*z5) + b5*z4 - z5*z7)/z2_2 - (2.*(z6 + z9*z5 + a1*z1)*z11)/z2_3 + ! BUG: In the following line: (2.*b2 + 4.*b3*T) should be (2.*b2 + 6.*b3*T) + drho_dt_dt = (z3*z6 - z1*(2.*c2 + 6.*c3*T + a1*z5) + (2.*b2 + 4.*b3*T)*z4 - z5*z8)/z2_2 - & + (2.*(z6 + z9*z5 + a1*z1)*(z3*z4 - z1*z8))/z2_3 + drho_ds_dp = (-c4 - c5*T - 2.*a2*z1)/z2_2 - (2.*z9*z11)/z2_3 + drho_dt_dp = (-c1 - c5*S - T*(2.*c2 + 3.*c3*T) - 2.*a1*z1)/z2_2 - (2.*z9*(z3*z4 - z1*z8))/z2_3 + +end subroutine calculate_density_second_derivs_elem_buggy_Wright + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the poor implementation of the equation of state, as fit by Wright, 1997 +elemental subroutine calculate_specvol_derivs_elem_buggy_Wright(this, T, S, pressure, dSV_dT, dSV_dS) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + ! Local variables + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of specific volume in the Wright EOS [Pa-1] + +! al0 = (a0 + a1*T) + a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) + + ! SV = al0 + lambda / (pressure + p0) + + I_denom = 1.0 / (pressure + p0) + dSV_dT = (a1 + I_denom * (c1 + T*((2.0*c2 + 3.0*c3*T)) + c5*S)) - & + (I_denom**2 * lambda) * (b1 + T*((2.0*b2 + 3.0*b3*T)) + b5*S) + dSV_dS = (a2 + I_denom * (c4 + c5*T)) - & + (I_denom**2 * lambda) * (b4 + b5*T) + +end subroutine calculate_specvol_derivs_elem_buggy_Wright + +!> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) +!! at the given salinity, potential temperature and pressure +!! using the poor implementation of the equation of state, as fit by Wright, 1997 +elemental subroutine calculate_compress_elem_buggy_Wright(this, T, S, pressure, rho, drho_dp) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + + al0 = (a0 + a1*T) +a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) + + I_denom = 1.0 / (lambda + al0*(pressure + p0)) + rho = (pressure + p0) * I_denom + drho_dp = lambda * I_denom * I_denom + +end subroutine calculate_compress_elem_buggy_Wright + +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, to determine +!! the layer-average specific volumes. There are essentially no free assumptions, apart from a +!! truncation in the series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine avg_spec_vol_buggy_Wright(T, S, p_t, dp, SpV_avg, start, npts) + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface + !! [degC]. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [m3 kg-1] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + + ! Local variables + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: eps2 ! The square of a nondimensional ratio [nondim] + real :: I_pterm ! The inverse of p0 plus p_ave [Pa-1]. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] + integer :: j + + ! alpha(j) = al0 + lambda / (pressure(j) + p0) + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + I_pterm = 1.0 / (p0 + (p_t(j) + 0.5*dp(j))) + eps2 = (0.5 * dp(j) * I_pterm)**2 + SpV_avg(j) = al0 + (lambda * I_pterm) * & + (1.0 + eps2*(C1_3 + eps2*(0.2 + eps2*(C1_7 + eps2*C1_9)))) + enddo +end subroutine avg_spec_vol_buggy_Wright + +!> Return the range of temperatures, salinities and pressures for which the reduced-range equation +!! of state from Wright (1997) has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range_buggy_Wright(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -2.0 + if (present(T_max)) T_max = 30.0 + if (present(S_min)) S_min = 28.0 + if (present(S_max)) S_max = 38.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 5.0e7 + +end subroutine EoS_fit_range_buggy_Wright + +!> Calculates analytical and nearly-analytical integrals, in geopotential across layers, of pressure +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's rule +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. +subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & + useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. + !! (The pressure is calculated as p~=-z*rho_0*G_e.) + real, intent(in) :: rho_0 !< Density [R ~> kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly across the + !! layer [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer + !! of the pressure anomaly relative to the anomaly + !! at the top of the layer [R Z L2 T-2 ~> Pa m]. + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: rem ! [kg m-1 s-2] + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: g_Earth ! The gravitational acceleration [m2 Z-1 s-2 ~> m s-2] + real :: I_Rho ! The inverse of the Boussinesq density [m3 kg-1] + real :: rho_ref_mks ! The reference density in MKS units [kg m-3] + real :: p_ave ! The layer averaged pressure [Pa] + real :: I_al0 ! The inverse of al0 [kg m-3] + real :: I_Lzz ! The inverse of the denominator [Pa-1] + real :: dz ! The layer thickness [Z ~> m]. + real :: hWght ! A pressure-thickness below topography [Z ~> m]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. + real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by + ! pres_scale [R L2 T-2 Pa-1 ~> 1]. + real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + if (present(pres_scale)) then + GxRho = pres_scale * G_e * rho_0 ; g_Earth = pres_scale * G_e + Pa_to_RL2_T2 = 1.0 / pres_scale + else + GxRho = G_e * rho_0 ; g_Earth = G_e + Pa_to_RL2_T2 = 1.0 + endif + if (present(rho_scale)) then + g_Earth = g_Earth * rho_scale + rho_ref_mks = rho_ref / rho_scale ; I_Rho = rho_scale / rho_0 + else + rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 + endif + z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "bathyT must be present if useMassWghtInterp is present and true.") + ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + al0_2d(i,j) = (a0 + a1s*T(i,j)) + a2s*S(i,j) + p0_2d(i,j) = (b0 + b4s*S(i,j)) + T(i,j) * (b1s + T(i,j)*((b2s + b3s*T(i,j))) + b5s*S(i,j)) + lambda_2d(i,j) = (c0 +c4s*S(i,j)) + T(i,j) * (c1s + T(i,j)*((c2s + c3s*T(i,j))) + c5s*S(i,j)) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + + dz = z_t(i,j) - z_b(i,j) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) + eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps + +! rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) + + rho_anom = (p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks + rem = I_Rho * (lambda * I_al0**2) * eps2 * & + (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + dpa(i,j) = Pa_to_RL2_T2 * (g_Earth*rho_anom*dz - 2.0*eps*rem) + if (present(intz_dpa)) & + intz_dpa(i,j) = Pa_to_RL2_T2 * (0.5*g_Earth*rho_anom*dz**2 - dz*(1.0+eps)*rem) + enddo ; enddo + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i+1,j)+z_b(i+1,j))) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) + eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( g_Earth*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) ) + enddo + ! Use Boole's rule to integrate the values. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i,j+1) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i,j+1) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i,j+1) + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i,j+1)+z_b(i,j+1))) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) + eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( g_Earth*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) ) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + +end subroutine int_density_dz_wright + +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, of geopotential +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! non-Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. +subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & + intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & + useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, intent(in) :: spv_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! The calculation is mathematically identical with different values of + !! spv_ref, but this reduces the effects of roundoff. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly + !! at the bottom of the layer [R L4 T-4 ~> Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the x grid spacing + !! [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the y grid spacing + !! [L2 T-2 ~> m2 s-2]. + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate + !! dza. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific + !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0 ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real :: p0 ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real :: lambda ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0_scale ! Scaling factor to convert al0 from MKS units [R-1 kg m-3 ~> 1] + real :: p0_scale ! Scaling factor to convert p0 from MKS units [R L2 T-2 Pa-1 ~> 1] + real :: lam_scale ! Scaling factor to convert lambda from MKS units [L2 s2 T-2 m-2 ~> 1] + real :: p_ave ! The layer average pressure [R L2 T-2 ~> Pa] + real :: rem ! [L2 T-2 ~> m2 s-2] + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: alpha_anom ! The depth averaged specific volume anomaly [R-1 ~> m3 kg-1]. + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa]. + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif + + + al0_scale = 1.0 ; if (present(SV_scale)) al0_scale = SV_scale + p0_scale = 1.0 + if (present(pres_scale)) then ; if (pres_scale /= 1.0) then + p0_scale = 1.0 / pres_scale + endif ; endif + lam_scale = al0_scale * p0_scale + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. +! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "bathyP must be present if useMassWghtInterp is present and true.") +! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) + do j=jsh,jeh ; do i=ish,ieh + al0_2d(i,j) = al0_scale * ( (a0 + a1s*T(i,j)) + a2s*S(i,j) ) + p0_2d(i,j) = p0_scale * ( (b0 + b4s*S(i,j)) + T(i,j) * (b1s + T(i,j)*((b2s + b3s*T(i,j))) + b5s*S(i,j)) ) + lambda_2d(i,j) = lam_scale * ( (c0 + c4s*S(i,j)) + T(i,j) * (c1s + T(i,j)*((c2s + c3s*T(i,j))) + c5s*S(i,j)) ) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + dp = p_b(i,j) - p_t(i,j) + p_ave = 0.5*(p_t(i,j)+p_b(i,j)) + + eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps + alpha_anom = al0 + lambda / (p0 + p_ave) - spv_ref + rem = lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + dza(i,j) = alpha_anom*dp + 2.0*eps*rem + if (present(intp_dza)) & + intp_dza(i,j) = 0.5*alpha_anom*dp**2 - dp*(1.0-eps)*rem + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j))) + + eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps + intp(m) = (al0 + lambda / (p0 + p_ave) - spv_ref)*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = wt_L*al0_2d(i,j) + wt_R*al0_2d(i,j+1) + p0 = wt_L*p0_2d(i,j) + wt_R*p0_2d(i,j+1) + lambda = wt_L*lambda_2d(i,j) + wt_R*lambda_2d(i,j+1) + + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1))) + + eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps + intp(m) = (al0 + lambda / (p0 + p_ave) - spv_ref)*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif +end subroutine int_spec_vol_dp_wright + +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_buggy_Wright(this, T, S, pressure, rho, start, npts, rho_ref) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_buggy_Wright(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_buggy_Wright(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_buggy_Wright + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_buggy_Wright(this, T, S, pressure, specvol, start, npts, spv_ref) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_buggy_Wright(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_buggy_Wright(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_buggy_Wright + + +!> \namespace mom_eos_wright +!! +!! \section section_EOS_Wright Wright equation of state +!! +!! Wright, 1997, provide an approximation for the in situ density as a function of +!! potential temperature, salinity and pressure. The formula follow the Tumlirz +!! equation of state which are easier to evaluate and make efficient. +!! +!! Two ranges are provided by Wright: a "full" range and "reduced" range. The version in this +!! module uses the reduced range. +!! +!! Originally coded in 2000 by R. Hallberg. +!! Anomaly form coded in 3/18. +!! +!! \subsection section_EOS_Wright_references References +!! +!! Wright, D., 1997: An Equation of State for Use in Ocean Models: Eckart's Formula Revisited. +!! J. Ocean. Atmosph. Tech., 14 (3), 735-740. +!! https://journals.ametsoc.org/doi/abs/10.1175/1520-0426%281997%29014%3C0735%3AAEOSFU%3E2.0.CO%3B2 + +end module MOM_EOS_Wright diff --git a/equation_of_state/MOM_EOS_Wright_full.F90 b/equation_of_state/MOM_EOS_Wright_full.F90 new file mode 100644 index 0000000000..31b82e6190 --- /dev/null +++ b/equation_of_state/MOM_EOS_Wright_full.F90 @@ -0,0 +1,965 @@ +!> The equation of state using the Wright 1997 expressions with full range of data. +module MOM_EOS_Wright_full + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS_base_type, only : EOS_base +use MOM_hor_index, only : hor_index_type + +implicit none ; private + +public Wright_full_EOS +public int_density_dz_wright_full, int_spec_vol_dp_wright_full +public avg_spec_vol_Wright_full + +!>@{ Parameters in the Wright equation of state using the full range formula, which is a fit to the UNESCO +! equation of state for the full range: -2 < theta < 40 [degC], 0 < S < 40 [PSU], 0 < p < 1e8 [Pa]. + + ! Note that a0/a1 ~= 2618 [degC] ; a0/a2 ~= -4333 [PSU] + ! b0/b1 ~= 156 [degC] ; b0/b4 ~= 974 [PSU] + ! c0/c1 ~= 216 [degC] ; c0/c4 ~= -741 [PSU] +real, parameter :: a0 = 7.133718e-4 ! A parameter in the Wright alpha_0 fit [m3 kg-1] +real, parameter :: a1 = 2.724670e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 degC-1] +real, parameter :: a2 = -1.646582e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 PSU-1] +real, parameter :: b0 = 5.613770e8 ! A parameter in the Wright p_0 fit [Pa] +real, parameter :: b1 = 3.600337e6 ! A parameter in the Wright p_0 fit [Pa degC-1] +real, parameter :: b2 = -3.727194e4 ! A parameter in the Wright p_0 fit [Pa degC-2] +real, parameter :: b3 = 1.660557e2 ! A parameter in the Wright p_0 fit [Pa degC-3] +real, parameter :: b4 = 6.844158e5 ! A parameter in the Wright p_0 fit [Pa PSU-1] +real, parameter :: b5 = -8.389457e3 ! A parameter in the Wright p_0 fit [Pa degC-1 PSU-1] +real, parameter :: c0 = 1.609893e5 ! A parameter in the Wright lambda fit [m2 s-2] +real, parameter :: c1 = 8.427815e2 ! A parameter in the Wright lambda fit [m2 s-2 degC-1] +real, parameter :: c2 = -6.931554 ! A parameter in the Wright lambda fit [m2 s-2 degC-2] +real, parameter :: c3 = 3.869318e-2 ! A parameter in the Wright lambda fit [m2 s-2 degC-3] +real, parameter :: c4 = -1.664201e2 ! A parameter in the Wright lambda fit [m2 s-2 PSU-1] +real, parameter :: c5 = -2.765195 ! A parameter in the Wright lambda fit [m2 s-2 degC-1 PSU-1] +!>@} + +!> The EOS_base implementation of the full range Wright 1997 equation of state +type, extends (EOS_base) :: Wright_full_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Wright_full + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Wright_full + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Wright_full + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Wright_full + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Wright_full + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Wright_full + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Wright_full + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Wright_full + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Wright_full + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_Wright_full + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_Wright_full + +end type Wright_full_EOS + +contains + +!> In situ density of sea water using a full range fit by Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Wright_full(this, T, S, pressure) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + density_elem_Wright_full = (pressure + p0) / (lambda + al0*(pressure + p0)) + +end function density_elem_Wright_full + +!> In situ density anomaly of sea water using a full range fit by Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Wright_full(this, T, S, pressure, rho_ref) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_TS ! The contributions of temperature and salinity to lambda [m2 s-2] + real :: pa_000 ! A corrected offset to the pressure, including contributions from rho_ref [Pa] + + pa_000 = b0*(1.0 - a0*rho_ref) - rho_ref*c0 + al_TS = a1*T + a2*S + al0 = a0 + al_TS + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lam_TS = c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) + + ! The following two expressions are mathematically equivalent. + ! rho = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref + density_anomaly_elem_Wright_full = & + (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & + ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) + +end function density_anomaly_elem_Wright_full + +!> In situ specific volume of sea water using a full range fit by Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Wright_full(this, T, S, pressure) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2], perhaps with + ! an offset to account for spv_ref + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_000 ! A corrected offset to lambda, including contributions from spv_ref [m2 s-2] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + spec_vol_elem_Wright_full = al0 + lambda / (pressure + p0) + +end function spec_vol_elem_Wright_full + +!> In situ specific volume anomaly of sea water using a full range fit by Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Wright_full(this, T, S, pressure, spv_ref) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2], perhaps with + ! an offset to account for spv_ref + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_000 ! A corrected offset to lambda, including contributions from spv_ref [m2 s-2] + + lam_000 = c0 + (a0 - spv_ref)*b0 + al_TS = a1*T + a2*S + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lambda = lam_000 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + ! This is equivalent to the expression below minus spv_ref, but less sensitive to roundoff. + spec_vol_anomaly_elem_Wright_full = al_TS + (lambda + (a0 - spv_ref)*p_TSp) / (b0 + p_TSp) + +end function spec_vol_anomaly_elem_Wright_full + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using the full range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_derivs_elem_Wright_full(this, T, S, pressure, drho_dT, drho_dS) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + I_denom2 = 1.0 / (lambda + al0*(pressure + p0))**2 + drho_dT = I_denom2 * (lambda * (b1 + (T*(2.0*b2 + 3.0*b3*T) + b5*S)) - & + (pressure+p0) * ( (pressure+p0)*a1 + (c1 + (T*(c2*2.0 + c3*3.0*T) + c5*S)) )) + drho_dS = I_denom2 * (lambda * (b4 + b5*T) - & + (pressure+p0) * ( (pressure+p0)*a2 + (c4 + c5*T) )) + +end subroutine calculate_density_derivs_elem_Wright_full + +!> Second derivatives of density with respect to temperature, salinity, and pressure, +!! using the full range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_second_derivs_elem_Wright_full(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: p_p0 ! A local work variable combining the pressure and pressure + ! offset (p0 elsewhere) in the Wright EOS [Pa] + real :: dp0_dT ! The partial derivative of p0 with temperature [Pa degC-1] + real :: dp0_dS ! The partial derivative of p0 with salinity [Pa PSU-1] + real :: dlam_dT ! The partial derivative of lambda with temperature [m2 s-2 degC-1] + real :: dlam_dS ! The partial derivative of lambda with salinity [m2 s-2 degC-1] + real :: dRdT_num ! The numerator in the expression for drho_dT [Pa m2 s-2 degC-1] = [kg m s-4 degC-1] + real :: dRdS_num ! The numerator in the expression for drho_ds [Pa m2 s-2 PSU-1] = [kg m s-4 PSU-1] + real :: ddenom_dT ! The derivative of the denominator of density in the Wright EOS with temperature [m2 s-2 deg-1] + real :: ddenom_dS ! The derivative of the denominator of density in the Wright EOS with salinity [m2 s-2 PSU-1] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + real :: I_denom3 ! The inverse of the cube of the denominator of density in the Wright EOS [s6 m-6] + + al0 = a0 + (a1*T + a2*S) + p_p0 = pressure + ( b0 + (b4*S + T*(b1 + (b5*S + T*(b2 + b3*T)))) ) ! P + p0 + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + dp0_dT = b1 + (b5*S + T*(2.*b2 + 3.*b3*T)) + dp0_dS = b4 + b5*T + dlam_dT = c1 + (c5*S + T*(2.*c2 + 3.*c3*T)) + dlam_dS = c4 + c5*T + I_denom = 1.0 / (lambda + al0*p_p0) + I_denom2 = I_denom*I_denom + I_denom3 = I_denom*I_denom2 + + ddenom_dS = (dlam_dS + a2*p_p0) + al0*dp0_dS + ddenom_dT = (dlam_dT + a1*p_p0) + al0*dp0_dT + dRdS_num = dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0) + dRdT_num = dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0) + + ! In deriving the following, it is useful to note that: + ! rho = p_p0 / (lambda + al0*p_p0) + ! drho_dp = lambda * I_denom2 + ! drho_dT = (dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0)) * I_denom2 = dRdT_num * I_denom2 + ! drho_dS = (dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0)) * I_denom2 = dRdS_num * I_denom2 + drho_ds_ds = -2.*(p_p0*(a2*dp0_dS)) * I_denom2 - 2.*(dRdS_num*ddenom_dS) * I_denom3 + drho_ds_dt = ((b5*lambda - p_p0*(c5 + 2.*a2*dp0_dT)) + (dp0_dS*dlam_dT - dp0_dT*dlam_dS))*I_denom2 - & + 2.*(ddenom_dT*dRdS_num) * I_denom3 + drho_dt_dt = 2.*((b2 + 3.*b3*T)*lambda - p_p0*((c2 + 3.*c3*T) + a1*dp0_dT))*I_denom2 - & + 2.*(dRdT_num * ddenom_dT) * I_denom3 + + ! The following is a rearranged form that is equivalent to + ! drho_ds_dp = dlam_dS * I_denom2 - 2.0 * lambda * (dlam_dS + a2*p_p0 + al0*dp0_ds) * Idenom3 + drho_ds_dp = (-dlam_dS - 2.*a2*p_p0) * I_denom2 - (2.*al0*dRdS_num) * I_denom3 + drho_dt_dp = (-dlam_dT - 2.*a1*p_p0) * I_denom2 - (2.*al0*dRdT_num) * I_denom3 + +end subroutine calculate_density_second_derivs_elem_Wright_full + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the full range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_specvol_derivs_elem_Wright_full(this,T, S, pressure, dSV_dT, dSV_dS) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + ! Local variables + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of specific volume in the Wright EOS [Pa-1] + + ! al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + ! SV = al0 + lambda / (pressure + p0) + + I_denom = 1.0 / (pressure + p0) + dSV_dT = a1 + I_denom * ((c1 + (T*(2.0*c2 + 3.0*c3*T) + c5*S)) - & + (I_denom * lambda) * (b1 + (T*(2.0*b2 + 3.0*b3*T) + b5*S))) + dSV_dS = a2 + I_denom * ((c4 + c5*T) - & + (I_denom * lambda) * (b4 + b5*T)) + +end subroutine calculate_specvol_derivs_elem_Wright_full + +!> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) +!! at the given salinity, potential temperature and pressure +!! using the full range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_compress_elem_Wright_full(this, T, S, pressure, rho, drho_dp) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + I_denom = 1.0 / (lambda + al0*(pressure + p0)) + rho = (pressure + p0) * I_denom + drho_dp = lambda * I_denom**2 + +end subroutine calculate_compress_elem_Wright_full + +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, to determine +!! the layer-average specific volumes. There are essentially no free assumptions, apart from a +!! truncation in the series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine avg_spec_vol_Wright_full(T, S, p_t, dp, SpV_avg, start, npts) + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface + !! [degC]. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [m3 kg-1] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + + ! Local variables + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: eps2 ! The square of a nondimensional ratio [nondim] + real :: I_pterm ! The inverse of p0 plus p_ave [Pa-1]. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] + integer :: j + + ! alpha = al0 + lambda / (pressure + p0) + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + I_pterm = 1.0 / (p0 + (p_t(j) + 0.5*dp(j))) + eps2 = (0.5 * dp(j) * I_pterm)**2 + SpV_avg(j) = al0 + (lambda * I_pterm) * & + (1.0 + eps2*(C1_3 + eps2*(0.2 + eps2*(C1_7 + eps2*C1_9)))) + enddo + +end subroutine avg_spec_vol_Wright_full + +!> Return the range of temperatures, salinities and pressures for which full-range equation +!! of state from Wright (1997) has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range_Wright_full(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -2.0 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 40.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_Wright_full + +!> Calculates analytical and nearly-analytical integrals, in geopotential across layers, of pressure +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's rule +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. +subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & + useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. + !! (The pressure is calculated as p~=-z*rho_0*G_e.) + real, intent(in) :: rho_0 !< Density [R ~> kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly across the + !! layer [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer + !! of the pressure anomaly relative to the anomaly + !! at the top of the layer [R Z L2 T-2 ~> Pa m]. + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: rem ! [kg m-1 s-2] + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: g_Earth ! The gravitational acceleration [m2 Z-1 s-2 ~> m s-2] + real :: I_Rho ! The inverse of the Boussinesq density [m3 kg-1] + real :: rho_ref_mks ! The reference density in MKS units [kg m-3] + real :: p_ave ! The layer averaged pressure [Pa] + real :: I_al0 ! The inverse of al0 [kg m-3] + real :: I_Lzz ! The inverse of the denominator [Pa-1] + real :: dz ! The layer thickness [Z ~> m]. + real :: hWght ! A pressure-thickness below topography [Z ~> m]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. + real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by + ! pres_scale [R L2 T-2 Pa-1 ~> 1]. + real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + if (present(pres_scale)) then + GxRho = pres_scale * G_e * rho_0 ; g_Earth = pres_scale * G_e + Pa_to_RL2_T2 = 1.0 / pres_scale + else + GxRho = G_e * rho_0 ; g_Earth = G_e + Pa_to_RL2_T2 = 1.0 + endif + if (present(rho_scale)) then + g_Earth = g_Earth * rho_scale + rho_ref_mks = rho_ref / rho_scale ; I_Rho = rho_scale / rho_0 + else + rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 + endif + z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "bathyT must be present if useMassWghtInterp is present and true.") + ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + al0_2d(i,j) = a0 + (a1s*T(i,j) + a2s*S(i,j)) + p0_2d(i,j) = b0 + ( b4s*S(i,j) + T(i,j) * (b1s + (T(i,j)*(b2s + b3s*T(i,j)) + b5s*S(i,j))) ) + lambda_2d(i,j) = c0 + ( c4s*S(i,j) + T(i,j) * (c1s + (T(i,j)*(c2s + c3s*T(i,j)) + c5s*S(i,j))) ) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + + dz = z_t(i,j) - z_b(i,j) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + +! rho = (pressure + p0) / (lambda + al0*(pressure + p0)) + + rho_anom = (p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks + rem = (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) + dpa(i,j) = Pa_to_RL2_T2 * ((g_Earth*rho_anom)*dz - 2.0*eps*rem) + if (present(intz_dpa)) & + intz_dpa(i,j) = Pa_to_RL2_T2 * (0.5*(g_Earth*rho_anom)*dz**2 - dz*((1.0+eps)*rem)) + enddo ; enddo + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i+1,j)+z_b(i+1,j))) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( (g_Earth*dz) * ((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) ) + enddo + ! Use Boole's rule to integrate the values. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i,j+1) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i,j+1) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i,j+1) + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i,j+1)+z_b(i,j+1))) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( (g_Earth*dz) * ((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) ) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + +end subroutine int_density_dz_wright_full + +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, of geopotential +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! non-Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. +subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & + intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & + useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, intent(in) :: spv_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! The calculation is mathematically identical with different values of + !! spv_ref, but this reduces the effects of roundoff. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly + !! at the bottom of the layer [R L4 T-4 ~> Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the x grid spacing + !! [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the y grid spacing + !! [L2 T-2 ~> m2 s-2]. + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate + !! dza. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific + !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0 ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real :: p0 ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real :: lambda ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0_scale ! Scaling factor to convert al0 from MKS units [R-1 kg m-3 ~> 1] + real :: p0_scale ! Scaling factor to convert p0 from MKS units [R L2 T-2 Pa-1 ~> 1] + real :: lam_scale ! Scaling factor to convert lambda from MKS units [L2 s2 T-2 m-2 ~> 1] + real :: p_ave ! The layer average pressure [R L2 T-2 ~> Pa] + real :: rem ! [L2 T-2 ~> m2 s-2] + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: alpha_anom ! The depth averaged specific volume anomaly [R-1 ~> m3 kg-1]. + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa]. + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2]. + real :: I_pterm ! The inverse of p0 plus p_ave [T2 R-1 L-2 ~> Pa-1]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif + + + al0_scale = 1.0 ; if (present(SV_scale)) al0_scale = SV_scale + p0_scale = 1.0 + if (present(pres_scale)) then ; if (pres_scale /= 1.0) then + p0_scale = 1.0 / pres_scale + endif ; endif + lam_scale = al0_scale * p0_scale + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. +! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "bathyP must be present if useMassWghtInterp is present and true.") +! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + ! alpha = (lambda + al0*(pressure + p0)) / (pressure + p0) + do j=jsh,jeh ; do i=ish,ieh + al0_2d(i,j) = al0_scale * ( a0 + (a1s*T(i,j) + a2s*S(i,j)) ) + p0_2d(i,j) = p0_scale * ( b0 + ( b4s*S(i,j) + T(i,j) * (b1s + (T(i,j)*(b2s + b3s*T(i,j)) + b5s*S(i,j))) ) ) + lambda_2d(i,j) = lam_scale * ( c0 + ( c4s*S(i,j) + T(i,j) * (c1s + (T(i,j)*(c2s + c3s*T(i,j)) + c5s*S(i,j))) ) ) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + dp = p_b(i,j) - p_t(i,j) + p_ave = 0.5*(p_t(i,j)+p_b(i,j)) + I_pterm = 1.0 / (p0 + p_ave) + + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + alpha_anom = (al0 - spv_ref) + lambda * I_pterm + rem = (lambda * eps2) * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + dza(i,j) = alpha_anom*dp + 2.0*eps*rem + if (present(intp_dza)) & + intp_dza(i,j) = 0.5*alpha_anom*dp**2 - dp*((1.0-eps)*rem) + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j))) + I_pterm = 1.0 / (p0 + p_ave) + + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda * I_pterm)*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = wt_L*al0_2d(i,j) + wt_R*al0_2d(i,j+1) + p0 = wt_L*p0_2d(i,j) + wt_R*p0_2d(i,j+1) + lambda = wt_L*lambda_2d(i,j) + wt_R*lambda_2d(i,j+1) + + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1))) + I_pterm = 1.0 / (p0 + p_ave) + + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda * I_pterm)*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif +end subroutine int_spec_vol_dp_wright_full + +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_Wright_full(this, T, S, pressure, rho, start, npts, rho_ref) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_Wright_full(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_Wright_full(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_Wright_full + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_Wright_full(this, T, S, pressure, specvol, start, npts, spv_ref) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_Wright_full(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_Wright_full(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_Wright_full + + +!> \namespace mom_eos_wright_full +!! +!! \section section_EOS_Wright_full Wright equation of state +!! +!! Wright, 1997, provide an approximation for the in situ density as a function of +!! potential temperature, salinity, and pressure. The formula follow the Tumlirz +!! equation of state which are easier to evaluate and make efficient. +!! +!! Two ranges are provided by Wright: a "full" range and "reduced" range. The version in this +!! module uses the full range. +!! +!! Originally coded in 2000 by R. Hallberg. +!! Anomaly form coded in 3/18. +!! +!! \subsection section_EOS_Wright_full_references References +!! +!! Wright, D., 1997: An Equation of State for Use in Ocean Models: Eckart's Formula Revisited. +!! J. Ocean. Atmosph. Tech., 14 (3), 735-740. +!! https://journals.ametsoc.org/doi/abs/10.1175/1520-0426%281997%29014%3C0735%3AAEOSFU%3E2.0.CO%3B2 + +end module MOM_EOS_Wright_full diff --git a/equation_of_state/MOM_EOS_Wright_red.F90 b/equation_of_state/MOM_EOS_Wright_red.F90 new file mode 100644 index 0000000000..65bdb9e521 --- /dev/null +++ b/equation_of_state/MOM_EOS_Wright_red.F90 @@ -0,0 +1,967 @@ +!> The equation of state using the Wright 1997 expressions with reduced range of data. +module MOM_EOS_Wright_red + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS_base_type, only : EOS_base +use MOM_hor_index, only : hor_index_type + +implicit none ; private + +public Wright_red_EOS +public int_density_dz_wright_red, int_spec_vol_dp_wright_red +public avg_spec_vol_Wright_red + +!>@{ Parameters in the Wright equation of state using the reduced range formula, which is a fit to the UNESCO +! equation of state for the restricted range: -2 < theta < 30 [degC], 28 < S < 38 [PSU], 0 < p < 5e7 [Pa]. + + ! Note that a0/a1 ~= 2028 [degC] ; a0/a2 ~= -6343 [PSU] + ! b0/b1 ~= 165 [degC] ; b0/b4 ~= 974 [PSU] + ! c0/c1 ~= 216 [degC] ; c0/c4 ~= -740 [PSU] +real, parameter :: a0 = 7.057924e-4 ! A parameter in the Wright alpha_0 fit [m3 kg-1] +real, parameter :: a1 = 3.480336e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 degC-1] +real, parameter :: a2 = -1.112733e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 PSU-1] +real, parameter :: b0 = 5.790749e8 ! A parameter in the Wright p_0 fit [Pa] +real, parameter :: b1 = 3.516535e6 ! A parameter in the Wright p_0 fit [Pa degC-1] +real, parameter :: b2 = -4.002714e4 ! A parameter in the Wright p_0 fit [Pa degC-2] +real, parameter :: b3 = 2.084372e2 ! A parameter in the Wright p_0 fit [Pa degC-3] +real, parameter :: b4 = 5.944068e5 ! A parameter in the Wright p_0 fit [Pa PSU-1] +real, parameter :: b5 = -9.643486e3 ! A parameter in the Wright p_0 fit [Pa degC-1 PSU-1] +real, parameter :: c0 = 1.704853e5 ! A parameter in the Wright lambda fit [m2 s-2] +real, parameter :: c1 = 7.904722e2 ! A parameter in the Wright lambda fit [m2 s-2 degC-1] +real, parameter :: c2 = -7.984422 ! A parameter in the Wright lambda fit [m2 s-2 degC-2] +real, parameter :: c3 = 5.140652e-2 ! A parameter in the Wright lambda fit [m2 s-2 degC-3] +real, parameter :: c4 = -2.302158e2 ! A parameter in the Wright lambda fit [m2 s-2 PSU-1] +real, parameter :: c5 = -3.079464 ! A parameter in the Wright lambda fit [m2 s-2 degC-1 PSU-1] +!>@} + +!> The EOS_base implementation of the reduced range Wright 1997 equation of state +type, extends (EOS_base) :: Wright_red_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Wright_red + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Wright_red + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Wright_red + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Wright_red + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Wright_red + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Wright_red + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Wright_red + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Wright_red + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Wright_red + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_Wright_red + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_Wright_red + +end type Wright_red_EOS + +contains + +!> In situ density of sea water using a reduced range fit by Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Wright_red(this, T, S, pressure) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + density_elem_Wright_red = (pressure + p0) / (lambda + al0*(pressure + p0)) + +end function density_elem_Wright_red + +!> In situ density anomaly of sea water using a reduced range fit by Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Wright_red(this, T, S, pressure, rho_ref) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(in) :: rho_ref !< A reference density [kg m-3]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_TS ! The contributions of temperature and salinity to lambda [m2 s-2] + real :: pa_000 ! A corrected offset to the pressure, including contributions from rho_ref [Pa] + + pa_000 = b0*(1.0 - a0*rho_ref) - rho_ref*c0 + al_TS = a1*T + a2*S + al0 = a0 + al_TS + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lam_TS = c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) + + ! The following two expressions are mathematically equivalent. + ! rho = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref + density_anomaly_elem_Wright_red = & + (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & + ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) + +end function density_anomaly_elem_Wright_red + +!> In situ specific volume of sea water using a reduced range fit by Wright, 1997 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Wright_red(this, T, S, pressure) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC] + real, intent(in) :: S !< salinity [PSU] + real, intent(in) :: pressure !< pressure [Pa] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2], perhaps with + ! an offset to account for spv_ref + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_000 ! A corrected offset to lambda, including contributions from spv_ref [m2 s-2] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + spec_vol_elem_Wright_red = al0 + lambda / (pressure + p0) + +end function spec_vol_elem_Wright_red + +!> In situ specific volume anomaly of sea water using a reduced range fit by Wright, 1997 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Wright_red(this, T, S, pressure, spv_ref) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC] + real, intent(in) :: S !< salinity [PSU] + real, intent(in) :: pressure !< pressure [Pa] + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2], perhaps with + ! an offset to account for spv_ref + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_000 ! A corrected offset to lambda, including contributions from spv_ref [m2 s-2] + + lam_000 = c0 + (a0 - spv_ref)*b0 + al_TS = a1*T + a2*S + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lambda = lam_000 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + ! This is equivalent to the expression below minus spv_ref, but less sensitive to roundoff. + spec_vol_anomaly_elem_Wright_red = al_TS + (lambda + (a0 - spv_ref)*p_TSp) / (b0 + p_TSp) + +end function spec_vol_anomaly_elem_Wright_red + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using the reduced range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_derivs_elem_Wright_red(this, T, S, pressure, drho_dT, drho_dS) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + I_denom2 = 1.0 / (lambda + al0*(pressure + p0))**2 + drho_dT = I_denom2 * (lambda * (b1 + (T*(2.0*b2 + 3.0*b3*T) + b5*S)) - & + (pressure+p0) * ( (pressure+p0)*a1 + (c1 + (T*(c2*2.0 + c3*3.0*T) + c5*S)) )) + drho_dS = I_denom2 * (lambda * (b4 + b5*T) - & + (pressure+p0) * ( (pressure+p0)*a2 + (c4 + c5*T) )) + +end subroutine calculate_density_derivs_elem_Wright_red + +!> Second derivatives of density with respect to temperature, salinity, and pressure, +!! using the reduced range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_second_derivs_elem_Wright_red(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: p_p0 ! A local work variable combining the pressure and pressure + ! offset (p0 elsewhere) in the Wright EOS [Pa] + real :: dp0_dT ! The partial derivative of p0 with temperature [Pa degC-1] + real :: dp0_dS ! The partial derivative of p0 with salinity [Pa PSU-1] + real :: dlam_dT ! The partial derivative of lambda with temperature [m2 s-2 degC-1] + real :: dlam_dS ! The partial derivative of lambda with salinity [m2 s-2 degC-1] + real :: dRdT_num ! The numerator in the expression for drho_dT [Pa m2 s-2 degC-1] = [kg m s-4 degC-1] + real :: dRdS_num ! The numerator in the expression for drho_ds [Pa m2 s-2 PSU-1] = [kg m s-4 PSU-1] + real :: ddenom_dT ! The derivative of the denominator of density in the Wright EOS with temperature [m2 s-2 deg-1] + real :: ddenom_dS ! The derivative of the denominator of density in the Wright EOS with salinity [m2 s-2 PSU-1] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + real :: I_denom3 ! The inverse of the cube of the denominator of density in the Wright EOS [s6 m-6] + + al0 = a0 + (a1*T + a2*S) + p_p0 = pressure + ( b0 + (b4*S + T*(b1 + (b5*S + T*(b2 + b3*T)))) ) ! P + p0 + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + dp0_dT = b1 + (b5*S + T*(2.*b2 + 3.*b3*T)) + dp0_dS = b4 + b5*T + dlam_dT = c1 + (c5*S + T*(2.*c2 + 3.*c3*T)) + dlam_dS = c4 + c5*T + I_denom = 1.0 / (lambda + al0*p_p0) + I_denom2 = I_denom*I_denom + I_denom3 = I_denom*I_denom2 + + ddenom_dS = (dlam_dS + a2*p_p0) + al0*dp0_dS + ddenom_dT = (dlam_dT + a1*p_p0) + al0*dp0_dT + dRdS_num = dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0) + dRdT_num = dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0) + + ! In deriving the following, it is useful to note that: + ! rho = p_p0 / (lambda + al0*p_p0) + ! drho_dp = lambda * I_denom2 + ! drho_dT = (dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0)) * I_denom2 = dRdT_num * I_denom2 + ! drho_dS = (dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0)) * I_denom2 = dRdS_num * I_denom2 + drho_ds_ds = -2.*(p_p0*(a2*dp0_dS)) * I_denom2 - 2.*(dRdS_num*ddenom_dS) * I_denom3 + drho_ds_dt = ((b5*lambda - p_p0*(c5 + 2.*a2*dp0_dT)) + (dp0_dS*dlam_dT - dp0_dT*dlam_dS))*I_denom2 - & + 2.*(ddenom_dT*dRdS_num) * I_denom3 + drho_dt_dt = 2.*((b2 + 3.*b3*T)*lambda - p_p0*((c2 + 3.*c3*T) + a1*dp0_dT))*I_denom2 - & + 2.*(dRdT_num * ddenom_dT) * I_denom3 + + ! The following is a rearranged form that is equivalent to + ! drho_ds_dp = dlam_dS * I_denom2 - 2.0 * lambda * (dlam_dS + a2*p_p0 + al0*dp0_ds) * Idenom3 + drho_ds_dp = (-dlam_dS - 2.*a2*p_p0) * I_denom2 - (2.*al0*dRdS_num) * I_denom3 + drho_dt_dp = (-dlam_dT - 2.*a1*p_p0) * I_denom2 - (2.*al0*dRdT_num) * I_denom3 + +end subroutine calculate_density_second_derivs_elem_Wright_red + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the reduced range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_specvol_derivs_elem_Wright_red(this, T, S, pressure, dSV_dT, dSV_dS) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + + ! Local variables + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of specific volume in the Wright EOS [Pa-1] + + !al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + ! SV = al0 + lambda / (pressure + p0) + + I_denom = 1.0 / (pressure + p0) + dSV_dT = a1 + I_denom * ((c1 + (T*(2.0*c2 + 3.0*c3*T) + c5*S)) - & + (I_denom * lambda) * (b1 + (T*(2.0*b2 + 3.0*b3*T) + b5*S))) + dSV_dS = a2 + I_denom * ((c4 + c5*T) - & + (I_denom * lambda) * (b4 + b5*T)) + +end subroutine calculate_specvol_derivs_elem_Wright_red + +!> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) +!! at the given salinity, potential temperature and pressure +!! using the reduced range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_compress_elem_Wright_red(this, T, S, pressure, rho, drho_dp) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + I_denom = 1.0 / (lambda + al0*(pressure + p0)) + rho = (pressure + p0) * I_denom + drho_dp = lambda * I_denom**2 + +end subroutine calculate_compress_elem_Wright_red + +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, to determine +!! the layer-average specific volumes. There are essentially no free assumptions, apart from a +!! truncation in the series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine avg_spec_vol_Wright_red(T, S, p_t, dp, SpV_avg, start, npts) + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface + !! [degC]. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [m3 kg-1] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + + ! Local variables + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: eps2 ! The square of a nondimensional ratio [nondim] + real :: I_pterm ! The inverse of p0 plus p_ave [Pa-1]. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] + integer :: j + + ! alpha(j) = al0 + lambda / (pressure(j) + p0) + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + I_pterm = 1.0 / (p0 + (p_t(j) + 0.5*dp(j))) + eps2 = (0.5 * dp(j) * I_pterm)**2 + SpV_avg(j) = al0 + (lambda * I_pterm) * & + (1.0 + eps2*(C1_3 + eps2*(0.2 + eps2*(C1_7 + eps2*C1_9)))) + enddo +end subroutine avg_spec_vol_Wright_red + +!> Return the range of temperatures, salinities and pressures for which the reduced-range equation +!! of state from Wright (1997) has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range_Wright_red(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -2.0 + if (present(T_max)) T_max = 30.0 + if (present(S_min)) S_min = 28.0 + if (present(S_max)) S_max = 38.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 5.0e7 + +end subroutine EoS_fit_range_Wright_red + +!> Calculates analytical and nearly-analytical integrals, in geopotential across layers, of pressure +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's rule +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. +subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & + useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. + !! (The pressure is calculated as p~=-z*rho_0*G_e.) + real, intent(in) :: rho_0 !< Density [R ~> kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly across the + !! layer [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer + !! of the pressure anomaly relative to the anomaly + !! at the top of the layer [R Z L2 T-2 ~> Pa m]. + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: rem ! [kg m-1 s-2] + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: g_Earth ! The gravitational acceleration [m2 Z-1 s-2 ~> m s-2] + real :: I_Rho ! The inverse of the Boussinesq density [m3 kg-1] + real :: rho_ref_mks ! The reference density in MKS units [kg m-3] + real :: p_ave ! The layer averaged pressure [Pa] + real :: I_al0 ! The inverse of al0 [kg m-3] + real :: I_Lzz ! The inverse of the denominator [Pa-1] + real :: dz ! The layer thickness [Z ~> m]. + real :: hWght ! A pressure-thickness below topography [Z ~> m]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. + real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by + ! pres_scale [R L2 T-2 Pa-1 ~> 1]. + real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + if (present(pres_scale)) then + GxRho = pres_scale * G_e * rho_0 ; g_Earth = pres_scale * G_e + Pa_to_RL2_T2 = 1.0 / pres_scale + else + GxRho = G_e * rho_0 ; g_Earth = G_e + Pa_to_RL2_T2 = 1.0 + endif + if (present(rho_scale)) then + g_Earth = g_Earth * rho_scale + rho_ref_mks = rho_ref / rho_scale ; I_Rho = rho_scale / rho_0 + else + rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 + endif + z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "bathyT must be present if useMassWghtInterp is present and true.") + ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + al0_2d(i,j) = a0 + (a1s*T(i,j) + a2s*S(i,j)) + p0_2d(i,j) = b0 + ( b4s*S(i,j) + T(i,j) * (b1s + (T(i,j)*(b2s + b3s*T(i,j)) + b5s*S(i,j))) ) + lambda_2d(i,j) = c0 + ( c4s*S(i,j) + T(i,j) * (c1s + (T(i,j)*(c2s + c3s*T(i,j)) + c5s*S(i,j))) ) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + + dz = z_t(i,j) - z_b(i,j) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + +! rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) + + rho_anom = (p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks + rem = (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) + dpa(i,j) = Pa_to_RL2_T2 * ((g_Earth*rho_anom)*dz - 2.0*eps*rem) + if (present(intz_dpa)) & + intz_dpa(i,j) = Pa_to_RL2_T2 * (0.5*(g_Earth*rho_anom)*dz**2 - dz*((1.0+eps)*rem)) + enddo ; enddo + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i+1,j)+z_b(i+1,j))) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( (g_Earth*dz) * ((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) ) + enddo + ! Use Boole's rule to integrate the values. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i,j+1) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i,j+1) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i,j+1) + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i,j+1)+z_b(i,j+1))) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( (g_Earth*dz) * ((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) ) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + +end subroutine int_density_dz_wright_red + +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, of geopotential +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! non-Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. +subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & + intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & + useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, intent(in) :: spv_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! The calculation is mathematically identical with different values of + !! spv_ref, but this reduces the effects of roundoff. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly + !! at the bottom of the layer [R L4 T-4 ~> Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the x grid spacing + !! [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the y grid spacing + !! [L2 T-2 ~> m2 s-2]. + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate + !! dza. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific + !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0 ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real :: p0 ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real :: lambda ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0_scale ! Scaling factor to convert al0 from MKS units [R-1 kg m-3 ~> 1] + real :: p0_scale ! Scaling factor to convert p0 from MKS units [R L2 T-2 Pa-1 ~> 1] + real :: lam_scale ! Scaling factor to convert lambda from MKS units [L2 s2 T-2 m-2 ~> 1] + real :: p_ave ! The layer average pressure [R L2 T-2 ~> Pa] + real :: rem ! [L2 T-2 ~> m2 s-2] + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: alpha_anom ! The depth averaged specific volume anomaly [R-1 ~> m3 kg-1]. + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa]. + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2]. + real :: I_pterm ! The inverse of p0 plus p_ave [T2 R-1 L-2 ~> Pa-1]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif + + + al0_scale = 1.0 ; if (present(SV_scale)) al0_scale = SV_scale + p0_scale = 1.0 + if (present(pres_scale)) then ; if (pres_scale /= 1.0) then + p0_scale = 1.0 / pres_scale + endif ; endif + lam_scale = al0_scale * p0_scale + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. +! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "bathyP must be present if useMassWghtInterp is present and true.") +! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) + do j=jsh,jeh ; do i=ish,ieh + al0_2d(i,j) = al0_scale * ( a0 + (a1s*T(i,j) + a2s*S(i,j)) ) + p0_2d(i,j) = p0_scale * ( b0 + ( b4s*S(i,j) + T(i,j) * (b1s + (T(i,j)*(b2s + b3s*T(i,j)) + b5s*S(i,j))) ) ) + lambda_2d(i,j) = lam_scale * ( c0 + ( c4s*S(i,j) + T(i,j) * (c1s + (T(i,j)*(c2s + c3s*T(i,j)) + c5s*S(i,j))) ) ) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + dp = p_b(i,j) - p_t(i,j) + p_ave = 0.5*(p_t(i,j)+p_b(i,j)) + I_pterm = 1.0 / (p0 + p_ave) + + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + alpha_anom = (al0 - spv_ref) + lambda * I_pterm + rem = (lambda * eps2) * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + dza(i,j) = alpha_anom*dp + 2.0*eps*rem + if (present(intp_dza)) & + intp_dza(i,j) = 0.5*alpha_anom*dp**2 - dp*((1.0-eps)*rem) + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j))) + I_pterm = 1.0 / (p0 + p_ave) + + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda * I_pterm)*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = wt_L*al0_2d(i,j) + wt_R*al0_2d(i,j+1) + p0 = wt_L*p0_2d(i,j) + wt_R*p0_2d(i,j+1) + lambda = wt_L*lambda_2d(i,j) + wt_R*lambda_2d(i,j+1) + + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1))) + I_pterm = 1.0 / (p0 + p_ave) + + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda * I_pterm)*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif +end subroutine int_spec_vol_dp_wright_red + +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_Wright_red(this, T, S, pressure, rho, start, npts, rho_ref) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_Wright_red(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_Wright_red(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_Wright_red + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_Wright_red(this, T, S, pressure, specvol, start, npts, spv_ref) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_Wright_red(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_Wright_red(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_Wright_red + + +!> \namespace mom_eos_wright_red +!! +!! \section section_EOS_Wright_red Wright equation of state +!! +!! Wright, 1997, provide an approximation for the in situ density as a function of +!! potential temperature, salinity, and pressure. The formula follow the Tumlirz +!! equation of state which are easier to evaluate and make efficient. +!! +!! Two ranges are provided by Wright: a "full" range and "reduced" range. The version in this +!! module uses the reduced range. +!! +!! Originally coded in 2000 by R. Hallberg. +!! Anomaly form coded in 3/18. +!! +!! \subsection section_EOS_Wright_red_references References +!! +!! Wright, D., 1997: An Equation of State for Use in Ocean Models: Eckart's Formula Revisited. +!! J. Ocean. Atmosph. Tech., 14 (3), 735-740. +!! https://journals.ametsoc.org/doi/abs/10.1175/1520-0426%281997%29014%3C0735%3AAEOSFU%3E2.0.CO%3B2 + +end module MOM_EOS_Wright_red diff --git a/equation_of_state/MOM_EOS_base_type.F90 b/equation_of_state/MOM_EOS_base_type.F90 new file mode 100644 index 0000000000..a6e5a21309 --- /dev/null +++ b/equation_of_state/MOM_EOS_base_type.F90 @@ -0,0 +1,464 @@ +!> A generic type for equations of state +module MOM_EOS_base_type + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public EOS_base + +!> The base class for implementations of the equation of state +type, abstract :: EOS_base + +contains + + ! The following functions/subroutines are deferred and must be provided specifically by each EOS + + !> Deferred implementation of the in-situ density as an elemental function [kg m-3] + procedure(i_density_elem), deferred :: density_elem + !> Deferred implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure(i_density_anomaly_elem), deferred :: density_anomaly_elem + !> Deferred implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure(i_spec_vol_elem), deferred :: spec_vol_elem + !> Deferred implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure(i_spec_vol_anomaly_elem), deferred :: spec_vol_anomaly_elem + !> Deferred implementation of the calculation of derivatives of density + procedure(i_calculate_density_derivs_elem), deferred :: calculate_density_derivs_elem + !> Deferred implementation of the calculation of second derivatives of density + procedure(i_calculate_density_second_derivs_elem), deferred :: calculate_density_second_derivs_elem + !> Deferred implementation of the calculation of derivatives of specific volume + procedure(i_calculate_specvol_derivs_elem), deferred :: calculate_specvol_derivs_elem + !> Deferred implementation of the calculation of compressibility + procedure(i_calculate_compress_elem), deferred :: calculate_compress_elem + !> Deferred implementation of the range query function + procedure(i_EOS_fit_range), deferred :: EOS_fit_range + + ! The following functions/subroutines are shared across all EOS and provided by this module + !> Returns the in-situ density or density anomaly [kg m-3] + procedure :: density_fn => a_density_fn + !> Returns the in-situ specific volume or specific volume anomaly [m3 kg-1] + procedure :: spec_vol_fn => a_spec_vol_fn + !> Calculates the in-situ density or density anomaly for scalar inputs [m3 kg-1] + procedure :: calculate_density_scalar => a_calculate_density_scalar + !> Calculates the in-situ density or density anomaly for array inputs [m3 kg-1] + procedure :: calculate_density_array => a_calculate_density_array + !> Calculates the in-situ specific volume or specific volume anomaly for scalar inputs [m3 kg-1] + procedure :: calculate_spec_vol_scalar => a_calculate_spec_vol_scalar + !> Calculates the in-situ specific volume or specific volume anomaly for array inputs [m3 kg-1] + procedure :: calculate_spec_vol_array => a_calculate_spec_vol_array + !> Calculates the derivatives of density for scalar inputs + procedure :: calculate_density_derivs_scalar => a_calculate_density_derivs_scalar + !> Calculates the derivatives of density for array inputs + procedure :: calculate_density_derivs_array => a_calculate_density_derivs_array + !> Calculates the second derivatives of density for scalar inputs + procedure :: calculate_density_second_derivs_scalar => a_calculate_density_second_derivs_scalar + !> Calculates the second derivatives of density for array inputs + procedure :: calculate_density_second_derivs_array => a_calculate_density_second_derivs_array + !> Calculates the derivatives of specific volume for array inputs + procedure :: calculate_specvol_derivs_array => a_calculate_specvol_derivs_array + !> Calculates the compressibility for array inputs + procedure :: calculate_compress_array => a_calculate_compress_array + +end type EOS_base + +interface + + !> In situ density [kg m-3] + !! + !! This is an elemental function that can be applied to any combination of scalar and array inputs. + real elemental function i_density_elem(this, T, S, pressure) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + end function i_density_elem + + !> In situ density anomaly [kg m-3] + !! + !! This is an elemental function that can be applied to any combination of scalar and array inputs. + real elemental function i_density_anomaly_elem(this, T, S, pressure, rho_ref) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: rho_ref !< A reference density [kg m-3] + + end function i_density_anomaly_elem + + !> In situ specific volume [m3 kg-1] + !! + !! This is an elemental function that can be applied to any combination of scalar and array inputs. + real elemental function i_spec_vol_elem(this, T, S, pressure) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + end function i_spec_vol_elem + + !> In situ specific volume anomaly [m3 kg-1] + !! + !! This is an elemental function that can be applied to any combination of scalar and array inputs. + real elemental function i_spec_vol_anomaly_elem(this, T, S, pressure, spv_ref) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + end function i_spec_vol_anomaly_elem + + !> Calculate the partial derivatives of density with potential temperature and salinity + elemental subroutine i_calculate_density_derivs_elem(this, T, S, pressure, drho_dT, drho_dS) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + + end subroutine i_calculate_density_derivs_elem + + !> Calculate the partial derivatives of specific volume with temperature and salinity + elemental subroutine i_calculate_specvol_derivs_elem(this, T, S, pressure, dSV_dT, dSV_dS) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + + end subroutine i_calculate_specvol_derivs_elem + + !> Calculate second derivatives of density with respect to temperature, salinity, and pressure + elemental subroutine i_calculate_density_second_derivs_elem(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + end subroutine i_calculate_density_second_derivs_elem + + !> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) + !! at the given salinity, potential temperature and pressure + elemental subroutine i_calculate_compress_elem(this, T, S, pressure, rho, drho_dp) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure (or + !! the inverse of the square of sound speed) [s2 m-2] + + end subroutine i_calculate_compress_elem + + !> Return the range of temperatures, salinities and pressures for which the equations of state has been + !! fitted or is valid. Care should be taken when applying this equation of state outside of its fit range. + subroutine i_EOS_fit_range(this, T_min, T_max, S_min, S_max, p_min, p_max) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + end subroutine i_EOS_fit_range + +end interface + +contains + + !> In situ density [kg m-3] + real function a_density_fn(this, T, S, pressure, rho_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + if (present(rho_ref)) then + a_density_fn = this%density_anomaly_elem(T, S, pressure, rho_ref) + else + a_density_fn = this%density_elem(T, S, pressure) + endif + + end function a_density_fn + + !> Calculate the in-situ density for scalar inputs and outputs. + subroutine a_calculate_density_scalar(this, T, S, pressure, rho, rho_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + if (present(rho_ref)) then + rho = this%density_anomaly_elem(T, S, pressure, rho_ref) + else + rho = this%density_elem(T, S, pressure) + endif + + end subroutine a_calculate_density_scalar + + !> Calculate the in-situ density for 1D arraya inputs and outputs. + subroutine a_calculate_density_array(this, T, S, pressure, rho, start, npts, rho_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + if (present(rho_ref)) then + rho(js:je) = this%density_anomaly_elem(T(js:je), S(js:je), pressure(js:je), rho_ref) + else + rho(js:je) = this%density_elem(T(js:je), S(js:je), pressure(js:je)) + endif + + end subroutine a_calculate_density_array + + !> In situ specific volume [m3 kg-1] + real function a_spec_vol_fn(this, T, S, pressure, spv_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + if (present(spv_ref)) then + a_spec_vol_fn = this%spec_vol_anomaly_elem(T, S, pressure, spv_ref) + else + a_spec_vol_fn = this%spec_vol_elem(T, S, pressure) + endif + + end function a_spec_vol_fn + + !> Calculate the in-situ specific volume for scalar inputs and outputs. + subroutine a_calculate_spec_vol_scalar(this, T, S, pressure, specvol, spv_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: specvol !< In situ specific volume [m3 kg-1] + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + if (present(spv_ref)) then + specvol = this%spec_vol_anomaly_elem(T, S, pressure, spv_ref) + else + specvol = this%spec_vol_elem(T, S, pressure) + endif + + end subroutine a_calculate_spec_vol_scalar + + !> Calculate the in-situ specific volume for 1D array inputs and outputs. + subroutine a_calculate_spec_vol_array(this, T, S, pressure, specvol, start, npts, spv_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + if (present(spv_ref)) then + specvol(js:je) = this%spec_vol_anomaly_elem(T(js:je), S(js:je), pressure(js:je), spv_ref) + else + specvol(js:je) = this%spec_vol_elem(T(js:je), S(js:je), pressure(js:je) ) + endif + + end subroutine a_calculate_spec_vol_array + + !> Calculate the derivatives of density with respect to temperature, salinity and pressure + !! for scalar inputs + subroutine a_calculate_density_derivs_scalar(this, T, S, P, drho_dT, drho_dS) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: P !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + + call this%calculate_density_derivs_elem(T, S, P, drho_dt, drho_ds) + + end subroutine a_calculate_density_derivs_scalar + + !> Calculate the derivatives of density with respect to temperature, salinity and pressure + !! for array inputs + subroutine a_calculate_density_derivs_array(this, T, S, pressure, drho_dT, drho_dS, start, npts) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, dimension(:), intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + call this%calculate_density_derivs_elem(T(js:je), S(js:je), pressure(js:je), drho_dt(js:je), drho_ds(js:je)) + + end subroutine a_calculate_density_derivs_array + + !> Calculate the second derivatives of density with respect to temperature, salinity and pressure + !! for scalar inputs + subroutine a_calculate_density_second_derivs_scalar(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(out) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(out) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + call this%calculate_density_second_derivs_elem(T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + + end subroutine a_calculate_density_second_derivs_scalar + + !> Calculate the second derivatives of density with respect to temperature, salinity and pressure + !! for array inputs + subroutine a_calculate_density_second_derivs_array(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp, start, npts) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature referenced to 0 dbar + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, dimension(:), intent(out) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, dimension(:), intent(out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, dimension(:), intent(out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(:), intent(out) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + call this%calculate_density_second_derivs_elem(T(js:je), S(js:je), pressure(js:je), & + drho_ds_ds(js:je), drho_ds_dt(js:je), drho_dt_dt(js:je), & + drho_ds_dp(js:je), drho_dt_dp(js:je)) + + end subroutine a_calculate_density_second_derivs_array + + !> Calculate the partial derivatives of specific volume with temperature and salinity + !! for array inputs + subroutine a_calculate_specvol_derivs_array(this, T, S, pressure, dSV_dT, dSV_dS, start, npts) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + call this%calculate_specvol_derivs_elem(T(js:je), S(js:je), pressure(js:je), & + dSV_dT(js:je), dSV_dS(js:je)) + + end subroutine a_calculate_specvol_derivs_array + + !> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) + !! at the given salinity, potential temperature and pressure for array inputs + subroutine a_calculate_compress_array(this, T, S, pressure, rho, drho_dp, start, npts) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + real, dimension(:), intent(out) :: drho_dp !< The partial derivative of density with pressure (or + !! the inverse of the square of sound speed) [s2 m-2] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + call this%calculate_compress_elem(T(js:je), S(js:je), pressure(js:je), & + rho(js:je), drho_dp(js:je)) + + end subroutine a_calculate_compress_array + +!> \namespace mom_eos_base_type +!! +!! \section section_EOS_base_type Generic EOS type +!! + +end module MOM_EOS_base_type diff --git a/equation_of_state/MOM_EOS_linear.F90 b/equation_of_state/MOM_EOS_linear.F90 new file mode 100644 index 0000000000..8984fbca88 --- /dev/null +++ b/equation_of_state/MOM_EOS_linear.F90 @@ -0,0 +1,661 @@ +!> A simple linear equation of state for sea water with constant coefficients +module MOM_EOS_linear + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS_base_type, only : EOS_base +use MOM_hor_index, only : hor_index_type + +implicit none ; private + +public linear_EOS +public int_density_dz_linear +public int_spec_vol_dp_linear +public avg_spec_vol_linear + +!> The EOS_base implementation of a linear equation of state +type, extends (EOS_base) :: linear_EOS + + real :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + real :: dRho_dT !< The derivative of density with temperature [kg m-3 degC-1]. + real :: dRho_dS !< The derivative of density with salinity [kg m-3 ppt-1]. + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_linear + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_linear + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_linear + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_linear + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_linear + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_linear + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_linear + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_linear + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_linear + + !> Instance specific function to set internal parameters + procedure :: set_params_linear => set_params_linear + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_linear + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_linear + +end type linear_EOS + +contains + +!> Density computed as a linear function of T and S [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of +!! scalar and array inputs. +real elemental function density_elem_linear(this, T, S, pressure) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + + density_elem_linear = this%Rho_T0_S0 + this%dRho_dT*T + this%dRho_dS*S + +end function density_elem_linear + +!> Density anomaly computed as a linear function of T and S [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of +!! scalar and array inputs. +real elemental function density_anomaly_elem_linear(this, T, S, pressure, rho_ref) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: rho_ref !< A reference density [kg m-3] + + density_anomaly_elem_linear = (this%Rho_T0_S0 - rho_ref) + (this%dRho_dT*T + this%dRho_dS*S) + +end function density_anomaly_elem_linear + +!> Specific volume using a linear equation of state for density [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of +!! scalar and array inputs. +real elemental function spec_vol_elem_linear(this, T, S, pressure) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. + real, intent(in) :: pressure !< Pressure [Pa]. + + spec_vol_elem_linear = 1.0 / ( this%Rho_T0_S0 + (this%dRho_dT*T + this%dRho_dS*S)) + +end function spec_vol_elem_linear + +!> Specific volume anomaly using a linear equation of state for density [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of +!! scalar and array inputs. +real elemental function spec_vol_anomaly_elem_linear(this, T, S, pressure, spv_ref) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. + real, intent(in) :: pressure !< Pressure [Pa]. + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + spec_vol_anomaly_elem_linear = ((1.0 - this%Rho_T0_S0*spv_ref) - & + spv_ref*(this%dRho_dT*T + this%dRho_dS*S)) / & + ( this%Rho_T0_S0 + (this%dRho_dT*T + this%dRho_dS*S)) + +end function spec_vol_anomaly_elem_linear + +!> This subroutine calculates the partial derivatives of density +!! with potential temperature and salinity. +elemental subroutine calculate_density_derivs_elem_linear(this,T, S, pressure, dRho_dT, dRho_dS) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. + real, intent(in) :: pressure !< Pressure [Pa]. + real, intent(out) :: drho_dT !< The partial derivative of density with + !! potential temperature [kg m-3 degC-1]. + real, intent(out) :: drho_dS !< The partial derivative of density with + !! salinity [kg m-3 ppt-1]. + + drho_dT = this%dRho_dT + drho_dS = this%dRho_dS + +end subroutine calculate_density_derivs_elem_linear + +!> This subroutine calculates the five, partial second derivatives of density w.r.t. +!! potential temperature and salinity and pressure which for a linear equation of state should all be 0. +elemental subroutine calculate_density_second_derivs_elem_linear(this, T, S, pressure, & + drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(inout) :: drho_dS_dS !< The second derivative of density with + !! salinity [kg m-3 ppt-2]. + real, intent(inout) :: drho_dS_dT !< The second derivative of density with + !! temperature and salinity [kg m-3 ppt-1 degC-1]. + real, intent(inout) :: drho_dT_dT !< The second derivative of density with + !! temperature [kg m-3 degC-2]. + real, intent(inout) :: drho_dS_dP !< The second derivative of density with + !! salinity and pressure [kg m-3 ppt-1 Pa-1]. + real, intent(inout) :: drho_dT_dP !< The second derivative of density with + !! temperature and pressure [kg m-3 degC-1 Pa-1]. + + drho_dS_dS = 0. + drho_dS_dT = 0. + drho_dT_dT = 0. + drho_dS_dP = 0. + drho_dT_dP = 0. + +end subroutine calculate_density_second_derivs_elem_linear + +!> Calculate the derivatives of specific volume with temperature and salinity +elemental subroutine calculate_specvol_derivs_elem_linear(this, T, S, pressure, dSV_dT, dSV_dS) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< pressure [Pa] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 ppt-1] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + ! Local variables + real :: I_rho2 ! The inverse of density squared [m6 kg-2] + + ! Sv = 1.0 / (Rho_T0_S0 + dRho_dT*T + dRho_dS*S) + I_rho2 = 1.0 / (this%Rho_T0_S0 + (this%dRho_dT*T + this%dRho_dS*S))**2 + dSV_dT = -this%dRho_dT * I_rho2 + dSV_dS = -this%dRho_dS * I_rho2 + +end subroutine calculate_specvol_derivs_elem_linear + +!> This subroutine computes the in situ density of sea water (rho) +!! and the compressibility (drho/dp == C_sound^-2) at the given +!! salinity, potential temperature, and pressure. +elemental subroutine calculate_compress_elem_linear(this, T, S, pressure, rho, drho_dp) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: rho !< In situ density [kg m-3]. + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2]. + + rho = this%Rho_T0_S0 + this%dRho_dT*T + this%dRho_dS*S + drho_dp = 0.0 + +end subroutine calculate_compress_elem_linear + +!> Calculates the layer average specific volumes. +subroutine avg_spec_vol_linear(T, S, p_t, dp, SpV_avg, start, npts, Rho_T0_S0, dRho_dT, dRho_dS) + real, dimension(:), intent(in) :: T !< Potential temperature [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [m3 kg-1] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3] + real, intent(in) :: dRho_dT !< The derivative of density with temperature + !! [kg m-3 degC-1] + real, intent(in) :: dRho_dS !< The derivative of density with salinity + !! [kg m-3 ppt-1] + ! Local variables + integer :: j + + do j=start,start+npts-1 + SpV_avg(j) = 1.0 / (Rho_T0_S0 + (dRho_dT*T(j) + dRho_dS*S(j))) + enddo +end subroutine avg_spec_vol_linear + +!> Return the range of temperatures, salinities and pressures for which the reduced-range equation +!! of state from Wright (1997) has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range_linear(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(linear_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum salinity over which this EoS is fitted [ppt] + real, optional, intent(out) :: S_max !< The maximum salinity over which this EoS is fitted [ppt] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -273.0 + if (present(T_max)) T_max = 100.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 1000.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e9 + +end subroutine EoS_fit_range_linear + +!> Set coefficients for the linear equation of state +subroutine set_params_linear(this, Rho_T0_S0, dRho_dT, dRho_dS) + class(linear_EOS), intent(inout) :: this !< This EOS + real, optional, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3] + real, optional, intent(in) :: dRho_dT !< The derivative of density with temperature, + !! [kg m-3 degC-1] + real, optional, intent(in) :: dRho_dS !< The derivative of density with salinity, + !! in [kg m-3 ppt-1] + + if (present(Rho_T0_S0)) this%Rho_T0_S0 = Rho_T0_S0 + if (present(dRho_dT)) this%dRho_dT = dRho_dT + if (present(dRho_dS)) this%dRho_dS = dRho_dS + +end subroutine set_params_linear + +!> This subroutine calculates analytical and nearly-analytical integrals of +!! pressure anomalies across layers, which are required for calculating the +!! finite-volume form pressure accelerations in a Boussinesq model. +subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & + Rho_T0_S0, dRho_dT, dRho_dS, dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> ppt]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that + !! is subtracted out to reduce the magnitude of + !! each of the integrals. + real, intent(in) :: rho_0_pres !< A density [R ~> kg m-3], used to calculate + !! the pressure (as p~=-z*rho_0_pres*G_e) used in + !! the equation of state. rho_0_pres is not used. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] + real, intent(in) :: dRho_dT !< The derivative of density with temperature, + !! [R C-1 ~> kg m-3 degC-1] + real, intent(in) :: dRho_dS !< The derivative of density with salinity, + !! in [R S-1 ~> kg m-3 ppt-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(out) :: dpa !< The change in the pressure anomaly across the + !! layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(out) :: intz_dpa !< The integral through the thickness of the layer + !! of the pressure anomaly relative to the anomaly + !! at the top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(out) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(out) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + + ! Local variables + real :: rho_anom ! The density anomaly from rho_ref [R ~> kg m-3]. + real :: raL, raR ! rho_anom to the left and right [R ~> kg m-3]. + real :: dz, dzL, dzR ! Layer thicknesses [Z ~> m]. + real :: hWght ! A pressure-thickness below topography [Z ~> m]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intz(5) ! The integrals of density with height at the + ! 5 sub-column locations [R L2 T-2 ~> Pa] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants [nondim]. + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "bathyT must be present if useMassWghtInterp is present and true.") + ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dz = z_t(i,j) - z_b(i,j) + rho_anom = (Rho_T0_S0 - rho_ref) + dRho_dT*T(i,j) + dRho_dS*S(i,j) + dpa(i,j) = G_e*rho_anom*dz + if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*rho_anom*dz**2 + enddo ; enddo + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + + if (hWght <= 0.0) then + dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i+1,j) - z_b(i+1,j) + raL = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j) + dRho_dS*S(i,j)) + raR = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j)) + + intx_dpa(i,j) = G_e*C1_6 * (dzL*(2.0*raL + raR) + dzR*(2.0*raR + raL)) + else + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + rho_anom = (Rho_T0_S0 - rho_ref) + & + (dRho_dT * (wtT_L*T(i,j) + wtT_R*T(i+1,j)) + & + dRho_dS * (wtT_L*S(i,j) + wtT_R*S(i+1,j))) + intz(m) = G_e*rho_anom*dz + enddo + ! Use Boole's rule to integrate the values. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + endif + enddo ; enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + + if (hWght <= 0.0) then + dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i,j+1) - z_b(i,j+1) + raL = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j) + dRho_dS*S(i,j)) + raR = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1)) + + inty_dpa(i,j) = G_e*C1_6 * (dzL*(2.0*raL + raR) + dzR*(2.0*raR + raL)) + else + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + rho_anom = (Rho_T0_S0 - rho_ref) + & + (dRho_dT * (wtT_L*T(i,j) + wtT_R*T(i,j+1)) + & + dRho_dS * (wtT_L*S(i,j) + wtT_R*S(i,j+1))) + intz(m) = G_e*rho_anom*dz + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + endif + + enddo ; enddo ; endif +end subroutine int_density_dz_linear + +!> Calculates analytical and nearly-analytical integrals in +!! pressure across layers of geopotential anomalies, which are required for +!! calculating the finite-volume form pressure accelerations in a non-Boussinesq +!! model. Specific volume is assumed to vary linearly between adjacent points. +subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & + dRho_dT, dRho_dS, dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> ppt]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! The calculation is mathematically identical with different values of + !! alpha_ref, but this reduces the effects of roundoff. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] + real, intent(in) :: dRho_dT !< The derivative of density with temperature + !! [R C-1 ~> kg m-3 degC-1] + real, intent(in) :: dRho_dS !< The derivative of density with salinity, + !! in [R S-1 ~> kg m-3 ppt-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(out) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(out) :: intp_dza !< The integral in pressure through the layer of the + !! geopotential anomaly relative to the anomaly at the + !! bottom of the layer [R L4 T-4 ~> Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(out) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the x grid spacing + !! [L2 T-2 ~> m2 s-2] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(out) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the y grid spacing + !! [L2 T-2 ~> m2 s-2] + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + ! Local variables + real :: dRho_TS ! The density anomaly due to T and S [R ~> kg m-3] + real :: alpha_anom ! The specific volume anomaly from 1/rho_ref [R-1 ~> m3 kg-1] + real :: aaL, aaR ! The specific volume anomaly to the left and right [R-1 ~> m3 kg-1] + real :: dp, dpL, dpR ! Layer pressure thicknesses [R L2 T-2 ~> Pa] + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants [nondim]. + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. +! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "bathyP must be present if useMassWghtInterp is present and true.") +! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=jsh,jeh ; do i=ish,ieh + dp = p_b(i,j) - p_t(i,j) + dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) + ! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref + alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + dza(i,j) = alpha_anom*dp + if (present(intp_dza)) intp_dza(i,j) = 0.5*alpha_anom*dp**2 + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + + if (hWght <= 0.0) then + dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i+1,j) - p_t(i+1,j) + dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) + aaL = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + dRho_TS = dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j) + aaR = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + + intx_dza(i,j) = C1_6 * (2.0*(dpL*aaL + dpR*aaR) + (dpL*aaR + dpR*aaL)) + else + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + + dRho_TS = dRho_dT*(wtT_L*T(i,j) + wtT_R*T(i+1,j)) + & + dRho_dS*(wtT_L*S(i,j) + wtT_R*S(i+1,j)) + ! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref + alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + intp(m) = alpha_anom*dp + enddo + ! Use Boole's rule to integrate the interface height anomaly values in y. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + endif + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + + if (hWght <= 0.0) then + dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i,j+1) - p_t(i,j+1) + dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) + aaL = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + dRho_TS = dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1) + aaR = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + + inty_dza(i,j) = C1_6 * (2.0*(dpL*aaL + dpR*aaR) + (dpL*aaR + dpR*aaL)) + else + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + + dRho_TS = dRho_dT*(wtT_L*T(i,j) + wtT_R*T(i,j+1)) + & + dRho_dS*(wtT_L*S(i,j) + wtT_R*S(i,j+1)) + ! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref + alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + intp(m) = alpha_anom*dp + enddo + ! Use Boole's rule to integrate the interface height anomaly values in y. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + endif + enddo ; enddo ; endif +end subroutine int_spec_vol_dp_linear + +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_linear(this, T, S, pressure, rho, start, npts, rho_ref) + class(linear_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_linear(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_linear(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_linear + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_linear(this, T, S, pressure, specvol, start, npts, spv_ref) + class(linear_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_linear(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_linear(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_linear + +end module MOM_EOS_linear diff --git a/equation_of_state/MOM_TFreeze.F90 b/equation_of_state/MOM_TFreeze.F90 new file mode 100644 index 0000000000..faa103d094 --- /dev/null +++ b/equation_of_state/MOM_TFreeze.F90 @@ -0,0 +1,253 @@ +!> Freezing point expressions +module MOM_TFreeze + +! This file is part of MOM6. See LICENSE.md for the license. + +!********+*********+*********+*********+*********+*********+*********+** +!* The subroutines in this file determine the potential temperature * +!* or conservative temperature at which sea-water freezes. * +!********+*********+*********+*********+*********+*********+*********+** +use gsw_mod_toolbox, only : gsw_ct_freezing_exact + +implicit none ; private + +public calculate_TFreeze_linear, calculate_TFreeze_Millero, calculate_TFreeze_teos10 +public calculate_TFreeze_TEOS_poly + +!> Compute the freezing point potential temperature [degC] from salinity [ppt] and +!! pressure [Pa] using a simple linear expression, with coefficients passed in as arguments. +interface calculate_TFreeze_linear + module procedure calculate_TFreeze_linear_scalar, calculate_TFreeze_linear_array +end interface calculate_TFreeze_linear + +!> Compute the freezing point potential temperature [degC] from salinity [PSU] and +!! pressure [Pa] using the expression from Millero (1978) (and in appendix A of Gill 1982), +!! but with the of the pressure dependence changed from 7.53e-8 to 7.75e-8 to make this an +!! expression for potential temperature (not in situ temperature), using a +!! value that is correct at the freezing point at 35 PSU and 5e6 Pa (500 dbar). +interface calculate_TFreeze_Millero + module procedure calculate_TFreeze_Millero_scalar, calculate_TFreeze_Millero_array +end interface calculate_TFreeze_Millero + +!> Compute the freezing point conservative temperature [degC] from absolute salinity [g kg-1] +!! and pressure [Pa] using the TEOS10 package. +interface calculate_TFreeze_teos10 + module procedure calculate_TFreeze_teos10_scalar, calculate_TFreeze_teos10_array +end interface calculate_TFreeze_teos10 + +!> Compute the freezing point conservative temperature [degC] from absolute salinity [g kg-1] and +!! pressure [Pa] using a rescaled and refactored version of the expressions from the TEOS10 package. +interface calculate_TFreeze_TEOS_poly + module procedure calculate_TFreeze_TEOS_poly_scalar, calculate_TFreeze_TEOS_poly_array +end interface calculate_TFreeze_TEOS_poly + +contains + +!> This subroutine computes the freezing point potential temperature [degC] from +!! salinity [ppt], and pressure [Pa] using a simple linear expression, +!! with coefficients passed in as arguments. +subroutine calculate_TFreeze_linear_scalar(S, pres, T_Fr, TFr_S0_P0, & + dTFr_dS, dTFr_dp) + real, intent(in) :: S !< salinity [ppt]. + real, intent(in) :: pres !< pressure [Pa]. + real, intent(out) :: T_Fr !< Freezing point potential temperature [degC]. + real, intent(in) :: TFr_S0_P0 !< The freezing point at S=0, p=0 [degC]. + real, intent(in) :: dTFr_dS !< The derivative of freezing point with salinity, + !! [degC ppt-1]. + real, intent(in) :: dTFr_dp !< The derivative of freezing point with pressure, + !! [degC Pa-1]. + + T_Fr = (TFr_S0_P0 + dTFr_dS*S) + dTFr_dp*pres + +end subroutine calculate_TFreeze_linear_scalar + +!> This subroutine computes an array of freezing point potential temperatures +!! [degC] from salinity [ppt], and pressure [Pa] using a simple +!! linear expression, with coefficients passed in as arguments. +subroutine calculate_TFreeze_linear_array(S, pres, T_Fr, start, npts, & + TFr_S0_P0, dTFr_dS, dTFr_dp) + real, dimension(:), intent(in) :: S !< salinity [ppt]. + real, dimension(:), intent(in) :: pres !< pressure [Pa]. + real, dimension(:), intent(out) :: T_Fr !< Freezing point potential temperature [degC]. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, intent(in) :: TFr_S0_P0 !< The freezing point at S=0, p=0, [degC]. + real, intent(in) :: dTFr_dS !< The derivative of freezing point with salinity, + !! [degC ppt-1]. + real, intent(in) :: dTFr_dp !< The derivative of freezing point with pressure, + !! [degC Pa-1]. + integer :: j + + do j=start,start+npts-1 + T_Fr(j) = (TFr_S0_P0 + dTFr_dS*S(j)) + dTFr_dp*pres(j) + enddo + +end subroutine calculate_TFreeze_linear_array + +!> This subroutine computes the freezing point potential temperature +!! [degC] from salinity [ppt], and pressure [Pa] using the expression +!! from Millero (1978) (and in appendix A of Gill 1982), but with the of the +!! pressure dependence changed from 7.53e-8 to 7.75e-8 to make this an +!! expression for potential temperature (not in situ temperature), using a +!! value that is correct at the freezing point at 35 PSU and 5e6 Pa (500 dbar). +subroutine calculate_TFreeze_Millero_scalar(S, pres, T_Fr) + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pres !< Pressure [Pa] + real, intent(out) :: T_Fr !< Freezing point potential temperature [degC] + + ! Local variables + real, parameter :: cS1 = -0.0575 ! A term in the freezing point fit [degC PSU-1] + real, parameter :: cS3_2 = 1.710523e-3 ! A term in the freezing point fit [degC PSU-3/2] + real, parameter :: cS2 = -2.154996e-4 ! A term in the freezing point fit [degC PSU-2] + real, parameter :: dTFr_dp = -7.75e-8 ! Derivative of freezing point with pressure [degC Pa-1] + + T_Fr = S*(cS1 + (cS3_2 * sqrt(max(S, 0.0)) + cS2 * S)) + dTFr_dp*pres + +end subroutine calculate_TFreeze_Millero_scalar + +!> This subroutine computes the freezing point potential temperature +!! [degC] from salinity [ppt], and pressure [Pa] using the expression +!! from Millero (1978) (and in appendix A of Gill 1982), but with the +!! pressure dependence changed from 7.53e-8 to 7.75e-8 to make this an +!! expression for potential temperature (not in situ temperature), using a +!! value that is correct at the freezing point at 35 PSU and 5e6 Pa (500 dbar). +subroutine calculate_TFreeze_Millero_array(S, pres, T_Fr, start, npts) + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: pres !< Pressure [Pa]. + real, dimension(:), intent(out) :: T_Fr !< Freezing point potential temperature [degC]. + integer, intent(in) :: start !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. + + ! Local variables + real, parameter :: cS1 = -0.0575 ! A term in the freezing point fit [degC PSU-1] + real, parameter :: cS3_2 = 1.710523e-3 ! A term in the freezing point fit [degC PSU-3/2] + real, parameter :: cS2 = -2.154996e-4 ! A term in the freezing point fit [degC PSU-2] + real, parameter :: dTFr_dp = -7.75e-8 ! Derivative of freezing point with pressure [degC Pa-1] + integer :: j + + do j=start,start+npts-1 + T_Fr(j) = S(j)*(cS1 + (cS3_2 * sqrt(max(S(j), 0.0)) + cS2 * S(j))) + & + dTFr_dp*pres(j) + enddo + +end subroutine calculate_TFreeze_Millero_array + +!> This subroutine computes the freezing point conservative temperature [degC] +!! from absolute salinity [g kg-1], and pressure [Pa] using a rescaled and +!! refactored version of the polynomial expressions from the TEOS10 package. +subroutine calculate_TFreeze_TEOS_poly_scalar(S, pres, T_Fr) + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pres !< Pressure [Pa]. + real, intent(out) :: T_Fr !< Freezing point conservative temperature [degC]. + + ! Local variables + real, dimension(1) :: S0 ! Salinity at a point [g kg-1] + real, dimension(1) :: pres0 ! Pressure at a point [Pa] + real, dimension(1) :: tfr0 ! The freezing temperature [degC] + + S0(1) = S + pres0(1) = pres + + call calculate_TFreeze_TEOS_poly_array(S0, pres0, tfr0, 1, 1) + T_Fr = tfr0(1) + +end subroutine calculate_TFreeze_TEOS_poly_scalar + +!> This subroutine computes the freezing point conservative temperature [degC] +!! from absolute salinity [g kg-1], and pressure [Pa] using a rescaled and +!! refactored version of the polynomial expressions from the TEOS10 package. +subroutine calculate_TFreeze_TEOS_poly_array(S, pres, T_Fr, start, npts) + real, dimension(:), intent(in) :: S !< absolute salinity [g kg-1]. + real, dimension(:), intent(in) :: pres !< Pressure [Pa]. + real, dimension(:), intent(out) :: T_Fr !< Freezing point conservative temperature [degC]. + integer, intent(in) :: start !< The starting point in the arrays + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + real :: Sa ! Absolute salinity [g kg-1] = [ppt] + real :: rS ! Square root of salinity [ppt1/2] + ! The coefficients here use the notation TFab for contributions proportional to S**a/2 * P**b. + real, parameter :: TF00 = 0.017947064327968736 ! Freezing point coefficient [degC] + real, parameter :: TF20 = -6.076099099929818e-2 ! Freezing point coefficient [degC ppt-1] + real, parameter :: TF30 = 4.883198653547851e-3 ! Freezing point coefficient [degC ppt-3/2] + real, parameter :: TF40 = -1.188081601230542e-3 ! Freezing point coefficient [degC ppt-2] + real, parameter :: TF50 = 1.334658511480257e-4 ! Freezing point coefficient [degC ppt-5/2] + real, parameter :: TF60 = -8.722761043208607e-6 ! Freezing point coefficient [degC ppt-3] + real, parameter :: TF70 = 2.082038908808201e-7 ! Freezing point coefficient [degC ppt-7/2] + real, parameter :: TF01 = -7.389420998107497e-8 ! Freezing point coefficient [degC Pa-1] + real, parameter :: TF21 = -9.891538123307282e-11 ! Freezing point coefficient [degC ppt-1 Pa-1] + real, parameter :: TF31 = -8.987150128406496e-13 ! Freezing point coefficient [degC ppt-3/2 Pa-1] + real, parameter :: TF41 = 1.054318231187074e-12 ! Freezing point coefficient [degC ppt-2 Pa-1] + real, parameter :: TF51 = 3.850133554097069e-14 ! Freezing point coefficient [degC ppt-5/2 Pa-1] + real, parameter :: TF61 = -2.079022768390933e-14 ! Freezing point coefficient [degC ppt-3 Pa-1] + real, parameter :: TF71 = 1.242891021876471e-15 ! Freezing point coefficient [degC ppt-7/2 Pa-1] + real, parameter :: TF02 = -2.110913185058476e-16 ! Freezing point coefficient [degC Pa-2] + real, parameter :: TF22 = 3.831132432071728e-19 ! Freezing point coefficient [degC ppt-1 Pa-2] + real, parameter :: TF32 = 1.065556599652796e-19 ! Freezing point coefficient [degC ppt-3/2 Pa-2] + real, parameter :: TF42 = -2.078616693017569e-20 ! Freezing point coefficient [degC ppt-2 Pa-2] + real, parameter :: TF52 = 1.596435439942262e-21 ! Freezing point coefficient [degC ppt-5/2 Pa-2] + real, parameter :: TF03 = 2.295491578006229e-25 ! Freezing point coefficient [degC Pa-3] + real, parameter :: TF23 = -7.997496801694032e-27 ! Freezing point coefficient [degC ppt-1 Pa-3] + real, parameter :: TF33 = 8.756340772729538e-28 ! Freezing point coefficient [degC ppt-3/2 Pa-3] + real, parameter :: TF43 = 1.338002171109174e-29 ! Freezing point coefficient [degC ppt-2 Pa-3] + integer :: j + + do j=start,start+npts-1 + rS = sqrt(max(S(j), 0.0)) + T_Fr(j) = (TF00 + S(j)*(TF20 + rS*(TF30 + rS*(TF40 + rS*(TF50 + rS*(TF60 + rS*TF70)))))) & + + pres(j)*( (TF01 + S(j)*(TF21 + rS*(TF31 + rS*(TF41 + rS*(TF51 + rS*(TF61 + rS*TF71)))))) & + + pres(j)*((TF02 + S(j)*(TF22 + rS*(TF32 + rS*(TF42 + rS* TF52)))) & + + pres(j)*(TF03 + S(j)*(TF23 + rS*(TF33 + rS* TF43))) ) ) + enddo + +end subroutine calculate_TFreeze_TEOS_poly_array + +!> This subroutine computes the freezing point conservative temperature [degC] +!! from absolute salinity [g kg-1], and pressure [Pa] using the +!! TEOS10 package. +subroutine calculate_TFreeze_teos10_scalar(S, pres, T_Fr) + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pres !< Pressure [Pa]. + real, intent(out) :: T_Fr !< Freezing point conservative temperature [degC]. + + ! Local variables + real, dimension(1) :: S0 ! Salinity at a point [g kg-1] + real, dimension(1) :: pres0 ! Pressure at a point [Pa] + real, dimension(1) :: tfr0 ! The freezing temperature [degC] + + S0(1) = S + pres0(1) = pres + + call calculate_TFreeze_teos10_array(S0, pres0, tfr0, 1, 1) + T_Fr = tfr0(1) + +end subroutine calculate_TFreeze_teos10_scalar + +!> This subroutine computes the freezing point conservative temperature [degC] +!! from absolute salinity [g kg-1], and pressure [Pa] using the +!! TEOS10 package. +subroutine calculate_TFreeze_teos10_array(S, pres, T_Fr, start, npts) + real, dimension(:), intent(in) :: S !< absolute salinity [g kg-1]. + real, dimension(:), intent(in) :: pres !< pressure [Pa]. + real, dimension(:), intent(out) :: T_Fr !< Freezing point conservative temperature [degC]. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + + ! Local variables + real, parameter :: Pa2db = 1.e-4 ! The conversion factor from Pa to dbar [dbar Pa-1] + real :: zp ! Pressures in [dbar] + integer :: j + ! Assume sea-water contains no dissolved air. + real, parameter :: saturation_fraction = 0.0 ! Air saturation fraction in seawater [nondim] + + do j=start,start+npts-1 + !Conversions + zp = pres(j)* Pa2db !Convert pressure from Pascal to decibar + + if (S(j) < -1.0e-10) cycle !Can we assume safely that this is a missing value? + T_Fr(j) = gsw_ct_freezing_exact(S(j), zp, saturation_fraction) + enddo + +end subroutine calculate_TFreeze_teos10_array + +end module MOM_TFreeze diff --git a/equation_of_state/MOM_temperature_convert.F90 b/equation_of_state/MOM_temperature_convert.F90 new file mode 100644 index 0000000000..ee4bc21e62 --- /dev/null +++ b/equation_of_state/MOM_temperature_convert.F90 @@ -0,0 +1,166 @@ +!> Functions to convert between conservative and potential temperature +module MOM_temperature_convert + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public poTemp_to_consTemp, consTemp_to_poTemp + +!>@{ Parameters in the temperature conversion code +real, parameter :: Sprac_Sref = (35.0/35.16504) ! The TEOS 10 conversion factor to go from + ! reference salinity to practical salinity [nondim] +real, parameter :: I_S0 = 0.025*Sprac_Sref ! The inverse of a plausible range of oceanic salinities [kg g-1] +real, parameter :: I_Ts = 0.025 ! The inverse of a plausible range of oceanic temperatures [degC-1] +real, parameter :: I_cp0 = 1.0/3991.86795711963 ! The inverse of the "specific heat" for use + ! with Conservative Temperature, as defined with TEOS10 [degC kg J-1] + +! The following are coefficients of contributions to conservative temperature as a function of the square root +! of normalized absolute salinity with an offset (zS) and potential temperature (T) with a contribution +! Hab * zS**a * T**b. The numbers here are copied directly from the corresponding gsw module, but +! the expressions here do not use the same nondimensionalization for pressure or temperature as they do. + +real, parameter :: H00 = 61.01362420681071*I_cp0 ! Tp to Tc fit constant [degC] +real, parameter :: H01 = 168776.46138048015*(I_cp0*I_Ts) ! Tp to Tc fit T coef. [nondim] +real, parameter :: H02 = -2735.2785605119625*(I_cp0*I_Ts**2) ! Tp to Tc fit T**2 coef. [degC-1] +real, parameter :: H03 = 2574.2164453821433*(I_cp0*I_Ts**3) ! Tp to Tc fit T**3 coef. [degC-2] +real, parameter :: H04 = -1536.6644434977543*(I_cp0*I_Ts**4) ! Tp to Tc fit T**4 coef. [degC-3] +real, parameter :: H05 = 545.7340497931629*(I_cp0*I_Ts**5) ! Tp to Tc fit T**5 coef. [degC-4] +real, parameter :: H06 = -50.91091728474331*(I_cp0*I_Ts**6) ! Tp to Tc fit T**6 coef. [degC-5] +real, parameter :: H07 = -18.30489878927802*(I_cp0*I_Ts**7) ! Tp to Tc fit T**7 coef. [degC-6] +real, parameter :: H20 = 268.5520265845071*I_cp0 ! Tp to Tc fit zS**2 coef. [degC] +real, parameter :: H21 = -12019.028203559312*(I_cp0*I_Ts) ! Tp to Tc fit zS**2 * T coef. [nondim] +real, parameter :: H22 = 3734.858026725145*(I_cp0*I_Ts**2) ! Tp to Tc fit zS**2 * T**2 coef. [degC-1] +real, parameter :: H23 = -2046.7671145057618*(I_cp0*I_Ts**3) ! Tp to Tc fit zS**2 * T**3 coef. [degC-2] +real, parameter :: H24 = 465.28655623826234*(I_cp0*I_Ts**4) ! Tp to Tc fit zS**2 * T**4 coef. [degC-3] +real, parameter :: H25 = -0.6370820302376359*(I_cp0*I_Ts**5) ! Tp to Tc fit zS**2 * T**5 coef. [degC-4] +real, parameter :: H26 = -10.650848542359153*(I_cp0*I_Ts**6) ! Tp to Tc fit zS**2 * T**6 coef. [degC-5] +real, parameter :: H30 = 937.2099110620707*I_cp0 ! Tp to Tc fit zS**3 coef. [degC] +real, parameter :: H31 = 588.1802812170108*(I_cp0*I_Ts) ! Tp to Tc fit zS** 3* T coef. [nondim] +real, parameter :: H32 = 248.39476522971285*(I_cp0*I_Ts**2) ! Tp to Tc fit zS**3 * T**2 coef. [degC-1] +real, parameter :: H33 = -3.871557904936333*(I_cp0*I_Ts**3) ! Tp to Tc fit zS**3 * T**3 coef. [degC-2] +real, parameter :: H34 = -2.6268019854268356*(I_cp0*I_Ts**4) ! Tp to Tc fit zS**3 * T**4 coef. [degC-3] +real, parameter :: H40 = -1687.914374187449*I_cp0 ! Tp to Tc fit zS**4 coef. [degC] +real, parameter :: H41 = 936.3206544460336*(I_cp0*I_Ts) ! Tp to Tc fit zS**4 * T coef. [nondim] +real, parameter :: H42 = -942.7827304544439*(I_cp0*I_Ts**2) ! Tp to Tc fit zS**4 * T**2 coef. [degC-1] +real, parameter :: H43 = 369.4389437509002*(I_cp0*I_Ts**3) ! Tp to Tc fit zS**4 * T**3 coef. [degC-2] +real, parameter :: H44 = -33.83664947895248*(I_cp0*I_Ts**4) ! Tp to Tc fit zS**4 * T**4 coef. [degC-3] +real, parameter :: H45 = -9.987880382780322*(I_cp0*I_Ts**5) ! Tp to Tc fit zS**4 * T**5 coef. [degC-4] +real, parameter :: H50 = 246.9598888781377*I_cp0 ! Tp to Tc fit zS**5 coef. [degC] +real, parameter :: H60 = 123.59576582457964*I_cp0 ! Tp to Tc fit zS**6 coef. [degC] +real, parameter :: H70 = -48.5891069025409*I_cp0 ! Tp to Tc fit zS**7 coef. [degC] + +!>@} + +contains + +!> Convert input potential temperature [degC] and absolute salinity [g kg-1] to returned +!! conservative temperature [degC] using the polynomial expressions from TEOS-10. +elemental real function poTemp_to_consTemp(T, Sa) result(Tc) + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: Sa !< Absolute salinity [g kg-1] + + ! Local variables + real :: x2 ! Absolute salinity normalized by a plausible salinity range [nondim] + real :: x ! Square root of normalized absolute salinity [nondim] + + x2 = max(I_S0 * Sa, 0.0) + x = sqrt(x2) + + Tc = H00 + (T*(H01 + T*(H02 + T*(H03 + T*(H04 + T*(H05 + T*(H06 + T* H07)))))) & + + x2*(H20 + (T*(H21 + T*(H22 + T*(H23 + T*(H24 + T*(H25 + T*H26))))) & + + x*(H30 + (T*(H31 + T*(H32 + T*(H33 + T* H34))) & + + x*(H40 + (T*(H41 + T*(H42 + T*(H43 + T*(H44 + T*H45)))) & + + x*(H50 + x*(H60 + x* H70)) )) )) )) ) + +end function poTemp_to_consTemp + + +!> Return the partial derivative of conservative temperature with potential temperature [nondim] +!! based on the polynomial expressions from TEOS-10. +elemental real function dTc_dTp(T, Sa) + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: Sa !< Absolute salinity [g kg-1] + + ! Local variables + real :: x2 ! Absolute salinity normalized by a plausible salinity range [nondim] + real :: x ! Square root of normalized absolute salinity [nondim] + + x2 = max(I_S0 * Sa, 0.0) + x = sqrt(x2) + + dTc_dTp = ( H01 + T*(2.*H02 + T*(3.*H03 + T*(4.*H04 + T*(5.*H05 + T*(6.*H06 + T*(7.*H07)))))) ) & + + x2*( (H21 + T*(2.*H22 + T*(3.*H23 + T*(4.*H24 + T*(5.*H25 + T*(6.*H26)))))) & + + x*( (H31 + T*(2.*H32 + T*(3.*H33 + T*(4.*H34)))) & + + x*(H41 + T*(2.*H42 + T*(3.*H43 + T*(4.*H44 + T*(5.*H45))))) ) ) + +end function dTc_dTp + + + +!> Convert input potential temperature [degC] and absolute salinity [g kg-1] to returned +!! conservative temperature [degC] by inverting the polynomial expressions from TEOS-10. +elemental real function consTemp_to_poTemp(Tc, Sa) result(Tp) + real, intent(in) :: Tc !< Conservative temperature [degC] + real, intent(in) :: Sa !< Absolute salinity [g kg-1] + + real :: Tp_num ! The numerator of a simple expression for potential temperature [degC] + real :: I_Tp_den ! The inverse of the denominator of a simple expression for potential temperature [nondim] + real :: Tc_diff ! The difference between an estimate of conservative temperature and its target [degC] + real :: Tp_old ! A previous estimate of the potential tempearture [degC] + real :: dTp_dTc ! The partial derivative of potential temperature with conservative temperature [nondim] + ! The following are coefficients in the nominator (TPNxx) or denominator (TPDxx) of a simple rational + ! expression that approximately converts conservative temperature to potential temperature. + real, parameter :: TPN00 = -1.446013646344788e-2 ! Simple fit numerator constant [degC] + real, parameter :: TPN10 = -3.305308995852924e-3*Sprac_Sref ! Simple fit numerator Sa coef. [degC ppt-1] + real, parameter :: TPN20 = 1.062415929128982e-4*Sprac_Sref**2 ! Simple fit numerator Sa**2 coef. [degC ppt-2] + real, parameter :: TPN01 = 9.477566673794488e-1 ! Simple fit numerator Tc coef. [nondim] + real, parameter :: TPN11 = 2.166591947736613e-3*Sprac_Sref ! Simple fit numerator Sa * Tc coef. [ppt-1] + real, parameter :: TPN02 = 3.828842955039902e-3 ! Simple fit numerator Tc**2 coef. [degC-1] + real, parameter :: TPD10 = 6.506097115635800e-4*Sprac_Sref ! Simple fit denominator Sa coef. [ppt-1] + real, parameter :: TPD01 = 3.830289486850898e-3 ! Simple fit denominator Tc coef. [degC-1] + real, parameter :: TPD02 = 1.247811760368034e-6 ! Simple fit denominator Tc**2 coef. [degC-2] + + ! Estimate the potential temperature and its derivative from an approximate rational function fit. + Tp_num = TPN00 + (Sa*(TPN10 + TPN20*Sa) + Tc*(TPN01 + (TPN11*Sa + TPN02*Tc))) + I_Tp_den = 1.0 / (1.0 + (TPD10*Sa + Tc*(TPD01 + TPD02*Tc))) + Tp = Tp_num*I_Tp_den + dTp_dTc = ((TPN01 + (TPN11*Sa + 2.*TPN02*Tc)) - (TPD01 + 2.*TPD02*Tc)*Tp)*I_Tp_den + + ! Start the 1.5 iterations through the modified Newton-Raphson iterative method, which is also known + ! as the Newton-McDougall method. In this case 1.5 iterations converge to 64-bit machine precision + ! for oceanographically relevant temperatures and salinities. + + Tc_diff = poTemp_to_consTemp(Tp, Sa) - Tc + Tp_old = Tp + Tp = Tp_old - Tc_diff*dTp_dTc + + dTp_dTc = 1.0 / dTc_dTp(0.5*(Tp + Tp_old), Sa) + + Tp = Tp_old - Tc_diff*dTp_dTc + Tc_diff = poTemp_to_consTemp(Tp, Sa) - Tc + Tp_old = Tp + + Tp = Tp_old - Tc_diff*dTp_dTc + +end function consTemp_to_poTemp + +!> \namespace MOM_temperature_conv +!! +!! \section MOM_temperature_conv Temperature conversions +!! +!! This module has functions that convert potential temperature to conservative temperature +!! and the reverse, as described in the TEOS-10 manual. This code was originally derived +!! from their corresponding routines in the gsw code package, but has had some refactoring so that the +!! answers are more likely to reproduce across compilers and levels of optimization. A complete +!! discussion of the thermodynamics of seawater and the definition of conservative temperature +!! can be found in IOC et al. (2010). +!! +!! \subsection section_temperature_conv_references References +!! +!! IOC, SCOR and IAPSO, 2010: The international thermodynamic equation of seawater - 2010: +!! Calculation and use of thermodynamic properties. Intergovernmental Oceanographic Commission, +!! Manuals and Guides No. 56, UNESCO (English), 196 pp. +!! (Available from www.teos-10.org/pubs/TEOS-10_Manual.pdf) + +end module MOM_temperature_convert diff --git a/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 b/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 new file mode 100644 index 0000000000..ca1ac55956 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 @@ -0,0 +1,82 @@ +!========================================================================== +elemental function gsw_chem_potential_water_t_exact (sa, t, p) +!========================================================================== +! +! Calculates the chemical potential of water in seawater. +! +! SA = Absolute Salinity [ g/kg ] +! t = in-situ temperature (ITS-90) [ deg C ] +! p = sea pressure [ dbar ] +! ( i.e. absolute pressure - 10.1325 dbar ) +! +! chem_potential_water_t_exact = chemical potential of water in seawater +! [ J/g ] +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_sfac + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, t, p + +real (r8) :: gsw_chem_potential_water_t_exact + +real (r8) :: g03_g, g08_g, g_sa_part, x, x2, y, z + +real (r8), parameter :: kg2g = 1e-3_r8 + +x2 = gsw_sfac*sa +x = sqrt(x2) +y = t*0.025_r8 +z = p*1e-4_r8 + +g03_g = 101.342743139674_r8 + z*(100015.695367145_r8 + & + z*(-2544.5765420363_r8 + z*(284.517778446287_r8 + & + z*(-33.3146754253611_r8 + (4.20263108803084_r8 - 0.546428511471039_r8*z)*z)))) + & + y*(5.90578347909402_r8 + z*(-270.983805184062_r8 + & + z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & + y*(-12357.785933039_r8 + z*(1455.0364540468_r8 + & + z*(-756.558385769359_r8 + z*(273.479662323528_r8 + z*(-55.5604063817218_r8 + 4.34420671917197_r8*z)))) + & + y*(736.741204151612_r8 + z*(-672.50778314507_r8 + & + z*(499.360390819152_r8 + z*(-239.545330654412_r8 + (48.8012518593872_r8 - 1.66307106208905_r8*z)*z))) + & + y*(-148.185936433658_r8 + z*(397.968445406972_r8 + & + z*(-301.815380621876_r8 + (152.196371733841_r8 - 26.3748377232802_r8*z)*z)) + & + y*(58.0259125842571_r8 + z*(-194.618310617595_r8 + & + z*(120.520654902025_r8 + z*(-55.2723052340152_r8 + 6.48190668077221_r8*z))) + & + y*(-18.9843846514172_r8 + y*(3.05081646487967_r8 - 9.63108119393062_r8*z) + & + z*(63.5113936641785_r8 + z*(-22.2897317140459_r8 + 8.17060541818112_r8*z)))))))) + +g08_g = x2*(1416.27648484197_r8 + & + x*(-2432.14662381794_r8 + x*(2025.80115603697_r8 + & + y*(543.835333000098_r8 + y*(-68.5572509204491_r8 + & + y*(49.3667694856254_r8 + y*(-17.1397577419788_r8 + 2.49697009569508_r8*y))) - 22.6683558512829_r8*z) + & + x*(-1091.66841042967_r8 - 196.028306689776_r8*y + & + x*(374.60123787784_r8 - 48.5891069025409_r8*x + 36.7571622995805_r8*y) + 36.0284195611086_r8*z) + & + z*(-54.7919133532887_r8 + (-4.08193978912261_r8 - 30.1755111971161_r8*z)*z)) + & + z*(199.459603073901_r8 + z*(-52.2940909281335_r8 + (68.0444942726459_r8 - 3.41251932441282_r8*z)*z)) + & + y*(-493.407510141682_r8 + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & + y*(-43.0664675978042_r8 + z*(383.058066002476_r8 + z*(-54.1917262517112_r8 + 25.6398487389914_r8*z)) + & + y*(-10.0227370861875_r8 - 460.319931801257_r8*z + y*(0.875600661808945_r8 + 234.565187611355_r8*z))))) + & + y*(168.072408311545_r8)) + +g_sa_part = 8645.36753595126_r8 + & + x*(-7296.43987145382_r8 + x*(8103.20462414788_r8 + & + y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & + y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & + x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & + x*(2247.60742726704_r8 - 340.1237483177863_r8*x + 220.542973797483_r8*y) + 180.142097805543_r8*z) + & + z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) + & + z*(598.378809221703_r8 + z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & + y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & + y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & + y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(2.626801985426835_r8 + 703.695562834065_r8*z))))) + & + y*(1187.3715515697959_r8) + +gsw_chem_potential_water_t_exact = kg2g*(g03_g + g08_g - 0.5_r8*x2*g_sa_part) + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 b/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 new file mode 100644 index 0000000000..1627322dcd --- /dev/null +++ b/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 @@ -0,0 +1,43 @@ +!========================================================================== +elemental function gsw_ct_freezing_exact (sa, p, saturation_fraction) +!========================================================================== +! +! Calculates the Conservative Temperature at which seawater freezes. The +! Conservative Temperature freezing point is calculated from the exact +! in-situ freezing temperature which is found by a modified Newton-Raphson +! iteration (McDougall and Wotherspoon, 2013) of the equality of the +! chemical potentials of water in seawater and in ice. +! +! An alternative GSW function, gsw_CT_freezing_poly, it is based on a +! computationally-efficient polynomial, and is accurate to within -5e-4 K +! and 6e-4 K, when compared with this function. +! +! SA = Absolute Salinity [ g/kg ] +! p = sea pressure [ dbar ] +! ( i.e. absolute pressure - 10.1325 dbar ) +! saturation_fraction = the saturation fraction of dissolved air in +! seawater +! +! CT_freezing = Conservative Temperature at freezing of seawater [ deg C ] +!-------------------------------------------------------------------------- + +use gsw_mod_toolbox, only : gsw_t_freezing_exact +use gsw_mod_toolbox, only : gsw_ct_from_t + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, p, saturation_fraction + +real (r8) :: gsw_ct_freezing_exact + +real (r8) :: t_freezing + +t_freezing = gsw_t_freezing_exact(sa,p,saturation_fraction) +gsw_ct_freezing_exact = gsw_ct_from_t(sa,t_freezing,p) + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 b/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 new file mode 100644 index 0000000000..a6b8f08091 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 @@ -0,0 +1,53 @@ +!========================================================================== +elemental function gsw_ct_freezing_poly (sa, p, saturation_fraction) +!========================================================================== +! +! Calculates the Conservative Temperature at which seawater freezes. +! The error of this fit ranges between -5e-4 K and 6e-4 K when compared +! with the Conservative Temperature calculated from the exact in-situ +! freezing temperature which is found by a Newton-Raphson iteration of the +! equality of the chemical potentials of water in seawater and in ice. +! Note that the Conservative temperature freezing temperature can be found +! by this exact method using the function gsw_CT_freezing. +! +! SA = Absolute Salinity [ g/kg ] +! p = sea pressure [ dbar ] +! ( i.e. absolute pressure - 10.1325 dbar ) +! saturation_fraction = the saturation fraction of dissolved air in +! seawater +! +! CT_freezing = Conservative Temperature at freezing of seawater [ deg C ] +! That is, the freezing temperature expressed in +! terms of Conservative Temperature (ITS-90). +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_sso + +use gsw_mod_freezing_poly_coefficients + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, p, saturation_fraction + +real (r8) :: gsw_ct_freezing_poly + +real (r8) :: p_r, sa_r, x + +sa_r = sa*1e-2_r8 +x = sqrt(sa_r) +p_r = p*1e-4_r8 + +gsw_ct_freezing_poly = c0 & + + sa_r*(c1 + x*(c2 + x*(c3 + x*(c4 + x*(c5 + c6*x))))) & + + p_r*(c7 + p_r*(c8 + c9*p_r)) + sa_r*p_r*(c10 + p_r*(c12 & + + p_r*(c15 + c21*sa_r)) + sa_r*(c13 + c17*p_r + c19*sa_r) & + + x*(c11 + p_r*(c14 + c18*p_r) + sa_r*(c16 + c20*p_r + c22*sa_r))) + +! Adjust for the effects of dissolved air +gsw_ct_freezing_poly = gsw_ct_freezing_poly - saturation_fraction* & + (1e-3_r8)*(2.4_r8 - a*sa)*(1.0_r8 + b*(1.0_r8 - sa/gsw_sso)) + +return +end function diff --git a/equation_of_state/TEOS10/gsw_ct_from_pt.f90 b/equation_of_state/TEOS10/gsw_ct_from_pt.f90 new file mode 100644 index 0000000000..c4a624ed37 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_ct_from_pt.f90 @@ -0,0 +1,52 @@ +!========================================================================== +elemental function gsw_ct_from_pt (sa, pt) +!========================================================================== +! +! Calculates Conservative Temperature from potential temperature of seawater +! +! sa : Absolute Salinity [g/kg] +! pt : potential temperature with [deg C] +! reference pressure of 0 dbar +! +! gsw_ct_from_pt : Conservative Temperature [deg C] +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sfac + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, pt + +real (r8) :: gsw_ct_from_pt + +real (r8) :: pot_enthalpy, x2, x, y + +x2 = gsw_sfac*sa +x = sqrt(x2) +y = pt*0.025_r8 ! normalize for F03 and F08 + +pot_enthalpy = 61.01362420681071_r8 + y*(168776.46138048015_r8 + & + y*(-2735.2785605119625_r8 + y*(2574.2164453821433_r8 + & + y*(-1536.6644434977543_r8 + y*(545.7340497931629_r8 + & + (-50.91091728474331_r8 - 18.30489878927802_r8*y)*y))))) + & + x2*(268.5520265845071_r8 + y*(-12019.028203559312_r8 + & + y*(3734.858026725145_r8 + y*(-2046.7671145057618_r8 + & + y*(465.28655623826234_r8 + (-0.6370820302376359_r8 - & + 10.650848542359153_r8*y)*y)))) + & + x*(937.2099110620707_r8 + y*(588.1802812170108_r8 + & + y*(248.39476522971285_r8 + (-3.871557904936333_r8 - & + 2.6268019854268356_r8*y)*y)) + & + x*(-1687.914374187449_r8 + x*(246.9598888781377_r8 + & + x*(123.59576582457964_r8 - 48.5891069025409_r8*x)) + & + y*(936.3206544460336_r8 + & + y*(-942.7827304544439_r8 + y*(369.4389437509002_r8 + & + (-33.83664947895248_r8 - 9.987880382780322_r8*y)*y)))))) + +gsw_ct_from_pt = pot_enthalpy/gsw_cp0 + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_ct_from_t.f90 b/equation_of_state/TEOS10/gsw_ct_from_t.f90 new file mode 100644 index 0000000000..b2a0c9e354 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_ct_from_t.f90 @@ -0,0 +1,32 @@ +!========================================================================== +elemental function gsw_ct_from_t (sa, t, p) +!========================================================================== +! +! Calculates Conservative Temperature from in-situ temperature +! +! sa : Absolute Salinity [g/kg] +! t : in-situ temperature [deg C] +! p : sea pressure [dbar] +! +! gsw_ct_from_t : Conservative Temperature [deg C] +!-------------------------------------------------------------------------- + +use gsw_mod_toolbox, only : gsw_ct_from_pt, gsw_pt0_from_t + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, t, p + +real (r8) :: gsw_ct_from_t + +real (r8) :: pt0 + +pt0 = gsw_pt0_from_t(sa,t,p) +gsw_ct_from_t = gsw_ct_from_pt(sa,pt0) + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_entropy_part.f90 b/equation_of_state/TEOS10/gsw_entropy_part.f90 new file mode 100644 index 0000000000..70fcd11255 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_entropy_part.f90 @@ -0,0 +1,62 @@ +!========================================================================== +elemental function gsw_entropy_part (sa, t, p) +!========================================================================== +! +! entropy minus the terms that are a function of only SA +! +! sa : Absolute Salinity [g/kg] +! t : in-situ temperature [deg C] +! p : sea pressure [dbar] +! +! gsw_entropy_part : entropy part +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_sfac + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, t, p + +real (r8) :: gsw_entropy_part + +real (r8) :: x2, x, y, z, g03, g08 + +x2 = gsw_sfac*sa +x = sqrt(x2) +y = t*0.025_r8 +z = p*1e-4_r8 + +g03 = z*(-270.983805184062_r8 + & + z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & + y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & + z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & + y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & + z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & + y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & + z*(-1207.261522487504_r8 + (608.785486935364_r8 - 105.4993508931208_r8*z)*z)) + & + y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & + z*(602.603274510125_r8 + z*(-276.361526170076_r8 + 32.40953340386105_r8*z))) + & + y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - 67.41756835751434_r8*z) + & + z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + 49.023632509086724_r8*z))))))) + +g08 = x2*(z*(729.116529735046_r8 + & + z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & + x*( x*(y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & + 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & + y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & + y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(3.50240264723578_r8 + 938.26075044542_r8*z)))) + & + y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & + y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y) + & + z*(-1190.914967948748_r8 + (298.904564555024_r8 - 145.9491676006352_r8*z)*z)) + & + z*(2082.7344423998043_r8 + z*(-614.668925894709_r8 + (340.685093521782_r8 - 33.3848202979239_r8*z)*z))) + & + z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & + z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) + +gsw_entropy_part = -(g03 + g08)*0.025_r8 + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 b/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 new file mode 100644 index 0000000000..2156b71c4e --- /dev/null +++ b/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 @@ -0,0 +1,44 @@ +!========================================================================== +elemental function gsw_entropy_part_zerop (sa, pt0) +!========================================================================== +! +! entropy part evaluated at the sea surface +! +! sa : Absolute Salinity [g/kg] +! pt0 : insitu temperature [deg C] +! +! gsw_entropy_part_zerop : entropy part at the sea surface +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_sfac + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, pt0 + +real (r8) :: gsw_entropy_part_zerop + +real (r8) :: x2, x, y, g03, g08 + +x2 = gsw_sfac*sa +x = sqrt(x2) +y = pt0*0.025_r8 + +g03 = y*(-24715.571866078_r8 + y*(2210.2236124548363_r8 + & + y*(-592.743745734632_r8 + y*(290.12956292128547_r8 + & + y*(-113.90630790850321_r8 + y*21.35571525415769_r8))))) + +g08 = x2*(x*(x*(y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + & + y*(-68.5590309679152_r8 + 12.4848504784754_r8*y)))) + & + y*(-86.1329351956084_r8 + y*(-30.0682112585625_r8 + y*3.50240264723578_r8))) + & + y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & + y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y))))) + +gsw_entropy_part_zerop = -(g03 + g08)*0.025_r8 + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_gibbs.f90 b/equation_of_state/TEOS10/gsw_gibbs.f90 new file mode 100644 index 0000000000..59f7d221ac --- /dev/null +++ b/equation_of_state/TEOS10/gsw_gibbs.f90 @@ -0,0 +1,317 @@ +!========================================================================== +elemental function gsw_gibbs (ns, nt, np, sa, t, p) +!========================================================================== +! +! seawater specific Gibbs free energy and derivatives up to order 2 +! +! ns : order of s derivative +! nt : order of t derivative +! np : order of p derivative +! sa : Absolute Salinity [g/kg] +! t : temperature [deg C] +! p : sea pressure [dbar] +! +! gsw_gibbs : specific Gibbs energy or its derivative +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_sfac + +use gsw_mod_kinds + +implicit none + +integer, intent(in) :: ns, nt, np +real (r8), intent(in) :: sa, t, p + +real (r8) :: gsw_gibbs + +real (r8) :: x2, x, y, z, g03, g08 + +x2 = gsw_sfac*sa +x = sqrt(x2) +y = t*0.025_r8 +z = p*1e-4_r8 + +if(ns.eq.0 .and. nt.eq.0 .and. np.eq.0) then + + g03 = 101.342743139674_r8 + z*(100015.695367145_r8 + & + z*(-2544.5765420363_r8 + z*(284.517778446287_r8 + & + z*(-33.3146754253611_r8 + (4.20263108803084_r8 - 0.546428511471039_r8*z)*z)))) + & + y*(5.90578347909402_r8 + z*(-270.983805184062_r8 + & + z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & + y*(-12357.785933039_r8 + z*(1455.0364540468_r8 + & + z*(-756.558385769359_r8 + z*(273.479662323528_r8 + z*(-55.5604063817218_r8 + 4.34420671917197_r8*z)))) + & + y*(736.741204151612_r8 + z*(-672.50778314507_r8 + & + z*(499.360390819152_r8 + z*(-239.545330654412_r8 + (48.8012518593872_r8 - 1.66307106208905_r8*z)*z))) + & + y*(-148.185936433658_r8 + z*(397.968445406972_r8 + & + z*(-301.815380621876_r8 + (152.196371733841_r8 - 26.3748377232802_r8*z)*z)) + & + y*(58.0259125842571_r8 + z*(-194.618310617595_r8 + & + z*(120.520654902025_r8 + z*(-55.2723052340152_r8 + 6.48190668077221_r8*z))) + & + y*(-18.9843846514172_r8 + y*(3.05081646487967_r8 - 9.63108119393062_r8*z) + & + z*(63.5113936641785_r8 + z*(-22.2897317140459_r8 + 8.17060541818112_r8*z)))))))) + + g08 = x2*(1416.27648484197_r8 + z*(-3310.49154044839_r8 + & + z*(384.794152978599_r8 + z*(-96.5324320107458_r8 + (15.8408172766824_r8 - 2.62480156590992_r8*z)*z))) + & + x*(-2432.14662381794_r8 + x*(2025.80115603697_r8 + & + y*(543.835333000098_r8 + y*(-68.5572509204491_r8 + & + y*(49.3667694856254_r8 + y*(-17.1397577419788_r8 + 2.49697009569508_r8*y))) - 22.6683558512829_r8*z) + & + x*(-1091.66841042967_r8 - 196.028306689776_r8*y + & + x*(374.60123787784_r8 - 48.5891069025409_r8*x + 36.7571622995805_r8*y) + 36.0284195611086_r8*z) + & + z*(-54.7919133532887_r8 + (-4.08193978912261_r8 - 30.1755111971161_r8*z)*z)) + & + z*(199.459603073901_r8 + z*(-52.2940909281335_r8 + (68.0444942726459_r8 - 3.41251932441282_r8*z)*z)) + & + y*(-493.407510141682_r8 + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & + y*(-43.0664675978042_r8 + z*(383.058066002476_r8 + z*(-54.1917262517112_r8 + 25.6398487389914_r8*z)) + & + y*(-10.0227370861875_r8 - 460.319931801257_r8*z + y*(0.875600661808945_r8 + 234.565187611355_r8*z))))) + & + y*(168.072408311545_r8 + z*(729.116529735046_r8 + & + z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & + y*(880.031352997204_r8 + y*(-225.267649263401_r8 + & + y*(91.4260447751259_r8 + y*(-21.6603240875311_r8 + 2.13016970847183_r8*y) + & + z*(-297.728741987187_r8 + (74.726141138756_r8 - 36.4872919001588_r8*z)*z)) + & + z*(694.244814133268_r8 + z*(-204.889641964903_r8 + (113.561697840594_r8 - 11.1282734326413_r8*z)*z))) + & + z*(-860.764303783977_r8 + z*(337.409530269367_r8 + & + z*(-178.314556207638_r8 + (44.2040358308_r8 - 7.92001547211682_r8*z)*z)))))) + + if(sa.gt.0.0_r8) & + g08 = g08 + x2*(5812.81456626732_r8 + 851.226734946706_r8*y)*log(x) + + gsw_gibbs = g03 + g08 + +elseif(ns.eq.1 .and. nt.eq.0 .and. np.eq.0) then + + g08 = 8645.36753595126_r8 + z*(-6620.98308089678_r8 + & + z*(769.588305957198_r8 + z*(-193.0648640214916_r8 + (31.6816345533648_r8 - 5.24960313181984_r8*z)*z))) + & + x*(-7296.43987145382_r8 + x*(8103.20462414788_r8 + & + y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & + y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & + x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & + x*(2247.60742726704_r8 - 340.1237483177863_r8*x + 220.542973797483_r8*y) + 180.142097805543_r8*z) + & + z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) + & + z*(598.378809221703_r8 + z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & + y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & + y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & + y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(2.626801985426835_r8 + 703.695562834065_r8*z))))) + & + y*(1187.3715515697959_r8 + z*(1458.233059470092_r8 + & + z*(-687.913805923122_r8 + z*(249.375342232496_r8 + z*(-63.313928772146_r8 + 14.09317606630898_r8*z)))) + & + y*(1760.062705994408_r8 + y*(-450.535298526802_r8 + & + y*(182.8520895502518_r8 + y*(-43.3206481750622_r8 + 4.26033941694366_r8*y) + & + z*(-595.457483974374_r8 + (149.452282277512_r8 - 72.9745838003176_r8*z)*z)) + & + z*(1388.489628266536_r8 + z*(-409.779283929806_r8 + (227.123395681188_r8 - 22.2565468652826_r8*z)*z))) + & + z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & + z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) + + if(sa.gt.0_r8) then + g08 = g08 + (11625.62913253464_r8 + 1702.453469893412_r8*y)*log(x) + else + g08 = 0.0_r8 + endif + + gsw_gibbs = 0.5*gsw_sfac*g08 + +elseif(ns.eq.0 .and. nt.eq.1 .and. np.eq.0) then + + g03 = 5.90578347909402_r8 + z*(-270.983805184062_r8 + & + z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & + y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & + z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & + y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & + z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & + y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & + z*(-1207.261522487504_r8 + (608.785486935364_r8 - 105.4993508931208_r8*z)*z)) + & + y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & + z*(602.603274510125_r8 + z*(-276.361526170076_r8 + 32.40953340386105_r8*z))) + & + y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - 67.41756835751434_r8*z) + & + z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + 49.023632509086724_r8*z))))))) + + g08 = x2*(168.072408311545_r8 + z*(729.116529735046_r8 + & + z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & + x*(-493.407510141682_r8 + x*(543.835333000098_r8 + x*(-196.028306689776_r8 + 36.7571622995805_r8*x) + & + y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & + 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & + y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & + y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(3.50240264723578_r8 + 938.26075044542_r8*z)))) + & + y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & + y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y) + & + z*(-1190.914967948748_r8 + (298.904564555024_r8 - 145.9491676006352_r8*z)*z)) + & + z*(2082.7344423998043_r8 + z*(-614.668925894709_r8 + (340.685093521782_r8 - 33.3848202979239_r8*z)*z))) + & + z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & + z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) + + if(sa.gt.0_r8) g08 = g08 + 851.226734946706_r8*x2*log(x) + + gsw_gibbs = (g03 + g08)*0.025_r8 + +elseif(ns.eq.0 .and. nt.eq.0 .and. np.eq.1) then + + g03 = 100015.695367145_r8 + z*(-5089.1530840726_r8 + & + z*(853.5533353388611_r8 + z*(-133.2587017014444_r8 + (21.0131554401542_r8 - 3.278571068826234_r8*z)*z))) + & + y*(-270.983805184062_r8 + z*(1552.307223226202_r8 + & + z*(-589.53765264366_r8 + (115.91861051767_r8 - 10.664504175916349_r8*z)*z)) + & + y*(1455.0364540468_r8 + z*(-1513.116771538718_r8 + & + z*(820.438986970584_r8 + z*(-222.2416255268872_r8 + 21.72103359585985_r8*z))) + & + y*(-672.50778314507_r8 + z*(998.720781638304_r8 + & + z*(-718.6359919632359_r8 + (195.2050074375488_r8 - 8.31535531044525_r8*z)*z)) + & + y*(397.968445406972_r8 + z*(-603.630761243752_r8 + (456.589115201523_r8 - 105.4993508931208_r8*z)*z) + & + y*(-194.618310617595_r8 + y*(63.5113936641785_r8 - 9.63108119393062_r8*y + & + z*(-44.5794634280918_r8 + 24.511816254543362_r8*z)) + & + z*(241.04130980405_r8 + z*(-165.8169157020456_r8 + & + 25.92762672308884_r8*z))))))) + + g08 = x2*(-3310.49154044839_r8 + z*(769.588305957198_r8 + & + z*(-289.5972960322374_r8 + (63.3632691067296_r8 - 13.1240078295496_r8*z)*z)) + & + x*(199.459603073901_r8 + x*(-54.7919133532887_r8 + 36.0284195611086_r8*x - 22.6683558512829_r8*y + & + (-8.16387957824522_r8 - 90.52653359134831_r8*z)*z) + & + z*(-104.588181856267_r8 + (204.1334828179377_r8 - 13.65007729765128_r8*z)*z) + & + y*(-175.292041186547_r8 + (166.3847855603638_r8 - 88.449193048287_r8*z)*z + & + y*(383.058066002476_r8 + y*(-460.319931801257_r8 + 234.565187611355_r8*y) + & + z*(-108.3834525034224_r8 + 76.9195462169742_r8*z)))) + & + y*(729.116529735046_r8 + z*(-687.913805923122_r8 + & + z*(374.063013348744_r8 + z*(-126.627857544292_r8 + 35.23294016577245_r8*z))) + & + y*(-860.764303783977_r8 + y*(694.244814133268_r8 + & + y*(-297.728741987187_r8 + (149.452282277512_r8 - 109.46187570047641_r8*z)*z) + & + z*(-409.779283929806_r8 + (340.685093521782_r8 - 44.5130937305652_r8*z)*z)) + & + z*(674.819060538734_r8 + z*(-534.943668622914_r8 + (176.8161433232_r8 - 39.600077360584095_r8*z)*z))))) + + gsw_gibbs = (g03 + g08)*1e-8_r8 + +elseif(ns.eq.0 .and. nt.eq.2 .and. np.eq.0) then + + g03 = -24715.571866078_r8 + z*(2910.0729080936_r8 + z* & + (-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & + y*(4420.4472249096725_r8 + z*(-4035.04669887042_r8 + & + z*(2996.162344914912_r8 + z*(-1437.2719839264719_r8 + (292.8075111563232_r8 - 9.978426372534301_r8*z)*z))) + & + y*(-1778.231237203896_r8 + z*(4775.621344883664_r8 + & + z*(-3621.784567462512_r8 + (1826.356460806092_r8 - 316.49805267936244_r8*z)*z)) + & + y*(1160.5182516851419_r8 + z*(-3892.3662123519_r8 + & + z*(2410.4130980405_r8 + z*(-1105.446104680304_r8 + 129.6381336154442_r8*z))) + & + y*(-569.531539542516_r8 + y*(128.13429152494615_r8 - 404.50541014508605_r8*z) + & + z*(1905.341809925355_r8 + z*(-668.691951421377_r8 + 245.11816254543362_r8*z)))))) + + g08 = x2*(1760.062705994408_r8 + x*(-86.1329351956084_r8 + & + x*(-137.1145018408982_r8 + y*(296.20061691375236_r8 + y*(-205.67709290374563_r8 + 49.9394019139016_r8*y))) + & + z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & + y*(-60.136422517125_r8 - 2761.9195908075417_r8*z + y*(10.50720794170734_r8 + 2814.78225133626_r8*z))) + & + y*(-1351.605895580406_r8 + y*(1097.1125373015109_r8 + y*(-433.20648175062206_r8 + 63.905091254154904_r8*y) + & + z*(-3572.7449038462437_r8 + (896.713693665072_r8 - 437.84750280190565_r8*z)*z)) + & + z*(4165.4688847996085_r8 + z*(-1229.337851789418_r8 + (681.370187043564_r8 - 66.7696405958478_r8*z)*z))) + & + z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & + z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z)))) + + gsw_gibbs = (g03 + g08)*0.000625_r8 + +elseif(ns.eq.1 .and. nt.eq.0 .and. np.eq.1) then + + g08 = -6620.98308089678_r8 + z*(1539.176611914396_r8 + & + z*(-579.1945920644748_r8 + (126.7265382134592_r8 - 26.2480156590992_r8*z)*z)) + & + x*(598.378809221703_r8 + x*(-219.1676534131548_r8 + 180.142097805543_r8*x - 90.6734234051316_r8*y + & + (-32.65551831298088_r8 - 362.10613436539325_r8*z)*z) + & + z*(-313.764545568801_r8 + (612.4004484538132_r8 - 40.95023189295384_r8*z)*z) + & + y*(-525.876123559641_r8 + (499.15435668109143_r8 - 265.347579144861_r8*z)*z + & + y*(1149.174198007428_r8 + y*(-1380.9597954037708_r8 + 703.695562834065_r8*y) + & + z*(-325.1503575102672_r8 + 230.7586386509226_r8*z)))) + & + y*(1458.233059470092_r8 + z*(-1375.827611846244_r8 + & + z*(748.126026697488_r8 + z*(-253.255715088584_r8 + 70.4658803315449_r8*z))) + & + y*(-1721.528607567954_r8 + y*(1388.489628266536_r8 + & + y*(-595.457483974374_r8 + (298.904564555024_r8 - 218.92375140095282_r8*z)*z) + & + z*(-819.558567859612_r8 + (681.370187043564_r8 - 89.0261874611304_r8*z)*z)) + & + z*(1349.638121077468_r8 + z*(-1069.887337245828_r8 + (353.6322866464_r8 - 79.20015472116819_r8*z)*z)))) + + gsw_gibbs = g08*gsw_sfac*0.5e-8_r8 + +elseif(ns.eq.0 .and. nt.eq.1 .and. np.eq.1) then + + g03 = -270.983805184062_r8 + z*(1552.307223226202_r8 + z*(-589.53765264366_r8 + & + (115.91861051767_r8 - 10.664504175916349_r8*z)*z)) + & + y*(2910.0729080936_r8 + z*(-3026.233543077436_r8 + & + z*(1640.877973941168_r8 + z*(-444.4832510537744_r8 + 43.4420671917197_r8*z))) + & + y*(-2017.52334943521_r8 + z*(2996.162344914912_r8 + & + z*(-2155.907975889708_r8 + (585.6150223126464_r8 - 24.946065931335752_r8*z)*z)) + & + y*(1591.873781627888_r8 + z*(-2414.523044975008_r8 + (1826.356460806092_r8 - 421.9974035724832_r8*z)*z) + & + y*(-973.091553087975_r8 + z*(1205.20654902025_r8 + z*(-829.084578510228_r8 + 129.6381336154442_r8*z)) + & + y*(381.06836198507096_r8 - 67.41756835751434_r8*y + z*(-267.4767805685508_r8 + 147.07089752726017_r8*z)))))) + + g08 = x2*(729.116529735046_r8 + z*(-687.913805923122_r8 + & + z*(374.063013348744_r8 + z*(-126.627857544292_r8 + 35.23294016577245_r8*z))) + & + x*(-175.292041186547_r8 - 22.6683558512829_r8*x + (166.3847855603638_r8 - 88.449193048287_r8*z)*z + & + y*(766.116132004952_r8 + y*(-1380.9597954037708_r8 + 938.26075044542_r8*y) + & + z*(-216.7669050068448_r8 + 153.8390924339484_r8*z))) + & + y*(-1721.528607567954_r8 + y*(2082.7344423998043_r8 + & + y*(-1190.914967948748_r8 + (597.809129110048_r8 - 437.84750280190565_r8*z)*z) + & + z*(-1229.337851789418_r8 + (1022.055280565346_r8 - 133.5392811916956_r8*z)*z)) + & + z*(1349.638121077468_r8 + z*(-1069.887337245828_r8 + (353.6322866464_r8 - 79.20015472116819_r8*z)*z)))) + + gsw_gibbs = (g03 + g08)*2.5e-10_r8 + +elseif(ns.eq.1 .and. nt.eq.1 .and. np.eq.0) then + + g08 = 1187.3715515697959_r8 + z*(1458.233059470092_r8 + & + z*(-687.913805923122_r8 + z*(249.375342232496_r8 + z*(-63.313928772146_r8 + 14.09317606630898_r8*z)))) + & + x*(-1480.222530425046_r8 + x*(2175.341332000392_r8 + x*(-980.14153344888_r8 + 220.542973797483_r8*x) + & + y*(-548.4580073635929_r8 + y*(592.4012338275047_r8 + y*(-274.2361238716608_r8 + 49.9394019139016_r8*y))) - & + 90.6734234051316_r8*z) + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & + y*(-258.3988055868252_r8 + z*(2298.348396014856_r8 + z*(-325.1503575102672_r8 + 153.8390924339484_r8*z)) + & + y*(-90.2046337756875_r8 - 4142.8793862113125_r8*z + y*(10.50720794170734_r8 + 2814.78225133626_r8*z)))) + & + y*(3520.125411988816_r8 + y*(-1351.605895580406_r8 + & + y*(731.4083582010072_r8 + y*(-216.60324087531103_r8 + 25.56203650166196_r8*y) + & + z*(-2381.829935897496_r8 + (597.809129110048_r8 - 291.8983352012704_r8*z)*z)) + & + z*(4165.4688847996085_r8 + z*(-1229.337851789418_r8 + (681.370187043564_r8 - 66.7696405958478_r8*z)*z))) + & + z*(-3443.057215135908_r8 + z*(1349.638121077468_r8 + & + z*(-713.258224830552_r8 + (176.8161433232_r8 - 31.68006188846728_r8*z)*z)))) + + if(sa.gt.0_r8) g08 = g08 + 1702.453469893412_r8*log(x) + + gsw_gibbs = 0.5_r8*gsw_sfac*0.025_r8*g08 + +elseif(ns.eq.2 .and. nt.eq.0 .and. np.eq.0) then + + g08 = 2.0_r8*(8103.20462414788_r8 + & + y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & + y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & + 1.5_r8*x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & + (4.0_r8/3.0_r8)*x*(2247.60742726704_r8 - 340.1237483177863_r8*1.25_r8*x + 220.542973797483_r8*y) + & + 180.142097805543_r8*z) + & + z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) + + if (x.gt.0_r8) then + g08 = g08 + (-7296.43987145382_r8 + z*(598.378809221703_r8 + & + z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & + y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + & + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & + y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + & + z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & + y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + & + y*(2.626801985426835_r8 + 703.695562834065_r8*z)))))/x + & + (11625.62913253464_r8 + 1702.453469893412_r8*y)/x2 + else + g08 = 0.0_r8 + end if + + gsw_gibbs = 0.25_r8*gsw_sfac*gsw_sfac*g08 + +elseif(ns.eq.0 .and. nt.eq.0 .and. np.eq.2) then + + g03 = -5089.1530840726_r8 + z*(1707.1066706777221_r8 + & + z*(-399.7761051043332_r8 + (84.0526217606168_r8 - 16.39285534413117_r8*z)*z)) + & + y*(1552.307223226202_r8 + z*(-1179.07530528732_r8 + (347.75583155301_r8 - 42.658016703665396_r8*z)*z) + & + y*(-1513.116771538718_r8 + z*(1640.877973941168_r8 + z*(-666.7248765806615_r8 + 86.8841343834394_r8*z)) + & + y*(998.720781638304_r8 + z*(-1437.2719839264719_r8 + (585.6150223126464_r8 - 33.261421241781_r8*z)*z) + & + y*(-603.630761243752_r8 + (913.178230403046_r8 - 316.49805267936244_r8*z)*z + & + y*(241.04130980405_r8 + y*(-44.5794634280918_r8 + 49.023632509086724_r8*z) + & + z*(-331.6338314040912_r8 + 77.78288016926652_r8*z)))))) + + g08 = x2*(769.588305957198_r8 + z*(-579.1945920644748_r8 + (190.08980732018878_r8 - 52.4960313181984_r8*z)*z) + & + x*(-104.588181856267_r8 + x*(-8.16387957824522_r8 - 181.05306718269662_r8*z) + & + (408.2669656358754_r8 - 40.95023189295384_r8*z)*z + & + y*(166.3847855603638_r8 - 176.898386096574_r8*z + y*(-108.3834525034224_r8 + 153.8390924339484_r8*z))) + & + y*(-687.913805923122_r8 + z*(748.126026697488_r8 + z*(-379.883572632876_r8 + 140.9317606630898_r8*z)) + & + y*(674.819060538734_r8 + z*(-1069.887337245828_r8 + (530.4484299696_r8 - 158.40030944233638_r8*z)*z) + & + y*(-409.779283929806_r8 + y*(149.452282277512_r8 - 218.92375140095282_r8*z) + & + (681.370187043564_r8 - 133.5392811916956_r8*z)*z)))) + + gsw_gibbs = (g03 + g08)*1e-16_r8 + +end if + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_gibbs_ice.f90 b/equation_of_state/TEOS10/gsw_gibbs_ice.f90 new file mode 100644 index 0000000000..0416a1eeaf --- /dev/null +++ b/equation_of_state/TEOS10/gsw_gibbs_ice.f90 @@ -0,0 +1,130 @@ +! ========================================================================= +elemental function gsw_gibbs_ice (nt, np, t, p) +! ========================================================================= +! +! Ice specific Gibbs energy and derivatives up to order 2. +! +! nt = order of t derivative [ integers 0, 1 or 2 ] +! np = order of p derivative [ integers 0, 1 or 2 ] +! t = in-situ temperature (ITS-90) [ deg C ] +! p = sea pressure [ dbar ] +! +! gibbs_ice = Specific Gibbs energy of ice or its derivatives. +! The Gibbs energy (when nt = np = 0) has units of: [ J/kg ] +! The temperature derivatives are output in units of: +! [ (J/kg) (K)^(-nt) ] +! The pressure derivatives are output in units of: +! [ (J/kg) (Pa)^(-np) ] +! The mixed derivatives are output in units of: +! [ (J/kg) (K)^(-nt) (Pa)^(-np) ] +! Note. The derivatives are taken with respect to pressure in Pa, not +! withstanding that the pressure input into this routine is in dbar. +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_t0, db2pa + +use gsw_mod_gibbs_ice_coefficients + +use gsw_mod_kinds + +implicit none + +integer, intent(in) :: nt, np +real (r8), intent(in) :: t, p + +real (r8) :: gsw_gibbs_ice + +real (r8) :: dzi, g0, g0p, g0pp, sqrec_pt +complex (r8) :: r2, r2p, r2pp, g, sqtau_t1, sqtau_t2, tau, tau_t1, tau_t2 + +real (r8), parameter :: s0 = -3.32733756492168e3_r8 + +tau = (t + gsw_t0)*rec_tt + +dzi = db2pa*p*rec_pt + +if (nt.eq.0 .and. np.eq.0) then + + tau_t1 = tau/t1 + sqtau_t1 = tau_t1*tau_t1 + tau_t2 = tau/t2 + sqtau_t2 = tau_t2*tau_t2 + + g0 = g00 + dzi*(g01 + dzi*(g02 + dzi*(g03 + g04*dzi))) + + r2 = r20 + dzi*(r21 + r22*dzi) + + g = r1*(tau*log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) & + + t1*(log(1.0_r8 - sqtau_t1) - sqtau_t1)) & + + r2*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & + + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) + + gsw_gibbs_ice = g0 - tt*(s0*tau - real(g)) + +elseif (nt.eq.1 .and. np.eq.0) then + + tau_t1 = tau/t1 + tau_t2 = tau/t2 + + r2 = r20 + dzi*(r21 + r22*dzi) + + g = r1*(log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) - 2.0_r8*tau_t1) & + + r2*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2) + + gsw_gibbs_ice = -s0 + real(g) + +elseif (nt.eq.0 .and. np.eq.1) then + + tau_t2 = tau/t2 + sqtau_t2 = tau_t2*tau_t2 + + g0p = rec_pt*(g01 + dzi*(2.0_r8*g02 + dzi*(3.0_r8*g03 + 4.0_r8*g04*dzi))) + + r2p = rec_pt*(r21 + 2.0_r8*r22*dzi) + + g = r2p*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & + + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) + + gsw_gibbs_ice = g0p + tt*real(g) + +elseif (nt.eq.1 .and. np.eq.1) then + + tau_t2 = tau/t2 + + r2p = rec_pt*(r21 + 2.0_r8*r22*dzi) + + g = r2p*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2) + + gsw_gibbs_ice = real(g) + +elseif (nt.eq.2 .and. np.eq.0) then + + r2 = r20 + dzi*(r21 + r22*dzi) + + g = r1*(1.0_r8/(t1 - tau) + 1.0_r8/(t1 + tau) - 2.0_r8/t1) & + + r2*(1.0_r8/(t2 - tau) + 1.0_r8/(t2 + tau) - 2.0_r8/t2) + + gsw_gibbs_ice = rec_tt*real(g) + +elseif (nt.eq.0 .and. np.eq.2) then + + sqrec_pt = rec_pt*rec_pt + + tau_t2 = tau/t2 + sqtau_t2 = tau_t2*tau_t2 + + g0pp = sqrec_pt*(2.0_r8*g02 + dzi*(6.0_r8*g03 + 12.0_r8*g04*dzi)) + + r2pp = 2.0_r8*r22*sqrec_pt + + g = r2pp*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & + + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) + + gsw_gibbs_ice = g0pp + tt*real(g) + +end if + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 b/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 new file mode 100644 index 0000000000..6e8bcfc779 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 @@ -0,0 +1,47 @@ +!========================================================================== +elemental function gsw_gibbs_pt0_pt0 (sa, pt0) +!========================================================================== +! +! gibbs_tt at (sa,pt,0) +! +! sa : Absolute Salinity [g/kg] +! pt0 : potential temperature [deg C] +! +! gsw_gibbs_pt0_pt0 : gibbs_tt at (sa,pt,0) +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_sfac + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, pt0 + +real (r8) :: gsw_gibbs_pt0_pt0 + +real (r8) :: x2, x, y, g03, g08 + +x2 = gsw_sfac*sa +x = sqrt(x2) +y = pt0*0.025_r8 + +g03 = -24715.571866078_r8 + & + y*(4420.4472249096725_r8 + & + y*(-1778.231237203896_r8 + & + y*(1160.5182516851419_r8 + & + y*(-569.531539542516_r8 + y*128.13429152494615_r8)))) + +g08 = x2*(1760.062705994408_r8 + x*(-86.1329351956084_r8 + & + x*(-137.1145018408982_r8 + y*(296.20061691375236_r8 + & + y*(-205.67709290374563_r8 + 49.9394019139016_r8*y))) + & + y*(-60.136422517125_r8 + y*10.50720794170734_r8)) + & + y*(-1351.605895580406_r8 + y*(1097.1125373015109_r8 + & + y*(-433.20648175062206_r8 + 63.905091254154904_r8*y)))) + +gsw_gibbs_pt0_pt0 = (g03 + g08)*0.000625_r8 + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_mod_error_functions.f90 b/equation_of_state/TEOS10/gsw_mod_error_functions.f90 new file mode 100644 index 0000000000..2dc44b725a --- /dev/null +++ b/equation_of_state/TEOS10/gsw_mod_error_functions.f90 @@ -0,0 +1,160 @@ +!========================================================================== +module gsw_mod_error_functions +!========================================================================== + +use gsw_mod_kinds + +implicit none + +logical, public :: gsw_error_check = .true. +logical, public :: gsw_abort_on_error = .true. + +real (r8), parameter, public :: gsw_error_limit = 1e10_r8 + +integer, parameter, private :: nfuncs = 37 +integer, parameter, private :: maxlen = 40 +character (len=maxlen), dimension(nfuncs), private :: func_list + +data func_list / & + "gsw_ct_from_enthalpy_exact", & + "gsw_ct_from_enthalpy", & + "gsw_ct_from_rho", & + "gsw_deltasa_atlas", & + "gsw_deltasa_from_sp", & + "gsw_fdelta", & + "gsw_frazil_properties", & + "gsw_frazil_properties_potential", & + "gsw_frazil_properties_potential_poly", & + "gsw_geo_strf_dyn_height", & + "gsw_geo_strf_dyn_height_pc", & + "gsw_ice_fraction_to_freeze_seawater", & + "gsw_ipv_vs_fnsquared_ratio", & + "gsw_melting_ice_into_seawater", & + "gsw_melting_ice_sa_ct_ratio", & + "gsw_melting_ice_sa_ct_ratio_poly", & + "gsw_melting_seaice_into_seawater", & + "gsw_melting_seaice_sa_ct_ratio", & + "gsw_melting_seaice_sa_ct_ratio_poly", & + "gsw_nsquared", & + "gsw_pressure_freezing_ct", & + "gsw_rr68_interp_sa_ct", & + "gsw_saar", & + "gsw_sa_freezing_from_ct", & + "gsw_sa_freezing_from_ct_poly", & + "gsw_sa_freezing_from_t", & + "gsw_sa_freezing_from_t_poly", & + "gsw_sa_from_rho", & + "gsw_sa_from_sp", & + "gsw_sa_from_sstar", & + "gsw_seaice_fraction_to_freeze_seawater", & + "gsw_sp_from_c", & + "gsw_sp_from_sa", & + "gsw_sp_from_sstar", & + "gsw_sstar_from_sa", & + "gsw_sstar_from_sp", & + "gsw_turner_rsubrho" / + +public :: gsw_error_code +public :: gsw_error_handler + +private :: gsw_error_fnum + +contains + + elemental function gsw_error_code (err_num, func_name, error_code) + + ! Constructs an error code of the form 9.nabcxyz000000d15 + ! + ! where n = current error level (1-4) + ! abc = error code for level #1 + ! xyz = error code for level #2 + ! ... + ! and level error codes comprise ... + ! a = error number for level #1 (0-9) + ! bc = function number for level #10 + + implicit none + + integer, intent(in) :: err_num + character (*), intent(in) :: func_name + real (r8), intent(in), optional :: error_code + + integer :: ival, k + real (r8) :: gsw_error_code, base_code, mult + + if (present(error_code)) then + k = int(error_code/1.0e14_r8) - 90 + base_code = error_code + 1.0e14_r8 + mult = 10.0_r8**(11-k*3) + else + base_code = 9.1e15_r8 + mult = 1.0e11_r8 + end if + + ival = err_num*100 + gsw_error_fnum(func_name) + gsw_error_code = base_code + ival*mult + + end function gsw_error_code + + !========================================================================== + + elemental function gsw_error_fnum (func_name) + + implicit none + + character (*), intent(in) :: func_name + + integer :: gsw_error_fnum + + integer :: i + character (len=maxlen) :: fname + + fname = func_name + do i = 1, nfuncs + if (fname == func_list(i)) goto 100 + end do + gsw_error_fnum = 99 + return + +100 gsw_error_fnum = i + return + + end function gsw_error_fnum + + !========================================================================== + + subroutine gsw_error_handler (error_code) + + implicit none + + real (r8), intent(in) :: error_code + + integer (selected_int_kind(14)) :: base_code + integer :: func_num, ival, i, k + real (r8) :: gsw_error_code, mult + + character (len=maxlen) :: func_name + + print '(/"Trace for error code: ", es20.13/)', error_code + + base_code = error_code - 9.0e15_r8 + k = int(base_code/1.0e14_r8) + base_code = base_code/(10**(14-k*3)) + + do i = 1, k + ival = mod(base_code,1000) + func_num = mod(ival,100) + if (func_num .le. nfuncs) then + func_name = func_list(func_num) + else + func_name = "unknown" + end if + print '(" Code: ",i1," in function: ",a)', ival/100, func_name + base_code = base_code/1000 + end do + + if (gsw_abort_on_error) stop + + end subroutine gsw_error_handler + +end module gsw_mod_error_functions diff --git a/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 b/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 new file mode 100644 index 0000000000..d4b5052f99 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 @@ -0,0 +1,63 @@ +!========================================================================== +module gsw_mod_freezing_poly_coefficients +!========================================================================== + +use gsw_mod_kinds + +implicit none + +real (r8), parameter :: c0 = 0.017947064327968736_r8 +real (r8), parameter :: c1 = -6.076099099929818_r8 +real (r8), parameter :: c2 = 4.883198653547851_r8 +real (r8), parameter :: c3 = -11.88081601230542_r8 +real (r8), parameter :: c4 = 13.34658511480257_r8 +real (r8), parameter :: c5 = -8.722761043208607_r8 +real (r8), parameter :: c6 = 2.082038908808201_r8 +real (r8), parameter :: c7 = -7.389420998107497_r8 +real (r8), parameter :: c8 = -2.110913185058476_r8 +real (r8), parameter :: c9 = 0.2295491578006229_r8 +real (r8), parameter :: c10 = -0.9891538123307282_r8 +real (r8), parameter :: c11 = -0.08987150128406496_r8 +real (r8), parameter :: c12 = 0.3831132432071728_r8 +real (r8), parameter :: c13 = 1.054318231187074_r8 +real (r8), parameter :: c14 = 1.065556599652796_r8 +real (r8), parameter :: c15 = -0.7997496801694032_r8 +real (r8), parameter :: c16 = 0.3850133554097069_r8 +real (r8), parameter :: c17 = -2.078616693017569_r8 +real (r8), parameter :: c18 = 0.8756340772729538_r8 +real (r8), parameter :: c19 = -2.079022768390933_r8 +real (r8), parameter :: c20 = 1.596435439942262_r8 +real (r8), parameter :: c21 = 0.1338002171109174_r8 +real (r8), parameter :: c22 = 1.242891021876471_r8 + +! Note that a = 0.502500117621_r8/gsw_sso +real (r8), parameter :: a = 0.014289763856964_r8 +real (r8), parameter :: b = 0.057000649899720_r8 + +real (r8), parameter :: t0 = 0.002519_r8 +real (r8), parameter :: t1 = -5.946302841607319_r8 +real (r8), parameter :: t2 = 4.136051661346983_r8 +real (r8), parameter :: t3 = -1.115150523403847e1_r8 +real (r8), parameter :: t4 = 1.476878746184548e1_r8 +real (r8), parameter :: t5 = -1.088873263630961e1_r8 +real (r8), parameter :: t6 = 2.961018839640730_r8 +real (r8), parameter :: t7 = -7.433320943962606_r8 +real (r8), parameter :: t8 = -1.561578562479883_r8 +real (r8), parameter :: t9 = 4.073774363480365e-2_r8 +real (r8), parameter :: t10 = 1.158414435887717e-2_r8 +real (r8), parameter :: t11 = -4.122639292422863e-1_r8 +real (r8), parameter :: t12 = -1.123186915628260e-1_r8 +real (r8), parameter :: t13 = 5.715012685553502e-1_r8 +real (r8), parameter :: t14 = 2.021682115652684e-1_r8 +real (r8), parameter :: t15 = 4.140574258089767e-2_r8 +real (r8), parameter :: t16 = -6.034228641903586e-1_r8 +real (r8), parameter :: t17 = -1.205825928146808e-2_r8 +real (r8), parameter :: t18 = -2.812172968619369e-1_r8 +real (r8), parameter :: t19 = 1.877244474023750e-2_r8 +real (r8), parameter :: t20 = -1.204395563789007e-1_r8 +real (r8), parameter :: t21 = 2.349147739749606e-1_r8 +real (r8), parameter :: t22 = 2.748444541144219e-3_r8 + +end module + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 b/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 new file mode 100644 index 0000000000..e9da3baf48 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 @@ -0,0 +1,30 @@ +!========================================================================== +module gsw_mod_gibbs_ice_coefficients +!========================================================================== + +use gsw_mod_kinds + +implicit none + +complex(r8), parameter :: t1 =( 3.68017112855051e-2_r8, 5.10878114959572e-2_r8) +complex(r8), parameter :: t2 =( 3.37315741065416e-1_r8, 3.35449415919309e-1_r8) + +complex(r8), parameter :: r1 =( 4.47050716285388e1_r8, 6.56876847463481e1_r8) +complex(r8), parameter :: r20=(-7.25974574329220e1_r8, -7.81008427112870e1_r8) +complex(r8), parameter :: r21=(-5.57107698030123e-5_r8, 4.64578634580806e-5_r8) +complex(r8), parameter :: r22=(2.34801409215913e-11_r8,-2.85651142904972e-11_r8) + +! 1./Pt, where Pt = 611.657; Experimental triple-point pressure in Pa. +real (r8), parameter :: rec_pt = 1.634903221903779e-3_r8 +real (r8), parameter :: tt = 273.16_r8 ! Triple-point temperature, kelvin (K). +real (r8), parameter :: rec_tt = 3.660858105139845e-3_r8 ! = 1/tt + +real (r8), parameter :: g00 = -6.32020233335886e5_r8 +real (r8), parameter :: g01 = 6.55022213658955e-1_r8 +real (r8), parameter :: g02 = -1.89369929326131e-8_r8 +real (r8), parameter :: g03 = 3.3974612327105304e-15_r8 +real (r8), parameter :: g04 = -5.564648690589909e-22_r8 + +end module + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_mod_kinds.f90 b/equation_of_state/TEOS10/gsw_mod_kinds.f90 new file mode 100644 index 0000000000..7a2a80891f --- /dev/null +++ b/equation_of_state/TEOS10/gsw_mod_kinds.f90 @@ -0,0 +1,16 @@ +!========================================================================== +module gsw_mod_kinds +!========================================================================== + +implicit none + +integer, parameter :: r4 = selected_real_kind(6,30) + +integer, parameter :: r8 = selected_real_kind(14,30) + +end module + +!-------------------------------------------------------------------------- + + + diff --git a/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 b/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 new file mode 100644 index 0000000000..7bc89c7b5e --- /dev/null +++ b/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 @@ -0,0 +1,313 @@ +!========================================================================== +module gsw_mod_specvol_coefficients +!========================================================================== + +use gsw_mod_kinds + +implicit none + +real (r8), parameter :: a000 = -1.56497346750e-5_r8 +real (r8), parameter :: a001 = 1.85057654290e-5_r8 +real (r8), parameter :: a002 = -1.17363867310e-6_r8 +real (r8), parameter :: a003 = -3.65270065530e-7_r8 +real (r8), parameter :: a004 = 3.14540999020e-7_r8 +real (r8), parameter :: a010 = 5.55242129680e-5_r8 +real (r8), parameter :: a011 = -2.34332137060e-5_r8 +real (r8), parameter :: a012 = 4.26100574800e-6_r8 +real (r8), parameter :: a013 = 5.73918103180e-7_r8 +real (r8), parameter :: a020 = -4.95634777770e-5_r8 +real (r8), parameter :: a021 = 2.37838968519e-5_r8 +real (r8), parameter :: a022 = -1.38397620111e-6_r8 +real (r8), parameter :: a030 = 2.76445290808e-5_r8 +real (r8), parameter :: a031 = -1.36408749928e-5_r8 +real (r8), parameter :: a032 = -2.53411666056e-7_r8 +real (r8), parameter :: a040 = -4.02698077700e-6_r8 +real (r8), parameter :: a041 = 2.53683834070e-6_r8 +real (r8), parameter :: a050 = 1.23258565608e-6_r8 +real (r8), parameter :: a100 = 3.50095997640e-5_r8 +real (r8), parameter :: a101 = -9.56770881560e-6_r8 +real (r8), parameter :: a102 = -5.56991545570e-6_r8 +real (r8), parameter :: a103 = -2.72956962370e-7_r8 +real (r8), parameter :: a110 = -7.48716846880e-5_r8 +real (r8), parameter :: a111 = -4.73566167220e-7_r8 +real (r8), parameter :: a112 = 7.82747741600e-7_r8 +real (r8), parameter :: a120 = 7.24244384490e-5_r8 +real (r8), parameter :: a121 = -1.03676320965e-5_r8 +real (r8), parameter :: a122 = 2.32856664276e-8_r8 +real (r8), parameter :: a130 = -3.50383492616e-5_r8 +real (r8), parameter :: a131 = 5.18268711320e-6_r8 +real (r8), parameter :: a140 = -1.65263794500e-6_r8 +real (r8), parameter :: a200 = -4.35926785610e-5_r8 +real (r8), parameter :: a201 = 1.11008347650e-5_r8 +real (r8), parameter :: a202 = 5.46207488340e-6_r8 +real (r8), parameter :: a210 = 7.18156455200e-5_r8 +real (r8), parameter :: a211 = 5.85666925900e-6_r8 +real (r8), parameter :: a212 = -1.31462208134e-6_r8 +real (r8), parameter :: a220 = -4.30608991440e-5_r8 +real (r8), parameter :: a221 = 9.49659182340e-7_r8 +real (r8), parameter :: a230 = 1.74814722392e-5_r8 +real (r8), parameter :: a300 = 3.45324618280e-5_r8 +real (r8), parameter :: a301 = -9.84471178440e-6_r8 +real (r8), parameter :: a302 = -1.35441856270e-6_r8 +real (r8), parameter :: a310 = -3.73971683740e-5_r8 +real (r8), parameter :: a311 = -9.76522784000e-7_r8 +real (r8), parameter :: a320 = 6.85899736680e-6_r8 +real (r8), parameter :: a400 = -1.19594097880e-5_r8 +real (r8), parameter :: a401 = 2.59092252600e-6_r8 +real (r8), parameter :: a410 = 7.71906784880e-6_r8 +real (r8), parameter :: a500 = 1.38645945810e-6_r8 + +real (r8), parameter :: b000 = -3.10389819760e-4_r8 +real (r8), parameter :: b003 = 3.63101885150e-7_r8 +real (r8), parameter :: b004 = -1.11471254230e-7_r8 +real (r8), parameter :: b010 = 3.50095997640e-5_r8 +real (r8), parameter :: b013 = -2.72956962370e-7_r8 +real (r8), parameter :: b020 = -3.74358423440e-5_r8 +real (r8), parameter :: b030 = 2.41414794830e-5_r8 +real (r8), parameter :: b040 = -8.75958731540e-6_r8 +real (r8), parameter :: b050 = -3.30527589000e-7_r8 +real (r8), parameter :: b100 = 1.33856134076e-3_r8 +real (r8), parameter :: b103 = 3.34926075600e-8_r8 +real (r8), parameter :: b110 = -8.71853571220e-5_r8 +real (r8), parameter :: b120 = 7.18156455200e-5_r8 +real (r8), parameter :: b130 = -2.87072660960e-5_r8 +real (r8), parameter :: b140 = 8.74073611960e-6_r8 +real (r8), parameter :: b200 = -2.55143801811e-3_r8 +real (r8), parameter :: b210 = 1.03597385484e-4_r8 +real (r8), parameter :: b220 = -5.60957525610e-5_r8 +real (r8), parameter :: b230 = 6.85899736680e-6_r8 +real (r8), parameter :: b300 = 2.32344279772e-3_r8 +real (r8), parameter :: b310 = -4.78376391520e-5_r8 +real (r8), parameter :: b320 = 1.54381356976e-5_r8 +real (r8), parameter :: b400 = -1.05461852535e-3_r8 +real (r8), parameter :: b410 = 6.93229729050e-6_r8 +real (r8), parameter :: b500 = 1.91594743830e-4_r8 +real (r8), parameter :: b001 = 2.42624687470e-5_r8 +real (r8), parameter :: b011 = -9.56770881560e-6_r8 +real (r8), parameter :: b021 = -2.36783083610e-7_r8 +real (r8), parameter :: b031 = -3.45587736550e-6_r8 +real (r8), parameter :: b041 = 1.29567177830e-6_r8 +real (r8), parameter :: b101 = -6.95849219480e-5_r8 +real (r8), parameter :: b111 = 2.22016695300e-5_r8 +real (r8), parameter :: b121 = 5.85666925900e-6_r8 +real (r8), parameter :: b131 = 6.33106121560e-7_r8 +real (r8), parameter :: b201 = 1.12412331915e-4_r8 +real (r8), parameter :: b211 = -2.95341353532e-5_r8 +real (r8), parameter :: b221 = -1.46478417600e-6_r8 +real (r8), parameter :: b301 = -6.92888744480e-5_r8 +real (r8), parameter :: b311 = 1.03636901040e-5_r8 +real (r8), parameter :: b401 = 1.54637136265e-5_r8 +real (r8), parameter :: b002 = -5.84844329840e-7_r8 +real (r8), parameter :: b012 = -5.56991545570e-6_r8 +real (r8), parameter :: b022 = 3.91373870800e-7_r8 +real (r8), parameter :: b032 = 7.76188880920e-9_r8 +real (r8), parameter :: b102 = -9.62445031940e-6_r8 +real (r8), parameter :: b112 = 1.09241497668e-5_r8 +real (r8), parameter :: b122 = -1.31462208134e-6_r8 +real (r8), parameter :: b202 = 1.47789320994e-5_r8 +real (r8), parameter :: b212 = -4.06325568810e-6_r8 +real (r8), parameter :: b302 = -7.12478989080e-6_r8 + +real (r8), parameter :: c000 = -6.07991438090e-5_r8 +real (r8), parameter :: c001 = 1.99712338438e-5_r8 +real (r8), parameter :: c002 = -3.39280843110e-6_r8 +real (r8), parameter :: c003 = 4.21246123200e-7_r8 +real (r8), parameter :: c004 = -6.32363064300e-8_r8 +real (r8), parameter :: c005 = 1.17681023580e-8_r8 +real (r8), parameter :: c010 = 1.85057654290e-5_r8 +real (r8), parameter :: c011 = -2.34727734620e-6_r8 +real (r8), parameter :: c012 = -1.09581019659e-6_r8 +real (r8), parameter :: c013 = 1.25816399608e-6_r8 +real (r8), parameter :: c020 = -1.17166068530e-5_r8 +real (r8), parameter :: c021 = 4.26100574800e-6_r8 +real (r8), parameter :: c022 = 8.60877154770e-7_r8 +real (r8), parameter :: c030 = 7.92796561730e-6_r8 +real (r8), parameter :: c031 = -9.22650800740e-7_r8 +real (r8), parameter :: c040 = -3.41021874820e-6_r8 +real (r8), parameter :: c041 = -1.26705833028e-7_r8 +real (r8), parameter :: c050 = 5.07367668140e-7_r8 +real (r8), parameter :: c100 = 2.42624687470e-5_r8 +real (r8), parameter :: c101 = -1.16968865968e-6_r8 +real (r8), parameter :: c102 = 1.08930565545e-6_r8 +real (r8), parameter :: c103 = -4.45885016920e-7_r8 +real (r8), parameter :: c110 = -9.56770881560e-6_r8 +real (r8), parameter :: c111 = -1.11398309114e-5_r8 +real (r8), parameter :: c112 = -8.18870887110e-7_r8 +real (r8), parameter :: c120 = -2.36783083610e-7_r8 +real (r8), parameter :: c121 = 7.82747741600e-7_r8 +real (r8), parameter :: c130 = -3.45587736550e-6_r8 +real (r8), parameter :: c131 = 1.55237776184e-8_r8 +real (r8), parameter :: c140 = 1.29567177830e-6_r8 +real (r8), parameter :: c200 = -3.47924609740e-5_r8 +real (r8), parameter :: c201 = -9.62445031940e-6_r8 +real (r8), parameter :: c202 = 5.02389113400e-8_r8 +real (r8), parameter :: c210 = 1.11008347650e-5_r8 +real (r8), parameter :: c211 = 1.09241497668e-5_r8 +real (r8), parameter :: c220 = 2.92833462950e-6_r8 +real (r8), parameter :: c221 = -1.31462208134e-6_r8 +real (r8), parameter :: c230 = 3.16553060780e-7_r8 +real (r8), parameter :: c300 = 3.74707773050e-5_r8 +real (r8), parameter :: c301 = 9.85262139960e-6_r8 +real (r8), parameter :: c310 = -9.84471178440e-6_r8 +real (r8), parameter :: c311 = -2.70883712540e-6_r8 +real (r8), parameter :: c320 = -4.88261392000e-7_r8 +real (r8), parameter :: c400 = -1.73222186120e-5_r8 +real (r8), parameter :: c401 = -3.56239494540e-6_r8 +real (r8), parameter :: c410 = 2.59092252600e-6_r8 +real (r8), parameter :: c500 = 3.09274272530e-6_r8 + +real (r8), parameter :: h001 = 1.07699958620e-3_r8 +real (r8), parameter :: h002 = -3.03995719050e-5_r8 +real (r8), parameter :: h003 = 3.32853897400e-6_r8 +real (r8), parameter :: h004 = -2.82734035930e-7_r8 +real (r8), parameter :: h005 = 2.10623061600e-8_r8 +real (r8), parameter :: h006 = -2.10787688100e-9_r8 +real (r8), parameter :: h007 = 2.80192913290e-10_r8 +real (r8), parameter :: h011 = -1.56497346750e-5_r8 +real (r8), parameter :: h012 = 9.25288271450e-6_r8 +real (r8), parameter :: h013 = -3.91212891030e-7_r8 +real (r8), parameter :: h014 = -9.13175163830e-8_r8 +real (r8), parameter :: h015 = 6.29081998040e-8_r8 +real (r8), parameter :: h021 = 2.77621064840e-5_r8 +real (r8), parameter :: h022 = -5.85830342650e-6_r8 +real (r8), parameter :: h023 = 7.10167624670e-7_r8 +real (r8), parameter :: h024 = 7.17397628980e-8_r8 +real (r8), parameter :: h031 = -1.65211592590e-5_r8 +real (r8), parameter :: h032 = 3.96398280870e-6_r8 +real (r8), parameter :: h033 = -1.53775133460e-7_r8 +real (r8), parameter :: h042 = -1.70510937410e-6_r8 +real (r8), parameter :: h043 = -2.11176388380e-8_r8 +real (r8), parameter :: h041 = 6.91113227020e-6_r8 +real (r8), parameter :: h051 = -8.05396155400e-7_r8 +real (r8), parameter :: h052 = 2.53683834070e-7_r8 +real (r8), parameter :: h061 = 2.05430942680e-7_r8 +real (r8), parameter :: h101 = -3.10389819760e-4_r8 +real (r8), parameter :: h102 = 1.21312343735e-5_r8 +real (r8), parameter :: h103 = -1.94948109950e-7_r8 +real (r8), parameter :: h104 = 9.07754712880e-8_r8 +real (r8), parameter :: h105 = -2.22942508460e-8_r8 +real (r8), parameter :: h111 = 3.50095997640e-5_r8 +real (r8), parameter :: h112 = -4.78385440780e-6_r8 +real (r8), parameter :: h113 = -1.85663848520e-6_r8 +real (r8), parameter :: h114 = -6.82392405930e-8_r8 +real (r8), parameter :: h121 = -3.74358423440e-5_r8 +real (r8), parameter :: h122 = -1.18391541805e-7_r8 +real (r8), parameter :: h123 = 1.30457956930e-7_r8 +real (r8), parameter :: h131 = 2.41414794830e-5_r8 +real (r8), parameter :: h132 = -1.72793868275e-6_r8 +real (r8), parameter :: h133 = 2.58729626970e-9_r8 +real (r8), parameter :: h141 = -8.75958731540e-6_r8 +real (r8), parameter :: h142 = 6.47835889150e-7_r8 +real (r8), parameter :: h151 = -3.30527589000e-7_r8 +real (r8), parameter :: h201 = 6.69280670380e-4_r8 +real (r8), parameter :: h202 = -1.73962304870e-5_r8 +real (r8), parameter :: h203 = -1.60407505320e-6_r8 +real (r8), parameter :: h204 = 4.18657594500e-9_r8 +real (r8), parameter :: h211 = -4.35926785610e-5_r8 +real (r8), parameter :: h212 = 5.55041738250e-6_r8 +real (r8), parameter :: h213 = 1.82069162780e-6_r8 +real (r8), parameter :: h221 = 3.59078227600e-5_r8 +real (r8), parameter :: h222 = 1.46416731475e-6_r8 +real (r8), parameter :: h223 = -2.19103680220e-7_r8 +real (r8), parameter :: h231 = -1.43536330480e-5_r8 +real (r8), parameter :: h232 = 1.58276530390e-7_r8 +real (r8), parameter :: h241 = 4.37036805980e-6_r8 +real (r8), parameter :: h301 = -8.50479339370e-4_r8 +real (r8), parameter :: h302 = 1.87353886525e-5_r8 +real (r8), parameter :: h303 = 1.64210356660e-6_r8 +real (r8), parameter :: h311 = 3.45324618280e-5_r8 +real (r8), parameter :: h312 = -4.92235589220e-6_r8 +real (r8), parameter :: h313 = -4.51472854230e-7_r8 +real (r8), parameter :: h321 = -1.86985841870e-5_r8 +real (r8), parameter :: h322 = -2.44130696000e-7_r8 +real (r8), parameter :: h331 = 2.28633245560e-6_r8 +real (r8), parameter :: h401 = 5.80860699430e-4_r8 +real (r8), parameter :: h402 = -8.66110930600e-6_r8 +real (r8), parameter :: h403 = -5.93732490900e-7_r8 +real (r8), parameter :: h411 = -1.19594097880e-5_r8 +real (r8), parameter :: h421 = 3.85953392440e-6_r8 +real (r8), parameter :: h412 = 1.29546126300e-6_r8 +real (r8), parameter :: h501 = -2.10923705070e-4_r8 +real (r8), parameter :: h502 = 1.54637136265e-6_r8 +real (r8), parameter :: h511 = 1.38645945810e-6_r8 +real (r8), parameter :: h601 = 3.19324573050e-5_r8 + +real (r8), parameter :: v000 = 1.0769995862e-3_r8 +real (r8), parameter :: v001 = -6.0799143809e-5_r8 +real (r8), parameter :: v002 = 9.9856169219e-6_r8 +real (r8), parameter :: v003 = -1.1309361437e-6_r8 +real (r8), parameter :: v004 = 1.0531153080e-7_r8 +real (r8), parameter :: v005 = -1.2647261286e-8_r8 +real (r8), parameter :: v006 = 1.9613503930e-9_r8 +real (r8), parameter :: v010 = -3.1038981976e-4_r8 +real (r8), parameter :: v011 = 2.4262468747e-5_r8 +real (r8), parameter :: v012 = -5.8484432984e-7_r8 +real (r8), parameter :: v013 = 3.6310188515e-7_r8 +real (r8), parameter :: v014 = -1.1147125423e-7_r8 +real (r8), parameter :: v020 = 6.6928067038e-4_r8 +real (r8), parameter :: v021 = -3.4792460974e-5_r8 +real (r8), parameter :: v022 = -4.8122251597e-6_r8 +real (r8), parameter :: v023 = 1.6746303780e-8_r8 +real (r8), parameter :: v030 = -8.5047933937e-4_r8 +real (r8), parameter :: v031 = 3.7470777305e-5_r8 +real (r8), parameter :: v032 = 4.9263106998e-6_r8 +real (r8), parameter :: v040 = 5.8086069943e-4_r8 +real (r8), parameter :: v041 = -1.7322218612e-5_r8 +real (r8), parameter :: v042 = -1.7811974727e-6_r8 +real (r8), parameter :: v050 = -2.1092370507e-4_r8 +real (r8), parameter :: v051 = 3.0927427253e-6_r8 +real (r8), parameter :: v060 = 3.1932457305e-5_r8 +real (r8), parameter :: v100 = -1.5649734675e-5_r8 +real (r8), parameter :: v101 = 1.8505765429e-5_r8 +real (r8), parameter :: v102 = -1.1736386731e-6_r8 +real (r8), parameter :: v103 = -3.6527006553e-7_r8 +real (r8), parameter :: v104 = 3.1454099902e-7_r8 +real (r8), parameter :: v110 = 3.5009599764e-5_r8 +real (r8), parameter :: v111 = -9.5677088156e-6_r8 +real (r8), parameter :: v112 = -5.5699154557e-6_r8 +real (r8), parameter :: v113 = -2.7295696237e-7_r8 +real (r8), parameter :: v120 = -4.3592678561e-5_r8 +real (r8), parameter :: v121 = 1.1100834765e-5_r8 +real (r8), parameter :: v122 = 5.4620748834e-6_r8 +real (r8), parameter :: v130 = 3.4532461828e-5_r8 +real (r8), parameter :: v131 = -9.8447117844e-6_r8 +real (r8), parameter :: v132 = -1.3544185627e-6_r8 +real (r8), parameter :: v140 = -1.1959409788e-5_r8 +real (r8), parameter :: v141 = 2.5909225260e-6_r8 +real (r8), parameter :: v150 = 1.3864594581e-6_r8 +real (r8), parameter :: v200 = 2.7762106484e-5_r8 +real (r8), parameter :: v201 = -1.1716606853e-5_r8 +real (r8), parameter :: v202 = 2.1305028740e-6_r8 +real (r8), parameter :: v203 = 2.8695905159e-7_r8 +real (r8), parameter :: v210 = -3.7435842344e-5_r8 +real (r8), parameter :: v211 = -2.3678308361e-7_r8 +real (r8), parameter :: v212 = 3.9137387080e-7_r8 +real (r8), parameter :: v220 = 3.5907822760e-5_r8 +real (r8), parameter :: v221 = 2.9283346295e-6_r8 +real (r8), parameter :: v222 = -6.5731104067e-7_r8 +real (r8), parameter :: v230 = -1.8698584187e-5_r8 +real (r8), parameter :: v231 = -4.8826139200e-7_r8 +real (r8), parameter :: v240 = 3.8595339244e-6_r8 +real (r8), parameter :: v300 = -1.6521159259e-5_r8 +real (r8), parameter :: v301 = 7.9279656173e-6_r8 +real (r8), parameter :: v302 = -4.6132540037e-7_r8 +real (r8), parameter :: v310 = 2.4141479483e-5_r8 +real (r8), parameter :: v311 = -3.4558773655e-6_r8 +real (r8), parameter :: v312 = 7.7618888092e-9_r8 +real (r8), parameter :: v320 = -1.4353633048e-5_r8 +real (r8), parameter :: v321 = 3.1655306078e-7_r8 +real (r8), parameter :: v330 = 2.2863324556e-6_r8 +real (r8), parameter :: v400 = 6.9111322702e-6_r8 +real (r8), parameter :: v401 = -3.4102187482e-6_r8 +real (r8), parameter :: v402 = -6.3352916514e-8_r8 +real (r8), parameter :: v410 = -8.7595873154e-6_r8 +real (r8), parameter :: v411 = 1.2956717783e-6_r8 +real (r8), parameter :: v420 = 4.3703680598e-6_r8 +real (r8), parameter :: v500 = -8.0539615540e-7_r8 +real (r8), parameter :: v501 = 5.0736766814e-7_r8 +real (r8), parameter :: v510 = -3.3052758900e-7_r8 +real (r8), parameter :: v600 = 2.0543094268e-7_r8 + +end module + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 b/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 new file mode 100644 index 0000000000..e3c6afbce0 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 @@ -0,0 +1,71 @@ +!========================================================================== +module gsw_mod_teos10_constants +!========================================================================== + +use gsw_mod_kinds + +implicit none + +real (r8), parameter :: db2pa = 1.0e4_r8 +real (r8), parameter :: rec_db2pa = 1.0e-4_r8 + +real (r8), parameter :: pa2db = 1.0e-4_r8 +real (r8), parameter :: rec_pa2db = 1.0e4_r8 + +real (r8), parameter :: pi = 3.141592653589793_r8 +real (r8), parameter :: deg2rad = pi/180.0_r8 +real (r8), parameter :: rad2deg = 180.0_r8/pi + +real (r8), parameter :: gamma = 2.26e-7_r8 + +! cp0 = The "specific heat" for use [ J/(kg K) ] +! with Conservative Temperature + +real (r8), parameter :: gsw_cp0 = 3991.86795711963_r8 + +! T0 = the Celcius zero point. [ K ] + +real (r8), parameter :: gsw_t0 = 273.15_r8 + +! P0 = Absolute Pressure of one standard atmosphere. [ Pa ] + +real (r8), parameter :: gsw_p0 = 101325.0_r8 + +! SSO = Standard Ocean Reference Salinity. [ g/kg ] + +real (r8), parameter :: gsw_sso = 35.16504_r8 +real (r8), parameter :: gsw_sqrtsso = 5.930011804372737_r8 + +! uPS = unit conversion factor for salinities [ g/kg ] + +real (r8), parameter :: gsw_ups = gsw_sso/35.0_r8 + +! sfac = 1/(40*gsw_ups) + +real (r8), parameter :: gsw_sfac = 0.0248826675584615_r8 + +! deltaS = 24, offset = deltaS*gsw_sfac + +real (r8), parameter :: offset = 5.971840214030754e-1_r8 + +! C3515 = Conductivity at (SP=35, t_68=15, p=0) [ mS/cm ] + +real (r8), parameter :: gsw_c3515 = 42.9140_r8 + +! SonCl = SP to Chlorinity ratio [ (g/kg)^-1 ] + +real (r8), parameter :: gsw_soncl = 1.80655_r8 + +! valence_factor = valence factor of sea salt of Reference Composition +! [ unitless ] + +real (r8), parameter :: gsw_valence_factor = 1.2452898_r8 + +! atomic_weight = mole-weighted atomic weight of sea salt of Reference +! Composition [ g/mol ] + +real (r8), parameter :: gsw_atomic_weight = 31.4038218_r8 + +end module + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_mod_toolbox.f90 b/equation_of_state/TEOS10/gsw_mod_toolbox.f90 new file mode 100644 index 0000000000..a8012e1274 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_mod_toolbox.f90 @@ -0,0 +1,1493 @@ +module gsw_mod_toolbox + +use gsw_mod_kinds + +implicit none + +public :: gsw_add_barrier +public :: gsw_add_mean +public :: gsw_adiabatic_lapse_rate_from_ct +public :: gsw_adiabatic_lapse_rate_ice +public :: gsw_alpha +public :: gsw_alpha_on_beta +public :: gsw_alpha_wrt_t_exact +public :: gsw_alpha_wrt_t_ice +public :: gsw_beta_const_t_exact +public :: gsw_beta +public :: gsw_cabbeling +public :: gsw_c_from_sp +public :: gsw_chem_potential_water_ice +public :: gsw_chem_potential_water_t_exact +public :: gsw_cp_ice +public :: gsw_ct_first_derivatives +public :: gsw_ct_first_derivatives_wrt_t_exact +public :: gsw_ct_freezing_exact +public :: gsw_ct_freezing +public :: gsw_ct_freezing_first_derivatives +public :: gsw_ct_freezing_first_derivatives_poly +public :: gsw_ct_freezing_poly +public :: gsw_ct_from_enthalpy_exact +public :: gsw_ct_from_enthalpy +public :: gsw_ct_from_entropy +public :: gsw_ct_from_pt +public :: gsw_ct_from_rho +public :: gsw_ct_from_t +public :: gsw_ct_maxdensity +public :: gsw_ct_second_derivatives +public :: gsw_deltasa_atlas +public :: gsw_deltasa_from_sp +public :: gsw_dilution_coefficient_t_exact +public :: gsw_dynamic_enthalpy +public :: gsw_enthalpy_ct_exact +public :: gsw_enthalpy_diff +public :: gsw_enthalpy +public :: gsw_enthalpy_first_derivatives_ct_exact +public :: gsw_enthalpy_first_derivatives +public :: gsw_enthalpy_ice +public :: gsw_enthalpy_second_derivatives_ct_exact +public :: gsw_enthalpy_second_derivatives +public :: gsw_enthalpy_sso_0 +public :: gsw_enthalpy_t_exact +public :: gsw_entropy_first_derivatives +public :: gsw_entropy_from_pt +public :: gsw_entropy_from_t +public :: gsw_entropy_ice +public :: gsw_entropy_part +public :: gsw_entropy_part_zerop +public :: gsw_entropy_second_derivatives +public :: gsw_fdelta +public :: gsw_frazil_properties +public :: gsw_frazil_properties_potential +public :: gsw_frazil_properties_potential_poly +public :: gsw_frazil_ratios_adiabatic +public :: gsw_frazil_ratios_adiabatic_poly +public :: gsw_geo_strf_dyn_height +public :: gsw_geo_strf_dyn_height_pc +public :: gsw_gibbs +public :: gsw_gibbs_ice +public :: gsw_gibbs_ice_part_t +public :: gsw_gibbs_ice_pt0 +public :: gsw_gibbs_ice_pt0_pt0 +public :: gsw_gibbs_pt0_pt0 +public :: gsw_grav +public :: gsw_helmholtz_energy_ice +public :: gsw_hill_ratio_at_sp2 +public :: gsw_ice_fraction_to_freeze_seawater +public :: gsw_internal_energy +public :: gsw_internal_energy_ice +public :: gsw_ipv_vs_fnsquared_ratio +public :: gsw_kappa_const_t_ice +public :: gsw_kappa +public :: gsw_kappa_ice +public :: gsw_kappa_t_exact +public :: gsw_latentheat_evap_ct +public :: gsw_latentheat_evap_t +public :: gsw_latentheat_melting +public :: gsw_linear_interp_sa_ct +public :: gsw_melting_ice_equilibrium_sa_ct_ratio +public :: gsw_melting_ice_equilibrium_sa_ct_ratio_poly +public :: gsw_melting_ice_into_seawater +public :: gsw_melting_ice_sa_ct_ratio +public :: gsw_melting_ice_sa_ct_ratio_poly +public :: gsw_melting_seaice_equilibrium_sa_ct_ratio +public :: gsw_melting_seaice_equilibrium_sa_ct_ratio_poly +public :: gsw_melting_seaice_into_seawater +public :: gsw_melting_seaice_sa_ct_ratio +public :: gsw_melting_seaice_sa_ct_ratio_poly +public :: gsw_nsquared +public :: gsw_pot_enthalpy_from_pt_ice +public :: gsw_pot_enthalpy_from_pt_ice_poly +public :: gsw_pot_enthalpy_ice_freezing +public :: gsw_pot_enthalpy_ice_freezing_first_derivatives +public :: gsw_pot_enthalpy_ice_freezing_first_derivatives_poly +public :: gsw_pot_enthalpy_ice_freezing_poly +public :: gsw_pot_rho_t_exact +public :: gsw_pressure_coefficient_ice +public :: gsw_pressure_freezing_ct +public :: gsw_pt0_cold_ice_poly +public :: gsw_pt0_from_t +public :: gsw_pt0_from_t_ice +public :: gsw_pt_first_derivatives +public :: gsw_pt_from_ct +public :: gsw_pt_from_entropy +public :: gsw_pt_from_pot_enthalpy_ice +public :: gsw_pt_from_pot_enthalpy_ice_poly_dh +public :: gsw_pt_from_pot_enthalpy_ice_poly +public :: gsw_pt_from_t +public :: gsw_pt_from_t_ice +public :: gsw_pt_second_derivatives +public :: gsw_rho_alpha_beta +public :: gsw_rho +public :: gsw_rho_first_derivatives +public :: gsw_rho_first_derivatives_wrt_enthalpy +public :: gsw_rho_ice +public :: gsw_rho_second_derivatives +public :: gsw_rho_second_derivatives_wrt_enthalpy +public :: gsw_rho_t_exact +public :: gsw_rr68_interp_sa_ct +public :: gsw_saar +public :: gsw_sa_freezing_estimate +public :: gsw_sa_freezing_from_ct +public :: gsw_sa_freezing_from_ct_poly +public :: gsw_sa_freezing_from_t +public :: gsw_sa_freezing_from_t_poly +public :: gsw_sa_from_rho +public :: gsw_sa_from_sp_baltic +public :: gsw_sa_from_sp +public :: gsw_sa_from_sstar +public :: gsw_sa_p_inrange +public :: gsw_seaice_fraction_to_freeze_seawater +public :: gsw_sigma0 +public :: gsw_sigma1 +public :: gsw_sigma2 +public :: gsw_sigma3 +public :: gsw_sigma4 +public :: gsw_sound_speed +public :: gsw_sound_speed_ice +public :: gsw_sound_speed_t_exact +public :: gsw_specvol_alpha_beta +public :: gsw_specvol_anom_standard +public :: gsw_specvol +public :: gsw_specvol_first_derivatives +public :: gsw_specvol_first_derivatives_wrt_enthalpy +public :: gsw_specvol_ice +public :: gsw_specvol_second_derivatives +public :: gsw_specvol_second_derivatives_wrt_enthalpy +public :: gsw_specvol_sso_0 +public :: gsw_specvol_t_exact +public :: gsw_sp_from_c +public :: gsw_sp_from_sa_baltic +public :: gsw_sp_from_sa +public :: gsw_sp_from_sk +public :: gsw_sp_from_sr +public :: gsw_sp_from_sstar +public :: gsw_spiciness0 +public :: gsw_spiciness1 +public :: gsw_spiciness2 +public :: gsw_sr_from_sp +public :: gsw_sstar_from_sa +public :: gsw_sstar_from_sp +public :: gsw_t_deriv_chem_potential_water_t_exact +public :: gsw_t_freezing_exact +public :: gsw_t_freezing +public :: gsw_t_freezing_first_derivatives +public :: gsw_t_freezing_first_derivatives_poly +public :: gsw_t_freezing_poly +public :: gsw_t_from_ct +public :: gsw_t_from_pt0_ice +public :: gsw_thermobaric +public :: gsw_turner_rsubrho +public :: gsw_util_indx +public :: gsw_util_interp1q_int +public :: gsw_util_sort_real +public :: gsw_util_xinterp1 +public :: gsw_z_from_p + +interface + + pure subroutine gsw_add_barrier (input_data, long, lat, long_grid, & + lat_grid, dlong_grid, dlat_grid, output_data) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: long, lat, long_grid, lat_grid, dlong_grid + real (r8), intent(in) :: dlat_grid + real (r8), intent(in), dimension(4) :: input_data + real (r8), intent(out), dimension(4) :: output_data + end subroutine gsw_add_barrier + + pure subroutine gsw_add_mean (data_in, data_out) + use gsw_mod_kinds + implicit none + real (r8), intent(in), dimension(4) :: data_in + real (r8), intent(out), dimension(4) :: data_out + end subroutine gsw_add_mean + + elemental function gsw_adiabatic_lapse_rate_from_ct (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_adiabatic_lapse_rate_from_ct + end function gsw_adiabatic_lapse_rate_from_ct + + elemental function gsw_adiabatic_lapse_rate_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_adiabatic_lapse_rate_ice + end function gsw_adiabatic_lapse_rate_ice + + elemental function gsw_alpha (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_alpha + end function gsw_alpha + + elemental function gsw_alpha_on_beta (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_alpha_on_beta + end function gsw_alpha_on_beta + + elemental function gsw_alpha_wrt_t_exact (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_alpha_wrt_t_exact + end function gsw_alpha_wrt_t_exact + + elemental function gsw_alpha_wrt_t_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_alpha_wrt_t_ice + end function gsw_alpha_wrt_t_ice + + elemental function gsw_beta_const_t_exact (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_beta_const_t_exact + end function gsw_beta_const_t_exact + + elemental function gsw_beta (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_beta + end function gsw_beta + + elemental function gsw_cabbeling (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_cabbeling + end function gsw_cabbeling + + elemental function gsw_c_from_sp (sp, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sp, t, p + real (r8) :: gsw_c_from_sp + end function gsw_c_from_sp + + elemental function gsw_chem_potential_water_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_chem_potential_water_ice + end function gsw_chem_potential_water_ice + + elemental function gsw_chem_potential_water_t_exact (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_chem_potential_water_t_exact + end function gsw_chem_potential_water_t_exact + + elemental function gsw_cp_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_cp_ice + end function gsw_cp_ice + + elemental subroutine gsw_ct_first_derivatives (sa, pt, ct_sa, ct_pt) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, pt + real (r8), intent(out), optional :: ct_sa, ct_pt + end subroutine gsw_ct_first_derivatives + + elemental subroutine gsw_ct_first_derivatives_wrt_t_exact (sa, t, p, & + ct_sa_wrt_t, ct_t_wrt_t, ct_p_wrt_t) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8), intent(out), optional :: ct_p_wrt_t, ct_sa_wrt_t, ct_t_wrt_t + end subroutine gsw_ct_first_derivatives_wrt_t_exact + + elemental function gsw_ct_freezing_exact (sa, p, saturation_fraction) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, saturation_fraction + real (r8) :: gsw_ct_freezing_exact + end function gsw_ct_freezing_exact + + elemental function gsw_ct_freezing (sa, p, saturation_fraction, poly) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, saturation_fraction + logical, intent(in), optional :: poly + real (r8) :: gsw_ct_freezing + end function gsw_ct_freezing + + elemental subroutine gsw_ct_freezing_first_derivatives (sa, p, & + saturation_fraction, ctfreezing_sa, ctfreezing_p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, saturation_fraction + real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p + end subroutine gsw_ct_freezing_first_derivatives + + elemental subroutine gsw_ct_freezing_first_derivatives_poly (sa, p, & + saturation_fraction, ctfreezing_sa, ctfreezing_p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, saturation_fraction + real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p + end subroutine gsw_ct_freezing_first_derivatives_poly + + elemental function gsw_ct_freezing_poly (sa, p, saturation_fraction) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, saturation_fraction + real (r8) :: gsw_ct_freezing_poly + end function gsw_ct_freezing_poly + + elemental function gsw_ct_from_enthalpy_exact (sa, h, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, h, p + real (r8) :: gsw_ct_from_enthalpy_exact + end function gsw_ct_from_enthalpy_exact + + elemental function gsw_ct_from_enthalpy (sa, h, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, h, p + real (r8) :: gsw_ct_from_enthalpy + end function gsw_ct_from_enthalpy + + elemental function gsw_ct_from_entropy (sa, entropy) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, entropy + real (r8) :: gsw_ct_from_entropy + end function gsw_ct_from_entropy + + elemental function gsw_ct_from_pt (sa, pt) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, pt + real (r8) :: gsw_ct_from_pt + end function gsw_ct_from_pt + + elemental subroutine gsw_ct_from_rho (rho, sa, p, ct, ct_multiple) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: rho, sa, p + real (r8), intent(out) :: ct + real (r8), intent(out), optional :: ct_multiple + end subroutine gsw_ct_from_rho + + elemental function gsw_ct_from_t (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_ct_from_t + end function gsw_ct_from_t + + elemental function gsw_ct_maxdensity (sa, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p + real (r8) :: gsw_ct_maxdensity + end function gsw_ct_maxdensity + + elemental subroutine gsw_ct_second_derivatives (sa, pt, ct_sa_sa, ct_sa_pt, & + ct_pt_pt) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, pt + real (r8), intent(out), optional :: ct_sa_sa, ct_sa_pt, ct_pt_pt + end subroutine gsw_ct_second_derivatives + + elemental function gsw_deltasa_atlas (p, long, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: p, long, lat + real (r8) :: gsw_deltasa_atlas + end function gsw_deltasa_atlas + + elemental function gsw_deltasa_from_sp (sp, p, long, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sp, p, long, lat + real (r8) :: gsw_deltasa_from_sp + end function gsw_deltasa_from_sp + + elemental function gsw_dilution_coefficient_t_exact (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_dilution_coefficient_t_exact + end function gsw_dilution_coefficient_t_exact + + elemental function gsw_dynamic_enthalpy (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_dynamic_enthalpy + end function gsw_dynamic_enthalpy + + elemental function gsw_enthalpy_ct_exact (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_enthalpy_ct_exact + end function gsw_enthalpy_ct_exact + + elemental function gsw_enthalpy_diff (sa, ct, p_shallow, p_deep) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p_shallow, p_deep + real (r8) :: gsw_enthalpy_diff + end function gsw_enthalpy_diff + + elemental function gsw_enthalpy (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_enthalpy + end function gsw_enthalpy + + elemental subroutine gsw_enthalpy_first_derivatives_ct_exact (sa, ct, p, & + h_sa, h_ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8), intent(out), optional :: h_sa, h_ct + end subroutine gsw_enthalpy_first_derivatives_ct_exact + + elemental subroutine gsw_enthalpy_first_derivatives (sa, ct, p, h_sa, h_ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8), intent(out), optional :: h_sa, h_ct + end subroutine gsw_enthalpy_first_derivatives + + elemental function gsw_enthalpy_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_enthalpy_ice + end function gsw_enthalpy_ice + + elemental subroutine gsw_enthalpy_second_derivatives_ct_exact (sa, ct, p, & + h_sa_sa, h_sa_ct, h_ct_ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct + end subroutine gsw_enthalpy_second_derivatives_ct_exact + + elemental subroutine gsw_enthalpy_second_derivatives (sa, ct, p, h_sa_sa, & + h_sa_ct, h_ct_ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct + end subroutine gsw_enthalpy_second_derivatives + + elemental function gsw_enthalpy_sso_0 (p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: p + real (r8) :: gsw_enthalpy_sso_0 + end function gsw_enthalpy_sso_0 + + elemental function gsw_enthalpy_t_exact (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_enthalpy_t_exact + end function gsw_enthalpy_t_exact + + elemental subroutine gsw_entropy_first_derivatives (sa, ct, eta_sa, eta_ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8), intent(out), optional :: eta_sa, eta_ct + end subroutine gsw_entropy_first_derivatives + + elemental function gsw_entropy_from_pt (sa, pt) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, pt + real (r8) :: gsw_entropy_from_pt + end function gsw_entropy_from_pt + + elemental function gsw_entropy_from_t (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_entropy_from_t + end function gsw_entropy_from_t + + elemental function gsw_entropy_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_entropy_ice + end function gsw_entropy_ice + + elemental function gsw_entropy_part (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_entropy_part + end function gsw_entropy_part + + elemental function gsw_entropy_part_zerop (sa, pt0) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, pt0 + real (r8) :: gsw_entropy_part_zerop + end function gsw_entropy_part_zerop + + elemental subroutine gsw_entropy_second_derivatives (sa, ct, eta_sa_sa, & + eta_sa_ct, eta_ct_ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8), intent(out), optional :: eta_sa_sa, eta_sa_ct, eta_ct_ct + end subroutine gsw_entropy_second_derivatives + + elemental function gsw_fdelta (p, long, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: p, long, lat + real (r8) :: gsw_fdelta + end function gsw_fdelta + + elemental subroutine gsw_frazil_properties (sa_bulk, h_bulk, p, & + sa_final, ct_final, w_ih_final) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa_bulk, h_bulk, p + real (r8), intent(out) :: sa_final, ct_final, w_ih_final + end subroutine gsw_frazil_properties + + elemental subroutine gsw_frazil_properties_potential (sa_bulk, h_pot_bulk,& + p, sa_final, ct_final, w_ih_final) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa_bulk, h_pot_bulk, p + real (r8), intent(out) :: sa_final, ct_final, w_ih_final + end subroutine gsw_frazil_properties_potential + + elemental subroutine gsw_frazil_properties_potential_poly (sa_bulk, & + h_pot_bulk, p, sa_final, ct_final, w_ih_final) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa_bulk, h_pot_bulk, p + real (r8), intent(out) :: sa_final, ct_final, w_ih_final + end subroutine gsw_frazil_properties_potential_poly + + elemental subroutine gsw_frazil_ratios_adiabatic (sa, p, w_ih, & + dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, w_ih + real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil + end subroutine gsw_frazil_ratios_adiabatic + + elemental subroutine gsw_frazil_ratios_adiabatic_poly (sa, p, w_ih, & + dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, w_ih + real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil + end subroutine gsw_frazil_ratios_adiabatic_poly + + pure function gsw_geo_strf_dyn_height (sa, ct, p, p_ref) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa(:), ct(:), p(:), p_ref + real (r8) :: gsw_geo_strf_dyn_height(size(sa)) + end function gsw_geo_strf_dyn_height + + pure subroutine gsw_geo_strf_dyn_height_pc (sa, ct, delta_p, & + geo_strf_dyn_height_pc, p_mid) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa(:), ct(:), delta_p(:) + real (r8), intent(out) :: geo_strf_dyn_height_pc(:), p_mid(:) + end subroutine gsw_geo_strf_dyn_height_pc + + elemental function gsw_gibbs (ns, nt, np, sa, t, p) + use gsw_mod_kinds + implicit none + integer, intent(in) :: ns, nt, np + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_gibbs + end function gsw_gibbs + + elemental function gsw_gibbs_ice (nt, np, t, p) + use gsw_mod_kinds + implicit none + integer, intent(in) :: nt, np + real (r8), intent(in) :: t, p + real (r8) :: gsw_gibbs_ice + end function gsw_gibbs_ice + + elemental function gsw_gibbs_ice_part_t (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_gibbs_ice_part_t + end function gsw_gibbs_ice_part_t + + elemental function gsw_gibbs_ice_pt0 (pt0) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: pt0 + real (r8) :: gsw_gibbs_ice_pt0 + end function gsw_gibbs_ice_pt0 + + elemental function gsw_gibbs_ice_pt0_pt0 (pt0) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: pt0 + real (r8) :: gsw_gibbs_ice_pt0_pt0 + end function gsw_gibbs_ice_pt0_pt0 + + elemental function gsw_gibbs_pt0_pt0 (sa, pt0) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, pt0 + real (r8) :: gsw_gibbs_pt0_pt0 + end function gsw_gibbs_pt0_pt0 + + elemental function gsw_grav (lat, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: lat, p + real (r8) :: gsw_grav + end function gsw_grav + + elemental function gsw_helmholtz_energy_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_helmholtz_energy_ice + end function gsw_helmholtz_energy_ice + + elemental function gsw_hill_ratio_at_sp2 (t) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t + real (r8) :: gsw_hill_ratio_at_sp2 + end function gsw_hill_ratio_at_sp2 + + elemental subroutine gsw_ice_fraction_to_freeze_seawater (sa, ct, p, & + t_ih, sa_freeze, ct_freeze, w_ih) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p, t_ih + real (r8), intent(out) :: sa_freeze, ct_freeze, w_ih + end subroutine gsw_ice_fraction_to_freeze_seawater + + elemental function gsw_internal_energy (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_internal_energy + end function gsw_internal_energy + + elemental function gsw_internal_energy_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_internal_energy_ice + end function gsw_internal_energy_ice + + pure subroutine gsw_ipv_vs_fnsquared_ratio (sa, ct, p, p_ref, & + ipv_vs_fnsquared_ratio, p_mid) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa(:), ct(:), p(:), p_ref + real (r8), intent(out) :: ipv_vs_fnsquared_ratio(:), p_mid(:) + end subroutine gsw_ipv_vs_fnsquared_ratio + + elemental function gsw_kappa_const_t_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_kappa_const_t_ice + end function gsw_kappa_const_t_ice + + elemental function gsw_kappa (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_kappa + end function gsw_kappa + + elemental function gsw_kappa_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_kappa_ice + end function gsw_kappa_ice + + elemental function gsw_kappa_t_exact (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_kappa_t_exact + end function gsw_kappa_t_exact + + elemental function gsw_latentheat_evap_ct (sa, ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8) :: gsw_latentheat_evap_ct + end function gsw_latentheat_evap_ct + + elemental function gsw_latentheat_evap_t (sa, t) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t + real (r8) :: gsw_latentheat_evap_t + end function gsw_latentheat_evap_t + + elemental function gsw_latentheat_melting (sa, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p + real (r8) :: gsw_latentheat_melting + end function gsw_latentheat_melting + + pure subroutine gsw_linear_interp_sa_ct (sa, ct, p, p_i, sa_i, ct_i) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa(:), ct(:), p(:), p_i(:) + real (r8), intent(out) :: sa_i(:), ct_i(:) + end subroutine gsw_linear_interp_sa_ct + + elemental function gsw_melting_ice_equilibrium_sa_ct_ratio (sa, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p + real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio + end function gsw_melting_ice_equilibrium_sa_ct_ratio + + elemental function gsw_melting_ice_equilibrium_sa_ct_ratio_poly (sa, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p + real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio_poly + end function gsw_melting_ice_equilibrium_sa_ct_ratio_poly + + elemental subroutine gsw_melting_ice_into_seawater (sa, ct, p, w_ih, t_ih,& + sa_final, ct_final, w_ih_final) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p, w_ih, t_ih + real (r8), intent(out) :: sa_final, ct_final, w_ih_final + end subroutine gsw_melting_ice_into_seawater + + elemental function gsw_melting_ice_sa_ct_ratio (sa, ct, p, t_ih) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p, t_ih + real (r8) :: gsw_melting_ice_sa_ct_ratio + end function gsw_melting_ice_sa_ct_ratio + + elemental function gsw_melting_ice_sa_ct_ratio_poly (sa, ct, p, t_ih) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p, t_ih + real (r8) :: gsw_melting_ice_sa_ct_ratio_poly + end function gsw_melting_ice_sa_ct_ratio_poly + + elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio (sa, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p + real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio + end function gsw_melting_seaice_equilibrium_sa_ct_ratio + + elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio_poly (sa, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p + real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio_poly + end function gsw_melting_seaice_equilibrium_sa_ct_ratio_poly + + elemental subroutine gsw_melting_seaice_into_seawater (sa, ct, p, & + w_seaice, sa_seaice, t_seaice, sa_final, ct_final) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p, w_seaice, sa_seaice, t_seaice + real (r8), intent(out) :: sa_final, ct_final + end subroutine gsw_melting_seaice_into_seawater + + elemental function gsw_melting_seaice_sa_ct_ratio (sa, ct, p, sa_seaice, & + t_seaice) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice + real (r8) :: gsw_melting_seaice_sa_ct_ratio + end function gsw_melting_seaice_sa_ct_ratio + + elemental function gsw_melting_seaice_sa_ct_ratio_poly (sa, ct, p, & + sa_seaice, t_seaice) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice + real (r8) :: gsw_melting_seaice_sa_ct_ratio_poly + end function gsw_melting_seaice_sa_ct_ratio_poly + + pure subroutine gsw_nsquared (sa, ct, p, lat, n2, p_mid) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa(:), ct(:), p(:), lat(:) + real (r8), intent(out) :: n2(:), p_mid(:) + end subroutine gsw_nsquared + + elemental function gsw_pot_enthalpy_from_pt_ice (pt0_ice) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: pt0_ice + real (r8) :: gsw_pot_enthalpy_from_pt_ice + end function gsw_pot_enthalpy_from_pt_ice + + elemental function gsw_pot_enthalpy_from_pt_ice_poly (pt0_ice) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: pt0_ice + real (r8) :: gsw_pot_enthalpy_from_pt_ice_poly + end function gsw_pot_enthalpy_from_pt_ice_poly + + elemental function gsw_pot_enthalpy_ice_freezing (sa, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p + real (r8) :: gsw_pot_enthalpy_ice_freezing + end function gsw_pot_enthalpy_ice_freezing + + elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives (sa, & + p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p + real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa + real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p + end subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives + + elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly(& + sa, p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p + real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa + real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p + end subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly + + elemental function gsw_pot_enthalpy_ice_freezing_poly (sa, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p + real (r8) :: gsw_pot_enthalpy_ice_freezing_poly + end function gsw_pot_enthalpy_ice_freezing_poly + + elemental function gsw_pot_rho_t_exact (sa, t, p, p_ref) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p, p_ref + real (r8) :: gsw_pot_rho_t_exact + end function gsw_pot_rho_t_exact + + elemental function gsw_pressure_coefficient_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_pressure_coefficient_ice + end function gsw_pressure_coefficient_ice + + elemental function gsw_pressure_freezing_ct (sa, ct, saturation_fraction) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, saturation_fraction + real (r8) :: gsw_pressure_freezing_ct + end function gsw_pressure_freezing_ct + + elemental function gsw_pt0_cold_ice_poly (pot_enthalpy_ice) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: pot_enthalpy_ice + real (r8) :: gsw_pt0_cold_ice_poly + end function gsw_pt0_cold_ice_poly + + elemental function gsw_pt0_from_t (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_pt0_from_t + end function gsw_pt0_from_t + + elemental function gsw_pt0_from_t_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_pt0_from_t_ice + end function gsw_pt0_from_t_ice + + elemental subroutine gsw_pt_first_derivatives (sa, ct, pt_sa, pt_ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8), intent(out), optional :: pt_sa, pt_ct + end subroutine gsw_pt_first_derivatives + + elemental function gsw_pt_from_ct (sa, ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8) :: gsw_pt_from_ct + end function gsw_pt_from_ct + + elemental function gsw_pt_from_entropy (sa, entropy) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, entropy + real (r8) :: gsw_pt_from_entropy + end function gsw_pt_from_entropy + + elemental function gsw_pt_from_pot_enthalpy_ice (pot_enthalpy_ice) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: pot_enthalpy_ice + real (r8) :: gsw_pt_from_pot_enthalpy_ice + end function gsw_pt_from_pot_enthalpy_ice + + elemental function gsw_pt_from_pot_enthalpy_ice_poly_dh (pot_enthalpy_ice) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: pot_enthalpy_ice + real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly_dh + end function gsw_pt_from_pot_enthalpy_ice_poly_dh + + elemental function gsw_pt_from_pot_enthalpy_ice_poly (pot_enthalpy_ice) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: pot_enthalpy_ice + real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly + end function gsw_pt_from_pot_enthalpy_ice_poly + + elemental function gsw_pt_from_t (sa, t, p, p_ref) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p, p_ref + real (r8) :: gsw_pt_from_t + end function gsw_pt_from_t + + elemental function gsw_pt_from_t_ice (t, p, p_ref) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p, p_ref + real (r8) :: gsw_pt_from_t_ice + end function gsw_pt_from_t_ice + + elemental subroutine gsw_pt_second_derivatives (sa, ct, pt_sa_sa, & + pt_sa_ct, pt_ct_ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8), intent(out), optional :: pt_sa_sa, pt_sa_ct, pt_ct_ct + end subroutine gsw_pt_second_derivatives + + elemental subroutine gsw_rho_alpha_beta (sa, ct, p, rho, alpha, beta) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8), intent(out), optional :: rho, alpha, beta + end subroutine gsw_rho_alpha_beta + + elemental function gsw_rho (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_rho + end function gsw_rho + + elemental subroutine gsw_rho_first_derivatives (sa, ct, p, drho_dsa, & + drho_dct, drho_dp) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8), intent(out), optional :: drho_dsa, drho_dct, drho_dp + end subroutine gsw_rho_first_derivatives + + elemental subroutine gsw_rho_first_derivatives_wrt_enthalpy (sa, ct, p, & + rho_sa, rho_h) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8), intent(out), optional :: rho_sa, rho_h + end subroutine gsw_rho_first_derivatives_wrt_enthalpy + + elemental function gsw_rho_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_rho_ice + end function gsw_rho_ice + + elemental subroutine gsw_rho_second_derivatives (sa, ct, p, rho_sa_sa, & + rho_sa_ct, rho_ct_ct, rho_sa_p, rho_ct_p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8), intent(out), optional :: rho_sa_sa, rho_sa_ct, rho_ct_ct + real (r8), intent(out), optional :: rho_sa_p, rho_ct_p + end subroutine gsw_rho_second_derivatives + + elemental subroutine gsw_rho_second_derivatives_wrt_enthalpy (sa, ct, p, & + rho_sa_sa, rho_sa_h, rho_h_h) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8), intent(out), optional :: rho_sa_sa, rho_sa_h, rho_h_h + end subroutine gsw_rho_second_derivatives_wrt_enthalpy + + elemental function gsw_rho_t_exact (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_rho_t_exact + end function gsw_rho_t_exact + + pure subroutine gsw_rr68_interp_sa_ct (sa, ct, p, p_i, sa_i, ct_i) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa(:), ct(:), p(:), p_i(:) + real (r8), intent(out) :: sa_i(:), ct_i(:) + end subroutine gsw_rr68_interp_sa_ct + + elemental function gsw_saar (p, long, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: p, long, lat + real (r8) :: gsw_saar + end function gsw_saar + + elemental function gsw_sa_freezing_estimate (p, saturation_fraction, ct, t) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: p, saturation_fraction + real (r8), intent(in), optional :: ct, t + real (r8) :: gsw_sa_freezing_estimate + end function gsw_sa_freezing_estimate + + elemental function gsw_sa_freezing_from_ct (ct, p, saturation_fraction) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: ct, p, saturation_fraction + real (r8) :: gsw_sa_freezing_from_ct + end function gsw_sa_freezing_from_ct + + elemental function gsw_sa_freezing_from_ct_poly (ct, p, saturation_fraction) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: ct, p, saturation_fraction + real (r8) :: gsw_sa_freezing_from_ct_poly + end function gsw_sa_freezing_from_ct_poly + + elemental function gsw_sa_freezing_from_t (t, p, saturation_fraction) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p, saturation_fraction + real (r8) :: gsw_sa_freezing_from_t + end function gsw_sa_freezing_from_t + + elemental function gsw_sa_freezing_from_t_poly (t, p, saturation_fraction) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p, saturation_fraction + real (r8) :: gsw_sa_freezing_from_t_poly + end function gsw_sa_freezing_from_t_poly + + elemental function gsw_sa_from_rho (rho, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: rho, ct, p + real (r8) :: gsw_sa_from_rho + end function gsw_sa_from_rho + + elemental function gsw_sa_from_sp_baltic (sp, long, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sp, long, lat + real (r8) :: gsw_sa_from_sp_baltic + end function gsw_sa_from_sp_baltic + + elemental function gsw_sa_from_sp (sp, p, long, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sp, p, long, lat + real (r8) :: gsw_sa_from_sp + end function gsw_sa_from_sp + + elemental function gsw_sa_from_sstar (sstar, p, long, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sstar, p, long, lat + real (r8) :: gsw_sa_from_sstar + end function gsw_sa_from_sstar + + elemental function gsw_sa_p_inrange (sa, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p + logical :: gsw_sa_p_inrange + end function gsw_sa_p_inrange + + elemental subroutine gsw_seaice_fraction_to_freeze_seawater (sa, ct, p, & + sa_seaice, t_seaice, sa_freeze, ct_freeze, w_seaice) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice + real (r8), intent(out) :: sa_freeze, ct_freeze, w_seaice + end subroutine gsw_seaice_fraction_to_freeze_seawater + + elemental function gsw_sigma0 (sa, ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8) :: gsw_sigma0 + end function gsw_sigma0 + + elemental function gsw_sigma1 (sa, ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8) :: gsw_sigma1 + end function gsw_sigma1 + + elemental function gsw_sigma2 (sa, ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8) :: gsw_sigma2 + end function gsw_sigma2 + + elemental function gsw_sigma3 (sa, ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8) :: gsw_sigma3 + end function gsw_sigma3 + + elemental function gsw_sigma4 (sa, ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8) :: gsw_sigma4 + end function gsw_sigma4 + + elemental function gsw_sound_speed (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_sound_speed + end function gsw_sound_speed + + elemental function gsw_sound_speed_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_sound_speed_ice + end function gsw_sound_speed_ice + + elemental function gsw_sound_speed_t_exact (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_sound_speed_t_exact + end function gsw_sound_speed_t_exact + + elemental subroutine gsw_specvol_alpha_beta (sa, ct, p, specvol, alpha, & + beta) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8), intent(out), optional :: specvol, alpha, beta + end subroutine gsw_specvol_alpha_beta + + elemental function gsw_specvol_anom_standard (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_specvol_anom_standard + end function gsw_specvol_anom_standard + + elemental function gsw_specvol (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_specvol + end function gsw_specvol + + elemental subroutine gsw_specvol_first_derivatives (sa, ct, p, v_sa, v_ct, & + v_p, iflag) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + integer, intent(in), optional :: iflag + real (r8), intent(out), optional :: v_sa, v_ct, v_p + end subroutine gsw_specvol_first_derivatives + + elemental subroutine gsw_specvol_first_derivatives_wrt_enthalpy (sa, ct, & + p, v_sa, v_h, iflag) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + integer, intent(in), optional :: iflag + real (r8), intent(out), optional :: v_sa, v_h + end subroutine gsw_specvol_first_derivatives_wrt_enthalpy + + elemental function gsw_specvol_ice (t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: t, p + real (r8) :: gsw_specvol_ice + end function gsw_specvol_ice + + elemental subroutine gsw_specvol_second_derivatives (sa, ct, p, v_sa_sa, & + v_sa_ct, v_ct_ct, v_sa_p, v_ct_p, iflag) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + integer, intent(in), optional :: iflag + real (r8), intent(out), optional :: v_sa_sa, v_sa_ct, v_ct_ct, v_sa_p, v_ct_p + end subroutine gsw_specvol_second_derivatives + + elemental subroutine gsw_specvol_second_derivatives_wrt_enthalpy (sa, ct, & + p, v_sa_sa, v_sa_h, v_h_h, iflag) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + integer, intent(in), optional :: iflag + real (r8), intent(out), optional :: v_sa_sa, v_sa_h, v_h_h + end subroutine gsw_specvol_second_derivatives_wrt_enthalpy + + elemental function gsw_specvol_sso_0 (p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: p + real (r8) :: gsw_specvol_sso_0 + end function gsw_specvol_sso_0 + + elemental function gsw_specvol_t_exact (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_specvol_t_exact + end function gsw_specvol_t_exact + + elemental function gsw_sp_from_c (c, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: c, t, p + real (r8) :: gsw_sp_from_c + end function gsw_sp_from_c + + elemental function gsw_sp_from_sa_baltic (sa, long, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, long, lat + real (r8) :: gsw_sp_from_sa_baltic + end function gsw_sp_from_sa_baltic + + elemental function gsw_sp_from_sa (sa, p, long, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, long, lat + real (r8) :: gsw_sp_from_sa + end function gsw_sp_from_sa + + elemental function gsw_sp_from_sk (sk) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sk + real (r8) :: gsw_sp_from_sk + end function gsw_sp_from_sk + + elemental function gsw_sp_from_sr (sr) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sr + real (r8) :: gsw_sp_from_sr + end function gsw_sp_from_sr + + elemental function gsw_sp_from_sstar (sstar, p, long, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sstar, p, long, lat + real (r8) :: gsw_sp_from_sstar + end function gsw_sp_from_sstar + + elemental function gsw_spiciness0 (sa, ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8) :: gsw_spiciness0 + end function gsw_spiciness0 + + elemental function gsw_spiciness1 (sa, ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8) :: gsw_spiciness1 + end function gsw_spiciness1 + + elemental function gsw_spiciness2 (sa, ct) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct + real (r8) :: gsw_spiciness2 + end function gsw_spiciness2 + + elemental function gsw_sr_from_sp (sp) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sp + real (r8) :: gsw_sr_from_sp + end function gsw_sr_from_sp + + elemental function gsw_sstar_from_sa (sa, p, long, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, long, lat + real (r8) :: gsw_sstar_from_sa + end function gsw_sstar_from_sa + + elemental function gsw_sstar_from_sp (sp, p, long, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sp, p, long, lat + real (r8) :: gsw_sstar_from_sp + end function gsw_sstar_from_sp + + elemental function gsw_t_deriv_chem_potential_water_t_exact (sa, t, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, t, p + real (r8) :: gsw_t_deriv_chem_potential_water_t_exact + end function gsw_t_deriv_chem_potential_water_t_exact + + elemental function gsw_t_freezing_exact (sa, p, saturation_fraction) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, saturation_fraction + real (r8) :: gsw_t_freezing_exact + end function gsw_t_freezing_exact + + elemental function gsw_t_freezing (sa, p, saturation_fraction, poly) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, saturation_fraction + logical, intent(in), optional :: poly + real (r8) :: gsw_t_freezing + end function gsw_t_freezing + + elemental subroutine gsw_t_freezing_first_derivatives (sa, p, & + saturation_fraction, tfreezing_sa, tfreezing_p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, saturation_fraction + real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p + end subroutine gsw_t_freezing_first_derivatives + + elemental subroutine gsw_t_freezing_first_derivatives_poly (sa, p, & + saturation_fraction, tfreezing_sa, tfreezing_p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p, saturation_fraction + real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p + end subroutine gsw_t_freezing_first_derivatives_poly + + elemental function gsw_t_freezing_poly (sa, p, saturation_fraction, polynomial) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, p + real (r8), intent(in), optional :: saturation_fraction + logical, intent(in), optional :: polynomial + real (r8) :: gsw_t_freezing_poly + end function gsw_t_freezing_poly + + elemental function gsw_t_from_ct (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_t_from_ct + end function gsw_t_from_ct + + elemental function gsw_t_from_pt0_ice (pt0_ice, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: pt0_ice, p + real (r8) :: gsw_t_from_pt0_ice + end function gsw_t_from_pt0_ice + + elemental function gsw_thermobaric (sa, ct, p) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa, ct, p + real (r8) :: gsw_thermobaric + end function gsw_thermobaric + + pure subroutine gsw_turner_rsubrho (sa, ct, p, tu, rsubrho, p_mid) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: sa(:), ct(:), p(:) + real (r8), intent(out) :: tu(:), rsubrho(:), p_mid(:) + end subroutine gsw_turner_rsubrho + + pure subroutine gsw_util_indx (x, n, z, k) + use gsw_mod_kinds + integer, intent(in) :: n + integer, intent(out) :: k + real (r8), intent(in), dimension(n) :: x + real (r8), intent(in) :: z + end subroutine gsw_util_indx + + pure function gsw_util_interp1q_int (x, iy, x_i) result(y_i) + use gsw_mod_kinds + implicit none + integer, intent(in) :: iy(:) + real (r8), intent(in) :: x(:), x_i(:) + real (r8) :: y_i(size(x_i)) + end function gsw_util_interp1q_int + + pure function gsw_util_sort_real (rarray) result(iarray) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: rarray(:) ! Values to be sorted + integer :: iarray(size(rarray)) ! Sorted ids + end function gsw_util_sort_real + + pure function gsw_util_xinterp1 (x, y, n, x0) + use gsw_mod_kinds + implicit none + integer, intent(in) :: n + real (r8), intent(in) :: x0 + real (r8), dimension(n), intent(in) :: x, y + real (r8) :: gsw_util_xinterp1 + end function gsw_util_xinterp1 + + elemental function gsw_z_from_p (p, lat) + use gsw_mod_kinds + implicit none + real (r8), intent(in) :: p, lat + real (r8) :: gsw_z_from_p + end function gsw_z_from_p + +end interface + +end module gsw_mod_toolbox diff --git a/equation_of_state/TEOS10/gsw_pt0_from_t.f90 b/equation_of_state/TEOS10/gsw_pt0_from_t.f90 new file mode 100644 index 0000000000..63c2c83292 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_pt0_from_t.f90 @@ -0,0 +1,59 @@ +!========================================================================== +elemental function gsw_pt0_from_t (sa, t, p) +!========================================================================== +! +! Calculates potential temperature with reference pressure, p_ref = 0 dbar. +! +! sa : Absolute Salinity [g/kg] +! t : in-situ temperature [deg C] +! p : sea pressure [dbar] +! +! gsw_pt0_from_t : potential temperature, p_ref = 0 [deg C] +!-------------------------------------------------------------------------- + +use gsw_mod_toolbox, only : gsw_entropy_part, gsw_entropy_part_zerop +use gsw_mod_toolbox, only : gsw_gibbs_pt0_pt0 + +use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sso, gsw_t0, gsw_ups + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, t, p + +real (r8) :: gsw_pt0_from_t + +integer n, no_iter +real (r8) :: s1, true_entropy_part, pt0m +real (r8) :: pt0, pt0_old, de_dt, dentropy, dentropy_dt + +s1 = sa/gsw_ups + +pt0 = t + p*( 8.65483913395442e-6_r8 - & + s1 * 1.41636299744881e-6_r8 - & + p * 7.38286467135737e-9_r8 + & + t *(-8.38241357039698e-6_r8 + & + s1 * 2.83933368585534e-8_r8 + & + t * 1.77803965218656e-8_r8 + & + p * 1.71155619208233e-10_r8)) + +dentropy_dt = gsw_cp0/((gsw_t0 + pt0)*(1.0_r8 - 0.05_r8*(1.0_r8 - sa/gsw_sso))) + +true_entropy_part = gsw_entropy_part(sa,t,p) + +do no_iter = 1, 2 + pt0_old = pt0 + dentropy = gsw_entropy_part_zerop(sa,pt0_old) - true_entropy_part + pt0 = pt0_old - dentropy/dentropy_dt + pt0m = 0.5_r8*(pt0 + pt0_old) + dentropy_dt = -gsw_gibbs_pt0_pt0(sa,pt0m) + pt0 = pt0_old - dentropy/dentropy_dt +end do + +gsw_pt0_from_t = pt0 + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_pt_from_ct.f90 b/equation_of_state/TEOS10/gsw_pt_from_ct.f90 new file mode 100644 index 0000000000..b856b923c8 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_pt_from_ct.f90 @@ -0,0 +1,72 @@ +!========================================================================== +elemental function gsw_pt_from_ct (sa, ct) +!========================================================================== +! +! potential temperature of seawater from conservative temperature +! +! sa : Absolute Salinity [g/kg] +! ct : Conservative Temperature [deg C] +! p : sea pressure [dbar] +! +! gsw_pt_from_ct : potential temperature with [deg C] +! reference pressure of 0 dbar +!-------------------------------------------------------------------------- + +use gsw_mod_toolbox, only : gsw_ct_from_pt, gsw_gibbs_pt0_pt0 + +use gsw_mod_teos10_constants, only : gsw_cp0, gsw_ups, gsw_t0 + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, ct + +real (r8) :: gsw_pt_from_ct + +real (r8) :: a5ct, b3ct, ct_factor, pt_num, pt_recden, ct_diff +real (r8) :: ct0, pt, pt_old, ptm, dct, dpt_dct, s1 + +real (r8), parameter :: a0 = -1.446013646344788e-2_r8 +real (r8), parameter :: a1 = -3.305308995852924e-3_r8 +real (r8), parameter :: a2 = 1.062415929128982e-4_r8 +real (r8), parameter :: a3 = 9.477566673794488e-1_r8 +real (r8), parameter :: a4 = 2.166591947736613e-3_r8 +real (r8), parameter :: a5 = 3.828842955039902e-3_r8 + +real (r8), parameter :: b0 = 1.0_r8 +real (r8), parameter :: b1 = 6.506097115635800e-4_r8 +real (r8), parameter :: b2 = 3.830289486850898e-3_r8 +real (r8), parameter :: b3 = 1.247811760368034e-6_r8 + +s1 = sa/gsw_ups + +a5ct = a5*ct +b3ct = b3*ct + +ct_factor = (a3 + a4*s1 + a5ct) +pt_num = a0 + s1*(a1 + a2*s1) + ct*ct_factor +pt_recden = 1.0_r8/(b0 + b1*s1 + ct*(b2 + b3ct)) +pt = pt_num*pt_recden + +dpt_dct = (ct_factor + a5ct - (b2 + b3ct + b3ct)*pt)*pt_recden + +! Start the 1.5 iterations through the modified Newton-Rapshon iterative, +! method, which is also known as the Newton-McDougall method. + +ct_diff = gsw_ct_from_pt(sa,pt) - ct +pt_old = pt +pt = pt_old - ct_diff*dpt_dct +ptm = 0.5_r8*(pt + pt_old) + +dpt_dct = -gsw_cp0/((ptm + gsw_t0)*gsw_gibbs_pt0_pt0(sa,ptm)) + +pt = pt_old - ct_diff*dpt_dct +ct_diff = gsw_ct_from_pt(sa,pt) - ct +pt_old = pt +gsw_pt_from_ct = pt_old - ct_diff*dpt_dct + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_pt_from_t.f90 b/equation_of_state/TEOS10/gsw_pt_from_t.f90 new file mode 100644 index 0000000000..46dc766fb6 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_pt_from_t.f90 @@ -0,0 +1,61 @@ +!========================================================================== +elemental function gsw_pt_from_t (sa, t, p, p_ref) +!========================================================================== +! +! Calculates potential temperature of seawater from in-situ temperature +! +! sa : Absolute Salinity [g/kg] +! t : in-situ temperature [deg C] +! p : sea pressure [dbar] +! p_ref : reference sea pressure [dbar] +! +! gsw_pt_from_t : potential temperature [deg C] +!-------------------------------------------------------------------------- + +use gsw_mod_toolbox, only : gsw_entropy_part, gsw_gibbs + +use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sso, gsw_t0, gsw_ups + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, t, p, p_ref + +real (r8) :: gsw_pt_from_t + +integer n, no_iter +real (r8) :: s1, pt, pt_old, de_dt, dentropy, dentropy_dt +real (r8) :: true_entropy_part, ptm + +integer, parameter :: n0=0, n2=2 + +s1 = sa/gsw_ups + +pt = t + (p-p_ref)*( 8.65483913395442e-6_r8 - & + s1 * 1.41636299744881e-6_r8 - & + (p+p_ref)* 7.38286467135737e-9_r8 + & + t *(-8.38241357039698e-6_r8 + & + s1 * 2.83933368585534e-8_r8 + & + t * 1.77803965218656e-8_r8 + & + (p+p_ref)* 1.71155619208233e-10_r8)) + +dentropy_dt = gsw_cp0/((gsw_t0 + pt)*(1.0_r8 - 0.05_r8*(1.0_r8 - sa/gsw_sso))) + +true_entropy_part = gsw_entropy_part(sa,t,p) + +do no_iter = 1, 2 + pt_old = pt + dentropy = gsw_entropy_part(sa,pt_old,p_ref) - true_entropy_part + pt = pt_old - dentropy/dentropy_dt + ptm = 0.5_r8*(pt + pt_old) + dentropy_dt = -gsw_gibbs(n0,n2,n0,sa,ptm,p_ref) + pt = pt_old - dentropy/dentropy_dt +end do + +gsw_pt_from_t = pt + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_rho.f90 b/equation_of_state/TEOS10/gsw_rho.f90 new file mode 100644 index 0000000000..3daa65746e --- /dev/null +++ b/equation_of_state/TEOS10/gsw_rho.f90 @@ -0,0 +1,36 @@ +!========================================================================== +elemental function gsw_rho (sa, ct, p) +!========================================================================== +! +! Calculates in-situ density from Absolute Salinity and Conservative +! Temperature, using the computationally-efficient expression for +! specific volume in terms of SA, CT and p (Roquet et al., 2014). +! +! Note that potential density with respect to reference pressure, pr, is +! obtained by calling this function with the pressure argument being pr +! (i.e. "gsw_rho(SA,CT,pr)"). +! +! SA = Absolute Salinity [ g/kg ] +! CT = Conservative Temperature (ITS-90) [ deg C ] +! p = sea pressure [ dbar ] +! ( i.e. absolute pressure - 10.1325 dbar ) +! +! rho = in-situ density [ kg/m ] +!-------------------------------------------------------------------------- + +use gsw_mod_toolbox, only : gsw_specvol + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, ct, p + +real (r8) :: gsw_rho + +gsw_rho = 1.0_r8/gsw_specvol(sa,ct,p) + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 b/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 new file mode 100644 index 0000000000..b4ee696a1d --- /dev/null +++ b/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 @@ -0,0 +1,110 @@ +!========================================================================== +elemental subroutine gsw_rho_first_derivatives (sa, ct, p, drho_dsa, & + drho_dct, drho_dp) +!========================================================================== +! +! Calculates the three (3) partial derivatives of in-situ density with +! respect to Absolute Salinity, Conservative Temperature and pressure. +! Note that the pressure derivative is done with respect to pressure in +! Pa, not dbar. This function uses the computationally-efficient expression +! for specific volume in terms of SA, CT and p (Roquet et al., 2014). +! +! SA = Absolute Salinity [ g/kg ] +! CT = Conservative Temperature (ITS-90) [ deg C ] +! p = sea pressure [ dbar ] +! ( i.e. absolute pressure - 10.1325 dbar ) +! +! drho_dSA = partial derivatives of density [ kg^2/(g m^3) ] +! with respect to Absolute Salinity +! drho_dCT = partial derivatives of density [ kg/(K m^3) ] +! with respect to Conservative Temperature +! drho_dP = partial derivatives of density [ kg/(Pa m^3) ] +! with respect to pressure in Pa +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : pa2db, gsw_sfac, offset + +use gsw_mod_specvol_coefficients + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, ct, p +real (r8), intent(out), optional :: drho_dsa, drho_dct, drho_dp + +real (r8) :: rho2, v_ct, v_p, v_sa, xs, ys, z, v + +xs = sqrt(gsw_sfac*sa + offset) +ys = ct*0.025_r8 +z = p*1e-4_r8 + +v = v000 + xs*(v010 + xs*(v020 + xs*(v030 + xs*(v040 + xs*(v050 & + + v060*xs))))) + ys*(v100 + xs*(v110 + xs*(v120 + xs*(v130 + xs*(v140 & + + v150*xs)))) + ys*(v200 + xs*(v210 + xs*(v220 + xs*(v230 + v240*xs))) & + + ys*(v300 + xs*(v310 + xs*(v320 + v330*xs)) + ys*(v400 + xs*(v410 & + + v420*xs) + ys*(v500 + v510*xs + v600*ys))))) + z*(v001 + xs*(v011 & + + xs*(v021 + xs*(v031 + xs*(v041 + v051*xs)))) + ys*(v101 + xs*(v111 & + + xs*(v121 + xs*(v131 + v141*xs))) + ys*(v201 + xs*(v211 + xs*(v221 & + + v231*xs)) + ys*(v301 + xs*(v311 + v321*xs) + ys*(v401 + v411*xs & + + v501*ys)))) + z*(v002 + xs*(v012 + xs*(v022 + xs*(v032 + v042*xs))) & + + ys*(v102 + xs*(v112 + xs*(v122 + v132*xs)) + ys*(v202 + xs*(v212 & + + v222*xs) + ys*(v302 + v312*xs + v402*ys))) + z*(v003 + xs*(v013 & + + v023*xs) + ys*(v103 + v113*xs + v203*ys) + z*(v004 + v014*xs + v104*ys & + + z*(v005 + v006*z))))) + +rho2 = (1.0_r8/v)**2 + +if (present(drho_dsa)) then + + v_sa = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) & + + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & + + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 & + + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) & + + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) & + + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 & + + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) & + + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 & + + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) & + + z*(b003 + b103*xs + b013*ys + b004*z))) + + drho_dsa = -rho2*0.5_r8*gsw_sfac*v_sa/xs + +end if + +if (present(drho_dct)) then + + v_ct = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) & + + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & + + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 & + + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) & + + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) & + + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 & + + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) & + + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 & + + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) & + + z*(a003 + a103*xs + a013*ys + a004*z))) + + drho_dct = -rho2*0.025_r8*v_ct + +end if + +if (present(drho_dp)) then + + v_p = c000 + xs*(c100 + xs*(c200 + xs*(c300 + xs*(c400 + c500*xs)))) & + + ys*(c010 + xs*(c110 + xs*(c210 + xs*(c310 + c410*xs))) + ys*(c020 & + + xs*(c120 + xs*(c220 + c320*xs)) + ys*(c030 + xs*(c130 + c230*xs) & + + ys*(c040 + c140*xs + c050*ys)))) + z*(c001 + xs*(c101 + xs*(c201 & + + xs*(c301 + c401*xs))) + ys*(c011 + xs*(c111 + xs*(c211 + c311*xs)) & + + ys*(c021 + xs*(c121 + c221*xs) + ys*(c031 + c131*xs + c041*ys))) & + + z*(c002 + xs*(c102 + c202*xs) + ys*(c012 + c112*xs + c022*ys) & + + z*(c003 + c103*xs + c013*ys + z*(c004 + c005*z)))) + + drho_dp = -rho2*1e-4_r8*pa2db*v_p + +end if + +return +end subroutine + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 b/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 new file mode 100644 index 0000000000..fdf75e7a0a --- /dev/null +++ b/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 @@ -0,0 +1,78 @@ +!========================================================================== +elemental subroutine gsw_rho_second_derivatives (sa, ct, p, rho_sa_sa, & + rho_sa_ct, rho_ct_ct, rho_sa_p, rho_ct_p) +!========================================================================== +! +! Calculates five second-order derivatives of rho. Note that this function +! uses the using the computationally-efficient expression for specific +! volume (Roquet et al., 2014). +! +! SA = Absolute Salinity [ g/kg ] +! CT = Conservative Temperature (ITS-90) [ deg C ] +! p = sea pressure [ dbar ] +! ( i.e. absolute pressure - 10.1325 dbar ) +! +! rho_SA_SA = The second-order derivative of rho with respect to +! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] +! rho_SA_CT = The second-order derivative of rho with respect to +! SA and CT at constant p. [ J/(kg K(g/kg)) ] +! rho_CT_CT = The second-order derivative of rho with respect to CT at +! constant SA & p +! rho_SA_P = The second-order derivative with respect to SA & P at +! constant CT. +! rho_CT_P = The second-order derivative with respect to CT & P at +! constant SA. +!-------------------------------------------------------------------------- + +use gsw_mod_toolbox, only : gsw_specvol, gsw_specvol_first_derivatives +use gsw_mod_toolbox, only : gsw_specvol_second_derivatives + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, ct, p +real (r8), intent(out), optional :: rho_sa_sa, rho_sa_ct, rho_ct_ct +real (r8), intent(out), optional :: rho_sa_p, rho_ct_p + +integer :: iflag1, iflag2 +real (r8) :: rec_v, rec_v2, rec_v3, v_ct, v_ct_ct, v_ct_p, v_p, v_sa, v_sa_ct +real (r8) :: v_sa_p, v_sa_sa + +iflag1 = 0 +if (present(rho_sa_sa) .or. present(rho_sa_ct) & + .or. present(rho_sa_p)) iflag1 = ibset(iflag1,1) +if (present(rho_sa_ct) .or. present(rho_ct_ct) & + .or. present(rho_ct_p)) iflag1 = ibset(iflag1,2) +if (present(rho_sa_p) .or. present(rho_ct_p)) iflag1 = ibset(iflag1,3) + +call gsw_specvol_first_derivatives(sa,ct,p,v_sa,v_ct,v_p,iflag=iflag1) + +iflag2 = 0 +if (present(rho_sa_sa)) iflag2 = ibset(iflag2,1) +if (present(rho_sa_ct)) iflag2 = ibset(iflag2,2) +if (present(rho_ct_ct)) iflag2 = ibset(iflag2,3) +if (present(rho_sa_p)) iflag2 = ibset(iflag2,4) +if (present(rho_ct_p)) iflag2 = ibset(iflag2,5) + +call gsw_specvol_second_derivatives(sa,ct,p,v_sa_sa,v_sa_ct,v_ct_ct, & + v_sa_p,v_ct_p,iflag=iflag2) + +rec_v = 1.0_r8/gsw_specvol(sa,ct,p) +rec_v2 = rec_v**2 +rec_v3 = rec_v2*rec_v + +if (present(rho_sa_sa)) rho_sa_sa = -v_sa_sa*rec_v2 + 2.0_r8*v_sa*v_sa*rec_v3 + +if (present(rho_sa_ct)) rho_sa_ct = -v_sa_ct*rec_v2 + 2.0_r8*v_sa*v_ct*rec_v3 + +if (present(rho_ct_ct)) rho_ct_ct = -v_ct_ct*rec_v2 + 2.0_r8*v_ct*v_ct*rec_v3 + +if (present(rho_sa_p)) rho_sa_p = -v_sa_p*rec_v2 + 2.0_r8*v_sa*v_p*rec_v3 + +if (present(rho_ct_p)) rho_ct_p = -v_ct_p*rec_v2 + 2.0_r8*v_ct*v_p*rec_v3 + +return +end subroutine + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_sp_from_sr.f90 b/equation_of_state/TEOS10/gsw_sp_from_sr.f90 new file mode 100644 index 0000000000..c01377546c --- /dev/null +++ b/equation_of_state/TEOS10/gsw_sp_from_sr.f90 @@ -0,0 +1,30 @@ +!========================================================================== +elemental function gsw_sp_from_sr (sr) +!========================================================================== +! +! Calculates Practical Salinity, sp, from Reference Salinity, sr. +! +! sr : Reference Salinity [g/kg] +! +! gsw_sp_from_sr : Practical Salinity [unitless] +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_ups + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sr + +real (r8) :: gsw_sp_from_sr + +gsw_sp_from_sr = sr/gsw_ups + +return +end function + +!-------------------------------------------------------------------------- + + + diff --git a/equation_of_state/TEOS10/gsw_specvol.f90 b/equation_of_state/TEOS10/gsw_specvol.f90 new file mode 100644 index 0000000000..00cfaab125 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_specvol.f90 @@ -0,0 +1,52 @@ +!========================================================================== +elemental function gsw_specvol (sa, ct, p) +!========================================================================== +! +! Calculates specific volume from Absolute Salinity, Conservative +! Temperature and pressure, using the computationally-efficient +! polynomial expression for specific volume (Roquet et al., 2014). +! +! SA = Absolute Salinity [ g/kg ] +! CT = Conservative Temperature (ITS-90) [ deg C ] +! p = sea pressure [ dbar ] +! ( i.e. absolute pressure - 10.1325 dbar ) +! +! specvol = specific volume [ m^3/kg ] +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_sfac, offset + +use gsw_mod_specvol_coefficients + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, ct, p + +real (r8) :: gsw_specvol + +real (r8) :: xs, ys, z + +xs = sqrt(gsw_sfac*sa + offset) +ys = ct*0.025_r8 +z = p*1e-4_r8 + +gsw_specvol = v000 + xs*(v010 + xs*(v020 + xs*(v030 + xs*(v040 + xs*(v050 & + + v060*xs))))) + ys*(v100 + xs*(v110 + xs*(v120 + xs*(v130 + xs*(v140 & + + v150*xs)))) + ys*(v200 + xs*(v210 + xs*(v220 + xs*(v230 + v240*xs))) & + + ys*(v300 + xs*(v310 + xs*(v320 + v330*xs)) + ys*(v400 + xs*(v410 & + + v420*xs) + ys*(v500 + v510*xs + v600*ys))))) + z*(v001 + xs*(v011 & + + xs*(v021 + xs*(v031 + xs*(v041 + v051*xs)))) + ys*(v101 + xs*(v111 & + + xs*(v121 + xs*(v131 + v141*xs))) + ys*(v201 + xs*(v211 + xs*(v221 & + + v231*xs)) + ys*(v301 + xs*(v311 + v321*xs) + ys*(v401 + v411*xs & + + v501*ys)))) + z*(v002 + xs*(v012 + xs*(v022 + xs*(v032 + v042*xs))) & + + ys*(v102 + xs*(v112 + xs*(v122 + v132*xs)) + ys*(v202 + xs*(v212 & + + v222*xs) + ys*(v302 + v312*xs + v402*ys))) + z*(v003 + xs*(v013 & + + v023*xs) + ys*(v103 + v113*xs + v203*ys) + z*(v004 + v014*xs + v104*ys & + + z*(v005 + v006*z))))) + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 b/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 new file mode 100644 index 0000000000..2f2a006b17 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 @@ -0,0 +1,104 @@ +!========================================================================== +elemental subroutine gsw_specvol_first_derivatives (sa, ct, p, v_sa, v_ct, & + v_p, iflag) +! ========================================================================= +! +! Calculates three first-order derivatives of specific volume (v). +! Note that this function uses the computationally-efficient +! expression for specific volume (Roquet et al., 2014). +! +! SA = Absolute Salinity [ g/kg ] +! CT = Conservative Temperature (ITS-90) [ deg C ] +! p = sea pressure [ dbar ] +! ( i.e. absolute pressure - 10.1325 dbar ) +! +! v_SA = The first derivative of specific volume with respect to +! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] +! v_CT = The first derivative of specific volume with respect to +! CT at constant SA and p. [ J/(kg K(g/kg)) ] +! v_P = The first derivative of specific volume with respect to +! P at constant SA and CT. [ J/(kg K^2) ] +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_sfac, offset + +use gsw_mod_specvol_coefficients + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, ct, p +integer, intent(in), optional :: iflag +real (r8), intent(out), optional :: v_sa, v_ct, v_p + +integer :: i +logical :: flags(3) +real (r8) :: v_ct_part, v_p_part, v_sa_part, xs, ys, z + +xs = sqrt(gsw_sfac*sa + offset) +ys = ct*0.025_r8 +z = p*1e-4_r8 + +if (present(iflag)) then + do i = 1, 3 + flags(i) = btest(iflag,i) + end do +else + flags = .true. +end if + +if (present(v_sa) .and. flags(1)) then + + v_sa_part = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) & + + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & + + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 & + + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) & + + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) & + + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 & + + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) & + + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 & + + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) & + + z*(b003 + b103*xs + b013*ys + b004*z))) + + v_sa = 0.5_r8*gsw_sfac*v_sa_part/xs + +end if + + +if (present(v_ct) .and. flags(2)) then + + v_ct_part = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) & + + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & + + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 & + + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) & + + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) & + + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 & + + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) & + + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 & + + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) & + + z*(a003 + a103*xs + a013*ys + a004*z))) + + v_ct = 0.025_r8*v_ct_part + +end if + +if (present(v_p) .and. flags(3)) then + + v_p_part = c000 + xs*(c100 + xs*(c200 + xs*(c300 + xs*(c400 + c500*xs)))) & + + ys*(c010 + xs*(c110 + xs*(c210 + xs*(c310 + c410*xs))) + ys*(c020 & + + xs*(c120 + xs*(c220 + c320*xs)) + ys*(c030 + xs*(c130 + c230*xs) & + + ys*(c040 + c140*xs + c050*ys)))) + z*(c001 + xs*(c101 + xs*(c201 & + + xs*(c301 + c401*xs))) + ys*(c011 + xs*(c111 + xs*(c211 + c311*xs)) & + + ys*(c021 + xs*(c121 + c221*xs) + ys*(c031 + c131*xs + c041*ys))) & + + z*( c002 + xs*(c102 + c202*xs) + ys*(c012 + c112*xs + c022*ys) & + + z*(c003 + c103*xs + c013*ys + z*(c004 + c005*z)))) + + v_p = 1e-8_r8*v_p_part + +end if + +return +end subroutine + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 b/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 new file mode 100644 index 0000000000..39096109e9 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 @@ -0,0 +1,131 @@ +!========================================================================== +elemental subroutine gsw_specvol_second_derivatives (sa, ct, p, v_sa_sa, & + v_sa_ct, v_ct_ct, v_sa_p, v_ct_p, iflag) +! ========================================================================= +! +! Calculates five second-order derivatives of specific volume (v). +! Note that this function uses the computationally-efficient +! expression for specific volume (Roquet et al., 2014). +! +! SA = Absolute Salinity [ g/kg ] +! CT = Conservative Temperature (ITS-90) [ deg C ] +! p = sea pressure [ dbar ] +! ( i.e. absolute pressure - 10.1325 dbar ) +! +! v_SA_SA = The second derivative of specific volume with respect to +! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] +! v_SA_CT = The second derivative of specific volume with respect to +! SA and CT at constant p. [ J/(kg K(g/kg)) ] +! v_CT_CT = The second derivative of specific volume with respect to +! CT at constant SA and p. [ J/(kg K^2) ] +! v_SA_P = The second derivative of specific volume with respect to +! SA and P at constant CT. [ J/(kg K(g/kg)) ] +! v_CT_P = The second derivative of specific volume with respect to +! CT and P at constant SA. [ J/(kg K(g/kg)) ] +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_sfac, offset + +use gsw_mod_specvol_coefficients + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, ct, p +integer, intent(in), optional :: iflag +real (r8), intent(out), optional :: v_sa_sa, v_sa_ct, v_ct_ct, v_sa_p, v_ct_p + +integer :: i +logical :: flags(5) +real (r8) :: v_ct_ct_part, v_ct_p_part, v_sa_ct_part, v_sa_p_part +real (r8) :: v_sa_sa_part, xs, xs2, ys, z + +xs2 = gsw_sfac*sa + offset +xs = sqrt(xs2) +ys = ct*0.025_r8 +z = p*1e-4_r8 + +if (present(iflag)) then + do i = 1, 5 + flags(i) = btest(iflag,i) + end do +else + flags = .true. +end if + +if (present(v_sa_sa) .and. flags(1)) then + + v_sa_sa_part = (-b000 + xs2*(b200 + xs*(2.0_r8*b300 + xs*(3.0_r8*b400 & + + 4.0_r8*b500*xs))) + ys*(-b010 + xs2*(b210 + xs*(2.0_r8*b310 & + + 3.0_r8*b410*xs)) + ys*(-b020 + xs2*(b220 + 2.0_r8*b320*xs) & + + ys*(-b030 + b230*xs2 + ys*(-b040 - b050*ys)))) + z*(-b001 & + + xs2*(b201 + xs*(2.0_r8*b301 + 3.0_r8*b401*xs)) + ys*(-b011 & + + xs2*(b211 + 2.0_r8*b311*xs) + ys*(-b021 + b221*xs2 & + + ys*(-b031 - b041*ys))) + z*(-b002 + xs2*(b202 + 2.0_r8*b302*xs) & + + ys*(-b012 + b212*xs2 + ys*(-b022 - b032*ys)) + z*(-b003 & + - b013*ys - b004*z))))/xs2 + + v_sa_sa = 0.25_r8*gsw_sfac*gsw_sfac*v_sa_sa_part/xs + +end if + +if (present(v_sa_ct) .and. flags(2)) then + + v_sa_ct_part = (b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & + + ys*(2.0_r8*(b020 + xs*(b120 + xs*(b220 + b320*xs))) & + + ys*(3.0_r8*(b030 + xs*(b130 + b230*xs)) + ys*(4.0_r8*(b040 + b140*xs) & + + 5.0_r8*b050*ys))) + z*(b011 + xs*(b111 + xs*(b211 + b311*xs)) & + + ys*(2.0_r8*(b021 + xs*(b121 + b221*xs)) + ys*(3.0_r8*(b031 + b131*xs) & + + 4.0_r8*b041*ys)) + z*(b012 + xs*(b112 + b212*xs) + ys*(2.0_r8*(b022 & + + b122*xs) + 3.0_r8*b032*ys) + b013*z)))/xs + + v_sa_ct = 0.025_r8*0.5_r8*gsw_sfac*v_sa_ct_part + +end if + +if (present(v_ct_ct) .and. flags(3)) then + + v_ct_ct_part = a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & + + ys*(2.0_r8*(a020 + xs*(a120 + xs*(a220 + a320*xs))) & + + ys*(3.0_r8*(a030 + xs*(a130 + a230*xs)) + ys*(4.0_r8*(a040 & + + a140*xs) + 5.0_r8*a050*ys))) + z*( a011 + xs*(a111 + xs*(a211 & + + a311*xs)) + ys*(2.0_r8*(a021 + xs*(a121 + a221*xs)) & + + ys*(3.0_r8*(a031 + a131*xs) + 4.0_r8*a041*ys)) + z*(a012 & + + xs*(a112 + a212*xs) + ys*(2.0_r8*(a022 + a122*xs) & + + 3.0_r8*a032*ys) + a013*z)) + + v_ct_ct = 0.025_r8*0.025_r8*v_ct_ct_part + +end if + +if (present(v_sa_p) .and. flags(4)) then + + v_sa_p_part = b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) + ys*(b011 & + + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 + xs*(b121 + b221*xs) & + + ys*(b031 + b131*xs + b041*ys))) + z*(2.0_r8*(b002 + xs*(b102 & + + xs*(b202 + b302*xs)) + ys*(b012 + xs*(b112 + b212*xs) + ys*(b022 & + + b122*xs + b032*ys))) + z*(3.0_r8*(b003 + b103*xs + b013*ys) & + + 4.0_r8*b004*z)) + + v_sa_p = 1e-8_r8*0.5_r8*gsw_sfac*v_sa_p_part + +end if + +if (present(v_ct_p) .and. flags(5)) then + + v_ct_p_part = a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) + ys*(a011 & + + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 + xs*(a121 + a221*xs) & + + ys*(a031 + a131*xs + a041*ys))) + z*(2.0_r8*(a002 + xs*(a102 & + + xs*(a202 + a302*xs)) + ys*(a012 + xs*(a112 + a212*xs) + ys*(a022 & + + a122*xs + a032*ys))) + z*(3.0_r8*(a003 + a103*xs + a013*ys) & + + 4.0_r8*a004*z)) + + v_ct_p = 1e-8_r8*0.025_r8*v_ct_p_part + +end if + +return +end subroutine + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_sr_from_sp.f90 b/equation_of_state/TEOS10/gsw_sr_from_sp.f90 new file mode 100644 index 0000000000..cbcc4fea0b --- /dev/null +++ b/equation_of_state/TEOS10/gsw_sr_from_sp.f90 @@ -0,0 +1,30 @@ +!========================================================================== +elemental function gsw_sr_from_sp (sp) +!========================================================================== +! +! Calculates Reference Salinity, SR, from Practical Salinity, SP. +! +! sp : Practical Salinity [unitless] +! +! gsw_sr_from_sp : Reference Salinity [g/kg] +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_ups + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sp + +real (r8) :: gsw_sr_from_sp + +gsw_sr_from_sp = sp*gsw_ups + +return +end function + +!-------------------------------------------------------------------------- + + + diff --git a/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 b/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 new file mode 100644 index 0000000000..668184491f --- /dev/null +++ b/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 @@ -0,0 +1,88 @@ +!========================================================================== +elemental function gsw_t_deriv_chem_potential_water_t_exact (sa, t, p) +!========================================================================== +! +! Calculates the temperature derivative of the chemical potential of water +! in seawater so that it is valid at exactly SA = 0. +! +! SA = Absolute Salinity [ g/kg ] +! t = in-situ temperature (ITS-90) [ deg C ] +! p = sea pressure [ dbar ] +! ( i.e. absolute pressure - 10.1325 dbar ) +! +! chem_potential_water_dt = temperature derivative of the chemical +! potential of water in seawater [ J g^-1 K^-1 ] +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_sfac, rec_db2pa + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, t, p + +real (r8) :: gsw_t_deriv_chem_potential_water_t_exact + +real (r8) :: g03_t, g08_sa_t, x, x2, y, z, g08_t + +real (r8), parameter :: kg2g = 1e-3_r8 + +! Note. The kg2g, a factor of 1e-3, is needed to convert the output of this +! function into units of J/g. See section (2.9) of the TEOS-10 Manual. + +x2 = gsw_sfac*sa +x = sqrt(x2) +y = t*0.025_r8 +z = p*rec_db2pa ! the input pressure (p) is sea pressure in units of dbar. + +g03_t = 5.90578347909402_r8 + z*(-270.983805184062_r8 + & + z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - & + 2.13290083518327_r8*z)*z))) + & + y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & + z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + & + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & + y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & + z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + & + (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & + y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & + z*(-1207.261522487504_r8 + (608.785486935364_r8 - & + 105.4993508931208_r8*z)*z)) + & + y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & + z*(602.603274510125_r8 + z*(-276.361526170076_r8 + & + 32.40953340386105_r8*z))) + & + y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - & + 67.41756835751434_r8*z) + & + z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + & + 49.023632509086724_r8*z))))))) + +g08_t = x2*(168.072408311545_r8 + & + x*(-493.407510141682_r8 + x*(543.835333000098_r8 + & + x*(-196.028306689776_r8 + 36.7571622995805_r8*x) + & + y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + & + y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & + 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + & + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & + y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + & + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & + y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + & + y*(3.50240264723578_r8 + 938.26075044542_r8*z))))) + +g08_sa_t = 1187.3715515697959_r8 + & + x*(-1480.222530425046_r8 + x*(2175.341332000392_r8 + & + x*(-980.14153344888_r8 + 220.542973797483_r8*x) + & + y*(-548.4580073635929_r8 + y*(592.4012338275047_r8 + & + y*(-274.2361238716608_r8 + 49.9394019139016_r8*y))) - & + 90.6734234051316_r8*z) + z*(-525.876123559641_r8 + & + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & + y*(-258.3988055868252_r8 + z*(2298.348396014856_r8 + & + z*(-325.1503575102672_r8 + 153.8390924339484_r8*z)) + & + y*(-90.2046337756875_r8 - 4142.8793862113125_r8*z + & + y*(10.50720794170734_r8 + 2814.78225133626_r8*z)))) + +gsw_t_deriv_chem_potential_water_t_exact = kg2g*((g03_t + g08_t)*0.025_r8 - & + 0.5_r8*gsw_sfac*0.025_r8*sa*g08_sa_t) +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 b/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 new file mode 100644 index 0000000000..63c27db986 --- /dev/null +++ b/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 @@ -0,0 +1,71 @@ +!========================================================================== +elemental function gsw_t_freezing_exact (sa, p, saturation_fraction) +!========================================================================== +! +! Calculates the in-situ temperature at which seawater freezes. The +! in-situ temperature freezing point is calculated from the exact +! in-situ freezing temperature which is found by a modified Newton-Raphson +! iteration (McDougall and Wotherspoon, 2013) of the equality of the +! chemical potentials of water in seawater and in ice. +! +! An alternative GSW function, gsw_t_freezing_poly, it is based on a +! computationally-efficient polynomial, and is accurate to within -5e-4 K +! and 6e-4 K, when compared with this function. +! +! SA = Absolute Salinity [ g/kg ] +! p = sea pressure [ dbar ] +! ( i.e. absolute pressure - 10.1325 dbar ) +! saturation_fraction = the saturation fraction of dissolved air in +! seawater +! (i.e., saturation_fraction must be between 0 and 1, and the default +! is 1, completely saturated) +! +! t_freezing = in-situ temperature at which seawater freezes. [ deg C ] +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_sso + +use gsw_mod_toolbox, only : gsw_gibbs_ice, gsw_chem_potential_water_t_exact +use gsw_mod_toolbox, only : gsw_t_deriv_chem_potential_water_t_exact +use gsw_mod_toolbox, only : gsw_t_freezing_poly + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, p, saturation_fraction + +real (r8) :: gsw_t_freezing_exact + +real (r8) :: df_dt, p_r, sa_r, tf, tfm, tf_old, x, f + +! The initial value of t_freezing_exact (for air-free seawater) +tf = gsw_t_freezing_poly(sa,p,polynomial=.true.) + +df_dt = 1e3_r8*gsw_t_deriv_chem_potential_water_t_exact(sa,tf,p) - & + gsw_gibbs_ice(1,0,tf,p) +! df_dt here is the initial value of the derivative of the function f whose +! zero (f = 0) we are finding (see Eqn. (3.33.2) of IOC et al (2010)). + +tf_old = tf +f = 1e3_r8*gsw_chem_potential_water_t_exact(sa,tf_old,p) - & + gsw_gibbs_ice(0,0,tf_old,p) +tf = tf_old - f/df_dt +tfm = 0.5_r8*(tf + tf_old) +df_dt = 1e3_r8*gsw_t_deriv_chem_potential_water_t_exact(sa,tfm,p) - & + gsw_gibbs_ice(1,0,tfm,p) +tf = tf_old - f/df_dt + +tf_old = tf +f = 1e3_r8*gsw_chem_potential_water_t_exact(sa,tf_old,p) - & + gsw_gibbs_ice(0,0,tf_old,p) +tf = tf_old - f/df_dt + +! Adjust for the effects of dissolved air +gsw_t_freezing_exact = tf - & + saturation_fraction*(1e-3_r8)*(2.4_r8 - sa/(2.0_r8*gsw_sso)) + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 b/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 new file mode 100644 index 0000000000..479a323d2c --- /dev/null +++ b/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 @@ -0,0 +1,78 @@ +!========================================================================== +elemental function gsw_t_freezing_poly (sa, p, saturation_fraction, polynomial) +!========================================================================== +! +! Calculates the in-situ temperature at which seawater freezes from a +! computationally efficient polynomial. +! +! SA = Absolute Salinity [ g/kg ] +! p = sea pressure [ dbar ] +! ( i.e. absolute pressure - 10.1325 dbar ) +! saturation_fraction = the saturation fraction of dissolved air in +! seawater +! +! t_freezing = in-situ temperature at which seawater freezes. [ deg C ] +! (ITS-90) +!-------------------------------------------------------------------------- + +use gsw_mod_teos10_constants, only : gsw_sso + +use gsw_mod_freezing_poly_coefficients + +use gsw_mod_toolbox, only : gsw_ct_freezing_poly, gsw_t_from_ct + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, p +real (r8), intent(in), optional :: saturation_fraction +logical, intent(in), optional :: polynomial + +real (r8) :: gsw_t_freezing_poly + +real (r8) :: p_r, sa_r, x, ctf, sfrac +logical :: direct_poly + +if (present(polynomial)) then + direct_poly = polynomial +else + direct_poly = .false. +end if + +if (.not. direct_poly) then + + if (present(saturation_fraction)) then + sfrac = saturation_fraction + else + sfrac = 1.0_r8 + end if + + ctf = gsw_ct_freezing_poly(sa,p,sfrac) + gsw_t_freezing_poly = gsw_t_from_ct(sa,ctf,p) + +else + + ! Alternative calculation ... + sa_r = sa*1e-2_r8 + x = sqrt(sa_r) + p_r = p*1e-4_r8 + + gsw_t_freezing_poly = t0 & + + sa_r*(t1 + x*(t2 + x*(t3 + x*(t4 + x*(t5 + t6*x))))) & + + p_r*(t7 + p_r*(t8 + t9*p_r)) & + + sa_r*p_r*(t10 + p_r*(t12 + p_r*(t15 + t21*sa_r)) & + + sa_r*(t13 + t17*p_r + t19*sa_r) & + + x*(t11 + p_r*(t14 + t18*p_r) + sa_r*(t16 + t20*p_r + t22*sa_r))) + + if (.not. present(saturation_fraction)) return + + ! Adjust for the effects of dissolved air + gsw_t_freezing_poly = gsw_t_freezing_poly - & + saturation_fraction*(1e-3_r8)*(2.4_r8 - sa/(2.0_r8*gsw_sso)) +end if + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/TEOS10/gsw_t_from_ct.f90 b/equation_of_state/TEOS10/gsw_t_from_ct.f90 new file mode 100644 index 0000000000..9f85a4530c --- /dev/null +++ b/equation_of_state/TEOS10/gsw_t_from_ct.f90 @@ -0,0 +1,33 @@ +!========================================================================== +elemental function gsw_t_from_ct (sa, ct, p) +!========================================================================== +! +! Calculates in-situ temperature from Conservative Temperature of seawater +! +! sa : Absolute Salinity [g/kg] +! ct : Conservative Temperature [deg C] +! +! gsw_t_from_ct : in-situ temperature [deg C] +!-------------------------------------------------------------------------- + +use gsw_mod_toolbox, only : gsw_pt_from_ct, gsw_pt_from_t + +use gsw_mod_kinds + +implicit none + +real (r8), intent(in) :: sa, ct, p + +real (r8) :: gsw_t_from_ct + +real (r8) :: pt0 + +real (r8), parameter :: p0 = 0.0_r8 + +pt0 = gsw_pt_from_ct(sa,ct) +gsw_t_from_ct = gsw_pt_from_t(sa,pt0,p0,p) + +return +end function + +!-------------------------------------------------------------------------- diff --git a/equation_of_state/_Equation_of_State.dox b/equation_of_state/_Equation_of_State.dox new file mode 100644 index 0000000000..0e80c9652a --- /dev/null +++ b/equation_of_state/_Equation_of_State.dox @@ -0,0 +1,108 @@ +/*! \page Equation_of_State Equation of State + +Within MOM6, there is a wrapper for the equation of state, so that all calls look +the same from the rest of the model. The equation of state code has to calculate +not just in situ or potential density, but also the compressibility and various +derivatives of the density. There is also code for computing specific volume and the +freezing temperature, and for converting between potential and conservative +temperatures and between practical and reference (or absolute) salinity. + +\section Linear_EOS Linear Equation of State + +Compute the required quantities with uniform values for \f$\alpha = \frac{\partial +\rho}{\partial T}\f$ and \f$\beta = \frac{\partial \rho}{\partial S}\f$, (DRHO_DT, +DRHO_DS in MOM_input, also uses RHO_T0_S0). + +\section Wright_EOS Wright reduced range Equation of State + +Compute the required quantities using the equation of state from \cite wright1997 +as a function of potential temperature and practical salinity, with +coefficients based on the reduced-range (salinity from 28 to 38 PSU, temperature +from -2 to 30 degC and pressure up to 5000 dbar) fit to the UNESCO 1981 data. This +equation of state is in the form: +\f[ + \alpha(s, \theta, p) = A(s, \theta) + \frac{\lambda(s, \theta)}{P(s, \theta) + p} +\f] +where \f$A, \lambda\f$ and \f$P\f$ are functions only of \f$s\f$ and \f$\theta\f$ +and \f$\alpha = 1/ \rho\f$ is the specific volume. This form is useful for the +pressure gradient computation as discussed in \ref section_PG. This EoS is selected +by setting EQN_OF_STATE = WRIGHT or WRIGHT_RED, which are mathematically equivalent, +but the latter is refactored for consistent answers between compiler settings. + +\section Wright_full_EOS Wright full range Equation of State + +Compute the required quantities using the equation of state from \cite wright1997 +as a function of potential temperature and practical salinity, with +coefficients based on a fit to the UNESCO 1981 data over the full range of +validity of that data (salinity from 0 to 40 PSU, temperatures from -2 to 40 +degC, and pressures up to 10000 dbar). The functional form of the WRIGHT_FULL +equation of state is the same as for WRIGHT or WRIGHT_RED, but with different +coefficients. + +\section Jackett06_EOS Jackett et al. (2006) Equation of State + +Compute the required quantities using the equation of state from Jackett et al. +(2006) as a function of potential temperature and practical salinity, with +coefficients based on a fit to the updated data that were later used to define +the TEOS-10 equation of state over the full range of validity of that data +(salinity from 0 to 42 PSU, temperatures from the freezing point to 40 degC, and +pressures up to 8500 dbar), but focused on the "oceanographic funnel" of +thermodynamic properties observed in the ocean. This equation of state is +commonly used in realistic Hycom simulations. + +\section UNESCO_EOS UNESCO Equation of State + +Compute the required quantities using the equation of state from \cite jackett1995, +which uses potential temperature and practical salinity as state variables and is +a fit to the 1981 UNESCO equation of state with the same functional form but a +replacement of the temperature variable (the original uses in situ temperature). + +\section ROQUET_RHO_EOS ROQUET_RHO Equation of State + +Compute the required quantities using the equation of state from \cite roquet2015, +which uses a 75-member polynomial for density as a function of conservative temperature +and absolute salinity, in a fit to the output from the full TEOS-10 equation of state. + +\section ROQUET_SPV_EOS ROQUET_SPV Equation of State + +Compute the required quantities using the specific volume oriented equation of state from +\cite roquet2015, which uses a 75-member polynomial for specific volume as a function of +conservative temperature and absolute salinity, in a fit to the output from the full +TEOS-10 equation of state. + +\section TEOS-10_EOS TEOS-10 Equation of State + +Compute the required quantities using the equation of state from +[TEOS-10](http://www.teos-10.org/), with calls directly to the subroutines +in that code package. + +\section section_TFREEZE Freezing Temperature of Sea Water + +There are four choices for computing the freezing point of sea water: + +\li Linear The freezing temperature is a linear function of the salinity and +pressure: +\f[ + T_{Fr} = (T_{Fr0} + a\,S) + b\,P +\f] +where \f$T_{Fr0},a,b\f$ are constants which can be set in MOM_input (TFREEZE_S0_P0, +DTFREEZE_DS, DTFREEZE_DP). + +\li Millero The \cite millero1978 equation is used to calculate the freezing +point from practical salinity and pressure, but modified so that returns a +potential temperature rather than an in situ temperature: +\f[ + T_{Fr} = S(a + (b \sqrt{\max(S,0.0)} + c\, S)) + d\,P +\f] +where \f$a,b, c, d\f$ are fixed constants. + +\li TEOS-10 The TEOS-10 package is used to compute the freezing conservative +temperature [degC] from absolute salinity [g/kg], and pressure [Pa]. This one or +TEOS_poly must be used if you are using the ROQUET_RHO, ROQUET_SPV or TEOS-10 +equation of state. + +\li TEOS_poly A 23-term polynomial fit refactored from the TEOS-10 package is +used to compute the freezing conservative temperature [degC] from absolute +salinity [g/kg], and pressure [Pa]. + +*/ diff --git a/framework/MOM_array_transform.F90 b/framework/MOM_array_transform.F90 new file mode 100644 index 0000000000..66c9925f11 --- /dev/null +++ b/framework/MOM_array_transform.F90 @@ -0,0 +1,357 @@ +!> Module for supporting the rotation of a field's index map. +!! The implementation of each angle is described below. +!! +!! +90deg: B(i,j) = A(n-j,i) +!! = transpose, then row reverse +!! 180deg: B(i,j) = A(m-i,n-j) +!! = row reversal + column reversal +!! -90deg: B(i,j) = A(j,m-i) +!! = row reverse, then transpose +!! +!! 90 degree rotations change the shape of the field, and are handled +!! separately from 180 degree rotations. + +module MOM_array_transform + +implicit none ; private + +public rotate_array +public rotate_array_pair +public rotate_vector +public allocate_rotated_array + + +!> Rotate the elements of an array to the rotated set of indices. +!! Rotation is applied across the first and second axes of the array. +interface rotate_array + module procedure rotate_array_real_2d + module procedure rotate_array_real_3d + module procedure rotate_array_real_4d + module procedure rotate_array_integer + module procedure rotate_array_logical +end interface rotate_array + + +!> Rotate a pair of arrays which map to a rotated set of indices. +!! Rotation is applied across the first and second axes of the array. +!! This rotation should be applied when one field is mapped onto the other. +!! For example, a tracer indexed along u or v face points will map from one +!! to the other after a quarter turn, and back onto itself after a half turn. +interface rotate_array_pair + module procedure rotate_array_pair_real_2d + module procedure rotate_array_pair_real_3d + module procedure rotate_array_pair_integer +end interface rotate_array_pair + + +!> Rotate an array pair representing the components of a vector. +!! Rotation is applied across the first and second axes of the array. +!! This rotation should be applied when the fields satisfy vector +!! transformation rules. For example, the u and v components of a velocity +!! will map from one to the other for quarter turns, with a sign change in one +!! component. A half turn will map elements onto themselves with sign changes +!! in both components. +interface rotate_vector + module procedure rotate_vector_real_2d + module procedure rotate_vector_real_3d + module procedure rotate_vector_real_4d +end interface rotate_vector + + +!> Allocate an array based on the rotated index map of an unrotated reference +!! array. +interface allocate_rotated_array + module procedure allocate_rotated_array_real_2d + module procedure allocate_rotated_array_real_3d + module procedure allocate_rotated_array_real_4d + module procedure allocate_rotated_array_integer +end interface allocate_rotated_array + +contains + +!> Rotate the elements of a 2d real array along first and second axes. +subroutine rotate_array_real_2d(A_in, turns, A) + real, intent(in) :: A_in(:,:) !< Unrotated array [arbitrary] + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:) !< Rotated array [arbitrary] + + integer :: m, n + + m = size(A_in, 1) + n = size(A_in, 2) + + select case (modulo(turns, 4)) + case(0) + A(:,:) = A_in(:,:) + case(1) + A(:,:) = transpose(A_in) + A(:,:) = A(n:1:-1, :) + case(2) + A(:,:) = A_in(m:1:-1, n:1:-1) + case(3) + A(:,:) = transpose(A_in(m:1:-1, :)) + end select +end subroutine rotate_array_real_2d + + +!> Rotate the elements of a 3d real array along first and second axes. +subroutine rotate_array_real_3d(A_in, turns, A) + real, intent(in) :: A_in(:,:,:) !< Unrotated array [arbitrary] + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:) !< Rotated array [arbitrary] + + integer :: k + + do k = 1, size(A_in, 3) + call rotate_array(A_in(:,:,k), turns, A(:,:,k)) + enddo +end subroutine rotate_array_real_3d + + +!> Rotate the elements of a 4d real array along first and second axes. +subroutine rotate_array_real_4d(A_in, turns, A) + real, intent(in) :: A_in(:,:,:,:) !< Unrotated array [arbitrary] + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:,:) !< Rotated array [arbitrary] + + integer :: n + + do n = 1, size(A_in, 4) + call rotate_array(A_in(:,:,:,n), turns, A(:,:,:,n)) + enddo +end subroutine rotate_array_real_4d + + +!> Rotate the elements of a 2d integer array along first and second axes. +subroutine rotate_array_integer(A_in, turns, A) + integer, intent(in) :: A_in(:,:) !< Unrotated array + integer, intent(in) :: turns !< Number of quarter turns + integer, intent(out) :: A(:,:) !< Rotated array + + integer :: m, n + + m = size(A_in, 1) + n = size(A_in, 2) + + select case (modulo(turns, 4)) + case(0) + A(:,:) = A_in(:,:) + case(1) + A(:,:) = transpose(A_in) + A(:,:) = A(n:1:-1, :) + case(2) + A(:,:) = A_in(m:1:-1, n:1:-1) + case(3) + A(:,:) = transpose(A_in(m:1:-1, :)) + end select +end subroutine rotate_array_integer + + +!> Rotate the elements of a 2d logical array along first and second axes. +subroutine rotate_array_logical(A_in, turns, A) + logical, intent(in) :: A_in(:,:) !< Unrotated array + integer, intent(in) :: turns !< Number of quarter turns + logical, intent(out) :: A(:,:) !< Rotated array + + integer :: m, n + + m = size(A_in, 1) + n = size(A_in, 2) + + select case (modulo(turns, 4)) + case(0) + A(:,:) = A_in(:,:) + case(1) + A(:,:) = transpose(A_in) + A(:,:) = A(n:1:-1, :) + case(2) + A(:,:) = A_in(m:1:-1, n:1:-1) + case(3) + A(:,:) = transpose(A_in(m:1:-1, :)) + end select +end subroutine rotate_array_logical + + +!> Rotate the elements of a 2d real array pair along first and second axes. +subroutine rotate_array_pair_real_2d(A_in, B_in, turns, A, B) + real, intent(in) :: A_in(:,:) !< Unrotated scalar array pair [arbitrary] + real, intent(in) :: B_in(:,:) !< Unrotated scalar array pair [arbitrary] + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:) !< Rotated scalar array pair [arbitrary] + real, intent(out) :: B(:,:) !< Rotated scalar array pair [arbitrary] + + if (modulo(turns, 2) /= 0) then + call rotate_array(B_in, turns, A) + call rotate_array(A_in, turns, B) + else + call rotate_array(A_in, turns, A) + call rotate_array(B_in, turns, B) + endif +end subroutine rotate_array_pair_real_2d + + +!> Rotate the elements of a 3d real array pair along first and second axes. +subroutine rotate_array_pair_real_3d(A_in, B_in, turns, A, B) + real, intent(in) :: A_in(:,:,:) !< Unrotated scalar array pair [arbitrary] + real, intent(in) :: B_in(:,:,:) !< Unrotated scalar array pair [arbitrary] + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:) !< Rotated scalar array pair [arbitrary] + real, intent(out) :: B(:,:,:) !< Rotated scalar array pair [arbitrary] + + integer :: k + + do k = 1, size(A_in, 3) + call rotate_array_pair(A_in(:,:,k), B_in(:,:,k), turns, & + A(:,:,k), B(:,:,k)) + enddo +end subroutine rotate_array_pair_real_3d + + +!> Rotate the elements of a 4d real array pair along first and second axes. +subroutine rotate_array_pair_integer(A_in, B_in, turns, A, B) + integer, intent(in) :: A_in(:,:) !< Unrotated scalar array pair + integer, intent(in) :: B_in(:,:) !< Unrotated scalar array pair + integer, intent(in) :: turns !< Number of quarter turns + integer, intent(out) :: A(:,:) !< Rotated scalar array pair + integer, intent(out) :: B(:,:) !< Rotated scalar array pair + + if (modulo(turns, 2) /= 0) then + call rotate_array(B_in, turns, A) + call rotate_array(A_in, turns, B) + else + call rotate_array(A_in, turns, A) + call rotate_array(B_in, turns, B) + endif +end subroutine rotate_array_pair_integer + + +!> Rotate the elements of a 2d real vector along first and second axes. +subroutine rotate_vector_real_2d(A_in, B_in, turns, A, B) + real, intent(in) :: A_in(:,:) !< First component of unrotated vector [arbitrary] + real, intent(in) :: B_in(:,:) !< Second component of unrotated vector [arbitrary] + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:) !< First component of rotated vector [arbitrary] + real, intent(out) :: B(:,:) !< Second component of unrotated vector [arbitrary] + + call rotate_array_pair(A_in, B_in, turns, A, B) + + if (modulo(turns, 4) == 1 .or. modulo(turns, 4) == 2) & + A(:,:) = -A(:,:) + + if (modulo(turns, 4) == 2 .or. modulo(turns, 4) == 3) & + B(:,:) = -B(:,:) +end subroutine rotate_vector_real_2d + + +!> Rotate the elements of a 3d real vector along first and second axes. +subroutine rotate_vector_real_3d(A_in, B_in, turns, A, B) + real, intent(in) :: A_in(:,:,:) !< First component of unrotated vector [arbitrary] + real, intent(in) :: B_in(:,:,:) !< Second component of unrotated vector [arbitrary] + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:) !< First component of rotated vector [arbitrary] + real, intent(out) :: B(:,:,:) !< Second component of unrotated vector [arbitrary] + + integer :: k + + do k = 1, size(A_in, 3) + call rotate_vector(A_in(:,:,k), B_in(:,:,k), turns, A(:,:,k), B(:,:,k)) + enddo +end subroutine rotate_vector_real_3d + + +!> Rotate the elements of a 4d real vector along first and second axes. +subroutine rotate_vector_real_4d(A_in, B_in, turns, A, B) + real, intent(in) :: A_in(:,:,:,:) !< First component of unrotated vector [arbitrary] + real, intent(in) :: B_in(:,:,:,:) !< Second component of unrotated vector [arbitrary] + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:,:) !< First component of rotated vector [arbitrary] + real, intent(out) :: B(:,:,:,:) !< Second component of unrotated vector [arbitrary] + + integer :: n + + do n = 1, size(A_in, 4) + call rotate_vector(A_in(:,:,:,n), B_in(:,:,:,n), turns, & + A(:,:,:,n), B(:,:,:,n)) + enddo +end subroutine rotate_vector_real_4d + + +!> Allocate a 2d real array on the rotated index map of a reference array. +subroutine allocate_rotated_array_real_2d(A_in, lb, turns, A) + ! NOTE: lb must be declared before A_in + integer, intent(in) :: lb(2) !< Lower index bounds of A_in + real, intent(in) :: A_in(lb(1):, lb(2):) !< Reference array [arbitrary] + integer, intent(in) :: turns !< Number of quarter turns + real, allocatable, intent(inout) :: A(:,:) !< Array on rotated index [arbitrary] + + integer :: ub(2) + + ub(:) = ubound(A_in) + + if (modulo(turns, 2) /= 0) then + allocate(A(lb(2):ub(2), lb(1):ub(1))) + else + allocate(A(lb(1):ub(1), lb(2):ub(2))) + endif +end subroutine allocate_rotated_array_real_2d + + +!> Allocate a 3d real array on the rotated index map of a reference array. +subroutine allocate_rotated_array_real_3d(A_in, lb, turns, A) + ! NOTE: lb must be declared before A_in + integer, intent(in) :: lb(3) !< Lower index bounds of A_in + real, intent(in) :: A_in(lb(1):, lb(2):, lb(3):) !< Reference array [arbitrary] + integer, intent(in) :: turns !< Number of quarter turns + real, allocatable, intent(inout) :: A(:,:,:) !< Array on rotated index [arbitrary] + + integer :: ub(3) + + ub(:) = ubound(A_in) + + if (modulo(turns, 2) /= 0) then + allocate(A(lb(2):ub(2), lb(1):ub(1), lb(3):ub(3))) + else + allocate(A(lb(1):ub(1), lb(2):ub(2), lb(3):ub(3))) + endif +end subroutine allocate_rotated_array_real_3d + + +!> Allocate a 4d real array on the rotated index map of a reference array. +subroutine allocate_rotated_array_real_4d(A_in, lb, turns, A) + ! NOTE: lb must be declared before A_in + integer, intent(in) :: lb(4) !< Lower index bounds of A_in + real, intent(in) :: A_in(lb(1):,lb(2):,lb(3):,lb(4):) !< Reference array [arbitrary] + integer, intent(in) :: turns !< Number of quarter turns + real, allocatable, intent(inout) :: A(:,:,:,:) !< Array on rotated index [arbitrary] + + integer:: ub(4) + + ub(:) = ubound(A_in) + + if (modulo(turns, 2) /= 0) then + allocate(A(lb(2):ub(2), lb(1):ub(1), lb(3):ub(3), lb(4):ub(4))) + else + allocate(A(lb(1):ub(1), lb(2):ub(2), lb(3):ub(3), lb(4):ub(4))) + endif +end subroutine allocate_rotated_array_real_4d + + +!> Allocate a 2d integer array on the rotated index map of a reference array. +subroutine allocate_rotated_array_integer(A_in, lb, turns, A) + integer, intent(in) :: lb(2) !< Lower index bounds of A_in + integer, intent(in) :: A_in(lb(1):,lb(2):) !< Reference array + integer, intent(in) :: turns !< Number of quarter turns + integer, allocatable, intent(inout) :: A(:,:) !< Array on rotated index + + integer :: ub(2) + + ub(:) = ubound(A_in) + + if (modulo(turns, 2) /= 0) then + allocate(A(lb(2):ub(2), lb(1):ub(1))) + else + allocate(A(lb(1):ub(1), lb(2):ub(2))) + endif +end subroutine allocate_rotated_array_integer + +end module MOM_array_transform diff --git a/framework/MOM_checksums.F90 b/framework/MOM_checksums.F90 new file mode 100644 index 0000000000..00e4ba4918 --- /dev/null +++ b/framework/MOM_checksums.F90 @@ -0,0 +1,2416 @@ +!> Routines to calculate checksums of various array and vector types +module MOM_checksums + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_array_transform, only : rotate_array, rotate_array_pair, rotate_vector +use MOM_array_transform, only : allocate_rotated_array +use MOM_coms, only : PE_here, root_PE, num_PEs, sum_across_PEs +use MOM_coms, only : min_across_PEs, max_across_PEs +use MOM_coms, only : reproducing_sum, field_chksum +use MOM_error_handler, only : MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : log_version, param_file_type +use MOM_hor_index, only : hor_index_type, rotate_hor_index + +use iso_fortran_env, only : error_unit, int32, int64 + +implicit none ; private + +public :: chksum0, zchksum, rotated_field_chksum +public :: hchksum, Bchksum, uchksum, vchksum, qchksum, is_NaN, chksum +public :: hchksum_pair, uvchksum, Bchksum_pair +public :: MOM_checksums_init + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. +! The functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + +!> Checksums a pair of arrays (2d or 3d) staggered at tracer points +interface hchksum_pair + module procedure chksum_pair_h_2d, chksum_pair_h_3d +end interface + +!> Checksums a pair velocity arrays (2d or 3d) staggered at C-grid locations +interface uvchksum + module procedure chksum_uv_2d, chksum_uv_3d +end interface + +!> Checksums an array (2d or 3d) staggered at C-grid u points. +interface uchksum + module procedure chksum_u_2d, chksum_u_3d +end interface + +!> Checksums an array (2d or 3d) staggered at C-grid v points. +interface vchksum + module procedure chksum_v_2d, chksum_v_3d +end interface + +!> Checksums a pair of arrays (2d or 3d) staggered at corner points +interface Bchksum_pair + module procedure chksum_pair_B_2d, chksum_pair_B_3d +end interface + +!> Checksums an array (2d or 3d) staggered at tracer points. +interface hchksum + module procedure chksum_h_2d, chksum_h_3d +end interface + +!> Checksums an array (2d or 3d) staggered at corner points. +interface Bchksum + module procedure chksum_B_2d, chksum_B_3d +end interface + +!> This is an older interface that has been renamed Bchksum +interface qchksum + module procedure chksum_B_2d, chksum_B_3d +end interface + +!> This is an older interface for 1-, 2-, or 3-D checksums +interface chksum + module procedure chksum1d, chksum2d, chksum3d +end interface + +!> Write a message with either checksums or numerical statistics of arrays +interface chk_sum_msg + module procedure chk_sum_msg1, chk_sum_msg2, chk_sum_msg3, chk_sum_msg5 +end interface + +!> Returns .true. if any element of x is a NaN, and .false. otherwise. +interface is_NaN + module procedure is_NaN_0d, is_NaN_1d, is_NaN_2d, is_NaN_3d +end interface + +!> Rotate and compute the checksum of a field +interface rotated_field_chksum + module procedure rotated_field_chksum_real_0d + module procedure rotated_field_chksum_real_1d + module procedure rotated_field_chksum_real_2d + module procedure rotated_field_chksum_real_3d + module procedure rotated_field_chksum_real_4d +end interface rotated_field_chksum + +integer, parameter :: bc_modulus = 1000000000 !< Modulus of checksum bitcount +integer, parameter :: default_shift=0 !< The default array shift +logical :: calculateStatistics=.true. !< If true, report min, max and mean. +logical :: writeChksums=.true. !< If true, report the bitcount checksum +logical :: checkForNaNs=.true. !< If true, checks array for NaNs and cause + !! FATAL error is any are found + +contains + +!> Checksum a scalar field (consistent with array checksums) +subroutine chksum0(scalar, mesg, scale, logunit) + real, intent(in) :: scalar !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real :: scaling !< Explicit rescaling factor [a A-1 ~> 1] + integer :: iounit !< Log IO unit + real :: rs !< Rescaled scalar [a] + integer :: bc !< Scalar bitcount + + if (checkForNaNs .and. is_NaN(scalar)) & + call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) + + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit ; if (present(logunit)) iounit = logunit + + if (calculateStatistics) then + rs = scaling * scalar + if (is_root_pe()) & + call chk_sum_msg(" scalar:", rs, rs, rs, mesg, iounit) + endif + + if (.not. writeChksums) return + + bc = mod(bitcount(abs(scaling * scalar)), bc_modulus) + if (is_root_pe()) & + call chk_sum_msg(" scalar:", bc, mesg, iounit) + +end subroutine chksum0 + + +!> Checksum a 1d array (typically a column). +subroutine zchksum(array, mesg, scale, logunit) + real, dimension(:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, allocatable, dimension(:) :: rescaled_array ! The array with scaling undone [a] + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] + integer :: iounit !< Log IO unit + integer :: k + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] + integer :: bc0 + + if (checkForNaNs) then + if (is_NaN(array(:))) & + call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) + endif + + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit ; if (present(logunit)) iounit = logunit + + if (calculateStatistics) then + if (present(scale)) then + allocate(rescaled_array(LBOUND(array,1):UBOUND(array,1)), source=0.0) + do k=1, size(array, 1) + rescaled_array(k) = scale * array(k) + enddo + + call subStats(rescaled_array, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(array, aMean, aMin, aMax) + endif + + if (is_root_pe()) & + call chk_sum_msg(" column:", aMean, aMin, aMax, mesg, iounit) + endif + + if (.not. writeChksums) return + + bc0 = subchk(array, scaling) + if (is_root_pe()) call chk_sum_msg(" column:", bc0, mesg, iounit) + + contains + + integer function subchk(array, scale) + real, dimension(:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer :: k, bc + subchk = 0 + do k=LBOUND(array, 1), UBOUND(array, 1) + bc = bitcount(abs(scale * array(k))) + subchk = subchk + bc + enddo + subchk=mod(subchk, bc_modulus) + end function subchk + + subroutine subStats(array, aMean, aMin, aMax) + real, dimension(:), intent(in) :: array !< The array to be checksummed [a] + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] + + integer :: k, n + + aMin = array(1) + aMax = array(1) + n = 0 + do k=LBOUND(array,1), UBOUND(array,1) + aMin = min(aMin, array(k)) + aMax = max(aMax, array(k)) + n = n + 1 + enddo + aMean = sum(array(:)) / real(n) + end subroutine subStats +end subroutine zchksum + +!> Checksums on a pair of 2d arrays staggered at tracer points. +subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & + scale, logunit, scalar_pair) + character(len=*), intent(in) :: mesg !< Identifying messages + type(hor_index_type), target, intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert these arrays back to unscaled + !! units for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe + !! a scalar, rather than vector + logical :: vector_pair + integer :: turns + type(hor_index_type), pointer :: HI_in + real, dimension(:,:), pointer :: arrayA_in, arrayB_in ! Rotated arrays [A ~> a] + + vector_pair = .true. + if (present(scalar_pair)) vector_pair = .not. scalar_pair + + turns = HI%turns + if (modulo(turns, 4) /= 0) then + ! Rotate field back to the input grid + allocate(HI_in) + call rotate_hor_index(HI, -turns, HI_in) + allocate(arrayA_in(HI_in%isd:HI_in%ied, HI_in%jsd:HI_in%jed)) + allocate(arrayB_in(HI_in%isd:HI_in%ied, HI_in%jsd:HI_in%jed)) + + if (vector_pair) then + call rotate_vector(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + else + call rotate_array_pair(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + endif + else + HI_in => HI + arrayA_in => arrayA + arrayB_in => arrayB + endif + + if (present(haloshift)) then + call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, haloshift, omit_corners, & + scale=scale, logunit=logunit) + call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, haloshift, omit_corners, & + scale=scale, logunit=logunit) + else + call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit) + call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit) + endif +end subroutine chksum_pair_h_2d + +!> Checksums on a pair of 3d arrays staggered at tracer points. +subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & + scale, logunit, scalar_pair) + character(len=*), intent(in) :: mesg !< Identifying messages + type(hor_index_type), target, intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayA !< The first array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayB !< The second array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe + !! a scalar, rather than vector + logical :: vector_pair + integer :: turns + type(hor_index_type), pointer :: HI_in + real, dimension(:,:,:), pointer :: arrayA_in, arrayB_in ! Rotated arrays [A ~> a] + + vector_pair = .true. + if (present(scalar_pair)) vector_pair = .not. scalar_pair + + turns = HI%turns + if (modulo(turns, 4) /= 0) then + ! Rotate field back to the input grid + allocate(HI_in) + call rotate_hor_index(HI, -turns, HI_in) + allocate(arrayA_in(HI_in%isd:HI_in%ied, HI_in%jsd:HI_in%jed, size(arrayA, 3))) + allocate(arrayB_in(HI_in%isd:HI_in%ied, HI_in%jsd:HI_in%jed, size(arrayB, 3))) + + if (vector_pair) then + call rotate_vector(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + else + call rotate_array_pair(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + endif + else + HI_in => HI + arrayA_in => arrayA + arrayB_in => arrayB + endif + + if (present(haloshift)) then + call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, haloshift, omit_corners, & + scale=scale, logunit=logunit) + call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, haloshift, omit_corners, & + scale=scale, logunit=logunit) + else + call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit) + call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit) + endif + + ! NOTE: automatic deallocation of array[AB]_in +end subroutine chksum_pair_h_3d + +!> Checksums a 2d array staggered at tracer points. +subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit) + type(hor_index_type), target, intent(in) :: HI_m !< Horizontal index bounds of the model grid + real, dimension(HI_m%isd:,HI_m%jsd:), target, intent(in) :: array_m !< Field array on the model grid in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:) :: rescaled_array ! The array with scaling undone [a] + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] + integer :: iounit !< Log IO unit + integer :: i, j + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] + integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift + integer :: bcN, bcS, bcE, bcW + logical :: do_corners + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + allocate(array(HI%isd:HI%ied, HI%jsd:HI%jed)) + call rotate_array(array_m, -turns, array) + else + HI => HI_m + array => array_m + endif + + if (checkForNaNs) then + if (is_NaN(array(HI%isc:HI%iec,HI%jsc:HI%jec))) & + call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) +! if (is_NaN(array)) & +! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) + endif + + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit ; if (present(logunit)) iounit = logunit + + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2)), source=0.0 ) + do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + rescaled_array(i,j) = scale*array(i,j) + enddo ; enddo + call subStats(HI, rescaled_array, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, aMean, aMin, aMax) + endif + + if (is_root_pe()) & + call chk_sum_msg("h-point:", aMean, aMin, aMax, mesg, iounit) + endif + + if (.not.writeChksums) return + + hshift = default_shift + if (present(haloshift)) hshift = haloshift + if (hshift<0) hshift = HI%ied-HI%iec + + if ( HI%isc-hshiftHI%ied .or. & + HI%jsc-hshiftHI%jed ) then + write(0,*) 'chksum_h_2d: haloshift =',hshift + write(0,*) 'chksum_h_2d: isd,isc,iec,ied=',HI%isd,HI%isc,HI%iec,HI%ied + write(0,*) 'chksum_h_2d: jsd,jsc,jec,jed=',HI%jsd,HI%jsc,HI%jec,HI%jed + call chksum_error(FATAL,'Error in chksum_h_2d '//trim(mesg)) + endif + + bc0 = subchk(array, HI, 0, 0, scaling) + + if (hshift==0) then + if (is_root_pe()) call chk_sum_msg("h-point:", bc0, mesg, iounit) + return + endif + + do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + + if (do_corners) then + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcSE = subchk(array, HI, hshift, -hshift, scaling) + bcNW = subchk(array, HI, -hshift, hshift, scaling) + bcNE = subchk(array, HI, hshift, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg("h-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + bcE = subchk(array, HI, hshift, 0, scaling) + bcW = subchk(array, HI, -hshift, 0, scaling) + bcN = subchk(array, HI, 0, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg_NSEW("h-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + endif + + contains + integer function subchk(array, HI, di, dj, scale) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer :: i, j, bc + subchk = 0 + do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di + bc = bitcount(abs(scale*array(i,j))) + subchk = subchk + bc + enddo ; enddo + call sum_across_PEs(subchk) + subchk=mod(subchk, bc_modulus) + end function subchk + + subroutine subStats(HI, array, aMean, aMin, aMax) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed [a] + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] + + integer :: i, j, n + + aMin = array(HI%isc,HI%jsc) + aMax = array(HI%isc,HI%jsc) + n = 0 + do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + aMin = min(aMin, array(i,j)) + aMax = max(aMax, array(i,j)) + n = n + 1 + enddo ; enddo + aMean = reproducing_sum(array(HI%isc:HI%iec,HI%jsc:HI%jec)) + call sum_across_PEs(n) + call min_across_PEs(aMin) + call max_across_PEs(aMax) + aMean = aMean / real(n) + end subroutine subStats + +end subroutine chksum_h_2d + +!> Checksums on a pair of 2d arrays staggered at q-points. +subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & + omit_corners, scale, logunit, scalar_pair) + character(len=*), intent(in) :: mesg !< Identifying messages + type(hor_index_type), target, intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe + !! a scalar, rather than vector + + logical :: sym + logical :: vector_pair + integer :: turns + type(hor_index_type), pointer :: HI_in + real, dimension(:,:), pointer :: arrayA_in, arrayB_in ! Rotated arrays [A ~> a] + + vector_pair = .true. + if (present(scalar_pair)) vector_pair = .not. scalar_pair + + turns = HI%turns + if (modulo(turns, 4) /= 0) then + ! Rotate field back to the input grid + allocate(HI_in) + call rotate_hor_index(HI, -turns, HI_in) + allocate(arrayA_in(HI_in%IsdB:HI_in%IedB, HI_in%JsdB:HI_in%JedB)) + allocate(arrayB_in(HI_in%IsdB:HI_in%IedB, HI_in%JsdB:HI_in%JedB)) + + if (vector_pair) then + call rotate_vector(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + else + call rotate_array_pair(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + endif + else + HI_in => HI + arrayA_in => arrayA + arrayB_in => arrayB + endif + + sym = .false. ; if (present(symmetric)) sym = symmetric + + if (present(haloshift)) then + call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, haloshift, symmetric=sym, & + omit_corners=omit_corners, scale=scale, logunit=logunit) + call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, haloshift, symmetric=sym, & + omit_corners=omit_corners, scale=scale, logunit=logunit) + else + call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, symmetric=sym, scale=scale, & + logunit=logunit) + call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, symmetric=sym, scale=scale, & + logunit=logunit) + endif + +end subroutine chksum_pair_B_2d + +!> Checksums on a pair of 3d arrays staggered at q-points. +subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & + omit_corners, scale, logunit, scalar_pair) + character(len=*), intent(in) :: mesg !< Identifying messages + type(hor_index_type), target, intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayA !< The first array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayB !< The second array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe + !! a scalar, rather than vector + + logical :: vector_pair + integer :: turns + type(hor_index_type), pointer :: HI_in + real, dimension(:,:,:), pointer :: arrayA_in, arrayB_in ! Rotated arrays [A ~> a] + + vector_pair = .true. + if (present(scalar_pair)) vector_pair = .not. scalar_pair + + turns = HI%turns + if (modulo(turns, 4) /= 0) then + ! Rotate field back to the input grid + allocate(HI_in) + call rotate_hor_index(HI, -turns, HI_in) + allocate(arrayA_in(HI_in%IsdB:HI_in%IedB, HI_in%JsdB:HI_in%JedB, size(arrayA, 3))) + allocate(arrayB_in(HI_in%IsdB:HI_in%IedB, HI_in%JsdB:HI_in%JedB, size(arrayB, 3))) + + if (vector_pair) then + call rotate_vector(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + else + call rotate_array_pair(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + endif + else + HI_in => HI + arrayA_in => arrayA + arrayB_in => arrayB + endif + + if (present(haloshift)) then + call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, haloshift, symmetric, & + omit_corners, scale=scale, logunit=logunit) + call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, haloshift, symmetric, & + omit_corners, scale=scale, logunit=logunit) + else + call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, symmetric=symmetric, scale=scale, & + logunit=logunit) + call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, symmetric=symmetric, scale=scale, & + logunit=logunit) + endif +end subroutine chksum_pair_B_3d + +!> Checksums a 2d array staggered at corner points. +subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & + scale, logunit) + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%IsdB:,HI_m%JsdB:), & + target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the + !! full symmetric computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:) :: rescaled_array ! The array with scaling undone [a] + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] + integer :: iounit !< Log IO unit + integer :: i, j, Is, Js + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] + integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift + integer :: bcN, bcS, bcE, bcW + logical :: do_corners, sym, sym_stats + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + allocate(array(HI%IsdB:HI%IedB, HI%JsdB:HI%JedB)) + call rotate_array(array_m, -turns, array) + else + HI => HI_m + array => array_m + endif + + if (checkForNaNs) then + if (is_NaN(array(HI%IscB:HI%IecB,HI%JscB:HI%JecB))) & + call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) +! if (is_NaN(array)) & +! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) + endif + + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit ; if (present(logunit)) iounit = logunit + sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric + if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif + + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2)), source=0.0 ) + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 + do J=Js,HI%JecB ; do I=Is,HI%IecB + rescaled_array(I,J) = scale*array(I,J) + enddo ; enddo + call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, sym_stats, aMean, aMin, aMax) + endif + if (is_root_pe()) & + call chk_sum_msg("B-point:", aMean, aMin, aMax, mesg, iounit) + endif + + if (.not.writeChksums) return + + hshift = default_shift + if (present(haloshift)) hshift = haloshift + if (hshift<0) hshift = HI%ied-HI%iec + + if ( HI%iscB-hshiftHI%iedB .or. & + HI%jscB-hshiftHI%jedB ) then + write(0,*) 'chksum_B_2d: haloshift =',hshift + write(0,*) 'chksum_B_2d: isd,isc,iec,ied=',HI%isdB,HI%iscB,HI%iecB,HI%iedB + write(0,*) 'chksum_B_2d: jsd,jsc,jec,jed=',HI%jsdB,HI%jscB,HI%jecB,HI%jedB + call chksum_error(FATAL,'Error in chksum_B_2d '//trim(mesg)) + endif + + bc0 = subchk(array, HI, 0, 0, scaling) + + sym = .false. ; if (present(symmetric)) sym = symmetric + + if ((hshift==0) .and. .not.sym) then + if (is_root_pe()) call chk_sum_msg("B-point:", bc0, mesg, iounit) + return + endif + + do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + + if (do_corners) then + if (sym) then + bcSW = subchk(array, HI, -hshift-1, -hshift-1, scaling) + bcSE = subchk(array, HI, hshift, -hshift-1, scaling) + bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + else + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcSE = subchk(array, HI, hshift, -hshift, scaling) + bcNW = subchk(array, HI, -hshift, hshift, scaling) + endif + bcNE = subchk(array, HI, hshift, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg("B-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + bcE = subchk(array, HI, hshift, 0, scaling) + bcW = subchk(array, HI, -hshift, 0, scaling) + bcN = subchk(array, HI, 0, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg_NSEW("B-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + endif + + contains + + integer function subchk(array, HI, di, dj, scale) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer :: i, j, bc + subchk = 0 + ! This line deliberately uses the h-point computational domain. + do J=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di + bc = bitcount(abs(scale*array(I,J))) + subchk = subchk + bc + enddo ; enddo + call sum_across_PEs(subchk) + subchk=mod(subchk, bc_modulus) + end function subchk + + subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed [a] + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] + + integer :: i, j, n, IsB, JsB + + IsB = HI%isc ; if (sym_stats) IsB = HI%isc-1 + JsB = HI%jsc ; if (sym_stats) JsB = HI%jsc-1 + + aMin = array(HI%isc,HI%jsc) ; aMax = aMin + do J=JsB,HI%JecB ; do I=IsB,HI%IecB + aMin = min(aMin, array(I,J)) + aMax = max(aMax, array(I,J)) + enddo ; enddo + ! This line deliberately uses the h-point computational domain. + aMean = reproducing_sum(array(HI%isc:HI%iec,HI%jsc:HI%jec)) + n = (1 + HI%jec - HI%jsc) * (1 + HI%iec - HI%isc) + call sum_across_PEs(n) + call min_across_PEs(aMin) + call max_across_PEs(aMax) + aMean = aMean / real(n) + end subroutine subStats + +end subroutine chksum_B_2d + +!> Checksums a pair of 2d velocity arrays staggered at C-grid locations +subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & + omit_corners, scale, logunit, scalar_pair) + character(len=*), intent(in) :: mesg !< Identifying messages + type(hor_index_type), target, intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:), target, intent(in) :: arrayU !< The u-component array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%JsdB:), target, intent(in) :: arrayV !< The v-component array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert these arrays back to unscaled + !! units for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe a + !! a scalar, rather than vector + logical :: vector_pair + integer :: turns + type(hor_index_type), pointer :: HI_in + real, dimension(:,:), pointer :: arrayU_in, arrayV_in ! Rotated arrays [A ~> a] + + vector_pair = .true. + if (present(scalar_pair)) vector_pair = .not. scalar_pair + + turns = HI%turns + if (modulo(turns, 4) /= 0) then + ! Rotate field back to the input grid + allocate(HI_in) + call rotate_hor_index(HI, -turns, HI_in) + allocate(arrayU_in(HI_in%IsdB:HI_in%IedB, HI_in%jsd:HI_in%jed)) + allocate(arrayV_in(HI_in%isd:HI_in%ied, HI_in%JsdB:HI_in%JedB)) + + if (vector_pair) then + call rotate_vector(arrayU, arrayV, -turns, arrayU_in, arrayV_in) + else + call rotate_array_pair(arrayU, arrayV, -turns, arrayU_in, arrayV_in) + endif + else + HI_in => HI + arrayU_in => arrayU + arrayV_in => arrayV + endif + + if (present(haloshift)) then + call chksum_u_2d(arrayU_in, 'u '//mesg, HI_in, haloshift, symmetric, & + omit_corners, scale=scale, logunit=logunit) + call chksum_v_2d(arrayV_in, 'v '//mesg, HI_in, haloshift, symmetric, & + omit_corners, scale=scale, logunit=logunit) + else + call chksum_u_2d(arrayU_in, 'u '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit) + call chksum_v_2d(arrayV_in, 'v '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit) + endif +end subroutine chksum_uv_2d + +!> Checksums a pair of 3d velocity arrays staggered at C-grid locations +subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & + omit_corners, scale, logunit, scalar_pair) + character(len=*), intent(in) :: mesg !< Identifying messages + type(hor_index_type), target, intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:,:), target, intent(in) :: arrayU !< The u-component array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%JsdB:,:), target, intent(in) :: arrayV !< The v-component array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert these arrays back to unscaled + !! units for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe a + !! a scalar, rather than vector + logical :: vector_pair + integer :: turns + type(hor_index_type), pointer :: HI_in + real, dimension(:,:,:), pointer :: arrayU_in, arrayV_in ! Rotated arrays [A ~> a] + + vector_pair = .true. + if (present(scalar_pair)) vector_pair = .not. scalar_pair + + turns = HI%turns + if (modulo(turns, 4) /= 0) then + ! Rotate field back to the input grid + allocate(HI_in) + call rotate_hor_index(HI, -turns, HI_in) + allocate(arrayU_in(HI_in%IsdB:HI_in%IedB, HI_in%jsd:HI_in%jed, size(arrayU, 3))) + allocate(arrayV_in(HI_in%isd:HI_in%ied, HI_in%JsdB:HI_in%JedB, size(arrayV, 3))) + + if (vector_pair) then + call rotate_vector(arrayU, arrayV, -turns, arrayU_in, arrayV_in) + else + call rotate_array_pair(arrayU, arrayV, -turns, arrayU_in, arrayV_in) + endif + else + HI_in => HI + arrayU_in => arrayU + arrayV_in => arrayV + endif + + if (present(haloshift)) then + call chksum_u_3d(arrayU_in, 'u '//mesg, HI_in, haloshift, symmetric, & + omit_corners, scale=scale, logunit=logunit) + call chksum_v_3d(arrayV_in, 'v '//mesg, HI_in, haloshift, symmetric, & + omit_corners, scale=scale, logunit=logunit) + else + call chksum_u_3d(arrayU_in, 'u '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit) + call chksum_v_3d(arrayV_in, 'v '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit) + endif +end subroutine chksum_uv_3d + +!> Checksums a 2d array staggered at C-grid u points. +subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & + scale, logunit) + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%IsdB:,HI_m%jsd:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:) :: rescaled_array ! The array with scaling undone [a] + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] + integer :: iounit !< Log IO unit + integer :: i, j, Is + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] + integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift + integer :: bcN, bcS, bcE, bcW + logical :: do_corners, sym, sym_stats + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + if (modulo(turns, 2) /= 0) then + ! Arrays originating from v-points must be handled by vchksum + allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB)) + call rotate_array(array_m, -turns, array) + call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + return + else + allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed)) + call rotate_array(array_m, -turns, array) + endif + else + HI => HI_m + array => array_m + endif + + if (checkForNaNs) then + if (is_NaN(array(HI%IscB:HI%IecB,HI%jsc:HI%jec))) & + call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) +! if (is_NaN(array)) & +! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) + endif + + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit ; if (present(logunit)) iounit = logunit + sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric + if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif + + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2)), source=0.0 ) + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + do j=HI%jsc,HI%jec ; do I=Is,HI%IecB + rescaled_array(I,j) = scale*array(I,j) + enddo ; enddo + call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, sym_stats, aMean, aMin, aMax) + endif + + if (is_root_pe()) & + call chk_sum_msg("u-point:", aMean, aMin, aMax, mesg, iounit) + endif + + if (.not.writeChksums) return + + hshift = default_shift + if (present(haloshift)) hshift = haloshift + if (hshift<0) hshift = HI%iedB-HI%iecB + + if ( HI%iscB-hshiftHI%iedB .or. & + HI%jsc-hshiftHI%jed ) then + write(0,*) 'chksum_u_2d: haloshift =',hshift + write(0,*) 'chksum_u_2d: isd,isc,iec,ied=',HI%isdB,HI%iscB,HI%iecB,HI%iedB + write(0,*) 'chksum_u_2d: jsd,jsc,jec,jed=',HI%jsd,HI%jsc,HI%jec,HI%jed + call chksum_error(FATAL,'Error in chksum_u_2d '//trim(mesg)) + endif + + bc0 = subchk(array, HI, 0, 0, scaling) + + sym = .false. ; if (present(symmetric)) sym = symmetric + + if ((hshift==0) .and. .not.sym) then + if (is_root_pe()) call chk_sum_msg("u-point:", bc0, mesg, iounit) + return + endif + + do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + + if (hshift==0) then + bcW = subchk(array, HI, -hshift-1, 0, scaling) + if (is_root_pe()) call chk_sum_msg_W("u-point:", bc0, bcW, mesg, iounit) + elseif (do_corners) then + if (sym) then + bcSW = subchk(array, HI, -hshift-1, -hshift, scaling) + bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + else + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcNW = subchk(array, HI, -hshift, hshift, scaling) + endif + bcSE = subchk(array, HI, hshift, -hshift, scaling) + bcNE = subchk(array, HI, hshift, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg("u-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + bcE = subchk(array, HI, hshift, 0, scaling) + if (sym) then + bcW = subchk(array, HI, -hshift-1, 0, scaling) + else + bcW = subchk(array, HI, -hshift, 0, scaling) + endif + bcN = subchk(array, HI, 0, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg_NSEW("u-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + endif + + contains + + integer function subchk(array, HI, di, dj, scale) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer :: i, j, bc + subchk = 0 + ! This line deliberately uses the h-point computational domain. + do j=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di + bc = bitcount(abs(scale*array(I,j))) + subchk = subchk + bc + enddo ; enddo + call sum_across_PEs(subchk) + subchk=mod(subchk, bc_modulus) + end function subchk + + subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed [a] + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] + + integer :: i, j, n, IsB + + IsB = HI%isc ; if (sym_stats) IsB = HI%isc-1 + + aMin = array(HI%isc,HI%jsc) ; aMax = aMin + do j=HI%jsc,HI%jec ; do I=IsB,HI%IecB + aMin = min(aMin, array(I,j)) + aMax = max(aMax, array(I,j)) + enddo ; enddo + ! This line deliberately uses the h-point computational domain. + aMean = reproducing_sum(array(HI%isc:HI%iec,HI%jsc:HI%jec)) + n = (1 + HI%jec - HI%jsc) * (1 + HI%iec - HI%isc) + call sum_across_PEs(n) + call min_across_PEs(aMin) + call max_across_PEs(aMax) + aMean = aMean / real(n) + end subroutine subStats + +end subroutine chksum_u_2d + +!> Checksums a 2d array staggered at C-grid v points. +subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & + scale, logunit) + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%isd:,HI_m%JsdB:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:) :: rescaled_array ! The array with scaling undone [a] + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] + integer :: iounit !< Log IO unit + integer :: i, j, Js + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] + integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift + integer :: bcN, bcS, bcE, bcW + logical :: do_corners, sym, sym_stats + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + if (modulo(turns, 2) /= 0) then + ! Arrays originating from u-points must be handled by uchksum + allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed)) + call rotate_array(array_m, -turns, array) + call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + return + else + allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB)) + call rotate_array(array_m, -turns, array) + endif + else + HI => HI_m + array => array_m + endif + + if (checkForNaNs) then + if (is_NaN(array(HI%isc:HI%iec,HI%JscB:HI%JecB))) & + call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) +! if (is_NaN(array)) & +! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) + endif + + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit ; if (present(logunit)) iounit = logunit + sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric + if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif + + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2)), source=0.0 ) + Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 + do J=Js,HI%JecB ; do i=HI%isc,HI%iec + rescaled_array(i,J) = scale*array(i,J) + enddo ; enddo + call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, sym_stats, aMean, aMin, aMax) + endif + + if (is_root_pe()) & + call chk_sum_msg("v-point:", aMean, aMin, aMax, mesg, iounit) + endif + + if (.not.writeChksums) return + + hshift = default_shift + if (present(haloshift)) hshift = haloshift + if (hshift<0) hshift = HI%ied-HI%iec + + if ( HI%isc-hshiftHI%ied .or. & + HI%jscB-hshiftHI%jedB ) then + write(0,*) 'chksum_v_2d: haloshift =',hshift + write(0,*) 'chksum_v_2d: isd,isc,iec,ied=',HI%isd,HI%isc,HI%iec,HI%ied + write(0,*) 'chksum_v_2d: jsd,jsc,jec,jed=',HI%jsdB,HI%jscB,HI%jecB,HI%jedB + call chksum_error(FATAL,'Error in chksum_v_2d '//trim(mesg)) + endif + + bc0 = subchk(array, HI, 0, 0, scaling) + + sym = .false. ; if (present(symmetric)) sym = symmetric + + if ((hshift==0) .and. .not.sym) then + if (is_root_pe()) call chk_sum_msg("v-point:", bc0, mesg, iounit) + return + endif + + do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + + if (hshift==0) then + bcS = subchk(array, HI, 0, -hshift-1, scaling) + if (is_root_pe()) call chk_sum_msg_S("v-point:", bc0, bcS, mesg, iounit) + elseif (do_corners) then + if (sym) then + bcSW = subchk(array, HI, -hshift, -hshift-1, scaling) + bcSE = subchk(array, HI, hshift, -hshift-1, scaling) + else + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcSE = subchk(array, HI, hshift, -hshift, scaling) + endif + bcNW = subchk(array, HI, -hshift, hshift, scaling) + bcNE = subchk(array, HI, hshift, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg("v-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) + else + if (sym) then + bcS = subchk(array, HI, 0, -hshift-1, scaling) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + endif + bcE = subchk(array, HI, hshift, 0, scaling) + bcW = subchk(array, HI, -hshift, 0, scaling) + bcN = subchk(array, HI, 0, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg_NSEW("v-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + endif + + contains + + integer function subchk(array, HI, di, dj, scale) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer :: i, j, bc + subchk = 0 + ! This line deliberately uses the h-point computational domain. + do J=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di + bc = bitcount(abs(scale*array(i,J))) + subchk = subchk + bc + enddo ; enddo + call sum_across_PEs(subchk) + subchk=mod(subchk, bc_modulus) + end function subchk + + subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed [a] + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] + + integer :: i, j, n, JsB + + JsB = HI%jsc ; if (sym_stats) JsB = HI%jsc-1 + + aMin = array(HI%isc,HI%jsc) ; aMax = aMin + do J=JsB,HI%JecB ; do i=HI%isc,HI%iec + aMin = min(aMin, array(i,J)) + aMax = max(aMax, array(i,J)) + enddo ; enddo + ! This line deliberately uses the h-computational domain. + aMean = reproducing_sum(array(HI%isc:HI%iec,HI%jsc:HI%jec)) + n = (1 + HI%jec - HI%jsc) * (1 + HI%iec - HI%isc) + call sum_across_PEs(n) + call min_across_PEs(aMin) + call max_across_PEs(aMax) + aMean = aMean / real(n) + end subroutine subStats + +end subroutine chksum_v_2d + +!> Checksums a 3d array staggered at tracer points. +subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit) + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%isd:,HI_m%jsd:,:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:,:) :: rescaled_array ! The array with scaling undone [a] + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] + integer :: iounit !< Log IO unit + integer :: i, j, k + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] + integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift + integer :: bcN, bcS, bcE, bcW + logical :: do_corners + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + allocate(array(HI%isd:HI%ied, HI%jsd:HI%jed, size(array_m, 3))) + call rotate_array(array_m, -turns, array) + else + HI => HI_m + array => array_m + endif + + if (checkForNaNs) then + if (is_NaN(array(HI%isc:HI%iec,HI%jsc:HI%jec,:))) & + call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) +! if (is_NaN(array)) & +! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) + endif + + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit ; if (present(logunit)) iounit = logunit + + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2), & + LBOUND(array,3):UBOUND(array,3)), source=0.0 ) + do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + rescaled_array(i,j,k) = scale*array(i,j,k) + enddo ; enddo ; enddo + + call subStats(HI, rescaled_array, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, aMean, aMin, aMax) + endif + + if (is_root_pe()) & + call chk_sum_msg("h-point:", aMean, aMin, aMax, mesg, iounit) + endif + + if (.not.writeChksums) return + + hshift = default_shift + if (present(haloshift)) hshift = haloshift + if (hshift<0) hshift = HI%ied-HI%iec + + if ( HI%isc-hshiftHI%ied .or. & + HI%jsc-hshiftHI%jed ) then + write(0,*) 'chksum_h_3d: haloshift =',hshift + write(0,*) 'chksum_h_3d: isd,isc,iec,ied=',HI%isd,HI%isc,HI%iec,HI%ied + write(0,*) 'chksum_h_3d: jsd,jsc,jec,jed=',HI%jsd,HI%jsc,HI%jec,HI%jed + call chksum_error(FATAL,'Error in chksum_h_3d '//trim(mesg)) + endif + + bc0 = subchk(array, HI, 0, 0, scaling) + + if (hshift==0) then + if (is_root_pe()) call chk_sum_msg("h-point:", bc0, mesg, iounit) + return + endif + + do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + + if (do_corners) then + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcSE = subchk(array, HI, hshift, -hshift, scaling) + bcNW = subchk(array, HI, -hshift, hshift, scaling) + bcNE = subchk(array, HI, hshift, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg("h-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + bcE = subchk(array, HI, hshift, 0, scaling) + bcW = subchk(array, HI, -hshift, 0, scaling) + bcN = subchk(array, HI, 0, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg_NSEW("h-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + endif + + contains + + integer function subchk(array, HI, di, dj, scale) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer :: i, j, k, bc + subchk = 0 + do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di + bc = bitcount(abs(scale*array(i,j,k))) + subchk = subchk + bc + enddo ; enddo ; enddo + call sum_across_PEs(subchk) + subchk=mod(subchk, bc_modulus) + end function subchk + + subroutine subStats(HI, array, aMean, aMin, aMax) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed [a] + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] + + integer :: i, j, k, n + + aMin = array(HI%isc,HI%jsc,1) + aMax = array(HI%isc,HI%jsc,1) + n = 0 + do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + aMin = min(aMin, array(i,j,k)) + aMax = max(aMax, array(i,j,k)) + n = n + 1 + enddo ; enddo ; enddo + aMean = reproducing_sum(array(HI%isc:HI%iec,HI%jsc:HI%jec,:)) + call sum_across_PEs(n) + call min_across_PEs(aMin) + call max_across_PEs(aMax) + aMean = aMean / real(n) + end subroutine subStats + +end subroutine chksum_h_3d + +!> Checksums a 3d array staggered at corner points. +subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & + scale, logunit) + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%IsdB:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:,:) :: rescaled_array ! The array with scaling undone [a] + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] + integer :: iounit !< Log IO unit + integer :: i, j, k, Is, Js + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] + integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift + integer :: bcN, bcS, bcE, bcW + logical :: do_corners, sym, sym_stats + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + allocate(array(HI%IsdB:HI%IedB, HI%JsdB:HI%JedB, size(array_m, 3))) + call rotate_array(array_m, -turns, array) + else + HI => HI_m + array => array_m + endif + + if (checkForNaNs) then + if (is_NaN(array(HI%IscB:HI%IecB,HI%JscB:HI%JecB,:))) & + call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) +! if (is_NaN(array)) & +! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) + endif + + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit ; if (present(logunit)) iounit = logunit + sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric + if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif + + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2), & + LBOUND(array,3):UBOUND(array,3)), source=0.0 ) + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 + do k=1,size(array,3) ; do J=Js,HI%JecB ; do I=Is,HI%IecB + rescaled_array(I,J,k) = scale*array(I,J,k) + enddo ; enddo ; enddo + call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, sym_stats, aMean, aMin, aMax) + endif + + if (is_root_pe()) & + call chk_sum_msg("B-point:", aMean, aMin, aMax, mesg, iounit) + endif + + if (.not.writeChksums) return + + hshift = default_shift + if (present(haloshift)) hshift = haloshift + if (hshift<0) hshift = HI%ied-HI%iec + + if ( HI%isc-hshiftHI%ied .or. & + HI%jsc-hshiftHI%jed ) then + write(0,*) 'chksum_B_3d: haloshift =',hshift + write(0,*) 'chksum_B_3d: isd,isc,iec,ied=',HI%isd,HI%isc,HI%iec,HI%ied + write(0,*) 'chksum_B_3d: jsd,jsc,jec,jed=',HI%jsd,HI%jsc,HI%jec,HI%jed + call chksum_error(FATAL,'Error in chksum_B_3d '//trim(mesg)) + endif + + bc0 = subchk(array, HI, 0, 0, scaling) + + sym = .false. ; if (present(symmetric)) sym = symmetric + + if ((hshift==0) .and. .not.sym) then + if (is_root_pe()) call chk_sum_msg("B-point:", bc0, mesg, iounit) + return + endif + + do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + + if (do_corners) then + if (sym) then + bcSW = subchk(array, HI, -hshift-1, -hshift-1, scaling) + bcSE = subchk(array, HI, hshift, -hshift-1, scaling) + bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + else + bcSW = subchk(array, HI, -hshift-1, -hshift-1, scaling) + bcSE = subchk(array, HI, hshift, -hshift-1, scaling) + bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + endif + bcNE = subchk(array, HI, hshift, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg("B-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) + else + if (sym) then + bcS = subchk(array, HI, 0, -hshift-1, scaling) + bcW = subchk(array, HI, -hshift-1, 0, scaling) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + bcW = subchk(array, HI, -hshift, 0, scaling) + endif + bcE = subchk(array, HI, hshift, 0, scaling) + bcN = subchk(array, HI, 0, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg_NSEW("B-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + endif + + contains + + integer function subchk(array, HI, di, dj, scale) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer :: i, j, k, bc + subchk = 0 + ! This line deliberately uses the h-point computational domain. + do k=LBOUND(array,3),UBOUND(array,3) ; do J=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di + bc = bitcount(abs(scale*array(I,J,k))) + subchk = subchk + bc + enddo ; enddo ; enddo + call sum_across_PEs(subchk) + subchk=mod(subchk, bc_modulus) + end function subchk + + subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed [a] + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] + + integer :: i, j, k, n, IsB, JsB + + IsB = HI%isc ; if (sym_stats) IsB = HI%isc-1 + JsB = HI%jsc ; if (sym_stats) JsB = HI%jsc-1 + + aMin = array(HI%isc,HI%jsc,1) ; aMax = aMin + do k=LBOUND(array,3),UBOUND(array,3) ; do J=JsB,HI%JecB ; do I=IsB,HI%IecB + aMin = min(aMin, array(I,J,k)) + aMax = max(aMax, array(I,J,k)) + enddo ; enddo ; enddo + aMean = reproducing_sum(array(HI%isc:HI%iec,HI%jsc:HI%jec,:)) + n = (1 + HI%jec - HI%jsc) * (1 + HI%iec - HI%isc) * size(array,3) + call sum_across_PEs(n) + call min_across_PEs(aMin) + call max_across_PEs(aMax) + aMean = aMean / real(n) + end subroutine subStats + +end subroutine chksum_B_3d + +!> Checksums a 3d array staggered at C-grid u points. +subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & + scale, logunit) + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%isdB:,HI_m%Jsd:,:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:,:) :: rescaled_array ! The array with scaling undone [a] + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] + integer :: iounit !< Log IO unit + integer :: i, j, k, Is + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] + integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift + integer :: bcN, bcS, bcE, bcW + logical :: do_corners, sym, sym_stats + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + if (modulo(turns, 2) /= 0) then + ! Arrays originating from v-points must be handled by vchksum + allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB, size(array_m, 3))) + call rotate_array(array_m, -turns, array) + call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + return + else + allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed, size(array_m, 3))) + call rotate_array(array_m, -turns, array) + endif + else + HI => HI_m + array => array_m + endif + + if (checkForNaNs) then + if (is_NaN(array(HI%IscB:HI%IecB,HI%jsc:HI%jec,:))) & + call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) +! if (is_NaN(array)) & +! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) + endif + + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit ; if (present(logunit)) iounit = logunit + sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric + if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif + + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2), & + LBOUND(array,3):UBOUND(array,3)), source=0.0 ) + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do I=Is,HI%IecB + rescaled_array(I,j,k) = scale*array(I,j,k) + enddo ; enddo ; enddo + call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, sym_stats, aMean, aMin, aMax) + endif + if (is_root_pe()) & + call chk_sum_msg("u-point:", aMean, aMin, aMax, mesg, iounit) + endif + + if (.not.writeChksums) return + + hshift = default_shift + if (present(haloshift)) hshift = haloshift + if (hshift<0) hshift = HI%ied-HI%iec + + if ( HI%isc-hshiftHI%ied .or. & + HI%jsc-hshiftHI%jed ) then + write(0,*) 'chksum_u_3d: haloshift =',hshift + write(0,*) 'chksum_u_3d: isd,isc,iec,ied=',HI%isd,HI%isc,HI%iec,HI%ied + write(0,*) 'chksum_u_3d: jsd,jsc,jec,jed=',HI%jsd,HI%jsc,HI%jec,HI%jed + call chksum_error(FATAL,'Error in chksum_u_3d '//trim(mesg)) + endif + + bc0 = subchk(array, HI, 0, 0, scaling) + + sym = .false. ; if (present(symmetric)) sym = symmetric + + if ((hshift==0) .and. .not.sym) then + if (is_root_pe()) call chk_sum_msg("u-point:", bc0, mesg, iounit) + return + endif + + do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + + if (hshift==0) then + bcW = subchk(array, HI, -hshift-1, 0, scaling) + if (is_root_pe()) call chk_sum_msg_W("u-point:", bc0, bcW, mesg, iounit) + elseif (do_corners) then + if (sym) then + bcSW = subchk(array, HI, -hshift-1, -hshift, scaling) + bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + else + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcNW = subchk(array, HI, -hshift, hshift, scaling) + endif + bcSE = subchk(array, HI, hshift, -hshift, scaling) + bcNE = subchk(array, HI, hshift, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg("u-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + bcE = subchk(array, HI, hshift, 0, scaling) + if (sym) then + bcW = subchk(array, HI, -hshift-1, 0, scaling) + else + bcW = subchk(array, HI, -hshift, 0, scaling) + endif + bcN = subchk(array, HI, 0, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg_NSEW("u-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + endif + + contains + + integer function subchk(array, HI, di, dj, scale) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer :: i, j, k, bc + subchk = 0 + ! This line deliberately uses the h-point computational domain. + do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di + bc = bitcount(abs(scale*array(I,j,k))) + subchk = subchk + bc + enddo ; enddo ; enddo + call sum_across_PEs(subchk) + subchk=mod(subchk, bc_modulus) + end function subchk + + subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed [a] + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] + + integer :: i, j, k, n, IsB + + IsB = HI%isc ; if (sym_stats) IsB = HI%isc-1 + + aMin = array(HI%isc,HI%jsc,1) ; aMax = aMin + do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc,HI%jec ; do I=IsB,HI%IecB + aMin = min(aMin, array(I,j,k)) + aMax = max(aMax, array(I,j,k)) + enddo ; enddo ; enddo + ! This line deliberately uses the h-point computational domain. + aMean = reproducing_sum(array(HI%isc:HI%iec,HI%jsc:HI%jec,:)) + n = (1 + HI%jec - HI%jsc) * (1 + HI%iec - HI%isc) * size(array,3) + call sum_across_PEs(n) + call min_across_PEs(aMin) + call max_across_PEs(aMax) + aMean = aMean / real(n) + end subroutine subStats + +end subroutine chksum_u_3d + +!> Checksums a 3d array staggered at C-grid v points. +subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & + scale, logunit) + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%isd:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:,:) :: rescaled_array ! The array with scaling undone [a] + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] + integer :: iounit !< Log IO unit + integer :: i, j, k, Js + integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift + integer :: bcN, bcS, bcE, bcW + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] + logical :: do_corners, sym, sym_stats + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + if (modulo(turns, 2) /= 0) then + ! Arrays originating from u-points must be handled by uchksum + allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed, size(array_m, 3))) + call rotate_array(array_m, -turns, array) + call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + return + else + allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB, size(array_m, 3))) + call rotate_array(array_m, -turns, array) + endif + else + HI => HI_m + array => array_m + endif + + if (checkForNaNs) then + if (is_NaN(array(HI%isc:HI%iec,HI%JscB:HI%JecB,:))) & + call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) +! if (is_NaN(array)) & +! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) + endif + + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit ; if (present(logunit)) iounit = logunit + sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric + if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif + + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2), & + LBOUND(array,3):UBOUND(array,3)), source=0.0 ) + Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 + do k=1,size(array,3) ; do J=Js,HI%JecB ; do i=HI%isc,HI%iec + rescaled_array(i,J,k) = scale*array(i,J,k) + enddo ; enddo ; enddo + call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, sym_stats, aMean, aMin, aMax) + endif + if (is_root_pe()) & + call chk_sum_msg("v-point:", aMean, aMin, aMax, mesg, iounit) + endif + + if (.not.writeChksums) return + + hshift = default_shift + if (present(haloshift)) hshift = haloshift + if (hshift<0) hshift = HI%ied-HI%iec + + if ( HI%isc-hshiftHI%ied .or. & + HI%jsc-hshiftHI%jed ) then + write(0,*) 'chksum_v_3d: haloshift =',hshift + write(0,*) 'chksum_v_3d: isd,isc,iec,ied=',HI%isd,HI%isc,HI%iec,HI%ied + write(0,*) 'chksum_v_3d: jsd,jsc,jec,jed=',HI%jsd,HI%jsc,HI%jec,HI%jed + call chksum_error(FATAL,'Error in chksum_v_3d '//trim(mesg)) + endif + + bc0 = subchk(array, HI, 0, 0, scaling) + + sym = .false. ; if (present(symmetric)) sym = symmetric + + if ((hshift==0) .and. .not.sym) then + if (is_root_pe()) call chk_sum_msg("v-point:", bc0, mesg, iounit) + return + endif + + do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + + if (hshift==0) then + bcS = subchk(array, HI, 0, -hshift-1, scaling) + if (is_root_pe()) call chk_sum_msg_S("v-point:", bc0, bcS, mesg, iounit) + elseif (do_corners) then + if (sym) then + bcSW = subchk(array, HI, -hshift, -hshift-1, scaling) + bcSE = subchk(array, HI, hshift, -hshift-1, scaling) + else + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcSE = subchk(array, HI, hshift, -hshift, scaling) + endif + bcNW = subchk(array, HI, -hshift, hshift, scaling) + bcNE = subchk(array, HI, hshift, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg("v-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) + else + if (sym) then + bcS = subchk(array, HI, 0, -hshift-1, scaling) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + endif + bcE = subchk(array, HI, hshift, 0, scaling) + bcW = subchk(array, HI, -hshift, 0, scaling) + bcN = subchk(array, HI, 0, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg_NSEW("v-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + endif + + contains + + integer function subchk(array, HI, di, dj, scale) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer :: i, j, k, bc + subchk = 0 + ! This line deliberately uses the h-point computational domain. + do k=LBOUND(array,3),UBOUND(array,3) ; do J=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di + bc = bitcount(abs(scale*array(i,J,k))) + subchk = subchk + bc + enddo ; enddo ; enddo + call sum_across_PEs(subchk) + subchk=mod(subchk, bc_modulus) + end function subchk + + !subroutine subStats(HI, array, mesg, sym_stats) + subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed [a] + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. + real, intent(out) :: aMean !< Mean of array over domain [a] + real, intent(out) :: aMin !< Minimum of array over domain [a] + real, intent(out) :: aMax !< Maximum of array over domain [a] + + integer :: i, j, k, n, JsB + + JsB = HI%jsc ; if (sym_stats) JsB = HI%jsc-1 + + aMin = array(HI%isc,HI%jsc,1) ; aMax = aMin + do k=LBOUND(array,3),UBOUND(array,3) ; do J=JsB,HI%JecB ; do i=HI%isc,HI%iec + aMin = min(aMin, array(i,J,k)) + aMax = max(aMax, array(i,J,k)) + enddo ; enddo ; enddo + ! This line deliberately uses the h-point computational domain. + aMean = reproducing_sum(array(HI%isc:HI%iec,HI%jsc:HI%jec,:)) + n = (1 + HI%jec - HI%jsc) * (1 + HI%iec - HI%isc) * size(array,3) + call sum_across_PEs(n) + call min_across_PEs(aMin) + call max_across_PEs(aMax) + aMean = aMean / real(n) + end subroutine subStats + +end subroutine chksum_v_3d + +! These are the older version of chksum that do not take the grid staggering +! into account. + +!> chksum1d does a checksum of a 1-dimensional array. +subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs) + real, dimension(:), intent(in) :: array !< The array to be summed (index starts at 1) [abitrary]. + character(len=*), intent(in) :: mesg !< An identifying message. + integer, optional, intent(in) :: start_i !< The starting index for the sum (default 1) + integer, optional, intent(in) :: end_i !< The ending index for the sum (default all) + logical, optional, intent(in) :: compare_PEs !< If true, compare across PEs instead of summing + !! and list the root_PE value (default true) + + integer :: is, ie, i, bc, sum1, sum_bc + real :: sum ! The global sum of the array [arbitrary] + real, allocatable :: sum_here(:) ! The sum on each PE [arbitrary] + logical :: compare + integer :: pe_num ! pe number of the data + integer :: nPEs ! Total number of processsors + + is = LBOUND(array,1) ; ie = UBOUND(array,1) + if (present(start_i)) is = start_i + if (present(end_i)) ie = end_i + compare = .true. ; if (present(compare_PEs)) compare = compare_PEs + + sum = 0.0 ; sum_bc = 0 + do i=is,ie + sum = sum + array(i) + bc = bitcount(ABS(array(i))) + sum_bc = sum_bc + bc + enddo + + pe_num = pe_here() + 1 - root_pe() ; nPEs = num_pes() + allocate(sum_here(nPEs), source=0.0) ; sum_here(pe_num) = sum + call sum_across_PEs(sum_here,nPEs) + + sum1 = sum_bc + call sum_across_PEs(sum1) + + if (.not.compare) then + sum = 0.0 + do i=1,nPEs ; sum = sum + sum_here(i) ; enddo + sum_bc = sum1 + elseif (is_root_pe()) then + if (sum1 /= nPEs*sum_bc) & + write(0, '(A40," bitcounts do not match across PEs: ",I12,1X,I12)') & + mesg, sum1, nPEs*sum_bc + do i=1,nPEs ; if (sum /= sum_here(i)) then + write(0, '(A40," PE ",i4," sum mismatches root_PE: ",3(ES22.13,1X))') & + mesg, i, sum_here(i), sum, sum_here(i)-sum + endif ; enddo + endif + deallocate(sum_here) + + if (is_root_pe()) & + write(0,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum_bc + +end subroutine chksum1d + +! These are the older version of chksum that do not take the grid staggering +! into account. + +!> chksum2d does a checksum of all data in a 2-d array. +subroutine chksum2d(array, mesg) + + real, dimension(:,:), intent(in) :: array !< The array to be checksummed [arbitrary] + character(len=*), intent(in) :: mesg !< An identifying message + + integer :: xs,xe,ys,ye,i,j,sum1,bc + real :: sum ! The global sum of the array [arbitrary] + + xs = LBOUND(array,1) ; xe = UBOUND(array,1) + ys = LBOUND(array,2) ; ye = UBOUND(array,2) + + sum = 0.0 ; sum1 = 0 + do i=xs,xe ; do j=ys,ye + bc = bitcount(abs(array(i,j))) + sum1 = sum1 + bc + enddo ; enddo + call sum_across_PEs(sum1) + + sum = reproducing_sum(array(:,:)) + + if (is_root_pe()) & + write(0,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1 +! write(0,'(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') & +! mesg, sum, sum1, sum, sum1 + +end subroutine chksum2d + +!> chksum3d does a checksum of all data in a 2-d array. +subroutine chksum3d(array, mesg) + + real, dimension(:,:,:), intent(in) :: array !< The array to be checksummed [arbitrary] + character(len=*), intent(in) :: mesg !< An identifying message + + integer :: xs,xe,ys,ye,zs,ze,i,j,k, bc,sum1 + real :: sum ! The global sum of the array [arbitrary] + + xs = LBOUND(array,1) ; xe = UBOUND(array,1) + ys = LBOUND(array,2) ; ye = UBOUND(array,2) + zs = LBOUND(array,3) ; ze = UBOUND(array,3) + + sum = 0.0 ; sum1 = 0 + do i=xs,xe ; do j=ys,ye ; do k=zs,ze + bc = bitcount(ABS(array(i,j,k))) + sum1 = sum1 + bc + enddo ; enddo ; enddo + + call sum_across_PEs(sum1) + sum = reproducing_sum(array(:,:,:)) + + if (is_root_pe()) & + write(0,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1 +! write(0,'(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') & +! mesg, sum, sum1, sum, sum1 + +end subroutine chksum3d + +!> This function returns .true. if x is a NaN, and .false. otherwise. +function is_NaN_0d(x) + real, intent(in) :: x !< The value to be checked for NaNs [arbitrary] + logical :: is_NaN_0d + + !is_NaN_0d = (((x < 0.0) .and. (x >= 0.0)) .or. & + ! (.not.(x < 0.0) .and. .not.(x >= 0.0))) + if (((x < 0.0) .and. (x >= 0.0)) .or. & + (.not.(x < 0.0) .and. .not.(x >= 0.0))) then + is_NaN_0d = .true. + else + is_NaN_0d = .false. + endif + +end function is_NaN_0d + +!> Returns .true. if any element of x is a NaN, and .false. otherwise. +function is_NaN_1d(x, skip_mpp) + real, dimension(:), intent(in) :: x !< The array to be checked for NaNs [arbitrary] + logical, optional, intent(in) :: skip_mpp !< If true, only check this array only + !! on the local PE (default false). + logical :: is_NaN_1d + + integer :: i, n + logical :: global_check + + n = 0 + do i = LBOUND(x,1), UBOUND(x,1) + if (is_NaN_0d(x(i))) n = n + 1 + enddo + global_check = .true. + if (present(skip_mpp)) global_check = .not.skip_mpp + + if (global_check) call sum_across_PEs(n) + is_NaN_1d = .false. + if (n>0) is_NaN_1d = .true. + +end function is_NaN_1d + +!> Returns .true. if any element of x is a NaN, and .false. otherwise. +function is_NaN_2d(x) + real, dimension(:,:), intent(in) :: x !< The array to be checked for NaNs [arbitrary] + logical :: is_NaN_2d + + integer :: i, j, n + + n = 0 + do j = LBOUND(x,2), UBOUND(x,2) ; do i = LBOUND(x,1), UBOUND(x,1) + if (is_NaN_0d(x(i,j))) n = n + 1 + enddo ; enddo + call sum_across_PEs(n) + is_NaN_2d = .false. + if (n>0) is_NaN_2d = .true. + +end function is_NaN_2d + +!> Returns .true. if any element of x is a NaN, and .false. otherwise. +function is_NaN_3d(x) + real, dimension(:,:,:), intent(in) :: x !< The array to be checked for NaNs [arbitrary] + logical :: is_NaN_3d + + integer :: i, j, k, n + + n = 0 + do k = LBOUND(x,3), UBOUND(x,3) + do j = LBOUND(x,2), UBOUND(x,2) ; do i = LBOUND(x,1), UBOUND(x,1) + if (is_NaN_0d(x(i,j,k))) n = n + 1 + enddo ; enddo + enddo + call sum_across_PEs(n) + is_NaN_3d = .false. + if (n>0) is_NaN_3d = .true. + +end function is_NaN_3d + +! The following set of routines do a checksum across the computational domain of +! a field, with the potential for rotation of this field and masking. + +!> Compute the field checksum of a scalar. +function rotated_field_chksum_real_0d(field, pelist, mask_val, turns) & + result(chksum) + real, intent(in) :: field !< Input scalar [arbitrary] + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] + integer, optional, intent(in) :: turns !< Number of quarter turns + integer(kind=int64) :: chksum !< checksum of scalar + + if (present(turns)) call MOM_error(FATAL, "Rotation not supported for 0d fields.") + + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) +end function rotated_field_chksum_real_0d + + +!> Compute the field checksum of a 1d field. +function rotated_field_chksum_real_1d(field, pelist, mask_val, turns) & + result(chksum) + real, dimension(:), intent(in) :: field !< Input array [arbitrary] + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] + integer, optional, intent(in) :: turns !< Number of quarter turns + integer(kind=int64) :: chksum !< checksum of array + + if (present(turns)) call MOM_error(FATAL, "Rotation not supported for 1d fields.") + + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) +end function rotated_field_chksum_real_1d + + +!> Compute the field checksum of a rotated 2d field. +function rotated_field_chksum_real_2d(field, pelist, mask_val, turns) & + result(chksum) + real, dimension(:,:), intent(in) :: field !< Unrotated input field [arbitrary] + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] + integer, optional, intent(in) :: turns !< Number of quarter turns + integer(kind=int64) :: chksum !< checksum of array + + ! Local variables + real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units [arbitrary] + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) + else + call allocate_rotated_array(field, [1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + chksum = field_chksum(field_rot, pelist=pelist, mask_val=mask_val) + deallocate(field_rot) + endif +end function rotated_field_chksum_real_2d + +!> Compute the field checksum of a rotated 3d field. +function rotated_field_chksum_real_3d(field, pelist, mask_val, turns) & + result(chksum) + real, dimension(:,:,:), intent(in) :: field !< Unrotated input field [arbitrary] + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] + integer, optional, intent(in) :: turns !< Number of quarter turns + integer(kind=int64) :: chksum !< checksum of array + + ! Local variables + real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units [arbitrary] + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) + else + call allocate_rotated_array(field, [1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + chksum = field_chksum(field_rot, pelist=pelist, mask_val=mask_val) + deallocate(field_rot) + endif +end function rotated_field_chksum_real_3d + +!> Compute the field checksum of a rotated 4d field. +function rotated_field_chksum_real_4d(field, pelist, mask_val, turns) & + result(chksum) + real, dimension(:,:,:,:), intent(in) :: field !< Unrotated input field [arbitrary] + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] + integer, optional, intent(in) :: turns !< Number of quarter turns + integer(kind=int64) :: chksum !< checksum of array + + ! Local variables + real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units [arbitrary] + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) + else + call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + chksum = field_chksum(field_rot, pelist=pelist, mask_val=mask_val) + deallocate(field_rot) + endif +end function rotated_field_chksum_real_4d + + +!> Write a message including the checksum of the non-shifted array +subroutine chk_sum_msg1(fmsg, bc0, mesg, iounit) + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) & + write(iounit, '(a,1(a,i10,1x),a)') fmsg, " c=", bc0, trim(mesg) +end subroutine chk_sum_msg1 + +!> Write a message including checksums of non-shifted and diagonally shifted arrays +subroutine chk_sum_msg5(fmsg, bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcSW !< The bitcount for SW shifted array + integer, intent(in) :: bcSE !< The bitcount for SE shifted array + integer, intent(in) :: bcNW !< The bitcount for NW shifted array + integer, intent(in) :: bcNE !< The bitcount for NE shifted array + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) write(iounit, '(A,5(A,I10,1X),A)') & + fmsg, " c=", bc0, "sw=", bcSW, "se=", bcSE, "nw=", bcNW, "ne=", bcNE, trim(mesg) +end subroutine chk_sum_msg5 + +!> Write a message including checksums of non-shifted and laterally shifted arrays +subroutine chk_sum_msg_NSEW(fmsg, bc0, bcN, bcS, bcE, bcW, mesg, iounit) + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcN !< The bitcount for N shifted array + integer, intent(in) :: bcS !< The bitcount for S shifted array + integer, intent(in) :: bcE !< The bitcount for E shifted array + integer, intent(in) :: bcW !< The bitcount for W shifted array + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) write(iounit, '(A,5(A,I10,1X),A)') & + fmsg, " c=", bc0, "N=", bcN, "S=", bcS, "E=", bcE, "W=", bcW, trim(mesg) +end subroutine chk_sum_msg_NSEW + +!> Write a message including checksums of non-shifted and southward shifted arrays +subroutine chk_sum_msg_S(fmsg, bc0, bcS, mesg, iounit) + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcS !< The bitcount of the south-shifted array + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) write(iounit, '(A,2(A,I10,1X),A)') & + fmsg, " c=", bc0, "S=", bcS, trim(mesg) +end subroutine chk_sum_msg_S + +!> Write a message including checksums of non-shifted and westward shifted arrays +subroutine chk_sum_msg_W(fmsg, bc0, bcW, mesg, iounit) + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcW !< The bitcount of the west-shifted array + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) write(iounit, '(A,2(A,I10,1X),A)') & + fmsg, " c=", bc0, "W=", bcW, trim(mesg) +end subroutine chk_sum_msg_W + +!> Write a message including checksums of non-shifted and southwestward shifted arrays +subroutine chk_sum_msg2(fmsg, bc0, bcSW, mesg, iounit) + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcSW !< The bitcount of the southwest-shifted array + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) write(iounit, '(A,2(A,I9,1X),A)') & + fmsg, " c=", bc0, "s/w=", bcSW, trim(mesg) +end subroutine chk_sum_msg2 + +!> Write a message including the global mean, maximum and minimum of an array +subroutine chk_sum_msg3(fmsg, aMean, aMin, aMax, mesg, iounit) + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + real, intent(in) :: aMean !< The mean value of the array [arbitrary] + real, intent(in) :: aMin !< The minimum value of the array [arbitrary] + real, intent(in) :: aMax !< The maximum value of the array [arbitrary] + integer, intent(in) :: iounit !< Checksum logger IO unit + + ! NOTE: We add zero to aMin and aMax to remove any negative zeros. + ! This is due to inconsistencies of signed zero in local vs MPI calculations. + + if (is_root_pe()) write(iounit, '(A,3(A,ES25.16,1X),A)') & + fmsg, " mean=", aMean, "min=", (0. + aMin), "max=", (0. + aMax), trim(mesg) +end subroutine chk_sum_msg3 + +!> MOM_checksums_init initializes the MOM_checksums module. As it happens, the +!! only thing that it does is to log the version of this module. +subroutine MOM_checksums_init(param_file) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_checksums" ! This module's name. + + call log_version(param_file, mdl, version) + +end subroutine MOM_checksums_init + +!> A wrapper for MOM_error used in the checksum code +subroutine chksum_error(signal, message) + ! Wrapper for MOM_error to help place specific break points in debuggers + integer, intent(in) :: signal !< An error severity level, such as FATAL or WARNING + character(len=*), intent(in) :: message !< An error message + call MOM_error(signal, message) +end subroutine chksum_error + +!> Does a bitcount of a number by first casting to an integer and then using BTEST +!! to check bit by bit +integer function bitcount(x) + real, intent(in) :: x !< Number to be bitcount [arbitrary] + + integer, parameter :: xk = kind(x) !< Kind type of x + + ! NOTE: Assumes that reals and integers of kind=xk are the same size + bitcount = popcnt(transfer(x, 1_xk)) +end function bitcount + +end module MOM_checksums diff --git a/framework/MOM_coms.F90 b/framework/MOM_coms.F90 new file mode 100644 index 0000000000..38ad55fd96 --- /dev/null +++ b/framework/MOM_coms.F90 @@ -0,0 +1,884 @@ +!> Interfaces to non-domain-oriented communication subroutines, including the +!! MOM6 reproducing sums facility +module MOM_coms + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms_infra, only : PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist +use MOM_coms_infra, only : broadcast, field_chksum, MOM_infra_init, MOM_infra_end +use MOM_coms_infra, only : sum_across_PEs, max_across_PEs, min_across_PEs +use MOM_coms_infra, only : all_across_PEs, any_across_PEs +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING +use MOM_coms_infra, only : sync_PEs + +implicit none ; private + +public :: PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end +public :: sync_PEs +public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs, field_chksum +public :: all_across_PEs, any_across_PEs +public :: set_PElist, Get_PElist, Set_rootPE +public :: reproducing_sum, reproducing_sum_EFP, EFP_sum_across_PEs, EFP_list_sum_across_PEs +public :: EFP_plus, EFP_minus, EFP_to_real, real_to_EFP, EFP_real_diff +public :: operator(+), operator(-), assignment(=) +public :: query_EFP_overflow_error, reset_EFP_overflow_error + +! This module provides interfaces to the non-domain-oriented communication subroutines. + +integer(kind=8), parameter :: prec=2_8**46 !< The precision of each integer. +real, parameter :: r_prec=2.0**46 !< A real version of prec. +real, parameter :: I_prec=1.0/(2.0**46) !< The inverse of prec. +integer, parameter :: max_count_prec=2**(63-46)-1 + !< The number of values that can be added together + !! with the current value of prec before there will + !! be roundoff problems. + +integer, parameter :: ni=6 !< The number of long integers to use to represent + !< a real number. +real, parameter, dimension(ni) :: & + pr = (/ r_prec**2, r_prec, 1.0, 1.0/r_prec, 1.0/r_prec**2, 1.0/r_prec**3 /) + !< An array of the real precision of each of the integers +real, parameter, dimension(ni) :: & + I_pr = (/ 1.0/r_prec**2, 1.0/r_prec, 1.0, r_prec, r_prec**2, r_prec**3 /) + !< An array of the inverse of the real precision of each of the integers +real, parameter :: max_efp_float = pr(1) * (2.**63 - 1.) + !< The largest float with an EFP representation. + !! NOTE: Only the first bin can exceed precision, + !! but is bounded by the largest signed integer. + +logical :: overflow_error = .false. !< This becomes true if an overflow is encountered. +logical :: NaN_error = .false. !< This becomes true if a NaN is encountered. +logical :: debug = .false. !< Making this true enables debugging output. + +!> Find an accurate and order-invariant sum of a distributed 2d or 3d field +interface reproducing_sum + module procedure reproducing_sum_2d, reproducing_sum_3d +end interface reproducing_sum + +!> Find an accurate and order-invariant sum of a distributed 2d field, returning the result +!! in the form of an extended fixed point value that can be converted back with EFP_to_real. +interface reproducing_sum_EFP + module procedure reproducing_EFP_sum_2d +end interface reproducing_sum_EFP + +!> Sum a value or 1-d array of values across processors, returning the sums in place +interface EFP_sum_across_PEs + module procedure EFP_list_sum_across_PEs, EFP_val_sum_across_PEs +end interface EFP_sum_across_PEs + +!> The Extended Fixed Point (EFP) type provides a public interface for doing sums +!! and taking differences with this type. +!! +!! The use of this type is documented in +!! Hallberg, R. & A. Adcroft, 2014: An Order-invariant Real-to-Integer Conversion Sum. +!! Parallel Computing, 40(5-6), doi:10.1016/j.parco.2014.04.007. +type, public :: EFP_type ; private + integer(kind=8), dimension(ni) :: v !< The value in this type +end type EFP_type + +!> Add two extended-fixed-point numbers +interface operator (+) ; module procedure EFP_plus ; end interface +!> Subtract one extended-fixed-point number from another +interface operator (-) ; module procedure EFP_minus ; end interface +!> Copy the value of one extended-fixed-point number into another +interface assignment(=); module procedure EFP_assign ; end interface + +contains + +!> This subroutine uses a conversion to an integer representation of real numbers to give an +!! order-invariant sum of distributed 2-D arrays that reproduces across domain decomposition, with +!! the result returned as an extended fixed point type that can be converted back to a real number +!! using EFP_to_real. This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, +!! doi:10.1016/j.parco.2014.04.007. +function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, only_on_PE) result(EFP_sum) + real, dimension(:,:), intent(in) :: array !< The array to be summed + integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jsr !< The starting j-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting + !! that the array indices starts at 1 + logical, optional, intent(in) :: overflow_check !< If present and false, disable + !! checking for overflows in incremental results. + !! This can speed up calculations if the number + !! of values being summed is small enough + integer, optional, intent(out) :: err !< If present, return an error code instead of + !! triggering any fatal errors directly from + !! this routine. + logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum + !! across processors, only reporting the local sum + type(EFP_type) :: EFP_sum !< The result in extended fixed point format + + ! This subroutine uses a conversion to an integer representation + ! of real numbers to give order-invariant sums that will reproduce + ! across PE count. This idea comes from R. Hallberg and A. Adcroft. + + integer(kind=8), dimension(ni) :: ints_sum + integer(kind=8) :: ival, prec_error + real :: rs + real :: max_mag_term + logical :: over_check, do_sum_across_PEs + character(len=256) :: mesg + integer :: i, j, n, is, ie, js, je, sgn + + if (num_PEs() > max_count_prec) call MOM_error(FATAL, & + "reproducing_sum: Too many processors are being used for the value of "//& + "prec. Reduce prec to (2^63-1)/num_PEs.") + + prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + + is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2 ) + if (present(isr)) then + if (isr < is) call MOM_error(FATAL, "Value of isr too small in reproducing_EFP_sum_2d.") + is = isr + endif + if (present(ier)) then + if (ier > ie) call MOM_error(FATAL, "Value of ier too large in reproducing_EFP_sum_2d.") + ie = ier + endif + if (present(jsr)) then + if (jsr < js) call MOM_error(FATAL, "Value of jsr too small in reproducing_EFP_sum_2d.") + js = jsr + endif + if (present(jer)) then + if (jer > je) call MOM_error(FATAL, "Value of jer too large in reproducing_EFP_sum_2d.") + je = jer + endif + + over_check = .true. ; if (present(overflow_check)) over_check = overflow_check + do_sum_across_PEs = .true. ; if (present(only_on_PE)) do_sum_across_PEs = .not.only_on_PE + + overflow_error = .false. ; NaN_error = .false. ; max_mag_term = 0.0 + ints_sum(:) = 0 + if (over_check) then + if ((je+1-js)*(ie+1-is) < max_count_prec) then + do j=js,je ; do i=is,ie + call increment_ints_faster(ints_sum, array(i,j), max_mag_term) + enddo ; enddo + call carry_overflow(ints_sum, prec_error) + elseif ((ie+1-is) < max_count_prec) then + do j=js,je + do i=is,ie + call increment_ints_faster(ints_sum, array(i,j), max_mag_term) + enddo + call carry_overflow(ints_sum, prec_error) + enddo + else + do j=js,je ; do i=is,ie + call increment_ints(ints_sum, real_to_ints(array(i,j), prec_error), & + prec_error) + enddo ; enddo + endif + else + do j=js,je ; do i=is,ie + sgn = 1 ; if (array(i,j)<0.0) sgn = -1 + rs = abs(array(i,j)) + do n=1,ni + ival = int(rs*I_pr(n), 8) + rs = rs - ival*pr(n) + ints_sum(n) = ints_sum(n) + sgn*ival + enddo + enddo ; enddo + call carry_overflow(ints_sum, prec_error) + endif + + if (present(err)) then + err = 0 + if (overflow_error) & + err = err+2 + if (NaN_error) & + err = err+4 + if (err > 0) then ; do n=1,ni ; ints_sum(n) = 0 ; enddo ; endif + else + if (NaN_error) then + call MOM_error(FATAL, "NaN in input field of reproducing_EFP_sum(_2d).") + endif + if (abs(max_mag_term) >= prec_error*pr(1)) then + write(mesg, '(ES13.5)') max_mag_term + call MOM_error(FATAL,"Overflow in reproducing_EFP_sum(_2d) conversion of "//trim(mesg)) + endif + if (overflow_error) then + call MOM_error(FATAL, "Overflow in reproducing_EFP_sum(_2d).") + endif + endif + + if (do_sum_across_PEs) call sum_across_PEs(ints_sum, ni) + + call regularize_ints(ints_sum) + + EFP_sum%v(:) = ints_sum(:) + +end function reproducing_EFP_sum_2d + +!> This subroutine uses a conversion to an integer representation of real numbers to give an +!! order-invariant sum of distributed 2-D arrays that reproduces across domain decomposition. +!! This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, +!! doi:10.1016/j.parco.2014.04.007. +function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & + overflow_check, err, only_on_PE) result(sum) + real, dimension(:,:), intent(in) :: array !< The array to be summed + integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jsr !< The starting j-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting + !! that the array indices starts at 1 + type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format + logical, optional, intent(in) :: reproducing !< If present and false, do the sum + !! using the naive non-reproducing approach + logical, optional, intent(in) :: overflow_check !< If present and false, disable + !! checking for overflows in incremental results. + !! This can speed up calculations if the number + !! of values being summed is small enough + integer, optional, intent(out) :: err !< If present, return an error code instead of + !! triggering any fatal errors directly from + !! this routine. + logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum + !! across processors, only reporting the local sum + real :: sum !< Result + + ! This subroutine uses a conversion to an integer representation + ! of real numbers to give order-invariant sums that will reproduce + ! across PE count. This idea comes from R. Hallberg and A. Adcroft. + + integer(kind=8), dimension(ni) :: ints_sum + integer(kind=8) :: prec_error + real :: rsum(1) + logical :: repro, do_sum_across_PEs + character(len=256) :: mesg + type(EFP_type) :: EFP_val ! An extended fixed point version of the sum + integer :: i, j, is, ie, js, je + + if (num_PEs() > max_count_prec) call MOM_error(FATAL, & + "reproducing_sum: Too many processors are being used for the value of "//& + "prec. Reduce prec to (2^63-1)/num_PEs.") + + prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + + is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2 ) + if (present(isr)) then + if (isr < is) call MOM_error(FATAL, "Value of isr too small in reproducing_sum_2d.") + is = isr + endif + if (present(ier)) then + if (ier > ie) call MOM_error(FATAL, "Value of ier too large in reproducing_sum_2d.") + ie = ier + endif + if (present(jsr)) then + if (jsr < js) call MOM_error(FATAL, "Value of jsr too small in reproducing_sum_2d.") + js = jsr + endif + if (present(jer)) then + if (jer > je) call MOM_error(FATAL, "Value of jer too large in reproducing_sum_2d.") + je = jer + endif + + repro = .true. ; if (present(reproducing)) repro = reproducing + do_sum_across_PEs = .true. ; if (present(only_on_PE)) do_sum_across_PEs = .not.only_on_PE + + if (repro) then + EFP_val = reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, only_on_PE) + sum = ints_to_real(EFP_val%v) + if (present(EFP_sum)) EFP_sum = EFP_val + if (debug) ints_sum(:) = EFP_sum%v(:) + else + rsum(1) = 0.0 + do j=js,je ; do i=is,ie + rsum(1) = rsum(1) + array(i,j) + enddo ; enddo + if (do_sum_across_PEs) call sum_across_PEs(rsum,1) + sum = rsum(1) + + if (present(err)) then ; err = 0 ; endif + + if (debug .or. present(EFP_sum)) then + overflow_error = .false. + ints_sum = real_to_ints(sum, prec_error, overflow_error) + if (overflow_error) then + if (present(err)) then + err = err + 2 + else + write(mesg, '(ES13.5)') sum + call MOM_error(FATAL,"Repro_sum_2d: Overflow in real_to_ints conversion of "//trim(mesg)) + endif + endif + endif + if (present(EFP_sum)) EFP_sum%v(:) = ints_sum(:) + endif + + if (debug) then + write(mesg,'("2d RS: ", ES24.16, 6 Z17.16)') sum, ints_sum(1:ni) + call MOM_mesg(mesg, 3) + endif + +end function reproducing_sum_2d + +!> This subroutine uses a conversion to an integer representation of real numbers to give an +!! order-invariant sum of distributed 3-D arrays that reproduces across domain decomposition. +!! This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, +!! doi:10.1016/j.parco.2014.04.007. +function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_sums, err, only_on_PE) & + result(sum) + real, dimension(:,:,:), intent(in) :: array !< The array to be summed + integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jsr !< The starting j-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting + !! that the array indices starts at 1 + real, dimension(:), optional, intent(out) :: sums !< The sums by vertical layer + type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format + type(EFP_type), dimension(:), & + optional, intent(out) :: EFP_lay_sums !< The sums by vertical layer in EFP format + integer, optional, intent(out) :: err !< If present, return an error code instead of + !! triggering any fatal errors directly from + !! this routine. + logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum + !! across processors, only reporting the local sum + real :: sum !< Result + + ! This subroutine uses a conversion to an integer representation + ! of real numbers to give order-invariant sums that will reproduce + ! across PE count. This idea comes from R. Hallberg and A. Adcroft. + + real :: val, max_mag_term + integer(kind=8), dimension(ni) :: ints_sum + integer(kind=8), dimension(ni,size(array,3)) :: ints_sums + integer(kind=8) :: prec_error + character(len=256) :: mesg + logical :: do_sum_across_PEs + integer :: i, j, k, is, ie, js, je, ke, isz, jsz, n + + if (num_PEs() > max_count_prec) call MOM_error(FATAL, & + "reproducing_sum: Too many processors are being used for the value of "//& + "prec. Reduce prec to (2^63-1)/num_PEs.") + + prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + max_mag_term = 0.0 + + is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2) ; ke = size(array,3) + if (present(isr)) then + if (isr < is) call MOM_error(FATAL, "Value of isr too small in reproducing_sum(_3d).") + is = isr + endif + if (present(ier)) then + if (ier > ie) call MOM_error(FATAL, "Value of ier too large in reproducing_sum(_3d).") + ie = ier + endif + if (present(jsr)) then + if (jsr < js) call MOM_error(FATAL, "Value of jsr too small in reproducing_sum(_3d).") + js = jsr + endif + if (present(jer)) then + if (jer > je) call MOM_error(FATAL, "Value of jer too large in reproducing_sum(_3d).") + je = jer + endif + jsz = je+1-js; isz = ie+1-is + + do_sum_across_PEs = .true. ; if (present(only_on_PE)) do_sum_across_PEs = .not.only_on_PE + + if (present(sums) .or. present(EFP_lay_sums)) then + if (present(sums)) then ; if (size(sums) < ke) then + call MOM_error(FATAL, "Sums is smaller than the vertical extent of array in reproducing_sum(_3d).") + endif ; endif + if (present(EFP_lay_sums)) then ; if (size(EFP_lay_sums) < ke) then + call MOM_error(FATAL, "Sums is smaller than the vertical extent of array in reproducing_sum(_3d).") + endif ; endif + ints_sums(:,:) = 0 + overflow_error = .false. ; NaN_error = .false. ; max_mag_term = 0.0 + if (jsz*isz < max_count_prec) then + do k=1,ke + do j=js,je ; do i=is,ie + call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term) + enddo ; enddo + call carry_overflow(ints_sums(:,k), prec_error) + enddo + elseif (isz < max_count_prec) then + do k=1,ke ; do j=js,je + do i=is,ie + call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term) + enddo + call carry_overflow(ints_sums(:,k), prec_error) + enddo ; enddo + else + do k=1,ke ; do j=js,je ; do i=is,ie + call increment_ints(ints_sums(:,k), & + real_to_ints(array(i,j,k), prec_error), prec_error) + enddo ; enddo ; enddo + endif + if (present(err)) then + err = 0 + if (abs(max_mag_term) >= prec_error*pr(1)) err = err+1 + if (overflow_error) err = err+2 + if (NaN_error) err = err+2 + if (err > 0) then ; do k=1,ke ; do n=1,ni ; ints_sums(n,k) = 0 ; enddo ; enddo ; endif + else + if (NaN_error) call MOM_error(FATAL, "NaN in input field of reproducing_sum(_3d).") + if (abs(max_mag_term) >= prec_error*pr(1)) then + write(mesg, '(ES13.5)') max_mag_term + call MOM_error(FATAL,"Overflow in reproducing_sum(_3d) conversion of "//trim(mesg)) + endif + if (overflow_error) call MOM_error(FATAL, "Overflow in reproducing_sum(_3d).") + endif + + if (do_sum_across_PEs) call sum_across_PEs(ints_sums(:,1:ke), ni*ke) + + sum = 0.0 + do k=1,ke + call regularize_ints(ints_sums(:,k)) + val = ints_to_real(ints_sums(:,k)) + if (present(sums)) sums(k) = val + sum = sum + val + enddo + if (present(EFP_lay_sums)) then ; do k=1,ke + EFP_lay_sums(k)%v(:) = ints_sums(:,k) + enddo ; endif + + if (present(EFP_sum)) then + EFP_sum%v(:) = 0 + do k=1,ke ; call increment_ints(EFP_sum%v(:), ints_sums(:,k)) ; enddo + endif + + if (debug) then + do n=1,ni ; ints_sum(n) = 0 ; enddo + do k=1,ke ; do n=1,ni ; ints_sum(n) = ints_sum(n) + ints_sums(n,k) ; enddo ; enddo + write(mesg,'("3D RS: ", ES24.16, 6 Z17.16)') sum, ints_sum(1:ni) + call MOM_mesg(mesg, 3) + endif + else + ints_sum(:) = 0 + overflow_error = .false. ; NaN_error = .false. ; max_mag_term = 0.0 + if (jsz*isz < max_count_prec) then + do k=1,ke + do j=js,je ; do i=is,ie + call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term) + enddo ; enddo + call carry_overflow(ints_sum, prec_error) + enddo + elseif (isz < max_count_prec) then + do k=1,ke ; do j=js,je + do i=is,ie + call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term) + enddo + call carry_overflow(ints_sum, prec_error) + enddo ; enddo + else + do k=1,ke ; do j=js,je ; do i=is,ie + call increment_ints(ints_sum, real_to_ints(array(i,j,k), prec_error), & + prec_error) + enddo ; enddo ; enddo + endif + if (present(err)) then + err = 0 + if (abs(max_mag_term) >= prec_error*pr(1)) err = err+1 + if (overflow_error) err = err+2 + if (NaN_error) err = err+2 + if (err > 0) then ; do n=1,ni ; ints_sum(n) = 0 ; enddo ; endif + else + if (NaN_error) call MOM_error(FATAL, "NaN in input field of reproducing_sum(_3d).") + if (abs(max_mag_term) >= prec_error*pr(1)) then + write(mesg, '(ES13.5)') max_mag_term + call MOM_error(FATAL,"Overflow in reproducing_sum(_3d) conversion of "//trim(mesg)) + endif + if (overflow_error) call MOM_error(FATAL, "Overflow in reproducing_sum(_3d).") + endif + + if (do_sum_across_PEs) call sum_across_PEs(ints_sum, ni) + + call regularize_ints(ints_sum) + sum = ints_to_real(ints_sum) + + if (present(EFP_sum)) EFP_sum%v(:) = ints_sum(:) + + if (debug) then + write(mesg,'("3d RS: ", ES24.16, 6 Z17.16)') sum, ints_sum(1:ni) + call MOM_mesg(mesg, 3) + endif + endif + +end function reproducing_sum_3d + +!> Convert a real number into the array of integers constitute its extended-fixed-point representation +function real_to_ints(r, prec_error, overflow) result(ints) + real, intent(in) :: r !< The real number being converted + integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + !! integers that is safe from overflows during global + !! sums. This will be larger than the compile-time + !! precision parameter, and is used to detect overflows. + logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being + !! done on a value that is too large to be represented + integer(kind=8), dimension(ni) :: ints + ! This subroutine converts a real number to an equivalent representation + ! using several long integers. + + real :: rs + character(len=80) :: mesg + integer(kind=8) :: ival, prec_err + integer :: sgn, i + + prec_err = prec ; if (present(prec_error)) prec_err = prec_error + ints(:) = 0_8 + if ((r >= 1e30) .eqv. (r < 1e30)) then ; NaN_error = .true. ; return ; endif + + sgn = 1 ; if (r<0.0) sgn = -1 + rs = abs(r) + + if (present(overflow)) then + if (.not.(rs < prec_err*pr(1))) overflow = .true. + if ((r >= 1e30) .eqv. (r < 1e30)) overflow = .true. + elseif (.not.(rs < prec_err*pr(1))) then + write(mesg, '(ES13.5)') r + call MOM_error(FATAL,"Overflow in real_to_ints conversion of "//trim(mesg)) + endif + + do i=1,ni + ival = int(rs*I_pr(i), 8) + rs = rs - ival*pr(i) + ints(i) = sgn*ival + enddo + +end function real_to_ints + +!> Convert the array of integers that constitute an extended-fixed-point +!! representation into a real number +function ints_to_real(ints) result(r) + integer(kind=8), dimension(ni), intent(in) :: ints !< The array of EFP integers + real :: r + ! This subroutine reverses the conversion in real_to_ints. + + integer :: i + + r = 0.0 + do i=1,ni ; r = r + pr(i)*ints(i) ; enddo +end function ints_to_real + +!> Increment an array of integers that constitutes an extended-fixed-point +!! representation with a another EFP number +subroutine increment_ints(int_sum, int2, prec_error) + integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + integer(kind=8), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added + integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + !! integers that is safe from overflows during global + !! sums. This will be larger than the compile-time + !! precision parameter, and is used to detect overflows. + + ! This subroutine increments a number with another, both using the integer + ! representation in real_to_ints. + integer :: i + + do i=ni,2,-1 + int_sum(i) = int_sum(i) + int2(i) + ! Carry the local overflow. + if (int_sum(i) > prec) then + int_sum(i) = int_sum(i) - prec + int_sum(i-1) = int_sum(i-1) + 1 + elseif (int_sum(i) < -prec) then + int_sum(i) = int_sum(i) + prec + int_sum(i-1) = int_sum(i-1) - 1 + endif + enddo + int_sum(1) = int_sum(1) + int2(1) + if (present(prec_error)) then + if (abs(int_sum(1)) > prec_error) overflow_error = .true. + else + if (abs(int_sum(1)) > prec) overflow_error = .true. + endif + +end subroutine increment_ints + +!> Increment an EFP number with a real number without doing any carrying of +!! of overflows and using only minimal error checking. +subroutine increment_ints_faster(int_sum, r, max_mag_term) + integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + real, intent(in) :: r !< The real number being added. + real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's. + + ! This subroutine increments a number with another, both using the integer + ! representation in real_to_ints, but without doing any carrying of overflow. + ! The entire operation is embedded in a single call for greater speed. + real :: rs + integer(kind=8) :: ival + integer :: sgn, i + + if ((r >= 1e30) .eqv. (r < 1e30)) then ; NaN_error = .true. ; return ; endif + sgn = 1 ; if (r<0.0) sgn = -1 + rs = abs(r) + if (rs > abs(max_mag_term)) max_mag_term = r + + ! Abort if the number has no EFP representation + if (rs > max_efp_float) then + overflow_error = .true. + return + endif + + do i=1,ni + ival = int(rs*I_pr(i), 8) + rs = rs - ival*pr(i) + int_sum(i) = int_sum(i) + sgn*ival + enddo + +end subroutine increment_ints_faster + +!> This subroutine handles carrying of the overflow. +subroutine carry_overflow(int_sum, prec_error) + integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being + !! modified by carries, but without changing value. + integer(kind=8), intent(in) :: prec_error !< The PE-count dependent precision of the + !! integers that is safe from overflows during global + !! sums. This will be larger than the compile-time + !! precision parameter, and is used to detect overflows. + + ! This subroutine handles carrying of the overflow. + integer :: i, num_carry + + do i=ni,2,-1 ; if (abs(int_sum(i)) >= prec) then + num_carry = int(int_sum(i) * I_prec) + int_sum(i) = int_sum(i) - num_carry*prec + int_sum(i-1) = int_sum(i-1) + num_carry + endif ; enddo + if (abs(int_sum(1)) > prec_error) then + overflow_error = .true. + endif + +end subroutine carry_overflow + +!> This subroutine carries the overflow, and then makes sure that +!! all integers are of the same sign as the overall value. +subroutine regularize_ints(int_sum) + integer(kind=8), dimension(ni), & + intent(inout) :: int_sum !< The array of integers being modified to take a + !! regular form with all integers of the same sign, + !! but without changing value. + + ! This subroutine carries the overflow, and then makes sure that + ! all integers are of the same sign as the overall value. + logical :: positive + integer :: i, num_carry + + do i=ni,2,-1 ; if (abs(int_sum(i)) >= prec) then + num_carry = int(int_sum(i) * I_prec) + int_sum(i) = int_sum(i) - num_carry*prec + int_sum(i-1) = int_sum(i-1) + num_carry + endif ; enddo + + ! Determine the sign of the final number. + positive = .true. + do i=1,ni + if (abs(int_sum(i)) > 0) then + if (int_sum(i) < 0) positive = .false. + exit + endif + enddo + + if (positive) then + do i=ni,2,-1 ; if (int_sum(i) < 0) then + int_sum(i) = int_sum(i) + prec + int_sum(i-1) = int_sum(i-1) - 1 + endif ; enddo + else + do i=ni,2,-1 ; if (int_sum(i) > 0) then + int_sum(i) = int_sum(i) - prec + int_sum(i-1) = int_sum(i-1) + 1 + endif ; enddo + endif + +end subroutine regularize_ints + +!> Returns the status of the module's error flag +function query_EFP_overflow_error() + logical :: query_EFP_overflow_error + query_EFP_overflow_error = overflow_error +end function query_EFP_overflow_error + +!> Reset the module's error flag to false +subroutine reset_EFP_overflow_error() + overflow_error = .false. +end subroutine reset_EFP_overflow_error + +!> Add two extended-fixed-point numbers +function EFP_plus(EFP1, EFP2) + type(EFP_type) :: EFP_plus !< The result in extended fixed point format + type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The second extended fixed point number + + EFP_plus = EFP1 + + call increment_ints(EFP_plus%v(:), EFP2%v(:)) +end function EFP_plus + +!> Subract one extended-fixed-point number from another +function EFP_minus(EFP1, EFP2) + type(EFP_type) :: EFP_minus !< The result in extended fixed point format + type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The extended fixed point number being + !! subtracted from the first extended fixed point number + integer :: i + + do i=1,ni ; EFP_minus%v(i) = -1*EFP2%v(i) ; enddo + + call increment_ints(EFP_minus%v(:), EFP1%v(:)) +end function EFP_minus + +!> Copy one extended-fixed-point number into another +subroutine EFP_assign(EFP1, EFP2) + type(EFP_type), intent(out) :: EFP1 !< The recipient extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The source extended fixed point number + integer i + ! This subroutine assigns all components of the extended fixed point type + ! variable on the RHS (EFP2) to the components of the variable on the LHS + ! (EFP1). + + do i=1,ni ; EFP1%v(i) = EFP2%v(i) ; enddo +end subroutine EFP_assign + +!> Return the real number that an extended-fixed-point number corresponds with +function EFP_to_real(EFP1) + type(EFP_type), intent(inout) :: EFP1 !< The extended fixed point number being converted + real :: EFP_to_real + + call regularize_ints(EFP1%v) + EFP_to_real = ints_to_real(EFP1%v) +end function EFP_to_real + +!> Take the difference between two extended-fixed-point numbers (EFP1 - EFP2) +!! and return the result as a real number +function EFP_real_diff(EFP1, EFP2) + type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The extended fixed point number being + !! subtracted from the first extended fixed point number + real :: EFP_real_diff !< The real result + + type(EFP_type) :: EFP_diff + + EFP_diff = EFP1 - EFP2 + EFP_real_diff = EFP_to_real(EFP_diff) + +end function EFP_real_diff + +!> Return the extended-fixed-point number that a real number corresponds with +function real_to_EFP(val, overflow) + real, intent(in) :: val !< The real number being converted + logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being + !! done on a value that is too large to be represented + type(EFP_type) :: real_to_EFP + + logical :: over + character(len=80) :: mesg + + if (present(overflow)) then + real_to_EFP%v(:) = real_to_ints(val, overflow=overflow) + else + over = .false. + real_to_EFP%v(:) = real_to_ints(val, overflow=over) + if (over) then + write(mesg, '(ES13.5)') val + call MOM_error(FATAL,"Overflow in real_to_EFP conversion of "//trim(mesg)) + endif + endif + +end function real_to_EFP + +!> This subroutine does a sum across PEs of a list of EFP variables, +!! returning the sums in place, with all overflows carried. +subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) + type(EFP_type), dimension(:), & + intent(inout) :: EFPs !< The list of extended fixed point numbers + !! being summed across PEs. + integer, intent(in) :: nval !< The number of values being summed. + logical, dimension(:), & + optional, intent(out) :: errors !< A list of error flags for each sum + + ! This subroutine does a sum across PEs of a list of EFP variables, + ! returning the sums in place, with all overflows carried. + + integer(kind=8), dimension(ni,nval) :: ints + integer(kind=8) :: prec_error + logical :: error_found + character(len=256) :: mesg + integer :: i, n + + if (num_PEs() > max_count_prec) call MOM_error(FATAL, & + "reproducing_sum: Too many processors are being used for the value of "//& + "prec. Reduce prec to (2^63-1)/num_PEs.") + + prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + ! overflow_error is an overflow error flag for the whole module. + overflow_error = .false. ; error_found = .false. + + do i=1,nval ; do n=1,ni ; ints(n,i) = EFPs(i)%v(n) ; enddo ; enddo + + call sum_across_PEs(ints(:,:), ni*nval) + + if (present(errors)) errors(:) = .false. + do i=1,nval + overflow_error = .false. + call carry_overflow(ints(:,i), prec_error) + do n=1,ni ; EFPs(i)%v(n) = ints(n,i) ; enddo + if (present(errors)) errors(i) = overflow_error + if (overflow_error) then + write (mesg,'("EFP_list_sum_across_PEs error at ",i6," val was ",ES12.6, ", prec_error = ",ES12.6)') & + i, EFP_to_real(EFPs(i)), real(prec_error) + call MOM_error(WARNING, mesg) + endif + error_found = error_found .or. overflow_error + enddo + if (error_found .and. .not.(present(errors))) then + call MOM_error(FATAL, "Overflow in EFP_list_sum_across_PEs.") + endif + +end subroutine EFP_list_sum_across_PEs + +!> This subroutine does a sum across PEs of an EFP variable, +!! returning the sums in place, with all overflows carried. +subroutine EFP_val_sum_across_PEs(EFP, error) + type(EFP_type), intent(inout) :: EFP !< The extended fixed point numbers + !! being summed across PEs. + logical, optional, intent(out) :: error !< An error flag for this sum + + ! This subroutine does a sum across PEs of a list of EFP variables, + ! returning the sums in place, with all overflows carried. + + integer(kind=8), dimension(ni) :: ints + integer(kind=8) :: prec_error + logical :: error_found + character(len=256) :: mesg + integer :: n + + if (num_PEs() > max_count_prec) call MOM_error(FATAL, & + "reproducing_sum: Too many processors are being used for the value of "//& + "prec. Reduce prec to (2^63-1)/num_PEs.") + + prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + ! overflow_error is an overflow error flag for the whole module. + overflow_error = .false. ; error_found = .false. + + do n=1,ni ; ints(n) = EFP%v(n) ; enddo + + call sum_across_PEs(ints(:), ni) + + if (present(error)) error = .false. + + overflow_error = .false. + call carry_overflow(ints(:), prec_error) + do n=1,ni ; EFP%v(n) = ints(n) ; enddo + if (present(error)) error = overflow_error + if (overflow_error) then + write (mesg,'("EFP_val_sum_across_PEs error val was ",ES12.6, ", prec_error = ",ES12.6)') & + EFP_to_real(EFP), real(prec_error) + call MOM_error(WARNING, mesg) + endif + error_found = error_found .or. overflow_error + + if (error_found .and. .not.(present(error))) then + call MOM_error(FATAL, "Overflow in EFP_val_sum_across_PEs.") + endif + +end subroutine EFP_val_sum_across_PEs + +end module MOM_coms diff --git a/framework/MOM_coupler_types.F90 b/framework/MOM_coupler_types.F90 new file mode 100644 index 0000000000..f87b409694 --- /dev/null +++ b/framework/MOM_coupler_types.F90 @@ -0,0 +1,493 @@ +!> This module provides coupler type interfaces for use by MOM6 +module MOM_coupler_types + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_couplertype_infra, only : CT_spawn, CT_initialized, CT_destructor, atmos_ocn_coupler_flux +use MOM_couplertype_infra, only : CT_set_diags, CT_send_data, CT_write_chksums, CT_data_override +use MOM_couplertype_infra, only : CT_copy_data, CT_increment_data, CT_rescale_data +use MOM_couplertype_infra, only : CT_set_data, CT_extract_data, CT_redistribute_data +use MOM_couplertype_infra, only : coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type +use MOM_couplertype_infra, only : ind_flux, ind_alpha, ind_csurf +use MOM_domain_infra, only : domain2D +use MOM_time_manager, only : time_type + +implicit none ; private + +public :: coupler_type_spawn, coupler_type_destructor, coupler_type_initialized +public :: coupler_type_set_diags, coupler_type_send_data, coupler_type_write_chksums +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 :: 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 + module procedure CT_spawn_1d_2d, CT_spawn_1d_3d, CT_spawn_2d_2d, CT_spawn_2d_3d + module procedure CT_spawn_3d_2d, CT_spawn_3d_3d +end interface coupler_type_spawn + +!> This function interface indicates whether a coupler_bc_type has been initialized. +interface coupler_type_initialized + module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d +end interface coupler_type_initialized + +!> This is the interface to deallocate any data associated with a coupler_bc_type. +interface coupler_type_destructor + module procedure CT_destructor_1d, CT_destructor_2d +end interface coupler_type_destructor + +!> Copy all elements of the data in either a coupler_2d_bc_type or a coupler_3d_bc_type into +!! another structure of the same or the other type. Both must have the same array sizes in common +!! dimensions, while the details of any expansion from 2d to 3d are controlled by arguments. +interface coupler_type_copy_data + module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d +end interface coupler_type_copy_data + +!> Increment data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type with +!! the data from another. Both must have the same array sizes and rank. +interface coupler_type_increment_data + module procedure CT_increment_data_2d, CT_increment_data_3d, CT_increment_data_2d_3d +end interface coupler_type_increment_data + +!> Rescale the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +interface coupler_type_rescale_data + module procedure CT_rescale_data_2d, CT_rescale_data_3d +end interface coupler_type_rescale_data + +!> Redistribute the data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type into +!! another, which may be on different processors with a different decomposition. +interface coupler_type_redistribute_data + module procedure CT_redistribute_data_2d, CT_redistribute_data_3d +end interface coupler_type_redistribute_data + +!> Write out checksums for the elements of a coupler_2d_bc_type or coupler_3d_bc_type +interface coupler_type_write_chksums + module procedure CT_write_chksums_2d, CT_write_chksums_3d +end interface coupler_type_write_chksums + +contains + +!> Generate a 2-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_2d + +!> Generate a 3-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_3d + +!> Generate one 2-D coupler type using another 2-D coupler type as a template. +subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_2d + +!> Generate a 3-D coupler type using a 2-D coupler type as a template. +subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_3d + +!> Generate a 2-D coupler type using a 3-D coupler type as a template. +subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_2d + +!> Generate a 3-D coupler type using another 3-D coupler type as a template. +subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call CT_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_2d + +!> Copy all elements of the data in a coupler_3d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call CT_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into a coupler_3d_bc_type. +!! Both must have the same array sizes for the first two dimensions, while the extent +!! of the 3rd dimension that is being filled may be specified via optional arguments. +subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd + !! index of the 3d type to fill in. + integer, optional, intent(in) :: ind3_end !< The ending value of the 3rd + !! index of the 3d type to fill in. + + call CT_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) +end subroutine CT_copy_data_2d_3d + +!> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_2d(var_in, var, halo_size, scale_factor, scale_prev) + type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + + call CT_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev) + +end subroutine CT_increment_data_2d + +!> Increment data in all elements of one coupler_3d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_3d(var_in, var, halo_size, scale_factor, scale_prev, exclude_flux_type, only_flux_type) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_3d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. + + call CT_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev, exclude_flux_type=exclude_flux_type, & + only_flux_type=only_flux_type) + +end subroutine CT_increment_data_3d + +!> Increment data in the elements of a coupler_2d_bc_type with weighted averages of elements of a +!! coupler_3d_bc_type +subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to + !! increment the 2d-data. There is no renormalization, + !! so if the weights do not sum to 1 in the 3rd dimension + !! there may be adverse consequences! + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + + call CT_increment_data(var_in, weights, var, halo_size=halo_size) + +end subroutine CT_increment_data_2d_3d + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_2d(var, scale) + type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call CT_rescale_data(var, scale) + +end subroutine CT_rescale_data_2d + +!> Rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_3d(var, scale) + type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call CT_rescale_data(var, scale) + +end subroutine CT_rescale_data_3d + +!> Redistribute the data in all elements of one coupler_2d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_2d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_2d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call CT_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_2d + +!> Redistribute the data in all elements of one coupler_3d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_3d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_3d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call CT_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_3d + + +!> Potentially override the values in a coupler_2d_bc_type +subroutine coupler_type_data_override(gridname, var, time) + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time + + call CT_data_override(gridname, var, time) +end subroutine coupler_type_data_override + + +!> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array, using a +!! MOM-specific interface. +subroutine extract_coupler_type_data(var_in, bc_index, array_out, scale_factor, & + halo_size, idim, jdim, field_index) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + integer, optional, intent(in) :: field_index !< The index of the field in the boundary + !! condition that is being copied, or the + !! surface flux by default. + + if (present(field_index)) then + call CT_extract_data(var_in, bc_index, field_index, array_out, & + scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + else + call CT_extract_data(var_in, bc_index, ind_flux, array_out, & + scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + endif + +end subroutine extract_coupler_type_data + +!> Set single 2d field in coupler_2d_bc_type from a two-dimensional array, using a +!! MOM-specific interface. +subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_factor, & + halo_size, idim, jdim, field_index) + real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set + logical, optional, intent(in) :: solubility !< If true and field index is missing, set + !! the solubility field. Otherwise set the + !! surface concentration (the default). + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being set. The + !! surface concentration is set by default. + + integer :: subfield ! An integer indicating which field to set. + + subfield = ind_csurf + if (present(solubility)) then ; if (solubility) subfield = ind_alpha ; endif + if (present(field_index)) subfield = field_index + + call CT_set_data(array_in, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + +end subroutine set_coupler_type_data + +!> Register the diagnostics of a coupler_2d_bc_type +subroutine coupler_type_set_diags(var, diag_name, axes, time) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics + character(len=*), intent(in) :: diag_name !< name for diagnostic file, or blank not to register the fields + integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration + type(time_type), intent(in) :: time !< model time variable for registering diagnostic field + + call CT_set_diags(var, diag_name, axes, time) + +end subroutine coupler_type_set_diags + +!> Write out all diagnostics of elements of a coupler_2d_bc_type +subroutine coupler_type_send_data(var, Time) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write + type(time_type), intent(in) :: time !< The current model time + + call CT_send_data(var, Time) +end subroutine coupler_type_send_data + +!> Write out checksums for the elements of a coupler_2d_bc_type +subroutine CT_write_chksums_2d(var, outunit, name_lead) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call CT_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_2d + +!> Write out checksums for the elements of a coupler_3d_bc_type +subroutine CT_write_chksums_3d(var, outunit, name_lead) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call CT_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_3d + +!> Indicate whether a coupler_1d_bc_type has been initialized. +logical function CT_initialized_1d(var) + type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_1d = CT_initialized(var) +end function CT_initialized_1d + +!> Indicate whether a coupler_2d_bc_type has been initialized. +logical function CT_initialized_2d(var) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_2d = CT_initialized(var) +end function CT_initialized_2d + +!> Indicate whether a coupler_3d_bc_type has been initialized. +logical function CT_initialized_3d(var) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_3d = CT_initialized(var) +end function CT_initialized_3d + +!> Deallocate all data associated with a coupler_1d_bc_type +subroutine CT_destructor_1d(var) + type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call CT_destructor(var) + +end subroutine CT_destructor_1d + +!> Deallocate all data associated with a coupler_2d_bc_type +subroutine CT_destructor_2d(var) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call CT_destructor(var) + +end subroutine CT_destructor_2d + +end module MOM_coupler_types diff --git a/framework/MOM_cpu_clock.F90 b/framework/MOM_cpu_clock.F90 new file mode 100644 index 0000000000..f4e605a06c --- /dev/null +++ b/framework/MOM_cpu_clock.F90 @@ -0,0 +1,36 @@ +!> Provides cpu clock functions +module MOM_cpu_clock + +! This file is part of MOM6. See LICENSE.md for the license. + +! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module +use MOM_cpu_clock_infra, only : cpu_clock_begin +use MOM_cpu_clock_infra, only : cpu_clock_end +use MOM_cpu_clock_infra, only : cpu_clock_id +use MOM_cpu_clock_infra, only : CLOCK_COMPONENT +use MOM_cpu_clock_infra, only : CLOCK_SUBCOMPONENT +use MOM_cpu_clock_infra, only : CLOCK_MODULE_DRIVER +use MOM_cpu_clock_infra, only : CLOCK_MODULE +use MOM_cpu_clock_infra, only : CLOCK_ROUTINE +use MOM_cpu_clock_infra, only : CLOCK_LOOP +use MOM_cpu_clock_infra, only : CLOCK_INFRA + +implicit none ; private + +!> Public functions: +!> mom_cpu_clock_infra::cpu_clock_id, mom_cpu_clock_infra::cpu_clock_begin, mom_cpu_clock_infra::cpu_clock_end +public :: cpu_clock_id, cpu_clock_begin, cpu_clock_end + +!> Public constants: +!> mom_cpu_clock_infra::clock_component, mom_cpu_clock_infra::clock_subcomponent +!> mom_cpu_clock_infra::clock_module_driver, mom_cpu_clock_infra::clock_module_driver +public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE +!> mom_cpu_clock_infra::clock_routine, mom_cpu_clock_infra::clock_loop +!> mom_cpu_clock_infra::clock_infra +public :: CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA + +end module MOM_cpu_clock + +!> \namespace mom_cpu_clock +!! +!! APIs are defined and implemented in mom_cpu_clock_infra. diff --git a/framework/MOM_data_override.F90 b/framework/MOM_data_override.F90 new file mode 100644 index 0000000000..39841913e1 --- /dev/null +++ b/framework/MOM_data_override.F90 @@ -0,0 +1,24 @@ +!> These interfaces allow for ocean or sea-ice variables to be replaced with data. +module MOM_data_override + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_data_override_infra, only : data_override_init => impose_data_init +use MOM_data_override_infra, only : data_override => impose_data +use MOM_data_override_infra, only : data_override_unset_domains => impose_data_unset_domains + +implicit none ; private + +!> Public functions: +!> mom_data_override_infra:impose_data_init +public :: data_override_init +!> mom_data_override_infra:impose_data +public :: data_override +!> mom_data_override_infra:impose_data_unset_domains +public :: data_override_unset_domains + +end module MOM_data_override + +!> \namespace MOM_data_override +!! +!! APIs are defined and implemented in MOM_data_override_infra diff --git a/framework/MOM_diag_mediator.F90 b/framework/MOM_diag_mediator.F90 new file mode 100644 index 0000000000..eeb239859d --- /dev/null +++ b/framework/MOM_diag_mediator.F90 @@ -0,0 +1,4616 @@ +!> The subroutines here provide convenient wrappers to the fms diag_manager +!! interfaces with additional diagnostic capabilies. +module MOM_diag_mediator + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_checksums, only : chksum0, zchksum +use MOM_checksums, only : hchksum, uchksum, vchksum, Bchksum +use MOM_coms, only : PE_here +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_manager_infra, only : MOM_diag_manager_init, MOM_diag_manager_end +use MOM_diag_manager_infra, only : diag_axis_init=>MOM_diag_axis_init, get_MOM_diag_axis_name +use MOM_diag_manager_infra, only : send_data_infra, MOM_diag_field_add_attribute, EAST, NORTH +use MOM_diag_manager_infra, only : register_diag_field_infra, register_static_field_infra +use MOM_diag_manager_infra, only : get_MOM_diag_field_id, DIAG_FIELD_NOT_FOUND +use MOM_diag_remap, only : diag_remap_ctrl, diag_remap_update, diag_remap_calc_hmask +use MOM_diag_remap, only : diag_remap_init, diag_remap_end, diag_remap_do_remap +use MOM_diag_remap, only : vertically_reintegrate_diag_field, vertically_interpolate_diag_field +use MOM_diag_remap, only : horizontally_average_diag_field, diag_remap_get_axes_info +use MOM_diag_remap, only : diag_remap_configure_axes, diag_remap_axes_configured +use MOM_diag_remap, only : diag_remap_diag_registration_closed, diag_remap_set_active +use MOM_EOS, only : EOS_type +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, assert, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_io, only : slasher, vardesc, query_vardesc, MOM_read_data +use MOM_io, only : get_filename_appendix +use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc +use MOM_string_functions, only : lowercase +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#undef __DO_SAFETY_CHECKS__ +#define IMPLIES(A, B) ((.not. (A)) .or. (B)) +#define MAX_DSAMP_LEV 2 + +public set_axes_info, post_data, register_diag_field, time_type +public post_product_u, post_product_sum_u, post_product_v, post_product_sum_v +public set_masks_for_axes +! post_data_1d_k is a deprecated interface that can be replaced by a call to post_data, but +! it is being retained for backward compatibility to older versions of the ocean_BGC code. +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 +public diag_mediator_infrastructure_init +public diag_mediator_close_registration, get_diag_time_end +public diag_axis_init, ocean_register_diag, register_static_field +public register_scalar_field +public define_axes_group, diag_masks_set +public diag_register_area_ids +public register_cell_measure, diag_associate_volume_cell_measure +public diag_get_volume_cell_measure_dm_id +public diag_set_state_ptrs, diag_update_remap_grids +public diag_grid_storage_init, diag_grid_storage_end +public diag_copy_diag_to_storage, diag_copy_storage_to_diag +public diag_save_grids, diag_restore_grids +public found_in_diagtable + +!> Make a diagnostic available for averaging or output. +interface post_data + module procedure post_data_3d, post_data_2d, post_data_1d_k, post_data_0d +end interface post_data + +!> Down sample a field +interface downsample_field + module procedure downsample_field_2d, downsample_field_3d +end interface downsample_field + +!> Down sample the mask of a field +interface downsample_mask + module procedure downsample_mask_2d, downsample_mask_3d +end interface downsample_mask + +!> Down sample a diagnostic field +interface downsample_diag_field + module procedure downsample_diag_field_2d, downsample_diag_field_3d +end interface downsample_diag_field + +!> Contained for down sampled masks +type, private :: diag_dsamp + real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes + real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes +end type diag_dsamp + +!> A group of 1D axes that comprise a 1D/2D/3D mesh +type, public :: axes_grp + character(len=15) :: id !< The id string for this particular combination of handles. + integer :: rank !< Number of dimensions in the list of axes. + integer, dimension(:), allocatable :: handles !< Handles to 1D axes. + type(diag_ctrl), pointer :: diag_cs => null() !< Circular link back to the main diagnostics control structure + !! (Used to avoid passing said structure into every possible call). + ! ID's for cell_methods + character(len=9) :: x_cell_method = '' !< Default nature of data representation, if axes group + !! includes x-direction. + character(len=9) :: y_cell_method = '' !< Default nature of data representation, if axes group + !! includes y-direction. + character(len=9) :: v_cell_method = '' !< Default nature of data representation, if axes group + !! includes vertical direction. + ! For remapping + integer :: nz = 0 !< Vertical dimension of diagnostic + integer :: vertical_coordinate_number = 0 !< Index of the corresponding diag_remap_ctrl for this axis group + ! For detecting position on the grid + logical :: is_h_point = .false. !< If true, indicates that this axes group is for an h-point located field. + logical :: is_q_point = .false. !< If true, indicates that this axes group is for a q-point located field. + logical :: is_u_point = .false. !< If true, indicates that this axes group is for a u-point located field. + logical :: is_v_point = .false. !< If true, indicates that this axes group is for a v-point located field. + logical :: is_layer = .false. !< If true, indicates that this axes group is for a layer vertically-located field. + logical :: is_interface = .false. !< If true, indicates that this axes group is for an interface + !! vertically-located field. + logical :: is_native = .true. !< If true, indicates that this axes group is for a native model grid. + !! False for any other grid. Used for rank>2. + logical :: needs_remapping = .false. !< If true, indicates that this axes group is for a intensive layer-located + !! field that must be remapped to these axes. Used for rank>2. + logical :: needs_interpolating = .false. !< If true, indicates that this axes group is for a sampled + !! interface-located field that must be interpolated to + !! these axes. Used for rank>2. + integer :: downsample_level = 1 !< If greater than 1, the factor by which this diagnostic/axes/masks be downsampled + ! For horizontally averaged diagnositcs (applies to 2d and 3d fields only) + type(axes_grp), pointer :: xyave_axes => null() !< The associated 1d axes for horizontall area-averaged diagnostics + ! ID's for cell_measures + integer :: id_area = -1 !< The diag_manager id for area to be used for cell_measure of variables with this axes_grp. + integer :: id_volume = -1 !< The diag_manager id for volume to be used for cell_measure of variables + !! with this axes_grp. + ! For masking + real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes + real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes + type(diag_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample container +end type axes_grp + +!> Contains an array to store a diagnostic target grid +type, private :: diag_grids_type + real, dimension(:,:,:), allocatable :: h !< Target grid for remapped coordinate [H ~> m or kg m-2] or [Z ~> m] +end type diag_grids_type + +!> Stores all the remapping grids and the model's native space thicknesses +type, public :: diag_grid_storage + integer :: num_diag_coords !< Number of target coordinates + real, dimension(:,:,:), allocatable :: h_state !< Layer thicknesses in native + !! space [H ~> m or kg m-2] + type(diag_grids_type), dimension(:), allocatable :: diag_grids !< Primarily empty, except h field +end type diag_grid_storage + +! Integers to encode the total cell methods +!integer :: PPP=111 ! x:point,y:point,z:point, this kind of diagnostic is not currently present in diag_table.MOM6 +!integer :: PPS=112 ! x:point,y:point,z:sum , this kind of diagnostic is not currently present in diag_table.MOM6 +!integer :: PPM=113 ! x:point,y:point,z:mean , this kind of diagnostic is not currently present in diag_table.MOM6 +integer :: PSP=121 !< x:point,y:sum,z:point +integer :: PSS=122 !< x:point,y:sum,z:point +integer :: PSM=123 !< x:point,y:sum,z:mean +integer :: PMP=131 !< x:point,y:mean,z:point +integer :: PMM=133 !< x:point,y:mean,z:mean +integer :: SPP=211 !< x:sum,y:point,z:point +integer :: SPS=212 !< x:sum,y:point,z:sum +integer :: SSP=221 !< x:sum;y:sum,z:point +integer :: MPP=311 !< x:mean,y:point,z:point +integer :: MPM=313 !< x:mean,y:point,z:mean +integer :: MMP=331 !< x:mean,y:mean,z:point +integer :: MMS=332 !< x:mean,y:mean,z:sum +integer :: SSS=222 !< x:sum,y:sum,z:sum +integer :: MMM=333 !< x:mean,y:mean,z:mean +integer :: MSK=-1 !< Use the downsample method of a mask + +!> This type is used to represent a diagnostic at the diag_mediator level. +!! +!! There can be both 'primary' and 'seconday' diagnostics. The primaries +!! reside in the diag_cs%diags array. They have an id which is an index +!! into this array. The secondaries are 'variations' on the primary diagnostic. +!! For example the CMOR diagnostics are secondary. The secondary diagnostics +!! are kept in a list with the primary diagnostic as the head. +type, private :: diag_type + logical :: in_use !< True if this entry is being used. + integer :: fms_diag_id !< Underlying FMS diag_manager id. + integer :: fms_xyave_diag_id = -1 !< For a horizontally area-averaged diagnostic. + integer :: downsample_diag_id = -1 !< For a horizontally area-downsampled diagnostic. + character(64) :: debug_str = '' !< For FATAL errors and debugging. + type(axes_grp), pointer :: axes => null() !< The axis group for this diagnostic + type(diag_type), pointer :: next => null() !< Pointer to the next diagnostic + real :: conversion_factor = 0. !< A factor to multiply data by before posting to FMS, if non-zero. + logical :: v_extensive = .false. !< True for vertically extensive fields (vertically integrated). + !! False for intensive (concentrations). + integer :: xyz_method = 0 !< A 3 digit integer encoding the diagnostics cell method + !! It can be used to determine the downsample algorithm +end type diag_type + +!> Container for down sampling information +type diagcs_dsamp + integer :: isc !< The start i-index of cell centers within the computational domain + integer :: iec !< The end i-index of cell centers within the computational domain + integer :: jsc !< The start j-index of cell centers within the computational domain + integer :: jec !< The end j-index of cell centers within the computational domain + integer :: isd !< The start i-index of cell centers within the data domain + integer :: ied !< The end i-index of cell centers within the data domain + integer :: jsd !< The start j-index of cell centers within the data domain + integer :: jed !< The end j-index of cell centers within the data domain + integer :: isg !< The start i-index of cell centers within the global domain + integer :: ieg !< The end i-index of cell centers within the global domain + integer :: jsg !< The start j-index of cell centers within the global domain + integer :: jeg !< The end j-index of cell centers within the global domain + integer :: isgB !< The start i-index of cell corners within the global domain + integer :: iegB !< The end i-index of cell corners within the global domain + integer :: jsgB !< The start j-index of cell corners within the global domain + integer :: jegB !< The end j-index of cell corners within the global domain + + !>@{ Axes for each location on a diagnostic grid + type(axes_grp) :: axesBL, axesTL, axesCuL, axesCvL + type(axes_grp) :: axesBi, axesTi, axesCui, axesCvi + type(axes_grp) :: axesB1, axesT1, axesCu1, axesCv1 + type(axes_grp), dimension(:), allocatable :: remap_axesTL, remap_axesBL, remap_axesCuL, remap_axesCvL + type(axes_grp), dimension(:), allocatable :: remap_axesTi, remap_axesBi, remap_axesCui, remap_axesCvi + !>@} + + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points + real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points + real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points + real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points + !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) + real, dimension(:,:,:), pointer :: mask3dTL => null() + real, dimension(:,:,:), pointer :: mask3dBL => null() + real, dimension(:,:,:), pointer :: mask3dCuL => null() + real, dimension(:,:,:), pointer :: mask3dCvL => null() + real, dimension(:,:,:), pointer :: mask3dTi => null() + real, dimension(:,:,:), pointer :: mask3dBi => null() + real, dimension(:,:,:), pointer :: mask3dCui => null() + real, dimension(:,:,:), pointer :: mask3dCvi => null() + !>@} +end type diagcs_dsamp + +!> The following data type a list of diagnostic fields an their variants, +!! as well as variables that control the handling of model output. +type, public :: diag_ctrl + integer :: available_diag_doc_unit = -1 !< The unit number of a diagnostic documentation file. + !! This file is open if available_diag_doc_unit is > 0. + integer :: chksum_iounit = -1 !< The unit number of a diagnostic documentation file. + !! This file is open if available_diag_doc_unit is > 0. + logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics + logical :: show_call_tree !< Display the call tree while running. Set by VERBOSITY level. + logical :: grid_space_axes !< If true, diagnostic horizontal coordinates axes are in grid space. +! The following fields are used for the output of the data. + integer :: is !< The start i-index of cell centers within the computational domain + integer :: ie !< The end i-index of cell centers within the computational domain + integer :: js !< The start j-index of cell centers within the computational domain + integer :: je !< The end j-index of cell centers within the computational domain + + integer :: isd !< The start i-index of cell centers within the data domain + integer :: ied !< The end i-index of cell centers within the data domain + integer :: jsd !< The start j-index of cell centers within the data domain + integer :: jed !< The end j-index of cell centers within the data domain + real :: time_int !< The time interval for any fields + !! that are offered for averaging [s]. + type(time_type) :: time_end !< The end time of the valid + !! interval for any offered field. + logical :: ave_enabled = .false. !< True if averaging is enabled. + + !>@{ The following are 3D and 2D axis groups defined for output. The names + !! indicate the horizontal (B, T, Cu, or Cv) and vertical (L, i, or 1) locations. + type(axes_grp) :: axesBL, axesTL, axesCuL, axesCvL + type(axes_grp) :: axesBi, axesTi, axesCui, axesCvi + type(axes_grp) :: axesB1, axesT1, axesCu1, axesCv1 + !>@} + type(axes_grp) :: axesZi !< A 1-D z-space axis at interfaces + type(axes_grp) :: axesZL !< A 1-D z-space axis at layer centers + type(axes_grp) :: axesNull !< An axis group for scalars + + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points + real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points + real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points + real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points + !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) + real, dimension(:,:,:), pointer :: mask3dTL => null() + real, dimension(:,:,:), pointer :: mask3dBL => null() + real, dimension(:,:,:), pointer :: mask3dCuL => null() + real, dimension(:,:,:), pointer :: mask3dCvL => null() + real, dimension(:,:,:), pointer :: mask3dTi => null() + real, dimension(:,:,:), pointer :: mask3dBi => null() + real, dimension(:,:,:), pointer :: mask3dCui => null() + real, dimension(:,:,:), pointer :: mask3dCvi => null() + + type(diagcs_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample control container + + !>@} + +! Space for diagnostics is dynamically allocated as it is needed. +! The chunk size is how much the array should grow on each new allocation. +#define DIAG_ALLOC_CHUNK_SIZE 100 + type(diag_type), dimension(:), allocatable :: diags !< The list of diagnostics + integer :: next_free_diag_id !< The next unused diagnostic ID + + !> default missing value to be sent to ALL diagnostics registrations + real :: missing_value = -1.0e+34 + + !> Number of diagnostic vertical coordinates (remapped) + integer :: num_diag_coords + !> Control structure for each possible coordinate + type(diag_remap_ctrl), dimension(:), allocatable :: diag_remap_cs + type(diag_grid_storage) :: diag_grid_temp !< Stores the remapped diagnostic grid + logical :: diag_grid_overridden = .false. !< True if the diagnostic grids have been overriden + + type(axes_grp), dimension(:), allocatable :: & + remap_axesZL, & !< The 1-D z-space cell-centered axis for remapping + remap_axesZi !< The 1-D z-space interface axis for remapping + !>@{ Axes used for remapping + type(axes_grp), dimension(:), allocatable :: remap_axesTL, remap_axesBL, remap_axesCuL, remap_axesCvL + type(axes_grp), dimension(:), allocatable :: remap_axesTi, remap_axesBi, remap_axesCui, remap_axesCvi + !>@} + + ! Pointer to H, G and T&S needed for remapping + real, dimension(:,:,:), pointer :: h => null() !< The thicknesses needed for remapping [H ~> m or kg m-2] + real, dimension(:,:,:), pointer :: T => null() !< The temperatures needed for remapping [C ~> degC] + real, dimension(:,:,:), pointer :: S => null() !< The salinities needed for remapping [S ~> ppt] + type(EOS_type), pointer :: eqn_of_state => null() !< The equation of state type + type(thermo_var_ptrs), pointer :: tv => null() !< A sturcture with thermodynamic variables that are + !! are used to convert thicknesses to vertical extents + type(ocean_grid_type), pointer :: G => null() !< The ocean grid type + type(verticalGrid_type), pointer :: GV => null() !< The model's vertical ocean grid + type(unit_scale_type), pointer :: US => null() !< A dimensional unit scaling type + + !> The volume cell measure (special diagnostic) manager id + integer :: volume_cell_measure_dm_id = -1 + +#if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) + ! Keep a copy of h so that we know whether it has changed [H ~> m or kg m-2]. If it has then + ! need the target grid for vertical remapping needs to have been updated. + real, dimension(:,:,:), allocatable :: h_old +#endif + + !> Number of checksum-only diagnostics + integer :: num_chksum_diags + + real, dimension(:,:,:), allocatable :: h_begin !< Layer thicknesses at the beginning of the timestep used + !! for remapping of extensive variables [H ~> m or kg m-2] + +end type diag_ctrl + +!>@{ CPU clocks +integer :: id_clock_diag_mediator, id_clock_diag_remap, id_clock_diag_grid_updates +!>@} + +contains + +!> Sets up diagnostics axes +subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) + type(ocean_grid_type), intent(inout) :: 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(param_file_type), intent(in) :: param_file !< Parameter file structure + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure + logical, optional, intent(in) :: set_vertical !< If true or missing, set up + !! vertical axes + ! Local variables + integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh, id_null + integer :: id_zl_native, id_zi_native + integer :: i, j, nz + real :: zlev(GV%ke), zinter(GV%ke+1) + logical :: set_vert + real, allocatable, dimension(:) :: IaxB,iax + real, allocatable, dimension(:) :: JaxB,jax + + + set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical + + + if (diag_cs%grid_space_axes) then + allocate(IaxB(G%IsgB:G%IegB)) + do i=G%IsgB, G%IegB + Iaxb(i)=real(i) + enddo + allocate(iax(G%isg:G%ieg)) + do i=G%isg, G%ieg + iax(i)=real(i)-0.5 + enddo + allocate(JaxB(G%JsgB:G%JegB)) + do j=G%JsgB, G%JegB + JaxB(j)=real(j) + enddo + allocate(jax(G%jsg:G%jeg)) + do j=G%jsg, G%jeg + jax(j)=real(j)-0.5 + enddo + endif + + ! Horizontal axes for the native grids + if (G%symmetric) then + if (diag_cs%grid_space_axes) then + id_xq = diag_axis_init('iq', IaxB(G%isgB:G%iegB), 'none', 'x', & + 'q point grid-space longitude', G%Domain, position=EAST) + id_yq = diag_axis_init('jq', JaxB(G%jsgB:G%jegB), 'none', 'y', & + 'q point grid space latitude', G%Domain, position=NORTH) + else + id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & + 'q point nominal longitude', G%Domain, position=EAST) + id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & + 'q point nominal latitude', G%Domain, position=NORTH) + endif + else + if (diag_cs%grid_space_axes) then + id_xq = diag_axis_init('Iq', IaxB(G%isg:G%ieg), 'none', 'x', & + 'q point grid-space longitude', G%Domain, position=EAST) + id_yq = diag_axis_init('Jq', JaxB(G%jsg:G%jeg), 'none', 'y', & + 'q point grid space latitude', G%Domain, position=NORTH) + else + id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & + 'q point nominal longitude', G%Domain, position=EAST) + id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'q point nominal latitude', G%Domain, position=NORTH) + endif + endif + + if (diag_cs%grid_space_axes) then + id_xh = diag_axis_init('ih', iax(G%isg:G%ieg), 'none', 'x', & + 'h point grid-space longitude', G%Domain, position=EAST) + id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & + 'h point grid space latitude', G%Domain, position=NORTH) + else + id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & + 'h point nominal longitude', G%Domain) + id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'h point nominal latitude', G%Domain) + endif + + if (set_vert) then + nz = GV%ke + zinter(1:nz+1) = GV%sInterface(1:nz+1) + zlev(1:nz) = GV%sLayer(1:nz) + id_zl = diag_axis_init('zl', zlev, trim(GV%zAxisUnits), 'z', & + 'Layer '//trim(GV%zAxisLongName), direction=GV%direction) + id_zi = diag_axis_init('zi', zinter, trim(GV%zAxisUnits), 'z', & + 'Interface '//trim(GV%zAxisLongName), direction=GV%direction) + else + id_zl = -1 ; id_zi = -1 + endif + id_zl_native = id_zl ; id_zi_native = id_zi + ! Vertical axes for the interfaces and layers + call define_axes_group(diag_cs, (/ id_zi /), diag_cs%axesZi, & + v_cell_method='point', is_interface=.true.) + call define_axes_group(diag_cs, (/ id_zL /), diag_cs%axesZL, & + v_cell_method='mean', is_layer=.true.) + + ! Axis groupings for the model layers + call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%axesTL, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & + is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%axesBL, & + x_cell_method='point', y_cell_method='point', v_cell_method='mean', & + is_q_point=.true., is_layer=.true.) + call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%axesCuL, & + x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & + is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%axesCvL, & + x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & + is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + + ! Axis groupings for the model interfaces + call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%axesTi, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & + is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%axesBi, & + x_cell_method='point', y_cell_method='point', v_cell_method='point', & + is_q_point=.true., is_interface=.true.) + call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%axesCui, & + x_cell_method='point', y_cell_method='mean', v_cell_method='point', & + is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%axesCvi, & + x_cell_method='mean', y_cell_method='point', v_cell_method='point', & + is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + + ! Axis groupings for 2-D arrays + call define_axes_group(diag_cs, (/ id_xh, id_yh /), diag_cs%axesT1, & + x_cell_method='mean', y_cell_method='mean', is_h_point=.true.) + call define_axes_group(diag_cs, (/ id_xq, id_yq /), diag_cs%axesB1, & + x_cell_method='point', y_cell_method='point', is_q_point=.true.) + call define_axes_group(diag_cs, (/ id_xq, id_yh /), diag_cs%axesCu1, & + x_cell_method='point', y_cell_method='mean', is_u_point=.true.) + call define_axes_group(diag_cs, (/ id_xh, id_yq /), diag_cs%axesCv1, & + x_cell_method='mean', y_cell_method='point', is_v_point=.true.) + + ! Axis group for special null axis from diag manager. + id_null = diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none', null_axis=.true.) + call define_axes_group(diag_cs, (/ id_null /), diag_cs%axesNull) + + !Non-native Non-downsampled + if (diag_cs%num_diag_coords>0) then + allocate(diag_cs%remap_axesZL(diag_cs%num_diag_coords)) + allocate(diag_cs%remap_axesTL(diag_cs%num_diag_coords)) + allocate(diag_cs%remap_axesBL(diag_cs%num_diag_coords)) + allocate(diag_cs%remap_axesCuL(diag_cs%num_diag_coords)) + allocate(diag_cs%remap_axesCvL(diag_cs%num_diag_coords)) + allocate(diag_cs%remap_axesZi(diag_cs%num_diag_coords)) + allocate(diag_cs%remap_axesTi(diag_cs%num_diag_coords)) + allocate(diag_cs%remap_axesBi(diag_cs%num_diag_coords)) + allocate(diag_cs%remap_axesCui(diag_cs%num_diag_coords)) + allocate(diag_cs%remap_axesCvi(diag_cs%num_diag_coords)) + endif + + do i=1, diag_cs%num_diag_coords + ! For each possible diagnostic coordinate + call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, US, param_file) + + ! Allocate these arrays since the size of the diagnostic array is now known + allocate(diag_cs%diag_remap_cs(i)%h(G%isd:G%ied,G%jsd:G%jed, diag_cs%diag_remap_cs(i)%nz)) + allocate(diag_cs%diag_remap_cs(i)%h_extensive(G%isd:G%ied,G%jsd:G%jed, diag_cs%diag_remap_cs(i)%nz)) + + ! This vertical coordinate has been configured so can be used. + if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then + + ! This fetches the 1D-axis id for layers and interfaces and overwrite + ! id_zl and id_zi from above. It also returns the number of layers. + call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zL, id_zi) + + ! Axes for z layers + call define_axes_group(diag_cs, (/ id_zL /), diag_cs%remap_axesZL(i), & + nz=nz, vertical_coordinate_number=i, & + v_cell_method='mean', & + is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true.) + call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%remap_axesTL(i), & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & + is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + !! \note Remapping for B points is not yet implemented so needs_remapping is not + !! provided for remap_axesBL + call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%remap_axesBL(i), & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='point', v_cell_method='mean', & + is_q_point=.true., is_layer=.true., is_native=.false.) + + call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%remap_axesCuL(i), & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & + is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%remap_axesCvL(i), & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & + is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + ! Axes for z interfaces + call define_axes_group(diag_cs, (/ id_zi /), diag_cs%remap_axesZi(i), & + nz=nz, vertical_coordinate_number=i, & + v_cell_method='point', & + is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true.) + call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%remap_axesTi(i), & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & + is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., & + xyave_axes=diag_cs%remap_axesZi(i)) + + !! \note Remapping for B points is not yet implemented so needs_remapping is not provided for remap_axesBi + call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%remap_axesBi(i), & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='point', v_cell_method='point', & + is_q_point=.true., is_interface=.true., is_native=.false.) + + call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%remap_axesCui(i), & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='mean', v_cell_method='point', & + is_u_point=.true., is_interface=.true., is_native=.false., & + needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) + + call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%remap_axesCvi(i), & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='point', v_cell_method='point', & + is_v_point=.true., is_interface=.true., is_native=.false., & + needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) + endif + enddo + + if (diag_cs%grid_space_axes) then + deallocate(IaxB, iax, JaxB, jax) + endif + !Define the downsampled axes + call set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) + + call diag_grid_storage_init(diag_CS%diag_grid_temp, G, GV, diag_CS) + +end subroutine set_axes_info + +subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure + integer, intent(in) :: id_zl_native !< ID of native layers + integer, intent(in) :: id_zi_native !< ID of native interfaces + + ! Local variables + integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh + integer :: i, j, nz, dl + real, dimension(:), pointer :: gridLonT_dsamp =>NULL() + real, dimension(:), pointer :: gridLatT_dsamp =>NULL() + real, dimension(:), pointer :: gridLonB_dsamp =>NULL() + real, dimension(:), pointer :: gridLatB_dsamp =>NULL() + + id_zl = id_zl_native ; id_zi = id_zi_native + !Axes group for native downsampled diagnostics + do dl=2,MAX_DSAMP_LEV + if (dl /= 2) call MOM_error(FATAL, "set_axes_info_dsamp: Downsample level other than 2 is not supported yet!") + if (G%symmetric) then + allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isgB:diag_cs%dsamp(dl)%iegB)) + allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsgB:diag_cs%dsamp(dl)%jegB)) + do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridLonB_dsamp(i) = G%gridLonB(G%isgB+dl*i); enddo + do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dl*j); enddo + id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & + 'q point nominal longitude', G%Domain, coarsen=2) + id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & + 'q point nominal latitude', G%Domain, coarsen=2) + deallocate(gridLonB_dsamp,gridLatB_dsamp) + else + allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) + allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2); enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2); enddo + id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & + 'q point nominal longitude', G%Domain, coarsen=2) + id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & + 'q point nominal latitude', G%Domain, coarsen=2) + deallocate(gridLonB_dsamp,gridLatB_dsamp) + endif + + allocate(gridLonT_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) + allocate(gridLatT_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2); enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2); enddo + id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', & + 'h point nominal longitude', G%Domain, coarsen=2) + id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', & + 'h point nominal latitude', G%Domain, coarsen=2) + + deallocate(gridLonT_dsamp,gridLatT_dsamp) + + ! Axis groupings for the model layers + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%axesTL, dl, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & + is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%dsamp(dl)%axesBL, dl, & + x_cell_method='point', y_cell_method='point', v_cell_method='mean', & + is_q_point=.true., is_layer=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%dsamp(dl)%axesCuL, dl, & + x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & + is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%dsamp(dl)%axesCvL, dl, & + x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & + is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + + ! Axis groupings for the model interfaces + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%axesTi, dl, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & + is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%axesBi, dl, & + x_cell_method='point', y_cell_method='point', v_cell_method='point', & + is_q_point=.true., is_interface=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%axesCui, dl, & + x_cell_method='point', y_cell_method='mean', v_cell_method='point', & + is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%axesCvi, dl, & + x_cell_method='mean', y_cell_method='point', v_cell_method='point', & + is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + + ! Axis groupings for 2-D arrays + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh /), diag_cs%dsamp(dl)%axesT1, dl, & + x_cell_method='mean', y_cell_method='mean', is_h_point=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq /), diag_cs%dsamp(dl)%axesB1, dl, & + x_cell_method='point', y_cell_method='point', is_q_point=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh /), diag_cs%dsamp(dl)%axesCu1, dl, & + x_cell_method='point', y_cell_method='mean', is_u_point=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq /), diag_cs%dsamp(dl)%axesCv1, dl, & + x_cell_method='mean', y_cell_method='point', is_v_point=.true.) + + !Non-native axes + if (diag_cs%num_diag_coords>0) then + allocate(diag_cs%dsamp(dl)%remap_axesTL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesBL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCuL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCvL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesTi(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesBi(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCui(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCvi(diag_cs%num_diag_coords)) + endif + + do i=1, diag_cs%num_diag_coords + ! For each possible diagnostic coordinate + !call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, param_file) + + ! This vertical coordinate has been configured so can be used. + if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then + + ! This fetches the 1D-axis id for layers and interfaces and overwrite + ! id_zl and id_zi from above. It also returns the number of layers. + call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zL, id_zi) + + ! Axes for z layers + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%remap_axesTL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & + is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + !! \note Remapping for B points is not yet implemented so needs_remapping is not + !! provided for remap_axesBL + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%dsamp(dl)%remap_axesBL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='point', v_cell_method='mean', & + is_q_point=.true., is_layer=.true., is_native=.false.) + + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%dsamp(dl)%remap_axesCuL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & + is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%dsamp(dl)%remap_axesCvL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & + is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + ! Axes for z interfaces + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesTi(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & + is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., & + xyave_axes=diag_cs%remap_axesZi(i)) + + !! \note Remapping for B points is not yet implemented so needs_remapping is not provided for remap_axesBi + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesBi(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='point', v_cell_method='point', & + is_q_point=.true., is_interface=.true., is_native=.false.) + + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesCui(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='mean', v_cell_method='point', & + is_u_point=.true., is_interface=.true., is_native=.false., & + needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) + + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesCvi(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='point', v_cell_method='point', & + is_v_point=.true., is_interface=.true., is_native=.false., & + needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) + endif + enddo + enddo + +end subroutine set_axes_info_dsamp + + +!> set_masks_for_axes sets up the 2d and 3d masks for diagnostics using the current grid +!! recorded after calling diag_update_remap_grids() +subroutine set_masks_for_axes(G, diag_cs) + type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. + type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + ! Local variables + integer :: c, nk, i, j, k + type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience + + do c=1, diag_cs%num_diag_coords + ! This vertical coordinate has been configured so can be used. + if (diag_remap_axes_configured(diag_cs%diag_remap_cs(c))) then + + ! Level/layer h-points in diagnostic coordinate + axes => diag_cs%remap_axesTL(c) + nk = axes%nz + allocate( axes%mask3d(G%isd:G%ied,G%jsd:G%jed,nk), source=0. ) + call diag_remap_calc_hmask(diag_cs%diag_remap_cs(c), G, axes%mask3d) + + h_axes => diag_cs%remap_axesTL(c) ! Use the h-point masks to generate the u-, v- and q- masks + + ! Level/layer u-points in diagnostic coordinate + axes => diag_cs%remap_axesCuL(c) + call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at u-layers') + call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated') + allocate( axes%mask3d(G%IsdB:G%IedB,G%jsd:G%jed,nk), source=0. ) + do k = 1, nk ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec + if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j,k) > 0.) axes%mask3d(I,j,k) = 1. + enddo ; enddo ; enddo + + ! Level/layer v-points in diagnostic coordinate + axes => diag_cs%remap_axesCvL(c) + call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at v-layers') + call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated') + allocate( axes%mask3d(G%isd:G%ied,G%JsdB:G%JedB,nk), source=0. ) + do k = 1, nk ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,J,k) = 1. + enddo ; enddo ; enddo + + ! Level/layer q-points in diagnostic coordinate + axes => diag_cs%remap_axesBL(c) + call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at q-layers') + call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated') + allocate( axes%mask3d(G%IsdB:G%IedB,G%JsdB:G%JedB,nk), source=0. ) + do k = 1, nk ; do J=G%jsc-1,G%jec ; do I=G%isc-1,G%iec + if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + & + h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(I,J,k) = 1. + enddo ; enddo ; enddo + + ! Interface h-points in diagnostic coordinate (w-point) + axes => diag_cs%remap_axesTi(c) + call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at h-interfaces') + call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated') + allocate( axes%mask3d(G%isd:G%ied,G%jsd:G%jed,nk+1), source=0. ) + do J=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + if (h_axes%mask3d(i,j,1) > 0.) axes%mask3d(i,J,1) = 1. + do K = 2, nk + if (h_axes%mask3d(i,j,k-1) + h_axes%mask3d(i,j,k) > 0.) axes%mask3d(i,J,k) = 1. + enddo + if (h_axes%mask3d(i,j,nk) > 0.) axes%mask3d(i,J,nk+1) = 1. + enddo ; enddo + + h_axes => diag_cs%remap_axesTi(c) ! Use the w-point masks to generate the u-, v- and q- masks + + ! Interface u-points in diagnostic coordinate + axes => diag_cs%remap_axesCui(c) + call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at u-interfaces') + call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated') + allocate( axes%mask3d(G%IsdB:G%IedB,G%jsd:G%jed,nk+1), source=0. ) + do k = 1, nk+1 ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec + if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j,k) > 0.) axes%mask3d(I,j,k) = 1. + enddo ; enddo ; enddo + + ! Interface v-points in diagnostic coordinate + axes => diag_cs%remap_axesCvi(c) + call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at v-interfaces') + call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated') + allocate( axes%mask3d(G%isd:G%ied,G%JsdB:G%JedB,nk+1), source=0. ) + do k = 1, nk+1 ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,J,k) = 1. + enddo ; enddo ; enddo + + ! Interface q-points in diagnostic coordinate + axes => diag_cs%remap_axesBi(c) + call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at q-interfaces') + call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated') + allocate( axes%mask3d(G%IsdB:G%IedB,G%JsdB:G%JedB,nk+1), source=0. ) + do k = 1, nk ; do J=G%jsc-1,G%jec ; do I=G%isc-1,G%iec + if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + & + h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(I,J,k) = 1. + enddo ; enddo ; enddo + endif + enddo + + !Allocate and initialize the downsampled masks for the axes + call set_masks_for_axes_dsamp(G, diag_cs) + +end subroutine set_masks_for_axes + +subroutine set_masks_for_axes_dsamp(G, diag_cs) + type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. + type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + ! Local variables + integer :: c, dl + type(axes_grp), pointer :: axes => NULL() ! Current axes, for convenience + + !Each downsampled axis needs both downsampled and non-downsampled mask + !The downsampled mask is needed for sending out the diagnostics output via diag_manager + !The non-downsampled mask is needed for downsampling the diagnostics field + do dl=2,MAX_DSAMP_LEV + if (dl /= 2) call MOM_error(FATAL, "set_masks_for_axes_dsamp: Downsample level other than 2 is not supported!") + do c=1, diag_cs%num_diag_coords + ! Level/layer h-points in diagnostic coordinate + axes => diag_cs%remap_axesTL(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, & + dl, G%isc, G%jsc, G%isd, G%jsd, & + G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Level/layer u-points in diagnostic coordinate + axes => diag_cs%remap_axesCuL(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, & + dl, G%IscB, G%jsc, G%IsdB, G%jsd, & + G%HId2%IscB, G%HId2%IecB, G%HId2%jsc, G%HId2%jec, G%HId2%IsdB, G%HId2%IedB, G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Level/layer v-points in diagnostic coordinate + axes => diag_cs%remap_axesCvL(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, & + dl, G%isc, G%JscB, G%isd, G%JsdB, & + G%HId2%isc, G%HId2%iec, G%HId2%JscB, G%HId2%JecB, G%HId2%isd, G%HId2%ied, G%HId2%JsdB, G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Level/layer q-points in diagnostic coordinate + axes => diag_cs%remap_axesBL(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, & + dl, G%IscB, G%JscB, G%IsdB, G%JsdB, & + G%HId2%IscB, G%HId2%IecB, G%HId2%JscB, G%HId2%JecB, G%HId2%IsdB, G%HId2%IedB, G%HId2%JsdB, G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Interface h-points in diagnostic coordinate (w-point) + axes => diag_cs%remap_axesTi(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, & + dl, G%isc, G%jsc, G%isd, G%jsd, & + G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Interface u-points in diagnostic coordinate + axes => diag_cs%remap_axesCui(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, & + dl, G%IscB, G%jsc, G%IsdB, G%jsd, & + G%HId2%IscB, G%HId2%IecB, G%HId2%jsc, G%HId2%jec, G%HId2%IsdB, G%HId2%IedB, G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Interface v-points in diagnostic coordinate + axes => diag_cs%remap_axesCvi(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, & + dl, G%isc, G%JscB, G%isd, G%JsdB, & + G%HId2%isc, G%HId2%iec, G%HId2%JscB, G%HId2%JecB, G%HId2%isd, G%HId2%ied, G%HId2%JsdB, G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Interface q-points in diagnostic coordinate + axes => diag_cs%remap_axesBi(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, & + dl, G%IscB, G%JscB, G%IsdB, G%JsdB, & + G%HId2%IscB, G%HId2%IecB, G%HId2%JscB, G%HId2%JecB, G%HId2%IsdB, G%HId2%IedB, G%HId2%JsdB, G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-downsampled mask + enddo + enddo +end subroutine set_masks_for_axes_dsamp + +!> Attaches the id of cell areas to axes groups for use with cell_measures +subroutine diag_register_area_ids(diag_cs, id_area_t, id_area_q) + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure + integer, optional, intent(in) :: id_area_t !< Diag_mediator id for area of h-cells + integer, optional, intent(in) :: id_area_q !< Diag_mediator id for area of q-cells + ! Local variables + integer :: fms_id, i + if (present(id_area_t)) then + fms_id = diag_cs%diags(id_area_t)%fms_diag_id + diag_cs%axesT1%id_area = fms_id + diag_cs%axesTi%id_area = fms_id + diag_cs%axesTL%id_area = fms_id + do i=1, diag_cs%num_diag_coords + diag_cs%remap_axesTL(i)%id_area = fms_id + diag_cs%remap_axesTi(i)%id_area = fms_id + enddo + endif + if (present(id_area_q)) then + fms_id = diag_cs%diags(id_area_q)%fms_diag_id + diag_cs%axesB1%id_area = fms_id + diag_cs%axesBi%id_area = fms_id + diag_cs%axesBL%id_area = fms_id + do i=1, diag_cs%num_diag_coords + diag_cs%remap_axesBL(i)%id_area = fms_id + diag_cs%remap_axesBi(i)%id_area = fms_id + enddo + endif +end subroutine diag_register_area_ids + +!> Sets a handle inside diagnostics mediator to associate 3d cell measures +subroutine register_cell_measure(G, diag, Time) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(diag_ctrl), target, intent(inout) :: diag !< Regulates diagnostic output + type(time_type), intent(in) :: Time !< Model time + ! Local variables + integer :: id + id = register_diag_field('ocean_model', 'volcello', diag%axesTL, & + Time, 'Ocean grid-cell volume', 'm3', & + standard_name='ocean_volume', v_extensive=.true., & + x_cell_method='sum', y_cell_method='sum') + call diag_associate_volume_cell_measure(diag, id) + +end subroutine register_cell_measure + +!> Attaches the id of cell volumes to axes groups for use with cell_measures +subroutine diag_associate_volume_cell_measure(diag_cs, id_h_volume) + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure + integer, intent(in) :: id_h_volume !< Diag_manager id for volume of h-cells + ! Local variables + type(diag_type), pointer :: tmp => NULL() + + if (id_h_volume<=0) return ! Do nothing + diag_cs%volume_cell_measure_dm_id = id_h_volume ! Record for diag_get_volume_cell_measure_dm_id() + + ! Set the cell measure for this axes group to the FMS id in this coordinate system + diag_cs%diags(id_h_volume)%axes%id_volume = diag_cs%diags(id_h_volume)%fms_diag_id + + tmp => diag_cs%diags(id_h_volume)%next ! First item in the list, if any + do while (associated(tmp)) + ! Set the cell measure for this axes group to the FMS id in this coordinate system + tmp%axes%id_volume = tmp%fms_diag_id + tmp => tmp%next ! Move to next axes group for this field + enddo + +end subroutine diag_associate_volume_cell_measure + +!> Returns diag_manager id for cell measure of h-cells +integer function diag_get_volume_cell_measure_dm_id(diag_cs) + type(diag_ctrl), intent(in) :: diag_cs !< Diagnostics control structure + + diag_get_volume_cell_measure_dm_id = diag_cs%volume_cell_measure_dm_id + +end function diag_get_volume_cell_measure_dm_id + +!> Defines a group of "axes" from list of handles +subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_number, & + x_cell_method, y_cell_method, v_cell_method, & + is_h_point, is_q_point, is_u_point, is_v_point, & + is_layer, is_interface, & + is_native, needs_remapping, needs_interpolating, & + xyave_axes) + type(diag_ctrl), target, intent(in) :: diag_cs !< Diagnostics control structure + integer, dimension(:), intent(in) :: handles !< A list of 1D axis handles + type(axes_grp), intent(out) :: axes !< The group of 1D axes + integer, optional, intent(in) :: nz !< Number of layers in this diagnostic grid + integer, optional, intent(in) :: vertical_coordinate_number !< Index number for vertical coordinate + character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: v_cell_method !< A vertical direction cell method used to construct + !! the "cell_methods" attribute in CF convention + logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point + !! located fields + logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point + !! located fields + logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for + !! u-point located fields + logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for + !! v-point located fields + logical, optional, intent(in) :: is_layer !< If true, indicates that this axes group is + !! for a layer vertically-located field. + logical, optional, intent(in) :: is_interface !< If true, indicates that this axes group + !! is for an interface vertically-located field. + logical, optional, intent(in) :: is_native !< If true, indicates that this axes group is + !! for a native model grid. False for any other grid. + logical, optional, intent(in) :: needs_remapping !< If true, indicates that this axes group is + !! for a intensive layer-located field that must + !! be remapped to these axes. Used for rank>2. + logical, optional, intent(in) :: needs_interpolating !< If true, indicates that this axes group + !! is for a sampled interface-located field that must + !! be interpolated to these axes. Used for rank>2. + type(axes_grp), optional, target :: xyave_axes !< The corresponding axes group for horizontally + !! area-average diagnostics + ! Local variables + integer :: n + + n = size(handles) + if (n<1 .or. n>3) call MOM_error(FATAL, "define_axes_group: wrong size for list of handles!") + allocate( axes%handles(n) ) + axes%id = i2s(handles, n) ! Identifying string + axes%rank = n + axes%handles(:) = handles(:) + axes%diag_cs => diag_cs ! A [circular] link back to the diag_cs structure + if (present(x_cell_method)) then + if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set x_cell_method for rank<2.') + axes%x_cell_method = trim(x_cell_method) + else + axes%x_cell_method = '' + endif + if (present(y_cell_method)) then + if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set y_cell_method for rank<2.') + axes%y_cell_method = trim(y_cell_method) + else + axes%y_cell_method = '' + endif + if (present(v_cell_method)) then + if (axes%rank/=1 .and. axes%rank/=3) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set v_cell_method for rank<>1 or 3.') + axes%v_cell_method = trim(v_cell_method) + else + axes%v_cell_method = '' + endif + + if (present(nz)) axes%nz = nz + if (present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number + if (present(is_h_point)) axes%is_h_point = is_h_point + if (present(is_q_point)) axes%is_q_point = is_q_point + if (present(is_u_point)) axes%is_u_point = is_u_point + if (present(is_v_point)) axes%is_v_point = is_v_point + if (present(is_layer)) axes%is_layer = is_layer + if (present(is_interface)) axes%is_interface = is_interface + if (present(is_native)) axes%is_native = is_native + if (present(needs_remapping)) axes%needs_remapping = needs_remapping + if (present(needs_interpolating)) axes%needs_interpolating = needs_interpolating + if (present(xyave_axes)) axes%xyave_axes => xyave_axes + + ! Setup masks for this axes group + axes%mask2d => null() + if (axes%rank==2) then + if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT + if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu + if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv + if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu + endif + ! A static 3d mask for non-native coordinates can only be setup when a grid is available + axes%mask3d => null() + if (axes%rank==3 .and. axes%is_native) then + ! Native variables can/should use the native masks copied into diag_cs + if (axes%is_layer) then + if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTL + if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCuL + if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvL + if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBL + elseif (axes%is_interface) then + if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTi + if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCui + if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvi + if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBi + endif + endif + +end subroutine define_axes_group + +!> Defines a group of downsampled "axes" from list of handles +subroutine define_axes_group_dsamp(diag_cs, handles, axes, dl, nz, vertical_coordinate_number, & + x_cell_method, y_cell_method, v_cell_method, & + is_h_point, is_q_point, is_u_point, is_v_point, & + is_layer, is_interface, & + is_native, needs_remapping, needs_interpolating, & + xyave_axes) + type(diag_ctrl), target, intent(in) :: diag_cs !< Diagnostics control structure + integer, dimension(:), intent(in) :: handles !< A list of 1D axis handles + type(axes_grp), intent(out) :: axes !< The group of 1D axes + integer, intent(in) :: dl !< Downsample level + integer, optional, intent(in) :: nz !< Number of layers in this diagnostic grid + integer, optional, intent(in) :: vertical_coordinate_number !< Index number for vertical coordinate + character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: v_cell_method !< A vertical direction cell method used to construct + !! the "cell_methods" attribute in CF convention + logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point + !! located fields + logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point + !! located fields + logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for + !! u-point located fields + logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for + !! v-point located fields + logical, optional, intent(in) :: is_layer !< If true, indicates that this axes group is + !! for a layer vertically-located field. + logical, optional, intent(in) :: is_interface !< If true, indicates that this axes group + !! is for an interface vertically-located field. + logical, optional, intent(in) :: is_native !< If true, indicates that this axes group is + !! for a native model grid. False for any other grid. + logical, optional, intent(in) :: needs_remapping !< If true, indicates that this axes group is + !! for a intensive layer-located field that must + !! be remapped to these axes. Used for rank>2. + logical, optional, intent(in) :: needs_interpolating !< If true, indicates that this axes group + !! is for a sampled interface-located field that must + !! be interpolated to these axes. Used for rank>2. + type(axes_grp), optional, target :: xyave_axes !< The corresponding axes group for horizontally + !! area-average diagnostics + ! Local variables + integer :: n + + n = size(handles) + if (n<1 .or. n>3) call MOM_error(FATAL, "define_axes_group: wrong size for list of handles!") + allocate( axes%handles(n) ) + axes%id = i2s(handles, n) ! Identifying string + axes%rank = n + axes%handles(:) = handles(:) + axes%diag_cs => diag_cs ! A [circular] link back to the diag_cs structure + if (present(x_cell_method)) then + if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set x_cell_method for rank<2.') + axes%x_cell_method = trim(x_cell_method) + else + axes%x_cell_method = '' + endif + if (present(y_cell_method)) then + if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set y_cell_method for rank<2.') + axes%y_cell_method = trim(y_cell_method) + else + axes%y_cell_method = '' + endif + if (present(v_cell_method)) then + if (axes%rank/=1 .and. axes%rank/=3) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set v_cell_method for rank<>1 or 3.') + axes%v_cell_method = trim(v_cell_method) + else + axes%v_cell_method = '' + endif + axes%downsample_level = dl + if (present(nz)) axes%nz = nz + if (present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number + if (present(is_h_point)) axes%is_h_point = is_h_point + if (present(is_q_point)) axes%is_q_point = is_q_point + if (present(is_u_point)) axes%is_u_point = is_u_point + if (present(is_v_point)) axes%is_v_point = is_v_point + if (present(is_layer)) axes%is_layer = is_layer + if (present(is_interface)) axes%is_interface = is_interface + if (present(is_native)) axes%is_native = is_native + if (present(needs_remapping)) axes%needs_remapping = needs_remapping + if (present(needs_interpolating)) axes%needs_interpolating = needs_interpolating + if (present(xyave_axes)) axes%xyave_axes => xyave_axes + + ! Setup masks for this axes group + + axes%mask2d => null() + if (axes%rank==2) then + if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT + if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu + if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv + if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu + endif + ! A static 3d mask for non-native coordinates can only be setup when a grid is available + axes%mask3d => null() + if (axes%rank==3 .and. axes%is_native) then + ! Native variables can/should use the native masks copied into diag_cs + if (axes%is_layer) then + if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTL + if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCuL + if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvL + if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBL + elseif (axes%is_interface) then + if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTi + if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCui + if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvi + if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBi + endif + endif + + axes%dsamp(dl)%mask2d => null() + if (axes%rank==2) then + if (axes%is_h_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dT + if (axes%is_u_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCu + if (axes%is_v_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCv + if (axes%is_q_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dBu + endif + ! A static 3d mask for non-native coordinates can only be setup when a grid is available + axes%dsamp(dl)%mask3d => null() + if (axes%rank==3 .and. axes%is_native) then + ! Native variables can/should use the native masks copied into diag_cs + if (axes%is_layer) then + if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTL + if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCuL + if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvL + if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBL + elseif (axes%is_interface) then + if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTi + if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCui + if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvi + if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBi + endif + endif + +end subroutine define_axes_group_dsamp + +!> Set up the array extents for doing diagnostics +subroutine set_diag_mediator_grid(G, diag_cs) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output + + diag_cs%is = G%isc - (G%isd-1) ; diag_cs%ie = G%iec - (G%isd-1) + diag_cs%js = G%jsc - (G%jsd-1) ; diag_cs%je = G%jec - (G%jsd-1) + diag_cs%isd = G%isd ; diag_cs%ied = G%ied + diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed + +end subroutine set_diag_mediator_grid + +!> Make a real scalar diagnostic available for averaging or output +subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field !< real value being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + + ! Local variables + real :: locfield + logical :: used, is_stat + type(diag_type), pointer :: diag => null() + + if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) + is_stat = .false. ; if (present(is_static)) is_stat = is_static + + ! Iterate over list of diag 'variants', e.g. CMOR aliases, call send_data + ! for each one. + call assert(diag_field_id < diag_cs%next_free_diag_id, & + 'post_data_0d: Unregistered diagnostic id') + diag => diag_cs%diags(diag_field_id) + + do while (associated(diag)) + locfield = field + if (diag%conversion_factor /= 0.) & + locfield = locfield * diag%conversion_factor + + if (diag_cs%diag_as_chksum) then + call chksum0(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit) + elseif (is_stat) then + used = send_data_infra(diag%fms_diag_id, locfield) + elseif (diag_cs%ave_enabled) then + used = send_data_infra(diag%fms_diag_id, locfield, diag_cs%time_end) + endif + diag => diag%next + enddo + + if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) +end subroutine post_data_0d + +!> Make a real 1-d array diagnostic available for averaging or output +subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, target, intent(in) :: field(:) !< 1-d array being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + + ! Local variables + logical :: used ! The return value of send_data is not used for anything. + real, dimension(:), pointer :: locfield => NULL() + logical :: is_stat + integer :: k, ks, ke + type(diag_type), pointer :: diag => null() + + if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) + is_stat = .false. ; if (present(is_static)) is_stat = is_static + + ! Iterate over list of diag 'variants', e.g. CMOR aliases. + call assert(diag_field_id < diag_cs%next_free_diag_id, & + 'post_data_1d_k: Unregistered diagnostic id') + diag => diag_cs%diags(diag_field_id) + do while (associated(diag)) + + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then + ks = lbound(field,1) ; ke = ubound(field,1) + allocate( locfield( ks:ke ) ) + + do k=ks,ke + if (field(k) == diag_cs%missing_value) then + locfield(k) = diag_cs%missing_value + else + locfield(k) = field(k) * diag%conversion_factor + endif + enddo + else + locfield => field + endif + + if (diag_cs%diag_as_chksum) then + call zchksum(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit) + elseif (is_stat) then + used = send_data_infra(diag%fms_diag_id, locfield) + elseif (diag_cs%ave_enabled) then + used = send_data_infra(diag%fms_diag_id, locfield, time=diag_cs%time_end, weight=diag_cs%time_int) + endif + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) + + diag => diag%next + enddo + + if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) +end subroutine post_data_1d_k + +!> Make a real 2-d array diagnostic available for averaging or output +subroutine post_data_2d(diag_field_id, field, diag_cs, is_static, mask) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + + ! Local variables + type(diag_type), pointer :: diag => null() + + if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) + + ! Iterate over list of diag 'variants' (e.g. CMOR aliases) and post each. + call assert(diag_field_id < diag_cs%next_free_diag_id, & + 'post_data_2d: Unregistered diagnostic id') + diag => diag_cs%diags(diag_field_id) + do while (associated(diag)) + call post_data_2d_low(diag, field, diag_cs, is_static, mask) + diag => diag%next + enddo + + if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) +end subroutine post_data_2d + +!> Make a real 2-d array diagnostic available for averaging or output +!! using a diag_type instead of an integer id. +subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + + ! Local variables + real, dimension(:,:), pointer :: locfield + real, dimension(:,:), pointer :: locmask + character(len=300) :: mesg + logical :: used, is_stat + integer :: cszi, cszj, dszi, dszj + integer :: isv, iev, jsv, jev, i, j, isv_o,jsv_o + real, dimension(:,:), allocatable, target :: locfield_dsamp + real, dimension(:,:), allocatable, target :: locmask_dsamp + integer :: dl + + locfield => NULL() + locmask => NULL() + is_stat = .false. ; if (present(is_static)) is_stat = is_static + + ! Determine the propery array indices, noting that because of the (:,:) + ! declaration of field, symmetric arrays are using a SW-grid indexing, + ! but non-symmetric arrays are using a NE-grid indexing. Send_data + ! actually only uses the difference between ie and is to determine + ! the output data size and assumes that halos are symmetric. + isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je + + cszi = diag_cs%ie-diag_cs%is +1 ; dszi = diag_cs%ied-diag_cs%isd +1 + cszj = diag_cs%je-diag_cs%js +1 ; dszj = diag_cs%jed-diag_cs%jsd +1 + if ( size(field,1) == dszi ) then + isv = diag_cs%is ; iev = diag_cs%ie ! Data domain + elseif ( size(field,1) == dszi + 1 ) then + isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain + elseif ( size(field,1) == cszi) then + isv = 1 ; iev = cszi ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv = 1 ; iev = cszi+1 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg)) + endif + + if ( size(field,2) == dszj ) then + jsv = diag_cs%js ; jev = diag_cs%je ! Data domain + elseif ( size(field,2) == dszj + 1 ) then + jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain + elseif ( size(field,2) == cszj ) then + jsv = 1 ; jev = cszj ! Computational domain + elseif ( size(field,2) == cszj+1 ) then + jsv = 1 ; jev = cszj+1 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg)) + endif + + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then + allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2) ) ) + do j=jsv,jev ; do i=isv,iev + if (field(i,j) == diag_cs%missing_value) then + locfield(i,j) = diag_cs%missing_value + else + locfield(i,j) = field(i,j) * diag%conversion_factor + endif + enddo ; enddo + locfield(isv:iev,jsv:jev) = field(isv:iev,jsv:jev) * diag%conversion_factor + else + locfield => field + endif + + if (present(mask)) then + locmask => mask + elseif (.NOT. is_stat) then + if (associated(diag%axes%mask2d)) locmask => diag%axes%mask2d + endif + + dl=1 + if (.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet + !Downsample the diag field and mask (if present) + if (dl > 1) then + isv_o = isv ; jsv_o = jsv + call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) + locfield => locfield_dsamp + if (present(mask)) then + call downsample_field_2d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev) + locmask => locmask_dsamp + elseif (associated(diag%axes%dsamp(dl)%mask2d)) then + locmask => diag%axes%dsamp(dl)%mask2d + endif + endif + + if (diag_cs%diag_as_chksum) then + if (diag%axes%is_h_point) then + call hchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + elseif (diag%axes%is_u_point) then + call uchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + elseif (diag%axes%is_v_point) then + call vchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + elseif (diag%axes%is_q_point) then + call Bchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + else + call MOM_error(FATAL, "post_data_2d_low: unknown axis type.") + endif + else + if (is_stat) then + if (present(mask)) then + call assert(size(locfield) == size(locmask), & + 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str) + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=locmask) + !elseif (associated(diag%axes%mask2d)) then + ! used = send_data(diag%fms_diag_id, locfield, & + ! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%axes%mask2d) + else + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) + endif + elseif (diag_cs%ave_enabled) then + if (associated(locmask)) then + call assert(size(locfield) == size(locmask), & + 'post_data_2d_low: mask size mismatch: '//diag%debug_str) + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int, rmask=locmask) + else + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int) + endif + endif + endif + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) & + deallocate( locfield ) +end subroutine post_data_2d_low + +!> Make a real 3-d array diagnostic available for averaging or output. +subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) + + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + real, dimension(:,:,:), & + target, optional, intent(in) :: alt_h !< An alternate thickness to use for vertically + !! remapping this diagnostic [H ~> m or kg m-2]. + + ! Local variables + type(diag_type), pointer :: diag => null() + real, dimension(:,:,:), allocatable :: remapped_field + logical :: staggered_in_x, staggered_in_y, dz_diag_needed, dz_begin_needed + real, dimension(:,:,:), pointer :: h_diag => NULL() + real, dimension(diag_cs%G%isd:diag_cS%G%ied, diag_cs%G%jsd:diag_cS%G%jed, diag_cs%GV%ke) :: & + dz_diag, & ! Layer vertical extents for remapping [Z ~> m] + dz_begin ! Layer vertical extents for remapping extensive quantities [Z ~> m] + + if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) + + ! For intensive variables only, we can choose to use a different diagnostic grid to map to + if (present(alt_h)) then + h_diag => alt_h + else + h_diag => diag_cs%h + endif + + ! Iterate over list of diag 'variants', e.g. CMOR aliases, different vertical + ! grids, and post each. + call assert(diag_field_id < diag_cs%next_free_diag_id, & + 'post_data_3d: Unregistered diagnostic id') + + if (diag_cs%show_call_tree) & + call callTree_enter("post_data_3d("//trim(diag_cs%diags(diag_field_id)%debug_str)//")") + + ! Find out whether there are any z-based diagnostics + diag => diag_cs%diags(diag_field_id) + dz_diag_needed = .false. ; dz_begin_needed = .false. + do while (associated(diag)) + if (diag%v_extensive .and. .not.diag%axes%is_native) then + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) & + dz_begin_needed = .true. + elseif (diag%axes%needs_remapping .or. diag%axes%needs_interpolating) then + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) & + dz_diag_needed = .true. + endif + diag => diag%next + enddo + + ! Determine the diagnostic grid spacing in height units, if it is needed. + if (dz_diag_needed) then + call thickness_to_dz(h_diag, diag_cs%tv, dz_diag, diag_cs%G, diag_cs%GV, diag_cs%US, halo_size=1) + endif + if (dz_begin_needed) then + call thickness_to_dz(diag_cs%h_begin, diag_cs%tv, dz_begin, diag_cs%G, diag_cs%GV, diag_cs%US, halo_size=1) + endif + + diag => diag_cs%diags(diag_field_id) + do while (associated(diag)) + call assert(associated(diag%axes), 'post_data_3d: axes is not associated') + + staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point + staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point + + if (diag%v_extensive .and. .not.diag%axes%is_native) then + ! The field is vertically integrated and needs to be re-gridded + if (present(mask)) then + call MOM_error(FATAL,"post_data_3d: no mask for regridded field.") + endif + + if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) + allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) then + call vertically_reintegrate_diag_field( & + diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, & + dz_begin, diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & + staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) + else + call vertically_reintegrate_diag_field( & + diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, & + diag_cs%h_begin, diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & + staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) + endif + if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) + if (associated(diag%axes%mask3d)) then + ! Since 3d masks do not vary in the vertical, just use as much as is + ! needed. + call post_data_3d_low(diag, remapped_field, diag_cs, is_static, & + mask=diag%axes%mask3d) + else + call post_data_3d_low(diag, remapped_field, diag_cs, is_static) + endif + if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) + deallocate(remapped_field) + if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) + elseif (diag%axes%needs_remapping) then + ! Remap this field to another vertical coordinate. + if (present(mask)) then + call MOM_error(FATAL,"post_data_3d: no mask for regridded field.") + endif + + if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) + allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) then + call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & + diag_cs%G, diag_cs%GV, diag_cs%US, dz_diag, staggered_in_x, staggered_in_y, & + diag%axes%mask3d, field, remapped_field) + else + call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & + diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, staggered_in_x, staggered_in_y, & + diag%axes%mask3d, field, remapped_field) + endif + if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) + if (associated(diag%axes%mask3d)) then + ! Since 3d masks do not vary in the vertical, just use as much as is + ! needed. + call post_data_3d_low(diag, remapped_field, diag_cs, is_static, & + mask=diag%axes%mask3d) + else + call post_data_3d_low(diag, remapped_field, diag_cs, is_static) + endif + if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) + deallocate(remapped_field) + if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) + elseif (diag%axes%needs_interpolating) then + ! Interpolate this field to another vertical coordinate. + if (present(mask)) then + call MOM_error(FATAL,"post_data_3d: no mask for regridded field.") + endif + + if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) + allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz+1)) + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) then + call vertically_interpolate_diag_field(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & + diag_cs%G, dz_diag, staggered_in_x, staggered_in_y, & + diag%axes%mask3d, field, remapped_field) + else + call vertically_interpolate_diag_field(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & + diag_cs%G, h_diag, staggered_in_x, staggered_in_y, & + diag%axes%mask3d, field, remapped_field) + endif + if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) + if (associated(diag%axes%mask3d)) then + ! Since 3d masks do not vary in the vertical, just use as much as is + ! needed. + call post_data_3d_low(diag, remapped_field, diag_cs, is_static, & + mask=diag%axes%mask3d) + else + call post_data_3d_low(diag, remapped_field, diag_cs, is_static) + endif + if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) + deallocate(remapped_field) + if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) + else + call post_data_3d_low(diag, field, diag_cs, is_static, mask) + endif + diag => diag%next + enddo + if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) + + if (diag_cs%show_call_tree) & + call callTree_leave("post_data_3d("//trim(diag_cs%diags(diag_field_id)%debug_str)//")") + +end subroutine post_data_3d + +!> Make a real 3-d array diagnostic available for averaging or output +!! using a diag_type instead of an integer id. +subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + real, target, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + + ! Local variables + real, dimension(:,:,:), pointer :: locfield + real, dimension(:,:,:), pointer :: locmask + character(len=300) :: mesg + logical :: used ! The return value of send_data is not used for anything. + logical :: staggered_in_x, staggered_in_y + logical :: is_stat + integer :: cszi, cszj, dszi, dszj + integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o,jsv_o + real, dimension(:,:,:), allocatable, target :: locfield_dsamp + real, dimension(:,:,:), allocatable, target :: locmask_dsamp + integer :: dl + + locfield => NULL() + locmask => NULL() + is_stat = .false. ; if (present(is_static)) is_stat = is_static + + ! Determine the proper array indices, noting that because of the (:,:) + ! declaration of field, symmetric arrays are using a SW-grid indexing, + ! but non-symmetric arrays are using a NE-grid indexing. Send_data + ! actually only uses the difference between ie and is to determine + ! the output data size and assumes that halos are symmetric. + isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je + + cszi = (diag_cs%ie-diag_cs%is) +1 ; dszi = (diag_cs%ied-diag_cs%isd) +1 + cszj = (diag_cs%je-diag_cs%js) +1 ; dszj = (diag_cs%jed-diag_cs%jsd) +1 + if ( size(field,1) == dszi ) then + isv = diag_cs%is ; iev = diag_cs%ie ! Data domain + elseif ( size(field,1) == dszi + 1 ) then + isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain + elseif ( size(field,1) == cszi) then + isv = 1 ; iev = cszi ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv = 1 ; iev = cszi+1 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) + endif + + if ( size(field,2) == dszj ) then + jsv = diag_cs%js ; jev = diag_cs%je ! Data domain + elseif ( size(field,2) == dszj + 1 ) then + jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain + elseif ( size(field,2) == cszj ) then + jsv = 1 ; jev = cszj ! Computational domain + elseif ( size(field,2) == cszj+1 ) then + jsv = 1 ; jev = cszj+1 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) + endif + + ks = lbound(field,3) ; ke = ubound(field,3) + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then + allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2), ks:ke ) ) + ! locfield(:,:,:) = 0.0 ! Zeroing out this array would be a good idea, but it appears + ! not to be necessary. + isv_c = isv ; jsv_c = jsv + if (diag%fms_xyave_diag_id>0) then + staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point + staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point + ! When averaging a staggered field, edge points are always required. + if (staggered_in_x) isv_c = iev - (diag_cs%ie - diag_cs%is) - 1 + if (staggered_in_y) jsv_c = jev - (diag_cs%je - diag_cs%js) - 1 + if (isv_c < lbound(locfield,1)) call MOM_error(FATAL, & + "It is an error to average a staggered diagnostic field that does not "//& + "have i-direction space to represent the symmetric computational domain.") + if (jsv_c < lbound(locfield,2)) call MOM_error(FATAL, & + "It is an error to average a staggered diagnostic field that does not "//& + "have j-direction space to represent the symmetric computational domain.") + endif + + do k=ks,ke ; do j=jsv,jev ; do i=isv,iev + if (field(i,j,k) == diag_cs%missing_value) then + locfield(i,j,k) = diag_cs%missing_value + else + locfield(i,j,k) = field(i,j,k) * diag%conversion_factor + endif + enddo ; enddo ; enddo + else + locfield => field + endif + + if (present(mask)) then + locmask => mask + elseif (associated(diag%axes%mask3d)) then + locmask => diag%axes%mask3d + endif + + dl=1 + if (.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet + !Downsample the diag field and mask (if present) + if (dl > 1) then + isv_o = isv ; jsv_o = jsv + call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) + locfield => locfield_dsamp + if (present(mask)) then + call downsample_field_3d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev) + locmask => locmask_dsamp + elseif (associated(diag%axes%dsamp(dl)%mask3d)) then + locmask => diag%axes%dsamp(dl)%mask3d + endif + endif + + if (diag%fms_diag_id>0) then + if (diag_cs%diag_as_chksum) then + if (diag%axes%is_h_point) then + call hchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + elseif (diag%axes%is_u_point) then + call uchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + elseif (diag%axes%is_v_point) then + call vchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + elseif (diag%axes%is_q_point) then + call Bchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + else + call MOM_error(FATAL, "post_data_3d_low: unknown axis type.") + endif + else + if (is_stat) then + if (present(mask)) then + call assert(size(locfield) == size(locmask), & + 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str) + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=locmask) + !elseif (associated(diag%axes%mask2d)) then + ! used = send_data(diag%fms_diag_id, locfield, & + ! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%axes%mask2d) + else + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) + endif + elseif (diag_cs%ave_enabled) then + if (associated(locmask)) then + call assert(size(locfield) == size(locmask), & + 'post_data_3d_low: mask size mismatch: '//diag%debug_str) + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int, rmask=locmask) + else + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int) + endif + endif + endif + endif + + if (diag%fms_xyave_diag_id>0) then + call post_xy_average(diag_cs, diag, locfield) + endif + + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) & + deallocate( locfield ) + +end subroutine post_data_3d_low + +!> Calculate and write out diagnostics that are the product of two 3-d arrays at u-points +subroutine post_product_u(id, u_a, u_b, G, nz, diag, mask, alt_h) + integer, intent(in) :: id !< The ID for this diagnostic + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + integer, intent(in) :: nz !< The size of the arrays in the vertical + real, dimension(G%IsdB:G%IedB, G%jsd:G%jed, nz), & + intent(in) :: u_a !< The first u-point array in arbitrary units [A] + real, dimension(G%IsdB:G%IedB, G%jsd:G%jed, nz), & + intent(in) :: u_b !< The second u-point array in arbitrary units [B] + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask [nondim] + real, target, optional, intent(in) :: alt_h(:,:,:) !< An alternate thickness to use for vertically + !! remapping this diagnostic [H ~> m or kg m-2] + + ! Local variables + real, dimension(G%IsdB:G%IedB, G%jsd:G%jed, nz) :: u_prod ! The product of u_a and u_b [A B] + integer :: i, j, k + + if (id <= 0) return + + do k=1,nz ; do j=G%jsc,G%jec ; do I=G%IscB,G%IecB + u_prod(I,j,k) = u_a(I,j,k) * u_b(I,j,k) + enddo ; enddo ; enddo + call post_data(id, u_prod, diag, mask=mask, alt_h=alt_h) + +end subroutine post_product_u + +!> Calculate and write out diagnostics that are the vertical sum of the product of two 3-d arrays at u-points +subroutine post_product_sum_u(id, u_a, u_b, G, nz, diag) + integer, intent(in) :: id !< The ID for this diagnostic + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + integer, intent(in) :: nz !< The size of the arrays in the vertical + real, dimension(G%IsdB:G%IedB, G%jsd:G%jed, nz), & + intent(in) :: u_a !< The first u-point array in arbitrary units [A] + real, dimension(G%IsdB:G%IedB, G%jsd:G%jed, nz), & + intent(in) :: u_b !< The second u-point array in arbitrary units [B] + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + + real, dimension(G%IsdB:G%IedB, G%jsd:G%jed) :: u_sum ! The vertical sum of the product of u_a and u_b [A B] + integer :: i, j, k + + if (id <= 0) return + + u_sum(:,:) = 0.0 + do k=1,nz ; do j=G%jsc,G%jec ; do I=G%IscB,G%IecB + u_sum(I,j) = u_sum(I,j) + u_a(I,j,k) * u_b(I,j,k) + enddo ; enddo ; enddo + call post_data(id, u_sum, diag) + +end subroutine post_product_sum_u + +!> Calculate and write out diagnostics that are the product of two 3-d arrays at v-points +subroutine post_product_v(id, v_a, v_b, G, nz, diag, mask, alt_h) + integer, intent(in) :: id !< The ID for this diagnostic + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + integer, intent(in) :: nz !< The size of the arrays in the vertical + real, dimension(G%isd:G%ied, G%JsdB:G%JedB, nz), & + intent(in) :: v_a !< The first v-point array in arbitrary units [A] + real, dimension(G%isd:G%ied, G%JsdB:G%JedB, nz), & + intent(in) :: v_b !< The second v-point array in arbitrary units [B] + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask [nondim] + real, target, optional, intent(in) :: alt_h(:,:,:) !< An alternate thickness to use for vertically + !! remapping this diagnostic [H ~> m or kg m-2] + + ! Local variables + real, dimension(G%isd:G%ied, G%JsdB:G%JedB, nz) :: v_prod ! The product of v_a and v_b [A B] + integer :: i, j, k + + if (id <= 0) return + + do k=1,nz ; do J=G%JscB,G%JecB ; do i=G%isc,G%iec + v_prod(i,J,k) = v_a(i,J,k) * v_b(i,J,k) + enddo ; enddo ; enddo + call post_data(id, v_prod, diag, mask=mask, alt_h=alt_h) + +end subroutine post_product_v + +!> Calculate and write out diagnostics that are the vertical sum of the product of two 3-d arrays at v-points +subroutine post_product_sum_v(id, v_a, v_b, G, nz, diag) + integer, intent(in) :: id !< The ID for this diagnostic + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + integer, intent(in) :: nz !< The size of the arrays in the vertical + real, dimension(G%isd:G%ied, G%JsdB:G%JedB, nz), & + intent(in) :: v_a !< The first v-point array in arbitrary units [A] + real, dimension(G%isd:G%ied, G%JsdB:G%JedB, nz), & + intent(in) :: v_b !< The second v-point array in arbitrary units [B] + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + + real, dimension(G%isd:G%ied, G%JsdB:G%JedB) :: v_sum ! The vertical sum of the product of v_a and v_b [A B] + integer :: i, j, k + + if (id <= 0) return + + v_sum(:,:) = 0.0 + do k=1,nz ; do J=G%JscB,G%JecB ; do i=G%isc,G%iec + v_sum(i,J) = v_sum(i,J) + v_a(i,J,k) * v_b(i,J,k) + enddo ; enddo ; enddo + call post_data(id, v_sum, diag) + +end subroutine post_product_sum_v + +!> Post the horizontally area-averaged diagnostic +subroutine post_xy_average(diag_cs, diag, field) + type(diag_type), intent(in) :: diag !< This diagnostic + real, target, intent(in) :: field(:,:,:) !< Diagnostic field + type(diag_ctrl), intent(in) :: diag_cs !< Diagnostics mediator control structure + ! Local variable + real, dimension(size(field,3)) :: averaged_field + logical, dimension(size(field,3)) :: averaged_mask + logical :: staggered_in_x, staggered_in_y, used + integer :: nz, remap_nz, coord + + if (.not. diag_cs%ave_enabled) then + return + endif + + staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point + staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point + + if (diag%axes%is_native) then + call horizontally_average_diag_field(diag_cs%G, diag_cs%GV, diag_cs%h, & + staggered_in_x, staggered_in_y, & + diag%axes%is_layer, diag%v_extensive, & + field, averaged_field, averaged_mask) + else + nz = size(field, 3) + coord = diag%axes%vertical_coordinate_number + remap_nz = diag_cs%diag_remap_cs(coord)%nz + + call assert(diag_cs%diag_remap_cs(coord)%initialized, & + 'post_xy_average: remap_cs not initialized.') + + call assert(IMPLIES(diag%axes%is_layer, nz == remap_nz), & + 'post_xy_average: layer field dimension mismatch.') + call assert(IMPLIES(.not. diag%axes%is_layer, nz == remap_nz+1), & + 'post_xy_average: interface field dimension mismatch.') + + call horizontally_average_diag_field(diag_cs%G, diag_cs%GV, & + diag_cs%diag_remap_cs(coord)%h, & + staggered_in_x, staggered_in_y, & + diag%axes%is_layer, diag%v_extensive, & + field, averaged_field, averaged_mask) + endif + + if (diag_cs%diag_as_chksum) then + call zchksum(averaged_field, trim(diag%debug_str)//'_xyave', & + logunit=diag_CS%chksum_iounit) + else + used = send_data_infra(diag%fms_xyave_diag_id, averaged_field, & + time=diag_cs%time_end, weight=diag_cs%time_int, mask=averaged_mask) + endif +end subroutine post_xy_average + +!> This subroutine enables the accumulation of time averages over the specified time interval. +subroutine enable_averaging(time_int_in, time_end_in, diag_cs) + real, intent(in) :: time_int_in !< The time interval [s] over which any + !! values that are offered are valid. + type(time_type), intent(in) :: time_end_in !< The end time of the valid interval + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output + +! This subroutine enables the accumulation of time averages over the specified time interval. + +! if (num_file==0) return + diag_cs%time_int = time_int_in + diag_cs%time_end = time_end_in + diag_cs%ave_enabled = .true. +end subroutine enable_averaging + +!> Enable the accumulation of time averages over the specified time interval in time units. +subroutine enable_averages(time_int, time_end, diag_CS, T_to_s) + real, intent(in) :: time_int !< The time interval over which any values + !! that are offered are valid [T ~> s]. + type(time_type), intent(in) :: time_end !< The end time of the valid interval. + type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output + real, optional, intent(in) :: T_to_s !< A conversion factor for time_int to [s]. +! This subroutine enables the accumulation of time averages over the specified time interval. + + if (present(T_to_s)) then + diag_cs%time_int = time_int*T_to_s + elseif (associated(diag_CS%US)) then + diag_cs%time_int = time_int*diag_CS%US%T_to_s + else + diag_cs%time_int = time_int + endif + diag_cs%time_end = time_end + diag_cs%ave_enabled = .true. +end subroutine enable_averages + +!> Call this subroutine to avoid averaging any offered fields. +subroutine disable_averaging(diag_cs) + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output + + diag_cs%time_int = 0.0 + diag_cs%ave_enabled = .false. + +end subroutine disable_averaging + +!> Call this subroutine to determine whether the averaging is +!! currently enabled. .true. is returned if it is. +function query_averaging_enabled(diag_cs, time_int, time_end) + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + real, optional, intent(out) :: time_int !< Current setting of diag%time_int [s] + type(time_type), optional, intent(out) :: time_end !< Current setting of diag%time_end + logical :: query_averaging_enabled + + if (present(time_int)) time_int = diag_cs%time_int + if (present(time_end)) time_end = diag_cs%time_end + query_averaging_enabled = diag_cs%ave_enabled +end function query_averaging_enabled + +!> This function returns the valid end time for use with diagnostics that are +!! handled outside of the MOM6 diagnostics infrastructure. +function get_diag_time_end(diag_cs) + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(time_type) :: get_diag_time_end + ! This function returns the valid end time for diagnostics that are handled + ! outside of the MOM6 infrastructure, such as via the generic tracer code. + + get_diag_time_end = diag_cs%time_end +end function get_diag_time_end + +!> Returns the "diag_mediator" handle for a group (native, CMOR, z-coord, ...) of diagnostics +!! derived from one field. +integer function register_diag_field(module_name, field_name, axes_in, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & + x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive) + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axes_grp), target, intent(in) :: axes_in !< Container w/ up to 3 integer handles that + !! indicates axes for this field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_data calls (not used in MOM?) + logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to + !! have no attribute. If present, this overrides the + !! default constructed from the default for + !! each individual axis direction. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically + !! integrated). Default/absent for intensive. + ! Local variables + real :: MOM_missing_value + type(diag_ctrl), pointer :: diag_cs + type(axes_grp), pointer :: remap_axes + type(axes_grp), pointer :: axes + type(axes_grp), pointer :: axes_d2 + integer :: dm_id, i, dl + character(len=256) :: msg, cm_string + character(len=256) :: new_module_name + character(len=480) :: module_list, var_list + integer :: num_modnm, num_varnm + logical :: active + + diag_cs => axes_in%diag_cs + + ! Check if the axes match a standard grid axis. + ! If not, allocate the new axis and copy the contents. + if (axes_in%id == diag_cs%axesTL%id) then + axes => diag_cs%axesTL + elseif (axes_in%id == diag_cs%axesBL%id) then + axes => diag_cs%axesBL + elseif (axes_in%id == diag_cs%axesCuL%id) then + axes => diag_cs%axesCuL + elseif (axes_in%id == diag_cs%axesCvL%id) then + axes => diag_cs%axesCvL + elseif (axes_in%id == diag_cs%axesTi%id) then + axes => diag_cs%axesTi + elseif (axes_in%id == diag_cs%axesBi%id) then + axes => diag_cs%axesBi + elseif (axes_in%id == diag_cs%axesCui%id) then + axes => diag_cs%axesCui + elseif (axes_in%id == diag_cs%axesCvi%id) then + axes => diag_cs%axesCvi + else + allocate(axes) + axes = axes_in + endif + + MOM_missing_value = axes%diag_cs%missing_value + if (present(missing_value)) MOM_missing_value = missing_value + + diag_cs => axes%diag_cs + dm_id = -1 + + module_list = "{"//trim(module_name) + num_modnm = 1 + + ! Register the native diagnostic + active = register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, & + cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & + cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & + cell_methods=cell_methods, x_cell_method=x_cell_method, & + y_cell_method=y_cell_method, v_cell_method=v_cell_method, & + conversion=conversion, v_extensive=v_extensive) + if (associated(axes%xyave_axes)) then + num_varnm = 2 ; var_list = "{"//trim(field_name)//","//trim(field_name)//"_xyave" + else + num_varnm = 1 ; var_list = "{"//trim(field_name) + endif + if (present(cmor_field_name)) then + if (associated(axes%xyave_axes)) then + num_varnm = num_varnm + 2 + var_list = trim(var_list)//","//trim(cmor_field_name)//","//trim(cmor_field_name)//"_xyave" + else + num_varnm = num_varnm + 1 + var_list = trim(var_list)//","//trim(cmor_field_name) + endif + endif + var_list = trim(var_list)//"}" + + ! For each diagnostic coordinate register the diagnostic again under a different module name + do i=1,diag_cs%num_diag_coords + new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix) + + ! Register diagnostics remapped to z vertical coordinate + if (axes_in%rank == 3) then + remap_axes => null() + if ((axes_in%id == diag_cs%axesTL%id)) then + remap_axes => diag_cs%remap_axesTL(i) + elseif (axes_in%id == diag_cs%axesBL%id) then + remap_axes => diag_cs%remap_axesBL(i) + elseif (axes_in%id == diag_cs%axesCuL%id ) then + remap_axes => diag_cs%remap_axesCuL(i) + elseif (axes_in%id == diag_cs%axesCvL%id) then + remap_axes => diag_cs%remap_axesCvL(i) + elseif (axes_in%id == diag_cs%axesTi%id) then + remap_axes => diag_cs%remap_axesTi(i) + elseif (axes_in%id == diag_cs%axesBi%id) then + remap_axes => diag_cs%remap_axesBi(i) + elseif (axes_in%id == diag_cs%axesCui%id ) then + remap_axes => diag_cs%remap_axesCui(i) + elseif (axes_in%id == diag_cs%axesCvi%id) then + remap_axes => diag_cs%remap_axesCvi(i) + endif + ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will + ! always exist but in the mean-time we have to do this check: + ! call assert(associated(remap_axes), 'register_diag_field: remap_axes not set') + if (associated(remap_axes)) then + if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating) then + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, & + cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & + cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & + cell_methods=cell_methods, x_cell_method=x_cell_method, & + y_cell_method=y_cell_method, v_cell_method=v_cell_method, & + conversion=conversion, v_extensive=v_extensive) + if (active) then + call diag_remap_set_active(diag_cs%diag_remap_cs(i)) + endif + module_list = trim(module_list)//","//trim(new_module_name) + num_modnm = num_modnm + 1 + endif ! remap_axes%needs_remapping + endif ! associated(remap_axes) + endif ! axes%rank == 3 + enddo ! i + + !Register downsampled diagnostics + do dl=2,MAX_DSAMP_LEV + ! Do not attempt to checksum the downsampled diagnostics + if (diag_cs%diag_as_chksum) cycle + + new_module_name = trim(module_name)//'_d2' + + axes_d2 => null() + if (axes_in%rank == 3 .or. axes_in%rank == 2 ) then + if (axes_in%id == diag_cs%axesTL%id) then + axes_d2 => diag_cs%dsamp(dl)%axesTL + elseif (axes_in%id == diag_cs%axesBL%id) then + axes_d2 => diag_cs%dsamp(dl)%axesBL + elseif (axes_in%id == diag_cs%axesCuL%id ) then + axes_d2 => diag_cs%dsamp(dl)%axesCuL + elseif (axes_in%id == diag_cs%axesCvL%id) then + axes_d2 => diag_cs%dsamp(dl)%axesCvL + elseif (axes_in%id == diag_cs%axesTi%id) then + axes_d2 => diag_cs%dsamp(dl)%axesTi + elseif (axes_in%id == diag_cs%axesBi%id) then + axes_d2 => diag_cs%dsamp(dl)%axesBi + elseif (axes_in%id == diag_cs%axesCui%id ) then + axes_d2 => diag_cs%dsamp(dl)%axesCui + elseif (axes_in%id == diag_cs%axesCvi%id) then + axes_d2 => diag_cs%dsamp(dl)%axesCvi + elseif (axes_in%id == diag_cs%axesT1%id) then + axes_d2 => diag_cs%dsamp(dl)%axesT1 + elseif (axes_in%id == diag_cs%axesB1%id) then + axes_d2 => diag_cs%dsamp(dl)%axesB1 + elseif (axes_in%id == diag_cs%axesCu1%id ) then + axes_d2 => diag_cs%dsamp(dl)%axesCu1 + elseif (axes_in%id == diag_cs%axesCv1%id) then + axes_d2 => diag_cs%dsamp(dl)%axesCv1 + else + !Niki: Should we worry about these, e.g., diag_to_Z_CS? + call MOM_error(WARNING,"register_diag_field: Could not find a proper axes for " & + //trim(new_module_name)//"-"//trim(field_name)) + endif + endif + + ! Register the native diagnostic + if (associated(axes_d2)) then + 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, & + interp_method=interp_method, tile_count=tile_count, & + cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & + cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & + cell_methods=cell_methods, x_cell_method=x_cell_method, & + y_cell_method=y_cell_method, v_cell_method=v_cell_method, & + conversion=conversion, v_extensive=v_extensive) + module_list = trim(module_list)//","//trim(new_module_name) + num_modnm = num_modnm + 1 + endif + + ! For each diagnostic coordinate register the diagnostic again under a different module name + do i=1,diag_cs%num_diag_coords + new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix)//'_d2' + + ! Register diagnostics remapped to z vertical coordinate + if (axes_in%rank == 3) then + remap_axes => null() + if ((axes_in%id == diag_cs%axesTL%id)) then + remap_axes => diag_cs%dsamp(dl)%remap_axesTL(i) + elseif (axes_in%id == diag_cs%axesBL%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesBL(i) + elseif (axes_in%id == diag_cs%axesCuL%id ) then + remap_axes => diag_cs%dsamp(dl)%remap_axesCuL(i) + elseif (axes_in%id == diag_cs%axesCvL%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesCvL(i) + elseif (axes_in%id == diag_cs%axesTi%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesTi(i) + elseif (axes_in%id == diag_cs%axesBi%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesBi(i) + elseif (axes_in%id == diag_cs%axesCui%id ) then + remap_axes => diag_cs%dsamp(dl)%remap_axesCui(i) + elseif (axes_in%id == diag_cs%axesCvi%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesCvi(i) + endif + + ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will + ! always exist but in the mean-time we have to do this check: + ! call assert(associated(remap_axes), 'register_diag_field: remap_axes not set') + if (associated(remap_axes)) then + if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating) then + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, & + cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & + cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & + cell_methods=cell_methods, x_cell_method=x_cell_method, & + y_cell_method=y_cell_method, v_cell_method=v_cell_method, & + conversion=conversion, v_extensive=v_extensive) + if (active) then + call diag_remap_set_active(diag_cs%diag_remap_cs(i)) + endif + module_list = trim(module_list)//","//trim(new_module_name) + num_modnm = num_modnm + 1 + endif ! remap_axes%needs_remapping + endif ! associated(remap_axes) + endif ! axes%rank == 3 + enddo ! i + enddo + + if (is_root_pe() .and. (diag_CS%available_diag_doc_unit > 0)) then + msg = '' + if (present(cmor_field_name)) msg = 'CMOR equivalent is "'//trim(cmor_field_name)//'"' + call attach_cell_methods(-1, axes, cm_string, cell_methods, & + x_cell_method, y_cell_method, v_cell_method, & + v_extensive=v_extensive) + module_list = trim(module_list)//"}" + if (num_modnm <= 1) module_list = module_name + if (num_varnm <= 1) var_list = '' + + call log_available_diag(dm_id>0, module_list, field_name, cm_string, msg, diag_CS, & + long_name, units, standard_name, variants=var_list) + endif + + register_diag_field = dm_id + +end function register_diag_field + +!> Returns True if either the native or CMOr version of the diagnostic were registered. Updates 'dm_id' +!! after calling register_diag_field_expand_axes() for both native and CMOR variants of the field. +logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & + x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive) + integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes + !! for this field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided + !! with post_data calls (not used in MOM?) + logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. + !! Use '' to have no attribute. If present, this + !! overrides the default constructed from the default + !! for each individual axis direction. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically + !! integrated). Default/absent for intensive. + ! Local variables + real :: MOM_missing_value + type(diag_ctrl), pointer :: diag_cs => null() + type(diag_type), pointer :: this_diag => null() + integer :: fms_id, fms_xyave_id + character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string, msg + + MOM_missing_value = axes%diag_cs%missing_value + if (present(missing_value)) MOM_missing_value = missing_value + + register_diag_field_expand_cmor = .false. + diag_cs => axes%diag_cs + + ! Set up the 'primary' diagnostic, first get an underlying FMS id + fms_id = register_diag_field_expand_axes(module_name, field_name, axes, init_time, & + long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count) + if (.not. diag_cs%diag_as_chksum) & + call attach_cell_methods(fms_id, axes, cm_string, cell_methods, & + x_cell_method, y_cell_method, v_cell_method, & + v_extensive=v_extensive) + ! Associated horizontally area-averaged diagnostic + fms_xyave_id = DIAG_FIELD_NOT_FOUND + if (associated(axes%xyave_axes)) then + fms_xyave_id = register_diag_field_expand_axes(module_name, trim(field_name)//'_xyave', & + axes%xyave_axes, init_time, & + long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count) + if (.not. diag_cs%diag_as_chksum) & + call attach_cell_methods(fms_xyave_id, axes%xyave_axes, cm_string, & + cell_methods, v_cell_method, v_extensive=v_extensive) + endif + this_diag => null() + if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then + call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) + this_diag%fms_xyave_diag_id = fms_xyave_id + !Encode and save the cell methods for this diag + call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) + if (present(v_extensive)) this_diag%v_extensive = v_extensive + if (present(conversion)) this_diag%conversion_factor = conversion + register_diag_field_expand_cmor = .true. + endif + + ! For the CMOR variation of the above diagnostic + if (present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum) then + ! Fallback values for strings set to "NULL" + posted_cmor_units = "not provided" ! + posted_cmor_standard_name = "not provided" ! Values might be able to be replaced with a CS%missing field? + posted_cmor_long_name = "not provided" ! + + ! If attributes are present for MOM variable names, use them first for the register_diag_field + ! call for CMOR verison of the variable + if (present(units)) posted_cmor_units = units + if (present(standard_name)) posted_cmor_standard_name = standard_name + if (present(long_name)) posted_cmor_long_name = long_name + + ! If specified in the call to register_diag_field, override attributes with the CMOR versions + if (present(cmor_units)) posted_cmor_units = cmor_units + if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name + if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name + + fms_id = register_diag_field_expand_axes(module_name, cmor_field_name, axes, init_time, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & + standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, & + err_msg=err_msg, interp_method=interp_method, tile_count=tile_count) + call attach_cell_methods(fms_id, axes, cm_string, & + cell_methods, x_cell_method, y_cell_method, v_cell_method, & + v_extensive=v_extensive) + ! Associated horizontally area-averaged diagnostic + fms_xyave_id = DIAG_FIELD_NOT_FOUND + if (associated(axes%xyave_axes)) then + fms_xyave_id = register_diag_field_expand_axes(module_name, trim(cmor_field_name)//'_xyave', & + axes%xyave_axes, init_time, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & + standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, & + err_msg=err_msg, interp_method=interp_method, tile_count=tile_count) + call attach_cell_methods(fms_xyave_id, axes%xyave_axes, cm_string, & + cell_methods, v_cell_method, v_extensive=v_extensive) + endif + this_diag => null() + if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then + call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) + this_diag%fms_xyave_diag_id = fms_xyave_id + !Encode and save the cell methods for this diag + call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) + if (present(v_extensive)) this_diag%v_extensive = v_extensive + if (present(conversion)) this_diag%conversion_factor = conversion + register_diag_field_expand_cmor = .true. + endif + endif + +end function register_diag_field_expand_cmor + +!> Returns an FMS id from register_diag_field_fms (the diag_manager routine) after expanding axes +!! (axes-group) into handles and conditionally adding an FMS area_id for cell_measures. +integer function register_diag_field_expand_axes(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count) + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates + !! axes for this field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided + !! with post_data calls (not used in MOM?) + logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something + !! (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) + ! Local variables + integer :: fms_id, area_id, volume_id + + ! This gets the cell area associated with the grid location of this variable + area_id = axes%id_area + volume_id = axes%id_volume + + ! Get the FMS diagnostic id + if (axes%diag_cs%diag_as_chksum) then + fms_id = axes%diag_cs%num_chksum_diags + 1 + axes%diag_cs%num_chksum_diags = fms_id + elseif (present(interp_method) .or. axes%is_h_point) then + ! If interp_method is provided we must use it + if (area_id>0) then + if (volume_id>0) then + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, area=area_id, volume=volume_id) + else + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, area=area_id) + endif + else + if (volume_id>0) then + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, volume=volume_id) + else + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count) + endif + endif + else + ! If interp_method is not provided and the field is not at an h-point then interp_method='none' + if (area_id>0) then + if (volume_id>0) then + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method='none', tile_count=tile_count, area=area_id, volume=volume_id) + else + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method='none', tile_count=tile_count, area=area_id) + endif + else + if (volume_id>0) then + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method='none', tile_count=tile_count, volume=volume_id) + else + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method='none', tile_count=tile_count) + endif + endif + endif + + register_diag_field_expand_axes = fms_id + +end function register_diag_field_expand_axes + +!> Create a diagnostic type and attached to list +subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) + type(diag_ctrl), pointer :: diag_cs !< Diagnostics mediator control structure + integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group + integer, intent(in) :: fms_id !< The FMS diag_manager ID for this diagnostic + type(diag_type), pointer :: this_diag !< This diagnostic + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that + !! indicates axes for this field + character(len=*), intent(in) :: module_name !< Name of this module, usually + !! "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of diagnostic + character(len=*), intent(in) :: msg !< Message for errors + + ! If the diagnostic is needed obtain a diag_mediator ID (if needed) + if (dm_id == -1) dm_id = get_new_diag_id(diag_cs) + ! Create a new diag_type to store links in + call alloc_diag_with_id(dm_id, diag_cs, this_diag) + call assert(associated(this_diag), trim(msg)//': diag_type allocation failed') + ! Record FMS id, masks and conversion factor, in diag_type + this_diag%fms_diag_id = fms_id + this_diag%debug_str = trim(module_name)//"-"//trim(field_name) + this_diag%axes => axes + +end subroutine add_diag_to_list + +!> Adds the encoded "cell_methods" for a diagnostics as a diag% property +!! This allows access to the cell_method for a given diagnostics at the time of sending +subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) + type(diag_type), pointer :: diag !< This diagnostic + type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates + !! axes for this field + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields + !! (vertically integrated). Default/absent for intensive. + integer :: xyz_method + character(len=9) :: mstr + + !This is a simple way to encode the cell method information made from 3 strings + !(x_cell_method,y_cell_method,v_cell_method) in a 3 digit integer xyz + !x_cell_method,y_cell_method,v_cell_method can each be 'point' or 'sum' or 'mean' + !We can encode these with setting 1 for 'point', 2 for 'sum, 3 for 'mean' in + !the 100s position for x, 10s position for y, 1s position for z + !E.g., x:sum,y:point,z:mean is 213 + + xyz_method = 111 + + mstr = diag%axes%v_cell_method + if (present(v_extensive)) then + if (present(v_cell_method)) call MOM_error(FATAL, "attach_cell_methods: " // & + 'Vertical cell method was specified along with the vertically extensive flag.') + if (v_extensive) then + mstr='sum' + else + mstr='mean' + endif + elseif (present(v_cell_method)) then + mstr = v_cell_method + endif + if (trim(mstr)=='sum') then + xyz_method = xyz_method + 1 + elseif (trim(mstr)=='mean') then + xyz_method = xyz_method + 2 + endif + + mstr = diag%axes%y_cell_method + if (present(y_cell_method)) mstr = y_cell_method + if (trim(mstr)=='sum') then + xyz_method = xyz_method + 10 + elseif (trim(mstr)=='mean') then + xyz_method = xyz_method + 20 + endif + + mstr = diag%axes%x_cell_method + if (present(x_cell_method)) mstr = x_cell_method + if (trim(mstr)=='sum') then + xyz_method = xyz_method + 100 + elseif (trim(mstr)=='mean') then + xyz_method = xyz_method + 200 + endif + + diag%xyz_method = xyz_method +end subroutine add_xyz_method + +!> Attaches "cell_methods" attribute to a variable based on defaults for axes_grp or optional arguments. +subroutine attach_cell_methods(id, axes, ostring, cell_methods, & + x_cell_method, y_cell_method, v_cell_method, v_extensive) + integer, intent(in) :: id !< Handle to diagnostic + type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates + !! axes for this field + character(len=*), intent(out) :: ostring !< The cell_methods strings that would appear in the file + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. + !! Use '' to have no attribute. If present, this + !! overrides the default constructed from the default + !! for each individual axis direction. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields + !! (vertically integrated). Default/absent for intensive. + ! Local variables + character(len=9) :: axis_name + logical :: x_mean, y_mean, x_sum, y_sum + + x_mean = .false. + y_mean = .false. + x_sum = .false. + y_sum = .false. + + ostring = '' + if (present(cell_methods)) then + if (present(x_cell_method) .or. present(y_cell_method) .or. present(v_cell_method) & + .or. present(v_extensive)) then + call MOM_error(FATAL, "attach_cell_methods: " // & + 'Individual direction cell method was specified along with a "cell_methods" string.') + endif + if (len(trim(cell_methods))>0) then + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(cell_methods)) + ostring = trim(cell_methods) + endif + else + if (present(x_cell_method)) then + if (len(trim(x_cell_method))>0) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method)) + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(x_cell_method) + if (trim(x_cell_method)=='mean') x_mean=.true. + if (trim(x_cell_method)=='sum') x_sum=.true. + endif + else + if (len(trim(axes%x_cell_method))>0) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%x_cell_method)) + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%x_cell_method) + if (trim(axes%x_cell_method)=='mean') x_mean=.true. + if (trim(axes%x_cell_method)=='sum') x_sum=.true. + endif + endif + if (present(y_cell_method)) then + if (len(trim(y_cell_method))>0) then + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method)) + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(y_cell_method) + if (trim(y_cell_method)=='mean') y_mean=.true. + if (trim(y_cell_method)=='sum') y_sum=.true. + endif + else + if (len(trim(axes%y_cell_method))>0) then + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%y_cell_method)) + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%y_cell_method) + if (trim(axes%y_cell_method)=='mean') y_mean=.true. + if (trim(axes%y_cell_method)=='sum') y_sum=.true. + endif + endif + if (present(v_cell_method)) then + if (present(v_extensive)) call MOM_error(FATAL, "attach_cell_methods: " // & + 'Vertical cell method was specified along with the vertically extensive flag.') + if (len(trim(v_cell_method))>0) then + if (axes%rank==1) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + elseif (axes%rank==3) then + call get_MOM_diag_axis_name(axes%handles(3), axis_name) + endif + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(v_cell_method)) + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(v_cell_method) + endif + elseif (present(v_extensive)) then + if (v_extensive) then + if (axes%rank==1) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + elseif (axes%rank==3) then + call get_MOM_diag_axis_name(axes%handles(3), axis_name) + endif + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':sum') + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':sum' + endif + else + if (len(trim(axes%v_cell_method))>0) then + if (axes%rank==1) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + elseif (axes%rank==3) then + call get_MOM_diag_axis_name(axes%handles(3), axis_name) + endif + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%v_cell_method)) + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%v_cell_method) + endif + endif + if (x_mean .and. y_mean) then + call MOM_diag_field_add_attribute(id, 'cell_methods', 'area:mean') + ostring = trim(adjustl(ostring))//' area:mean' + elseif (x_sum .and. y_sum) then + call MOM_diag_field_add_attribute(id, 'cell_methods', 'area:sum') + ostring = trim(adjustl(ostring))//' area:sum' + endif + endif + ostring = adjustl(ostring) +end subroutine attach_cell_methods + +function register_scalar_field(module_name, field_name, init_time, diag_cs, & + long_name, units, missing_value, range, standard_name, & + do_not_log, err_msg, interp_method, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, conversion) + integer :: register_scalar_field !< An integer handle for a diagnostic array. + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + + ! Local variables + real :: MOM_missing_value + integer :: dm_id, fms_id + type(diag_type), pointer :: diag => null(), cmor_diag => null() + character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name + + MOM_missing_value = diag_cs%missing_value + if (present(missing_value)) MOM_missing_value = missing_value + + dm_id = -1 + diag => null() + cmor_diag => null() + + if (diag_cs%diag_as_chksum) then + fms_id = diag_cs%num_chksum_diags + 1 + diag_cs%num_chksum_diags = fms_id + else + fms_id = register_diag_field_infra(module_name, field_name, init_time, & + long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, standard_name=standard_name, do_not_log=do_not_log, & + err_msg=err_msg) + endif + + if (fms_id /= DIAG_FIELD_NOT_FOUND) then + dm_id = get_new_diag_id(diag_cs) + call alloc_diag_with_id(dm_id, diag_cs, diag) + call assert(associated(diag), 'register_scalar_field: diag allocation failed') + diag%fms_diag_id = fms_id + diag%debug_str = trim(module_name)//"-"//trim(field_name) + if (present(conversion)) diag%conversion_factor = conversion + endif + + if (present(cmor_field_name)) then + ! Fallback values for strings set to "not provided" + posted_cmor_units = "not provided" + posted_cmor_standard_name = "not provided" + posted_cmor_long_name = "not provided" + + ! If attributes are present for MOM variable names, use them first for the register_static_field + ! call for CMOR verison of the variable + if (present(units)) posted_cmor_units = units + if (present(standard_name)) posted_cmor_standard_name = standard_name + if (present(long_name)) posted_cmor_long_name = long_name + + ! If specified in the call to register_static_field, override attributes with the CMOR versions + if (present(cmor_units)) posted_cmor_units = cmor_units + if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name + if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name + + fms_id = register_diag_field_infra(module_name, cmor_field_name, init_time, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, & + standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, err_msg=err_msg) + if (fms_id /= DIAG_FIELD_NOT_FOUND) then + if (dm_id == -1) then + dm_id = get_new_diag_id(diag_cs) + endif + call alloc_diag_with_id(dm_id, diag_cs, cmor_diag) + cmor_diag%fms_diag_id = fms_id + cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name) + if (present(conversion)) cmor_diag%conversion_factor = conversion + endif + endif + + ! Document diagnostics in list of available diagnostics + if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then + if (present(cmor_field_name)) then + call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & + long_name, units, standard_name, & + variants="{"//trim(field_name)//","//trim(cmor_field_name)//"}") + else + call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & + long_name, units, standard_name) + endif + endif + + register_scalar_field = dm_id + +end function register_scalar_field + +!> Registers a static diagnostic, returning an integer handle +function register_static_field(module_name, field_name, axes, & + long_name, units, missing_value, range, mask_variant, standard_name, & + do_not_log, interp_method, tile_count, & + cmor_field_name, cmor_long_name, cmor_units, cmor_standard_name, area, & + x_cell_method, y_cell_method, area_cell_method, conversion) + integer :: register_static_field !< An integer handle for a diagnostic array. + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that + !! indicates axes for this field + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_data calls (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + integer, optional, intent(in) :: area !< fms_id for area_t + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + character(len=*), optional, intent(in) :: area_cell_method !< Specifies the cell method for area + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + + ! Local variables + real :: MOM_missing_value + type(diag_ctrl), pointer :: diag_cs => null() + type(diag_type), pointer :: diag => null(), cmor_diag => null() + integer :: dm_id, fms_id + character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name + character(len=9) :: axis_name + + MOM_missing_value = axes%diag_cs%missing_value + if (present(missing_value)) MOM_missing_value = missing_value + + diag_cs => axes%diag_cs + dm_id = -1 + diag => null() + cmor_diag => null() + + if (diag_cs%diag_as_chksum) then + fms_id = diag_cs%num_chksum_diags + 1 + diag_cs%num_chksum_diags = fms_id + else + fms_id = register_static_field_infra(module_name, field_name, axes%handles, & + long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + do_not_log=do_not_log, & + interp_method=interp_method, tile_count=tile_count, area=area) + endif + + if (fms_id /= DIAG_FIELD_NOT_FOUND) then + dm_id = get_new_diag_id(diag_cs) + call alloc_diag_with_id(dm_id, diag_cs, diag) + call assert(associated(diag), 'register_static_field: diag allocation failed') + diag%fms_diag_id = fms_id + diag%debug_str = trim(module_name)//"-"//trim(field_name) + if (present(conversion)) diag%conversion_factor = conversion + + if (diag_cs%diag_as_chksum) then + diag%axes => axes + else + if (present(x_cell_method)) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', & + trim(axis_name)//':'//trim(x_cell_method)) + endif + if (present(y_cell_method)) then + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', & + trim(axis_name)//':'//trim(y_cell_method)) + endif + if (present(area_cell_method)) then + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', & + 'area:'//trim(area_cell_method)) + endif + endif + endif + + if (present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum) then + ! Fallback values for strings set to "not provided" + posted_cmor_units = "not provided" + posted_cmor_standard_name = "not provided" + posted_cmor_long_name = "not provided" + + ! If attributes are present for MOM variable names, use them first for the register_static_field + ! call for CMOR verison of the variable + if (present(units)) posted_cmor_units = units + if (present(standard_name)) posted_cmor_standard_name = standard_name + if (present(long_name)) posted_cmor_long_name = long_name + + ! If specified in the call to register_static_field, override attributes with the CMOR versions + if (present(cmor_units)) posted_cmor_units = cmor_units + if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name + if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name + + fms_id = register_static_field_infra(module_name, cmor_field_name, axes%handles, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & + standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, & + interp_method=interp_method, tile_count=tile_count, area=area) + if (fms_id /= DIAG_FIELD_NOT_FOUND) then + if (dm_id == -1) then + dm_id = get_new_diag_id(diag_cs) + endif + call alloc_diag_with_id(dm_id, diag_cs, cmor_diag) + cmor_diag%fms_diag_id = fms_id + cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name) + if (present(conversion)) cmor_diag%conversion_factor = conversion + if (present(x_cell_method)) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method)) + endif + if (present(y_cell_method)) then + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method)) + endif + if (present(area_cell_method)) then + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', 'area:'//trim(area_cell_method)) + endif + endif + endif + + ! Document diagnostics in list of available diagnostics + if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then + if (present(cmor_field_name)) then + call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & + long_name, units, standard_name, & + variants="{"//trim(field_name)//","//trim(cmor_field_name)//"}") + else + call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & + long_name, units, standard_name) + endif + endif + + register_static_field = dm_id + +end function register_static_field + +!> Describe an option setting in the diagnostic files. +subroutine describe_option(opt_name, value, diag_CS) + character(len=*), intent(in) :: opt_name !< The name of the option + character(len=*), intent(in) :: value !< A character string with the setting of the option. + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + + character(len=480) :: mesg + integer :: len_ind + + len_ind = len_trim(value) ! Add error handling for long values? + + mesg = " ! "//trim(opt_name)//": "//trim(value) + write(diag_CS%available_diag_doc_unit, '(a)') trim(mesg) +end subroutine describe_option + +!> Registers a diagnostic using the information encapsulated in the vardesc +!! type argument and returns an integer handle to this diagostic. That +!! integer handle is negative if the diagnostic is unused. +function ocean_register_diag(var_desc, G, diag_CS, day) + integer :: ocean_register_diag !< An integer handle to this diagnostic. + type(vardesc), intent(in) :: var_desc !< The vardesc type describing the diagnostic + type(ocean_grid_type), intent(in) :: G !< The ocean's grid type + type(diag_ctrl), intent(in), target :: diag_CS !< The diagnotic control structure + type(time_type), intent(in) :: day !< The current model time + + character(len=64) :: var_name ! A variable's name. + character(len=48) :: units ! A variable's units. + character(len=240) :: longname ! A variable's longname. + character(len=8) :: hor_grid, z_grid ! Variable grid info. + type(axes_grp), pointer :: axes => NULL() + + call query_vardesc(var_desc, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, caller="ocean_register_diag") + + ! Use the hor_grid and z_grid components of vardesc to determine the + ! desired axes to register the diagnostic field for. + select case (z_grid) + + case ("L") + select case (hor_grid) + case ("q") ; axes => diag_cs%axesBL + case ("h") ; axes => diag_cs%axesTL + case ("u") ; axes => diag_cs%axesCuL + case ("v") ; axes => diag_cs%axesCvL + case ("Bu") ; axes => diag_cs%axesBL + case ("T") ; axes => diag_cs%axesTL + case ("Cu") ; axes => diag_cs%axesCuL + case ("Cv") ; axes => diag_cs%axesCvL + case ("z") ; axes => diag_cs%axeszL + case default ; call MOM_error(FATAL, "ocean_register_diag: " // & + "unknown hor_grid component "//trim(hor_grid)) + end select + + case ("i") + select case (hor_grid) + case ("q") ; axes => diag_cs%axesBi + case ("h") ; axes => diag_cs%axesTi + case ("u") ; axes => diag_cs%axesCui + case ("v") ; axes => diag_cs%axesCvi + case ("Bu") ; axes => diag_cs%axesBi + case ("T") ; axes => diag_cs%axesTi + case ("Cu") ; axes => diag_cs%axesCui + case ("Cv") ; axes => diag_cs%axesCvi + case ("z") ; axes => diag_cs%axeszi + case default ; call MOM_error(FATAL, "ocean_register_diag: " // & + "unknown hor_grid component "//trim(hor_grid)) + end select + + case ("1") + select case (hor_grid) + case ("q") ; axes => diag_cs%axesB1 + case ("h") ; axes => diag_cs%axesT1 + case ("u") ; axes => diag_cs%axesCu1 + case ("v") ; axes => diag_cs%axesCv1 + case ("Bu") ; axes => diag_cs%axesB1 + case ("T") ; axes => diag_cs%axesT1 + case ("Cu") ; axes => diag_cs%axesCu1 + case ("Cv") ; axes => diag_cs%axesCv1 + case default ; call MOM_error(FATAL, "ocean_register_diag: " // & + "unknown hor_grid component "//trim(hor_grid)) + end select + + case default + call MOM_error(FATAL,& + "ocean_register_diag: unknown z_grid component "//trim(z_grid)) + end select + + ocean_register_diag = register_diag_field("ocean_model", trim(var_name), & + axes, day, trim(longname), trim(units), missing_value=-1.0e+34) + +end function ocean_register_diag + +subroutine diag_mediator_infrastructure_init(err_msg) + ! This subroutine initializes the FMS diag_manager. + character(len=*), optional, intent(out) :: err_msg !< An error message + + call MOM_diag_manager_init(err_msg=err_msg) +end subroutine diag_mediator_infrastructure_init + +!> diag_mediator_init initializes the MOM diag_mediator and opens the available +!! diagnostics file, if appropriate. +subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) + type(ocean_grid_type), target, intent(inout) :: G !< The ocean grid type. + type(verticalGrid_type), target, intent(in) :: GV !< The ocean vertical grid structure + type(unit_scale_type), target, intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: nz !< The number of layers in the model's native grid. + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(diag_ctrl), intent(inout) :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + character(len=*), optional, intent(in) :: doc_file_dir !< A directory in which to create the + !! file + + ! This subroutine initializes the diag_mediator and the diag_manager. + ! The grid type should have its dimensions set by this point, but it + ! is not necessary that the metrics and axis labels be set up yet. + + ! Local variables + integer :: ios, i, new_unit + logical :: opened, new_file + integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use + ! for remapping. Values below 20190101 recover the remapping + ! answers from 2018, while higher values use more robust + ! forms of the same remapping expressions. + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + character(len=8) :: this_pe + character(len=240) :: doc_file, doc_file_dflt, doc_path + character(len=240), allocatable :: diag_coords(:) + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_diag_mediator" ! This module's name. + character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs + + id_clock_diag_mediator = cpu_clock_id('(Ocean diagnostics framework)', grain=CLOCK_MODULE) + id_clock_diag_remap = cpu_clock_id('(Ocean diagnostics remapping)', grain=CLOCK_ROUTINE) + id_clock_diag_grid_updates = cpu_clock_id('(Ocean diagnostics grid updates)', grain=CLOCK_ROUTINE) + + ! Allocate and initialize list of all diagnostics (and variants) + allocate(diag_cs%diags(DIAG_ALLOC_CHUNK_SIZE)) + diag_cs%next_free_diag_id = 1 + do i=1, DIAG_ALLOC_CHUNK_SIZE + call initialize_diag_type(diag_cs%diags(i)) + enddo + + diag_cs%show_call_tree = callTree_showQuery() + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, 'NUM_DIAG_COORDS', diag_cs%num_diag_coords, & + 'The number of diagnostic vertical coordinates to use. '//& + 'For each coordinate, an entry in DIAG_COORDS must be provided.', & + default=1) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) + call get_param(param_file, mdl, 'USE_GRID_SPACE_DIAGNOSTIC_AXES', diag_cs%grid_space_axes, & + 'If true, use a grid index coordinate convention for diagnostic axes. ',& + default=.false.) + + if (diag_cs%num_diag_coords>0) then + allocate(diag_coords(diag_cs%num_diag_coords)) + if (diag_cs%num_diag_coords==1) then ! The default is to provide just one instance of Z* + call get_param(param_file, mdl, 'DIAG_COORDS', diag_coords, & + 'A list of string tuples associating diag_table modules to '//& + 'a coordinate definition used for diagnostics. Each string '//& + 'is of the form "MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME".', & + default='z Z ZSTAR') + else ! If using more than 1 diagnostic coordinate, all must be explicitly defined + call get_param(param_file, mdl, 'DIAG_COORDS', diag_coords, & + 'A list of string tuples associating diag_table modules to '//& + 'a coordinate definition used for diagnostics. Each string '//& + 'is of the form "MODULE_SUFFIX,PARAMETER_SUFFIX,COORDINATE_NAME".', & + fail_if_missing=.true.) + endif + allocate(diag_cs%diag_remap_cs(diag_cs%num_diag_coords)) + ! Initialize each diagnostic vertical coordinate + do i=1, diag_cs%num_diag_coords + call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), answer_date=remap_answer_date, GV=GV) + enddo + deallocate(diag_coords) + endif + + call get_param(param_file, mdl, 'DIAG_MISVAL', diag_cs%missing_value, & + 'Set the default missing value to use for diagnostics.', & + units="various", default=1.e20) + call get_param(param_file, mdl, 'DIAG_AS_CHKSUM', diag_cs%diag_as_chksum, & + 'Instead of writing diagnostics to the diag manager, write '//& + 'a text file containing the checksum (bitcount) of the array.', & + default=.false.) + + if (diag_cs%diag_as_chksum) & + diag_cs%num_chksum_diags = 0 + + ! Keep pointers to the grid, h, T, S needed for diagnostic remapping + diag_cs%G => G + diag_cs%GV => GV + diag_cs%US => US + diag_cs%h => null() + diag_cs%T => null() + diag_cs%S => null() + diag_cs%eqn_of_state => null() + diag_cs%tv => null() + + allocate(diag_cs%h_begin(G%isd:G%ied,G%jsd:G%jed,nz)) +#if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) + allocate(diag_cs%h_old(G%isd:G%ied,G%jsd:G%jed,nz)) + diag_cs%h_old(:,:,:) = 0.0 +#endif + + diag_cs%is = G%isc - (G%isd-1) ; diag_cs%ie = G%iec - (G%isd-1) + diag_cs%js = G%jsc - (G%jsd-1) ; diag_cs%je = G%jec - (G%jsd-1) + diag_cs%isd = G%isd ; diag_cs%ied = G%ied + diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed + + !Downsample indices for dl=2 (should be generalized to arbitrary dl, perhaps via a G array) + diag_cs%dsamp(2)%isc = G%HId2%isc - (G%HId2%isd-1) ; diag_cs%dsamp(2)%iec = G%HId2%iec - (G%HId2%isd-1) + diag_cs%dsamp(2)%jsc = G%HId2%jsc - (G%HId2%jsd-1) ; diag_cs%dsamp(2)%jec = G%HId2%jec - (G%HId2%jsd-1) + diag_cs%dsamp(2)%isd = G%HId2%isd ; diag_cs%dsamp(2)%ied = G%HId2%ied + diag_cs%dsamp(2)%jsd = G%HId2%jsd ; diag_cs%dsamp(2)%jed = G%HId2%jed + diag_cs%dsamp(2)%isg = G%HId2%isg ; diag_cs%dsamp(2)%ieg = G%HId2%ieg + diag_cs%dsamp(2)%jsg = G%HId2%jsg ; diag_cs%dsamp(2)%jeg = G%HId2%jeg + diag_cs%dsamp(2)%isgB = G%HId2%isgB ; diag_cs%dsamp(2)%iegB = G%HId2%iegB + diag_cs%dsamp(2)%jsgB = G%HId2%jsgB ; diag_cs%dsamp(2)%jegB = G%HId2%jegB + + ! Initialze available diagnostic log file + if (is_root_pe() .and. (diag_CS%available_diag_doc_unit < 0)) then + write(this_pe,'(i6.6)') PE_here() + doc_file_dflt = "available_diags."//this_pe + call get_param(param_file, mdl, "AVAILABLE_DIAGS_FILE", doc_file, & + "A file into which to write a list of all available "//& + "ocean diagnostics that can be included in a diag_table.", & + default=doc_file_dflt, do_not_log=(diag_CS%available_diag_doc_unit/=-1)) + if (len_trim(doc_file) > 0) then + new_file = .true. ; if (diag_CS%available_diag_doc_unit /= -1) new_file = .false. + ! Find an unused unit number. + do new_unit=512,42,-1 + inquire( new_unit, opened=opened) + if (.not.opened) exit + enddo + if (opened) call MOM_error(FATAL, & + "diag_mediator_init failed to find an unused unit number.") + + doc_path = doc_file + if (present(doc_file_dir)) then ; if (len_trim(doc_file_dir) > 0) then + doc_path = trim(slasher(doc_file_dir))//trim(doc_file) + endif ; endif + + diag_CS%available_diag_doc_unit = new_unit + + if (new_file) then + open(diag_CS%available_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='REPLACE', iostat=ios) + else ! This file is being reopened, and should be appended. + open(diag_CS%available_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='OLD', position='APPEND', iostat=ios) + endif + inquire(diag_CS%available_diag_doc_unit, opened=opened) + if ((.not.opened) .or. (ios /= 0)) then + call MOM_error(FATAL, "Failed to open available diags file "//trim(doc_path)//".") + endif + endif + endif + + if (is_root_pe() .and. (diag_CS%chksum_iounit < 0) .and. diag_CS%diag_as_chksum) then + !write(this_pe,'(i6.6)') PE_here() + !doc_file_dflt = "chksum_diag."//this_pe + doc_file_dflt = "chksum_diag" + call get_param(param_file, mdl, "CHKSUM_DIAG_FILE", doc_file, & + "A file into which to write all checksums of the "//& + "diagnostics listed in the diag_table.", & + default=doc_file_dflt, do_not_log=(diag_CS%chksum_iounit/=-1)) + + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + doc_file = trim(doc_file) //'.'//trim(filename_appendix) + endif +#ifdef STATSLABEL + doc_file = trim(doc_file)//"."//trim(adjustl(STATSLABEL)) +#endif + + if (len_trim(doc_file) > 0) then + new_file = .true. ; if (diag_CS%chksum_iounit /= -1) new_file = .false. + ! Find an unused unit number. + do new_unit=512,42,-1 + inquire( new_unit, opened=opened) + if (.not.opened) exit + enddo + if (opened) call MOM_error(FATAL, & + "diag_mediator_init failed to find an unused unit number.") + + doc_path = doc_file + if (present(doc_file_dir)) then ; if (len_trim(doc_file_dir) > 0) then + doc_path = trim(slasher(doc_file_dir))//trim(doc_file) + endif ; endif + + diag_CS%chksum_iounit = new_unit + + if (new_file) then + open(diag_CS%chksum_iounit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='REPLACE', iostat=ios) + else ! This file is being reopened, and should be appended. + open(diag_CS%chksum_iounit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='OLD', position='APPEND', iostat=ios) + endif + inquire(diag_CS%chksum_iounit, opened=opened) + if ((.not.opened) .or. (ios /= 0)) then + call MOM_error(FATAL, "Failed to open checksum diags file "//trim(doc_path)//".") + endif + endif + endif + +end subroutine diag_mediator_init + +!> Set pointers to the default state fields used to remap diagnostics. +subroutine diag_set_state_ptrs(h, tv, diag_cs) + real, dimension(:,:,:), target, intent(in ) :: h !< the model thickness array [H ~> m or kg m-2] + type(thermo_var_ptrs), target, intent(in ) :: tv !< A sturcture with thermodynamic variables that are + !! are used to convert thicknesses to vertical extents + type(diag_ctrl), intent(inout) :: diag_cs !< diag mediator control structure + + ! Keep pointers to h, T, S needed for the diagnostic remapping + diag_cs%h => h + diag_cs%T => tv%T + diag_cs%S => tv%S + diag_cs%eqn_of_state => tv%eqn_of_state + diag_cs%tv => tv + +end subroutine + +!> Build/update vertical grids for diagnostic remapping. +!! \note The target grids need to be updated whenever sea surface +!! height changes. +subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensive, update_extensive ) + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure + real, target, optional, intent(in ) :: alt_h(:,:,:) !< Used if remapped grids should be something other than + !! the current thicknesses [H ~> m or kg m-2] + real, target, optional, intent(in ) :: alt_T(:,:,:) !< Used if remapped grids should be something other than + !! the current temperatures [C ~> degC] + real, target, optional, intent(in ) :: alt_S(:,:,:) !< Used if remapped grids should be something other than + !! the current salinity [S ~> ppt] + logical, optional, intent(in ) :: update_intensive !< If true (default), update the grids used for + !! intensive diagnostics + logical, optional, intent(in ) :: update_extensive !< If true (not default), update the grids used for + !! intensive diagnostics + ! Local variables + integer :: m + real, dimension(:,:,:), pointer :: h_diag => NULL() ! The layer thickneses for diagnostics [H ~> m or kg m-2] + real, dimension(:,:,:), pointer :: T_diag => NULL() ! The layer temperatures for diagnostics [C ~> degC] + real, dimension(:,:,:), pointer :: S_diag => NULL() ! The layer salinities for diagnostics [S ~> ppt] + real, dimension(diag_cs%G%isd:diag_cS%G%ied, diag_cs%G%jsd:diag_cS%G%jed, diag_cs%GV%ke) :: & + dz_diag ! Layer vertical extents for remapping [Z ~> m] + logical :: update_intensive_local, update_extensive_local, dz_diag_needed + + if (diag_cs%show_call_tree) call callTree_enter("diag_update_remap_grids()") + + ! Set values based on optional input arguments + if (present(alt_h)) then + h_diag => alt_h + else + h_diag => diag_cs%h + endif + + if (present(alt_T)) then + T_diag => alt_T + else + T_diag => diag_CS%T + endif + + if (present(alt_S)) then + S_diag => alt_S + else + S_diag => diag_CS%S + endif + + ! Defaults here are based on wanting to update intensive quantities frequently as soon as the model state changes. + ! Conversely, for extensive quantities, in an effort to close budgets and to be consistent with the total time + ! tendency, we construct the diagnostic grid at the beginning of the baroclinic timestep and remap all extensive + ! quantities to the same grid + update_intensive_local = .true. + if (present(update_intensive)) update_intensive_local = update_intensive + update_extensive_local = .false. + if (present(update_extensive)) update_extensive_local = update_extensive + + if (id_clock_diag_grid_updates>0) call cpu_clock_begin(id_clock_diag_grid_updates) + + if (diag_cs%diag_grid_overridden) then + call MOM_error(FATAL, "diag_update_remap_grids was called, but current grids in "// & + "diagnostic structure have been overridden") + endif + + ! Determine the diagnostic grid spacing in height units, if it is needed. + dz_diag_needed = .false. + if (update_intensive_local .or. update_extensive_local) then + do m=1, diag_cs%num_diag_coords + if (diag_cs%diag_remap_cs(m)%Z_based_coord) dz_diag_needed = .true. + enddo + endif + if (dz_diag_needed) then + call thickness_to_dz(h_diag, diag_cs%tv, dz_diag, diag_cs%G, diag_cs%GV, diag_cs%US, halo_size=1) + endif + + if (update_intensive_local) then + do m=1, diag_cs%num_diag_coords + if (diag_cs%diag_remap_cs(m)%Z_based_coord) then + call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, dz_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(m)%h) + else + call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(m)%h) + endif + enddo + endif + if (update_extensive_local) then + diag_cs%h_begin(:,:,:) = diag_cs%h(:,:,:) + do m=1, diag_cs%num_diag_coords + if (diag_cs%diag_remap_cs(m)%Z_based_coord) then + call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, dz_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(m)%h_extensive) + else + call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(m)%h_extensive) + endif + enddo + endif + +#if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) + ! Keep a copy of H - used to check whether grids are up-to-date + ! when doing remapping. + diag_cs%h_old(:,:,:) = diag_cs%h(:,:,:) +#endif + + if (id_clock_diag_grid_updates>0) call cpu_clock_end(id_clock_diag_grid_updates) + + if (diag_cs%show_call_tree) call callTree_leave("diag_update_remap_grids()") + +end subroutine diag_update_remap_grids + +!> Sets up the 2d and 3d masks for native diagnostics +subroutine diag_masks_set(G, nz, diag_cs) + type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. + integer, intent(in) :: nz !< The number of layers in the model's native grid. + type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + ! Local variables + integer :: k + + ! 2d masks point to the model masks since they are identical + diag_cs%mask2dT => G%mask2dT + diag_cs%mask2dBu => G%mask2dBu + diag_cs%mask2dCu => G%mask2dCu + diag_cs%mask2dCv => G%mask2dCv + + ! 3d native masks are needed by diag_manager but the native variables + ! can only be masked 2d - for ocean points, all layers exists. + allocate(diag_cs%mask3dTL(G%isd:G%ied,G%jsd:G%jed,1:nz)) + allocate(diag_cs%mask3dBL(G%IsdB:G%IedB,G%JsdB:G%JedB,1:nz)) + allocate(diag_cs%mask3dCuL(G%IsdB:G%IedB,G%jsd:G%jed,1:nz)) + allocate(diag_cs%mask3dCvL(G%isd:G%ied,G%JsdB:G%JedB,1:nz)) + do k=1,nz + diag_cs%mask3dTL(:,:,k) = diag_cs%mask2dT(:,:) + diag_cs%mask3dBL(:,:,k) = diag_cs%mask2dBu(:,:) + diag_cs%mask3dCuL(:,:,k) = diag_cs%mask2dCu(:,:) + diag_cs%mask3dCvL(:,:,k) = diag_cs%mask2dCv(:,:) + enddo + allocate(diag_cs%mask3dTi(G%isd:G%ied,G%jsd:G%jed,1:nz+1)) + allocate(diag_cs%mask3dBi(G%IsdB:G%IedB,G%JsdB:G%JedB,1:nz+1)) + allocate(diag_cs%mask3dCui(G%IsdB:G%IedB,G%jsd:G%jed,1:nz+1)) + allocate(diag_cs%mask3dCvi(G%isd:G%ied,G%JsdB:G%JedB,1:nz+1)) + do k=1,nz+1 + diag_cs%mask3dTi(:,:,k) = diag_cs%mask2dT(:,:) + diag_cs%mask3dBi(:,:,k) = diag_cs%mask2dBu(:,:) + diag_cs%mask3dCui(:,:,k) = diag_cs%mask2dCu(:,:) + diag_cs%mask3dCvi(:,:,k) = diag_cs%mask2dCv(:,:) + enddo + + !Allocate and initialize the downsampled masks + call downsample_diag_masks_set(G, nz, diag_cs) + +end subroutine diag_masks_set + +subroutine diag_mediator_close_registration(diag_CS) + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output + + integer :: i + + if (diag_CS%available_diag_doc_unit > -1) then + close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -2 + endif + + do i=1, diag_cs%num_diag_coords + call diag_remap_diag_registration_closed(diag_cs%diag_remap_cs(i)) + enddo + +end subroutine diag_mediator_close_registration + +subroutine axes_grp_end(axes) + type(axes_grp), intent(inout) :: axes !< Axes group to be destroyed + + deallocate(axes%handles) + if (associated(axes%mask2d)) deallocate(axes%mask2d) + if (associated(axes%mask3d)) deallocate(axes%mask3d) +end subroutine axes_grp_end + +subroutine diag_mediator_end(time, diag_CS, end_diag_manager) + type(time_type), intent(in) :: time !< The current model time + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: end_diag_manager !< If true, call diag_manager_end() + + ! Local variables + type(diag_type), pointer :: diag, next_diag + integer :: i, dl + + if (diag_CS%available_diag_doc_unit > -1) then + close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -3 + endif + if (diag_CS%chksum_iounit > -1) then + close(diag_CS%chksum_iounit) ; diag_CS%chksum_iounit = -3 + endif + + do i=1, diag_cs%next_free_diag_id - 1 + if (associated(diag_cs%diags(i)%next)) then + next_diag => diag_cs%diags(i)%next + do while (associated(next_diag)) + diag => next_diag + next_diag => diag%next + deallocate(diag) + enddo + endif + enddo + + deallocate(diag_cs%diags) + + do i=1, diag_cs%num_diag_coords + call diag_remap_end(diag_cs%diag_remap_cs(i)) + enddo + + call diag_grid_storage_end(diag_cs%diag_grid_temp) + if (associated(diag_cs%mask3dTL)) deallocate(diag_cs%mask3dTL) + if (associated(diag_cs%mask3dBL)) deallocate(diag_cs%mask3dBL) + if (associated(diag_cs%mask3dCuL)) deallocate(diag_cs%mask3dCuL) + if (associated(diag_cs%mask3dCvL)) deallocate(diag_cs%mask3dCvL) + if (associated(diag_cs%mask3dTi)) deallocate(diag_cs%mask3dTi) + if (associated(diag_cs%mask3dBi)) deallocate(diag_cs%mask3dBi) + if (associated(diag_cs%mask3dCui)) deallocate(diag_cs%mask3dCui) + if (associated(diag_cs%mask3dCvi)) deallocate(diag_cs%mask3dCvi) + do dl=2,MAX_DSAMP_LEV + if (associated(diag_cs%dsamp(dl)%mask2dT)) deallocate(diag_cs%dsamp(dl)%mask2dT) + if (associated(diag_cs%dsamp(dl)%mask2dBu)) deallocate(diag_cs%dsamp(dl)%mask2dBu) + if (associated(diag_cs%dsamp(dl)%mask2dCu)) deallocate(diag_cs%dsamp(dl)%mask2dCu) + if (associated(diag_cs%dsamp(dl)%mask2dCv)) deallocate(diag_cs%dsamp(dl)%mask2dCv) + if (associated(diag_cs%dsamp(dl)%mask3dTL)) deallocate(diag_cs%dsamp(dl)%mask3dTL) + if (associated(diag_cs%dsamp(dl)%mask3dBL)) deallocate(diag_cs%dsamp(dl)%mask3dBL) + if (associated(diag_cs%dsamp(dl)%mask3dCuL)) deallocate(diag_cs%dsamp(dl)%mask3dCuL) + if (associated(diag_cs%dsamp(dl)%mask3dCvL)) deallocate(diag_cs%dsamp(dl)%mask3dCvL) + if (associated(diag_cs%dsamp(dl)%mask3dTi)) deallocate(diag_cs%dsamp(dl)%mask3dTi) + if (associated(diag_cs%dsamp(dl)%mask3dBi)) deallocate(diag_cs%dsamp(dl)%mask3dBi) + if (associated(diag_cs%dsamp(dl)%mask3dCui)) deallocate(diag_cs%dsamp(dl)%mask3dCui) + if (associated(diag_cs%dsamp(dl)%mask3dCvi)) deallocate(diag_cs%dsamp(dl)%mask3dCvi) + + do i=1,diag_cs%num_diag_coords + if (associated(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d) + enddo + enddo + + ! axes_grp masks may point to diag_cs masks, so do these after mask dealloc + do i=1, diag_cs%num_diag_coords + call axes_grp_end(diag_cs%remap_axesZL(i)) + call axes_grp_end(diag_cs%remap_axesZi(i)) + call axes_grp_end(diag_cs%remap_axesTL(i)) + call axes_grp_end(diag_cs%remap_axesTi(i)) + call axes_grp_end(diag_cs%remap_axesBL(i)) + call axes_grp_end(diag_cs%remap_axesBi(i)) + call axes_grp_end(diag_cs%remap_axesCuL(i)) + call axes_grp_end(diag_cs%remap_axesCui(i)) + call axes_grp_end(diag_cs%remap_axesCvL(i)) + call axes_grp_end(diag_cs%remap_axesCvi(i)) + enddo + + if (diag_cs%num_diag_coords > 0) then + deallocate(diag_cs%remap_axesZL) + deallocate(diag_cs%remap_axesZi) + deallocate(diag_cs%remap_axesTL) + deallocate(diag_cs%remap_axesTi) + deallocate(diag_cs%remap_axesBL) + deallocate(diag_cs%remap_axesBi) + deallocate(diag_cs%remap_axesCuL) + deallocate(diag_cs%remap_axesCui) + deallocate(diag_cs%remap_axesCvL) + deallocate(diag_cs%remap_axesCvi) + endif + + do dl=2,MAX_DSAMP_LEV + if (allocated(diag_cs%dsamp(dl)%remap_axesTL)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTL) + if (allocated(diag_cs%dsamp(dl)%remap_axesTi)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTi) + if (allocated(diag_cs%dsamp(dl)%remap_axesBL)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBL) + if (allocated(diag_cs%dsamp(dl)%remap_axesBi)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBi) + if (allocated(diag_cs%dsamp(dl)%remap_axesCuL)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCuL) + if (allocated(diag_cs%dsamp(dl)%remap_axesCui)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCui) + if (allocated(diag_cs%dsamp(dl)%remap_axesCvL)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvL) + if (allocated(diag_cs%dsamp(dl)%remap_axesCvi)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvi) + enddo + + +#if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) + deallocate(diag_cs%h_old) +#endif + + if (present(end_diag_manager)) then + if (end_diag_manager) call MOM_diag_manager_end(time) + endif + +end subroutine diag_mediator_end + +!> Convert the first n elements (up to 3) of an integer array to an underscore delimited string. +function i2s(a,n_in) + ! "Convert the first n elements of an integer array to a string." + ! Perhaps this belongs elsewhere in the MOM6 code? + integer, dimension(:), intent(in) :: a !< The array of integers to translate + integer, optional , intent(in) :: n_in !< The number of elements to translate, by default all + character(len=15) :: i2s !< The returned string + + character(len=15) :: i2s_temp + integer :: i,n + + n=size(a) + if (present(n_in)) n = n_in + + i2s = '' + do i=1,min(n,3) + write (i2s_temp, '(I4.4)') a(i) + i2s = trim(i2s) //'_'// trim(i2s_temp) + enddo + i2s = adjustl(i2s) +end function i2s + +!> Returns a new diagnostic id, it may be necessary to expand the diagnostics array. +integer function get_new_diag_id(diag_cs) + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure + ! Local variables + type(diag_type), dimension(:), allocatable :: tmp + integer :: i + + if (diag_cs%next_free_diag_id > size(diag_cs%diags)) then + call assert(diag_cs%next_free_diag_id - size(diag_cs%diags) == 1, & + 'get_new_diag_id: inconsistent diag id') + + ! Increase the size of diag_cs%diags and copy data over. + ! Do not use move_alloc() because it is not supported by Fortran 90 + allocate(tmp(size(diag_cs%diags))) + tmp(:) = diag_cs%diags(:) + deallocate(diag_cs%diags) + allocate(diag_cs%diags(size(tmp) + DIAG_ALLOC_CHUNK_SIZE)) + diag_cs%diags(1:size(tmp)) = tmp(:) + deallocate(tmp) + + ! Initialize new part of the diag array. + do i=diag_cs%next_free_diag_id, size(diag_cs%diags) + call initialize_diag_type(diag_cs%diags(i)) + enddo + endif + + get_new_diag_id = diag_cs%next_free_diag_id + diag_cs%next_free_diag_id = diag_cs%next_free_diag_id + 1 + +end function get_new_diag_id + +!> Initializes a diag_type (used after allocating new memory) +subroutine initialize_diag_type(diag) + type(diag_type), intent(inout) :: diag !< diag_type to be initialized + + diag%in_use = .false. + diag%fms_diag_id = -1 + diag%axes => null() + diag%next => null() + diag%conversion_factor = 0. + +end subroutine initialize_diag_type + +!> Make a new diagnostic. Either use memory which is in the array of 'primary' +!! diagnostics, or if that is in use, insert it to the list of secondary diags. +subroutine alloc_diag_with_id(diag_id, diag_cs, diag) + integer, intent(in ) :: diag_id !< id for the diagnostic + type(diag_ctrl), target, intent(inout) :: diag_cs !< structure used to regulate diagnostic output + type(diag_type), pointer :: diag !< structure representing a diagnostic (inout) + + type(diag_type), pointer :: tmp => NULL() + + if (.not. diag_cs%diags(diag_id)%in_use) then + diag => diag_cs%diags(diag_id) + else + allocate(diag) + tmp => diag_cs%diags(diag_id)%next + diag_cs%diags(diag_id)%next => diag + diag%next => tmp + endif + diag%in_use = .true. + +end subroutine alloc_diag_with_id + +!> Log a diagnostic to the available diagnostics file. +subroutine log_available_diag(used, module_name, field_name, cell_methods_string, comment, & + diag_CS, long_name, units, standard_name, variants) + logical, intent(in) :: used !< Whether this diagnostic was in the diag_table or not + character(len=*), intent(in) :: module_name !< Name of the diagnostic module + character(len=*), intent(in) :: field_name !< Name of this diagnostic field + character(len=*), intent(in) :: cell_methods_string !< The spatial component of the CF cell_methods attribute + character(len=*), intent(in) :: comment !< A comment to append after [Used|Unused] + type(diag_ctrl), intent(in) :: diag_CS !< The diagnotics control structure + character(len=*), optional, intent(in) :: long_name !< CF long name of diagnostic + character(len=*), optional, intent(in) :: units !< Units for diagnostic + character(len=*), optional, intent(in) :: standard_name !< CF standardized name of diagnostic + character(len=*), optional, intent(in) :: variants !< Alternate modules and variable names for + !! this diagnostic and derived diagnostics + ! Local variables + character(len=240) :: mesg + + if (used) then + mesg = '"'//trim(field_name)//'" [Used]' + else + mesg = '"'//trim(field_name)//'" [Unused]' + endif + if (len(trim((comment)))>0) then + write(diag_CS%available_diag_doc_unit, '(a,1x,"(",a,")")') trim(mesg),trim(comment) + else + write(diag_CS%available_diag_doc_unit, '(a)') trim(mesg) + endif + call describe_option("modules", module_name, diag_CS) + if (present(long_name)) call describe_option("long_name", long_name, diag_CS) + if (present(units)) call describe_option("units", units, diag_CS) + if (present(standard_name)) & + call describe_option("standard_name", standard_name, diag_CS) + if (len(trim((cell_methods_string)))>0) & + call describe_option("cell_methods", trim(cell_methods_string), diag_CS) + if (present(variants)) then ; if (len(trim(variants)) > 0) then + call describe_option("variants", variants, diag_CS) + endif ; endif +end subroutine log_available_diag + +!> Log the diagnostic chksum to the chksum diag file +subroutine log_chksum_diag(docunit, description, chksum) + integer, intent(in) :: docunit !< Handle of the log file + character(len=*), intent(in) :: description !< Name of the diagnostic module + integer, intent(in) :: chksum !< chksum of the diagnostic + + write(docunit, '(a,1x,i9.8)') description, chksum + flush(docunit) + +end subroutine log_chksum_diag + +!> Allocates fields necessary to store diagnostic remapping fields +subroutine diag_grid_storage_init(grid_storage, G, GV, diag) + type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids + type(ocean_grid_type), intent(in) :: G !< Horizontal grid + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the contructor + !! template for this routine + + integer :: m, nz + grid_storage%num_diag_coords = diag%num_diag_coords + + ! Don't do anything else if there are no remapped coordinates + if (grid_storage%num_diag_coords < 1) return + + ! Allocate memory for the native space + allocate( grid_storage%h_state(G%isd:G%ied, G%jsd:G%jed, GV%ke)) + ! Allocate diagnostic remapping structures + allocate(grid_storage%diag_grids(diag%num_diag_coords)) + ! Loop through and allocate memory for the grid on each target coordinate + do m = 1, diag%num_diag_coords + nz = diag%diag_remap_cs(m)%nz + allocate(grid_storage%diag_grids(m)%h(G%isd:G%ied,G%jsd:G%jed, nz)) + enddo + +end subroutine diag_grid_storage_init + +!> Copy from the main diagnostic arrays to the grid storage as well as the native thicknesses +subroutine diag_copy_diag_to_storage(grid_storage, h_state, diag) + type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids + real, dimension(:,:,:), intent(in) :: h_state !< Current model thicknesses [H ~> m or kg m-2] + type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the contructor + + integer :: m + + ! Don't do anything else if there are no remapped coordinates + if (grid_storage%num_diag_coords < 1) return + + grid_storage%h_state(:,:,:) = h_state(:,:,:) + do m = 1,grid_storage%num_diag_coords + if (diag%diag_remap_cs(m)%nz > 0) & + grid_storage%diag_grids(m)%h(:,:,:) = diag%diag_remap_cs(m)%h(:,:,:) + enddo + +end subroutine diag_copy_diag_to_storage + +!> Copy from the stored diagnostic arrays to the main diagnostic grids +subroutine diag_copy_storage_to_diag(diag, grid_storage) + type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the contructor + type(diag_grid_storage), intent(in) :: grid_storage !< Structure containing a snapshot of the target grids + + integer :: m + + ! Don't do anything else if there are no remapped coordinates + if (grid_storage%num_diag_coords < 1) return + + diag%diag_grid_overridden = .true. + do m = 1,grid_storage%num_diag_coords + if (diag%diag_remap_cs(m)%nz > 0) & + diag%diag_remap_cs(m)%h(:,:,:) = grid_storage%diag_grids(m)%h(:,:,:) + enddo + +end subroutine diag_copy_storage_to_diag + +!> Save the current diagnostic grids in the temporary structure within diag +subroutine diag_save_grids(diag) + type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the contructor + + integer :: m + + ! Don't do anything else if there are no remapped coordinates + if (diag%num_diag_coords < 1) return + + do m = 1,diag%num_diag_coords + if (diag%diag_remap_cs(m)%nz > 0) & + diag%diag_grid_temp%diag_grids(m)%h(:,:,:) = diag%diag_remap_cs(m)%h(:,:,:) + enddo + +end subroutine diag_save_grids + +!> Restore the diagnostic grids from the temporary structure within diag +subroutine diag_restore_grids(diag) + type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the contructor + + integer :: m + + ! Don't do anything else if there are no remapped coordinates + if (diag%num_diag_coords < 1) return + + diag%diag_grid_overridden = .false. + do m = 1,diag%num_diag_coords + if (diag%diag_remap_cs(m)%nz > 0) & + diag%diag_remap_cs(m)%h(:,:,:) = diag%diag_grid_temp%diag_grids(m)%h(:,:,:) + enddo + +end subroutine diag_restore_grids + +!> Deallocates the fields in the remapping fields container +subroutine diag_grid_storage_end(grid_storage) + type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids + ! Local variables + integer :: m + + ! Don't do anything else if there are no remapped coordinates + if (grid_storage%num_diag_coords < 1) return + + ! Deallocate memory for the native space + deallocate(grid_storage%h_state) + ! Loop through and deallocate memory for the grid on each target coordinate + do m = 1, grid_storage%num_diag_coords + deallocate(grid_storage%diag_grids(m)%h) + enddo + ! Deallocate diagnostic remapping structures + deallocate(grid_storage%diag_grids) +end subroutine diag_grid_storage_end + +!< Allocate and initialize the masks for downsampled diagostics in diag_cs +!! The downsampled masks in the axes would later "point" to these. +subroutine downsample_diag_masks_set(G, nz, diag_cs) + type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. + integer, intent(in) :: nz !< The number of layers in the model's native grid. + type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + ! Local variables + integer :: k, dl + +!print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec +!print*,'original c extents ',G%iscb,G%iecb,G%jscb,G%jecb +!print*,'coarse c extents ',G%HId2%isc,G%HId2%iec,G%HId2%jsc,G%HId2%jec +!print*,'original d extents ',G%isd,G%ied,G%jsd,G%jed +!print*,'coarse d extents ',G%HId2%isd,G%HId2%ied,G%HId2%jsd,G%HId2%jed +! original c extents 5 52 5 52 +! original cB-nonsym extents 5 52 5 52 +! original cB-sym extents 4 52 4 52 +! coarse c extents 3 26 3 26 +! original d extents 1 56 1 56 +! original dB-nonsym extents 1 56 1 56 +! original dB-sym extents 0 56 0 56 +! coarse d extents 1 28 1 28 + + do dl=2,MAX_DSAMP_LEV + ! 2d mask + call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl, G%isc, G%jsc, G%isd, G%jsd, & + G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) + call downsample_mask(G%mask2dBu, diag_cs%dsamp(dl)%mask2dBu, dl,G%IscB, G%JscB, G%IsdB, G%JsdB, & + G%HId2%IscB,G%HId2%IecB, G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) + call downsample_mask(G%mask2dCu, diag_cs%dsamp(dl)%mask2dCu, dl, G%IscB, G%jsc, G%IsdB, G%jsd, & + G%HId2%IscB,G%HId2%IecB, G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) + call downsample_mask(G%mask2dCv, diag_cs%dsamp(dl)%mask2dCv, dl,G %isc ,G%JscB, G%isd, G%JsdB, & + G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) + ! 3d native masks are needed by diag_manager but the native variables + ! can only be masked 2d - for ocean points, all layers exists. + allocate(diag_cs%dsamp(dl)%mask3dTL(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dBL(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dCuL(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dCvL(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz)) + do k=1,nz + diag_cs%dsamp(dl)%mask3dTL(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) + diag_cs%dsamp(dl)%mask3dBL(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) + diag_cs%dsamp(dl)%mask3dCuL(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) + diag_cs%dsamp(dl)%mask3dCvL(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) + enddo + allocate(diag_cs%dsamp(dl)%mask3dTi(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dBi(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dCui(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dCvi(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) + do k=1,nz+1 + diag_cs%dsamp(dl)%mask3dTi(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) + diag_cs%dsamp(dl)%mask3dBi(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) + diag_cs%dsamp(dl)%mask3dCui(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) + diag_cs%dsamp(dl)%mask3dCvi(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) + enddo + enddo +end subroutine downsample_diag_masks_set + +!> Get the diagnostics-compute indices (to be passed to send_data) based on the shape of +!! the diag field (the same way they are deduced for non-downsampled fields) +subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev) + integer, intent(in) :: fo1 !< The size of the diag field in x + integer, intent(in) :: fo2 !< The size of the diag field in y + integer, intent(in) :: dl !< Integer downsample level + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + integer, intent(out) :: isv !< i-start index for diagnostics + integer, intent(out) :: iev !< i-end index for diagnostics + integer, intent(out) :: jsv !< j-start index for diagnostics + integer, intent(out) :: jev !< j-end index for diagnostics + ! Local variables + integer :: dszi,cszi,dszj,cszj,f1,f2 + character(len=500) :: mesg + logical, save :: first_check = .true. + + !Check ONCE that the downsampled diag-compute domain is commensurate with the original + !non-downsampled diag-compute domain. + !This is a major limitation of the current implementation of the downsampled diagnostics. + !We assume that the compute domain can be subdivided to dl*dl cells, hence avoiding the need of halo updates. + !We want this check to error out only if there was a downsampled diagnostics requested and about to post that is + !why the check is here and not in the init routines. This check need to be done only once, hence the outer if. + if (first_check) then + if (mod(diag_cs%ie-diag_cs%is+1, dl) /= 0 .OR. mod(diag_cs%je-diag_cs%js+1, dl) /= 0) then + write (mesg,*) "Non-commensurate downsampled domain is not supported. "//& + "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dl=",dl,& + " Current domain extents: ", diag_cs%is,diag_cs%ie, diag_cs%js,diag_cs%je + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) + endif + first_check = .false. + endif + + cszi = diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc +1 ; dszi = diag_cs%dsamp(dl)%ied-diag_cs%dsamp(dl)%isd +1 + cszj = diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc +1 ; dszj = diag_cs%dsamp(dl)%jed-diag_cs%dsamp(dl)%jsd +1 + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec + f1 = fo1/dl + f2 = fo2/dl + !Correction for the symmetric case + if (diag_cs%G%symmetric) then + f1 = f1 + mod(fo1,dl) + f2 = f2 + mod(fo2,dl) + endif + if ( f1 == dszi ) then + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec ! field on Data domain, take compute domain indcies + !The rest is not taken with the full MOM6 diag_table + elseif ( f1 == dszi + 1 ) then + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec+1 ! Symmetric data domain + elseif ( f1 == cszi) then + isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +1 ! Computational domain + elseif ( f1 == cszi + 1 ) then + isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",f1," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) + endif + if ( f2 == dszj ) then + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec ! Data domain + elseif ( f2 == dszj + 1 ) then + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec+1 ! Symmetric data domain + elseif ( f2 == cszj) then + jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +1 ! Computational domain + elseif ( f2 == cszj + 1 ) then + jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",f2," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) + endif +end subroutine downsample_diag_indices_get + +!> This subroutine allocates and computes a downsampled array from an input array +!! It also determines the diagnostics-compurte indices for the downsampled array +!! 3d interface +subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask) + real, dimension(:,:,:), pointer :: locfield !< Input array pointer + real, dimension(:,:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer, intent(in) :: dl !< Level of down sampling + integer, intent(inout) :: isv !< i-start index for diagnostics + integer, intent(inout) :: iev !< i-end index for diagnostics + integer, intent(inout) :: jsv !< j-start index for diagnostics + integer, intent(inout) :: jev !< j-end index for diagnostics + real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + ! Locals + real, dimension(:,:,:), pointer :: locmask + integer :: f1,f2,isv_o,jsv_o + + locmask => NULL() + !Get the correct indices corresponding to input field + !Shape of the input diag field + f1 = size(locfield, 1) + f2 = size(locfield, 2) + !Save the extents of the original (fine) domain + isv_o = isv ; jsv_o = jsv + !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them + call downsample_diag_indices_get(f1, f2, dl, diag_cs, isv, iev, jsv, jev) + !Set the non-downsampled mask, it must be associated and initialized + if (present(mask)) then + locmask => mask + elseif (associated(diag%axes%mask3d)) then + locmask => diag%axes%mask3d + else + call MOM_error(FATAL, "downsample_diag_field_3d: Cannot downsample without a mask!!! ") + endif + + call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs, diag, & + isv_o, jsv_o, isv, iev, jsv, jev) + +end subroutine downsample_diag_field_3d + +!> This subroutine allocates and computes a downsampled array from an input array +!! It also determines the diagnostics-compurte indices for the downsampled array +!! 2d interface +subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask) + real, dimension(:,:), pointer :: locfield !< Input array pointer + real, dimension(:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer, intent(in) :: dl !< Level of down sampling + integer, intent(inout) :: isv !< i-start index for diagnostics + integer, intent(inout) :: iev !< i-end index for diagnostics + integer, intent(inout) :: jsv !< j-start index for diagnostics + integer, intent(inout) :: jev !< j-end index for diagnostics + real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + ! Locals + real, dimension(:,:), pointer :: locmask + integer :: f1,f2,isv_o,jsv_o + + locmask => NULL() + !Get the correct indices corresponding to input field + !Shape of the input diag field + f1 = size(locfield,1) + f2 = size(locfield,2) + !Save the extents of the original (fine) domain + isv_o = isv ; jsv_o = jsv + !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them + call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) + !Set the non-downsampled mask, it must be associated and initialized + if (present(mask)) then + locmask => mask + elseif (associated(diag%axes%mask2d)) then + locmask => diag%axes%mask2d + else + call MOM_error(FATAL, "downsample_diag_field_2d: Cannot downsample without a mask!!! ") + endif + + call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs,diag, & + isv_o,jsv_o,isv,iev,jsv,jev) + +end subroutine downsample_diag_field_2d + +!> \section downsampling The down sample algorithm +!! +!! The down sample method could be deduced (before send_data call) +!! from the diag%x_cell_method, diag%y_cell_method and diag%v_cell_method +!! +!! This is the summary of the down sample algoritm for a diagnostic field f: +!! \f[ +!! f(Id,Jd) = \sum_{i,j} f(Id+i,Jd+j) * weight(Id+i,Jd+j) / [ \sum_{i,j} weight(Id+i,Jd+j)] +!! \f] +!! Here, i and j run from 0 to dl-1 (dl being the down sample level). +!! Id,Jd are the down sampled (coarse grid) indices run over the coarsened compute grid, +!! if and jf are the original (fine grid) indices. +!! +!! \verbatim +!! Example x_cell y_cell v_cell algorithm_id implemented weight(if,jf) +!! --------------------------------------------------------------------------------------- +!! theta mean mean mean MMM =222 G%areaT(if,jf)*h(if,jf) +!! u point mean mean PMM =022 dyCu(if,jf)*h(if,jf)*delta(if,Id) +!! v mean point mean MPM =202 dxCv(if,jf)*h(if,jf)*delta(jf,Jd) +!! ? point sum mean PSM =012 h(if,jf)*delta(if,Id) +!! volcello sum sum sum SSS =111 1 +!! T_dfxy_co sum sum point SSP =110 1 +!! umo point sum sum PSS =011 1*delta(if,Id) +!! vmo sum point sum SPS =101 1*delta(jf,Jd) +!! umo_2d point sum point PSP =010 1*delta(if,Id) +!! vmo_2d sum point point SPP =100 1*delta(jf,Jd) +!! ? point mean point PMP =020 dyCu(if,jf)*delta(if,Id) +!! ? mean point point MPP =200 dxCv(if,jf)*delta(jf,Jd) +!! w mean mean point MMP =220 G%areaT(if,jf) +!! h*theta mean mean sum MMS =221 G%areaT(if,jf) +!! +!! delta is the Kronecker delta +!! \endverbatim + +!> This subroutine allocates and computes a down sampled 3d array given an input array +!! The down sample method is based on the "cell_methods" for the diagnostics as explained +!! in the above table +subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) + real, dimension(:,:,:), pointer :: field_in !< Original field to be down sampled + real, dimension(:,:,:), allocatable :: field_out !< down sampled field + integer, intent(in) :: dl !< Level of down sampling + integer, intent(in) :: method !< Sampling method + real, dimension(:,:,:), pointer :: mask !< Mask for field + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer, intent(in) :: isv_o !< Original i-start index + integer, intent(in) :: jsv_o !< Original j-start index + integer, intent(in) :: isv_d !< i-start index of down sampled data + integer, intent(in) :: iev_d !< i-end index of down sampled data + integer, intent(in) :: jsv_d !< j-start index of down sampled data + integer, intent(in) :: jev_d !< j-end index of down sampled data + ! Locals + character(len=240) :: mesg + integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 + integer :: k,ks,ke + real :: ave,total_weight,weight + real :: eps_vol ! A negligibly small volume or mass [H L2 ~> m3 or kg] + real :: eps_area ! A negligibly small area [L2 ~> m2] + real :: eps_face ! A negligibly small face area [H L ~> m2 or kg m-1] + + ks = 1 ; ke = size(field_in,3) + eps_face = 1.0e-20 * diag_cs%G%US%m_to_L * diag_cs%GV%m_to_H + eps_area = 1.0e-20 * diag_cs%G%US%m_to_L**2 + eps_vol = 1.0e-20 * diag_cs%G%US%m_to_L**2 * diag_cs%GV%m_to_H + + ! Allocate the down sampled field on the down sampled data domain +! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed,ks:ke)) +! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl,ks:ke)) + f_in1 = size(field_in,1) + f_in2 = size(field_in,2) + f1 = f_in1/dl + f2 = f_in2/dl + !Correction for the symmetric case + if (diag_cs%G%symmetric) then + f1 = f1 + mod(f_in1,dl) + f2 = f2 + mod(f_in2,dl) + endif + allocate(field_out(1:f1,1:f2,ks:ke)) + + ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain + !### The averaging used here is not rotationally invariant. + if (method == MMM) then + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 !This seems to be faster!!!! + weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) * diag_cs%h(ii,jj,k) + total_weight = total_weight + weight + ave = ave+field_in(ii,jj,k) * weight + enddo ; enddo + field_out(i,j,k) = ave/(total_weight + eps_vol) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo ; enddo + elseif (method == SSS) then !e.g., volcello + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + weight = mask(ii,jj,k) + ave = ave+field_in(ii,jj,k)*weight + enddo ; enddo + field_out(i,j,k) = ave !Masked Sum (total_weight=1) + enddo ; enddo ; enddo + elseif (method == MMP .or. method == MMS) then !e.g., T_advection_xy + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) + total_weight = total_weight + weight + ave = ave+field_in(ii,jj,k)*weight + enddo ; enddo + field_out(i,j,k) = ave / (total_weight+eps_area) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo ; enddo + elseif (method == PMM) then + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight = mask(ii,jj,k) * diag_cs%G%dyCu(ii,jj) * diag_cs%h(ii,jj,k) + total_weight = total_weight +weight + ave = ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo ; enddo + elseif (method == PSS) then !e.g. umo + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight = mask(ii,jj,k) + ave = ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave !Masked Sum (total_weight=1) + enddo ; enddo ; enddo + elseif (method == SPS) then !e.g. vmo + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight = mask(ii,jj,k) + ave = ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave !Masked Sum (total_weight=1) + enddo ; enddo ; enddo + elseif (method == MPM) then + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight = mask(ii,jj,k) * diag_cs%G%dxCv(ii,jj) * diag_cs%h(ii,jj,k) + total_weight = total_weight + weight + ave = ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo ; enddo + elseif (method == MSK) then !The input field is a mask, subsample + field_out(:,:,:) = 0.0 + do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + ave = ave+field_in(ii,jj,k) + enddo ; enddo + if (ave > 0.0) field_out(i,j,k)=1.0 + enddo ; enddo ; enddo + else + write (mesg,*) " unknown sampling method: ",method + call MOM_error(FATAL, "downsample_field_3d: "//trim(mesg)//" "//trim(diag%debug_str)) + endif + +end subroutine downsample_field_3d + +!> This subroutine allocates and computes a down sampled 2d array given an input array +!! The down sample method is based on the "cell_methods" for the diagnostics as explained +!! in the above table +subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, diag, & + isv_o, jsv_o, isv_d, iev_d, jsv_d, jev_d) + real, dimension(:,:), pointer :: field_in !< Original field to be down sampled + real, dimension(:,:), allocatable :: field_out !< Down sampled field + integer, intent(in) :: dl !< Level of down sampling + integer, intent(in) :: method !< Sampling method + real, dimension(:,:), pointer :: mask !< Mask for field + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer, intent(in) :: isv_o !< Original i-start index + integer, intent(in) :: jsv_o !< Original j-start index + integer, intent(in) :: isv_d !< i-start index of down sampled data + integer, intent(in) :: iev_d !< i-end index of down sampled data + integer, intent(in) :: jsv_d !< j-start index of down sampled data + integer, intent(in) :: jev_d !< j-end index of down sampled data + ! Locals + character(len=240) :: mesg + integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 + real :: ave, total_weight, weight + real :: eps_area ! A negligibly small area [L2 ~> m2] + real :: eps_len ! A negligibly small horizontal length [L ~> m] + + eps_len = 1.0e-20 * diag_cs%G%US%m_to_L + eps_area = 1.0e-20 * diag_cs%G%US%m_to_L**2 + + ! Allocate the down sampled field on the down sampled data domain +! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed)) +! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl)) + ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain + f_in1 = size(field_in,1) + f_in2 = size(field_in,2) + f1 = f_in1/dl + f2 = f_in2/dl + ! Correction for the symmetric case + if (diag_cs%G%symmetric) then + f1 = f1 + mod(f_in1,dl) + f2 = f2 + mod(f_in2,dl) + endif + allocate(field_out(1:f1,1:f2)) + + if (method == MMP) then + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj) + total_weight = total_weight + weight + ave = ave+field_in(ii,jj)*weight + enddo ; enddo + field_out(i,j) = ave/(total_weight + eps_area) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo + elseif (method == SSP) then ! e.g., T_dfxy_cont_tendency_2d + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj) + ave = ave+field_in(ii,jj)*weight + enddo ; enddo + field_out(i,j) = ave !Masked Sum (total_weight=1) + enddo ; enddo + elseif (method == PSP) then ! e.g., umo_2d + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight = mask(ii,jj) + ave = ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave !Masked Sum (total_weight=1) + enddo ; enddo + elseif (method == SPP) then ! e.g., vmo_2d + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight = mask(ii,jj) + ave = ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave !Masked Sum (total_weight=1) + enddo ; enddo + elseif (method == PMP) then + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight = mask(ii,jj) * diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + total_weight = total_weight +weight + ave = ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo + elseif (method == MPP) then + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight = mask(ii,jj)* diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + total_weight = total_weight +weight + ave = ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo ; enddo + elseif (method == MSK) then !The input field is a mask, subsample + field_out(:,:) = 0.0 + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + ave = ave+field_in(ii,jj) + enddo ; enddo + if (ave > 0.0) field_out(i,j)=1.0 + enddo ; enddo + else + write (mesg,*) " unknown sampling method: ",method + call MOM_error(FATAL, "downsample_field_2d: "//trim(mesg)//" "//trim(diag%debug_str)) + endif + +end subroutine downsample_field_2d + +!> Allocate and compute the 2d down sampled mask +!! The masks are down sampled based on a minority rule, i.e., a coarse cell is open (1) +!! if at least one of the sub-cells are open, otherwise it's closed (0) +subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isd_o, jsd_o, & + isc_d, iec_d, jsc_d, jec_d, isd_d, ied_d, jsd_d, jed_d) + integer, intent(in) :: isd_o !< Original data domain i-start index + integer, intent(in) :: jsd_o !< Original data domain j-start index + real, dimension(isd_o:,jsd_o:), intent(in) :: field_in !< Original field to be down sampled in arbitrary units [A] + real, dimension(:,:), pointer :: field_out !< Down sampled field mask [nondim] + integer, intent(in) :: dl !< Level of down sampling + integer, intent(in) :: isc_o !< Original i-start index + integer, intent(in) :: jsc_o !< Original j-start index + integer, intent(in) :: isc_d !< Computational i-start index of down sampled data + integer, intent(in) :: iec_d !< Computational i-end index of down sampled data + integer, intent(in) :: jsc_d !< Computational j-start index of down sampled data + integer, intent(in) :: jec_d !< Computational j-end index of down sampled data + integer, intent(in) :: isd_d !< Data domain i-start index of down sampled data + integer, intent(in) :: ied_d !< Data domain i-end index of down sampled data + integer, intent(in) :: jsd_d !< Data domain j-start index of down sampled data + integer, intent(in) :: jed_d !< Data domain j-end index of down sampled data + ! Locals + integer :: i,j,ii,jj,i0,j0 + real :: tot_non_zero ! The sum of values in the down-scaled cell [A] + ! down sampled mask = 0 unless the mask value of one of the down sampling cells is 1 + allocate(field_out(isd_d:ied_d,jsd_d:jed_d)) + field_out(:,:) = 0.0 + do j=jsc_d,jec_d ; do i=isc_d,iec_d + i0 = isc_o+dl*(i-isc_d) + j0 = jsc_o+dl*(j-jsc_d) + tot_non_zero = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + tot_non_zero = tot_non_zero + field_in(ii,jj) + enddo ; enddo + if (tot_non_zero > 0.0) field_out(i,j)=1.0 + enddo ; enddo +end subroutine downsample_mask_2d + +!> Allocate and compute the 3d down sampled mask +!! The masks are down sampled based on a minority rule, i.e., a coarse cell is open (1) +!! if at least one of the sub-cells are open, otherwise it's closed (0) +subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isd_o, jsd_o, & + isc_d, iec_d, jsc_d, jec_d, isd_d, ied_d, jsd_d, jed_d) + integer, intent(in) :: isd_o !< Original data domain i-start index + integer, intent(in) :: jsd_o !< Original data domain j-start index + real, dimension(isd_o:,jsd_o:,:), intent(in) :: field_in !< Original field to be down sampled in arbitrary units [A] + real, dimension(:,:,:), pointer :: field_out !< down sampled field mask [nondim] + integer, intent(in) :: dl !< Level of down sampling + integer, intent(in) :: isc_o !< Original i-start index + integer, intent(in) :: jsc_o !< Original j-start index + integer, intent(in) :: isc_d !< Computational i-start index of down sampled data + integer, intent(in) :: iec_d !< Computational i-end index of down sampled data + integer, intent(in) :: jsc_d !< Computational j-start index of down sampled data + integer, intent(in) :: jec_d !< Computational j-end index of down sampled data + integer, intent(in) :: isd_d !< Computational i-start index of down sampled data + integer, intent(in) :: ied_d !< Computational i-end index of down sampled data + integer, intent(in) :: jsd_d !< Computational j-start index of down sampled data + integer, intent(in) :: jed_d !< Computational j-end index of down sampled data + ! Locals + integer :: i,j,ii,jj,i0,j0,k,ks,ke + real :: tot_non_zero ! The sum of values in the down-scaled cell [A] + ! down sampled mask = 0 unless the mask value of one of the down sampling cells is 1 + ks = lbound(field_in,3) ; ke = ubound(field_in,3) + allocate(field_out(isd_d:ied_d,jsd_d:jed_d,ks:ke)) + field_out(:,:,:) = 0.0 + do k=ks,ke ; do j=jsc_d,jec_d ; do i=isc_d,iec_d + i0 = isc_o+dl*(i-isc_d) + j0 = jsc_o+dl*(j-jsc_d) + tot_non_zero = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + tot_non_zero = tot_non_zero + field_in(ii,jj,k) + enddo ; enddo + if (tot_non_zero > 0.0) field_out(i,j,k)=1.0 + enddo ; enddo ; enddo +end subroutine downsample_mask_3d + +!> Fakes a register of a diagnostic to find out if an obsolete +!! parameter appears in the diag_table. +logical function found_in_diagtable(diag, varName) + type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. + character(len=*), intent(in) :: varName !< The obsolete diagnostic name + ! Local + integer :: handle ! Integer handle returned from diag_manager + + ! We use register_static_field_fms() instead of register_static_field() so + ! that the diagnostic does not appear in the available diagnostics list. + handle = register_static_field_infra('ocean_model', varName, diag%axesT1%handles) + + found_in_diagtable = (handle>0) + +end function found_in_diagtable + +end module MOM_diag_mediator diff --git a/framework/MOM_diag_remap.F90 b/framework/MOM_diag_remap.F90 new file mode 100644 index 0000000000..ace50242a5 --- /dev/null +++ b/framework/MOM_diag_remap.F90 @@ -0,0 +1,954 @@ +!> provides runtime remapping of diagnostics to z star, sigma and +!! rho vertical coordinates. +!! +!! The diag_remap_ctrl type represents a remapping of diagnostics to a particular +!! vertical coordinate. The module is used by the diag mediator module in the +!! following way: +!! 1. diag_remap_init() is called to initialize a diag_remap_ctrl instance. +!! 2. diag_remap_configure_axes() is called to read the configuration file and set up the +!! vertical coordinate / axes definitions. +!! 3. diag_remap_get_axes_info() returns information needed for the diag mediator to +!! define new axes for the remapped diagnostics. +!! 4. diag_remap_update() is called periodically (whenever h, T or S change) to either +!! create or update the target remapping grids. +!! 5. diag_remap_do_remap() is called from within a diag post() to do the remapping before +!! the diagnostic is written out. + + +! NOTE: In the following functions, the fields are initially passed using 1-based +! indexing, which are then passed to separate private internal routines that shift +! the indexing to use the same indexing conventions used elsewhere in the MOM6 code. +! +! * diag_remap_do_remap, which calls do_remap +! * vertically_reintegrate_diag_field, which calls vertically_reintegrate_field +! * vertically_interpolate_diag_field, which calls vertically_interpolate_field +! * horizontally_average_diag_field, which calls horizontally_average_field + + +module MOM_diag_remap + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : reproducing_sum_EFP, EFP_to_real +use MOM_coms, only : EFP_type, assignment(=), EFP_sum_across_PEs +use MOM_error_handler, only : MOM_error, FATAL, assert, WARNING +use MOM_debugging, only : check_column_integrals +use MOM_diag_manager_infra,only : MOM_diag_axis_init +use MOM_file_parser, only : get_param, log_param, param_file_type +use MOM_string_functions, only : lowercase, extractWord +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : EOS_type +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_remapping, only : interpolate_column, reintegrate_column +use MOM_regridding, only : regridding_CS, initialize_regridding, end_regridding +use MOM_regridding, only : set_regrid_params, get_regrid_size +use MOM_regridding, only : getCoordinateInterfaces, set_h_neglect, set_dz_neglect +use MOM_regridding, only : get_zlike_CS, get_sigma_CS, get_rho_CS +use regrid_consts, only : coordinateMode +use coord_zlike, only : build_zstar_column +use coord_sigma, only : build_sigma_column +use coord_rho, only : build_rho_column + + +implicit none ; private + +#include "MOM_memory.h" + +public diag_remap_ctrl +public diag_remap_init, diag_remap_end, diag_remap_update, diag_remap_do_remap +public diag_remap_configure_axes, diag_remap_axes_configured +public diag_remap_calc_hmask +public diag_remap_get_axes_info, diag_remap_set_active +public diag_remap_diag_registration_closed +public vertically_reintegrate_diag_field +public vertically_interpolate_diag_field +public horizontally_average_diag_field + +!> Represents remapping of diagnostics to a particular vertical coordinate. +!! +!! There is one of these types for each vertical coordinate. The vertical axes +!! of a diagnostic will reference an instance of this type indicating how (or +!! if) the diagnostic should be vertically remapped when being posted. +type :: diag_remap_ctrl + logical :: configured = .false. !< Whether vertical coordinate has been configured + logical :: initialized = .false. !< Whether remappping initialized + logical :: used = .false. !< Whether this coordinate actually gets used. + integer :: vertical_coord = 0 !< The vertical coordinate that we remap to + character(len=10) :: vertical_coord_name ='' !< The coordinate name as understood by ALE + logical :: Z_based_coord = .false. !< If true, this coordinate is based on remapping of + !! geometric distances across layers (in [Z ~> m]) rather + !! than layer thicknesses (in [H ~> m or kg m-2]). This + !! distinction only matters in non-Boussinesq mode. + character(len=16) :: diag_coord_name = '' !< A name for the purpose of run-time parameters + character(len=8) :: diag_module_suffix = '' !< The suffix for the module to appear in diag_table + type(remapping_CS) :: remap_cs !< Remapping control structure use for this axes + type(regridding_CS) :: regrid_cs !< Regridding control structure that defines the coordinates for this axes + integer :: nz = 0 !< Number of vertical levels used for remapping + real, dimension(:,:,:), allocatable :: h !< Remap grid thicknesses in [H ~> m or kg m-2] or + !! vertical extents in [Z ~> m], depending on the setting of Z_based_coord. + real, dimension(:,:,:), allocatable :: h_extensive !< Remap grid thicknesses in [H ~> m or kg m-2] or + !! vertical extents in [Z ~> m] for remapping extensive variables + integer :: interface_axes_id = 0 !< Vertical axes id for remapping at interfaces + integer :: layer_axes_id = 0 !< Vertical axes id for remapping on layers + integer :: answer_date !< The vintage of the order of arithmetic and expressions + !! to use for remapping. Values below 20190101 recover + !! the answers from 2018, while higher values use more + !! robust forms of the same remapping expressions. + +end type diag_remap_ctrl + +contains + +!> Initialize a diagnostic remapping type with the given vertical coordinate. +subroutine diag_remap_init(remap_cs, coord_tuple, answer_date, GV) + type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure + character(len=*), intent(in) :: coord_tuple !< A string in form of + !! MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME + integer, intent(in) :: answer_date !< The vintage of the order of arithmetic and expressions + !! to use for remapping. Values below 20190101 recover + !! the answers from 2018, while higher values use more + !! robust forms of the same remapping expressions. + type(verticalGrid_type), intent(in) :: GV !< The ocean vertical grid structure, used here to evaluate + !! whether the model is in non-Boussinesq mode. + + remap_cs%diag_module_suffix = trim(extractWord(coord_tuple, 1)) + remap_cs%diag_coord_name = trim(extractWord(coord_tuple, 2)) + remap_cs%vertical_coord_name = trim(extractWord(coord_tuple, 3)) + remap_cs%vertical_coord = coordinateMode(remap_cs%vertical_coord_name) + remap_cs%Z_based_coord = .false. + if (.not.(GV%Boussinesq .or. GV%semi_Boussinesq) .and. & + ((remap_cs%vertical_coord == coordinateMode('ZSTAR')) .or. & + (remap_cs%vertical_coord == coordinateMode('SIGMA')) .or. & + (remap_cs%vertical_coord == coordinateMode('RHO'))) ) & + remap_cs%Z_based_coord = .true. + + remap_cs%configured = .false. + remap_cs%initialized = .false. + remap_cs%used = .false. + remap_cs%answer_date = answer_date + remap_cs%nz = 0 + +end subroutine diag_remap_init + +!> De-init a diagnostic remapping type. +!! Free allocated memory. +subroutine diag_remap_end(remap_cs) + type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure + + if (allocated(remap_cs%h)) deallocate(remap_cs%h) + + remap_cs%configured = .false. + remap_cs%initialized = .false. + remap_cs%used = .false. + remap_cs%nz = 0 + +end subroutine diag_remap_end + +!> Inform that all diagnostics have been registered. +!! If _set_active() has not been called on the remapping control structure +!! will be disabled. This saves time in the case that a vertical coordinate was +!! configured but no diagnostics which use the coordinate appeared in the +!! diag_table. +subroutine diag_remap_diag_registration_closed(remap_cs) + type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure + + if (.not. remap_cs%used) then + call diag_remap_end(remap_cs) + call end_regridding(remap_cs%regrid_cs) + endif + +end subroutine diag_remap_diag_registration_closed + +!> Indicate that this remapping type is actually used by the diag manager. +!! If this is never called then the type will be disabled to save time. +!! See further explanation with diag_remap_registration_closed. +subroutine diag_remap_set_active(remap_cs) + type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure + + remap_cs%used = .true. + +end subroutine diag_remap_set_active + +!> Configure the vertical axes for a diagnostic remapping control structure. +!! Reads a configuration parameters to determine coordinate generation. +subroutine diag_remap_configure_axes(remap_cs, GV, US, param_file) + type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remap 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 structure + + ! Local variables + character(len=40) :: mod = "MOM_diag_remap" ! This module's name. + character(len=8) :: units + character(len=34) :: longname + real, allocatable, dimension(:) :: interfaces, layers + + call initialize_regridding(remap_cs%regrid_cs, GV, US, GV%max_depth, param_file, mod, & + trim(remap_cs%vertical_coord_name), "DIAG_COORD", trim(remap_cs%diag_coord_name)) + call set_regrid_params(remap_cs%regrid_cs, min_thickness=0., integrate_downward_for_e=.false.) + + remap_cs%nz = get_regrid_size(remap_cs%regrid_cs) + + if (remap_cs%vertical_coord == coordinateMode('SIGMA')) then + units = 'nondim' + longname = 'Fraction' + elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then + units = 'kg m-3' + longname = 'Target Potential Density' + else + units = 'meters' + longname = 'Depth' + endif + + ! Make axes objects + allocate(interfaces(remap_cs%nz+1)) + allocate(layers(remap_cs%nz)) + + interfaces(:) = getCoordinateInterfaces(remap_cs%regrid_cs, undo_scaling=.true.) + layers(:) = 0.5 * ( interfaces(1:remap_cs%nz) + interfaces(2:remap_cs%nz+1) ) + + remap_cs%interface_axes_id = MOM_diag_axis_init(lowercase(trim(remap_cs%diag_coord_name))//'_i', & + interfaces, trim(units), 'z', & + trim(longname)//' at interface', direction=-1) + remap_cs%layer_axes_id = MOM_diag_axis_init(lowercase(trim(remap_cs%diag_coord_name))//'_l', & + layers, trim(units), 'z', & + trim(longname)//' at cell center', direction=-1, & + edges=remap_cs%interface_axes_id) + + ! Axes have now been configured. + remap_cs%configured = .true. + + deallocate(interfaces) + deallocate(layers) + +end subroutine diag_remap_configure_axes + +!> Get layer and interface axes ids for this coordinate +!! Needed when defining axes groups. +subroutine diag_remap_get_axes_info(remap_cs, nz, id_layer, id_interface) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + integer, intent(out) :: nz !< Number of vertical levels for the coordinate + integer, intent(out) :: id_layer !< 1D-axes id for layer points + integer, intent(out) :: id_interface !< 1D-axes id for interface points + + nz = remap_cs%nz + id_layer = remap_cs%layer_axes_id + id_interface = remap_cs%interface_axes_id + +end subroutine diag_remap_get_axes_info + + +!> Whether or not the axes for this vertical coordinated has been configured. +!! Configuration is complete when diag_remap_configure_axes() has been +!! successfully called. +function diag_remap_axes_configured(remap_cs) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + logical :: diag_remap_axes_configured + + diag_remap_axes_configured = remap_cs%configured + +end function + +!> Build/update target vertical grids for diagnostic remapping. +!! \note The target grids need to be updated whenever sea surface +!! height or layer thicknesses changes. In the case of density-based +!! coordinates then technically we should also regenerate the +!! target grid whenever T/S change. +subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_target) + type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), pointer :: G !< The ocean's grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< New thickness in [H ~> m or kg m-2] or [Z ~> m], depending + !! on the value of remap_cs%Z_based_coord + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: T !< New temperatures [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: S !< New salinities [S ~> ppt] + type(EOS_type), intent(in) :: eqn_of_state !< A pointer to the equation of state + real, dimension(SZI_(G),SZJ_(G),remap_cs%nz), & + intent(inout) :: h_target !< The new diagnostic thicknesses in [H ~> m or kg m-2] + !! or [Z ~> m], depending on the value of remap_cs%Z_based_coord + + ! Local variables + real, dimension(remap_cs%nz + 1) :: zInterfaces ! Interface positions [H ~> m or kg m-2] or [Z ~> m] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] or [Z ~> m] + real :: bottom_depth(SZI_(G),SZJ_(G)) ! The depth of the bathymetry in [H ~> m or kg m-2] or [Z ~> m] + real :: h_tot(SZI_(G),SZJ_(G)) ! The total thickness of the water column [H ~> m or kg m-2] or [Z ~> m] + real :: Z_unit_scale ! A conversion factor from Z-units the internal work units in this routine, + ! in units of [H Z-1 ~> 1 or kg m-3] or [nondim], depending on remap_cs%Z_based_coord. + integer :: i, j, k, is, ie, js, je, nz + + ! Note that coordinateMode('LAYER') is never 'configured' so will always return here. + if (.not. remap_cs%configured) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + ! Set the bottom depth and negligible thicknesses used in the coordinate remapping in the right units. + if (remap_cs%Z_based_coord) then + h_neglect = set_dz_neglect(GV, US, remap_cs%answer_date, h_neglect_edge) + Z_unit_scale = 1.0 + do j=js-1,je+1 ; do i=is-1,ie+1 + bottom_depth(i,j) = G%bathyT(i,j) + G%Z_ref + enddo ; enddo + else + h_neglect = set_h_neglect(GV, remap_cs%answer_date, h_neglect_edge) + Z_unit_scale = GV%Z_to_H ! This branch is not used in fully non-Boussinesq mode. + do j=js-1,je+1 ; do i=is-1,ie+1 + bottom_depth(i,j) = GV%Z_to_H * (G%bathyT(i,j) + G%Z_ref) + enddo ; enddo + endif + + if (.not. remap_cs%initialized) then + ! Initialize remapping and regridding on the first call + call initialize_remapping(remap_cs%remap_cs, 'PPM_IH4', boundary_extrapolation=.false., & + answer_date=remap_cs%answer_date) + remap_cs%initialized = .true. + endif + + ! Calculate the total thickness of the water column, if it is needed, + if ((remap_cs%vertical_coord == coordinateMode('ZSTAR')) .or. & + (remap_cs%vertical_coord == coordinateMode('SIGMA'))) then + if (remap_CS%answer_date >= 20240201) then + ! Avoid using sum to have a specific order for the vertical sums. + ! For some compilers, the explicit expression gives the same answers as the sum function. + h_tot(:,:) = 0.0 + do k=1,GV%ke ; do j=js-1,je+1 ; do i=is-1,ie+1 + h_tot(i,j) = h_tot(i,j) + h(i,j,k) + enddo ; enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + h_tot(i,j) = sum(h(i,j,:)) + enddo ; enddo + endif + endif + + ! Calculate remapping thicknesses for different target grids based on + ! nominal/target interface locations. This happens for every call on the + ! assumption that h, T, S has changed. + h_target(:,:,:) = 0.0 + + nz = remap_cs%nz + if (remap_cs%vertical_coord == coordinateMode('ZSTAR')) then + do j=js-1,je+1 ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then + ! This function call can work with the last 4 arguments all in units of [Z ~> m] or [H ~> kg m-2]. + call build_zstar_column(get_zlike_CS(remap_cs%regrid_cs), & + bottom_depth(i,j), h_tot(i,j), zInterfaces, zScale=Z_unit_scale) + do k=1,nz ; h_target(i,j,k) = zInterfaces(K) - zInterfaces(K+1) ; enddo + endif ; enddo ; enddo + elseif (remap_cs%vertical_coord == coordinateMode('SIGMA')) then + do j=js-1, je+1 ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then + ! This function call can work with the last 3 arguments all in units of [Z ~> m] or [H ~> kg m-2]. + call build_sigma_column(get_sigma_CS(remap_cs%regrid_cs), & + bottom_depth(i,j), h_tot(i,j), zInterfaces) + do k=1,nz ; h_target(i,j,k) = zInterfaces(K) - zInterfaces(K+1) ; enddo + endif ; enddo ; enddo + elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then + do j=js-1,je+1 ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then + ! This function call can work with 5 arguments in units of [Z ~> m] or [H ~> kg m-2]. + call build_rho_column(get_rho_CS(remap_cs%regrid_cs), GV%ke, & + bottom_depth(i,j), h(i,j,:), T(i,j,:), S(i,j,:), & + eqn_of_state, zInterfaces, h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + do k=1,nz ; h_target(i,j,k) = zInterfaces(K) - zInterfaces(K+1) ; enddo + endif ; enddo ; enddo + elseif (remap_cs%vertical_coord == coordinateMode('HYCOM1')) then + call MOM_error(FATAL,"diag_remap_update: HYCOM1 coordinate not coded for diagnostics yet!") +! do j=js-1,je+1 ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then +! call build_hycom1_column(remap_cs%regrid_cs, nz, & +! bottom_depth(i,j), h_tot(i,j), zInterfaces) +! do k=1,nz ; h_target(i,j,k) = zInterfaces(K) - zInterfaces(K+1) ; enddo +! endif ; enddo ; enddo + endif + +end subroutine diag_remap_update + +!> Remap diagnostic field to alternative vertical grid. +subroutine diag_remap_do_remap(remap_cs, G, GV, US, h, staggered_in_x, staggered_in_y, & + mask, field, remapped_field) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], + !! depending on the value of remap_CS%Z_based_coord + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim]. + real, dimension(:,:,:), intent(in) :: field(:,:,:) !< The diagnostic field to be remapped [A] + real, dimension(:,:,:), intent(out) :: remapped_field !< Field remapped to new coordinate [A] + + ! Local variables + integer :: isdf, jsdf !< The starting i- and j-indices in memory for field + + call assert(remap_cs%initialized, 'diag_remap_do_remap: remap_cs not initialized.') + call assert(size(field, 3) == size(h, 3), & + 'diag_remap_do_remap: Remap field and thickness z-axes do not match.') + + isdf = G%isd ; if (staggered_in_x) Isdf = G%IsdB + jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB + + if (associated(mask)) then + call do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, remapped_field, mask(:,:,1)) + else + call do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, remapped_field) + endif + +end subroutine diag_remap_do_remap + +!> The internal routine to remap a diagnostic field to an alternative vertical grid. +subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, remapped_field, mask) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: isdf !< The starting i-index in memory for field + integer, intent(in) :: jsdf !< The starting j-index in memory for field + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], + !! depending on the value of remap_CS%Z_based_coord + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(isdf:,jsdf:,:), & + intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(isdf:,jsdf:,:), & + intent(out) :: remapped_field !< Field remapped to new coordinate [A] + real, dimension(isdf:,jsdf:), & + optional, intent(in) :: mask !< A mask for the field [nondim] + + ! Local variables + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] or [Z ~> m] + real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] or [Z ~> m] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] or [Z ~> m] + integer :: nz_src, nz_dest ! The number of layers on the native and remapped grids + integer :: i, j ! Grid index + + if (remap_cs%Z_based_coord) then + h_neglect = set_dz_neglect(GV, US, remap_cs%answer_date, h_neglect_edge) + else + h_neglect = set_h_neglect(GV, remap_cs%answer_date, h_neglect_edge) + endif + + nz_src = size(field,3) + nz_dest = remap_cs%nz + remapped_field(:,:,:) = 0. + + if (staggered_in_x .and. .not. staggered_in_y) then + ! U-points + if (present(mask)) then + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (mask(I,j) > 0.) then + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(I,j,:), & + nz_dest, h_dest(:), remapped_field(I,j,:), h_neglect, h_neglect_edge) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(I,j,:), & + nz_dest, h_dest(:), remapped_field(I,j,:), h_neglect, h_neglect_edge) + enddo ; enddo + endif + elseif (staggered_in_y .and. .not. staggered_in_x) then + ! V-points + if (present(mask)) then + do J=G%jscB,G%jecB ; do i=G%isc,G%iec ; if (mask(i,j) > 0.) then + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,J,:), & + nz_dest, h_dest(:), remapped_field(i,J,:), h_neglect, h_neglect_edge) + endif ; enddo ; enddo + else + do J=G%jscB,G%jecB ; do i=G%isc,G%iec + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,J,:), & + nz_dest, h_dest(:), remapped_field(i,J,:), h_neglect, h_neglect_edge) + enddo ; enddo + endif + elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then + ! H-points + if (present(mask)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (mask(i,j) > 0.) then + call remapping_core_h(remap_cs%remap_cs, nz_src, h(i,j,:), field(i,j,:), & + nz_dest, remap_cs%h(i,j,:), remapped_field(i,j,:), & + h_neglect, h_neglect_edge) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call remapping_core_h(remap_cs%remap_cs, nz_src, h(i,j,:), field(i,j,:), & + nz_dest, remap_cs%h(i,j,:), remapped_field(i,j,:), & + h_neglect, h_neglect_edge) + enddo ; enddo + endif + else + call assert(.false., 'diag_remap_do_remap: Unsupported axis combination') + endif + +end subroutine do_remap + +!> Calculate masks for target grid +subroutine diag_remap_calc_hmask(remap_cs, G, mask) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + real, dimension(G%isd:,G%jsd:,:), & + intent(out) :: mask !< h-point mask for target grid [nondim] + + ! Local variables + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] or [Z ~> m] + integer :: i, j, k + logical :: mask_vanished_layers + real :: h_tot ! Sum of all thicknesses [H ~> m or kg m-2] or [Z ~> m] + real :: h_err ! An estimate of a negligible thickness [H ~> m or kg m-2] or [Z ~> m] + + call assert(remap_cs%initialized, 'diag_remap_calc_hmask: remap_cs not initialized.') + + ! Only z*-like diagnostic coordinates should have a 3d mask + mask_vanished_layers = (remap_cs%vertical_coord == coordinateMode('ZSTAR')) + mask(:,:,:) = 0. + + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + if (G%mask2dT(i,j)>0.) then + if (mask_vanished_layers) then + h_dest(:) = remap_cs%h(i,j,:) + h_tot = 0. + h_err = 0. + do k=1, remap_cs%nz + h_tot = h_tot + h_dest(k) + ! This is an overestimate of how thick a vanished layer might be, that + ! appears due to round-off. + h_err = h_err + epsilon(h_tot) * h_tot + ! Mask out vanished layers + if (h_dest(k)<=8.*h_err) then + mask(i,j,k) = 0. + else + mask(i,j,k) = 1. + endif + enddo + else ! all layers might contain data + mask(i,j,:) = 1. + endif + endif + enddo ; enddo + +end subroutine diag_remap_calc_hmask + +!> Vertically re-grid an already vertically-integrated diagnostic field to alternative vertical grid. +subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered_in_x, staggered_in_y, & + mask, field, reintegrated_field) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + real, dimension(:,:,:), intent(in) :: h !< The thicknesses of the source grid [H ~> m or kg m-2] or [Z ~> m] + real, dimension(:,:,:), intent(in) :: h_target !< The thicknesses of the target grid [H ~> m or kg m-2] or [Z ~> m] + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim]. Note that because this + !! is a pointer it retains its declared indexing conventions. + real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(:,:,:), intent(out) :: reintegrated_field !< Field argument remapped to alternative coordinate [A] + + ! Local variables + integer :: isdf, jsdf !< The starting i- and j-indices in memory for field + + call assert(remap_cs%initialized, 'vertically_reintegrate_diag_field: remap_cs not initialized.') + call assert(size(field, 3) == size(h, 3), & + 'vertically_reintegrate_diag_field: Remap field and thickness z-axes do not match.') + + isdf = G%isd ; if (staggered_in_x) Isdf = G%IsdB + jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB + + if (associated(mask)) then + call vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, staggered_in_x, staggered_in_y, & + field, reintegrated_field, mask(:,:,1)) + else + call vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, staggered_in_x, staggered_in_y, & + field, reintegrated_field) + endif + +end subroutine vertically_reintegrate_diag_field + +!> The internal routine to vertically re-grid an already vertically-integrated diagnostic field to +!! an alternative vertical grid. +subroutine vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, staggered_in_x, staggered_in_y, & + field, reintegrated_field, mask) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + integer, intent(in) :: isdf !< The starting i-index in memory for field + integer, intent(in) :: jsdf !< The starting j-index in memory for field + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h !< The thicknesses of the source grid [H ~> m or kg m-2] or [Z ~> m] + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h_target !< The thicknesses of the target grid [H ~> m or kg m-2] or [Z ~> m] + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(isdf:,jsdf:,:), & + intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(isdf:,jsdf:,:), & + intent(out) :: reintegrated_field !< Field argument remapped to alternative coordinate [A] + real, dimension(isdf:,jsdf:), & + optional, intent(in) :: mask !< A mask for the field [nondim] + + ! Local variables + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] or [Z ~> m] + real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] or [Z ~> m] + integer :: nz_src, nz_dest ! The number of layers on the native and remapped grids + integer :: i, j ! Grid index + + nz_src = size(field,3) + nz_dest = remap_cs%nz + reintegrated_field(:,:,:) = 0. + + if (staggered_in_x .and. .not. staggered_in_y) then + ! U-points + if (present(mask)) then + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (mask(I,j) > 0.0) then + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i+1,j,:)) + call reintegrate_column(nz_src, h_src, field(I,j,:), & + nz_dest, h_dest, reintegrated_field(I,j,:)) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i+1,j,:)) + call reintegrate_column(nz_src, h_src, field(I,j,:), & + nz_dest, h_dest, reintegrated_field(I,j,:)) + enddo ; enddo + endif + elseif (staggered_in_y .and. .not. staggered_in_x) then + ! V-points + if (present(mask)) then + do J=G%jscB,G%jecB ; do i=G%isc,G%iec ; if (mask(i,J) > 0.0) then + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i,j+1,:)) + call reintegrate_column(nz_src, h_src, field(i,J,:), & + nz_dest, h_dest, reintegrated_field(i,J,:)) + endif ; enddo ; enddo + else + do J=G%jscB,G%jecB ; do i=G%isc,G%iec + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i,j+1,:)) + call reintegrate_column(nz_src, h_src, field(i,J,:), & + nz_dest, h_dest, reintegrated_field(i,J,:)) + enddo ; enddo + endif + elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then + ! H-points + if (present(mask)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (mask(i,J) > 0.0) then + call reintegrate_column(nz_src, h(i,j,:), field(i,j,:), & + nz_dest, h_target(i,j,:), reintegrated_field(i,j,:)) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call reintegrate_column(nz_src, h(i,j,:), field(i,j,:), & + nz_dest, h_target(i,j,:), reintegrated_field(i,j,:)) + enddo ; enddo + endif + else + call assert(.false., 'vertically_reintegrate_diag_field: Q point remapping is not coded yet.') + endif + +end subroutine vertically_reintegrate_field + +!> Vertically interpolate diagnostic field to alternative vertical grid. +subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, staggered_in_y, & + mask, field, interpolated_field) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], + !! depending on the value of remap_cs%Z_based_coord + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim]. Note that because this + !! is a pointer it retains its declared indexing conventions. + real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(:,:,:), intent(inout) :: interpolated_field !< Field argument remapped to alternative coordinate [A] + + ! Local variables + integer :: isdf, jsdf !< The starting i- and j-indices in memory for field + + call assert(remap_cs%initialized, 'vertically_interpolate_diag_field: remap_cs not initialized.') + call assert(size(field, 3) == size(h, 3)+1, & + 'vertically_interpolate_diag_field: Remap field and thickness z-axes do not match.') + + isdf = G%isd ; if (staggered_in_x) Isdf = G%IsdB + jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB + + if (associated(mask)) then + call vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, interpolated_field, mask(:,:,1)) + else + call vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, interpolated_field) + endif + +end subroutine vertically_interpolate_diag_field + +!> Internal routine to vertically interpolate a diagnostic field to an alternative vertical grid. +subroutine vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, interpolated_field, mask) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + integer, intent(in) :: isdf !< The starting i-index in memory for field + integer, intent(in) :: jsdf !< The starting j-index in memory for field + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], + !! depending on the value of remap_cs%Z_based_coord + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(isdf:,jsdf:,:), & + intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(isdf:,jsdf:,:), & + intent(out) :: interpolated_field !< Field argument remapped to alternative coordinate [A] + real, dimension(isdf:,jsdf:), & + optional, intent(in) :: mask !< A mask for the field [nondim] + + ! Local variables + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] or [Z ~> m] + real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] or [Z ~> m] + integer :: nz_src, nz_dest ! The number of layers on the native and remapped grids + integer :: i, j !< Grid index + + interpolated_field(:,:,:) = 0. + + nz_src = size(h,3) + nz_dest = remap_cs%nz + + if (staggered_in_x .and. .not. staggered_in_y) then + ! U-points + if (present(mask)) then + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (mask(I,j) > 0.0) then + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + call interpolate_column(nz_src, h_src, field(I,j,:), & + nz_dest, h_dest, interpolated_field(I,j,:), .true.) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + call interpolate_column(nz_src, h_src, field(I,j,:), & + nz_dest, h_dest, interpolated_field(I,j,:), .true.) + enddo ; enddo + endif + elseif (staggered_in_y .and. .not. staggered_in_x) then + ! V-points + if (present(mask)) then + do J=G%jscB,G%jecB ; do i=G%isc,G%iec ; if (mask(I,j) > 0.0) then + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + call interpolate_column(nz_src, h_src, field(i,J,:), & + nz_dest, h_dest, interpolated_field(i,J,:), .true.) + endif ; enddo ; enddo + else + do J=G%jscB,G%jecB ; do i=G%isc,G%iec + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + call interpolate_column(nz_src, h_src, field(i,J,:), & + nz_dest, h_dest, interpolated_field(i,J,:), .true.) + enddo ; enddo + endif + elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then + ! H-points + if (present(mask)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (mask(i,j) > 0.0) then + call interpolate_column(nz_src, h(i,j,:), field(i,j,:), & + nz_dest, remap_cs%h(i,j,:), interpolated_field(i,j,:), .true.) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call interpolate_column(nz_src, h(i,j,:), field(i,j,:), & + nz_dest, remap_cs%h(i,j,:), interpolated_field(i,j,:), .true.) + enddo ; enddo + endif + else + call assert(.false., 'vertically_interpolate_diag_field: Q point remapping is not coded yet.') + endif + +end subroutine vertically_interpolate_field + +!> Horizontally average a diagnostic field +subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_in_y, & + is_layer, is_extensive, & + field, averaged_field, & + averaged_mask) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean vertical grid structure + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] + logical, intent(in) :: staggered_in_x !< True if the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True if the y-axis location is at v or q points + logical, intent(in) :: is_layer !< True if the z-axis location is at h points + logical, intent(in) :: is_extensive !< True if the z-direction is spatially integrated (over layers) + real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(:), intent(out) :: averaged_field !< Field argument horizontally averaged [A] + logical, dimension(:), intent(out) :: averaged_mask !< Mask for horizontally averaged field [nondim] + + ! Local variables + integer :: isdf, jsdf !< The starting i- and j-indices in memory for field + + isdf = G%isd ; if (staggered_in_x) Isdf = G%IsdB + jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB + + call horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + is_layer, is_extensive, field, averaged_field, averaged_mask) + +end subroutine horizontally_average_diag_field + +!> Horizontally average a diagnostic field +subroutine horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + is_layer, is_extensive, field, averaged_field, averaged_mask) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean vertical grid structure + integer, intent(in) :: isdf !< The starting i-index in memory for field + integer, intent(in) :: jsdf !< The starting j-index in memory for field + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] + logical, intent(in) :: staggered_in_x !< True if the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True if the y-axis location is at v or q points + logical, intent(in) :: is_layer !< True if the z-axis location is at h points + logical, intent(in) :: is_extensive !< True if the z-direction is spatially integrated (over layers) + real, dimension(isdf:,jsdf:,:), & + intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(:), intent(out) :: averaged_field !< Field argument horizontally averaged [A] + logical, dimension(:), intent(out) :: averaged_mask !< Mask for horizontally averaged field [nondim] + + ! Local variables + real :: volume(G%isc:G%iec, G%jsc:G%jec, size(field,3)) ! The area [m2], volume [m3] or mass [kg] of each cell. + real :: stuff(G%isc:G%iec, G%jsc:G%jec, size(field,3)) ! The area, volume or mass-weighted integral of the + ! field being averaged in each cell, in [m2 A], [m3 A] or [kg A], + ! depending on the weighting for the averages and whether the + ! model makes the Boussinesq approximation. + real, dimension(size(field, 3)) :: vol_sum ! The global sum of the areas [m2], volumes [m3] or mass [kg] + ! in the cells that used in the weighted averages. + real, dimension(size(field, 3)) :: stuff_sum ! The global sum of the weighted field in all cells, in + ! [A m2], [A m3] or [A kg] + type(EFP_type), dimension(2*size(field,3)) :: sums_EFP ! Sums of volume or stuff by layer + real :: height ! An average thickness attributed to an velocity point [H ~> m or kg m-2] + integer :: i, j, k, nz + + nz = size(field, 3) + + ! TODO: These averages could potentially be modified to use the function in + ! the MOM_spatial_means module. + ! NOTE: Reproducible sums must be computed in the original MKS units + + if (staggered_in_x .and. .not. staggered_in_y) then + if (is_layer) then + ! U-points + do k=1,nz + vol_sum(k) = 0. + stuff_sum(k) = 0. + if (is_extensive) then + do j=G%jsc, G%jec ; do I=G%isc, G%iec + volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) * G%mask2dCu(I,j) + stuff(I,j,k) = volume(I,j,k) * field(I,j,k) + enddo ; enddo + else ! Intensive + do j=G%jsc, G%jec ; do I=G%isc, G%iec + height = 0.5 * (h(i,j,k) + h(i+1,j,k)) + volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) & + * (GV%H_to_MKS * height) * G%mask2dCu(I,j) + stuff(I,j,k) = volume(I,j,k) * field(I,j,k) + enddo ; enddo + endif + enddo + else ! Interface + do k=1,nz + do j=G%jsc, G%jec ; do I=G%isc, G%iec + volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) * G%mask2dCu(I,j) + stuff(I,j,k) = volume(I,j,k) * field(I,j,k) + enddo ; enddo + enddo + endif + elseif (staggered_in_y .and. .not. staggered_in_x) then + if (is_layer) then + ! V-points + do k=1,nz + if (is_extensive) then + do J=G%jsc, G%jec ; do i=G%isc, G%iec + volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) * G%mask2dCv(i,J) + stuff(i,J,k) = volume(i,J,k) * field(i,J,k) + enddo ; enddo + else ! Intensive + do J=G%jsc, G%jec ; do i=G%isc, G%iec + height = 0.5 * (h(i,j,k) + h(i,j+1,k)) + volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) & + * (GV%H_to_MKS * height) * G%mask2dCv(i,J) + stuff(i,J,k) = volume(i,J,k) * field(i,J,k) + enddo ; enddo + endif + enddo + else ! Interface + do k=1,nz + do J=G%jsc, G%jec ; do i=G%isc, G%iec + volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) * G%mask2dCv(i,J) + stuff(i,J,k) = volume(i,J,k) * field(i,J,k) + enddo ; enddo + enddo + endif + elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then + if (is_layer) then + ! H-points + do k=1,nz + if (is_extensive) then + do j=G%jsc, G%jec ; do i=G%isc, G%iec + if (h(i,j,k) > 0.) then + volume(i,j,k) = (G%US%L_to_m**2 * G%areaT(i,j)) * G%mask2dT(i,j) + stuff(i,j,k) = volume(i,j,k) * field(i,j,k) + else + volume(i,j,k) = 0. + stuff(i,j,k) = 0. + endif + enddo ; enddo + else ! Intensive + do j=G%jsc, G%jec ; do i=G%isc, G%iec + volume(i,j,k) = (G%US%L_to_m**2 * G%areaT(i,j)) & + * (GV%H_to_MKS * h(i,j,k)) * G%mask2dT(i,j) + stuff(i,j,k) = volume(i,j,k) * field(i,j,k) + enddo ; enddo + endif + enddo + else ! Interface + do k=1,nz + do j=G%jsc, G%jec ; do i=G%isc, G%iec + volume(i,j,k) = (G%US%L_to_m**2 * G%areaT(i,j)) * G%mask2dT(i,j) + stuff(i,j,k) = volume(i,j,k) * field(i,j,k) + enddo ; enddo + enddo + endif + else + call assert(.false., 'horizontally_average_diag_field: Q point averaging is not coded yet.') + endif + + ! Packing the sums into a single array with a single call to sum across PEs saves reduces + ! the costs of communication. + do k=1,nz + sums_EFP(2*k-1) = reproducing_sum_EFP(volume(:,:,k), only_on_PE=.true.) + sums_EFP(2*k) = reproducing_sum_EFP(stuff(:,:,k), only_on_PE=.true.) + enddo + call EFP_sum_across_PEs(sums_EFP, 2*nz) + do k=1,nz + vol_sum(k) = EFP_to_real(sums_EFP(2*k-1)) + stuff_sum(k) = EFP_to_real(sums_EFP(2*k)) + enddo + + averaged_mask(:) = .true. + do k=1,nz + if (vol_sum(k) > 0.) then + averaged_field(k) = stuff_sum(k) / vol_sum(k) + else + averaged_field(k) = 0. + averaged_mask(k) = .false. + endif + enddo + +end subroutine horizontally_average_field + +end module MOM_diag_remap diff --git a/framework/MOM_document.F90 b/framework/MOM_document.F90 new file mode 100644 index 0000000000..f32573815f --- /dev/null +++ b/framework/MOM_document.F90 @@ -0,0 +1,1091 @@ +!> The subroutines here provide hooks for document generation functions at +!! various levels of granularity. +module MOM_document + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_time_manager, only : time_type, operator(==), get_time, get_ticks_per_second +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe + +implicit none ; private + +public doc_param, doc_subroutine, doc_function, doc_module, doc_init, doc_end +public doc_openBlock, doc_closeBlock + +!> Document parameter values +interface doc_param + module procedure doc_param_none, & + doc_param_logical, doc_param_logical_array, & + doc_param_int, doc_param_int_array, & + doc_param_real, doc_param_real_array, & + doc_param_char, & + doc_param_time +end interface + +integer, parameter :: mLen = 1240 !< Length of interface/message strings + +!> A structure that controls where the documentation occurs, its veborsity and formatting. +type, public :: doc_type ; private + integer :: unitAll = -1 !< The open unit number for docFileBase + .all. + integer :: unitShort = -1 !< The open unit number for docFileBase + .short. + integer :: unitLayout = -1 !< The open unit number for docFileBase + .layout. + integer :: unitDebugging = -1 !< The open unit number for docFileBase + .debugging. + logical :: filesAreOpen = .false. !< True if any files were successfully opened. + character(len=mLen) :: docFileBase = '' !< The basename of the files where run-time + !! parameters, settings and defaults are documented. + logical :: complete = .true. !< If true, document all parameters. + logical :: minimal = .true. !< If true, document non-default parameters. + logical :: layout = .true. !< If true, document layout parameters. + logical :: debugging = .true. !< If true, document debugging parameters. + logical :: defineSyntax = .false. !< If true, use '\#def' syntax instead of a=b syntax + logical :: warnOnConflicts = .false. !< Cause a WARNING error if defaults differ. + integer :: commentColumn = 32 !< Number of spaces before the comment marker. + integer :: max_line_len = 112 !< The maximum length of message lines. + type(link_msg), pointer :: chain_msg => NULL() !< Database of messages + character(len=240) :: blockPrefix = '' !< The full name of the current block. +end type doc_type + +!> A linked list of the parameter documentation messages that have been issued so far. +type :: link_msg ; private + type(link_msg), pointer :: next => NULL() !< Facilitates linked list + character(len=80) :: name !< Parameter name + character(len=620) :: msg !< Parameter value and default +end type link_msg + +character(len=4), parameter :: STRING_TRUE = 'True' !< A string for true logicals +character(len=5), parameter :: STRING_FALSE = 'False' !< A string for false logicals + +contains + +! ---------------------------------------------------------------------- + +!> This subroutine handles parameter documentation with no value. +subroutine doc_param_none(doc, varname, desc, units) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented +! This subroutine handles parameter documentation with no value. + integer :: numspc + character(len=mLen) :: mesg + + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + + if (doc%filesAreOpen) then + numspc = max(1,doc%commentColumn-8-len_trim(varname)) + mesg = "#define "//trim(varname)//repeat(" ",numspc)//"!" + if (len_trim(units) > 0) mesg = trim(mesg)//" ["//trim(units)//"]" + + if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates + call writeMessageAndDesc(doc, mesg, desc) + endif +end subroutine doc_param_none + +!> This subroutine handles parameter documentation for logicals. +subroutine doc_param_logical(doc, varname, desc, units, val, default, & + layoutParam, debuggingParam, like_default) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + logical, intent(in) :: val !< The value of this parameter + logical, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. +! This subroutine handles parameter documentation for logicals. + character(len=mLen) :: mesg + logical :: equalsDefault + + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + + if (doc%filesAreOpen) then + if (val) then + mesg = define_string(doc, varname, STRING_TRUE, units) + else + mesg = undef_string(doc, varname, units) + endif + + equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default + if (present(default)) then + if (val .eqv. default) equalsDefault = .true. + if (default) then + mesg = trim(mesg)//" default = "//STRING_TRUE + else + mesg = trim(mesg)//" default = "//STRING_FALSE + endif + endif + + if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + layoutParam=layoutParam, debuggingParam=debuggingParam) + endif +end subroutine doc_param_logical + +!> This subroutine handles parameter documentation for arrays of logicals. +subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & + layoutParam, debuggingParam, like_default) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + logical, intent(in) :: vals(:) !< The array of values to record + logical, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. +! This subroutine handles parameter documentation for arrays of logicals. + integer :: i + character(len=mLen) :: mesg + character(len=mLen) :: valstring + logical :: equalsDefault + + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + + if (doc%filesAreOpen) then + if (vals(1)) then ; valstring = STRING_TRUE ; else ; valstring = STRING_FALSE ; endif + do i=2,min(size(vals),128) + if (vals(i)) then + valstring = trim(valstring)//", "//STRING_TRUE + else + valstring = trim(valstring)//", "//STRING_FALSE + endif + enddo + + mesg = define_string(doc, varname, valstring, units) + + equalsDefault = .false. + if (present(default)) then + equalsDefault = .true. + do i=1,size(vals) ; if (vals(i) .neqv. default) equalsDefault = .false. ; enddo + if (default) then + mesg = trim(mesg)//" default = "//STRING_TRUE + else + mesg = trim(mesg)//" default = "//STRING_FALSE + endif + endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif + + if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + layoutParam=layoutParam, debuggingParam=debuggingParam) + endif +end subroutine doc_param_logical_array + +!> This subroutine handles parameter documentation for integers. +subroutine doc_param_int(doc, varname, desc, units, val, default, & + layoutParam, debuggingParam, like_default) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + integer, intent(in) :: val !< The value of this parameter + integer, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. +! This subroutine handles parameter documentation for integers. + character(len=mLen) :: mesg + character(len=doc%commentColumn) :: valstring + logical :: equalsDefault + + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + + if (doc%filesAreOpen) then + valstring = int_string(val) + mesg = define_string(doc, varname, valstring, units) + + equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default + if (present(default)) then + if (val == default) equalsDefault = .true. + mesg = trim(mesg)//" default = "//(trim(int_string(default))) + endif + + if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + layoutParam=layoutParam, debuggingParam=debuggingParam) + endif +end subroutine doc_param_int + +!> This subroutine handles parameter documentation for arrays of integers. +subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & + layoutParam, debuggingParam, like_default) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + integer, intent(in) :: vals(:) !< The array of values to record + integer, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. +! This subroutine handles parameter documentation for arrays of integers. + integer :: i + character(len=mLen) :: mesg + character(len=mLen) :: valstring + logical :: equalsDefault + + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + + if (doc%filesAreOpen) then + valstring = int_string(vals(1)) + do i=2,min(size(vals),128) + valstring = trim(valstring)//", "//trim(int_string(vals(i))) + enddo + + mesg = define_string(doc, varname, valstring, units) + + equalsDefault = .false. + if (present(default)) then + equalsDefault = .true. + do i=1,size(vals) ; if (vals(i) /= default) equalsDefault = .false. ; enddo + mesg = trim(mesg)//" default = "//(trim(int_string(default))) + endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif + + if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + layoutParam=layoutParam, debuggingParam=debuggingParam) + endif + +end subroutine doc_param_int_array + +!> This subroutine handles parameter documentation for reals. +subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingParam, like_default) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + real, intent(in) :: val !< The value of this parameter + real, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. +! This subroutine handles parameter documentation for reals. + character(len=mLen) :: mesg + character(len=doc%commentColumn) :: valstring + logical :: equalsDefault + + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + + if (doc%filesAreOpen) then + valstring = real_string(val) + mesg = define_string(doc, varname, valstring, units) + + equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default + if (present(default)) then + if (val == default) equalsDefault = .true. + mesg = trim(mesg)//" default = "//trim(real_string(default)) + endif + + if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, debuggingParam=debuggingParam) + endif +end subroutine doc_param_real + +!> This subroutine handles parameter documentation for arrays of reals. +subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debuggingParam, like_default) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + real, intent(in) :: vals(:) !< The array of values to record + real, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. +! This subroutine handles parameter documentation for arrays of reals. + integer :: i + character(len=mLen) :: mesg + character(len=mLen) :: valstring + logical :: equalsDefault + + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + + if (doc%filesAreOpen) then + valstring = trim(real_array_string(vals(:))) + + mesg = define_string(doc, varname, valstring, units) + + equalsDefault = .false. + if (present(default)) then + equalsDefault = .true. + do i=1,size(vals) ; if (vals(i) /= default) equalsDefault = .false. ; enddo + mesg = trim(mesg)//" default = "//trim(real_string(default)) + endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif + + if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, debuggingParam=debuggingParam) + endif + +end subroutine doc_param_real_array + +!> This subroutine handles parameter documentation for character strings. +subroutine doc_param_char(doc, varname, desc, units, val, default, & + layoutParam, debuggingParam, like_default) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + character(len=*), intent(in) :: val !< The value of the parameter + character(len=*), & + optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. +! This subroutine handles parameter documentation for character strings. + character(len=mLen) :: mesg + logical :: equalsDefault + + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + + if (doc%filesAreOpen) then + mesg = define_string(doc, varname, '"'//trim(val)//'"', units) + + equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default + if (present(default)) then + if (trim(val) == trim(default)) equalsDefault = .true. + mesg = trim(mesg)//' default = "'//trim(adjustl(default))//'"' + endif + + if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + layoutParam=layoutParam, debuggingParam=debuggingParam) + endif + +end subroutine doc_param_char + +!> This subroutine handles documentation for opening a parameter block. +subroutine doc_openBlock(doc, blockName, desc) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: blockName !< The name of the parameter block being opened + character(len=*), optional, intent(in) :: desc !< A description of the parameter block being opened +! This subroutine handles documentation for opening a parameter block. + character(len=mLen) :: mesg + + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + + if (doc%filesAreOpen) then + mesg = trim(blockName)//'%' + + if (present(desc)) then + call writeMessageAndDesc(doc, mesg, desc) + else + call writeMessageAndDesc(doc, mesg, '') + endif + endif + doc%blockPrefix = trim(doc%blockPrefix)//trim(blockName)//'%' +end subroutine doc_openBlock + +!> This subroutine handles documentation for closing a parameter block. +subroutine doc_closeBlock(doc, blockName) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: blockName !< The name of the parameter block being closed +! This subroutine handles documentation for closing a parameter block. + character(len=mLen) :: mesg + integer :: i + + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + + if (doc%filesAreOpen) then + mesg = '%'//trim(blockName) + + call writeMessageAndDesc(doc, mesg, '') + endif + i = index(trim(doc%blockPrefix), trim(blockName)//'%', .true.) + if (i>1) then + doc%blockPrefix = trim(doc%blockPrefix(1:i-1)) + else + doc%blockPrefix = '' + endif +end subroutine doc_closeBlock + +!> This subroutine handles parameter documentation for time-type variables. +subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingParam, like_default) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + type(time_type), intent(in) :: val !< The value of the parameter + type(time_type), optional, intent(in) :: default !< The default value of this parameter + character(len=*), optional, intent(in) :: units !< The units of the parameter being documented + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. + + ! Local varables + character(len=mLen) :: mesg ! The output message + character(len=doc%commentColumn) :: valstring ! A string with the formatted value. + logical :: equalsDefault ! True if val = default. + + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + + if (doc%filesAreOpen) then + valstring = time_string(val) + if (present(units)) then + mesg = define_string(doc, varname, valstring, units) + else + mesg = define_string(doc, varname, valstring, "[days : seconds]") + endif + + equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default + if (present(default)) then + if (val == default) equalsDefault = .true. + mesg = trim(mesg)//" default = "//trim(time_string(default)) + endif + + if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, debuggingParam=debuggingParam) + endif + +end subroutine doc_param_time + +!> This subroutine writes out the message and description to the documetation files. +subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & + layoutParam, debuggingParam) + type(doc_type), intent(in) :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: vmesg !< A message with the parameter name, units, and default value. + character(len=*), intent(in) :: desc !< A description of the parameter being documented + logical, optional, intent(in) :: valueWasDefault !< If true, this parameter has its default value + integer, optional, intent(in) :: indent !< An amount by which to indent this message + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + + ! Local variables + character(len=mLen) :: mesg ! A full line of a message including indents. + character(len=mLen) :: mesg_text ! A line of message text without preliminary indents. + integer :: start_ind = 1 ! The starting index in the description for the next line. + integer :: nl_ind, tab_ind, end_ind ! The indices of new-lines, tabs, and the end of a line. + integer :: len_text, len_tab, len_nl ! The lengths of the text string, tabs and new-lines. + integer :: len_cor ! The permitted length corrected for tab sizes in a line. + integer :: len_desc ! The non-whitespace length of the description. + integer :: substr_start ! The starting index of a substring to search for tabs. + integer :: indnt, msg_pad ! Space counts used to format a message. + logical :: msg_done, reset_msg_pad ! Logicals used to format messages. + logical :: all, short, layout, debug ! Flags indicating which files to write into. + + layout = .false. ; if (present(layoutParam)) layout = layoutParam + debug = .false. ; if (present(debuggingParam)) debug = debuggingParam + all = doc%complete .and. (doc%unitAll > 0) .and. .not. (layout .or. debug) + short = doc%minimal .and. (doc%unitShort > 0) .and. .not. (layout .or. debug) + if (present(valueWasDefault)) short = short .and. (.not. valueWasDefault) + + if (all) write(doc%unitAll, '(a)') trim(vmesg) + if (short) write(doc%unitShort, '(a)') trim(vmesg) + if (layout) write(doc%unitLayout, '(a)') trim(vmesg) + if (debug) write(doc%unitDebugging, '(a)') trim(vmesg) + + if (len_trim(desc) == 0) return + + len_tab = len_trim("_\t_") - 2 + len_nl = len_trim("_\n_") - 2 + + indnt = doc%commentColumn ; if (present(indent)) indnt = indent + len_text = doc%max_line_len - (indnt + 2) + start_ind = 1 ; msg_pad = 0 ; msg_done = .false. + do + if (len_trim(desc(start_ind:)) < 1) exit + + len_cor = len_text - msg_pad + + substr_start = start_ind + len_desc = len_trim(desc) + do ! Adjust the available line length for anomalies in the size of tabs, counting \t as 2 spaces. + if (substr_start >= start_ind+len_cor) exit + tab_ind = index(desc(substr_start:min(len_desc,start_ind+len_cor)), "\t") + if (tab_ind == 0) exit + substr_start = substr_start + tab_ind + len_cor = len_cor + (len_tab - 2) + enddo + + nl_ind = index(desc(start_ind:), "\n") + end_ind = 0 + if ((nl_ind > 0) .and. (len_trim(desc(start_ind:start_ind+nl_ind-2)) > len_cor)) then + ! This line is too long despite the new-line character. Look for an earlier space to break. + end_ind = scan(desc(start_ind:start_ind+len_cor), " ", back=.true.) - 1 + if (end_ind > 0) nl_ind = 0 + elseif ((nl_ind == 0) .and. (len_trim(desc(start_ind:)) > len_cor)) then + ! This line is too long and does not have a new-line character. Look for a space to break. + end_ind = scan(desc(start_ind:start_ind+len_cor), " ", back=.true.) - 1 + endif + + reset_msg_pad = .false. + if (nl_ind > 0) then + mesg_text = trim(desc(start_ind:start_ind+nl_ind-2)) + start_ind = start_ind + nl_ind + len_nl - 1 + reset_msg_pad = .true. + elseif (end_ind > 0) then + mesg_text = trim(desc(start_ind:start_ind+end_ind)) + start_ind = start_ind + end_ind + 1 + ! Adjust the starting point to move past leading spaces. + start_ind = start_ind + (len_trim(desc(start_ind:)) - len_trim(adjustl(desc(start_ind:)))) + else + mesg_text = trim(desc(start_ind:)) + msg_done = .true. + endif + + do ; tab_ind = index(mesg_text, "\t") ! Replace \t with 2 spaces. + if (tab_ind == 0) exit + mesg_text(tab_ind:) = " "//trim(mesg_text(tab_ind+len_tab:)) + enddo + + mesg = repeat(" ",indnt)//"! "//repeat(" ",msg_pad)//trim(mesg_text) + + if (reset_msg_pad) then + msg_pad = 0 + elseif (msg_pad == 0) then ! Indent continuation lines. + msg_pad = len_trim(mesg_text) - len_trim(adjustl(mesg_text)) + ! If already indented, indent an additional 2 spaces. + if (msg_pad >= 2) msg_pad = msg_pad + 2 + endif + + if (all) write(doc%unitAll, '(a)') trim(mesg) + if (short) write(doc%unitShort, '(a)') trim(mesg) + if (layout) write(doc%unitLayout, '(a)') trim(mesg) + if (debug) write(doc%unitDebugging, '(a)') trim(mesg) + + if (msg_done) exit + enddo + +end subroutine writeMessageAndDesc + +! ---------------------------------------------------------------------- + +!> This function returns a string with a time type formatted as seconds (perhaps including a +!! fractional number of seconds) and days +function time_string(time) + type(time_type), intent(in) :: time !< The time type being translated + character(len=40) :: time_string + + ! Local variables + integer :: secs, days, ticks, ticks_per_sec + + call get_time(Time, secs, days, ticks) + + time_string = trim(adjustl(int_string(days))) // ":" // trim(adjustl(int_string(secs))) + if (ticks /= 0) then + ticks_per_sec = get_ticks_per_second() + time_string = trim(time_string) // ":" // & + trim(adjustl(int_string(ticks)))//"/"//trim(adjustl(int_string(ticks_per_sec))) + endif + +end function time_string + +!> This function returns a string with a real formatted like '(G)' +function real_string(val) + real, intent(in) :: val !< The value being written into a string + character(len=32) :: real_string +! This function returns a string with a real formatted like '(G)' + integer :: len, ind + + if ((abs(val) < 1.0e4) .and. (abs(val) >= 1.0e-3)) then + write(real_string, '(F30.11)') val + if (.not.testFormattedFloatIsReal(real_string,val)) then + write(real_string, '(F30.12)') val + if (.not.testFormattedFloatIsReal(real_string,val)) then + write(real_string, '(F30.13)') val + if (.not.testFormattedFloatIsReal(real_string,val)) then + write(real_string, '(F30.14)') val + if (.not.testFormattedFloatIsReal(real_string,val)) then + write(real_string, '(F30.15)') val + if (.not.testFormattedFloatIsReal(real_string,val)) then + write(real_string, '(F30.16)') val + endif + endif + endif + endif + endif + do + len = len_trim(real_string) + if ((len<2) .or. (real_string(len-1:len) == ".0") .or. & + (real_string(len:len) /= "0")) exit + real_string(len:len) = " " + enddo + elseif (val == 0.) then + real_string = "0.0" + else + if ((abs(val) < 1.0e-99) .or. (abs(val) >= 1.0e100)) then + write(real_string(1:32), '(ES24.14E4)') val + if (scan(real_string, "eE") == 0) then ! Fix a bug with a missing E in PGI formatting + ind = scan(real_string, "-+", back=.true.) + if (ind > index(real_string, ".") ) & ! Avoid changing a leading sign. + real_string = real_string(1:ind-1)//"E"//real_string(ind:) + endif + if (.not.testFormattedFloatIsReal(real_string, val)) then + write(real_string(1:32), '(ES25.15E4)') val + if (scan(real_string, "eE") == 0) then ! Fix a bug with a missing E in PGI formatting + ind = scan(real_string, "-+", back=.true.) + if (ind > index(real_string, ".") ) & ! Avoid changing a leading sign. + real_string = real_string(1:ind-1)//"E"//real_string(ind:) + endif + endif + ! Remove a leading 0 from the exponent, if it is there. + ind = max(index(real_string, "E+0"), index(real_string, "E-0")) + if (ind > 0) real_string = real_string(1:ind+1)//real_string(ind+3:) + else + write(real_string(1:32), '(ES23.14)') val + if (.not.testFormattedFloatIsReal(real_string, val)) & + write(real_string(1:32), '(ES23.15)') val + endif + do ! Remove extra trailing 0s before the exponent. + ind = index(real_string, "0E") + if (ind == 0) exit + if (real_string(ind-1:ind-1) == ".") exit ! Leave at least one digit after the decimal point. + real_string = real_string(1:ind-1)//real_string(ind+1:) + enddo + endif + real_string = adjustl(real_string) +end function real_string + +!> Returns a character string of a comma-separated, compact formatted, reals +!> e.g. "1., 2., 5*3., 5.E2", that give the list of values. +function real_array_string(vals, sep) + character(len=:) ,allocatable :: real_array_string !< The output string listing vals + real, intent(in) :: vals(:) !< The array of values to record + character(len=*), & + optional, intent(in) :: sep !< The separator between successive values, + !! by default it is ', '. +! Returns a character string of a comma-separated, compact formatted, reals +! e.g. "1., 2., 5*3., 5.E2" + ! Local variables + integer :: j, n, ns + logical :: doWrite + character(len=10) :: separator + n = 1 ; doWrite = .true. ; real_array_string = '' + if (present(sep)) then + separator = sep ; ns = len(sep) + else + separator = ', ' ; ns = 2 + endif + do j=1,size(vals) + doWrite = .true. + if (j < size(vals)) then + if (vals(j) == vals(j+1)) then + n = n+1 + doWrite = .false. + endif + endif + if (doWrite) then + if (len(real_array_string) > 0) then ! Write separator if a number has already been written + real_array_string = real_array_string // separator(1:ns) + endif + if (n>1) then + real_array_string = real_array_string // trim(int_string(n)) // "*" // trim(real_string(vals(j))) + else + real_array_string = real_array_string // trim(real_string(vals(j))) + endif + n=1 + endif + enddo +end function real_array_string + +!> This function tests whether a real value is encoded in a string. +function testFormattedFloatIsReal(str, val) + character(len=*), intent(in) :: str !< The string that match val + real, intent(in) :: val !< The value being tested + logical :: testFormattedFloatIsReal + ! Local variables + real :: scannedVal + + read(str(1:),*) scannedVal + if (scannedVal == val) then + testFormattedFloatIsReal=.true. + else + testFormattedFloatIsReal=.false. + endif +end function testFormattedFloatIsReal + +!> This function returns a string with an integer formatted like '(I)' +function int_string(val) + integer, intent(in) :: val !< The value being written into a string + character(len=24) :: int_string +! This function returns a string with an integer formatted like '(I)' + write(int_string, '(i24)') val + int_string = adjustl(int_string) +end function int_string + +!> This function returns a string with an logical formatted like '(L)' +function logical_string(val) + logical, intent(in) :: val !< The value being written into a string + character(len=24) :: logical_string +! This function returns a string with an logical formatted like '(L)' + write(logical_string, '(l24)') val + logical_string = adjustl(logical_string) +end function logical_string + +!> This function returns a string for formatted parameter assignment +function define_string(doc, varName, valString, units) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varName !< The name of the parameter being documented + character(len=*), intent(in) :: valString !< A string containing the value of the parameter + character(len=*), intent(in) :: units !< The units of the parameter being documented + character(len=mLen) :: define_string +! This function returns a string for formatted parameter assignment + integer :: numSpaces + define_string = repeat(" ",mLen) ! Blank everything for safety + if (doc%defineSyntax) then + define_string = "#define "//trim(varName)//" "//valString + else + define_string = trim(varName)//" = "//valString + endif + numSpaces = max(1, doc%commentColumn - len_trim(define_string) ) + define_string = trim(define_string)//repeat(" ",numSpaces)//"!" + if (len_trim(units) > 0) define_string = trim(define_string)//" ["//trim(units)//"]" +end function define_string + +!> This function returns a string for formatted false logicals +function undef_string(doc, varName, units) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varName !< The name of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + character(len=mLen) :: undef_string +! This function returns a string for formatted false logicals + integer :: numSpaces + undef_string = repeat(" ",240) ! Blank everything for safety + undef_string = "#undef "//trim(varName) + if (doc%defineSyntax) then + undef_string = "#undef "//trim(varName) + else + undef_string = trim(varName)//" = "//STRING_FALSE + endif + numSpaces = max(1, doc%commentColumn - len_trim(undef_string) ) + undef_string = trim(undef_string)//repeat(" ",numSpaces)//"!" + if (len_trim(units) > 0) undef_string = trim(undef_string)//" ["//trim(units)//"]" +end function undef_string + +! ---------------------------------------------------------------------- + +!> This subroutine handles the module documentation +subroutine doc_module(doc, modname, desc, log_to_all, all_default, layoutMod, debuggingMod) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: modname !< The name of the module being documented + character(len=*), intent(in) :: desc !< A description of the module being documented + logical, optional, intent(in) :: log_to_all !< If present and true, log this parameter to the + !! ..._doc.all files, even if this module also has layout + !! or debugging parameters. + logical, optional, intent(in) :: all_default !< If true, all parameters take their default values. + logical, optional, intent(in) :: layoutMod !< If present and true, this module has layout parameters. + logical, optional, intent(in) :: debuggingMod !< If present and true, this module has debugging parameters. + + ! This subroutine handles the module documentation + character(len=mLen) :: mesg + logical :: repeat_doc + + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + + if (doc%filesAreOpen) then + ! Add a blank line for delineation + call writeMessageAndDesc(doc, '', '', valueWasDefault=all_default, & + layoutParam=layoutMod, debuggingParam=debuggingMod) + mesg = "! === module "//trim(modname)//" ===" + call writeMessageAndDesc(doc, mesg, desc, valueWasDefault=all_default, indent=0, & + layoutParam=layoutMod, debuggingParam=debuggingMod) + if (present(log_to_all)) then ; if (log_to_all) then + ! Log the module version again if the previous call was intercepted for use to document + ! a layout or debugging module. + repeat_doc = .false. + if (present(layoutMod)) then ; if (layoutMod) repeat_doc = .true. ; endif + if (present(debuggingMod)) then ; if (debuggingMod) repeat_doc = .true. ; endif + if (repeat_doc) then + call writeMessageAndDesc(doc, '', '', valueWasDefault=all_default) + call writeMessageAndDesc(doc, mesg, desc, valueWasDefault=all_default, indent=0) + endif + endif ; endif + endif +end subroutine doc_module + +!> This subroutine handles the subroutine documentation +subroutine doc_subroutine(doc, modname, subname, desc) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: modname !< The name of the module being documented + character(len=*), intent(in) :: subname !< The name of the subroutine being documented + character(len=*), intent(in) :: desc !< A description of the subroutine being documented +! This subroutine handles the subroutine documentation + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + +end subroutine doc_subroutine + +!> This subroutine handles the function documentation +subroutine doc_function(doc, modname, fnname, desc) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: modname !< The name of the module being documented + character(len=*), intent(in) :: fnname !< The name of the function being documented + character(len=*), intent(in) :: desc !< A description of the function being documented +! This subroutine handles the function documentation + if (.not. (is_root_pe() .and. associated(doc))) return + call open_doc_file(doc) + +end subroutine doc_function + +! ---------------------------------------------------------------------- + +!> Initialize the parameter documentation +subroutine doc_init(docFileBase, doc, minimal, complete, layout, debugging) + character(len=*), intent(in) :: docFileBase !< The base file name for this set of parameters, + !! for example MOM_parameter_doc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + logical, optional, intent(in) :: minimal !< If present and true, write out the files (.short) documenting + !! those parameters that do not take on their default values. + logical, optional, intent(in) :: complete !< If present and true, write out the (.all) files documenting all + !! parameters + logical, optional, intent(in) :: layout !< If present and true, write out the (.layout) files documenting + !! the layout parameters + logical, optional, intent(in) :: debugging !< If present and true, write out the (.debugging) files documenting + !! the debugging parameters + + if (.not. associated(doc)) then + allocate(doc) + endif + + doc%docFileBase = docFileBase + if (present(minimal)) doc%minimal = minimal + if (present(complete)) doc%complete = complete + if (present(layout)) doc%layout = layout + if (present(debugging)) doc%debugging = debugging + +end subroutine doc_init + +!> This subroutine allocates and populates a structure that controls where the +!! documentation occurs and its formatting, and opens up the files controlled +!! by this structure +subroutine open_doc_file(doc) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + + logical :: opened, new_file + integer :: ios + character(len=240) :: fileName + + if (.not. (is_root_pe() .and. associated(doc))) return + + if ((len_trim(doc%docFileBase) > 0) .and. doc%complete .and. (doc%unitAll<0)) then + new_file = .true. ; if (doc%unitAll /= -1) new_file = .false. + doc%unitAll = find_unused_unit_number() + + write(fileName(1:240),'(a)') trim(doc%docFileBase)//'.all' + if (new_file) then + open(doc%unitAll, file=trim(fileName), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='REPLACE', iostat=ios) + write(doc%unitAll, '(a)') & + '! This file was written by the model and records all non-layout '//& + 'or debugging parameters used at run-time.' + else ! This file is being reopened, and should be appended. + open(doc%unitAll, file=trim(fileName), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='OLD', position='APPEND', iostat=ios) + endif + inquire(doc%unitAll, opened=opened) + if ((.not.opened) .or. (ios /= 0)) then + call MOM_error(FATAL, "Failed to open doc file "//trim(fileName)//".") + endif + doc%filesAreOpen = .true. + endif + + if ((len_trim(doc%docFileBase) > 0) .and. doc%minimal .and. (doc%unitShort<0)) then + new_file = .true. ; if (doc%unitShort /= -1) new_file = .false. + doc%unitShort = find_unused_unit_number() + + write(fileName(1:240),'(a)') trim(doc%docFileBase)//'.short' + if (new_file) then + open(doc%unitShort, file=trim(fileName), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='REPLACE', iostat=ios) + write(doc%unitShort, '(a)') & + '! This file was written by the model and records the non-default parameters used at run-time.' + else ! This file is being reopened, and should be appended. + open(doc%unitShort, file=trim(fileName), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='OLD', position='APPEND', iostat=ios) + endif + inquire(doc%unitShort, opened=opened) + if ((.not.opened) .or. (ios /= 0)) then + call MOM_error(FATAL, "Failed to open doc file "//trim(fileName)//".") + endif + doc%filesAreOpen = .true. + endif + + if ((len_trim(doc%docFileBase) > 0) .and. doc%layout .and. (doc%unitLayout<0)) then + new_file = .true. ; if (doc%unitLayout /= -1) new_file = .false. + doc%unitLayout = find_unused_unit_number() + + write(fileName(1:240),'(a)') trim(doc%docFileBase)//'.layout' + if (new_file) then + open(doc%unitLayout, file=trim(fileName), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='REPLACE', iostat=ios) + write(doc%unitLayout, '(a)') & + '! This file was written by the model and records the layout parameters used at run-time.' + else ! This file is being reopened, and should be appended. + open(doc%unitLayout, file=trim(fileName), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='OLD', position='APPEND', iostat=ios) + endif + inquire(doc%unitLayout, opened=opened) + if ((.not.opened) .or. (ios /= 0)) then + call MOM_error(FATAL, "Failed to open doc file "//trim(fileName)//".") + endif + doc%filesAreOpen = .true. + endif + + if ((len_trim(doc%docFileBase) > 0) .and. doc%debugging .and. (doc%unitDebugging<0)) then + new_file = .true. ; if (doc%unitDebugging /= -1) new_file = .false. + doc%unitDebugging = find_unused_unit_number() + + write(fileName(1:240),'(a)') trim(doc%docFileBase)//'.debugging' + if (new_file) then + open(doc%unitDebugging, file=trim(fileName), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='REPLACE', iostat=ios) + write(doc%unitDebugging, '(a)') & + '! This file was written by the model and records the debugging parameters used at run-time.' + else ! This file is being reopened, and should be appended. + open(doc%unitDebugging, file=trim(fileName), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='OLD', position='APPEND', iostat=ios) + endif + inquire(doc%unitDebugging, opened=opened) + if ((.not.opened) .or. (ios /= 0)) then + call MOM_error(FATAL, "Failed to open doc file "//trim(fileName)//".") + endif + doc%filesAreOpen = .true. + endif + +end subroutine open_doc_file + +!> Find an unused unit number, returning >0 if found, and triggering a FATAL error if not. +function find_unused_unit_number() +! Find an unused unit number. +! Returns >0 if found. FATAL if not. + integer :: find_unused_unit_number + logical :: opened + do find_unused_unit_number=512,42,-1 + inquire( find_unused_unit_number, opened=opened) + if (.not.opened) exit + enddo + if (opened) call MOM_error(FATAL, & + "doc_init failed to find an unused unit number.") +end function find_unused_unit_number + +!> This subroutine closes the the files controlled by doc, and sets flags in +!! doc to indicate that parameterization is no longer permitted. +subroutine doc_end(doc) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + type(link_msg), pointer :: this => NULL(), next => NULL() + + if (.not.associated(doc)) return + + if (doc%unitAll > 0) then + close(doc%unitAll) + doc%unitAll = -2 + endif + + if (doc%unitShort > 0) then + close(doc%unitShort) + doc%unitShort = -2 + endif + + if (doc%unitLayout > 0) then + close(doc%unitLayout) + doc%unitLayout = -2 + endif + + if (doc%unitDebugging > 0) then + close(doc%unitDebugging) + doc%unitDebugging = -2 + endif + + doc%filesAreOpen = .false. + + this => doc%chain_msg + do while( associated(this) ) + next => this%next + deallocate(this) + this => next + enddo +end subroutine doc_end + +! ----------------------------------------------------------------------------- + +!> Returns true if documentation has already been written +function mesgHasBeenDocumented(doc,varName,mesg) + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varName !< The name of the parameter being documented + character(len=*), intent(in) :: mesg !< A message with parameter values, defaults, and descriptions + !! to compare with the message that was written previously + logical :: mesgHasBeenDocumented +! Returns true if documentation has already been written + type(link_msg), pointer :: newLink => NULL(), this => NULL(), last => NULL() + + mesgHasBeenDocumented = .false. + +!!if (mesg(1:1) == '!') return ! Ignore commented parameters + + ! Search through list for this parameter + last => NULL() + this => doc%chain_msg + do while( associated(this) ) + if (trim(doc%blockPrefix)//trim(varName) == trim(this%name)) then + mesgHasBeenDocumented = .true. + if (trim(mesg) == trim(this%msg)) return + ! If we fail the above test then cause an error + if (mesg(1:1) == '!') return ! Do not cause error for commented parameters + call MOM_error(WARNING, "Previous msg:"//trim(this%msg)) + call MOM_error(WARNING, "New message :"//trim(mesg)) + call MOM_error(WARNING, "Encountered inconsistent documentation line for parameter "& + //trim(varName)//"!") + endif + last => this + this => this%next + enddo + + ! Allocate a new link + allocate(newLink) + newLink%name = trim(doc%blockPrefix)//trim(varName) + newLink%msg = trim(mesg) + newLink%next => NULL() + if (.not. associated(doc%chain_msg)) then + doc%chain_msg => newLink + else + if (.not. associated(last)) call MOM_error(FATAL, & + "Unassociated LINK in mesgHasBeenDocumented: "//trim(mesg)) + last%next => newLink + endif +end function mesgHasBeenDocumented + +end module MOM_document diff --git a/framework/MOM_domains.F90 b/framework/MOM_domains.F90 new file mode 100644 index 0000000000..a0f3855d19 --- /dev/null +++ b/framework/MOM_domains.F90 @@ -0,0 +1,390 @@ +!> Describes the decomposed MOM domain and has routines for communications across PEs +module MOM_domains + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms_infra, only : MOM_infra_init, MOM_infra_end +use MOM_coms_infra, only : PE_here, root_PE, num_PEs, broadcast +use MOM_coms_infra, only : sum_across_PEs, min_across_PEs, max_across_PEs +use MOM_domain_infra, only : MOM_domain_type, domain2D, domain1D, group_pass_type +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 +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 +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 +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_io_infra, only : file_exists +use MOM_string_functions, only : slasher + +implicit none ; private + +public :: MOM_infra_init, MOM_infra_end +! Domain types and creation and destruction routines +public :: MOM_domain_type, domain2D, domain1D +public :: MOM_domains_init, create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain +public :: MOM_thread_affinity_set, set_MOM_thread_affinity +! Domain query routines +public :: get_domain_extent, get_domain_components, get_global_shape, same_domain +public :: PE_here, root_PE, num_PEs +! Blocks are not actively used in MOM6, so this routine could be deprecated. +public :: compute_block_extent +! Single call communication routines +public :: pass_var, pass_vector, fill_symmetric_edges, broadcast +! Non-blocking communication routines +public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete +! Multi-variable group communication routines and type +public :: create_group_pass, do_group_pass, group_pass_type, start_group_pass, complete_group_pass +! Global reduction routines +public :: sum_across_PEs, min_across_PEs, max_across_PEs +public :: global_field, redistribute_array, broadcast_domain +! Simple index-convention-invariant array manipulation routine +public :: rescale_comp_data +!> These encoding constants are used to indicate the staggering of scalars and vectors +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR +!> These encoding constants are used to indicate the discretization position of a variable +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 + +contains + +!> MOM_domains_init initializes a MOM_domain_type variable, based on the information +!! read in from a param_file_type, and optionally returns data describing various +!! properties of the domain type. +subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & + NIHALO, NJHALO, NIGLOBAL, NJGLOBAL, NIPROC, NJPROC, & + min_halo, domain_name, include_name, param_suffix) + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type + !! being defined here. + type(param_file_type), intent(in) :: param_file !< A structure to parse for + !! run-time parameters + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether this domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + logical, optional, intent(in) :: static_memory !< If present and true, this + !! domain type is set up for static memory and + !! error checking of various input values is + !! performed against those in the input file. + integer, optional, intent(in) :: NIHALO !< Default halo sizes, required + !! with static memory. + integer, optional, intent(in) :: NJHALO !< Default halo sizes, required + !! with static memory. + integer, optional, intent(in) :: NIGLOBAL !< Total domain sizes, required + !! with static memory. + integer, optional, intent(in) :: NJGLOBAL !< Total domain sizes, required + !! with static memory. + integer, optional, intent(in) :: NIPROC !< Processor counts, required with + !! static memory. + integer, optional, intent(in) :: NJPROC !< Processor counts, required with + !! static memory. + integer, dimension(2), optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" + !! if missing. + character(len=*), optional, intent(in) :: include_name !< A name for model's include file, + !! "MOM_memory.h" if missing. + character(len=*), optional, intent(in) :: param_suffix !< A suffix to apply to + !! layout-specific parameters. + + ! Local variables + integer, dimension(2) :: layout ! The number of logical processors in the i- and j- directions + integer, dimension(2) :: io_layout ! The layout of logical processors for input and output + !$ integer :: ocean_nthreads ! Number of openMP threads + !$ logical :: ocean_omp_hyper_thread ! If true use openMP hyper-threads + integer, dimension(2) :: n_global ! The number of i- and j- points in the global computational domain + integer, dimension(2) :: n_halo ! The number of i- and j- points in the halos + integer :: nihalo_dflt, njhalo_dflt ! The default halo sizes + integer :: PEs_used ! The number of processors used + logical, dimension(2) :: reentrant ! True if the x- and y- directions are periodic. + logical :: tripolar_N ! A flag indicating whether there is northern tripolar connectivity + logical :: is_static ! If true, static memory is being used for this domain. + logical :: is_symmetric ! True if the domain being set up will use symmetric memory. + logical :: nonblocking ! If true, nonblocking halo updates will be used. + logical :: thin_halos ! If true, If true, optional arguments may be used to specify the + ! width of the halos that are updated with each call. + logical :: mask_table_exists ! True if there is a mask table file + character(len=128) :: inputdir ! The directory in which to find the diag table + character(len=200) :: mask_table ! The file name and later the full path to the diag table + character(len=64) :: inc_nm ! The name of the memory include file + character(len=200) :: mesg ! A string to use for error messages + + integer :: nip_parsed, njp_parsed + character(len=8) :: char_xsiz, char_ysiz, char_niglobal, char_njglobal + character(len=40) :: nihalo_nm, njhalo_nm, layout_nm, io_layout_nm, masktable_nm + character(len=40) :: niproc_nm, njproc_nm + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl ! This module's name. + + PEs_used = num_PEs() + + mdl = "MOM_domains" + + is_symmetric = .true. ; if (present(symmetric)) is_symmetric = symmetric + if (present(min_halo)) mdl = trim(mdl)//" min_halo" + + inc_nm = "MOM_memory.h" ; if (present(include_name)) inc_nm = trim(include_name) + + nihalo_nm = "NIHALO" ; njhalo_nm = "NJHALO" + layout_nm = "LAYOUT" ; io_layout_nm = "IO_LAYOUT" ; masktable_nm = "MASKTABLE" + niproc_nm = "NIPROC" ; njproc_nm = "NJPROC" + if (present(param_suffix)) then ; if (len(trim(adjustl(param_suffix))) > 0) then + nihalo_nm = "NIHALO"//(trim(adjustl(param_suffix))) + njhalo_nm = "NJHALO"//(trim(adjustl(param_suffix))) + layout_nm = "LAYOUT"//(trim(adjustl(param_suffix))) + io_layout_nm = "IO_LAYOUT"//(trim(adjustl(param_suffix))) + masktable_nm = "MASKTABLE"//(trim(adjustl(param_suffix))) + niproc_nm = "NIPROC"//(trim(adjustl(param_suffix))) + njproc_nm = "NJPROC"//(trim(adjustl(param_suffix))) + endif ; endif + + is_static = .false. ; if (present(static_memory)) is_static = static_memory + if (is_static) then + if (.not.present(NIHALO)) call MOM_error(FATAL, "NIHALO must be "// & + "present in the call to MOM_domains_init with static memory.") + if (.not.present(NJHALO)) call MOM_error(FATAL, "NJHALO must be "// & + "present in the call to MOM_domains_init with static memory.") + if (.not.present(NIGLOBAL)) call MOM_error(FATAL, "NIGLOBAL must be "// & + "present in the call to MOM_domains_init with static memory.") + if (.not.present(NJGLOBAL)) call MOM_error(FATAL, "NJGLOBAL must be "// & + "present in the call to MOM_domains_init with static memory.") + if (.not.present(NIPROC)) call MOM_error(FATAL, "NIPROC must be "// & + "present in the call to MOM_domains_init with static memory.") + if (.not.present(NJPROC)) call MOM_error(FATAL, "NJPROC must be "// & + "present in the call to MOM_domains_init with static memory.") + endif + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "", log_to_all=.true., layout=.true.) + call get_param(param_file, mdl, "REENTRANT_X", reentrant(1), & + "If true, the domain is zonally reentrant.", default=.true.) + call get_param(param_file, mdl, "REENTRANT_Y", reentrant(2), & + "If true, the domain is meridionally reentrant.", & + default=.false.) + call get_param(param_file, mdl, "TRIPOLAR_N", tripolar_N, & + "Use tripolar connectivity at the northern edge of the "//& + "domain. With TRIPOLAR_N, NIGLOBAL must be even.", & + default=.false.) + +# ifndef NOT_SET_AFFINITY + !$ if (.not.MOM_thread_affinity_set()) then + !$ call get_param(param_file, mdl, "OCEAN_OMP_THREADS", ocean_nthreads, & + !$ "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.) + !$ call set_MOM_thread_affinity(ocean_nthreads, ocean_omp_hyper_thread) + !$ endif +# endif + + call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", is_symmetric, & + "If defined, the velocity point data domain includes every face of the "//& + "thickness points. In other words, some arrays are larger than others, "//& + "depending on where they are on the staggered grid. Also, the starting "//& + "index of the velocity-point arrays is usually 0, not 1. "//& + "This can only be set at compile time.",& + layoutParam=.true.) + call get_param(param_file, mdl, "NONBLOCKING_UPDATES", nonblocking, & + "If true, non-blocking halo updates may be used.", & + default=.false., layoutParam=.true.) + call get_param(param_file, mdl, "THIN_HALO_UPDATES", thin_halos, & + "If true, optional arguments may be used to specify the width of the "//& + "halos that are updated with each call.", & + default=.true., layoutParam=.true.) + + nihalo_dflt = 4 ; njhalo_dflt = 4 + if (present(NIHALO)) nihalo_dflt = NIHALO + if (present(NJHALO)) njhalo_dflt = NJHALO + + call log_param(param_file, mdl, "!STATIC_MEMORY_", is_static, & + "If STATIC_MEMORY_ is defined, the principle variables will have sizes that "//& + "are statically determined at compile time. Otherwise the sizes are not "//& + "determined until run time. The STATIC option is substantially faster, but "//& + "does not allow the PE count to be changed at run time. This can only be "//& + "set at compile time.", layoutParam=.true.) + + if (is_static) then + call get_param(param_file, mdl, "NIGLOBAL", n_global(1), & + "The total number of thickness grid points in the x-direction in the physical "//& + "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & + default=NIGLOBAL) + call get_param(param_file, mdl, "NJGLOBAL", n_global(2), & + "The total number of thickness grid points in the y-direction in the physical "//& + "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & + default=NJGLOBAL) + if (n_global(1) /= NIGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & + "static mismatch for NIGLOBAL_ domain size. Header file does not match input namelist") + if (n_global(2) /= NJGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & + "static mismatch for NJGLOBAL_ domain size. Header file does not match input namelist") + + ! Check the requirement of equal sized compute domains when STATIC_MEMORY_ is used. + if ((MOD(NIGLOBAL, NIPROC) /= 0) .OR. (MOD(NJGLOBAL, NJPROC) /= 0)) then + write( char_xsiz, '(i4)' ) NIPROC + write( char_ysiz, '(i4)' ) NJPROC + write( char_niglobal, '(i4)' ) NIGLOBAL + write( char_njglobal, '(i4)' ) NJGLOBAL + call MOM_error(WARNING, 'MOM_domains: Processor decomposition (NIPROC_,NJPROC_) = ('//& + trim(char_xsiz)//','//trim(char_ysiz)//') does not evenly divide size '//& + 'set by preprocessor macro ('//trim(char_niglobal)//','//trim(char_njglobal)//').') + call MOM_error(FATAL,'MOM_domains: #undef STATIC_MEMORY_ in '//trim(inc_nm)//' to use '//& + 'dynamic allocation, or change processor decomposition to evenly divide the domain.') + endif + else + call get_param(param_file, mdl, "NIGLOBAL", n_global(1), & + "The total number of thickness grid points in the x-direction in the physical "//& + "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "NJGLOBAL", n_global(2), & + "The total number of thickness grid points in the y-direction in the physical "//& + "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & + fail_if_missing=.true.) + endif + + call get_param(param_file, mdl, trim(nihalo_nm), n_halo(1), & + "The number of halo points on each side in the x-direction. How this is set "//& + "varies with the calling component and static or dynamic memory configuration.", & + default=nihalo_dflt) + call get_param(param_file, mdl, trim(njhalo_nm), n_halo(2), & + "The number of halo points on each side in the y-direction. How this is set "//& + "varies with the calling component and static or dynamic memory configuration.", & + default=njhalo_dflt) + if (present(min_halo)) then + n_halo(1) = max(n_halo(1), min_halo(1)) + min_halo(1) = n_halo(1) + n_halo(2) = max(n_halo(2), min_halo(2)) + min_halo(2) = n_halo(2) + ! These are generally used only with static memory, so they are considered layout params. + call log_param(param_file, mdl, "!NIHALO min_halo", n_halo(1), layoutParam=.true.) + call log_param(param_file, mdl, "!NJHALO min_halo", n_halo(2), layoutParam=.true.) + endif + if (is_static .and. .not.present(min_halo)) then + if (n_halo(1) /= NIHALO) call MOM_error(FATAL,"MOM_domains_init: " // & + "static mismatch for "//trim(nihalo_nm)//" domain size") + if (n_halo(2) /= NJHALO) call MOM_error(FATAL,"MOM_domains_init: " // & + "static mismatch for "//trim(njhalo_nm)//" domain size") + endif + + call get_param(param_file, mdl, "INPUTDIR", inputdir, do_not_log=.true., default=".") + inputdir = slasher(inputdir) + + call get_param(param_file, mdl, trim(masktable_nm), mask_table, & + "A text file to specify n_mask, layout and mask_list. This feature masks out "//& + "processors that contain only land points. The first line of mask_table is the "//& + "number of regions to be masked out. The second line is the layout of the "//& + "model and must be consistent with the actual model layout. The following "//& + "(n_mask) lines give the logical positions of the processors that are masked "//& + "out. The mask_table can be created by tools like check_mask. The following "//& + "example of mask_table masks out 2 processors, (1,2) and (3,6), out of the 24 "//& + "in a 4x6 layout: \n 2\n 4,6\n 1,2\n 3,6\n", default="MOM_mask_table", & + layoutParam=.true.) + mask_table = trim(inputdir)//trim(mask_table) + mask_table_exists = file_exists(mask_table) + + if (is_static) then + layout(1) = NIPROC ; layout(2) = NJPROC + else + call get_param(param_file, mdl, trim(layout_nm), layout, & + "The processor layout to be used, or 0, 0 to automatically set the layout "//& + "based on the number of processors.", default=0, do_not_log=.true.) + call get_param(param_file, mdl, trim(niproc_nm), nip_parsed, & + "The number of processors in the x-direction.", default=-1, do_not_log=.true.) + call get_param(param_file, mdl, trim(njproc_nm), njp_parsed, & + "The number of processors in the y-direction.", default=-1, do_not_log=.true.) + if (nip_parsed > -1) then + if ((layout(1) > 0) .and. (layout(1) /= nip_parsed)) & + call MOM_error(FATAL, trim(layout_nm)//" and "//trim(niproc_nm)//" set inconsistently. "//& + "Only LAYOUT should be used.") + layout(1) = nip_parsed + call MOM_mesg(trim(niproc_nm)//" used to set "//trim(layout_nm)//" in dynamic mode. "//& + "Shift to using "//trim(layout_nm)//" instead.") + endif + if (njp_parsed > -1) then + if ((layout(2) > 0) .and. (layout(2) /= njp_parsed)) & + call MOM_error(FATAL, trim(layout_nm)//" and "//trim(njproc_nm)//" set inconsistently. "//& + "Only "//trim(layout_nm)//" should be used.") + layout(2) = njp_parsed + call MOM_mesg(trim(njproc_nm)//" used to set "//trim(layout_nm)//" in dynamic mode. "//& + "Shift to using "//trim(layout_nm)//" instead.") + endif + + if ( (layout(1) == 0) .and. (layout(2) == 0) ) & + call MOM_define_layout(n_global, PEs_used, layout) + if ( (layout(1) /= 0) .and. (layout(2) == 0) ) layout(2) = PEs_used / layout(1) + if ( (layout(1) == 0) .and. (layout(2) /= 0) ) layout(1) = PEs_used / layout(2) + + if (layout(1)*layout(2) /= PEs_used .and. (.not. mask_table_exists) ) then + write(mesg,'("MOM_domains_init: The product of the two components of layout, ", & + & 2i4,", is not the number of PEs used, ",i5,".")') & + layout(1), layout(2), PEs_used + call MOM_error(FATAL, mesg) + endif + endif + call log_param(param_file, mdl, trim(niproc_nm), layout(1), & + "The number of processors in the x-direction. With STATIC_MEMORY_ this "//& + "is set in "//trim(inc_nm)//" at compile time.", layoutParam=.true.) + call log_param(param_file, mdl, trim(njproc_nm), layout(2), & + "The number of processors in the y-direction. With STATIC_MEMORY_ this "//& + "is set in "//trim(inc_nm)//" at compile time.", layoutParam=.true.) + call log_param(param_file, mdl, trim(layout_nm), layout, & + "The processor layout that was actually used.", layoutParam=.true.) + + ! Idiot check that fewer PEs than columns have been requested + if (layout(1)*layout(2) > n_global(1)*n_global(2)) then + write(mesg,'(a,2(i5,1x,a))') 'You requested to use', layout(1)*layout(2), & + 'PEs but there are only', n_global(1)*n_global(2), 'columns in the model' + call MOM_error(FATAL, mesg) + endif + + if (mask_table_exists) & + call MOM_error(NOTE, 'MOM_domains_init: reading maskmap information from '//trim(mask_table)) + + ! Set up the I/O layout, it will be checked later that it uses an even multiple of the number of + ! PEs in each direction. + io_layout(:) = (/ 1, 1 /) + call get_param(param_file, mdl, trim(io_layout_nm), io_layout, & + "The processor layout to be used, or 0,0 to automatically set the io_layout "//& + "to be the same as the layout.", default=1, layoutParam=.true.) + + call create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, layout, & + io_layout=io_layout, domain_name=domain_name, mask_table=mask_table, & + symmetric=symmetric, thin_halos=thin_halos, nonblocking=nonblocking) + +end subroutine MOM_domains_init + +!> Given a global array size and a number of (logical) processors, provide a layout of the +!! processors in the two directions where the total number of processors is the product of +!! the two layouts and number of points in the partitioned arrays are as close as possible +!! to an aspect ratio of 1. +subroutine MOM_define_layout(n_global, ndivs, layout) + integer, dimension(2), intent(in) :: n_global !< The total number of gridpoints in 2 directions + integer, intent(in) :: ndivs !< The total number of (logical) PEs + integer, dimension(2), intent(out) :: layout !< The generated layout of PEs + + ! Local variables + integer :: isz, jsz, idiv, jdiv + + ! At present, this algorithm is a copy of mpp_define_layout, but it could perhaps be improved? + + isz = n_global(1) ; jsz = n_global(2) + ! First try to divide ndivs to match the domain aspect ratio. If this is not an even + ! divisor of ndivs, reduce idiv until a factor is found. + idiv = max(nint( sqrt(float(ndivs*isz)/jsz) ), 1) + do while( mod(ndivs,idiv) /= 0 ) + idiv = idiv - 1 + enddo ! This will terminate at idiv=1 if not before + jdiv = ndivs / idiv + + layout = (/ idiv, jdiv /) +end subroutine MOM_define_layout + +end module MOM_domains diff --git a/framework/MOM_dyn_horgrid.F90 b/framework/MOM_dyn_horgrid.F90 new file mode 100644 index 0000000000..8c163f710f --- /dev/null +++ b/framework/MOM_dyn_horgrid.F90 @@ -0,0 +1,548 @@ +!> Contains a shareable dynamic type for describing horizontal grids and metric data +!! and utilty routines that work on this type. +module MOM_dyn_horgrid + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_array_transform, only : rotate_array, rotate_array_pair +use MOM_domains, only : MOM_domain_type, deallocate_MOM_domain +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING +use MOM_hor_index, only : hor_index_type +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +public create_dyn_horgrid, destroy_dyn_horgrid, set_derived_dyn_horgrid +public rescale_dyn_horgrid_bathymetry, rotate_dyn_horgrid + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Describes the horizontal ocean grid with only dynamic memory arrays +type, public :: dyn_horgrid_type + type(MOM_domain_type), pointer :: Domain => NULL() !< Ocean model domain + type(MOM_domain_type), pointer :: Domain_aux => NULL() !< A non-symmetric auxiliary domain type. + type(hor_index_type) :: HI !< Horizontal index ranges + + integer :: isc !< The start i-index of cell centers within the computational domain + integer :: iec !< The end i-index of cell centers within the computational domain + integer :: jsc !< The start j-index of cell centers within the computational domain + integer :: jec !< The end j-index of cell centers within the computational domain + + integer :: isd !< The start i-index of cell centers within the data domain + integer :: ied !< The end i-index of cell centers within the data domain + integer :: jsd !< The start j-index of cell centers within the data domain + integer :: jed !< The end j-index of cell centers within the data domain + + integer :: isg !< The start i-index of cell centers within the global domain + integer :: ieg !< The end i-index of cell centers within the global domain + integer :: jsg !< The start j-index of cell centers within the global domain + integer :: jeg !< The end j-index of cell centers within the global domain + + integer :: IscB !< The start i-index of cell vertices within the computational domain + integer :: IecB !< The end i-index of cell vertices within the computational domain + integer :: JscB !< The start j-index of cell vertices within the computational domain + integer :: JecB !< The end j-index of cell vertices within the computational domain + + integer :: IsdB !< The start i-index of cell vertices within the data domain + integer :: IedB !< The end i-index of cell vertices within the data domain + integer :: JsdB !< The start j-index of cell vertices within the data domain + integer :: JedB !< The end j-index of cell vertices within the data domain + + integer :: IsgB !< The start i-index of cell vertices within the global domain + integer :: IegB !< The end i-index of cell vertices within the global domain + integer :: JsgB !< The start j-index of cell vertices within the global domain + integer :: JegB !< The end j-index of cell vertices within the global domain + + integer :: isd_global !< The value of isd in the global index space (decompoistion invariant). + integer :: jsd_global !< The value of isd in the global index space (decompoistion invariant). + integer :: idg_offset !< The offset between the corresponding global and local i-indices. + integer :: jdg_offset !< The offset between the corresponding global and local j-indices. + logical :: symmetric !< True if symmetric memory is used. + + logical :: nonblocking_updates !< If true, non-blocking halo updates are + !! allowed. The default is .false. (for now). + integer :: first_direction !< An integer that indicates which direction is to be updated first in + !! directionally split parts of the calculation. This can be altered + !! during the course of the run via calls to set_first_direction. + + real, allocatable, dimension(:,:) :: & + mask2dT, & !< 0 for land points and 1 for ocean points on the h-grid [nondim]. + geoLatT, & !< The geographic latitude at q points [degrees of latitude] or [m]. + geoLonT, & !< The geographic longitude at q points [degrees of longitude] or [m]. + dxT, & !< dxT is delta x at h points [L ~> m]. + IdxT, & !< 1/dxT [L-1 ~> m-1]. + dyT, & !< dyT is delta y at h points [L ~> m]. + IdyT, & !< IdyT is 1/dyT [L-1 ~> m-1]. + areaT, & !< The area of an h-cell [L2 ~> m2]. + IareaT !< 1/areaT [L-2 ~> m-2]. + real, allocatable, dimension(:,:) :: sin_rot + !< The sine of the angular rotation between the local model grid's northward + !! and the true northward directions [nondim]. + real, allocatable, dimension(:,:) :: cos_rot + !< The cosine of the angular rotation between the local model grid's northward + !! and the true northward directions [nondim]. + + real, allocatable, dimension(:,:) :: & + mask2dCu, & !< 0 for boundary points and 1 for ocean points on the u grid [nondim]. + OBCmaskCu, & !< 0 for boundary or OBC points and 1 for ocean points on the u grid [nondim]. + geoLatCu, & !< The geographic latitude at u points [degrees of latitude] or [m]. + geoLonCu, & !< The geographic longitude at u points [degrees of longitude] or [m]. + dxCu, & !< dxCu is delta x at u points [L ~> m]. + IdxCu, & !< 1/dxCu [L-1 ~> m-1]. + dyCu, & !< dyCu is delta y at u points [L ~> m]. + IdyCu, & !< 1/dyCu [L-1 ~> m-1]. + dy_Cu, & !< The unblocked lengths of the u-faces of the h-cell [L ~> m]. + IareaCu, & !< The masked inverse areas of u-grid cells [L-2 ~> m-2]. + areaCu !< The areas of the u-grid cells [L2 ~> m2]. + + real, allocatable, dimension(:,:) :: & + mask2dCv, & !< 0 for boundary points and 1 for ocean points on the v grid [nondim]. + OBCmaskCv, & !< 0 for boundary or OBC points and 1 for ocean points on the v grid [nondim]. + geoLatCv, & !< The geographic latitude at v points [degrees of latitude] or [m]. + geoLonCv, & !< The geographic longitude at v points [degrees of longitude] or [m]. + dxCv, & !< dxCv is delta x at v points [L ~> m]. + IdxCv, & !< 1/dxCv [L-1 ~> m-1]. + dyCv, & !< dyCv is delta y at v points [L ~> m]. + IdyCv, & !< 1/dyCv [L-1 ~> m-1]. + dx_Cv, & !< The unblocked lengths of the v-faces of the h-cell [L ~> m]. + IareaCv, & !< The masked inverse areas of v-grid cells [L-2 ~> m-2]. + areaCv !< The areas of the v-grid cells [L2 ~> m2]. + + real, allocatable, dimension(:,:) :: & + porous_DminU, & !< minimum topographic height (deepest) of U-face [Z ~> m] + porous_DmaxU, & !< maximum topographic height (shallowest) of U-face [Z ~> m] + porous_DavgU !< average topographic height of U-face [Z ~> m] + + real, allocatable, dimension(:,:) :: & + porous_DminV, & !< minimum topographic height (deepest) of V-face [Z ~> m] + porous_DmaxV, & !< maximum topographic height (shallowest) of V-face [Z ~> m] + porous_DavgV !< average topographic height of V-face [Z ~> m] + + real, allocatable, dimension(:,:) :: & + mask2dBu, & !< 0 for boundary points and 1 for ocean points on the q grid [nondim]. + geoLatBu, & !< The geographic latitude at q points [degrees of latitude] or [m]. + geoLonBu, & !< The geographic longitude at q points [degrees of longitude] or [m]. + dxBu, & !< dxBu is delta x at q points [L ~> m]. + IdxBu, & !< 1/dxBu [L-1 ~> m-1]. + dyBu, & !< dyBu is delta y at q points [L ~> m]. + IdyBu, & !< 1/dyBu [L-1 ~> m-1]. + areaBu, & !< areaBu is the area of a q-cell [L ~> m] + IareaBu !< IareaBu = 1/areaBu [L-2 ~> m-2]. + + real, pointer, dimension(:) :: gridLatT => NULL() + !< The latitude of T points for the purpose of labeling the output axes. + !! On many grids this is the same as geoLatT. + real, pointer, dimension(:) :: gridLatB => NULL() + !< The latitude of B points for the purpose of labeling the output axes. + !! On many grids this is the same as geoLatBu. + real, pointer, dimension(:) :: gridLonT => NULL() + !< The longitude of T points for the purpose of labeling the output axes. + !! On many grids this is the same as geoLonT. + real, pointer, dimension(:) :: gridLonB => NULL() + !< The longitude of B points for the purpose of labeling the output axes. + !! On many grids this is the same as geoLonBu. + character(len=40) :: & + ! Except on a Cartesian grid, these are usually some variant of "degrees". + x_axis_units, & !< The units that are used in labeling the x coordinate axes. + y_axis_units, & !< The units that are used in labeling the y coordinate axes. + ! These are internally generated names, including "m", "km", "deg_E" and "deg_N". + x_ax_unit_short, & !< A short description of the x-axis units for documenting parameter units + y_ax_unit_short !< A short description of the y-axis units for documenting parameter units + + real, allocatable, dimension(:,:) :: & + bathyT !< Ocean bottom depth at tracer points, in depth units [Z ~> m]. + + logical :: bathymetry_at_vel !< If true, there are separate values for the + !! basin depths at velocity points. Otherwise the effects of + !! of topography are entirely determined from thickness points. + real, allocatable, dimension(:,:) :: & + Dblock_u, & !< Topographic depths at u-points at which the flow is blocked [Z ~> m]. + Dopen_u !< Topographic depths at u-points at which the flow is open at width dy_Cu [Z ~> m]. + real, allocatable, dimension(:,:) :: & + Dblock_v, & !< Topographic depths at v-points at which the flow is blocked [Z ~> m]. + Dopen_v !< Topographic depths at v-points at which the flow is open at width dx_Cv [Z ~> m]. + real, allocatable, dimension(:,:) :: & + CoriolisBu !< The Coriolis parameter at corner points [T-1 ~> s-1]. + real, allocatable, dimension(:,:) :: & + df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1]. + df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1]. + + ! These variables are global sums that are useful for 1-d diagnostics and should not be rescaled. + real :: areaT_global !< Global sum of h-cell area [m2] + real :: IareaT_global !< Global sum of inverse h-cell area (1/areaT_global) [m-2] + + ! These parameters are run-time parameters that are used during some + ! initialization routines (but not all) + real :: south_lat !< The latitude (or y-coordinate) of the first v-line + real :: west_lon !< The longitude (or x-coordinate) of the first u-line + real :: len_lat !< The latitudinal (or y-coord) extent of physical domain + real :: len_lon !< The longitudinal (or x-coord) extent of physical domain + real :: Rad_Earth !< The radius of the planet [m] + real :: Rad_Earth_L !< The radius of the planet in rescaled units [L ~> m] + real :: max_depth !< The maximum depth of the ocean [Z ~> m] +end type dyn_horgrid_type + +contains + +!--------------------------------------------------------------------- +!> Allocate memory used by the dyn_horgrid_type and related structures. +subroutine create_dyn_horgrid(G, HI, bathymetry_at_vel) + type(dyn_horgrid_type), pointer, intent(inout) :: G !< A pointer to the dynamic horizontal grid type + type(hor_index_type), intent(in) :: HI !< A hor_index_type for array extents + logical, optional, intent(in) :: bathymetry_at_vel !< If true, there are + !! separate values for the basin depths at velocity + !! points. Otherwise the effects of topography are + !! entirely determined from thickness points. + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isg, ieg, jsg, jeg + + ! This subroutine allocates the lateral elements of the dyn_horgrid_type that + ! are always used and zeros them out. + + if (associated(G)) then + call MOM_error(WARNING, "create_dyn_horgrid called with an associated horgrid_type.") + else + allocate(G) + endif + + G%HI = HI + + G%isc = HI%isc ; G%iec = HI%iec ; G%jsc = HI%jsc ; G%jec = HI%jec + G%isd = HI%isd ; G%ied = HI%ied ; G%jsd = HI%jsd ; G%jed = HI%jed + G%isg = HI%isg ; G%ieg = HI%ieg ; G%jsg = HI%jsg ; G%jeg = HI%jeg + + G%IscB = HI%IscB ; G%IecB = HI%IecB ; G%JscB = HI%JscB ; G%JecB = HI%JecB + G%IsdB = HI%IsdB ; G%IedB = HI%IedB ; G%JsdB = HI%JsdB ; G%JedB = HI%JedB + G%IsgB = HI%IsgB ; G%IegB = HI%IegB ; G%JsgB = HI%JsgB ; G%JegB = HI%JegB + + G%idg_offset = HI%idg_offset ; G%jdg_offset = HI%jdg_offset + G%isd_global = G%isd + HI%idg_offset ; G%jsd_global = G%jsd + HI%jdg_offset + G%symmetric = HI%symmetric + + G%bathymetry_at_vel = .false. + if (present(bathymetry_at_vel)) G%bathymetry_at_vel = bathymetry_at_vel + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + isg = G%isg ; ieg = G%ieg ; jsg = G%jsg ; jeg = G%jeg + + allocate(G%dxT(isd:ied,jsd:jed), source=0.0) + allocate(G%dxCu(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%dxCv(isd:ied,JsdB:JedB), source=0.0) + allocate(G%dxBu(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(G%IdxT(isd:ied,jsd:jed), source=0.0) + allocate(G%IdxCu(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%IdxCv(isd:ied,JsdB:JedB), source=0.0) + allocate(G%IdxBu(IsdB:IedB,JsdB:JedB), source=0.0) + + allocate(G%dyT(isd:ied,jsd:jed), source=0.0) + allocate(G%dyCu(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%dyCv(isd:ied,JsdB:JedB), source=0.0) + allocate(G%dyBu(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(G%IdyT(isd:ied,jsd:jed), source=0.0) + allocate(G%IdyCu(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%IdyCv(isd:ied,JsdB:JedB), source=0.0) + allocate(G%IdyBu(IsdB:IedB,JsdB:JedB), source=0.0) + + allocate(G%areaT(isd:ied,jsd:jed), source=0.0) + allocate(G%IareaT(isd:ied,jsd:jed), source=0.0) + allocate(G%areaBu(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(G%IareaBu(IsdB:IedB,JsdB:JedB), source=0.0) + + allocate(G%mask2dT(isd:ied,jsd:jed), source=0.0) + allocate(G%mask2dCu(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%mask2dCv(isd:ied,JsdB:JedB), source=0.0) + allocate(G%mask2dBu(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(G%OBCmaskCu(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%OBCmaskCv(isd:ied,JsdB:JedB), source=0.0) + allocate(G%geoLatT(isd:ied,jsd:jed), source=0.0) + allocate(G%geoLatCu(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%geoLatCv(isd:ied,JsdB:JedB), source=0.0) + allocate(G%geoLatBu(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(G%geoLonT(isd:ied,jsd:jed), source=0.0) + allocate(G%geoLonCu(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%geoLonCv(isd:ied,JsdB:JedB), source=0.0) + allocate(G%geoLonBu(IsdB:IedB,JsdB:JedB), source=0.0) + + allocate(G%dx_Cv(isd:ied,JsdB:JedB), source=0.0) + allocate(G%dy_Cu(IsdB:IedB,jsd:jed), source=0.0) + + allocate(G%areaCu(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%areaCv(isd:ied,JsdB:JedB), source=0.0) + allocate(G%IareaCu(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%IareaCv(isd:ied,JsdB:JedB), source=0.0) + + allocate(G%porous_DminU(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%porous_DmaxU(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%porous_DavgU(IsdB:IedB,jsd:jed), source=0.0) + + allocate(G%porous_DminV(isd:ied,JsdB:JedB), source=0.0) + allocate(G%porous_DmaxV(isd:ied,JsdB:JedB), source=0.0) + allocate(G%porous_DavgV(isd:ied,JsdB:JedB), source=0.0) + + + allocate(G%bathyT(isd:ied, jsd:jed), source=0.0) + allocate(G%CoriolisBu(IsdB:IedB, JsdB:JedB), source=0.0) + allocate(G%dF_dx(isd:ied, jsd:jed), source=0.0) + allocate(G%dF_dy(isd:ied, jsd:jed), source=0.0) + + allocate(G%sin_rot(isd:ied,jsd:jed), source=0.0) + allocate(G%cos_rot(isd:ied,jsd:jed), source=1.0) + + if (G%bathymetry_at_vel) then + allocate(G%Dblock_u(IsdB:IedB, jsd:jed), source=0.0) + allocate(G%Dopen_u(IsdB:IedB, jsd:jed), source=0.0) + allocate(G%Dblock_v(isd:ied, JsdB:JedB), source=0.0) + allocate(G%Dopen_v(isd:ied, JsdB:JedB), source=0.0) + endif + + ! gridLonB and gridLatB are used as edge values in some cases, so they + ! always need to use symmetric memory allcoations. + allocate(G%gridLonT(isg:ieg), source=0.0) + allocate(G%gridLonB(isg-1:ieg), source=0.0) + allocate(G%gridLatT(jsg:jeg), source=0.0) + allocate(G%gridLatB(jsg-1:jeg), source=0.0) + +end subroutine create_dyn_horgrid + + +!> Copy the rotated contents of one horizontal grid type into another. The input +!! and output grid type arguments can not use the same object. +subroutine rotate_dyn_horgrid(G_in, G, US, turns) + type(dyn_horgrid_type), intent(in) :: G_in !< The input horizontal grid type + type(dyn_horgrid_type), intent(inout) :: G !< An output rotated horizontal grid type + !! that has already been allocated, but whose + !! contents are largely replaced here. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: turns !< Number of quarter turns + + ! Center point + call rotate_array(G_in%geoLonT, turns, G%geoLonT) + call rotate_array(G_in%geoLatT, turns, G%geoLatT) + call rotate_array_pair(G_in%dxT, G_in%dyT, turns, G%dxT, G%dyT) + call rotate_array(G_in%areaT, turns, G%areaT) + call rotate_array(G_in%bathyT, turns, G%bathyT) + + call rotate_array_pair(G_in%df_dx, G_in%df_dy, turns, G%df_dx, G%df_dy) + call rotate_array(G_in%sin_rot, turns, G%sin_rot) + call rotate_array(G_in%cos_rot, turns, G%cos_rot) + call rotate_array(G_in%mask2dT, turns, G%mask2dT) + + ! Face points + call rotate_array_pair(G_in%geoLonCu, G_in%geoLonCv, turns, G%geoLonCu, G%geoLonCv) + call rotate_array_pair(G_in%geoLatCu, G_in%geoLatCv, turns, G%geoLatCu, G%geoLatCv) + call rotate_array_pair(G_in%dxCu, G_in%dyCv, turns, G%dxCu, G%dyCv) + call rotate_array_pair(G_in%dxCv, G_in%dyCu, turns, G%dxCv, G%dyCu) + call rotate_array_pair(G_in%dx_Cv, G_in%dy_Cu, turns, G%dx_Cv, G%dy_Cu) + + call rotate_array_pair(G_in%mask2dCu, G_in%mask2dCv, turns, G%mask2dCu, G%mask2dCv) + call rotate_array_pair(G_in%OBCmaskCu, G_in%OBCmaskCv, turns, G%OBCmaskCu, G%OBCmaskCv) + call rotate_array_pair(G_in%areaCu, G_in%areaCv, turns, G%areaCu, G%areaCv) + call rotate_array_pair(G_in%IareaCu, G_in%IareaCv, turns, G%IareaCu, G%IareaCv) + + call rotate_array_pair(G_in%porous_DminU, G_in%porous_DminV, & + turns, G%porous_DminU, G%porous_DminV) + call rotate_array_pair(G_in%porous_DmaxU, G_in%porous_DmaxV, & + turns, G%porous_DmaxU, G%porous_DmaxV) + call rotate_array_pair(G_in%porous_DavgU, G_in%porous_DavgV, & + turns, G%porous_DavgU, G%porous_DavgV) + + + ! Vertex point + call rotate_array(G_in%geoLonBu, turns, G%geoLonBu) + call rotate_array(G_in%geoLatBu, turns, G%geoLatBu) + call rotate_array_pair(G_in%dxBu, G_in%dyBu, turns, G%dxBu, G%dyBu) + call rotate_array(G_in%areaBu, turns, G%areaBu) + call rotate_array(G_in%CoriolisBu, turns, G%CoriolisBu) + call rotate_array(G_in%mask2dBu, turns, G%mask2dBu) + + ! Topography at the cell faces + G%bathymetry_at_vel = G_in%bathymetry_at_vel + if (G%bathymetry_at_vel) then + call rotate_array_pair(G_in%Dblock_u, G_in%Dblock_v, turns, G%Dblock_u, G%Dblock_v) + call rotate_array_pair(G_in%Dopen_u, G_in%Dopen_v, turns, G%Dopen_u, G%Dopen_v) + endif + + ! Nominal grid axes + ! TODO: We should not assign lat values to the lon axis, and vice versa. + ! We temporarily copy lat <-> lon since several components still expect + ! lat and lon sizes to match the first and second dimension sizes. + ! But we ought to instead leave them unchanged and adjust the references to + ! these axes. + if (modulo(turns, 2) /= 0) then + G%gridLonT(:) = G_in%gridLatT(G_in%jeg:G_in%jsg:-1) + G%gridLatT(:) = G_in%gridLonT(:) + G%gridLonB(:) = G_in%gridLatB(G_in%jeg:(G_in%jsg-1):-1) + G%gridLatB(:) = G_in%gridLonB(:) + else + G%gridLonT(:) = G_in%gridLonT(:) + G%gridLatT(:) = G_in%gridLatT(:) + G%gridLonB(:) = G_in%gridLonB(:) + G%gridLatB(:) = G_in%gridLatB(:) + endif + + G%x_axis_units = G_in%y_axis_units + G%y_axis_units = G_in%x_axis_units + G%x_ax_unit_short = G_in%y_ax_unit_short + G%y_ax_unit_short = G_in%x_ax_unit_short + G%south_lat = G_in%south_lat + G%west_lon = G_in%west_lon + G%len_lat = G_in%len_lat + G%len_lon = G_in%len_lon + + ! Rotation-invariant fields + G%areaT_global = G_in%areaT_global + G%IareaT_global = G_in%IareaT_global + G%Rad_Earth = G_in%Rad_Earth + G%Rad_Earth_L = G_in%Rad_Earth_L + G%max_depth = G_in%max_depth + + call set_derived_dyn_horgrid(G, US) +end subroutine rotate_dyn_horgrid + + +!> rescale_dyn_horgrid_bathymetry permits a change in the internal units for the bathymetry on the +!! grid, both rescaling the depths and recording the new internal depth units. +subroutine rescale_dyn_horgrid_bathymetry(G, m_in_new_units) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + real, intent(in) :: m_in_new_units !< The new internal representation of 1 m depth. + + ! Local variables + real :: rescale + integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (m_in_new_units == 1.0) return + if (m_in_new_units < 0.0) & + call MOM_error(FATAL, "rescale_dyn_horgrid_bathymetry: Negative depth units are not permitted.") + if (m_in_new_units == 0.0) & + call MOM_error(FATAL, "rescale_dyn_horgrid_bathymetry: Zero depth units are not permitted.") + + rescale = 1.0 / m_in_new_units + do j=jsd,jed ; do i=isd,ied + G%bathyT(i,j) = rescale*G%bathyT(i,j) + enddo ; enddo + if (G%bathymetry_at_vel) then ; do j=jsd,jed ; do I=IsdB,IedB + G%Dblock_u(I,j) = rescale*G%Dblock_u(I,j) ; G%Dopen_u(I,j) = rescale*G%Dopen_u(I,j) + enddo ; enddo ; endif + if (G%bathymetry_at_vel) then ; do J=JsdB,JedB ; do i=isd,ied + G%Dblock_v(i,J) = rescale*G%Dblock_v(i,J) ; G%Dopen_v(i,J) = rescale*G%Dopen_v(i,J) + enddo ; enddo ; endif + G%max_depth = rescale*G%max_depth + +end subroutine rescale_dyn_horgrid_bathymetry + +!> set_derived_dyn_horgrid calculates metric terms that are derived from other metrics. +subroutine set_derived_dyn_horgrid(G, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type +! Various inverse grid spacings and derived areas are calculated within this +! subroutine. + integer :: i, j, isd, ied, jsd, jed + integer :: IsdB, IedB, JsdB, JedB + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + do j=jsd,jed ; do i=isd,ied + if (G%dxT(i,j) < 0.0) G%dxT(i,j) = 0.0 + if (G%dyT(i,j) < 0.0) G%dyT(i,j) = 0.0 + G%IdxT(i,j) = Adcroft_reciprocal(G%dxT(i,j)) + G%IdyT(i,j) = Adcroft_reciprocal(G%dyT(i,j)) + G%IareaT(i,j) = Adcroft_reciprocal(G%areaT(i,j)) + enddo ; enddo + + do j=jsd,jed ; do I=IsdB,IedB + if (G%dxCu(I,j) < 0.0) G%dxCu(I,j) = 0.0 + if (G%dyCu(I,j) < 0.0) G%dyCu(I,j) = 0.0 + G%IdxCu(I,j) = Adcroft_reciprocal(G%dxCu(I,j)) + G%IdyCu(I,j) = Adcroft_reciprocal(G%dyCu(I,j)) + enddo ; enddo + + do J=JsdB,JedB ; do i=isd,ied + if (G%dxCv(i,J) < 0.0) G%dxCv(i,J) = 0.0 + if (G%dyCv(i,J) < 0.0) G%dyCv(i,J) = 0.0 + G%IdxCv(i,J) = Adcroft_reciprocal(G%dxCv(i,J)) + G%IdyCv(i,J) = Adcroft_reciprocal(G%dyCv(i,J)) + enddo ; enddo + + do J=JsdB,JedB ; do I=IsdB,IedB + if (G%dxBu(I,J) < 0.0) G%dxBu(I,J) = 0.0 + if (G%dyBu(I,J) < 0.0) G%dyBu(I,J) = 0.0 + + G%IdxBu(I,J) = Adcroft_reciprocal(G%dxBu(I,J)) + G%IdyBu(I,J) = Adcroft_reciprocal(G%dyBu(I,J)) + ! areaBu has usually been set to a positive area elsewhere. + if (G%areaBu(I,J) <= 0.0) G%areaBu(I,J) = G%dxBu(I,J) * G%dyBu(I,J) + G%IareaBu(I,J) = Adcroft_reciprocal(G%areaBu(I,J)) + enddo ; enddo + +end subroutine set_derived_dyn_horgrid + +!> Adcroft_reciprocal(x) = 1/x for |x|>0 or 0 for x=0. +function Adcroft_reciprocal(val) result(I_val) + real, intent(in) :: val !< The value being inverted. + real :: I_val !< The Adcroft reciprocal of val. + + I_val = 0.0 ; if (val /= 0.0) I_val = 1.0/val +end function Adcroft_reciprocal + +!--------------------------------------------------------------------- +!> Release memory used by the dyn_horgrid_type and related structures. +subroutine destroy_dyn_horgrid(G) + type(dyn_horgrid_type), pointer :: G !< The dynamic horizontal grid type + + if (.not.associated(G)) then + call MOM_error(FATAL, "destroy_dyn_horgrid called with an unassociated horgrid_type.") + endif + + deallocate(G%dxT) ; deallocate(G%dxCu) ; deallocate(G%dxCv) ; deallocate(G%dxBu) + deallocate(G%IdxT) ; deallocate(G%IdxCu) ; deallocate(G%IdxCv) ; deallocate(G%IdxBu) + + deallocate(G%dyT) ; deallocate(G%dyCu) ; deallocate(G%dyCv) ; deallocate(G%dyBu) + deallocate(G%IdyT) ; deallocate(G%IdyCu) ; deallocate(G%IdyCv) ; deallocate(G%IdyBu) + + deallocate(G%areaT) ; deallocate(G%IareaT) + deallocate(G%areaBu) ; deallocate(G%IareaBu) + deallocate(G%areaCu) ; deallocate(G%IareaCu) + deallocate(G%areaCv) ; deallocate(G%IareaCv) + + deallocate(G%mask2dT) ; deallocate(G%mask2dCu) ; deallocate(G%OBCmaskCu) + deallocate(G%mask2dCv) ; deallocate(G%OBCmaskCv) ; deallocate(G%mask2dBu) + + deallocate(G%geoLatT) ; deallocate(G%geoLatCu) + deallocate(G%geoLatCv) ; deallocate(G%geoLatBu) + deallocate(G%geoLonT) ; deallocate(G%geoLonCu) + deallocate(G%geoLonCv) ; deallocate(G%geoLonBu) + + deallocate(G%dx_Cv) ; deallocate(G%dy_Cu) + + deallocate(G%porous_DminU) ; deallocate(G%porous_DmaxU) ; deallocate(G%porous_DavgU) + deallocate(G%porous_DminV) ; deallocate(G%porous_DmaxV) ; deallocate(G%porous_DavgV) + + deallocate(G%bathyT) ; deallocate(G%CoriolisBu) + deallocate(G%dF_dx) ; deallocate(G%dF_dy) + deallocate(G%sin_rot) ; deallocate(G%cos_rot) + + if (allocated(G%Dblock_u)) deallocate(G%Dblock_u) + if (allocated(G%Dopen_u)) deallocate(G%Dopen_u) + if (allocated(G%Dblock_v)) deallocate(G%Dblock_v) + if (allocated(G%Dopen_v)) deallocate(G%Dopen_v) + + deallocate(G%gridLonT) ; deallocate(G%gridLatT) + deallocate(G%gridLonB) ; deallocate(G%gridLatB) + + ! CS%debug is required to validate Domain_aux, so use allocation test + if (associated(G%Domain_aux)) call deallocate_MOM_domain(G%Domain_aux) + + call deallocate_MOM_domain(G%Domain) + + deallocate(G) + +end subroutine destroy_dyn_horgrid + +end module MOM_dyn_horgrid diff --git a/framework/MOM_ensemble_manager.F90 b/framework/MOM_ensemble_manager.F90 new file mode 100644 index 0000000000..e431212524 --- /dev/null +++ b/framework/MOM_ensemble_manager.F90 @@ -0,0 +1,36 @@ +!> Manages ensemble member layout information +module MOM_ensemble_manager + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_ensemble_manager_infra, only : ensemble_manager_init +use MOM_ensemble_manager_infra, only : ensemble_pelist_setup +use MOM_ensemble_manager_infra, only : get_ensemble_id +use MOM_ensemble_manager_infra, only : get_ensemble_size +use MOM_ensemble_manager_infra, only : get_ensemble_pelist +use MOM_ensemble_manager_infra, only : get_ensemble_filter_pelist + +implicit none ; private + +!> Public functions: +!> mom_ensemble_manager_infra:ensemble_manager_init +public :: ensemble_manager_init +!> mom_ensemble_manager_infra:ensemble_pelist_setup +public :: ensemble_pelist_setup +!> mom_ensemble_manager_infra:get_ensemble_id +public :: get_ensemble_id +!> mom_ensemble_manager_infra:get_ensemble_size +public :: get_ensemble_size +!> mom_ensemble_manager_infra:get_ensemble_pelist +public :: get_ensemble_pelist +!> mom_ensemble_manager_infra:get_ensemble_filter_pelist +public :: get_ensemble_filter_pelist + + + + +end module MOM_ensemble_manager + +!> \namespace mom_ensemble_manager +!! +!! APIs are defined and implemented in MOM_ensemble_manager_infra diff --git a/framework/MOM_error_handler.F90 b/framework/MOM_error_handler.F90 new file mode 100644 index 0000000000..b113050572 --- /dev/null +++ b/framework/MOM_error_handler.F90 @@ -0,0 +1,307 @@ +!> Routines for error handling and I/O management +module MOM_error_handler + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms_infra, only : num_PEs +use MOM_error_infra, only : MOM_err, is_root_pe, stdlog, stdout, NOTE, WARNING, FATAL +use posix, only : getpid, getppid, handler_interface +use posix, only : signal, kill, SIGUSR1 +use posix, only : sigjmp_buf, siglongjmp +use posix, only : sleep + +! MOM_error_infra does not provide stderr . We only use stderr in this module +! *IF* FMS has not been initialized. Further, stderr is only used internally and +! not made public. Other modules should obtain stderr from MOM_io. +use iso_fortran_env, only : stderr=>error_unit + +implicit none ; private + +! These routines are found in this module. +public :: MOM_error, MOM_mesg, assert +public :: MOM_set_verbosity, MOM_get_verbosity, MOM_verbose_enough +public :: callTree_showQuery, callTree_enter, callTree_leave, callTree_waypoint +! These routines are simply passed-through from MOM_error_infra +public :: is_root_pe, stdlog, stdout +!> Integer parameters encoding the severity of an error message +public :: NOTE, WARNING, FATAL +public :: disable_fatal_errors, enable_fatal_errors, set_skip_mpi + +integer :: verbosity = 6 +!< Verbosity level: +!! 0 - FATAL messages only +!! 1 - FATAL + WARNING messages only +!! 2 - FATAL + WARNING + NOTE messages only [default] +!! 3 - above + informational +!! 4 - +!! 5 - +!! 6 - above + call tree +!! 7 - +!! 8 - +!! 9 - anything and everything (also set with DEBUG=True) + +! Note that this module default will only hold until the +! VERBOSITY parameter is parsed and the given default imposed. +! We set it to 6 here so that the call tree will print before +! the parser has been initialized +! Also note that this is a module variable rather than contained in +! a type passed by argument (preferred for most data) for convenience +! and to reduce obfuscation of code + +integer :: callTreeIndentLevel = 0 +!< The level of calling within the call tree + +! Error handling + +logical :: ignore_fatal = .false. + !< If true, ignore FATAL errors and jump to a prior state. +integer, parameter :: err_signal = SIGUSR1 + !< Signal used to trigger the error handler +integer :: err_pid + !< Process ID for the error handler (either self or MPI launcher) +procedure(handler_interface), pointer :: prior_handler + !< The default signal handler used before signal() setup (usually SIG_DFT) +type(sigjmp_buf) :: prior_env + !< Buffer containing the program state to be recovered by longjmp +logical :: skip_mpi_dep = .false. + !< If true, bypass any calls that require FMS (MPI) to have been initialized. + !! Use s/r set_skip_mpi() to change this flag. By default, set_skip_mpi() does not + !! need to be called and this flag is false so that FMS (and MPI) should be + !! initialized. + +contains + +!> This provides a convenient interface for writing an informative comment, depending +!! on the model's current verbosity setting and the verbosity level for this message. +subroutine MOM_mesg(message, verb, all_print) + character(len=*), intent(in) :: message !< A message to write out + integer, optional, intent(in) :: verb !< A level of verbosity for this message + logical, optional, intent(in) :: all_print !< If present and true, any PEs are + !! able to write this message. + ! This provides a convenient interface for writing an informative comment. + integer :: verb_msg + logical :: write_msg + + if (skip_mpi_dep) then + write_msg = .true. + else + write_msg = is_root_pe() + endif + if (present(all_print)) write_msg = write_msg .or. all_print + + verb_msg = 2 ; if (present(verb)) verb_msg = verb + if (write_msg .and. (verbosity >= verb_msg)) call loc_MOM_err(NOTE, message) + +end subroutine MOM_mesg + +!> Enable error handling, replacing FATALs in MOM_error with err_handler. +subroutine disable_fatal_errors(env) + type(sigjmp_buf), intent(in) :: env + !> Process recovery state after FATAL errors + + integer :: sig + + ignore_fatal = .true. + + ! TODO: Only need to call this once; move to an init() function? + if (num_PEs() > 1) then + err_pid = getppid() + else + err_pid = getpid() + endif + + ! Store the program state + prior_env = env + + ! Setup the signal handler + ! NOTE: Passing parameters to signal() in GFortran causes a compiler error. + ! We avert this by copying err_signal to a variable. + sig = err_signal + ! TODO: Use sigaction() in place of signal() + prior_handler => signal(sig, err_handler) +end subroutine disable_fatal_errors + +!> Disable the error handler and abort on FATAL +subroutine enable_fatal_errors() + integer :: sig + procedure(handler_interface), pointer :: dummy + + ignore_fatal = .false. + err_pid = -1 ! NOTE: 0 might be safer, since it's unusable. + + ! Restore the original signal handler (usually SIG_DFT). + sig = err_signal + ! NOTE: As above, we copy the err_signal to accommodate GFortran. + dummy => signal(sig, prior_handler) +end subroutine enable_fatal_errors + +!> Enable/disable skipping MPI dependent behaviors +subroutine set_skip_mpi(skip) + logical, intent(in) :: skip !< State to assign + + skip_mpi_dep = skip + +end subroutine set_skip_mpi + +!> This provides a convenient interface for writing an error message +!! with run-time filter based on a verbosity and the severity of the error. +subroutine MOM_error(level, message, all_print) + integer, intent(in) :: level !< The severity level of this message + character(len=*), intent(in) :: message !< A message to write out + logical, optional, intent(in) :: all_print !< If present and true, any PEs are + !! able to write this message. + logical :: write_msg + integer :: rc + + if (skip_mpi_dep) then + write_msg = .true. + else + write_msg = is_root_pe() + endif + if (present(all_print)) write_msg = write_msg .or. all_print + + select case (level) + case (NOTE) + if (write_msg.and.verbosity>=2) call loc_MOM_err(NOTE, message) + case (WARNING) + if (write_msg.and.verbosity>=1) call loc_MOM_err(WARNING, message) + case (FATAL) + if (ignore_fatal) then + print *, "(FATAL): " // message + rc = kill(err_pid, err_signal) + ! NOTE: MPI launchers require, in their words, "a few seconds" to + ! propagate the signal to the nodes, so we wait here to avoid + ! anomalous FATAL calls. + ! In practice, the signal will take control before sleep() completes. + rc = sleep(3) + endif + if (verbosity>=0) call loc_MOM_err(FATAL, message) + case default + call loc_MOM_err(level, message) + end select +end subroutine MOM_error + +!> A private routine through which all error/warning/note messages are written +!! by this module. +subroutine loc_MOM_err(level, message) + integer, intent(in) :: level !< The severity level of this message + character(len=*), intent(in) :: message !< A message to write out + + if (.not. skip_mpi_dep) then + call MOM_err(level, message) + else + ! FMS (and therefore MPI) have not been initialized + write(stdout(),'(a)') trim(message) ! Send message to stdout + select case (level) + case (WARNING) + write(stderr,'("WARNING ",a)') trim(message) ! Additionally send message to stderr + case (FATAL) + write(stderr,'("ERROR: ",a)') trim(message) ! Additionally send message to stderr + end select + endif + +end subroutine loc_MOM_err + +!> This subroutine sets the level of verbosity filtering MOM error messages +subroutine MOM_set_verbosity(verb) + integer, intent(in) :: verb !< A level of verbosity to set + character(len=80) :: msg + if (verb>0 .and. verb<10) then + verbosity=verb + else + write(msg(1:80),'("Attempt to set verbosity outside of range (0-9). verb=",I0)') verb + call MOM_error(FATAL,msg) + endif +end subroutine MOM_set_verbosity + +!> This subroutine gets the level of verbosity filtering MOM error messages +function MOM_get_verbosity() + integer :: MOM_get_verbosity + MOM_get_verbosity = verbosity +end function MOM_get_verbosity + +!> This tests whether the level of verbosity filtering MOM error messages is +!! sufficient to write a message of verbosity level verb +function MOM_verbose_enough(verb) + integer, intent(in) :: verb !< A level of verbosity to test + logical :: MOM_verbose_enough + MOM_verbose_enough = (verbosity >= verb) +end function MOM_verbose_enough + +!> Returns True, if the verbosity>=6 indicating to show the call tree +function callTree_showQuery() + ! Local variables + logical :: callTree_showQuery + callTree_showQuery = (verbosity >= 6) +end function callTree_showQuery + +!> Writes a message about entering a subroutine if call tree reporting is active +subroutine callTree_enter(mesg,n) + character(len=*), intent(in) :: mesg !< Message to write + integer, optional, intent(in) :: n !< An optional integer to write at end of message + ! Local variables + character(len=8) :: nAsString + callTreeIndentLevel = callTreeIndentLevel + 1 + if (verbosity<6) return + if (is_root_pe()) then + nAsString = '' + if (present(n)) then + write(nAsString(1:8),'(i8)') n + call loc_MOM_err(NOTE, 'callTree: '// & + repeat(' ',callTreeIndentLevel-1)//'loop '//trim(mesg)//trim(nAsString)) + else + call loc_MOM_err(NOTE, 'callTree: '// & + repeat(' ',callTreeIndentLevel-1)//'---> '//trim(mesg)) + endif + endif +end subroutine callTree_enter + +!> Writes a message about leaving a subroutine if call tree reporting is active +subroutine callTree_leave(mesg) + character(len=*) :: mesg !< Message to write + if (callTreeIndentLevel<1) write(0,*) 'callTree_leave: error callTreeIndentLevel=',callTreeIndentLevel,trim(mesg) + callTreeIndentLevel = callTreeIndentLevel - 1 + if (verbosity<6) return + if (is_root_pe()) call loc_MOM_err(NOTE, 'callTree: '// & + repeat(' ',callTreeIndentLevel)//'<--- '//trim(mesg)) +end subroutine callTree_leave + +!> Writes a message about reaching a milestone if call tree reporting is active +subroutine callTree_waypoint(mesg,n) + character(len=*), intent(in) :: mesg !< Message to write + integer, optional, intent(in) :: n !< An optional integer to write at end of message + ! Local variables + character(len=8) :: nAsString + if (callTreeIndentLevel<0) write(0,*) 'callTree_waypoint: error callTreeIndentLevel=',callTreeIndentLevel,trim(mesg) + if (verbosity<6) return + if (is_root_pe()) then + nAsString = '' + if (present(n)) then + write(nAsString(1:8),'(i8)') n + call loc_MOM_err(NOTE, 'callTree: '// & + repeat(' ',callTreeIndentLevel)//'loop '//trim(mesg)//trim(nAsString)) + else + call loc_MOM_err(NOTE, 'callTree: '// & + repeat(' ',callTreeIndentLevel)//'o '//trim(mesg)) + endif + endif +end subroutine callTree_waypoint + +!> Issues a FATAL error if the assertion fails, i.e. the first argument is false. +subroutine assert(logical_arg, msg) + logical, intent(in) :: logical_arg !< If false causes a FATAL error + character(len=*), intent(in) :: msg !< Message to issue in case of failed assertion + + if (.not. logical_arg) then + call MOM_error(FATAL, msg) + endif +end subroutine assert + +!> Restore the process state via longjmp after receiving a signal. +subroutine err_handler(sig) + integer, intent(in) :: sig + !< Signal passed to the handler (unused) + call siglongjmp(prior_env, 1) +end subroutine + +end module MOM_error_handler diff --git a/framework/MOM_file_parser.F90 b/framework/MOM_file_parser.F90 new file mode 100644 index 0000000000..22d3789ea5 --- /dev/null +++ b/framework/MOM_file_parser.F90 @@ -0,0 +1,2191 @@ +!> The MOM6 facility to parse input files for runtime parameters +module MOM_file_parser + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : root_PE, broadcast +use MOM_coms, only : any_across_PEs +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, assert +use MOM_error_handler, only : is_root_pe, stdlog, stdout +use MOM_time_manager, only : get_time, time_type, get_ticks_per_second +use MOM_time_manager, only : set_date, get_date, real_to_time, operator(-), set_time +use MOM_document, only : doc_param, doc_module, doc_init, doc_end, doc_type +use MOM_document, only : doc_openBlock, doc_closeBlock +use MOM_string_functions, only : left_int, left_ints, slasher +use MOM_string_functions, only : left_real, left_reals + +implicit none ; private + +! These are hard-coded limits that are used in the following code. They should be set +! generously enough not to impose any significant limitations. +integer, parameter, public :: MAX_PARAM_FILES = 5 !< Maximum number of parameter files. +integer, parameter :: INPUT_STR_LENGTH = 1024 !< Maximum line length in parameter file. Lines that + !! are combined by ending in '\' or '&' can exceed + !! this limit after merging. +integer, parameter :: FILENAME_LENGTH = 200 !< Maximum number of characters in file names. + + +!>@{ Default values for parameters +logical, parameter :: report_unused_default = .true. +logical, parameter :: unused_params_fatal_default = .false. +logical, parameter :: log_to_stdout_default = .false. +logical, parameter :: complete_doc_default = .true. +logical, parameter :: minimal_doc_default = .true. +!>@} + + +!> A simple type to allow lines in an array to be allocated with variable sizes. +type, private :: file_line_type ; private + character(len=:), allocatable :: line !< An allocatable line with content +end type file_line_type + +!> The valid lines extracted from an input parameter file without comments +type, private :: file_data_type ; private + integer :: num_lines = 0 !< The number of lines in this type + type(file_line_type), allocatable, dimension(:) :: fln !< Lines with the input content. + logical, pointer, dimension(:) :: line_used => NULL() !< If true, the line has been read +end type file_data_type + +!> A link in the list of variables that have already had override warnings issued +type, private :: link_parameter ; private + type(link_parameter), pointer :: next => NULL() !< Facilitates linked list + character(len=80) :: name !< Parameter name + logical :: hasIssuedOverrideWarning = .false. !< Has a default value +end type link_parameter + +!> Specify the active parameter block +type, private :: parameter_block ; private + character(len=240) :: name = '' !< The active parameter block name + logical :: log_access = .true. + !< Log the entry and exit of the block (but not its contents) +end type parameter_block + +!> A structure that can be parsed to read and document run-time parameters. +type, public :: param_file_type ; private + integer :: nfiles = 0 !< The number of open files. + integer :: iounit(MAX_PARAM_FILES) !< The unit numbers of open files. + character(len=FILENAME_LENGTH) :: filename(MAX_PARAM_FILES) !< The names of the open files. + logical :: NetCDF_file(MAX_PARAM_FILES) !< If true, the input file is in NetCDF. + ! This is not yet implemented. + type(file_data_type) :: param_data(MAX_PARAM_FILES) !< Structures that contain + !! the valid data lines from the parameter + !! files, enabling all subsequent reads of + !! parameter data to occur internally. + logical :: report_unused = report_unused_default !< If true, report any + !! parameter lines that are not used in the run. + logical :: unused_params_fatal = unused_params_fatal_default !< If true, kill + !! the run if there are any unused parameters. + logical :: log_to_stdout = log_to_stdout_default !< If true, all log + !! messages are also sent to stdout. + logical :: log_open = .false. !< True if the log file has been opened. + integer :: max_line_len = 4 !< The maximum number of characters in the lines + !! in any of the files in this param_file_type after + !! any continued lines have been combined. + integer :: stdout !< The unit number from stdout(). + integer :: stdlog !< The unit number from stdlog(). + character(len=240) :: doc_file !< A file where all run-time parameters, their + !! settings and defaults are documented. + logical :: complete_doc = complete_doc_default !< If true, document all + !! run-time parameters. + logical :: minimal_doc = minimal_doc_default !< If true, document only those + !! run-time parameters that differ from defaults. + type(doc_type), pointer :: doc => NULL() !< A structure that contains information + !! related to parameter documentation. + type(link_parameter), pointer :: chain => NULL() !< Facilitates linked list + type(parameter_block), pointer :: blockName => NULL() !< Name of active parameter block +end type param_file_type + +public read_param, open_param_file, close_param_file, log_param, log_version +public doc_param, get_param +public clearParameterBlock, openParameterBlock, closeParameterBlock + +!> An overloaded interface to read various types of parameters +interface read_param + module procedure read_param_int, read_param_real, read_param_logical, & + read_param_char, read_param_char_array, read_param_time, & + read_param_int_array, read_param_real_array +end interface +!> An overloaded interface to log the values of various types of parameters +interface log_param + module procedure log_param_int, log_param_real, log_param_logical, & + log_param_char, log_param_time, & + log_param_int_array, log_param_real_array +end interface +!> An overloaded interface to read and log the values of various types of parameters +interface get_param + module procedure get_param_int, get_param_real, get_param_logical, & + get_param_char, get_param_char_array, get_param_time, & + get_param_int_array, get_param_real_array +end interface + +!> An overloaded interface to log version information about modules +interface log_version + module procedure log_version_cs, log_version_plain +end interface + +contains + +!> Make the contents of a parameter input file availalble in a param_file_type +subroutine open_param_file(filename, CS, checkable, component, doc_file_dir, ensemble_num) + character(len=*), intent(in) :: filename !< An input file name, optionally with the full path + type(param_file_type), intent(inout) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + logical, optional, intent(in) :: checkable !< If this is false, it disables checks of this + !! file for unused parameters. The default is True. + character(len=*), optional, intent(in) :: component !< If present, this component name is used + !! to generate parameter documentation file names; the default is"MOM" + character(len=*), optional, intent(in) :: doc_file_dir !< An optional directory in which to write out + !! the documentation files. The default is effectively './'. + integer, optional, intent(in) :: ensemble_num !< ensemble number to be appended to _doc filenames (optional) + + ! Local variables + logical :: file_exists, Netcdf_file, may_check, reopened_file + integer :: ios, iounit, strlen, i + character(len=240) :: doc_path + character(len=5) :: ensemble_suffix + type(parameter_block), pointer :: block => NULL() + + may_check = .true. ; if (present(checkable)) may_check = checkable + + ! Check for non-blank filename + strlen = len_trim(filename) + if (strlen == 0) then + call MOM_error(FATAL, "open_param_file: Input file has not been specified.") + endif + + ! Check that this file has not already been opened + if (CS%nfiles > 0) then + reopened_file = .false. + + if (is_root_pe()) then + inquire(file=trim(filename), number=iounit) + if (iounit /= -1) then + do i = 1, CS%nfiles + if (CS%iounit(i) == iounit) then + call assert(trim(CS%filename(1)) == trim(filename), & + "open_param_file: internal inconsistency! "//trim(filename)// & + " is registered as open but has the wrong unit number!") + call MOM_error(WARNING, & + "open_param_file: file "//trim(filename)// & + " has already been opened. This should NOT happen!"// & + " Did you specify the same file twice in a namelist?") + reopened_file = .true. + endif ! unit numbers + enddo ! i + endif + endif + + if (any_across_PEs(reopened_file)) return + endif + + ! Check that the file exists to readstdlog + if (is_root_pe()) then + inquire(file=trim(filename), exist=file_exists) + if (.not.file_exists) call MOM_error(FATAL, & + "open_param_file: Input file '"// trim(filename)//"' does not exist.") + endif + + Netcdf_file = .false. + if (strlen > 3) then + if (filename(strlen-2:strlen) == ".nc") Netcdf_file = .true. + endif + + if (Netcdf_file) & + call MOM_error(FATAL,"open_param_file: NetCDF files are not yet supported.") + + if (is_root_pe()) then + open(newunit=iounit, file=trim(filename), access='SEQUENTIAL', & + form='FORMATTED', action='READ', position='REWIND', iostat=ios) + if (ios /= 0) call MOM_error(FATAL, "open_param_file: Error opening '"//trim(filename)//"'.") + else + iounit = 1 + endif + + ! Store/register the unit and details + i = CS%nfiles + 1 + CS%nfiles = i + CS%iounit(i) = iounit + CS%filename(i) = filename + CS%NetCDF_file(i) = Netcdf_file + + if (associated(CS%blockName)) deallocate(CS%blockName) + allocate(block) ; block%name = '' ; CS%blockName => block + + call MOM_mesg("open_param_file: "// trim(filename)//" has been opened successfully.", 5) + + call populate_param_data(iounit, filename, CS%param_data(i)) + ! Increment the maximum line length, but always report values in blocks of 4 characters. + CS%max_line_len = max(CS%max_line_len, 4 + 4*(max_input_line_length(CS, i) - 1) / 4) + + call read_param(CS,"SEND_LOG_TO_STDOUT",CS%log_to_stdout) + call read_param(CS,"REPORT_UNUSED_PARAMS",CS%report_unused) + call read_param(CS,"FATAL_UNUSED_PARAMS",CS%unused_params_fatal) + CS%doc_file = "MOM_parameter_doc" + if (present(ensemble_num)) then + ! append instance suffix to doc_file + write(ensemble_suffix,'(A,I0.4)') '_', ensemble_num + CS%doc_file = trim(CS%doc_file)//ensemble_suffix + endif + if (present(component)) CS%doc_file = trim(component)//"_parameter_doc" + call read_param(CS,"DOCUMENT_FILE", CS%doc_file) + if (.not.may_check) then + CS%report_unused = .false. + CS%unused_params_fatal = .false. + endif + + ! Open the log file. + CS%stdlog = stdlog() ; CS%stdout = stdout() + CS%log_open = (stdlog() > 0) + + doc_path = CS%doc_file + if (len_trim(CS%doc_file) > 0) then + CS%complete_doc = complete_doc_default + call read_param(CS, "COMPLETE_DOCUMENTATION", CS%complete_doc) + CS%minimal_doc = minimal_doc_default + call read_param(CS, "MINIMAL_DOCUMENTATION", CS%minimal_doc) + if (present(doc_file_dir)) then ; if (len_trim(doc_file_dir) > 0) then + doc_path = trim(slasher(doc_file_dir))//trim(CS%doc_file) + endif ; endif + else + CS%complete_doc = .false. + CS%minimal_doc = .false. + endif + call doc_init(doc_path, CS%doc, minimal=CS%minimal_doc, complete=CS%complete_doc, & + layout=CS%complete_doc, debugging=CS%complete_doc) + +end subroutine open_param_file + +!> Close any open input files and deallocate memory associated with this param_file_type. +!! To use this type again, open_param_file would have to be called again. +subroutine close_param_file(CS, quiet_close, component) + type(param_file_type), intent(inout) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + logical, optional, intent(in) :: quiet_close !< if present and true, do not do any + !! logging with this call. + character(len=*), optional, intent(in) :: component !< If present, this component name is used + !! to generate parameter documentation file names + ! Local variables + logical :: all_default + character(len=128) :: docfile_default + character(len=40) :: mdl ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + integer :: i, n, num_unused + + if (present(quiet_close)) then ; if (quiet_close) then + do i = 1, CS%nfiles + if (is_root_pe()) close(CS%iounit(i)) + call MOM_mesg("close_param_file: "// trim(CS%filename(i))// & + " has been closed successfully.", 5) + CS%iounit(i) = -1 + CS%filename(i) = '' + CS%NetCDF_file(i) = .false. + do n=1,CS%param_data(i)%num_lines ; deallocate(CS%param_data(i)%fln(n)%line) ; enddo + deallocate (CS%param_data(i)%fln) + deallocate (CS%param_data(i)%line_used) + enddo + CS%log_open = .false. + call doc_end(CS%doc) + deallocate(CS%doc) + return + endif ; endif + + ! Log the parameters for the parser. + docfile_default = "MOM_parameter_doc" + if (present(component)) docfile_default = trim(component)//"_parameter_doc" + + all_default = (CS%log_to_stdout .eqv. log_to_stdout_default) + all_default = all_default .and. (trim(CS%doc_file) == trim(docfile_default)) + if (len_trim(CS%doc_file) > 0) then + all_default = all_default .and. (CS%complete_doc .eqv. complete_doc_default) + all_default = all_default .and. (CS%minimal_doc .eqv. minimal_doc_default) + endif + + mdl = "MOM_file_parser" + call log_version(CS, mdl, version, "", debugging=.true., log_to_all=.true., all_default=all_default) + call log_param(CS, mdl, "SEND_LOG_TO_STDOUT", CS%log_to_stdout, & + "If true, all log messages are also sent to stdout.", & + default=log_to_stdout_default) + call log_param(CS, mdl, "REPORT_UNUSED_PARAMS", CS%report_unused, & + "If true, report any parameter lines that are not used "//& + "in the run.", default=report_unused_default, & + debuggingParam=.true.) + call log_param(CS, mdl, "FATAL_UNUSED_PARAMS", CS%unused_params_fatal, & + "If true, kill the run if there are any unused "//& + "parameters.", default=unused_params_fatal_default, & + debuggingParam=.true.) + call log_param(CS, mdl, "DOCUMENT_FILE", CS%doc_file, & + "The basename for files where run-time parameters, their "//& + "settings, units and defaults are documented. Blank will "//& + "disable all parameter documentation.", default=docfile_default) + if (len_trim(CS%doc_file) > 0) then + call log_param(CS, mdl, "COMPLETE_DOCUMENTATION", CS%complete_doc, & + "If true, all run-time parameters are "//& + "documented in "//trim(CS%doc_file)//& + ".all .", default=complete_doc_default) + call log_param(CS, mdl, "MINIMAL_DOCUMENTATION", CS%minimal_doc, & + "If true, non-default run-time parameters are "//& + "documented in "//trim(CS%doc_file)//& + ".short .", default=minimal_doc_default) + endif + + num_unused = 0 + do i = 1, CS%nfiles + if (is_root_pe() .and. (CS%report_unused .or. & + CS%unused_params_fatal)) then + ! Check for unused lines. + do n=1,CS%param_data(i)%num_lines + if (.not.CS%param_data(i)%line_used(n)) then + num_unused = num_unused + 1 + if (CS%report_unused) & + call MOM_error(WARNING, "Unused line in "//trim(CS%filename(i))// & + " : "//trim(CS%param_data(i)%fln(n)%line)) + endif + enddo + endif + + if (is_root_pe()) close(CS%iounit(i)) + call MOM_mesg("close_param_file: "// trim(CS%filename(i))//" has been closed successfully.", 5) + CS%iounit(i) = -1 + CS%filename(i) = '' + CS%NetCDF_file(i) = .false. + do n=1,CS%param_data(i)%num_lines ; deallocate(CS%param_data(i)%fln(n)%line) ; enddo + deallocate (CS%param_data(i)%fln) + deallocate (CS%param_data(i)%line_used) + enddo + deallocate(CS%blockName) + + if (is_root_pe() .and. (num_unused>0) .and. CS%unused_params_fatal) & + call MOM_error(FATAL, "Run stopped because of unused parameter lines.") + + CS%log_open = .false. + call doc_end(CS%doc) + deallocate(CS%doc) +end subroutine close_param_file + +!> Read the contents of a parameter input file, and store the contents in a +!! file_data_type after removing comments and simplifying white space +subroutine populate_param_data(iounit, filename, param_data) + integer, intent(in) :: iounit !< The IO unit number that is open for filename + character(len=*), intent(in) :: filename !< An input file name, optionally with the full path + type(file_data_type), intent(inout) :: param_data !< A list of the input lines that set parameters + !! after comments have been stripped out. + + ! Local variables + character(len=INPUT_STR_LENGTH) :: line + character(len=1), allocatable, dimension(:) :: char_buf + integer, allocatable, dimension(:) :: line_len ! The trimmed length of each processed input line + integer :: n, num_lines, total_chars, ch, rsc, llen, int_buf(2) + logical :: inMultiLineComment + + ! Find the number of keyword lines in a parameter file + if (is_root_pe()) then + ! rewind the parameter file + rewind(iounit) + + ! count the number of valid entries in the parameter file + num_lines = 0 + total_chars = 0 + inMultiLineComment = .false. + do while(.true.) + read(iounit, '(a)', end=8) line + line = replaceTabs(line) + if (inMultiLineComment) then + if (closeMultiLineComment(line)) inMultiLineComment=.false. + else + if (lastNonCommentNonBlank(line)>0) then + line = removeComments(line) + line = simplifyWhiteSpace(line(:len_trim(line))) + num_lines = num_lines + 1 + total_chars = total_chars + len_trim(line) + endif + if (openMultiLineComment(line)) inMultiLineComment=.true. + endif + enddo ! while (.true.) + 8 continue ! get here when read() reaches EOF + + if (inMultiLineComment .and. is_root_pe()) & + call MOM_error(FATAL, 'MOM_file_parser : A C-style multi-line comment '// & + '(/* ... */) was not closed before the end of '//trim(filename)) + + + int_buf(1) = num_lines + int_buf(2) = total_chars + endif ! (is_root_pe()) + + ! Broadcast the number of valid entries in parameter file + call broadcast(int_buf, 2, root_pe()) + num_lines = int_buf(1) + total_chars = int_buf(2) + + ! Set up the space for storing the actual lines. + param_data%num_lines = num_lines + allocate (line_len(num_lines), source=0) + allocate (char_buf(total_chars), source=" ") + + ! Read the actual lines. + if (is_root_pe()) then + ! rewind the parameter file + rewind(iounit) + + ! Populate param_data%fln%line + num_lines = 0 + rsc = 0 + do while(.true.) + read(iounit, '(a)', end=18) line + line = replaceTabs(line) + if (inMultiLineComment) then + if (closeMultiLineComment(line)) inMultiLineComment=.false. + else + if (lastNonCommentNonBlank(line)>0) then + line = removeComments(line) + if ((len_trim(line) > 1000) .and. is_root_PE()) then + call MOM_error(WARNING, "MOM_file_parser: Consider using continuation to split up "//& + "the excessivley long parameter input line "//trim(line)) + endif + line = simplifyWhiteSpace(line(:len_trim(line))) + num_lines = num_lines + 1 + llen = len_trim(line) + line_len(num_lines) = llen + do ch=1,llen ; char_buf(rsc+ch)(1:1) = line(ch:ch) ; enddo + rsc = rsc + llen + endif + if (openMultiLineComment(line)) inMultiLineComment=.true. + endif + enddo ! while (.true.) +18 continue ! get here when read() reaches EOF + + call assert(num_lines == param_data%num_lines, & + 'MOM_file_parser: Found different number of valid lines on second ' & + // 'reading of '//trim(filename)) + endif ! (is_root_pe()) + + ! Broadcast the populated arrays line_len and char_buf + call broadcast(line_len, num_lines, root_pe()) + call broadcast(char_buf(1:total_chars), 1, root_pe()) + + ! Allocate space to hold contents of the parameter file, including the lines in param_data%fln + allocate(param_data%fln(num_lines)) + allocate(param_data%line_used(num_lines)) + param_data%line_used(:) = .false. + ! Populate param_data%fln%line with the keyword lines from parameter file + rsc = 0 + do n=1,num_lines + line(1:INPUT_STR_LENGTH) = " " + do ch=1,line_len(n) ; line(ch:ch) = char_buf(rsc+ch)(1:1) ; enddo + param_data%fln(n)%line = trim(line) + rsc = rsc + line_len(n) + enddo + + deallocate(char_buf) ; deallocate(line_len) + +end subroutine populate_param_data + + +!> Return True if a /* appears on this line without a closing */ +function openMultiLineComment(string) + character(len=*), intent(in) :: string !< The input string to process + logical :: openMultiLineComment + + ! Local variables + integer :: icom, last + + openMultiLineComment = .false. + last = lastNonCommentIndex(string)+1 + icom = index(string(last:), "/*") + if (icom > 0) then + openMultiLineComment=.true. + last = last+icom+1 + endif + icom = index(string(last:), "*/") ; if (icom > 0) openMultiLineComment=.false. +end function openMultiLineComment + +!> Return True if a */ appears on this line +function closeMultiLineComment(string) + character(len=*), intent(in) :: string !< The input string to process + logical :: closeMultiLineComment +! True if a */ appears on this line + closeMultiLineComment = .false. + if (index(string, "*/")>0) closeMultiLineComment=.true. +end function closeMultiLineComment + +!> Find position of last character before any comments, As marked by "!", "//", or "/*" +!! following F90, C++, or C syntax +function lastNonCommentIndex(string) + character(len=*), intent(in) :: string !< The input string to process + integer :: lastNonCommentIndex + + ! Local variables + integer :: icom, last + + ! This subroutine is the only place where a comment needs to be defined + last = len_trim(string) + icom = index(string(:last), "!") ; if (icom > 0) last = icom-1 ! F90 style + icom = index(string(:last), "//") ; if (icom > 0) last = icom-1 ! C++ style + icom = index(string(:last), "/*") ; if (icom > 0) last = icom-1 ! C style + lastNonCommentIndex = last +end function lastNonCommentIndex + +!> Find position of last non-blank character before any comments +function lastNonCommentNonBlank(string) + character(len=*), intent(in) :: string !< The input string to process + integer :: lastNonCommentNonBlank + + lastNonCommentNonBlank = len_trim(string(:lastNonCommentIndex(string))) ! Ignore remaining trailing blanks +end function lastNonCommentNonBlank + +!> Returns a string with tabs replaced by a blank +function replaceTabs(string) + character(len=*), intent(in) :: string !< The input string to process + character(len=len(string)) :: replaceTabs + + integer :: i + + do i=1, len(string) + if (string(i:i)==achar(9)) then + replaceTabs(i:i)=" " + else + replaceTabs(i:i)=string(i:i) + endif + enddo +end function replaceTabs + +!> Trims comments and leading blanks from string +function removeComments(string) + character(len=*), intent(in) :: string !< The input string to process + character(len=len(string)) :: removeComments + + integer :: last + + removeComments=repeat(" ",len(string)) + last = lastNonCommentNonBlank(string) + removeComments(:last)=adjustl(string(:last)) ! Copy only the non-comment part of string +end function removeComments + +!> Constructs a string with all repeated whitespace replaced with single blanks +!! and insert white space where it helps delineate tokens (e.g. around =) +function simplifyWhiteSpace(string) + character(len=*), intent(in) :: string !< A string to modify to simpify white space + character(len=len(string)+16) :: simplifyWhiteSpace + + ! Local variables + integer :: i,j + logical :: nonBlank = .false., insideString = .false. + character(len=1) :: quoteChar=" " + + nonBlank = .false.; insideString = .false. ! NOTE: For some reason this line is needed?? + i=0 + simplifyWhiteSpace=repeat(" ",len(string)+16) + do j=1,len_trim(string) + if (insideString) then ! Do not change formatting inside strings + i=i+1 + simplifyWhiteSpace(i:i)=string(j:j) + if (string(j:j)==quoteChar) insideString=.false. ! End of string + else ! The following is outside of string delimiters + if (string(j:j)==" " .or. string(j:j)==achar(9)) then ! Space or tab + if (nonBlank) then ! Only copy a blank if the preceeding character was non-blank + i=i+1 + simplifyWhiteSpace(i:i)=" " ! Not string(j:j) so that tabs are replace by blanks + nonBlank=.false. + endif + elseif (string(j:j)=='"' .or. string(j:j)=="'") then ! Start a sting + i=i+1 + simplifyWhiteSpace(i:i)=string(j:j) + insideString=.true. + quoteChar=string(j:j) ! Keep copy of starting quote + nonBlank=.true. ! For exit from string + elseif (string(j:j)=='=') then + ! Insert spaces if this character is "=" so that line contains " = " + if (nonBlank) then + i=i+1 + simplifyWhiteSpace(i:i)=" " + endif + i=i+2 + simplifyWhiteSpace(i-1:i)=string(j:j)//" " + nonBlank=.false. + else ! All other characters + i=i+1 + simplifyWhiteSpace(i:i)=string(j:j) + nonBlank=.true. + endif + endif ! if (insideString) + enddo ! j + if (insideString) then ! A missing close quote should be flagged + if (is_root_pe()) call MOM_error(FATAL, & + "There is a mismatched quote in the parameter file line: "// & + trim(string)) + endif +end function simplifyWhiteSpace + +!> This subroutine reads the value of an integer model parameter from a parameter file. +subroutine read_param_int(CS, varname, value, fail_if_missing) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + ! Local variables + character(len=CS%max_line_len) :: value_string(1) + logical :: found, defined + + call get_variable_line(CS, varname, found, defined, value_string) + if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then + read(value_string(1),*,err = 1001) value + else + if (present(fail_if_missing)) then ; if (fail_if_missing) then + if (.not.found) then + call MOM_error(FATAL,'read_param_int: Unable to find variable '//trim(varname)// & + ' in any input files.') + else + call MOM_error(FATAL,'read_param_int: Variable '//trim(varname)// & + ' found but not set in input files.') + endif + endif ; endif + endif + return + 1001 call MOM_error(FATAL,'read_param_int: read error for integer variable '//trim(varname)// & + ' parsing "'//trim(value_string(1))//'"') +end subroutine read_param_int + +!> This subroutine reads the values of an array of integer model parameters from a parameter file. +subroutine read_param_int_array(CS, varname, value, fail_if_missing) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + ! Local variables + character(len=CS%max_line_len) :: value_string(1) + logical :: found, defined + + call get_variable_line(CS, varname, found, defined, value_string) + if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then + read(value_string(1),*,end=991,err=1002) value + 991 return + else + if (present(fail_if_missing)) then ; if (fail_if_missing) then + if (.not.found) then + call MOM_error(FATAL,'read_param_int_array: Unable to find variable '//trim(varname)// & + ' in any input files.') + else + call MOM_error(FATAL,'read_param_int_array: Variable '//trim(varname)// & + ' found but not set in input files.') + endif + endif ; endif + endif + return + 1002 call MOM_error(FATAL,'read_param_int_array: read error for integer array '//trim(varname)// & + ' parsing "'//trim(value_string(1))//'"') +end subroutine read_param_int_array + +!> This subroutine reads the value of a real model parameter from a parameter file. +subroutine read_param_real(CS, varname, value, fail_if_missing, scale) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + real, optional, intent(in) :: scale !< A scaling factor that the parameter is multiplied + !! by before it is returned. + + ! Local variables + character(len=CS%max_line_len) :: value_string(1) + logical :: found, defined + + call get_variable_line(CS, varname, found, defined, value_string) + if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then + read(value_string(1),*,err=1003) value + if (present(scale)) value = scale*value + else + if (present(fail_if_missing)) then ; if (fail_if_missing) then + if (.not.found) then + call MOM_error(FATAL,'read_param_real: Unable to find variable '//trim(varname)// & + ' in any input files.') + else + call MOM_error(FATAL,'read_param_real: Variable '//trim(varname)// & + ' found but not set in input files.') + endif + endif ; endif + endif + return + 1003 call MOM_error(FATAL,'read_param_real: read error for real variable '//trim(varname)// & + ' parsing "'//trim(value_string(1))//'"') +end subroutine read_param_real + +!> This subroutine reads the values of an array of real model parameters from a parameter file. +subroutine read_param_real_array(CS, varname, value, fail_if_missing, scale) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + real, optional, intent(in) :: scale !< A scaling factor that the parameter is multiplied + !! by before it is returned. + + ! Local variables + character(len=CS%max_line_len) :: value_string(1) + logical :: found, defined + + call get_variable_line(CS, varname, found, defined, value_string) + if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then + read(value_string(1),*,end=991,err=1004) value +991 continue + if (present(scale)) value(:) = scale*value(:) + return + else + if (present(fail_if_missing)) then ; if (fail_if_missing) then + if (.not.found) then + call MOM_error(FATAL,'read_param_real_array: Unable to find variable '//trim(varname)// & + ' in any input files.') + else + call MOM_error(FATAL,'read_param_real_array: Variable '//trim(varname)// & + ' found but not set in input files.') + endif + endif ; endif + endif + return + 1004 call MOM_error(FATAL,'read_param_real_array: read error for real array '//trim(varname)// & + ' parsing "'//trim(value_string(1))//'"') +end subroutine read_param_real_array + +!> This subroutine reads the value of a character string model parameter from a parameter file. +subroutine read_param_char(CS, varname, value, fail_if_missing) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + ! Local variables + character(len=CS%max_line_len) :: value_string(1) + logical :: found, defined + + call get_variable_line(CS, varname, found, defined, value_string) + if (found) then + value = trim(strip_quotes(value_string(1))) + elseif (present(fail_if_missing)) then ; if (fail_if_missing) then + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') + endif ; endif + +end subroutine read_param_char + +!> This subroutine reads the values of an array of character string model parameters from a parameter file. +subroutine read_param_char_array(CS, varname, value, fail_if_missing) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + + ! Local variables + character(len=CS%max_line_len) :: value_string(1), loc_string + logical :: found, defined + integer :: i, i_out + + call get_variable_line(CS, varname, found, defined, value_string) + if (found) then + loc_string = trim(value_string(1)) + i = index(loc_string,",") + i_out = 1 + do while(i>0) + value(i_out) = trim(strip_quotes(loc_string(:i-1))) + i_out = i_out+1 + loc_string = trim(adjustl(loc_string(i+1:))) + i = index(loc_string,",") + enddo + if (len_trim(loc_string)>0) then + value(i_out) = trim(strip_quotes(adjustl(loc_string))) + i_out = i_out+1 + endif + do i=i_out,SIZE(value) ; value(i) = " " ; enddo + elseif (present(fail_if_missing)) then ; if (fail_if_missing) then + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') + endif ; endif + +end subroutine read_param_char_array + +!> This subroutine reads the value of a logical model parameter from a parameter file. +subroutine read_param_logical(CS, varname, value, fail_if_missing) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + logical, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + + ! Local variables + character(len=CS%max_line_len) :: value_string(1) + logical :: found, defined + + call get_variable_line(CS, varname, found, defined, value_string, paramIsLogical=.true.) + if (found) then + value = defined + elseif (present(fail_if_missing)) then ; if (fail_if_missing) then + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') + endif ; endif +end subroutine read_param_logical + +!> This subroutine reads the value of a time_type model parameter from a parameter file. +subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_format) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + type(time_type), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + real, optional, intent(in) :: timeunit !< The number of seconds in a time unit for real-number input. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(out) :: date_format !< If present, this indicates whether this + !! parameter was read in a date format, so that it can + !! later be logged in the same format. + + ! Local variables + character(len=CS%max_line_len) :: value_string(1) + character(len=240) :: err_msg + logical :: found, defined + real :: real_time, time_unit + integer :: vals(7) + + if (present(date_format)) date_format = .false. + + call get_variable_line(CS, varname, found, defined, value_string) + if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then + ! Determine whether value string should be parsed for a real number + ! or a date, in either a string format or a comma-delimited list of values. + if ((INDEX(value_string(1),'-') > 0) .and. & + (INDEX(value_string(1),'-',back=.true.) > INDEX(value_string(1),'-'))) then + ! There are two dashes, so this must be a date format. + value = set_date(value_string(1), err_msg=err_msg) + if (LEN_TRIM(err_msg) > 0) call MOM_error(FATAL,'read_param_time: '//& + trim(err_msg)//' in integer list read error for time-type variable '//& + trim(varname)// ' parsing "'//trim(value_string(1))//'"') + if (present(date_format)) date_format = .true. + elseif (INDEX(value_string(1),',') > 0) then + ! Initialize vals with an invalid date. + vals(:) = (/ -999, -999, -999, 0, 0, 0, 0 /) + read(value_string(1), *, end=995, err=1005) vals + 995 continue + if ((vals(1) < 0) .or. (vals(2) < 0) .or. (vals(3) < 0)) & + call MOM_error(FATAL,'read_param_time: integer list read error for time-type variable '//& + trim(varname)// ' parsing "'//trim(value_string(1))//'"') + value = set_date(vals(1), vals(2), vals(3), vals(4), vals(5), vals(6), & + vals(7), err_msg=err_msg) + if (LEN_TRIM(err_msg) > 0) call MOM_error(FATAL,'read_param_time: '//& + trim(err_msg)//' in integer list read error for time-type variable '//& + trim(varname)// ' parsing "'//trim(value_string(1))//'"') + if (present(date_format)) date_format = .true. + else + time_unit = 1.0 ; if (present(timeunit)) time_unit = timeunit + read( value_string(1), *) real_time + value = real_to_time(real_time*time_unit) + endif + else + if (present(fail_if_missing)) then ; if (fail_if_missing) then + if (.not.found) then + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') + else + call MOM_error(FATAL, 'Variable '//trim(varname)//' found but not set in input files.') + endif + endif ; endif + endif + return + + 1005 call MOM_error(FATAL, 'read_param_time: read error for time-type variable '//& + trim(varname)// ' parsing "'//trim(value_string(1))//'"') +end subroutine read_param_time + +!> This function removes single and double quotes from a character string +function strip_quotes(val_str) + character(len=*), intent(in) :: val_str !< The character string to work on + character(len=len(val_str)) :: strip_quotes + ! Local variables + integer :: i + strip_quotes = val_str + i = index(strip_quotes,ACHAR(34)) ! Double quote + do while (i>0) + if (i > 1) then ; strip_quotes = strip_quotes(:i-1)//strip_quotes(i+1:) + else ; strip_quotes = strip_quotes(2:) ; endif + i = index(strip_quotes,ACHAR(34)) ! Double quote + enddo + i = index(strip_quotes,ACHAR(39)) ! Single quote + do while (i>0) + if (i > 1) then ; strip_quotes = strip_quotes(:i-1)//strip_quotes(i+1:) + else ; strip_quotes = strip_quotes(2:) ; endif + i = index(strip_quotes,ACHAR(39)) ! Single quote + enddo +end function strip_quotes + +!> This function returns the maximum number of characters in any input lines after they +!! have been combined by any line continuation. +function max_input_line_length(CS, pf_num) result(max_len) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + integer, optional, intent(in) :: pf_num !< If present, only work on a single file in the + !! param_file_type, or return 0 if this exceeds the + !! number of files in the param_file_type. + integer :: max_len !< The maximum number of characters in any input lines after they + !! have been combined by any line continuation. + + ! Local variables + character(len=FILENAME_LENGTH) :: filename + character :: last_char + integer :: ipf, ipf_s, ipf_e + integer :: last, line_len, count, contBufSize + logical :: continuedLine + + max_len = 0 + ipf_s = 1 ; ipf_e = CS%nfiles + if (present(pf_num)) then + if (pf_num > CS%nfiles) return + ipf_s = pf_num ; ipf_e = pf_num + endif + + paramfile_loop: do ipf = ipf_s, ipf_e + filename = CS%filename(ipf) + contBufSize = 0 + continuedLine = .false. + + ! Scan through each line of the file + do count = 1, CS%param_data(ipf)%num_lines + ! line = CS%param_data(ipf)%fln(count)%line + last = len_trim(CS%param_data(ipf)%fln(count)%line) + last_char = " " + if (last > 0) last_char = CS%param_data(ipf)%fln(count)%line(last:last) + ! Check if line ends in continuation character (either & or \) + ! Note achar(92) is a backslash + if (last_char == achar(92) .or. last_char == "&") then + contBufSize = contBufSize + last - 1 + continuedLine = .true. + if (count==CS%param_data(ipf)%num_lines .and. is_root_pe()) & + call MOM_error(FATAL, "MOM_file_parser : the last line of the file ends in a"// & + " continuation character but there are no more lines to read. "// & + " Line: '"//trim(CS%param_data(ipf)%fln(count)%line(:last))//"'"// & + " in file "//trim(filename)//".") + cycle ! cycle inorder to append the next line of the file + elseif (continuedLine) then + ! If we reached this point then this is the end of line continuation + line_len = contBufSize + last + contBufSize = 0 + continuedLine = .false. + else ! This is a simple line with no continuation. + line_len = last + endif + max_len = max(max_len, line_len) + enddo ! CS%param_data(ipf)%num_lines + enddo paramfile_loop + +end function max_input_line_length + +!> This subroutine extracts the contents of lines in the param_file_type that refer to +!! a named parameter. The value_string that is returned must be interepreted in a way +!! that depends on the type of this variable. +subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsLogical) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + logical, intent(out) :: found !< If true, this parameter has been found in CS + logical, intent(out) :: defined !< If true, this parameter is set (or true) in the CS + character(len=*), intent(out) :: value_string(:) !< A string that encodes the new value + logical, optional, intent(in) :: paramIsLogical !< If true, this is a logical parameter + !! that can be simply defined without parsing a value_string. + + ! Local variables + character(len=CS%max_line_len) :: val_str, lname, origLine + character(len=CS%max_line_len) :: line, continuationBuffer + character(len=240) :: blockName + character(len=FILENAME_LENGTH) :: filename + integer :: is, id, isd, isu, ise, iso, ipf + integer :: last, last1, ival, oval, max_vals, count, contBufSize + character(len=52) :: set + logical :: found_override, found_equals + logical :: found_define, found_undef + logical :: force_cycle, defined_in_line, continuedLine + logical :: variableKindIsLogical, valueIsSame + logical :: inWrongBlock, fullPathParameter + logical, parameter :: requireNamedClose = .false. + integer, parameter :: verbose = 1 + set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" + continuationBuffer = repeat(" ", CS%max_line_len) + contBufSize = 0 + + variableKindIsLogical=.false. + if (present(paramIsLogical)) variableKindIsLogical = paramIsLogical + + ! Find the first instance (if any) where the named variable is found, and + ! return variables indicating whether this variable is defined and the string + ! that contains the value of this variable. + found = .false. + oval = 0; ival = 0 + max_vals = SIZE(value_string) + do is=1,max_vals ; value_string(is) = " " ; enddo + + paramfile_loop: do ipf = 1, CS%nfiles + filename = CS%filename(ipf) + continuedLine = .false. + blockName = '' + + ! Scan through each line of the file + do count = 1, CS%param_data(ipf)%num_lines + line = CS%param_data(ipf)%fln(count)%line + last = len_trim(line) + + last1 = max(1,last) + ! Check if line ends in continuation character (either & or \) + ! Note achar(92) is a backslash + if (line(last1:last1) == achar(92).or.line(last1:last1) == "&") then + continuationBuffer(contBufSize+1:contBufSize+len_trim(line))=line(:last-1) + contBufSize=contBufSize + len_trim(line)-1 + continuedLine = .true. + if (count==CS%param_data(ipf)%num_lines .and. is_root_pe()) & + call MOM_error(FATAL, "MOM_file_parser : the last line"// & + " of the file ends in a continuation character but"// & + " there are no more lines to read. "// & + " Line: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//".") + cycle ! cycle inorder to append the next line of the file + elseif (continuedLine) then + ! If we reached this point then this is the end of line continuation + continuationBuffer(contBufSize+1:contBufSize+len_trim(line))=line(:last) + line = continuationBuffer + continuationBuffer=repeat(" ",CS%max_line_len) ! Clear for next use + contBufSize = 0 + continuedLine = .false. + last = len_trim(line) + endif + + origLine = trim(line) ! Keep original for error messages + + ! Check for '#override' at start of line + found_override = .false.; found_define = .false.; found_undef = .false. + iso = index(line(:last), "#override " )!; if (is > 0) found_override = .true. + if (iso>1) call MOM_error(FATAL, "MOM_file_parser : #override was found "// & + " but was not the first keyword."// & + " Line: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//".") + if (iso==1) then + found_override = .true. + if (index(line(:last), "#override define ")==1) found_define = .true. + if (index(line(:last), "#override undef ")==1) found_undef = .true. + line = trim(adjustl(line(iso+10:last))); last = len_trim(line) + endif + + ! Newer form of parameter block, block%, %block or block%param or + iso=index(line(:last),'%') + fullPathParameter = .false. + if (iso==1) then ! % is first character means this is a close + if (len_trim(blockName)==0 .and. is_root_pe()) call MOM_error(FATAL, & + 'get_variable_line: An extra close block was encountered. Line="'// & + trim(line(:last))//'"' ) + if (last>1 .and. trim(blockName)/=trim(line(2:last)) .and. is_root_pe()) & + call MOM_error(FATAL, 'get_variable_line: A named close for a parameter'// & + ' block did not match the open block. Line="'//trim(line(:last))//'"' ) + if (last==1 .and. requireNamedClose) & ! line = '%' is a generic (unnamed) close + call MOM_error(FATAL, 'get_variable_line: A named close for a parameter'// & + ' block is required but found "%". Block="'//trim(blockName)//'"' ) + blockName = popBlockLevel(blockName) + call flag_line_as_read(CS%param_data(ipf)%line_used,count) + elseif (iso==last) then ! This is a new block if % is last character + blockName = pushBlockLevel(blockName, line(:iso-1)) + call flag_line_as_read(CS%param_data(ipf)%line_used,count) + else ! This is of the form block%parameter = ... (full path parameter) + iso=index(line(:last),'%',.true.) + ! Check that the parameter block names on the line matches the state set by the caller + if (iso>0 .and. trim(CS%blockName%name)==trim(line(:iso-1))) then + fullPathParameter = .true. + line = trim(line(iso+1:last)) ! Strip away the block name for subsequent processing + last = len_trim(line) + endif + endif + + ! We should only interpret this line if this block is the active block + inWrongBlock = .false. + if (len_trim(blockName)>0) then ! In a namelist block in file + if (trim(CS%blockName%name)/=trim(blockName)) inWrongBlock = .true. ! Not in the required block + endif + if (len_trim(CS%blockName%name)>0) then ! In a namelist block in the model + if (trim(CS%blockName%name)/=trim(blockName)) inWrongBlock = .true. ! Not in the required block + endif + + if (inWrongBlock .and. .not. fullPathParameter) then + if (index(" "//line(:last+1), " "//trim(varname)//" ")>0) & + call MOM_error(WARNING,"MOM_file_parser : "//trim(varname)// & + ' found outside of block '//trim(CS%blockName%name)//'%. Ignoring.') + cycle + endif + + ! Determine whether this line mentions the named parameter or not + if (index(" "//line(:last)//" ", " "//trim(varname)//" ") == 0) cycle + + ! Detect keywords + found_equals = .false. + isd = index(line(:last), "define" )!; if (isd > 0) found_define = .true. + isu = index(line(:last), "undef" )!; if (isu > 0) found_undef = .true. + ise = index(line(:last), " = " ); if (ise > 1) found_equals = .true. + if (index(line(:last), "#define ")==1) found_define = .true. + if (index(line(:last), "#undef ")==1) found_undef = .true. + + ! Check for missing, mutually exclusive or incomplete keywords + if (.not. (found_define .or. found_undef .or. found_equals)) then + if (found_override) then + call MOM_error(FATAL, "MOM_file_parser : override was found " // & + " without a define or undef." // & + " Line: '" // trim(line(:last)) // "'" // & + " in file " // trim(filename) // ".") + else + call MOM_error(FATAL, "MOM_file_parser : the parameter name '" // & + trim(varname) // "' was found without define or undef." // & + " Line: '" // trim(line(:last)) // "'" // & + " in file " // trim(filename) // ".") + endif + endif + + if (found_equals .and. (found_define .or. found_undef)) & + call MOM_error(FATAL, & + "MOM_file_parser : Both 'a=b' and 'undef/define' syntax occur."// & + " Line: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//".") + + ! Interpret the line and collect values, if any + ! NOTE: At least one of these must be true + if (found_define) then + ! Move starting pointer to first letter of defined name. + is = isd + 5 + scan(line(isd+6:last), set) + + id = scan(line(is:last), ' ') ! Find space between name and value + if ( id == 0 ) then + ! There is no space so the name is simply being defined. + lname = trim(line(is:last)) + if (trim(lname) /= trim(varname)) cycle + val_str = " " + else + ! There is a string or number after the name. + lname = trim(line(is:is+id-1)) + if (trim(lname) /= trim(varname)) cycle + val_str = trim(adjustl(line(is+id:last))) + endif + found = .true. ; defined_in_line = .true. + elseif (found_undef) then + ! Move starting pointer to first letter of undefined name. + is = isu + 4 + scan(line(isu+5:last), set) + + id = scan(line(is:last), ' ') ! Find the first space after the name. + if (id > 0) last = is + id - 1 + lname = trim(line(is:last)) + if (trim(lname) /= trim(varname)) cycle + val_str = " " + found = .true. ; defined_in_line = .false. + elseif (found_equals) then + ! Move starting pointer to first letter of defined name. + is = scan(line(1:ise), set) + lname = trim(line(is:ise-1)) + if (trim(lname) /= trim(varname)) cycle + val_str = trim(adjustl(line(ise+3:last))) + if (variableKindIsLogical) then ! Special handling for logicals + read(val_str(:len_trim(val_str)),*) defined_in_line + else + defined_in_line = .true. + endif + found = .true. + endif + + ! This line has now been used. + call flag_line_as_read(CS%param_data(ipf)%line_used,count) + + ! Detect inconsistencies + force_cycle = .false. + valueIsSame = (trim(val_str) == trim(value_string(max_vals))) + if (found_override .and. (oval >= max_vals)) then + if (is_root_pe()) then + if ((defined_in_line .neqv. defined) .or. .not. valueIsSame) then + call MOM_error(FATAL,"MOM_file_parser : "//trim(varname)// & + " found with multiple inconsistent overrides."// & + " Line A: '"//trim(value_string(max_vals))//"'"//& + " Line B: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//" caused the model failure.") + else + call MOM_error(WARNING,"MOM_file_parser : "//trim(varname)// & + " over-ridden more times than is permitted."// & + " Line: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//" is being ignored.") + endif + endif + force_cycle = .true. + endif + if (.not.found_override .and. (oval > 0)) then + if (is_root_pe()) & + call MOM_error(WARNING,"MOM_file_parser : "//trim(varname)// & + " has already been over-ridden."// & + " Line: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//" is being ignored.") + force_cycle = .true. + endif + if (.not.found_override .and. (ival >= max_vals)) then + if (is_root_pe()) then + if ((defined_in_line .neqv. defined) .or. .not. valueIsSame) then + call MOM_error(FATAL,"MOM_file_parser : "//trim(varname)// & + " found with multiple inconsistent definitions."// & + " Line A: '"//trim(value_string(max_vals))//"'"//& + " Line B: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//" caused the model failure.") + else + call MOM_error(WARNING,"MOM_file_parser : "//trim(varname)// & + " occurs more times than is permitted."// & + " Line: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//" is being ignored.") + endif + endif + force_cycle = .true. + endif + if (force_cycle) cycle + + ! Store new values + if (found_override) then + oval = oval + 1 + value_string(oval) = trim(val_str) + defined = defined_in_line + if (verbose > 0 .and. ival > 0 .and. is_root_pe() .and. & + .not. overrideWarningHasBeenIssued(CS%chain, trim(varname)) ) & + call MOM_error(WARNING,"MOM_file_parser : "//trim(varname)// & + " over-ridden. Line: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//".") + else ! (.not. found_overide) + ival = ival + 1 + value_string(ival) = trim(val_str) + defined = defined_in_line + + if (verbose > 1 .and. is_root_pe()) & + call MOM_error(WARNING,"MOM_file_parser : "//trim(varname)// & + " set. Line: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//".") + endif + + enddo ! CS%param_data(ipf)%num_lines + + if (len_trim(blockName)>0 .and. is_root_pe()) call MOM_error(FATAL, & + 'A namelist/parameter block was not closed. Last open block appears '// & + 'to be "'//trim(blockName)//'".') + + enddo paramfile_loop + +end subroutine get_variable_line + +!> Record that a line has been used to set a parameter +subroutine flag_line_as_read(line_used, count) + logical, dimension(:), pointer :: line_used !< A structure indicating which lines have been read + integer, intent(in) :: count !< The parameter on this line number has been read + line_used(count) = .true. +end subroutine flag_line_as_read + +!> Returns true if an override warning has been issued for the variable varName +function overrideWarningHasBeenIssued(chain, varName) + type(link_parameter), pointer :: chain !< The linked list of variables that have already had + !! override warnings issued + character(len=*), intent(in) :: varName !< The name of the variable being queried for warnings + logical :: overrideWarningHasBeenIssued + ! Local variables + type(link_parameter), pointer :: newLink => NULL(), this => NULL() + + overrideWarningHasBeenIssued = .false. + this => chain + do while( associated(this) ) + if (trim(varName) == trim(this%name)) then + overrideWarningHasBeenIssued = .true. + return + endif + this => this%next + enddo + allocate(newLink) + newLink%name = trim(varName) + newLink%hasIssuedOverrideWarning = .true. + newLink%next => chain + chain => newLink +end function overrideWarningHasBeenIssued + +! The following subroutines write out to a log file. + +!> Log the version of a module to a log file and/or stdout, and/or to the +!! parameter documentation file. +subroutine log_version_cs(CS, modulename, version, desc, log_to_all, all_default, layout, debugging) + type(param_file_type), intent(in) :: CS !< File parser type + character(len=*), intent(in) :: modulename !< Name of calling module + character(len=*), intent(in) :: version !< Version string of module + character(len=*), optional, intent(in) :: desc !< Module description + logical, optional, intent(in) :: log_to_all !< If present and true, log this parameter to the + !! ..._doc.all files, even if this module also has layout + !! or debugging parameters. + logical, optional, intent(in) :: all_default !< If true, all parameters take their default values. + logical, optional, intent(in) :: layout !< If present and true, this module has layout parameters. + logical, optional, intent(in) :: debugging !< If present and true, this module has debugging parameters. + ! Local variables + character(len=240) :: mesg + + mesg = trim(modulename)//": "//trim(version) + if (is_root_pe()) then + if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) + if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) + endif + + if (present(desc)) call doc_module(CS%doc, modulename, desc, log_to_all, all_default, layout, debugging) + +end subroutine log_version_cs + +!> Log the version of a module to a log file and/or stdout. +subroutine log_version_plain(modulename, version) + character(len=*), intent(in) :: modulename !< Name of calling module + character(len=*), intent(in) :: version !< Version string of module + ! Local variables + character(len=240) :: mesg + + mesg = trim(modulename)//": "//trim(version) + if (is_root_pe()) then + write(stdlog(),'(a)') trim(mesg) + endif + +end subroutine log_version_plain + +!> Log the name and value of an integer model parameter in documentation files. +subroutine log_param_int(CS, modulename, varname, value, desc, units, & + default, layoutParam, debuggingParam, like_default) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the module using this parameter + character(len=*), intent(in) :: varname !< The name of the parameter to log + integer, intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + integer, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. + + character(len=240) :: mesg, myunits + + write(mesg, '(" ",a," ",a,": ",a)') trim(modulename), trim(varname), trim(left_int(value)) + if (is_root_pe()) then + if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) + if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) + endif + + myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) + if (present(desc)) & + call doc_param(CS%doc, varname, desc, myunits, value, default, & + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) + +end subroutine log_param_int + +!> Log the name and values of an array of integer model parameter in documentation files. +subroutine log_param_int_array(CS, modulename, varname, value, desc, & + units, default, layoutParam, debuggingParam, like_default) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the module using this parameter + character(len=*), intent(in) :: varname !< The name of the parameter to log + integer, dimension(:), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + integer, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. + + character(len=CS%max_line_len+120) :: mesg + character(len=240) :: myunits + + write(mesg, '(" ",a," ",a,": ",A)') trim(modulename), trim(varname), trim(left_ints(value)) + if (is_root_pe()) then + if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) + if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) + endif + + myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) + if (present(desc)) & + call doc_param(CS%doc, varname, desc, myunits, value, default, & + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) + +end subroutine log_param_int_array + +!> Log the name and value of a real model parameter in documentation files. +subroutine log_param_real(CS, modulename, varname, value, desc, units, & + default, debuggingParam, like_default, unscale) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + real, intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. + real, optional, intent(in) :: unscale !< A reciprocal scaling factor that the parameter is + !! multiplied by before it is logged + + real :: log_val ! The parameter value that is written out + character(len=240) :: mesg, myunits + + log_val = value ; if (present(unscale)) log_val = unscale * value + + write(mesg, '(" ",a," ",a,": ",a)') & + trim(modulename), trim(varname), trim(left_real(log_val)) + if (is_root_pe()) then + if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) + if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) + endif + + write(myunits(1:240),'(A)') trim(units) + if (present(desc)) & + call doc_param(CS%doc, varname, desc, myunits, log_val, default, & + debuggingParam=debuggingParam, like_default=like_default) + +end subroutine log_param_real + +!> Log the name and values of an array of real model parameter in documentation files. +subroutine log_param_real_array(CS, modulename, varname, value, desc, & + units, default, debuggingParam, like_default, unscale) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + real, dimension(:), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. + real, optional, intent(in) :: unscale !< A reciprocal scaling factor that the parameter is + !! multiplied by before it is logged + + real, dimension(size(value)) :: log_val ! The array of parameter values that is written out + character(len=:), allocatable :: mesg + character(len=240) :: myunits + + log_val(:) = value(:) ; if (present(unscale)) log_val(:) = unscale * value(:) + + !write(mesg, '(" ",a," ",a,": ",ES19.12,99(",",ES19.12))') & + !write(mesg, '(" ",a," ",a,": ",G,99(",",G))') & + ! trim(modulename), trim(varname), value + mesg = " " // trim(modulename) // " " // trim(varname) // ": " // trim(left_reals(log_val)) + if (is_root_pe()) then + if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) + if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) + endif + + write(myunits(1:240),'(A)') trim(units) + if (present(desc)) & + call doc_param(CS%doc, varname, desc, myunits, log_val, default, & + debuggingParam=debuggingParam, like_default=like_default) + +end subroutine log_param_real_array + +!> Log the name and value of a logical model parameter in documentation files. +subroutine log_param_logical(CS, modulename, varname, value, desc, & + units, default, layoutParam, debuggingParam, like_default) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + logical, intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + logical, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. + + character(len=240) :: mesg, myunits + + if (value) then + write(mesg, '(" ",a," ",a,": True")') trim(modulename), trim(varname) + else + write(mesg, '(" ",a," ",a,": False")') trim(modulename), trim(varname) + endif + if (is_root_pe()) then + if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) + if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) + endif + + myunits="Boolean"; if (present(units)) write(myunits(1:240),'(A)') trim(units) + if (present(desc)) & + call doc_param(CS%doc, varname, desc, myunits, value, default, & + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) + +end subroutine log_param_logical + +!> Log the name and value of a character string model parameter in documentation files. +subroutine log_param_char(CS, modulename, varname, value, desc, units, & + default, layoutParam, debuggingParam, like_default) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + character(len=*), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. + + character(len=:), allocatable :: mesg + character(len=240) :: myunits + + mesg = " " // trim(modulename) // " " // trim(varname) // ": " // trim(value) + if (is_root_pe()) then + if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) + if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) + endif + + myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) + if (present(desc)) & + call doc_param(CS%doc, varname, desc, myunits, value, default, & + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) + +end subroutine log_param_char + +!> This subroutine writes the value of a time-type parameter to a log file, +!! along with its name and the module it came from. +subroutine log_param_time(CS, modulename, varname, value, desc, units, & + default, timeunit, layoutParam, debuggingParam, log_date, like_default) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + type(time_type), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + type(time_type), optional, intent(in) :: default !< The default value of the parameter + real, optional, intent(in) :: timeunit !< The number of seconds in a time unit for + !! real-number output. + logical, optional, intent(in) :: log_date !< If true, log the time_type in date format. + !! If missing the default is false. + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. + + ! Local variables + real :: real_time, real_default + logical :: use_timeunit, date_format + character(len=240) :: mesg, myunits + character(len=80) :: date_string, default_string + integer :: days, secs, ticks + + use_timeunit = .false. + date_format = .false. ; if (present(log_date)) date_format = log_date + + call get_time(value, secs, days, ticks) + + if (ticks == 0) then + write(mesg, '(" ",a," ",a," (Time): ",i0,":",i0)') trim(modulename), & + trim(varname), days, secs + else + write(mesg, '(" ",a," ",a," (Time): ",i0,":",i0,":",i0)') trim(modulename), & + trim(varname), days, secs, ticks + endif + if (is_root_pe()) then + if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) + if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) + endif + + if (present(desc)) then + if (present(timeunit)) use_timeunit = (timeunit > 0.0) + if (date_format) then + myunits='[date]' + + date_string = convert_date_to_string(value) + if (present(default)) then + default_string = convert_date_to_string(default) + call doc_param(CS%doc, varname, desc, myunits, date_string, & + default=default_string, layoutParam=layoutParam, & + debuggingParam=debuggingParam, like_default=like_default) + else + call doc_param(CS%doc, varname, desc, myunits, date_string, & + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) + endif + elseif (use_timeunit) then + if (present(units)) then + write(myunits(1:240),'(A)') trim(units) + else + if (abs(timeunit-1.0) < 0.01) then ; myunits = "seconds" + elseif (abs(timeunit-3600.0) < 1.0) then ; myunits = "hours" + elseif (abs(timeunit-86400.0) < 1.0) then ; myunits = "days" + elseif (abs(timeunit-3.1e7) < 1.0e6) then ; myunits = "years" + else ; write(myunits,'(es8.2," sec")') timeunit ; endif + endif + real_time = (86400.0/timeunit)*days + secs/timeunit + if (ticks > 0) real_time = real_time + & + real(ticks) / (timeunit*get_ticks_per_second()) + if (present(default)) then + call get_time(default, secs, days, ticks) + real_default = (86400.0/timeunit)*days + secs/timeunit + if (ticks > 0) real_default = real_default + & + real(ticks) / (timeunit*get_ticks_per_second()) + call doc_param(CS%doc, varname, desc, myunits, real_time, real_default, like_default=like_default) + else + call doc_param(CS%doc, varname, desc, myunits, real_time, like_default=like_default) + endif + else + call doc_param(CS%doc, varname, desc, value, default, units=units, like_default=like_default) + endif + endif + +end subroutine log_param_time + +!> This function converts a date into a string, valid with ticks and for dates up to year 99,999,999 +function convert_date_to_string(date) result(date_string) + type(time_type), intent(in) :: date !< The date to be translated into a string. + character(len=40) :: date_string !< A date string in a format like YYYY-MM-DD HH:MM:SS.sss + + ! Local variables + character(len=40) :: sub_string + real :: real_secs + integer :: yrs, mons, days, hours, mins, secs, ticks, ticks_per_sec + + call get_date(date, yrs, mons, days, hours, mins, secs, ticks) + write (date_string, '(i8.4)') yrs + write (sub_string, '("-", i2.2, "-", I2.2, " ", i2.2, ":", i2.2, ":")') & + mons, days, hours, mins + date_string = trim(adjustl(date_string)) // trim(sub_string) + if (ticks > 0) then + ticks_per_sec = get_ticks_per_second() + real_secs = secs + ticks/ticks_per_sec + if (ticks_per_sec <= 100) then + write (sub_string, '(F7.3)') real_secs + else + write (sub_string, '(F10.6)') real_secs + endif + else + write (sub_string, '(i2.2)') secs + endif + date_string = trim(date_string) // trim(adjustl(sub_string)) + +end function convert_date_to_string + +!> This subroutine reads the value of an integer model parameter from a parameter file +!! and logs it in documentation files. +subroutine get_param_int(CS, modulename, varname, value, desc, units, & + default, fail_if_missing, do_not_read, do_not_log, & + layoutParam, debuggingParam) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + integer, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + + logical :: do_read, do_log + + do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read + do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log + + if (do_read) then + if (present(default)) value = default + call read_param_int(CS, varname, value, fail_if_missing) + endif + + if (do_log) then + call log_param_int(CS, modulename, varname, value, desc, units, & + default, layoutParam, debuggingParam) + endif + +end subroutine get_param_int + +!> This subroutine reads the values of an array of integer model parameters from a parameter file +!! and logs them in documentation files. +subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & + default, fail_if_missing, do_not_read, do_not_log, & + layoutParam, debuggingParam) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, dimension(:), intent(inout) :: value !< The value of the parameter that may be reset + !! from the parameter file + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + integer, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + + logical :: do_read, do_log + + do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read + do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log + + if (do_read) then + if (present(default)) value(:) = default + call read_param_int_array(CS, varname, value, fail_if_missing) + endif + + if (do_log) then + call log_param_int_array(CS, modulename, varname, value, desc, & + units, default, layoutParam, debuggingParam) + endif + +end subroutine get_param_int_array + +!> This subroutine reads the value of a real model parameter from a parameter file +!! and logs it in documentation files. +subroutine get_param_real(CS, modulename, varname, value, desc, units, & + default, fail_if_missing, do_not_read, do_not_log, & + debuggingParam, scale, unscaled) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + real, optional, intent(in) :: scale !< A scaling factor that the parameter is + !! multiplied by before it is returned. + real, optional, intent(out) :: unscaled !< The value of the parameter that would be + !! returned without any multiplication by a scaling factor. + + logical :: do_read, do_log + + do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read + do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log + + if (do_read) then + if (present(default)) value = default + call read_param_real(CS, varname, value, fail_if_missing) + endif + + if (do_log) then + call log_param_real(CS, modulename, varname, value, desc, units, & + default, debuggingParam) + endif + + if (present(unscaled)) unscaled = value + if (present(scale)) value = scale*value + +end subroutine get_param_real + +!> This subroutine reads the values of an array of real model parameters from a parameter file +!! and logs them in documentation files. +subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & + default, fail_if_missing, do_not_read, do_not_log, debuggingParam, & + scale, unscaled) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + real, optional, intent(in) :: scale !< A scaling factor that the parameter is + !! multiplied by before it is returned. + real, dimension(:), optional, intent(out) :: unscaled !< The value of the parameter that would be + !! returned without any multiplication by a scaling factor. + + logical :: do_read, do_log + + do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read + do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log + + if (do_read) then + if (present(default)) value(:) = default + call read_param_real_array(CS, varname, value, fail_if_missing) + endif + + if (do_log) then + call log_param_real_array(CS, modulename, varname, value, desc, & + units, default, debuggingParam) + endif + + if (present(unscaled)) unscaled(:) = value(:) + if (present(scale)) value(:) = scale*value(:) + +end subroutine get_param_real_array + +!> This subroutine reads the value of a character string model parameter from a parameter file +!! and logs it in documentation files. +subroutine get_param_char(CS, modulename, varname, value, desc, units, & + default, fail_if_missing, do_not_read, do_not_log, & + layoutParam, debuggingParam) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + + logical :: do_read, do_log + + do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read + do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log + + if (do_read) then + if (present(default)) value = default + call read_param_char(CS, varname, value, fail_if_missing) + endif + + if (do_log) then + call log_param_char(CS, modulename, varname, value, desc, units, & + default, layoutParam, debuggingParam) + endif + +end subroutine get_param_char + +!> This subroutine reads the values of an array of character string model parameters +!! from a parameter file and logs them in documentation files. +subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & + default, fail_if_missing, do_not_read, do_not_log) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + + ! Local variables + logical :: do_read, do_log + integer :: i, len_tot, len_val + character(len=:), allocatable :: cat_val + + do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read + do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log + + if (do_read) then + if (present(default)) value(:) = default + call read_param_char_array(CS, varname, value, fail_if_missing) + endif + + if (do_log) then + cat_val = trim(value(1)) ; len_tot = len_trim(value(1)) + do i=2,size(value) + len_val = len_trim(value(i)) + if ((len_val > 0) .and. (len_tot + len_val + 2 < 240)) then + cat_val = trim(cat_val)//ACHAR(34)// ", "//ACHAR(34)//trim(value(i)) + len_tot = len_tot + len_val + endif + enddo + call log_param_char(CS, modulename, varname, cat_val, desc, & + units, default) + endif + +end subroutine get_param_char_array + +!> This subroutine reads the value of a logical model parameter from a parameter file +!! and logs it in documentation files. +subroutine get_param_logical(CS, modulename, varname, value, desc, units, & + default, fail_if_missing, do_not_read, do_not_log, & + layoutParam, debuggingParam) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + logical, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + logical, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + + logical :: do_read, do_log + + do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read + do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log + + if (do_read) then + if (present(default)) value = default + call read_param_logical(CS, varname, value, fail_if_missing) + endif + + if (do_log) then + call log_param_logical(CS, modulename, varname, value, desc, & + units, default, layoutParam, debuggingParam) + endif + +end subroutine get_param_logical + +!> This subroutine reads the value of a time-type model parameter from a parameter file +!! and logs it in documentation files. +subroutine get_param_time(CS, modulename, varname, value, desc, units, & + default, fail_if_missing, do_not_read, do_not_log, & + timeunit, layoutParam, debuggingParam, & + log_as_date) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + type(time_type), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + type(time_type), optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + real, optional, intent(in) :: timeunit !< The number of seconds in a time unit for + !! real-number input to be translated to a time. + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical, optional, intent(in) :: log_as_date !< If true, log the time_type in date + !! format. The default is false. + + logical :: do_read, do_log, log_date + + do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read + do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log + log_date = .false. + + if (do_read) then + if (present(default)) value = default + call read_param_time(CS, varname, value, timeunit, fail_if_missing, date_format=log_date) + endif + + if (do_log) then + if (present(log_as_date)) log_date = log_as_date + call log_param_time(CS, modulename, varname, value, desc, units, default, & + timeunit, layoutParam=layoutParam, & + debuggingParam=debuggingParam, log_date=log_date) + endif + +end subroutine get_param_time + +! ----------------------------------------------------------------------------- + +!> Resets the parameter block name to blank +subroutine clearParameterBlock(CS) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + + type(parameter_block), pointer :: block => NULL() + if (associated(CS%blockName)) then + block => CS%blockName + block%name = '' + else + if (is_root_pe()) call MOM_error(FATAL, & + 'clearParameterBlock: A clear was attempted before allocation.') + endif +end subroutine clearParameterBlock + +!> Tags blockName onto the end of the active parameter block name +subroutine openParameterBlock(CS, blockName, desc, do_not_log) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: blockName !< The name of a parameter block being added + character(len=*), optional, intent(in) :: desc !< A description of the parameter block being added + logical, optional, intent(in) :: do_not_log + !< Log block entry if true. This only prevents logging of entry to the block, and not the contents. + + type(parameter_block), pointer :: block => NULL() + logical :: do_log + + do_log = .true. + if (present(do_not_log)) do_log = .not. do_not_log + + if (associated(CS%blockName)) then + block => CS%blockName + block%name = pushBlockLevel(block%name,blockName) + if (do_log) then + call doc_openBlock(CS%doc, block%name, desc) + block%log_access = .true. + else + block%log_access = .false. + endif + else + if (is_root_pe()) call MOM_error(FATAL, & + 'openParameterBlock: A push was attempted before allocation.') + endif +end subroutine openParameterBlock + +!> Remove the lowest level of recursion from the active block name +subroutine closeParameterBlock(CS) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + + type(parameter_block), pointer :: block => NULL() + + if (associated(CS%blockName)) then + block => CS%blockName + if (is_root_pe().and.len_trim(block%name)==0) call MOM_error(FATAL, & + 'closeParameterBlock: A pop was attempted on an empty stack. ("'//& + trim(block%name)//'")') + if (block%log_access) call doc_closeBlock(CS%doc, block%name) + else + if (is_root_pe()) call MOM_error(FATAL, & + 'closeParameterBlock: A pop was attempted before allocation.') + endif + block%name = popBlockLevel(block%name) +end subroutine closeParameterBlock + +!> Extends block name (deeper level of parameter block) +function pushBlockLevel(oldblockName,newBlockName) + character(len=*), intent(in) :: oldBlockName !< A sequence of hierarchical parameter block names + character(len=*), intent(in) :: newBlockName !< A new block name to add to the end of the sequence + character(len=len(oldBlockName)+40) :: pushBlockLevel + + if (len_trim(oldBlockName)>0) then + pushBlockLevel=trim(oldBlockName)//'%'//trim(newBlockName) + else + pushBlockLevel=trim(newBlockName) + endif +end function pushBlockLevel + +!> Truncates block name (shallower level of parameter block) +function popBlockLevel(oldblockName) + character(len=*), intent(in) :: oldBlockName !< A sequence of hierarchical parameter block names + character(len=len(oldBlockName)+40) :: popBlockLevel + + integer :: i + i = index(trim(oldBlockName), '%', .true.) + if (i>1) then + popBlockLevel = trim(oldBlockName(1:i-1)) + elseif (i==0) then + popBlockLevel = '' + else ! i==1 + if (is_root_pe()) call MOM_error(FATAL, & + 'popBlockLevel: A pop was attempted leaving an empty block name.') + endif +end function popBlockLevel + +!> \namespace mom_file_parser +!! +!! By Robert Hallberg and Alistair Adcroft, updated 9/2013. +!! +!! The subroutines here parse a set of input files for the value +!! a named parameter and sets that parameter at run time. Currently +!! these files use use one of several formats: +!! \#define VAR ! To set the logical VAR to true. +!! VAR = True ! To set the logical VAR to true. +!! \#undef VAR ! To set the logical VAR to false. +!! VAR = False ! To set the logical VAR to false. +!! \#define VAR 999 ! To set the real or integer VAR to 999. +!! VAR = 999 ! To set the real or integer VAR to 999. +!! \#override VAR = 888 ! To override a previously set value. +!! VAR = 1.1, 2.2, 3.3 ! To set an array of real values. + ! Note that in the comments above, dOxygen translates \# to # . +!! +!! In addition, when set by the get_param interface, the values of +!! parameters are automatically logged, along with defaults, units, +!! and a description. It is an error for a variable to be overridden +!! more than once, and MOM6 has a facility to check for unused lines +!! to set variables, which may indicate miss-spelled or archaic +!! parameters. Parameter names are case-specific, and lines may use +!! a F90 or C++ style comment, starting with ! or //. + +end module MOM_file_parser diff --git a/framework/MOM_get_input.F90 b/framework/MOM_get_input.F90 new file mode 100644 index 0000000000..6ecc3ef3f9 --- /dev/null +++ b/framework/MOM_get_input.F90 @@ -0,0 +1,132 @@ +!> \brief Reads the only Fortran name list needed to boot-strap the model. +!! +!! The name list parameters indicate which directories to use for +!! certain types of input and output, and which files to look in for +!! the full parsable input parameter file(s). +module MOM_get_input + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : open_param_file, param_file_type +use MOM_io, only : file_exists, close_file, slasher, ensembler +use MOM_io, only : open_namelist_file, check_nml_error +use posix, only : mkdir, stat, stat_buf + +implicit none ; private + +public get_MOM_input + +!> Container for paths and parameter file names. +type, public :: directories + character(len=240) :: & + restart_input_dir = ' ',& !< The directory to read restart and input files. + restart_output_dir = ' ',&!< The directory into which to write restart files. + output_directory = ' ' !< The directory to use to write the model output. + character(len=2048) :: & + input_filename = ' ' !< A string that indicates the input files or how + !! the run segment should be started. +end type directories + +contains + +!> Get the names of the I/O directories and initialization file. +!! Also calls the subroutine that opens run-time parameter files. +subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, ensemble_num) + type(param_file_type), optional, intent(out) :: param_file !< A structure to parse for run-time parameters. + type(directories), optional, intent(out) :: dirs !< Container for paths and parameter file names. + logical, optional, intent(in) :: check_params !< If present and False will stop error checking for + !! run-time parameters. + character(len=*), optional, intent(in) :: default_input_filename !< If present, is the value assumed for + !! input_filename if input_filename is not listed + !! in the namelist MOM_input_nml. + integer, optional, intent(in) :: ensemble_num !< The ensemble id of the current member + ! Local variables + integer, parameter :: npf = 5 ! Maximum number of parameter files + + character(len=240) :: & + parameter_filename(npf), & ! List of files containing parameters. + output_directory, & ! Directory to use to write the model output. + restart_input_dir, & ! Directory for reading restart and input files. + restart_output_dir ! Directory into which to write restart files. + character(len=2048) :: & + input_filename ! A string that indicates the input files or how + ! the run segment should be started. + character(len=240) :: output_dir + integer :: unit, io, ierr, valid_param_files + + type(stat_buf) :: buf + + namelist /MOM_input_nml/ output_directory, input_filename, parameter_filename, & + restart_input_dir, restart_output_dir + + ! Default values in case parameter is not set in file input.nml + parameter_filename(:) = ' ' + output_directory = ' ' + restart_input_dir = ' ' + restart_output_dir = ' ' + input_filename = ' ' + if (present(default_input_filename)) input_filename = trim(default_input_filename) + + ! Open namelist + if (file_exists('input.nml')) then + unit = open_namelist_file(file='input.nml') + else + call MOM_error(FATAL,'Required namelist file input.nml does not exist.') + endif + + ! Read namelist parameters + ! NOTE: Every rank is reading MOM_input_nml + ierr=1 ; do while (ierr /= 0) + read(unit, nml=MOM_input_nml, iostat=io, end=10) + ierr = check_nml_error(io, 'MOM_input_nml') + enddo +10 call close_file(unit) + + ! Store parameters in container + if (present(dirs)) then + if (present(ensemble_num)) then + dirs%output_directory = slasher(ensembler(output_directory,ensemble_num)) + dirs%restart_output_dir = slasher(ensembler(restart_output_dir,ensemble_num)) + dirs%restart_input_dir = slasher(ensembler(restart_input_dir,ensemble_num)) + dirs%input_filename = ensembler(input_filename,ensemble_num) + else + dirs%output_directory = slasher(ensembler(output_directory)) + dirs%restart_output_dir = slasher(ensembler(restart_output_dir)) + dirs%restart_input_dir = slasher(ensembler(restart_input_dir)) + dirs%input_filename = ensembler(input_filename) + endif + + ! Create the RESTART directory if absent + if (is_root_PE()) then + if (stat(trim(dirs%restart_output_dir), buf) == -1) then + ierr = mkdir(trim(dirs%restart_output_dir), int(o'700')) + if (ierr == -1) & + call MOM_error(FATAL, 'Restart directory could not be created.') + endif + endif + endif + + ! Open run-time parameter file(s) + if (present(param_file)) then + output_dir = slasher(ensembler(output_directory)) + valid_param_files = 0 + do io = 1, npf + if (len_trim(trim(parameter_filename(io))) > 0) then + if (present(ensemble_num)) then + call open_param_file(ensembler(parameter_filename(io),ensemble_num), param_file, & + check_params, doc_file_dir=output_dir, ensemble_num=ensemble_num) + else + call open_param_file(ensembler(parameter_filename(io)), param_file, & + check_params, doc_file_dir=output_dir) + endif + valid_param_files = valid_param_files + 1 + endif + enddo + if (valid_param_files == 0) call MOM_error(FATAL, "There must be at "//& + "least 1 valid entry in input_filename in MOM_input_nml in input.nml.") + endif + +end subroutine get_MOM_input + +end module MOM_get_input diff --git a/framework/MOM_hor_index.F90 b/framework/MOM_hor_index.F90 new file mode 100644 index 0000000000..2ce2808692 --- /dev/null +++ b/framework/MOM_hor_index.F90 @@ -0,0 +1,185 @@ +!> Defines the horizontal index type (hor_index_type) used for providing index ranges +module MOM_hor_index + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domains, only : MOM_domain_type, get_domain_extent, get_global_shape +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type + +implicit none ; private + +public :: hor_index_init, assignment(=) +public :: rotate_hor_index + +!> Container for horizontal index ranges for data, computational and global domains +type, public :: hor_index_type + integer :: isc !< The start i-index of cell centers within the computational domain + integer :: iec !< The end i-index of cell centers within the computational domain + integer :: jsc !< The start j-index of cell centers within the computational domain + integer :: jec !< The end j-index of cell centers within the computational domain + + integer :: isd !< The start i-index of cell centers within the data domain + integer :: ied !< The end i-index of cell centers within the data domain + integer :: jsd !< The start j-index of cell centers within the data domain + integer :: jed !< The end j-index of cell centers within the data domain + + integer :: isg !< The start i-index of cell centers within the global domain + integer :: ieg !< The end i-index of cell centers within the global domain + integer :: jsg !< The start j-index of cell centers within the global domain + integer :: jeg !< The end j-index of cell centers within the global domain + + integer :: IscB !< The start i-index of cell vertices within the computational domain + integer :: IecB !< The end i-index of cell vertices within the computational domain + integer :: JscB !< The start j-index of cell vertices within the computational domain + integer :: JecB !< The end j-index of cell vertices within the computational domain + + integer :: IsdB !< The start i-index of cell vertices within the data domain + integer :: IedB !< The end i-index of cell vertices within the data domain + integer :: JsdB !< The start j-index of cell vertices within the data domain + integer :: JedB !< The end j-index of cell vertices within the data domain + + integer :: IsgB !< The start i-index of cell vertices within the global domain + integer :: IegB !< The end i-index of cell vertices within the global domain + integer :: JsgB !< The start j-index of cell vertices within the global domain + integer :: JegB !< The end j-index of cell vertices within the global domain + + integer :: idg_offset !< The offset between the corresponding global and local i-indices. + integer :: jdg_offset !< The offset between the corresponding global and local j-indices. + logical :: symmetric !< True if symmetric memory is used. + + integer :: niglobal !< The global number of h-cells in the i-direction + integer :: njglobal !< The global number of h-cells in the j-direction + + integer :: turns !< Number of quarter-turn rotations from input to model +end type hor_index_type + +!> Copy the contents of one horizontal index type into another +interface assignment(=); module procedure HIT_assign ; end interface + +contains + +!> Sets various index values in a hor_index_type. +subroutine hor_index_init(Domain, HI, param_file, local_indexing, index_offset) + type(MOM_domain_type), intent(in) :: Domain !< The MOM domain from which to extract information. + type(hor_index_type), intent(inout) :: HI !< A horizontal index type to populate with data + type(param_file_type), optional, intent(in) :: param_file !< Parameter file handle + logical, optional, intent(in) :: local_indexing !< If true, all tracer data domains start at 1 + integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices + +! This include declares and sets the variable "version". +#include "version_variable.h" + + ! get_domain_extent ensures that domains start at 1 for compatibility between + ! static and dynamically allocated arrays. + call get_domain_extent(Domain, HI%isc, HI%iec, HI%jsc, HI%jec, & + HI%isd, HI%ied, HI%jsd, HI%jed, & + HI%isg, HI%ieg, HI%jsg, HI%jeg, & + HI%idg_offset, HI%jdg_offset, HI%symmetric, & + local_indexing=local_indexing) + call get_global_shape(Domain, HI%niglobal, HI%njglobal) + + ! Read all relevant parameters and write them to the model log. + if (present(param_file)) & + call log_version(param_file, "MOM_hor_index", version, & + "Sets the horizontal array index types.", all_default=.true.) + + HI%IscB = HI%isc ; HI%JscB = HI%jsc + HI%IsdB = HI%isd ; HI%JsdB = HI%jsd + HI%IsgB = HI%isg ; HI%JsgB = HI%jsg + if (HI%symmetric) then + HI%IscB = HI%isc-1 ; HI%JscB = HI%jsc-1 + HI%IsdB = HI%isd-1 ; HI%JsdB = HI%jsd-1 + HI%IsgB = HI%isg-1 ; HI%JsgB = HI%jsg-1 + endif + HI%IecB = HI%iec ; HI%JecB = HI%jec + HI%IedB = HI%ied ; HI%JedB = HI%jed + HI%IegB = HI%ieg ; HI%JegB = HI%jeg + + HI%turns = 0 +end subroutine hor_index_init + +!> HIT_assign copies one hor_index_type into another. It is accessed via an +!! assignment (=) operator. +subroutine HIT_assign(HI1, HI2) + type(hor_index_type), intent(out) :: HI1 !< Horizontal index type to copy to + type(hor_index_type), intent(in) :: HI2 !< Horizontal index type to copy from + ! This subroutine copies all components of the horizontal array index type + ! variable on the RHS (HI2) to the variable on the LHS (HI1). + + HI1%isc = HI2%isc ; HI1%iec = HI2%iec ; HI1%jsc = HI2%jsc ; HI1%jec = HI2%jec + HI1%isd = HI2%isd ; HI1%ied = HI2%ied ; HI1%jsd = HI2%jsd ; HI1%jed = HI2%jed + HI1%isg = HI2%isg ; HI1%ieg = HI2%ieg ; HI1%jsg = HI2%jsg ; HI1%jeg = HI2%jeg + + HI1%IscB = HI2%IscB ; HI1%IecB = HI2%IecB ; HI1%JscB = HI2%JscB ; HI1%JecB = HI2%JecB + HI1%IsdB = HI2%IsdB ; HI1%IedB = HI2%IedB ; HI1%JsdB = HI2%JsdB ; HI1%JedB = HI2%JedB + HI1%IsgB = HI2%IsgB ; HI1%IegB = HI2%IegB ; HI1%JsgB = HI2%JsgB ; HI1%JegB = HI2%JegB + + HI1%niglobal = HI2%niglobal ; HI1%njglobal = HI2%njglobal + HI1%idg_offset = HI2%idg_offset ; HI1%jdg_offset = HI2%jdg_offset + HI1%symmetric = HI2%symmetric + HI1%turns = HI2%turns +end subroutine HIT_assign + +!> Rotate the horizontal index ranges from the input to the output map. +subroutine rotate_hor_index(HI_in, turns, HI) + type(hor_index_type), intent(in) :: HI_in !< Unrotated horizontal indices + integer, intent(in) :: turns !< Number of quarter turns + type(hor_index_type), intent(inout) :: HI !< Rotated horizontal indices + + if (modulo(turns, 2) /= 0) then + HI%isc = HI_in%jsc + HI%iec = HI_in%jec + HI%jsc = HI_in%isc + HI%jec = HI_in%iec + HI%isd = HI_in%jsd + HI%ied = HI_in%jed + HI%jsd = HI_in%isd + HI%jed = HI_in%ied + HI%isg = HI_in%jsg + HI%ieg = HI_in%jeg + HI%jsg = HI_in%isg + HI%jeg = HI_in%ieg + + HI%IscB = HI_in%JscB + HI%IecB = HI_in%JecB + HI%JscB = HI_in%IscB + HI%JecB = HI_in%IecB + HI%IsdB = HI_in%JsdB + HI%IedB = HI_in%JedB + HI%JsdB = HI_in%IsdB + HI%JedB = HI_in%IedB + HI%IsgB = HI_in%JsgB + HI%IegB = HI_in%JegB + HI%JsgB = HI_in%IsgB + HI%JegB = HI_in%IegB + + HI%niglobal = HI_in%njglobal + HI%njglobal = HI_in%niglobal + HI%idg_offset = HI_in%jdg_offset + HI%jdg_offset = HI_in%idg_offset + + HI%symmetric = HI_in%symmetric + else + HI = HI_in + endif + HI%turns = HI_in%turns + turns +end subroutine rotate_hor_index + +!> \namespace mom_hor_index +!! +!! The hor_index_type provides the declarations and loop ranges for almost all data with horizontal extent. +!! +!! Declarations and loop ranges should always be coded with the symmetric memory model in mind. +!! The non-symmetric memory mode will then also work, albeit with a different (less efficient) communication pattern. +!! +!! Using the hor_index_type HI: +!! - declaration of h-point data is of the form `h(HI%%isd:HI%%ied,HI%%jsd:HI%%jed)` +!! - declaration of q-point data is of the form `q(HI%%IsdB:HI%%IedB,HI%%JsdB:HI%%JedB)` +!! - declaration of u-point data is of the form `u(HI%%IsdB:HI%%IedB,HI%%jsd:HI%%jed)` +!! - declaration of v-point data is of the form `v(HI%%isd:HI%%ied,HI%%JsdB:HI%%JedB)`. +!! +!! For more detail explanation of horizontal indexing see \ref Horizontal_Indexing. + + +end module MOM_hor_index diff --git a/framework/MOM_horizontal_regridding.F90 b/framework/MOM_horizontal_regridding.F90 new file mode 100644 index 0000000000..205dd6d7be --- /dev/null +++ b/framework/MOM_horizontal_regridding.F90 @@ -0,0 +1,1033 @@ +!> Horizontal interpolation +module MOM_horizontal_regridding + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : hchksum +use MOM_coms, only : max_across_PEs, min_across_PEs, sum_across_PEs, broadcast +use MOM_coms, only : reproducing_sum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_LOOP +use MOM_domains, only : pass_var +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_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 +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 : get_external_field_info +use MOM_interp_infra, only : external_field +use MOM_time_manager, only : time_type +use MOM_io, only : axis_info, get_axis_info, get_var_axes_info, MOM_read_data +use MOM_io, only : read_attribute, read_variable + +implicit none ; private + +#include + +public :: horiz_interp_and_extrap_tracer, myStats, homogenize_field + +!> Extrapolate and interpolate data +interface horiz_interp_and_extrap_tracer + module procedure horiz_interp_and_extrap_tracer_record + module procedure horiz_interp_and_extrap_tracer_fms_id +end interface + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. +! The functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + +contains + +!> Write to the terminal some basic statistics about the k-th level of an array +subroutine myStats(array, missing, G, k, mesg, scale, full_halo) + type(ocean_grid_type), intent(in) :: G !< Ocean grid type + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: array !< input array in arbitrary units [A ~> a] + real, intent(in) :: missing !< missing value in arbitrary units [A ~> a] + integer, intent(in) :: k !< Level to calculate statistics for + character(len=*), intent(in) :: mesg !< Label to use in message + real, optional, intent(in) :: scale !< A scaling factor for output [a A-1 ~> 1] + logical, optional, intent(in) :: full_halo !< If present and true, test values on the whole + !! array rather than just the computational domain. + ! Local variables + real :: minA ! Minimum value in the array in the arbitrary units of the input array [A ~> a] + real :: maxA ! Maximum value in the array in the arbitrary units of the input array [A ~> a] + real :: scl ! A factor for undoing any scaling of the array statistics for output [a A-1 ~> 1] + integer :: i, j, is, ie, js, je + logical :: found + character(len=120) :: lMesg + + scl = 1.0 ; if (present(scale)) scl = scale + minA = 9.E24 / scl ; maxA = -9.E24 / scl ; found = .false. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + if (present(full_halo)) then ; if (full_halo) then + is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed + endif ; endif + + do j=js,je ; do i=is,ie + if (array(i,j) /= array(i,j)) stop 'Nan!' + if (abs(array(i,j)-missing) > 1.e-6*abs(missing)) then + if (found) then + minA = min(minA, array(i,j)) + maxA = max(maxA, array(i,j)) + else + found = .true. + minA = array(i,j) + maxA = array(i,j) + endif + endif + enddo ; enddo + call min_across_PEs(minA) + call max_across_PEs(maxA) + if (is_root_pe()) then + write(lMesg(1:120),'(2(a,es12.4),a,i3,1x,a)') & + 'init_from_Z: min=',minA*scl,' max=',maxA*scl,' Level=',k,trim(mesg) + call MOM_mesg(lMesg,2) + endif + +end subroutine myStats + +!> Use ICE-9 algorithm to populate points (fill=1) with valid data (good=1). If no information +!! is available, use a previous guess (prev). Optionally (smooth) blend the filled points to +!! achieve a more desirable result. +subroutine fill_miss_2d(aout, good, fill, prev, G, acrit, num_pass, relc, debug, answer_date) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: aout !< The array with missing values to fill [arbitrary] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: good !< Valid data mask for incoming array + !! (1==good data; 0==missing data) [nondim]. + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: fill !< Same shape array of points which need + !! filling (1==fill;0==dont fill) [nondim] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: prev !< First guess where isolated holes exist [arbitrary] + real, intent(in) :: acrit !< A minimal value for deltas between iterations that + !! determines when the smoothing has converged [arbitrary]. + integer, optional, intent(in) :: num_pass !< The maximum number of iterations + real, optional, intent(in) :: relc !< A relaxation coefficient for Laplacian [nondim] + logical, optional, intent(in) :: debug !< If true, write verbose debugging messages. + integer, optional, intent(in) :: answer_date !< The vintage of the expressions in the code. + !! Dates before 20190101 give the same answers + !! as the code did in late 2018, while later versions + !! add parentheses for rotational symmetry. + + real, dimension(SZI_(G),SZJ_(G)) :: a_filled ! The aout with missing values filled in [arbitrary] + real, dimension(SZI_(G),SZJ_(G)) :: a_chg ! The change in aout due to an iteration of smoothing [arbitrary] + real, dimension(SZI_(G),SZJ_(G)) :: fill_pts ! 1 for points that still need to be filled [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good_ ! The values that are valid for the current iteration [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good_new ! The values of good_ to use for the next iteration [nondim] + + real :: east, west, north, south ! Valid neighboring values or 0 for invalid values [arbitrary] + real :: ge, gw, gn, gs ! Flags indicating which neighbors have valid values [nondim] + real :: ngood ! The number of valid values in neighboring points [nondim] + real :: nfill ! The remaining number of points to fill [nondim] + real :: nfill_prev ! The previous value of nfill [nondim] + character(len=256) :: mesg ! The text of an error message + integer :: i, j, k + integer, parameter :: num_pass_default = 10000 + real, parameter :: relc_default = 0.25 ! The default relaxation coefficient [nondim] + + integer :: npass ! The maximum number of passes of the Laplacian smoother + integer :: is, ie, js, je + real :: relax_coeff ! The grid-scale Laplacian relaxation coefficient per timestep [nondim] + real :: ares ! The maximum magnitude change in aout [A] + logical :: debug_it, ans_2018 + + debug_it=.false. + if (PRESENT(debug)) debug_it=debug + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + npass = num_pass_default + if (PRESENT(num_pass)) npass = num_pass + + relax_coeff = relc_default + if (PRESENT(relc)) relax_coeff = relc + + ans_2018 = .true. ; if (PRESENT(answer_date)) ans_2018 = (answer_date < 20190101) + + fill_pts(:,:) = fill(:,:) + + nfill = sum(fill(is:ie,js:je)) + call sum_across_PEs(nfill) + + nfill_prev = nfill + good_(:,:) = good(:,:) + a_chg(:,:) = 0.0 + + do while (nfill > 0.0) + + call pass_var(good_,G%Domain) + call pass_var(aout,G%Domain) + + a_filled(:,:) = aout(:,:) + good_new(:,:) = good_(:,:) + + do j=js,je ; do i=is,ie + + if (good_(i,j) == 1.0 .or. fill(i,j) == 0.) cycle + + ge=good_(i+1,j) ; gw=good_(i-1,j) + gn=good_(i,j+1) ; gs=good_(i,j-1) + east=0.0 ; west=0.0 ; north=0.0 ; south=0.0 + if (ge == 1.0) east = aout(i+1,j)*ge + if (gw == 1.0) west = aout(i-1,j)*gw + if (gn == 1.0) north = aout(i,j+1)*gn + if (gs == 1.0) south = aout(i,j-1)*gs + + if (ans_2018) then + ngood = ge+gw+gn+gs + else + ngood = (ge+gw) + (gn+gs) + endif + if (ngood > 0.) then + if (ans_2018) then + a_filled(i,j) = (east+west+north+south)/ngood + else + a_filled(i,j) = ((east+west) + (north+south))/ngood + endif + fill_pts(i,j) = 0.0 + good_new(i,j) = 1.0 + endif + enddo ; enddo + + aout(is:ie,js:je) = a_filled(is:ie,js:je) + good_(is:ie,js:je) = good_new(is:ie,js:je) + nfill_prev = nfill + nfill = sum(fill_pts(is:ie,js:je)) + call sum_across_PEs(nfill) + + if (nfill == nfill_prev) then + do j=js,je ; do i=is,ie ; if (fill_pts(i,j) == 1.0) then + aout(i,j) = prev(i,j) + fill_pts(i,j) = 0.0 + endif ; enddo ; enddo + elseif (nfill == nfill_prev) then + call MOM_error(WARNING, & + 'Unable to fill missing points using either data at the same vertical level from a connected basin'//& + 'or using a point from a previous vertical level. Make sure that the original data has some valid'//& + 'data in all basins.', .true.) + write(mesg,*) 'nfill=',nfill + call MOM_error(WARNING, mesg, .true.) + endif + + ! Determine the number of remaining points to fill globally. + nfill = sum(fill_pts(is:ie,js:je)) + call sum_across_PEs(nfill) + + enddo ! while block for remaining points to fill. + + ! Do Laplacian smoothing for the points that have been filled in. + do k=1,npass + call pass_var(aout,G%Domain) + do j=js,je ; do i=is,ie + if (fill(i,j) == 1) then + east = max(good(i+1,j),fill(i+1,j)) ; west = max(good(i-1,j),fill(i-1,j)) + north = max(good(i,j+1),fill(i,j+1)) ; south = max(good(i,j-1),fill(i,j-1)) + if (ans_2018) then + a_chg(i,j) = relax_coeff*(south*aout(i,j-1)+north*aout(i,j+1) + & + west*aout(i-1,j)+east*aout(i+1,j) - & + (south+north+west+east)*aout(i,j)) + else + a_chg(i,j) = relax_coeff*( ((south*aout(i,j-1) + north*aout(i,j+1)) + & + (west*aout(i-1,j)+east*aout(i+1,j))) - & + ((south+north)+(west+east))*aout(i,j) ) + endif + else + a_chg(i,j) = 0. + endif + enddo ; enddo + ares = 0.0 + do j=js,je ; do i=is,ie + aout(i,j) = a_chg(i,j) + aout(i,j) + ares = max(ares, abs(a_chg(i,j))) + enddo ; enddo + call max_across_PEs(ares) + if (ares <= acrit) exit + enddo + + do j=js,je ; do i=is,ie + if (good_(i,j) == 0.0 .and. fill_pts(i,j) == 1.0) then + write(mesg,*) 'In fill_miss, fill, good,i,j= ',fill_pts(i,j),good_(i,j),i,j + call MOM_error(WARNING, mesg, .true.) + call MOM_error(FATAL,"MOM_initialize: "// & + "fill is true and good is false after fill_miss, how did this happen? ") + endif + enddo ; enddo + +end subroutine fill_miss_2d + +!> Extrapolate and interpolate from a file record +subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr_z, mask_z, & + z_in, z_edges_in, missing_value, scale, & + homogenize, m_to_Z, answers_2018, ongrid, tr_iter_tol, answer_date) + + character(len=*), intent(in) :: filename !< Path to file containing tracer to be + !! interpolated. + character(len=*), intent(in) :: varnam !< Name of tracer in file. + integer, intent(in) :: recnum !< Record number of tracer to be read. + type(ocean_grid_type), intent(inout) :: G !< Grid object + real, allocatable, dimension(:,:,:), intent(out) :: tr_z + !< Allocatable tracer array on the horizontal + !! model grid and input-file vertical levels + !! in arbitrary units [A ~> a] + real, allocatable, dimension(:,:,:), intent(out) :: mask_z + !< Allocatable tracer mask array on the horizontal + !! model grid and input-file vertical levels [nondim] + real, allocatable, dimension(:), intent(out) :: z_in + !< Cell grid values for input data [Z ~> m] + real, allocatable, dimension(:), intent(out) :: z_edges_in + !< Cell grid edge values for input data [Z ~> m] + real, intent(out) :: missing_value !< The missing value in the returned array, scaled + !! to avoid accidentally having valid values match + !! missing values in the same units as tr_z [A ~> a] + real, intent(in) :: scale !< Scaling factor for tracer into the internal + !! units of the model for the units in the file [A a-1 ~> 1] + logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data + !! to produce perfectly "flat" initial conditions + real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units + !! of depth [Z m-1 ~> 1]. If missing, G%bathyT must be in m. + logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same + !! answers as the code did in late 2018. Otherwise + !! add parentheses for rotational symmetry. + logical, optional, intent(in) :: ongrid !< If true, then data are assumed to have been interpolated + !! to the model horizontal grid. In this case, only + !! extrapolation is performed by this routine + real, optional, intent(in) :: tr_iter_tol !< The tolerance for changes in tracer concentrations + !! between smoothing iterations that determines when to + !! stop iterating in the same units as tr_z [A ~> a] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions in the code. + !! Dates before 20190101 give the same answers + !! as the code did in late 2018, while later versions + !! add parentheses for rotational symmetry. + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(:,:), allocatable :: tr_in !< A 2-d array for holding input data on its + !! native horizontal grid, with units that change + !! as the input data is interpreted [a] then [A ~> a] + real, dimension(:,:,:), allocatable :: tr_in_full !< A 3-d array for holding input data on the + !! model horizontal grid, with units that change + !! as the input data is interpreted [a] then [A ~> a] + real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles + !! with units that change as the input data is + !! interpreted [a] then [A ~> a] + real, dimension(:,:), allocatable :: mask_in ! A 2-d mask for extended input grid [nondim] + + real :: PI_180 ! A conversion factor from degrees to radians + integer :: id, jd, kd, jdp ! Input dataset data sizes + integer :: i, j, k + integer, dimension(4) :: start, count + real, dimension(:,:), allocatable :: x_in ! Input file longitudes [radians] + real, dimension(:,:), allocatable :: y_in ! Input file latitudes [radians] + real, dimension(:), allocatable :: lon_in ! The longitudes in the input file [degreesE] then [radians] + real, dimension(:), allocatable :: lat_in ! The latitudes in the input file [degreesN] then [radians] + real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole [degreesN] then [radians] + real :: max_lat ! The maximum latitude on the input grid [degreesN] + real :: pole ! The sum of tracer values at the pole [a] + real :: max_depth ! The maximum depth of the ocean [Z ~> m] + real :: npole ! The number of points contributing to the pole value [nondim] + real :: missing_val_in ! The missing value in the input field [a] + real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] + real :: add_offset, scale_factor ! File-specific conversion factors [a] or [nondim] + integer :: ans_date ! The vintage of the expressions and order of arithmetic to use + logical :: found_attr + logical :: add_np + logical :: is_ongrid + type(horiz_interp_type) :: Interp + type(axis_info), dimension(4) :: axes_info ! Axis information used for regridding + integer :: is, ie, js, je ! compute domain indices + integer :: isg, ieg, jsg, jeg ! global extent + integer :: isd, ied, jsd, jed ! data domain indices + integer :: id_clock_read + logical :: debug=.false. + real :: I_scale ! The inverse of the scale factor for diagnostic output [a A-1 ~> 1] + real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing + ! iterations that determines when to stop iterating [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: lon_out ! The longitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: lat_out ! The latitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: mask_out ! The mask on the model grid [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 [nondim] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isg = G%isg ; ieg = G%ieg ; jsg = G%jsg ; jeg = G%jeg + + id_clock_read = cpu_clock_id('(Initialize tracer from Z) read', grain=CLOCK_LOOP) + + is_ongrid = .false. + if (present(ongrid)) is_ongrid = ongrid + + dtr_iter_stop = 1.0e-3*scale + if (present(tr_iter_tol)) dtr_iter_stop = tr_iter_tol + + I_scale = 1.0 / scale + + PI_180 = atan(1.0)/45. + + ans_date = 20181231 + if (present(answers_2018)) then ; if (.not.answers_2018) ans_date = 20190101 ; endif + if (present(answer_date)) ans_date = answer_date + + ! Open NetCDF file and if present, extract data and spatial coordinate information + ! The convention adopted here requires that the data be written in (i,j,k) ordering. + + call cpu_clock_begin(id_clock_read) + + ! A note by MJH copied from elsewhere suggests that this code may be using the model connectivity + ! (e.g., reentrant or tripolar) but should use the dataset's connectivity instead. + + call get_var_axes_info(trim(filename), trim(varnam), axes_info) + + if (allocated(z_in)) deallocate(z_in) + if (allocated(z_edges_in)) deallocate(z_edges_in) + if (allocated(tr_z)) deallocate(tr_z) + if (allocated(mask_z)) deallocate(mask_z) + + call get_axis_info(axes_info(1),ax_size=id) + call get_axis_info(axes_info(2),ax_size=jd) + call get_axis_info(axes_info(3),ax_size=kd) + + allocate(lon_in(id), lat_in(jd), z_in(kd), z_edges_in(kd+1)) + allocate(tr_z(isd:ied,jsd:jed,kd), source=0.0) + allocate(mask_z(isd:ied,jsd:jed,kd), source=0.0) + + call get_axis_info(axes_info(1),ax_data=lon_in) + call get_axis_info(axes_info(2),ax_data=lat_in) + call get_axis_info(axes_info(3),ax_data=z_in) + + call cpu_clock_end(id_clock_read) + + if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif + + add_np = .false. + jdp = jd + if (.not. is_ongrid) then + max_lat = maxval(lat_in) + if (max_lat < 90.0) then + ! Extrapolate the input data to the north pole using the northern-most latitude. + add_np = .true. + jdp = jd+1 + allocate(lat_inp(jdp)) + lat_inp(1:jd) = lat_in(:) + lat_inp(jd+1) = 90.0 + deallocate(lat_in) + allocate(lat_in(1:jdp)) + lat_in(:) = lat_inp(:) + endif + endif + ! construct level cell boundaries as the mid-point between adjacent centers + + ! Set the I/O attributes + call read_attribute(trim(filename), "_FillValue", missing_val_in, & + varname=trim(varnam), found=found_attr) + if (.not. found_attr) call MOM_error(FATAL, & + "error finding missing value for " // trim(varnam) // & + " in file " // trim(filename) // " in hinterp_extrap") + missing_value = scale * missing_val_in + + call read_attribute(trim(filename), "scale_factor", scale_factor, & + varname=trim(varnam), found=found_attr) + if (.not. found_attr) scale_factor = 1. + + call read_attribute(trim(filename), "add_offset", add_offset, & + varname=trim(varnam), found=found_attr) + if (.not. found_attr) add_offset = 0. + + z_edges_in(1) = 0.0 + do K=2,kd + z_edges_in(K) = 0.5*(z_in(k-1)+z_in(k)) + enddo + z_edges_in(kd+1) = 2.0*z_in(kd) - z_in(kd-1) + + if (is_ongrid) then + allocate(tr_in(is:ie,js:je), source=0.0) + allocate(tr_in_full(is:ie,js:je,kd), source=0.0) + allocate(mask_in(is:ie,js:je), source=0.0) + else + call horizontal_interp_init() + lon_in = lon_in*PI_180 + lat_in = lat_in*PI_180 + allocate(x_in(id,jdp), y_in(id,jdp)) + call meshgrid(lon_in, lat_in, x_in, y_in) + lon_out(:,:) = G%geoLonT(:,:)*PI_180 + lat_out(:,:) = G%geoLatT(:,:)*PI_180 + allocate(tr_in(id,jd), source=0.0) + allocate(tr_inp(id,jdp), source=0.0) + allocate(mask_in(id,jdp), source=0.0) + endif + + max_depth = maxval(G%bathyT(:,:)) + G%Z_ref + call max_across_PEs(max_depth) + + if (z_edges_in(kd+1) < max_depth) z_edges_in(kd+1) = max_depth + roundoff = 3.0*EPSILON(missing_val_in) + + ! Loop through each data level and interpolate to model grid. + ! After interpolating, fill in points which will be needed to define the layers. + + if (is_ongrid) then + start(1) = is+G%HI%idg_offset ; start(2) = js+G%HI%jdg_offset ; start(3) = 1 + count(1) = ie-is+1 ; count(2) = je-js+1 ; count(3) = kd ; start(4) = 1 ; count(4) = 1 + call MOM_read_data(trim(filename), trim(varnam), tr_in_full, start, count, G%Domain) + endif + + do k=1,kd + mask_in(:,:) = 0.0 + tr_out(:,:) = 0.0 + + if (is_ongrid) then + tr_in(is:ie,js:je) = tr_in_full(is:ie,js:je,k) + do j=js,je + do i=is,ie + if (abs(tr_in(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then + mask_in(i,j) = 1.0 + tr_in(i,j) = (tr_in(i,j)*scale_factor+add_offset) * scale + else + tr_in(i,j) = missing_value + endif + enddo + enddo + + tr_out(is:ie,js:je) = tr_in(is:ie,js:je) + + else ! .not.is_ongrid + + start(:) = 1 ; start(3) = k + count(:) = 1 ; count(1) = id ; count(2) = jd + call read_variable(trim(filename), trim(varnam), tr_in, start=start, nread=count) + + if (is_root_pe()) then + if (add_np) then + pole = 0.0 ; npole = 0.0 + do i=1,id + if (abs(tr_in(i,jd)-missing_val_in) > abs(roundoff*missing_val_in)) then + pole = pole + tr_in(i,jd) + npole = npole + 1.0 + endif + enddo + if (npole > 0) then + pole = pole / npole + else + pole = missing_val_in + endif + tr_inp(:,1:jd) = tr_in(:,:) + tr_inp(:,jdp) = pole + else + tr_inp(:,:) = tr_in(:,:) + endif + endif + + call broadcast(tr_inp, id*jdp, blocking=.true.) + + do j=1,jdp ; do i=1,id + if (abs(tr_inp(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then + mask_in(i,j) = 1.0 + tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * scale + else + tr_inp(i,j) = missing_value + endif + enddo ; enddo + + ! call fms routine horiz_interp to interpolate input level data to model horizontal grid + if (k == 1) then + call build_horiz_interp_weights(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & + interp_method='bilinear', src_modulo=.true.) + endif + + if (debug) then + call myStats(tr_inp, missing_value, G, k, 'Tracer from file', scale=I_scale, full_halo=.true.) + endif + + call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value) + endif ! End of .not.is_ongrid + + mask_out(:,:) = 1.0 + do j=js,je ; do i=is,ie + if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j) = 0. + enddo ; enddo + + fill(:,:) = 0.0 ; good(:,:) = 0.0 + + do j=js,je ; do i=is,ie + if (mask_out(i,j) < 1.0) then + tr_out(i,j) = missing_value + else + good(i,j) = 1.0 + endif + if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j) + G%Z_ref) .and. & + (mask_out(i,j) < 1.0)) & + fill(i,j) = 1.0 + enddo ; enddo + + call pass_var(fill, G%Domain) + call pass_var(good, G%Domain) + + if (debug) then + call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', scale=I_scale) + endif + + ! Horizontally homogenize data to produce perfectly "flat" initial conditions + if (PRESENT(homogenize)) then ; if (homogenize) then + call homogenize_field(tr_out, mask_out, G, scale, answer_date) + endif ; endif + + ! tr_out contains input z-space data on the model grid with missing values + ! now fill in missing values using "ICE-nine" algorithm. + tr_outf(:,:) = tr_out(:,:) + if (k==1) tr_prev(:,:) = tr_outf(:,:) + good2(:,:) = good(:,:) + fill2(:,:) = fill(:,:) + + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, answer_date=ans_date) + if (debug) then + call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', scale=I_scale) + endif + + tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) + mask_z(:,:,k) = good2(:,:) + fill2(:,:) + + tr_prev(:,:) = tr_z(:,:,k) + + if (debug) then + call hchksum(tr_prev, 'field after fill ', G%HI, scale=I_scale) + endif + + enddo ! kd + + if (allocated(lat_inp)) deallocate(lat_inp) + deallocate(tr_in) + if (allocated(tr_inp)) deallocate(tr_inp) + if (allocated(tr_in_full)) deallocate(tr_in_full) + +end subroutine horiz_interp_and_extrap_tracer_record + +!> Extrapolate and interpolate using a FMS time interpolation handle +subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & + z_in, z_edges_in, missing_value, scale, & + homogenize, spongeOngrid, m_to_Z, & + answers_2018, tr_iter_tol, answer_date) + + type(external_field), intent(in) :: field !< Handle for the time interpolated field + type(time_type), intent(in) :: Time !< A FMS time type + type(ocean_grid_type), intent(inout) :: G !< Grid object + real, allocatable, dimension(:,:,:), intent(out) :: tr_z + !< Allocatable tracer array on the horizontal + !! model grid and input-file vertical levels + !! in arbitrary units [A ~> a] + real, allocatable, dimension(:,:,:), intent(out) :: mask_z + !< Allocatable tracer mask array on the horizontal + !! model grid and input-file vertical levels [nondim] + real, allocatable, dimension(:), intent(out) :: z_in + !< Cell grid values for input data [Z ~> m] + real, allocatable, dimension(:), intent(out) :: z_edges_in + !< Cell grid edge values for input data [Z ~> m] + real, intent(out) :: missing_value !< The missing value in the returned array, scaled + !! to avoid accidentally having valid values match + !! missing values, in the same arbitrary units as tr_z [A ~> a] + real, intent(in) :: scale !< Scaling factor for tracer into the internal + !! units of the model [A a-1 ~> 1] + logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data + !! to produce perfectly "flat" initial conditions + logical, optional, intent(in) :: spongeOngrid !< If present and true, the sponge data are on the model grid + real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units + !! of depth [Z m-1 ~> 1]. If missing, G%bathyT must be in m. + logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same + !! answers as the code did in late 2018. Otherwise + !! add parentheses for rotational symmetry. + real, optional, intent(in) :: tr_iter_tol !< The tolerance for changes in tracer concentrations + !! between smoothing iterations that determines when to + !! stop iterating, in the same arbitrary units as tr_z [A ~> a] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions in the code. + !! Dates before 20190101 give the same answers + !! as the code did in late 2018, while later versions + !! add parentheses for rotational symmetry. + + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(:,:), allocatable :: tr_in !< A 2-d array for holding input data on its + !! native horizontal grid, with units that change + !! as the input data is interpreted [a] then [A ~> a] + real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles + !! with units that change as the input data is + !! interpreted [a] then [A ~> a] + real, dimension(:,:,:), allocatable :: data_in !< A buffer for storing the full 3-d time-interpolated array + !! on the original grid [a] + real, dimension(:,:), allocatable :: mask_in !< A 2-d mask for extended input grid [nondim] + + real :: PI_180 ! A conversion factor from degrees to radians + integer :: id, jd, kd, jdp ! Input dataset data sizes + integer :: i, j, k + real, dimension(:,:), allocatable :: x_in ! Input file longitudes [radians] + real, dimension(:,:), allocatable :: y_in ! Input file latitudes [radians] + real, dimension(:), allocatable :: lon_in ! The longitudes in the input file [degreesE] then [radians] + real, dimension(:), allocatable :: lat_in ! The latitudes in the input file [degreesN] then [radians] + real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole [degreesN] then [radians] + real :: max_lat ! The maximum latitude on the input grid [degreesN] + real :: pole ! The sum of tracer values at the pole [a] + real :: max_depth ! The maximum depth of the ocean [Z ~> m] + real :: npole ! The number of points contributing to the pole value [nondim] + real :: missing_val_in ! The missing value in the input field [a] + real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] + logical :: add_np + type(horiz_interp_type) :: Interp + type(axis_info), dimension(4) :: axes_data + integer :: is, ie, js, je ! compute domain indices + integer :: isg, ieg, jsg, jeg ! global extent + integer :: isd, ied, jsd, jed ! data domain indices + integer :: id_clock_read + integer, dimension(4) :: fld_sz + logical :: debug=.false. + logical :: is_ongrid + integer :: ans_date ! The vintage of the expressions and order of arithmetic to use + real :: I_scale ! The inverse of the scale factor for diagnostic output [a A-1 ~> 1] + real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing + ! iterations that determines when to stop iterating [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: lon_out ! The longitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: lat_out ! The latitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: mask_out ! The mask on the model grid [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 [nondim] + integer :: turns + integer :: verbosity + + turns = G%HI%turns + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isg = G%isg ; ieg = G%ieg ; jsg = G%jsg ; jeg = G%jeg + + id_clock_read = cpu_clock_id('(Initialize tracer from Z) read', grain=CLOCK_LOOP) + + dtr_iter_stop = 1.0e-3*scale + if (present(tr_iter_tol)) dtr_iter_stop = tr_iter_tol + + I_scale = 1.0 / scale + + PI_180 = atan(1.0)/45. + + ans_date = 20181231 + if (present(answers_2018)) then ; if (.not.answers_2018) ans_date = 20190101 ; endif + if (present(answer_date)) ans_date = answer_date + + ! Open NetCDF file and if present, extract data and spatial coordinate information + ! The convention adopted here requires that the data be written in (i,j,k) ordering. + + call cpu_clock_begin(id_clock_read) + + call get_external_field_info(field, size=fld_sz, axes=axes_data, missing=missing_val_in) + missing_value = scale*missing_val_in + + verbosity = MOM_get_verbosity() + + id = fld_sz(1) ; jd = fld_sz(2) ; kd = fld_sz(3) + + is_ongrid = .false. + if (PRESENT(spongeOngrid)) is_ongrid = spongeOngrid + if (.not. is_ongrid) then + allocate(lon_in(id), lat_in(jd)) + call get_axis_info(axes_data(1), ax_data=lon_in) + call get_axis_info(axes_data(2), ax_data=lat_in) + endif + + allocate(z_in(kd), z_edges_in(kd+1)) + + allocate(tr_z(isd:ied,jsd:jed,kd), source=0.0) + allocate(mask_z(isd:ied,jsd:jed,kd), source=0.0) + + call get_axis_info(axes_data(3), ax_data=z_in) + + if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif + + call cpu_clock_end(id_clock_read) + + if (.not. is_ongrid) then + max_lat = maxval(lat_in) + add_np = .false. + if (max_lat < 90.0) then + ! Extrapolate the input data to the north pole using the northern-most latitude. + add_np = .true. + jdp = jd+1 + allocate(lat_inp(jdp)) + lat_inp(1:jd) = lat_in(:) + lat_inp(jd+1) = 90.0 + deallocate(lat_in) + allocate(lat_in(1:jdp)) + lat_in(:) = lat_inp(:) + else + jdp = jd + endif + 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)) + call meshgrid(lon_in, lat_in, x_in, y_in) + lon_out(:,:) = G%geoLonT(:,:)*PI_180 + lat_out(:,:) = G%geoLatT(:,:)*PI_180 + allocate(data_in(id,jd,kd), source=0.0) + allocate(tr_in(id,jd), source=0.0) + allocate(tr_inp(id,jdp), source=0.0) + allocate(mask_in(id,jdp), source=0.0) + else + allocate(data_in(isd:ied,jsd:jed,kd)) + endif + + ! Construct level cell boundaries as the mid-point between adjacent centers. + z_edges_in(1) = 0.0 + do K=2,kd + z_edges_in(K) = 0.5*(z_in(k-1)+z_in(k)) + enddo + z_edges_in(kd+1) = 2.0*z_in(kd) - z_in(kd-1) + + max_depth = maxval(G%bathyT(:,:)) + G%Z_ref + call max_across_PEs(max_depth) + + if (z_edges_in(kd+1) < max_depth) z_edges_in(kd+1) = max_depth + + ! roundoff = 3.0*EPSILON(missing_value) + roundoff = 1.e-4 + + if (.not.is_ongrid) then + if (is_root_pe()) & + call time_interp_external(field, Time, data_in, verbose=(verbosity>5), turns=turns) + + ! Loop through each data level and interpolate to model grid. + ! After interpolating, fill in points which will be needed to define the layers. + do k=1,kd + if (is_root_pe()) then + tr_in(1:id,1:jd) = data_in(1:id,1:jd,k) + if (add_np) then + pole = 0.0 ; npole = 0.0 + do i=1,id + if (abs(tr_in(i,jd)-missing_val_in) > abs(roundoff*missing_val_in)) then + pole = pole + tr_in(i,jd) + npole = npole + 1.0 + endif + enddo + if (npole > 0) then + pole = pole / npole + else + pole = missing_val_in + endif + tr_inp(:,1:jd) = tr_in(:,:) + tr_inp(:,jdp) = pole + else + tr_inp(:,:) = tr_in(:,:) + endif + endif + + call broadcast(tr_inp, id*jdp, blocking=.true.) + + mask_in(:,:) = 0.0 + + do j=1,jdp ; do i=1,id + if (abs(tr_inp(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then + mask_in(i,j) = 1.0 + tr_inp(i,j) = tr_inp(i,j) * scale + else + tr_inp(i,j) = missing_value + endif + enddo ; enddo + + ! call fms routine horiz_interp to interpolate input level data to model horizontal grid + if (k == 1) then + call build_horiz_interp_weights(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & + interp_method='bilinear', src_modulo=.true.) + endif + + if (debug) then + call myStats(tr_inp, missing_value, G, k, 'Tracer from file', scale=I_scale, full_halo=.true.) + endif + + tr_out(:,:) = 0.0 + + call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value) + + mask_out(:,:) = 1.0 + do j=js,je ; do i=is,ie + if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j) = 0. + enddo ; enddo + + fill(:,:) = 0.0 ; good(:,:) = 0.0 + + do j=js,je ; do i=is,ie + if (mask_out(i,j) < 1.0) then + tr_out(i,j) = missing_value + else + good(i,j) = 1.0 + endif + if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j) + G%Z_ref) .and. & + (mask_out(i,j) < 1.0)) & + fill(i,j) = 1.0 + enddo ; enddo + call pass_var(fill, G%Domain) + call pass_var(good, G%Domain) + + if (debug) then + call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', scale=I_scale) + endif + + ! Horizontally homogenize data to produce perfectly "flat" initial conditions + if (PRESENT(homogenize)) then ; if (homogenize) then + call homogenize_field(tr_out, mask_out, G, scale, answer_date) + endif ; endif + + ! tr_out contains input z-space data on the model grid with missing values + ! now fill in missing values using "ICE-nine" algorithm. + tr_outf(:,:) = tr_out(:,:) + if (k==1) tr_prev(:,:) = tr_outf(:,:) + good2(:,:) = good(:,:) + fill2(:,:) = fill(:,:) + + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, answer_date=ans_date) + +! if (debug) then +! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI, scale=I_scale) +! call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', scale=I_scale) +! endif + + tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) + mask_z(:,:,k) = good2(:,:) + fill2(:,:) + tr_prev(:,:) = tr_z(:,:,k) + + if (debug) then + call hchksum(tr_prev, 'field after fill ', G%HI, scale=I_scale) + endif + + enddo ! kd + else + call time_interp_external(field, Time, data_in, verbose=(verbosity>5), turns=turns) + do k=1,kd + do j=js,je + do i=is,ie + tr_z(i,j,k) = data_in(i,j,k) * scale + if (ans_date >= 20190101) mask_z(i,j,k) = 1. + if (abs(tr_z(i,j,k)-missing_value) < abs(roundoff*missing_value)) mask_z(i,j,k) = 0. + enddo + enddo + enddo + endif + +end subroutine horiz_interp_and_extrap_tracer_fms_id + +!> Replace all values of a 2-d field with the weighted average over the valid points. +subroutine homogenize_field(field, weight, G, scale, answer_date, wt_unscale) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid type + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: field !< The tracer on the model grid in arbitrary units [A ~> a] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: weight !< The weights for the tracer in arbitrary units that + !! typically differ from those used by field [B ~> b] + real, intent(in) :: scale !< A rescaling factor that has been used for the + !! variable and has to be undone before the + !! reproducing sums [A a-1 ~> 1] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions in the code. + !! Dates before 20230101 use non-reproducing sums + !! in their averages, while later versions use + !! reproducing sums for rotational symmetry and + !! consistency across PE layouts. + real, optional, intent(in) :: wt_unscale !< A factor that undoes any dimensional scaling + !! of the weights so that they can be used with + !! reproducing sums [b B-1 ~> 1] + + ! Local variables + ! In the following comments, [A] and [B] are used to indicate the arbitrary, possibly rescaled + ! units of the input field and the weighting array, while [a] and [b] indicate the corresponding + ! unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: field_for_Sums ! The field times the weights with the scaling undone [a b] + real, dimension(SZI_(G),SZJ_(G)) :: wts_for_Sums ! A copy of the wieghts with the scaling undone [b] + real :: var_unscale ! The reciprocal of the scaling factor for the field and weights [a b A-1 B-1 ~> 1] + real :: wt_descale ! A factor that undoes any dimensional scaling of the weights so that they + ! can be used with reproducing sums [b B-1 ~> 1] + real :: wt_sum ! The sum of the weights, in [b] (reproducing) or [B ~> b] (non-reproducing) + real :: varsum ! The weighted sum of field being averaged [A B ~> a b] + real :: varAvg ! The average of the field [A ~> a] + logical :: use_repro_sums ! If true, use reproducing sums. + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + varAvg = 0.0 ! This value will be used if wt_sum is 0. + + use_repro_sums = .false. ; if (present(answer_date)) use_repro_sums = (answer_date >= 20230101) + + if (scale == 0.0) then + ! This seems like an unlikely case to ever be used, but dealing with it is better than having NaNs arise? + varAvg = 0.0 + elseif (use_repro_sums) then + wt_descale = 1.0 ; if (present(wt_unscale)) wt_descale = wt_unscale + var_unscale = wt_descale / scale + + field_for_Sums(:,:) = 0.0 + wts_for_Sums(:,:) = 0.0 + do j=js,je ; do i=is,ie + wts_for_Sums(i,j) = wt_descale * weight(i,j) + field_for_Sums(i,j) = var_unscale * (field(i,j) * weight(i,j)) + enddo ; enddo + + wt_sum = reproducing_sum(wts_for_Sums) + if (abs(wt_sum) > 0.0) & + varAvg = reproducing_sum(field_for_Sums) * (scale / wt_sum) + + else ! Do the averages with order-dependent sums to reproduce older answers. + wt_sum = 0 ; varsum = 0. + do j=js,je ; do i=is,ie + if (weight(i,j) > 0.0) then + wt_sum = wt_sum + weight(i,j) + varsum = varsum + field(i,j) * weight(i,j) + endif + enddo ; enddo + + ! Note that these averages will not reproduce across PE layouts or grid rotation. + call sum_across_PEs(wt_sum) + if (wt_sum > 0.0) then + call sum_across_PEs(varsum) + varAvg = varsum / wt_sum + endif + endif + + field(:,:) = varAvg + +end subroutine homogenize_field + + +!> Create a 2d-mesh of grid coordinates from 1-d arrays. +subroutine meshgrid(x, y, x_T, y_T) + real, dimension(:), intent(in) :: x !< input 1-dimensional vector [arbitrary] + real, dimension(:), intent(in) :: y !< input 1-dimensional vector [arbitrary] + real, dimension(size(x,1),size(y,1)), intent(inout) :: x_T !< output 2-dimensional array [arbitrary] + real, dimension(size(x,1),size(y,1)), intent(inout) :: y_T !< output 2-dimensional array [arbitrary] + + integer :: ni, nj, i, j + + ni = size(x,1) ; nj = size(y,1) + + do j=1,nj ; do i=1,ni + x_T(i,j) = x(i) + enddo ; enddo + + do j=1,nj ; do i=1,ni + y_T(i,j) = y(j) + enddo ; enddo + +end subroutine meshgrid + +end module MOM_horizontal_regridding diff --git a/framework/MOM_interpolate.F90 b/framework/MOM_interpolate.F90 new file mode 100644 index 0000000000..e131e8db9d --- /dev/null +++ b/framework/MOM_interpolate.F90 @@ -0,0 +1,213 @@ +!> This module provides added functionality to the FMS temporal and spatial interpolation routines +module MOM_interpolate + +! This file is part of MOM6. See LICENSE.md for the license. + +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=>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_interp_infra, only : external_field +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, run_horiz_interp, build_horiz_interp_weights +public :: external_field + +!> Read a field based on model time, and rotate to the model domain. +interface time_interp_external + module procedure time_interp_external_0d + module procedure time_interp_external_2d + module procedure time_interp_external_3d +end interface time_interp_external + +contains + +!> Read a scalar field based on model time. +subroutine time_interp_external_0d(field, time, data_in, verbose, scale) + type(external_field), intent(in) :: field !< Handle for time interpolated field + type(time_type), intent(in) :: time !< The target time for the data + real, intent(inout) :: data_in !< The interpolated value + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + real, optional, intent(in) :: scale !< A scaling factor that new values of data_in are + !! multiplied by before it is returned + real :: data_in_pre_scale ! The input data before rescaling + real :: I_scale ! The inverse of scale + + ! Store the input value in case the scaling factor is perfectly invertable. + data_in_pre_scale = data_in + I_scale = 1.0 + if (present(scale)) then ; if ((scale /= 1.0) .and. (scale /= 0.0)) then + ! Because time_interp_extern has the ability to only set some values, but no clear + ! mechanism to determine which values have been set, the input data has to + ! be unscaled so that it will have the right values when it is returned. + I_scale = 1.0 / scale + data_in = data_in * I_scale + endif ; endif + + call time_interp_extern(field, time, data_in, verbose=verbose) + + if (present(scale)) then ; if (scale /= 1.0) then + ! Rescale data that has been newly set and restore the scaling of unset data. + if (data_in == I_scale * data_in_pre_scale) then + data_in = data_in_pre_scale + else + data_in = scale * data_in + endif + endif ; endif + +end subroutine time_interp_external_0d + +!> Read a 2d field from an external based on model time, potentially including horizontal +!! interpolation and rotation of the data +subroutine time_interp_external_2d(field, time, data_in, interp, & + verbose, horz_interp, mask_out, turns, scale) + type(external_field), intent(in) :: field !< Handle for time interpolated field + type(time_type), intent(in) :: time !< The target time for the data + real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + logical, dimension(:,:), & + optional, intent(out) :: mask_out !< An array that is true where there is valid data + integer, optional, intent(in) :: turns !< Number of quarter turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that new values of data_in are + !! multiplied by before it is returned + + real, allocatable :: data_in_pre_scale(:,:) ! The input data before rescaling + real, allocatable :: data_pre_rot(:,:) ! The unscaled input data before rotation + real :: I_scale ! The inverse of scale + integer :: qturns ! The number of quarter turns to rotate the data + integer :: i, j + + ! TODO: Mask rotation requires logical array rotation support + if (present(mask_out)) & + call MOM_error(FATAL, "Rotation of masked output not yet support") + + if (present(scale)) then ; if ((scale /= 1.0) .and. (scale /= 0.0)) then + ! Because time_interp_extern has the ability to only set some values, but no clear mechanism + ! to determine which values have been set, the input data has to be unscaled so that it will + ! have the right values when it is returned. It may be a problem for some compiler settings + ! if there are NaNs in data_in, but they will not spread. + if (abs(fraction(scale)) /= 1.0) then + ! This scaling factor may not be perfectly invertable, so store the input value + allocate(data_in_pre_scale, source=data_in) + endif + I_scale = 1.0 / scale + data_in(:,:) = I_scale * data_in(:,:) + endif ; endif + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call time_interp_extern(field, time, data_in, interp=interp, & + verbose=verbose, horz_interp=horz_interp) + else + call allocate_rotated_array(data_in, [1,1], -qturns, data_pre_rot) + call time_interp_extern(field, time, data_pre_rot, interp=interp, & + verbose=verbose, horz_interp=horz_interp) + call rotate_array(data_pre_rot, turns, data_in) + deallocate(data_pre_rot) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + ! Rescale data that has been newly set and restore the scaling of unset data. + if ((abs(fraction(scale)) /= 1.0) .and. (scale /= 0.0)) then + do j=LBOUND(data_in,2),UBOUND(data_in,2) ; do i=LBOUND(data_in,1),UBOUND(data_in,1) + ! This handles the case where scale is not exactly invertable for data + ! values that have not been modified by time_interp_extern. + if (data_in(i,j) == I_scale * data_in_pre_scale(i,j)) then + data_in(i,j) = data_in_pre_scale(i,j) + else + data_in(i,j) = scale * data_in(i,j) + endif + enddo ; enddo + else + data_in(:,:) = scale * data_in(:,:) + endif + endif ; endif + +end subroutine time_interp_external_2d + + +!> Read a 3d field based on model time, and rotate to the model grid +subroutine time_interp_external_3d(field, time, data_in, interp, & + verbose, horz_interp, mask_out, turns, scale) + type(external_field), intent(in) :: field !< Handle for time interpolated field + type(time_type), intent(in) :: time !< The target time for the data + real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + logical, dimension(:,:,:), & + optional, intent(out) :: mask_out !< An array that is true where there is valid data + integer, optional, intent(in) :: turns !< Number of quarter turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that new values of data_in are + !! multiplied by before it is returned + + real, allocatable :: data_in_pre_scale(:,:,:) ! The input data before rescaling + real, allocatable :: data_pre_rot(:,:,:) ! The unscaled input data before rotation + real :: I_scale ! The inverse of scale + integer :: qturns ! The number of quarter turns to rotate the data + integer :: i, j, k + + ! TODO: Mask rotation requires logical array rotation support + if (present(mask_out)) & + call MOM_error(FATAL, "Rotation of masked output not yet support") + + if (present(scale)) then ; if ((scale /= 1.0) .and. (scale /= 0.0)) then + ! Because time_interp_extern has the ability to only set some values, but no clear mechanism + ! to determine which values have been set, the input data has to be unscaled so that it will + ! have the right values when it is returned. It may be a problem for some compiler settings + ! if there are NaNs in data_in, but they will not spread. + if (abs(fraction(scale)) /= 1.0) then + ! This scaling factor may not be perfectly invertable, so store the input value + allocate(data_in_pre_scale, source=data_in) + endif + I_scale = 1.0 / scale + data_in(:,:,:) = I_scale * data_in(:,:,:) + endif ; endif + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call time_interp_extern(field, time, data_in, interp=interp, & + verbose=verbose, horz_interp=horz_interp) + else + call allocate_rotated_array(data_in, [1,1,1], -qturns, data_pre_rot) + call time_interp_extern(field, time, data_pre_rot, interp=interp, & + verbose=verbose, horz_interp=horz_interp) + call rotate_array(data_pre_rot, turns, data_in) + deallocate(data_pre_rot) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + ! Rescale data that has been newly set and restore the scaling of unset data. + if ((abs(fraction(scale)) /= 1.0) .and. (scale /= 0.0)) then + do k=LBOUND(data_in,3),UBOUND(data_in,3) + do j=LBOUND(data_in,2),UBOUND(data_in,2) + do i=LBOUND(data_in,1),UBOUND(data_in,1) + ! This handles the case where scale is not exactly invertable for data + ! values that have not been modified by time_interp_extern. + if (data_in(i,j,k) == I_scale * data_in_pre_scale(i,j,k)) then + data_in(i,j,k) = data_in_pre_scale(i,j,k) + else + data_in(i,j,k) = scale * data_in(i,j,k) + endif + enddo + enddo + enddo + else + data_in(:,:,:) = scale * data_in(:,:,:) + endif + endif ; endif + +end subroutine time_interp_external_3d + +end module MOM_interpolate diff --git a/framework/MOM_intrinsic_functions.F90 b/framework/MOM_intrinsic_functions.F90 new file mode 100644 index 0000000000..fbb1c28096 --- /dev/null +++ b/framework/MOM_intrinsic_functions.F90 @@ -0,0 +1,238 @@ +!> A module with intrinsic functions that are used by MOM but are not supported +!! by some compilers. +module MOM_intrinsic_functions + +! This file is part of MOM6. See LICENSE.md for the license. + +use iso_fortran_env, only : stdout => output_unit, stderr => error_unit +use iso_fortran_env, only : int64, real64 + +implicit none ; private + +public :: invcosh, cuberoot +public :: intrinsic_functions_unit_tests + +! Floating point model, if bit layout from high to low is (sign, exp, frac) + +integer, parameter :: bias = maxexponent(1.) - 1 + !< The double precision exponent offset +integer, parameter :: signbit = storage_size(1.) - 1 + !< Position of sign bit +integer, parameter :: explen = 1 + ceiling(log(real(bias))/log(2.)) + !< Bit size of exponent +integer, parameter :: expbit = signbit - explen + !< Position of lowest exponent bit +integer, parameter :: fraclen = expbit + !< Length of fractional part + +contains + +!> Evaluate the inverse cosh, either using a math library or an +!! equivalent expression +function invcosh(x) + real, intent(in) :: x !< The argument of the inverse of cosh [nondim]. NaNs will + !! occur if x<1, but there is no error checking + real :: invcosh ! The inverse of cosh of x [nondim] + +#ifdef __INTEL_COMPILER + invcosh = acosh(x) +#else + invcosh = log(x+sqrt(x*x-1)) +#endif + +end function invcosh + + +!> Returns the cube root of a real argument at roundoff accuracy, in a form that works properly with +!! rescaling of the argument by integer powers of 8. If the argument is a NaN, a NaN is returned. +elemental function cuberoot(x) result(root) + real, intent(in) :: x !< The argument of cuberoot in arbitrary units cubed [A3] + real :: root !< The real cube root of x in arbitrary units [A] + + real :: asx ! The absolute value of x rescaled by an integer power of 8 to put it into + ! the range from 0.125 < asx <= 1.0, in ambiguous units cubed [B3] + real :: root_asx ! The cube root of asx [B] + real :: ra_3 ! root_asx cubed [B3] + real :: num ! The numerator of an expression for the evolving estimate of the cube root of asx + ! in arbitrary units that can grow or shrink with each iteration [B C] + real :: den ! The denominator of an expression for the evolving estimate of the cube root of asx + ! in arbitrary units that can grow or shrink with each iteration [C] + real :: num_prev ! The numerator of an expression for the previous iteration of the evolving estimate + ! of the cube root of asx in arbitrary units that can grow or shrink with each iteration [B D] + real :: np_3 ! num_prev cubed [B3 D3] + real :: den_prev ! The denominator of an expression for the previous iteration of the evolving estimate of + ! the cube root of asx in arbitrary units that can grow or shrink with each iteration [D] + real :: dp_3 ! den_prev cubed [C3] + real :: r0 ! Initial value of the iterative solver. [B C] + real :: r0_3 ! r0 cubed [B3 C3] + integer :: itt + + integer(kind=int64) :: e_x, s_x + + if ((x >= 0.0) .eqv. (x <= 0.0)) then + ! Return 0 for an input of 0, or NaN for a NaN input. + root = x + else + call rescale_cbrt(x, asx, e_x, s_x) + + ! Iteratively determine root_asx = asx**1/3 using Halley's method and then Newton's method, + ! noting that Halley's method onverges monotonically and needs no bounding. Halley's method is + ! slightly more complicated that Newton's method, but converges in a third fewer iterations. + ! Keeping the estimates in a fractional form Root = num / den allows this calculation with + ! no real divisions during the iterations before doing a single real division at the end, + ! and it is therefore more computationally efficient. + + ! This first estimate gives the same magnitude of errors for 0.125 and 1.0 after two iterations. + ! The first iteration is applied explicitly. + r0 = 0.707106 + r0_3 = r0 * r0 * r0 + num = r0 * (r0_3 + 2.0 * asx) + den = 2.0 * r0_3 + asx + + do itt=1,2 + ! Halley's method iterates estimates as Root = Root * (Root**3 + 2.*asx) / (2.*Root**3 + asx). + num_prev = num ; den_prev = den + + ! Pre-compute these as integer powers, to avoid `pow()`-like intrinsics. + np_3 = num_prev * num_prev * num_prev + dp_3 = den_prev * den_prev * den_prev + + num = num_prev * (np_3 + 2.0 * asx * dp_3) + den = den_prev * (2.0 * np_3 + asx * dp_3) + ! Equivalent to: root_asx = root_asx * (root_asx**3 + 2.*asx) / (2.*root_asx**3 + asx) + enddo + ! At this point the error in root_asx is better than 1 part in 3e14. + root_asx = num / den + + ! One final iteration with Newton's method polishes up the root and gives a solution + ! that is within the last bit of the true solution. + ra_3 = root_asx * root_asx * root_asx + root_asx = root_asx - (ra_3 - asx) / (3.0 * (root_asx * root_asx)) + + root = descale(root_asx, e_x, s_x) + endif +end function cuberoot + + +!> Rescale `a` to the range [0.125, 1) and compute its cube-root exponent. +pure subroutine rescale_cbrt(a, x, e_r, s_a) + real, intent(in) :: a + !< The real parameter to be rescaled for cube root + real, intent(out) :: x + !< The rescaled value of a + integer(kind=int64), intent(out) :: e_r + !< Cube root of the exponent of the rescaling of `a` + integer(kind=int64), intent(out) :: s_a + !< The sign bit of a + + integer(kind=int64) :: xb + ! Floating point value of a, bit-packed as an integer + integer(kind=int64) :: e_a + ! Unscaled exponent of a + integer(kind=int64) :: e_x + ! Exponent of x + integer(kind=int64) :: e_div, e_mod + ! Quotient and remainder of e in e = 3*(e/3) + modulo(e,3). + + ! Pack bits of a into xb and extract its exponent and sign. + xb = transfer(a, 1_int64) + s_a = ibits(xb, signbit, 1) + e_a = ibits(xb, expbit, explen) - bias + + ! Compute terms of exponent decomposition e = 3*(e/3) + modulo(e,3). + ! (Fortran division is round-to-zero, so we must emulate floor division.) + e_mod = modulo(e_a, 3_int64) + e_div = (e_a - e_mod)/3 + + ! Our scaling decomposes e_a into e = {3*(e/3) + 3} + {modulo(e,3) - 3}. + + ! The first term is a perfect cube, whose cube root is computed below. + e_r = e_div + 1 + + ! The second term ensures that x is shifted to [0.125, 1). + e_x = e_mod - 3 + + ! Insert the new 11-bit exponent into xb and write to x and extend the + ! bitcount to 12, so that the sign bit is zero and x is always positive. + call mvbits(e_x + bias, 0, explen + 1, xb, fraclen) + x = transfer(xb, 1.) +end subroutine rescale_cbrt + + +!> Undo the rescaling of a real number back to its original base. +pure function descale(x, e_a, s_a) result(a) + real, intent(in) :: x + !< The rescaled value which is to be restored. + integer(kind=int64), intent(in) :: e_a + !< Exponent of the unscaled value + integer(kind=int64), intent(in) :: s_a + !< Sign bit of the unscaled value + real :: a + !< Restored value with the corrected exponent and sign + + integer(kind=int64) :: xb + ! Bit-packed real number into integer form + integer(kind=int64) :: e_x + ! Biased exponent of x + + ! Apply the corrected exponent and sign to x. + xb = transfer(x, 1_8) + e_x = ibits(xb, expbit, explen) + call mvbits(e_a + e_x, 0, explen, xb, expbit) + call mvbits(s_a, 0, 1, xb, signbit) + a = transfer(xb, 1.) +end function descale + + +!> Returns true if any unit test of intrinsic_functions fails, or false if they all pass. +function intrinsic_functions_unit_tests(verbose) result(fail) + logical, intent(in) :: verbose !< If true, write results to stdout + logical :: fail !< True if any of the unit tests fail + + ! Local variables + real :: testval ! A test value for self-consistency testing [nondim] + logical :: v + integer :: n + + fail = .false. + v = verbose + write(stdout,*) '==== MOM_intrinsic_functions: intrinsic_functions_unit_tests ===' + + fail = fail .or. Test_cuberoot(v, 1.2345678901234e9) + fail = fail .or. Test_cuberoot(v, -9.8765432109876e-21) + fail = fail .or. Test_cuberoot(v, 64.0) + fail = fail .or. Test_cuberoot(v, -0.5000000000001) + fail = fail .or. Test_cuberoot(v, 0.0) + fail = fail .or. Test_cuberoot(v, 1.0) + fail = fail .or. Test_cuberoot(v, 0.125) + fail = fail .or. Test_cuberoot(v, 0.965) + fail = fail .or. Test_cuberoot(v, 1.0 - epsilon(1.0)) + fail = fail .or. Test_cuberoot(v, 1.0 - 0.5*epsilon(1.0)) + + testval = 1.0e-99 + v = .false. + do n=-160,160 + fail = fail .or. Test_cuberoot(v, testval) + testval = (-2.908 * (1.414213562373 + 1.2345678901234e-5*n)) * testval + enddo +end function intrinsic_functions_unit_tests + +!> True if the cube of cuberoot(val) does not closely match val. False otherwise. +logical function Test_cuberoot(verbose, val) + logical, intent(in) :: verbose !< If true, write results to stdout + real, intent(in) :: val !< The real value to test, in arbitrary units [A] + ! Local variables + real :: diff ! The difference between val and the cube root of its cube. + + diff = val - cuberoot(val)**3 + Test_cuberoot = (abs(diff) > 2.0e-15*abs(val)) + + if (Test_cuberoot) then + write(stdout, '("For val = ",ES22.15,", (val - cuberoot(val**3))) = ",ES9.2," <-- FAIL")') val, diff + elseif (verbose) then + write(stdout, '("For val = ",ES22.15,", (val - cuberoot(val**3))) = ",ES9.2)') val, diff + + endif +end function Test_cuberoot + +end module MOM_intrinsic_functions diff --git a/framework/MOM_io.F90 b/framework/MOM_io.F90 new file mode 100644 index 0000000000..27d244b226 --- /dev/null +++ b/framework/MOM_io.F90 @@ -0,0 +1,3072 @@ +!> This module contains I/O framework code +module MOM_io + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_array_transform, only : allocate_rotated_array, rotate_array +use MOM_array_transform, only : rotate_array_pair, rotate_vector +use MOM_domains, only : MOM_domain_type, domain1D, broadcast, get_domain_components +use MOM_domains, only : rescale_comp_data, num_PEs, AGRID, BGRID_NE, CGRID_NE +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_ensemble_manager, only : get_ensemble_id +use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING, is_root_PE +use MOM_file_parser, only : log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_io_infra, only : read_field, read_vector +use MOM_io_infra, only : read_data => read_field ! Deprecated +use MOM_io_infra, only : read_field_chksum +use MOM_io_infra, only : file_exists +use MOM_io_infra, only : open_ASCII_file, close_file, file_is_open +use MOM_io_infra, only : get_field_size, field_exists, get_field_atts +use MOM_io_infra, only : get_axis_data, get_filename_suffix +use MOM_io_infra, only : write_version +use MOM_io_infra, only : MOM_namelist_file, check_namelist_error, io_infra_init, io_infra_end +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 +use MOM_io_file, only : MOM_file, MOM_infra_file, MOM_netcdf_file +use MOM_io_file, only : MOM_axis, MOM_field +use MOM_string_functions, only : lowercase, slasher +use MOM_verticalGrid, only : verticalGrid_type + +use iso_fortran_env, only : int32, int64, stdout_iso=>output_unit, stderr_iso=>error_unit +use netcdf, only : NF90_open, NF90_inq_varid, NF90_inq_varids, NF90_inquire, NF90_close +use netcdf, only : NF90_inquire_variable, NF90_get_var, NF90_get_att, NF90_inquire_attribute +use netcdf, only : NF90_strerror, NF90_inquire_dimension +use netcdf, only : NF90_NOWRITE, NF90_NOERR, NF90_GLOBAL, NF90_ENOTATT, NF90_CHAR + +! The following are not used in MOM6, but may be used by externals (e.g. SIS2). +use MOM_io_infra, only : axistype ! still used but soon to be nuked +use MOM_io_infra, only : fieldtype +use MOM_io_infra, only : file_type +use MOM_io_infra, only : get_file_info +use MOM_io_infra, only : get_file_fields +use MOM_io_infra, only : get_file_times +use MOM_io_infra, only : open_file +use MOM_io_infra, only : write_field + +implicit none ; private + +! These interfaces are actually implemented in this file. +public :: create_MOM_file, reopen_MOM_file, cmor_long_std, ensembler, MOM_io_init +public :: MOM_field +public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc, position_from_horgrid +public :: open_namelist_file, check_namelist_error, check_nml_error +public :: get_var_sizes, verify_variable_units, num_timelevels, read_variable, read_attribute +public :: open_file_to_read, close_file_to_read +! The following are simple pass throughs of routines from MOM_io_infra or other modules. +public :: file_exists, open_ASCII_file, close_file +public :: MOM_file, MOM_infra_file, MOM_netcdf_file +public :: field_exists, get_filename_appendix +public :: fieldtype, field_size, get_field_atts +public :: axistype, get_axis_data +public :: MOM_read_data, MOM_read_vector, read_field_chksum +public :: read_netCDF_data +public :: slasher, write_version_number +public :: io_infra_init, io_infra_end +public :: stdout_if_root +public :: get_var_axes_info +public :: get_axis_info +! This is used to set up information descibing non-domain-decomposed axes. +public :: axis_info, set_axis_info, delete_axis_info +! This is used to set up global file attributes +public :: attribute_info, set_attribute_info, delete_attribute_info +! This API is here just to support potential use by non-FMS drivers, and should not persist. +public :: read_data +!> These encoding constants are used to indicate the file format +public :: ASCII_FILE, NETCDF_FILE +!> These encoding constants are used to indicate whether the file is domain decomposed +public :: MULTIPLE, SINGLE_FILE +!> These encoding constants are used to indicate the access mode for a file +public :: APPEND_FILE, OVERWRITE_FILE, READONLY_FILE, WRITEONLY_FILE +!> These encoding constants are used to indicate the discretization position of a variable +public :: CENTER, CORNER, NORTH_FACE, EAST_FACE + +! The following are not used in MOM6, but may be used by externals (e.g. SIS2). +public :: create_file +public :: reopen_file +public :: file_type +public :: open_file +public :: get_file_info +public :: get_file_fields +public :: get_file_times + +!> Read a field from file using the infrastructure I/O. +interface MOM_read_data + module procedure MOM_read_data_0d + module procedure MOM_read_data_0d_int + module procedure MOM_read_data_1d + module procedure MOM_read_data_1d_int + module procedure MOM_read_data_2d + module procedure MOM_read_data_2d_region + module procedure MOM_read_data_3d + module procedure MOM_read_data_3d_region + module procedure MOM_read_data_4d +end interface MOM_read_data + +!> Read a vector from file using the infrastructure I/O. +interface MOM_read_vector + module procedure MOM_read_vector_2d + module procedure MOM_read_vector_3d +end interface MOM_read_vector + +!> Read a field using native netCDF I/O +!! +!! This function is primarily used for unstructured data which may contain +!! content that cannot be parsed by infrastructure I/O. +interface read_netCDF_data + ! NOTE: Only 2D I/O is currently used; this should be expanded as needed. + module procedure read_netCDF_data_2d +end interface read_netCDF_data + +!> Write a registered field to an output file, potentially with rotation +interface MOM_write_field + module procedure MOM_write_field_legacy_4d + module procedure MOM_write_field_legacy_3d + module procedure MOM_write_field_legacy_2d + module procedure MOM_write_field_legacy_1d + module procedure MOM_write_field_legacy_0d + module procedure MOM_write_field_4d + module procedure MOM_write_field_3d + module procedure MOM_write_field_2d + module procedure MOM_write_field_1d + module procedure MOM_write_field_0d +end interface MOM_write_field + +!> Read an entire named variable from a named netCDF file using netCDF calls directly, rather +!! than any infrastructure routines and broadcast it from the root PE to the other PEs. +interface read_variable + module procedure read_variable_0d, read_variable_0d_int + module procedure read_variable_1d, read_variable_1d_int + module procedure read_variable_2d, read_variable_3d +end interface read_variable + +!> Read a global or variable attribute from a named netCDF file using netCDF calls +!! directly, in some cases reading from the root PE before broadcasting to the other PEs. +interface read_attribute + module procedure read_attribute_str, read_attribute_real + module procedure read_attribute_int32, read_attribute_int64 +end interface read_attribute + +!> Type that stores information that can be used to create a non-decomposed axis. +type :: axis_info + character(len=32) :: name = "" !< The name of this axis for use in files + character(len=256) :: longname = "" !< A longer name describing this axis + character(len=48) :: units = "" !< The units of the axis labels + character(len=8) :: cartesian = "N" !< A variable indicating which direction + !! this axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer :: sense = 0 !< This is 1 for axes whose values increase upward, or -1 + !! if they increase downward. The default, 0, is ignored. + integer :: ax_size = 0 !< The number of elements in this axis + real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis [arbitrary] +end type axis_info + +!> Type for describing a 3-d variable for output +type, public :: vardesc + character(len=64) :: name !< Variable name in a NetCDF file + character(len=48) :: units !< Physical dimensions of the variable + character(len=240) :: longname !< Long name of the variable + character(len=8) :: hor_grid !< Horizontal grid: u, v, h, q, Cu, Cv, T, Bu, or 1 + character(len=8) :: z_grid !< Vertical grid: L, i, or 1 + character(len=8) :: t_grid !< Time description: s, p, or 1 + character(len=64) :: cmor_field_name !< CMOR name + character(len=64) :: cmor_units !< CMOR physical dimensions of the variable + character(len=240) :: cmor_longname !< CMOR long name of the variable + real :: conversion !< for unit conversions, such as needed to convert + !! from intensive to extensive [various] or [a A-1 ~> 1] + !! to undo internal dimensional rescaling + character(len=32) :: dim_names(5) !< The names in the file of the axes for this variable + integer :: position = -1 !< An integer encoding the horizontal position, it may + !! CENTER, CORNER, EAST_FACE, NORTH_FACE, or 0. + type(axis_info) :: extra_axes(5) !< dimensions other than space-time +end type vardesc + +!> Type that stores for a global file attribute +type :: attribute_info ; private + character(len=:), allocatable :: name !< The name of this attribute + character(len=:), allocatable :: att_val !< The values of this attribute +end type attribute_info + +integer, public :: stdout = stdout_iso !< standard output unit +integer, public :: stderr = stderr_iso !< standard output unit + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. +! The functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + +contains + +!> `create_MOM_file` wrapper for the legacy file handle, `file_type`. +!! NOTE: This function may be removed in a future release. +subroutine create_file(IO_handle, filename, vars, novars, fields, threading, & + timeunit, G, dG, GV, checksums, extra_axes, global_atts) + type(file_type), intent(inout) :: IO_handle + !< Handle for a files or fileset that is to be opened or reopened for + !! writing + character(len=*), intent(in) :: filename + !< full path to the file to create + type(vardesc), intent(in) :: vars(:) + !< structures describing fields written to filename + integer, intent(in) :: novars + !< number of fields written to filename + type(fieldtype), intent(inout) :: fields(:) + !< array of fieldtypes for each variable + integer, optional, intent(in) :: threading + !< SINGLE_FILE or MULTIPLE + real, optional, intent(in) :: timeunit + !< length of the units for time [s]. The default value is 86400.0, for 1 + !! day. + type(ocean_grid_type), optional, intent(in) :: G + !< ocean horizontal grid structure; G or dG is required if the new file + !! uses any horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG + !< dynamic horizontal grid structure; G or dG is required if the new file + !! uses any horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV + !< ocean vertical grid structure, which is ! required if the new file uses + !! any vertical grid axes. + integer(kind=int64), optional, intent(in) :: checksums(:,:) + !< checksums of vars + type(axis_info), optional, intent(in) :: extra_axes(:) + !< Types with information about some axes that might be used in this file + type(attribute_info), optional, intent(in) :: global_atts(:) + !< Global attributes to write to this file + + type(MOM_infra_file) :: new_file + type(MOM_field) :: new_fields(novars) + + new_file%handle_infra = IO_handle + + call create_MOM_file(new_file, filename, vars, novars, new_fields, & + threading=threading, timeunit=timeunit, G=G, dG=dG, GV=GV, & + checksums=checksums, extra_axes=extra_axes, global_atts=global_atts) + + IO_handle = new_file%handle_infra + call new_file%get_file_fieldtypes(fields(:novars)) +end subroutine create_file + + +!! Create a new netCDF file and register the MOM_fields to be written. +subroutine create_MOM_file(IO_handle, filename, vars, novars, fields, & + threading, timeunit, G, dG, GV, checksums, extra_axes, global_atts) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a files or fileset that is to be + !! opened or reopened for writing + character(len=*), intent(in) :: filename !< full path to the file to create + type(vardesc), intent(in) :: vars(:) !< structures describing fields written to filename + integer, intent(in) :: novars !< number of fields written to filename + type(MOM_field), intent(inout) :: fields(:) !< array of fieldtypes for each variable + integer, optional, intent(in) :: threading !< SINGLE_FILE or MULTIPLE + real, optional, intent(in) :: timeunit !< length of the units for time [s]. The + !! default value is 86400.0, for 1 day. + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is + !! required if the new file uses any + !! vertical grid axes. + integer(kind=int64), optional, intent(in) :: checksums(:,:) !< checksums of vars + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< Types with information about + !! some axes that might be used in this file + type(attribute_info), optional, intent(in) :: global_atts(:) !< Global attributes to + !! write to this file + + logical :: use_lath, use_lonh, use_latq, use_lonq, use_time + logical :: use_layer, use_int, use_periodic + logical :: one_file, domain_set, dim_found + logical, dimension(:), allocatable :: use_extra_axis + type(MOM_axis) :: axis_lath, axis_latq, axis_lonh, axis_lonq + type(MOM_axis) :: axis_layer, axis_int, axis_time, axis_periodic + type(MOM_axis), dimension(:), allocatable :: more_axes ! Axes generated from extra_axes + type(MOM_axis) :: axes(5) ! The axes of a variable + type(MOM_domain_type), pointer :: Domain => NULL() + type(domain1d) :: x_domain, y_domain + integer :: position, numaxes, pack, thread, k, n, m + integer :: num_extra_dims ! The number of extra possible dimensions from extra_axes + integer :: isg, ieg, jsg, jeg, IsgB, IegB, JsgB, JegB + integer :: var_periods, num_periods=0 + real, dimension(:), allocatable :: axis_val ! Axis label values [various] + real, pointer, dimension(:) :: & + gridLatT => NULL(), & ! The latitude of T or B points for the purpose of labeling + gridLatB => NULL(), & ! the output axes, often in units of [degrees_N] or [km] or [m]. + gridLonT => NULL(), & ! The longitude of T or B points for the purpose of labeling + gridLonB => NULL() ! the output axes, often in units of [degrees_E] or [km] or [m]. + character(len=40) :: time_units, x_axis_units, y_axis_units + character(len=8) :: t_grid, t_grid_read + character(len=64) :: ax_name(5) ! The axis names of a variable + + use_lath = .false. ; use_lonh = .false. + use_latq = .false. ; use_lonq = .false. + use_time = .false. ; use_periodic = .false. + use_layer = .false. ; use_int = .false. + num_extra_dims = 0 + if (present(extra_axes)) then + num_extra_dims = size(extra_axes) + if (num_extra_dims > 0) then + allocate(use_extra_axis(num_extra_dims)) ; use_extra_axis = .false. + allocate(more_axes(num_extra_dims)) + endif + endif + + thread = SINGLE_FILE + if (PRESENT(threading)) thread = threading + + domain_set = .false. + if (present(G)) then + domain_set = .true. ; Domain => G%Domain + gridLatT => G%gridLatT ; gridLatB => G%gridLatB + gridLonT => G%gridLonT ; gridLonB => G%gridLonB + x_axis_units = G%x_axis_units ; y_axis_units = G%y_axis_units + isg = G%isg ; ieg = G%ieg ; jsg = G%jsg ; jeg = G%jeg + IsgB = G%IsgB ; IegB = G%IegB ; JsgB = G%JsgB ; JegB = G%JegB + elseif (present(dG)) then + domain_set = .true. ; Domain => dG%Domain + gridLatT => dG%gridLatT ; gridLatB => dG%gridLatB + gridLonT => dG%gridLonT ; gridLonB => dG%gridLonB + x_axis_units = dG%x_axis_units ; y_axis_units = dG%y_axis_units + isg = dG%isg ; ieg = dG%ieg ; jsg = dG%jsg ; jeg = dG%jeg + IsgB = dG%IsgB ; IegB = dG%IegB ; JsgB = dG%JsgB ; JegB = dG%JegB + endif + + one_file = .true. + if (domain_set) one_file = (thread == SINGLE_FILE) + + if (one_file) then + if (domain_set) then + call IO_handle%open(filename, action=OVERWRITE_FILE, & + MOM_domain=domain, threading=thread, fileset=SINGLE_FILE) + else + call IO_handle%open(filename, action=OVERWRITE_FILE, threading=thread, & + fileset=SINGLE_FILE) + endif + else + call IO_handle%open(filename, action=OVERWRITE_FILE, MOM_domain=Domain, & + threading=thread, fileset=thread) + endif + +! Define the coordinates. + do k=1,novars + position = vars(k)%position + if (position == -1) position = position_from_horgrid(vars(k)%hor_grid) + select case (position) + case (CENTER) ; use_lath = .true. ; use_lonh = .true. + case (CORNER) ; use_latq = .true. ; use_lonq = .true. + case (EAST_FACE) ; use_lath = .true. ; use_lonq = .true. + case (NORTH_FACE) ; use_latq = .true. ; use_lonh = .true. + case (0) ! Do nothing. + case default + call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//" has an unrecognized value of postion") + end select + select case (vars(k)%z_grid) + case ('L') ; use_layer = .true. + case ('i') ; use_int = .true. + case ('1') ! Do nothing. + case default + call MOM_error(FATAL, "MOM_io create_file: "//trim(vars(k)%name)//& + " has unrecognized z_grid "//trim(vars(k)%z_grid)) + end select + t_grid = adjustl(vars(k)%t_grid) + select case (t_grid(1:1)) + case ('s', 'a', 'm') ; use_time = .true. + case ('p') ; use_periodic = .true. + if (len_trim(t_grid(2:8)) <= 0) call MOM_error(FATAL, & + "MOM_io create_file: No periodic axis length was specified in "//& + trim(vars(k)%t_grid) // " in the periodic axes of variable "//& + trim(vars(k)%name)//" in file "//trim(filename)) + var_periods = -9999999 + t_grid_read = adjustl(t_grid(2:8)) + read(t_grid_read,*) var_periods + if (var_periods == -9999999) call MOM_error(FATAL, & + "MOM_io create_file: Failed to read the number of periods from "//& + trim(vars(k)%t_grid) // " in the periodic axes of variable "//& + trim(vars(k)%name)//" in file "//trim(filename)) + if (var_periods < 1) call MOM_error(FATAL, "MOM_io create_file: "//& + "variable "//trim(vars(k)%name)//" in file "//trim(filename)//& + " uses a periodic time axis, and must have a positive "//& + "value for the number of periods in "//vars(k)%t_grid ) + if ((num_periods > 0) .and. (var_periods /= num_periods)) & + call MOM_error(FATAL, "MOM_io create_file: "//& + "Only one value of the number of periods can be used in the "//& + "create_file call for file "//trim(filename)//". The second is "//& + "variable "//trim(vars(k)%name)//" with t_grid "//vars(k)%t_grid ) + + num_periods = var_periods + case ('1') ! Do nothing. + case default + call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& + " has unrecognized t_grid "//trim(vars(k)%t_grid)) + end select + + do n=1,5 ; if (len_trim(vars(k)%dim_names(n)) > 0) then + dim_found = .false. + do m=1,num_extra_dims + if (lowercase(trim(vars(k)%dim_names(n))) == lowercase(trim(extra_axes(m)%name))) then + use_extra_axis(m) = .true. + dim_found = .true. + exit + endif + enddo + if (.not.dim_found) call MOM_error(FATAL, "Unable to find a match for dimension "//& + trim(vars(k)%dim_names(n))//" for variable "//trim(vars(k)%name)//" in file "//trim(filename)) + endif ; enddo + enddo + + if ((use_lath .or. use_lonh .or. use_latq .or. use_lonq)) then + if (.not.domain_set) call MOM_error(FATAL, "create_file: "//& + "An ocean_grid_type or dyn_horgrid_type is required to create a file with a horizontal coordinate.") + + call get_domain_components(Domain, x_domain, y_domain) + endif + if ((use_layer .or. use_int) .and. .not.present(GV)) call MOM_error(FATAL, & + "create_file: A vertical grid type is required to create a file with a vertical coordinate.") + + if (use_lath) & + axis_lath = IO_handle%register_axis("lath", units=y_axis_units, longname="Latitude", & + cartesian='Y', domain=y_domain, data=gridLatT(jsg:jeg)) + if (use_lonh) & + axis_lonh = IO_handle%register_axis("lonh", units=x_axis_units, longname="Longitude", & + cartesian='X', domain=x_domain, data=gridLonT(isg:ieg)) + if (use_latq) & + axis_latq = IO_handle%register_axis("latq", units=y_axis_units, longname="Latitude", & + cartesian='Y', domain=y_domain, data=gridLatB(JsgB:JegB), edge_axis=.true.) + if (use_lonq) & + axis_lonq = IO_handle%register_axis("lonq", units=x_axis_units, longname="Longitude", & + cartesian='X', domain=x_domain, data=gridLonB(IsgB:IegB), edge_axis=.true.) + if (use_layer) & + axis_layer = IO_handle%register_axis("Layer", units=trim(GV%zAxisUnits), & + longname="Layer "//trim(GV%zAxisLongName), cartesian='Z', & + sense=1, data=GV%sLayer(1:GV%ke)) + if (use_int) & + axis_int = IO_handle%register_axis("Interface", units=trim(GV%zAxisUnits), & + longname="Interface "//trim(GV%zAxisLongName), cartesian='Z', & + sense=1, data=GV%sInterface(1:GV%ke+1)) + + if (use_time) then ; if (present(timeunit)) then + ! Set appropriate units, depending on the value. + if (timeunit < 0.0) then + time_units = "days" ! The default value. + elseif ((timeunit >= 0.99) .and. (timeunit < 1.01)) then + time_units = "seconds" + elseif ((timeunit >= 3599.0) .and. (timeunit < 3601.0)) then + time_units = "hours" + elseif ((timeunit >= 86399.0) .and. (timeunit < 86401.0)) then + time_units = "days" + elseif ((timeunit >= 3.0e7) .and. (timeunit < 3.2e7)) then + time_units = "years" + else + write(time_units,'(es8.2," s")') timeunit + endif + + axis_time = IO_handle%register_axis("Time", units=time_units, longname="Time", cartesian='T') + else + axis_time = IO_handle%register_axis("Time", units="days", longname="Time", cartesian='T') + endif ; endif + + if (use_periodic) then + if (num_periods <= 1) call MOM_error(FATAL, "MOM_io create_file: "//& + "num_periods for file "//trim(filename)//" must be at least 1.") + ! Define a periodic axis with unit labels. + allocate(axis_val(num_periods)) + do k=1,num_periods ; axis_val(k) = real(k) ; enddo + axis_periodic = IO_handle%register_axis("Period", units="nondimensional", & + longname="Periods for cyclical variables", cartesian='T', data=axis_val) + deallocate(axis_val) + endif + + do m=1,num_extra_dims ; if (use_extra_axis(m)) then + if (allocated(extra_axes(m)%ax_data)) then + more_axes(m) = IO_handle%register_axis(extra_axes(m)%name, units=extra_axes(m)%units, & + longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian, & + sense=extra_axes(m)%sense, data=extra_axes(m)%ax_data) + elseif (trim(extra_axes(m)%cartesian) == "T") then + more_axes(m) = IO_handle%register_axis(extra_axes(m)%name, units=extra_axes(m)%units, & + longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian) + else + ! FMS requires that non-time axes have variables that label their values, even if they are trivial. + allocate (axis_val(extra_axes(m)%ax_size)) + do k=1,extra_axes(m)%ax_size ; axis_val(k) = real(k) ; enddo + more_axes(m) = IO_handle%register_axis(extra_axes(m)%name, units=extra_axes(m)%units, & + longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian, & + sense=extra_axes(m)%sense, data=axis_val) + deallocate(axis_val) + endif + endif ; enddo + + do k=1,novars + numaxes = 0 + position = vars(k)%position + if (position == -1) position = position_from_horgrid(vars(k)%hor_grid) + select case (position) + case (CENTER) + numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_lath ; ax_name(1) = "lonh" ; ax_name(2) = "lath" + case (CORNER) + numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_latq ; ax_name(1) = "lonq" ; ax_name(2) = "latq" + case (EAST_FACE) + numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_lath ; ax_name(1) = "lonq" ; ax_name(2) = "lath" + case (NORTH_FACE) + numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_latq ; ax_name(1) = "lonh" ; ax_name(2) = "latq" + case (0) ! Do nothing. + case default + call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& + " has unrecognized position, hor_grid = "//trim(vars(k)%hor_grid)) + end select + select case (vars(k)%z_grid) + case ('L') ; numaxes = numaxes+1 ; axes(numaxes) = axis_layer ; ax_name(numaxes) = "Layer" + case ('i') ; numaxes = numaxes+1 ; axes(numaxes) = axis_int ; ax_name(numaxes) = "Interface" + case ('1') ! Do nothing. + case default + call MOM_error(FATAL, "MOM_io create_file: "//trim(vars(k)%name)//& + " has unrecognized z_grid "//trim(vars(k)%z_grid)) + end select + + do n=1,numaxes + if ( (len_trim(vars(k)%dim_names(n)) > 0) .and. (trim(ax_name(n)) /= trim(vars(k)%dim_names(n))) ) & + call MOM_error(WARNING, "MOM_io create_file: dimension "//trim(ax_name(n))//& + " of variable "//trim(vars(k)%name)//" in "//trim(filename)//& + " is being set inconsistently as "//trim(vars(k)%dim_names(n))) + enddo + do n=numaxes+1,5 ; if (len_trim(vars(k)%dim_names(n)) > 0) then + dim_found = .false. + do m=1,num_extra_dims + if (lowercase(trim(vars(k)%dim_names(n))) == lowercase(trim(extra_axes(m)%name))) then + numaxes = numaxes+1 ; axes(numaxes) = more_axes(m) + exit + endif + enddo + endif ; enddo + + t_grid = adjustl(vars(k)%t_grid) + select case (t_grid(1:1)) + case ('s', 'a', 'm') ; numaxes = numaxes+1 ; axes(numaxes) = axis_time + case ('p') ; numaxes = numaxes+1 ; axes(numaxes) = axis_periodic + case ('1') ! Do nothing. + case default + call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& + " has unrecognized t_grid "//trim(vars(k)%t_grid)) + end select + + pack = 1 + if (present(checksums)) then + fields(k) = IO_handle%register_field(axes(1:numaxes), vars(k)%name, vars(k)%units, & + vars(k)%longname, pack=pack, checksum=checksums(k,:)) + else + fields(k) = IO_handle%register_field(axes(1:numaxes), vars(k)%name, vars(k)%units, & + vars(k)%longname, pack=pack) + endif + enddo + + if (present(global_atts)) then + do n=1,size(global_atts) + if (allocated(global_atts(n)%name) .and. allocated(global_atts(n)%att_val)) & + call IO_handle%write_attribute(global_atts(n)%name, global_atts(n)%att_val) + enddo + endif + + ! Now write the variables with the axis label values + if (use_lath) call IO_handle%write_field(axis_lath) + if (use_latq) call IO_handle%write_field(axis_latq) + if (use_lonh) call IO_handle%write_field(axis_lonh) + if (use_lonq) call IO_handle%write_field(axis_lonq) + if (use_layer) call IO_handle%write_field(axis_layer) + if (use_int) call IO_handle%write_field(axis_int) + if (use_periodic) call IO_handle%write_field(axis_periodic) + do m=1,num_extra_dims ; if (use_extra_axis(m)) then + call IO_handle%write_field(more_axes(m)) + endif ; enddo + + if (num_extra_dims > 0) then + deallocate(use_extra_axis, more_axes) + endif +end subroutine create_MOM_file + + +!> `reopen_MOM_file` wrapper for the legacy file handle, `file_type`. +!! NOTE: This function may be removed in a future release. +subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, & + timeunit, G, dG, GV, extra_axes, global_atts) + type(file_type), intent(inout) :: IO_handle + !< Handle for a file or fileset that is to be opened or reopened for + !! writing + character(len=*), intent(in) :: filename + !< full path to the file to create + type(vardesc), intent(in) :: vars(:) + !< structures describing fields written to filename + integer, intent(in) :: novars + !< number of fields written to filename + type(fieldtype), intent(inout) :: fields(:) + !< array of fieldtypes for each variable + integer, optional, intent(in) :: threading + !< SINGLE_FILE or MULTIPLE + real, optional, intent(in) :: timeunit + !< length of the units for time [s]. The default value is 86400.0, for 1 + !! day. + type(ocean_grid_type), optional, intent(in) :: G + !< ocean horizontal grid structure; G or dG is required if a new file uses + !! any horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG + !< dynamic horizontal grid structure; G or dG is required if a new file + !! uses any horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV + !< ocean vertical grid structure, which is required if a new file uses any + !! vertical grid axes. + type(axis_info), optional, intent(in) :: extra_axes(:) + !< Types with information about some axes that might be used in this file + type(attribute_info), optional, intent(in) :: global_atts(:) + !< Global attributes to write to this file + + type(MOM_infra_file) :: mfile + !< Wrapper to MOM file + type(MOM_field), allocatable :: mfields(:) + !< Wrapper to MOM fields + integer :: i + + mfile%handle_infra = IO_handle + allocate(mfields(size(fields))) + + call reopen_MOM_file(mfile, filename, vars, novars, mfields, & + threading=threading, timeunit=timeunit, G=G, dG=dG, GV=GV, & + extra_axes=extra_axes, global_atts=global_atts) + + IO_handle = mfile%handle_infra + call get_file_fields(IO_handle, fields) +end subroutine reopen_file + + +!> This routine opens an existing NetCDF file for output. If it +!! does not find the file, a new file is created. It also sets up +!! structures that describe this file and the variables that will +!! later be written to this file. +subroutine reopen_MOM_file(IO_handle, filename, vars, novars, fields, & + threading, timeunit, G, dG, GV, extra_axes, global_atts) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file or fileset that is to be + !! opened or reopened for writing + character(len=*), intent(in) :: filename !< full path to the file to create + type(vardesc), intent(in) :: vars(:) !< structures describing fields written to filename + integer, intent(in) :: novars !< number of fields written to filename + type(MOM_field), intent(inout) :: fields(:) !< array of fieldtypes for each variable + integer, optional, intent(in) :: threading !< SINGLE_FILE or MULTIPLE + real, optional, intent(in) :: timeunit !< length of the units for time [s]. The + !! default value is 86400.0, for 1 day. + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG + !! is required if a new file uses any + !! horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if a new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is + !! required if a new file uses any + !! vertical grid axes. + type(axis_info), optional, intent(in) :: extra_axes(:) !< Types with information about + !! some axes that might be used in this file + type(attribute_info), optional, intent(in) :: global_atts(:) !< Global attributes to + !! write to this file + + type(MOM_domain_type), pointer :: Domain => NULL() + character(len=200) :: check_name, mesg + integer :: length, nvar, thread + logical :: exists, one_file, domain_set + + thread = SINGLE_FILE + if (PRESENT(threading)) thread = threading + + ! For single-file IO, only the root PE is required to set up the fields. + ! This permits calls by either the root PE or all PEs + if (.not. is_root_PE() .and. thread == SINGLE_FILE) return + + ! For multiple IO domains, we would need additional functionality: + ! * Identify ranks as IO PEs + ! * Determine the filename of + ! Neither of these tasks should be handed by MOM6, so we cannot safely use + ! this function. A framework-specific `inquire()` function is needed. + ! Until it exists, we will disable this function. + if (thread == MULTIPLE) & + call MOM_error(FATAL, 'reopen_MOM_file does not yet support files with ' & + // 'multiple I/O domains.') + + check_name = filename + length = len(trim(check_name)) + if (check_name(length-2:length) /= ".nc") check_name = trim(check_name)//".nc" + if (thread /= SINGLE_FILE) check_name = trim(check_name)//".0000" + + inquire(file=check_name,EXIST=exists) + + if (.not.exists) then + call create_MOM_file(IO_handle, filename, vars, novars, fields, & + threading, timeunit, G=G, dG=dG, GV=GV, extra_axes=extra_axes, & + global_atts=global_atts) + else + + domain_set = .false. + if (present(G)) then + domain_set = .true. ; Domain => G%Domain + elseif (present(dG)) then + domain_set = .true. ; Domain => dG%Domain + endif + + one_file = .true. + if (domain_set) one_file = (thread == SINGLE_FILE) + + if (one_file) then + call IO_handle%open(filename, APPEND_FILE, threading=thread) + else + call IO_handle%open(filename, APPEND_FILE, MOM_domain=Domain) + endif + if (.not. IO_handle%file_is_open()) return + + call IO_handle%get_file_info(nvar=nvar) + + if (nvar == -1) then + write (mesg,*) "Reopening file ",trim(filename)," apparently had ",nvar,& + " variables. Clobbering and creating file with ",novars," instead." + call MOM_error(WARNING,"MOM_io: "//mesg) + call create_MOM_file(IO_handle, filename, vars, novars, fields, & + threading, timeunit, G=G, dG=dG, GV=GV, extra_axes=extra_axes, & + global_atts=global_atts) + elseif (nvar /= novars) then + write (mesg,*) "Reopening file ",trim(filename)," with ",novars,& + " variables instead of ",nvar,"." + call MOM_error(FATAL,"MOM_io: "//mesg) + endif + + if (nvar > 0) call IO_handle%get_file_fields(fields(1:nvar)) + endif +end subroutine reopen_MOM_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) + character(len=*), intent(in) :: filename !< name of the file to read + character(len=*), intent(in) :: varname !< variable whose number of time levels + !! are to be returned + integer, optional, intent(in) :: min_dims !< The minimum number of dimensions a variable must have + !! if it has a time dimension. If the variable has 1 less + !! dimension than this, then 0 is returned. + integer :: n_time !< number of time levels varname has in filename + + character(len=256) :: msg + integer :: ndims + integer :: sizes(8) + + n_time = -1 + + ! To do almost the same via MOM_io_infra calls, we could do the following: + ! found = field_exists(filename, varname) + ! if (found) then + ! call open_file(ncid, filename, action=READONLY_FILE, form=NETCDF_FILE, threading=MULTIPLE) + ! call get_file_info(ncid, ntime=n_time) + ! endif + ! However, this does not handle the case where the time axis for the variable is not the record + ! axis and min_dims is not used. + + call get_var_sizes(filename, varname, ndims, sizes, match_case=.false., caller="num_timelevels") + + if (ndims > 0) n_time = sizes(ndims) + + if (present(min_dims)) then + if (ndims < min_dims-1) then + write(msg, '(I3)') min_dims + call MOM_error(WARNING, "num_timelevels: variable "//trim(varname)//" in file "//& + trim(filename)//" has fewer than min_dims = "//trim(msg)//" dimensions.") + n_time = -1 + elseif (ndims == min_dims - 1) then + n_time = 0 + endif + endif + +end function num_timelevels + + +!> get_var_sizes returns the number and size of dimensions associate with a variable in a file. +!! Usually only the root PE does the read, and then the information is broadcast +subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, all_read, dim_names, ncid_in) + character(len=*), intent(in) :: filename !< Name of the file to read, used here in messages + character(len=*), intent(in) :: varname !< The variable name, used here for messages + integer, intent(out) :: ndims !< The number of dimensions to the variable + integer, dimension(:), intent(out) :: sizes !< The dimension sizes, or 0 for extra values + logical, optional, intent(in) :: match_case !< If false, allow for variables name matches to be + !! case insensitive, but take a perfect match if + !! found. The default is true. + character(len=*), optional, intent(in) :: caller !< The name of a calling routine for use in error messages + logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this + !! routine actually do the read, otherwise only + !! root PE reads and then it broadcasts the results. + character(len=*), dimension(:), & + optional, intent(out) :: dim_names !< The names of the dimensions for this variable + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. + + logical :: do_read, do_broadcast + integer, allocatable :: size_msg(:) ! An array combining the number of dimensions and the sizes. + integer :: n, nval + + do_read = is_root_pe() + if (present(all_read)) do_read = all_read .or. do_read + do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read + + if (do_read) call read_var_sizes(filename, varname, ndims, sizes, match_case, caller, dim_names, ncid_in) + + if (do_broadcast) then + ! Distribute the sizes from the root PE. + nval = size(sizes) + 1 + + allocate(size_msg(nval)) + size_msg(1) = ndims + do n=2,nval ; size_msg(n) = sizes(n-1) ; enddo + + call broadcast(size_msg, nval, blocking=.true.) + + ndims = size_msg(1) + do n=2,nval ; sizes(n-1) = size_msg(n) ; enddo + deallocate(size_msg) + + if (present(dim_names) .and. (ndims > 0)) then + nval = min(ndims, size(dim_names)) + call broadcast(dim_names(1:nval), len(dim_names(1)), blocking=.true.) + endif + endif + +end subroutine get_var_sizes + +!> read_var_sizes returns the number and size of dimensions associated with a variable in a file. +!! If the variable is not in the file the returned sizes are all 0 and ndims is -1. +!! Every processor for which this is called does the reading. +subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, dim_names, ncid_in) + character(len=*), intent(in) :: filename !< Name of the file to read, used here in messages + character(len=*), intent(in) :: varname !< The variable name, used here for messages + integer, intent(out) :: ndims !< The number of dimensions to the variable + integer, dimension(:), intent(out) :: sizes !< The dimension sizes, or 0 for extra values + logical, optional, intent(in) :: match_case !< If false, allow for variables name matches to be + !! case insensitive, but take a perfect match if + !! found. The default is true. + character(len=*), & + optional, intent(in) :: caller !< The name of a calling routine for use in error messages + character(len=*), dimension(:), & + optional, intent(out) :: dim_names !< The names of the dimensions for this variable + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. + + character(len=256) :: hdr, dimname + integer, allocatable :: dimids(:) + integer :: varid, ncid, n, status + logical :: success, found + hdr = "get_var_size: " ; if (present(caller)) hdr = trim(hdr)//": " + sizes(:) = 0 ; ndims = -1 + + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid, success=success) + if (.not.success) then + call MOM_error(WARNING, "Unsuccessfully attempted to open file "//trim(filename)) + return + endif + endif + + ! Get the dimension sizes of the variable varname. + call get_varid(varname, ncid, filename, varid, match_case=match_case, found=found) + if (.not.found) then + call MOM_error(WARNING, "Could not find variable "//trim(varname)//" in file "//trim(filename)) + return + endif + + status = NF90_inquire_variable(ncid, varid, ndims=ndims) + if (status /= NF90_NOERR) then + call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& + " Getting number of dimensions of "//trim(varname)//" in "//trim(filename)) + return + endif + if (ndims < 1) return + + allocate(dimids(ndims)) + status = NF90_inquire_variable(ncid, varid, dimids=dimids(1:ndims)) + if (status /= NF90_NOERR) then + call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& + " Getting dimension IDs for "//trim(varname)//" in "//trim(filename)) + deallocate(dimids) ; return + endif + + do n = 1, min(ndims,size(sizes)) + status = NF90_Inquire_Dimension(ncid, dimids(n), name=dimname, len=sizes(n)) + if (status /= NF90_NOERR) call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& + " Getting dimension length for "//trim(varname)//" in "//trim(filename)) + if (present(dim_names)) then + if (n <= size(dim_names)) dim_names(n) = trim(dimname) + endif + enddo + deallocate(dimids) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + +end subroutine read_var_sizes + +!> Read a real scalar variable from a netCDF file with the root PE, and broadcast the +!! results to all the other PEs. +subroutine read_variable_0d(filename, varname, var, ncid_in, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: varname !< The variable name of the data in the file + real, intent(inout) :: var !< The scalar into which to read the data in arbitrary units [A ~> a] + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + + integer :: varid, ncid, rc + character(len=256) :: hdr + hdr = "read_variable_0d" + + if (is_root_pe()) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid) + endif + + call get_varid(varname, ncid, filename, varid, match_case=.false.) + if (varid < 0) call MOM_error(FATAL, "Unable to get netCDF varid for "//trim(varname)//& + " in "//trim(filename)) + rc = NF90_get_var(ncid, varid, var) + if (rc /= NF90_NOERR) call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + + if (present(scale)) var = scale * var + endif + + call broadcast(var, blocking=.true.) +end subroutine read_variable_0d + +!> Read a 1-d real variable from a netCDF file with the root PE, and broadcast the +!! results to all the other PEs. +subroutine read_variable_1d(filename, varname, var, ncid_in, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: varname !< The variable name of the data in the file + real, dimension(:), intent(inout) :: var !< The 1-d array into which to read the data in arbitrary units [A ~> a] + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + + integer :: varid, ncid, rc + character(len=256) :: hdr + hdr = "read_variable_1d" + + if (is_root_pe()) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid) + endif + + call get_varid(varname, ncid, filename, varid, match_case=.false.) + if (varid < 0) call MOM_error(FATAL, "Unable to get netCDF varid for "//trim(varname)//& + " in "//trim(filename)) + rc = NF90_get_var(ncid, varid, var) + if (rc /= NF90_NOERR) call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + + if (present(scale)) then ; if (scale /= 1.0) then + var(:) = scale * var(:) + endif ; endif + endif + + call broadcast(var, size(var), blocking=.true.) +end subroutine read_variable_1d + +!> Read a integer scalar variable from a netCDF file with the root PE, and broadcast the +!! results to all the other PEs. +subroutine read_variable_0d_int(filename, varname, var, ncid_in) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: varname !< The variable name of the data in the file + integer, intent(inout) :: var !< The scalar into which to read the data + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. + + integer :: varid, ncid, rc + character(len=256) :: hdr + hdr = "read_variable_0d_int" + + if (is_root_pe()) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid) + endif + + call get_varid(varname, ncid, filename, varid, match_case=.false.) + if (varid < 0) call MOM_error(FATAL, "Unable to get netCDF varid for "//trim(varname)//& + " in "//trim(filename)) + rc = NF90_get_var(ncid, varid, var) + if (rc /= NF90_NOERR) call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + endif + + call broadcast(var, blocking=.true.) +end subroutine read_variable_0d_int + +!> Read a 1-d integer variable from a netCDF file with the root PE, and broadcast the +!! results to all the other PEs. +subroutine read_variable_1d_int(filename, varname, var, ncid_in) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: varname !< The variable name of the data in the file + integer, dimension(:), intent(inout) :: var !< The 1-d array into which to read the data + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. + + integer :: varid, ncid, rc + character(len=256) :: hdr + hdr = "read_variable_1d_int" + + if (is_root_pe()) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid) + endif + + call get_varid(varname, ncid, filename, varid, match_case=.false.) + if (varid < 0) call MOM_error(FATAL, "Unable to get netCDF varid for "//trim(varname)//& + " in "//trim(filename)) + rc = NF90_get_var(ncid, varid, var) + if (rc /= NF90_NOERR) call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + endif + + call broadcast(var, size(var), blocking=.true.) +end subroutine read_variable_1d_int + +!> Read a 2d array from a netCDF input file and save to a variable. +!! +!! Start and nread lenths may exceed var rank. This allows for reading slices +!! of larger arrays. +!! +!! Previous versions of the model required a time axis on IO fields. This +!! constraint was dropped in later versions. As a result, versions both with +!! and without a time axis now exist. In order to support all such versions, +!! we use a reshaped version of start and nread in order to read the variable +!! as it exists in the file. +!! +!! Certain constraints are still applied to start and nread in order to ensure +!! that varname is a valid 2d array, or contains valid 2d slices. +!! +!! I/O occurs only on the root PE, and data is broadcast to other ranks. +!! Due to potentially large memory communication and storage, this subroutine +!! should only be used when domain-decomposition is unavaialable. +subroutine read_variable_2d(filename, varname, var, start, nread, ncid_in) + character(len=*), intent(in) :: filename !< Name of file to be read + character(len=*), intent(in) :: varname !< Name of variable to be read + real, intent(out) :: var(:,:) !< Output array of variable [arbitrary] + integer, optional, intent(in) :: start(:) !< Starting index on each axis. + integer, optional, intent(in) :: nread(:) !< Number of values to be read along each axis + integer, optional, intent(in) :: ncid_in !< netCDF ID of an opened file. + !! If absent, the file is opened and closed within this routine. + + integer :: ncid, varid + integer :: field_ndims, dim_len + integer, allocatable :: field_dimids(:), field_shape(:) + integer, allocatable :: field_start(:), field_nread(:) + integer :: i, rc + character(len=*), parameter :: hdr = "read_variable_2d: " + + ! Validate shape of start and nread + if (present(start)) then + if (size(start) < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " start must have at least two dimensions.") + endif + + if (present(nread)) then + if (size(nread) < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " nread must have at least two dimensions.") + + if (any(nread(3:) > 1)) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " nread may only read a single level in higher dimensions.") + endif + + ! Since start and nread may be reshaped, we cannot rely on netCDF to ensure + ! that their lengths are equivalent, and must do it here. + if (present(start) .and. present(nread)) then + if (size(start) /= size(nread)) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " start and nread must have the same length.") + endif + + ! Open and read `varname` from `filename` + if (is_root_pe()) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_Read(filename, ncid) + endif + + call get_varid(varname, ncid, filename, varid, match_case=.false.) + if (varid < 0) call MOM_error(FATAL, "Unable to get netCDF varid for "//trim(varname)//& + " in "//trim(filename)) + + ! Query for the dimensionality of the input field + rc = nf90_inquire_variable(ncid, varid, ndims=field_ndims) + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + ": Difficulties reading "//trim(varname)//" from "//trim(filename)) + + ! Confirm that field is at least 2d + if (field_ndims < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) // " " // & + trim(varname) // " from " // trim(filename) // " is not a 2D field.") + + ! If start and nread are present, then reshape them to match field dims + if (present(start) .or. present(nread)) then + allocate(field_shape(field_ndims)) + allocate(field_dimids(field_ndims)) + + rc = nf90_inquire_variable(ncid, varid, dimids=field_dimids) + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + ": Difficulties reading "//trim(varname)//" from "//trim(filename)) + + do i = 1, field_ndims + rc = nf90_inquire_dimension(ncid, field_dimids(i), len=dim_len) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // ": Difficulties reading dimensions from " // trim(filename)) + field_shape(i) = dim_len + enddo + + ! Reshape start(:) and nreads(:) in case ranks differ + allocate(field_start(field_ndims)) + field_start(:) = 1 + if (present(start)) then + dim_len = min(size(start), size(field_start)) + field_start(:dim_len) = start(:dim_len) + endif + + allocate(field_nread(field_ndims)) + field_nread(:2) = field_shape(:2) + field_nread(3:) = 1 + if (present(nread)) field_nread(:2) = nread(:2) + + rc = nf90_get_var(ncid, varid, var, field_start, field_nread) + + deallocate(field_start) + deallocate(field_nread) + deallocate(field_shape) + deallocate(field_dimids) + else + rc = nf90_get_var(ncid, varid, var) + endif + + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + endif + + call broadcast(var, size(var), blocking=.true.) +end subroutine read_variable_2d + + +subroutine read_variable_3d(filename, varname, var, start, nread, ncid_in) + character(len=*), intent(in) :: filename !< Name of file to be read + character(len=*), intent(in) :: varname !< Name of variable to be read + real, intent(out) :: var(:,:,:) !< Output array of variable [arbitrary] + integer, optional, intent(in) :: start(:) !< Starting index on each axis. + integer, optional, intent(in) :: nread(:) !< Number of values to be read along each axis + integer, optional, intent(in) :: ncid_in !< netCDF ID of an opened file. + !! If absent, the file is opened and closed within this routine. + + integer :: ncid, varid + integer :: field_ndims, dim_len + integer, allocatable :: field_dimids(:), field_shape(:) + integer, allocatable :: field_start(:), field_nread(:) + integer :: i, rc + character(len=*), parameter :: hdr = "read_variable_3d: " + + ! Validate shape of start and nread + if (present(start)) then + if (size(start) < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " start must have at least two dimensions.") + endif + + if (present(nread)) then + if (size(nread) < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " nread must have at least two dimensions.") + + if (any(nread(3:) > 1)) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " nread may only read a single level in higher dimensions.") + endif + + ! Since start and nread may be reshaped, we cannot rely on netCDF to ensure + ! that their lengths are equivalent, and must do it here. + if (present(start) .and. present(nread)) then + if (size(start) /= size(nread)) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " start and nread must have the same length.") + endif + + ! Open and read `varname` from `filename` + if (is_root_pe()) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_Read(filename, ncid) + endif + + call get_varid(varname, ncid, filename, varid, match_case=.false.) + if (varid < 0) call MOM_error(FATAL, "Unable to get netCDF varid for "//trim(varname)//& + " in "//trim(filename)) + + ! Query for the dimensionality of the input field + rc = nf90_inquire_variable(ncid, varid, ndims=field_ndims) + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + ": Difficulties reading "//trim(varname)//" from "//trim(filename)) + + ! Confirm that field is at least 2d + if (field_ndims < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) // " " // & + trim(varname) // " from " // trim(filename) // " is not a 2D field.") + + ! If start and nread are present, then reshape them to match field dims + if (present(start) .or. present(nread)) then + allocate(field_shape(field_ndims)) + allocate(field_dimids(field_ndims)) + + rc = nf90_inquire_variable(ncid, varid, dimids=field_dimids) + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + ": Difficulties reading "//trim(varname)//" from "//trim(filename)) + + do i = 1, field_ndims + rc = nf90_inquire_dimension(ncid, field_dimids(i), len=dim_len) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // ": Difficulties reading dimensions from " // trim(filename)) + field_shape(i) = dim_len + enddo + + ! Reshape start(:) and nreads(:) in case ranks differ + allocate(field_start(field_ndims)) + field_start(:) = 1 + if (present(start)) then + dim_len = min(size(start), size(field_start)) + field_start(:dim_len) = start(:dim_len) + endif + + allocate(field_nread(field_ndims)) + field_nread(:3) = field_shape(:3) + !field_nread(3:) = 1 + if (present(nread)) field_nread(:3) = nread(:3) + + rc = nf90_get_var(ncid, varid, var, field_start, field_nread) + + deallocate(field_start) + deallocate(field_nread) + deallocate(field_shape) + deallocate(field_dimids) + else + rc = nf90_get_var(ncid, varid, var) + endif + + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + endif + + call broadcast(var, size(var), blocking=.true.) +end subroutine read_variable_3d + +!> Read a character-string global or variable attribute +subroutine read_attribute_str(filename, attname, att_val, varname, found, all_read, ncid_in) + character(len=*), intent(in) :: filename !< Name of the file to read + character(len=*), intent(in) :: attname !< Name of the attribute to read + character(:), allocatable, intent(out) :: att_val !< The value of the attribute + character(len=*), optional, intent(in) :: varname !< The name of the variable whose attribute will + !! be read. If missing, read a global attribute. + logical, optional, intent(out) :: found !< Returns true if the attribute is found + logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this + !! routine actually do the read, otherwise only + !! root PE reads and then broadcasts the results. + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. + + logical :: do_read, do_broadcast + integer :: rc, ncid, varid, att_type, att_len, info(2) + character(len=256) :: hdr, att_str + character(len=:), dimension(:), allocatable :: tmp_str + hdr = "read_attribute_str" + att_len = 0 + + do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read + do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read + + if (do_read) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid, success=found) + if (present(found)) then ; if (.not.found) do_read = .false. ; endif + endif + endif + + if (do_read) then + rc = NF90_ENOTATT ; att_len = 0 + if (present(varname)) then ! Read a variable attribute + call get_varid(varname, ncid, filename, varid, match_case=.false., found=found) + att_str = "att "//trim(attname)//" for "//trim(varname)//" from "//trim(filename) + else ! Read a global attribute + varid = NF90_GLOBAL + att_str = "global att "//trim(attname)//" from "//trim(filename) + endif + if ((varid > 0) .or. (varid == NF90_GLOBAL)) then ! The named variable does exist, and found would be true. + rc = NF90_inquire_attribute(ncid, varid, attname, xtype=att_type, len=att_len) + if ((.not. present(found)) .or. (rc /= NF90_ENOTATT)) then + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Error getting info for "//trim(att_str)) + if (att_type /= NF90_CHAR) & + call MOM_error(FATAL, trim(hdr)//": Attribute data type is not a char for "//trim(att_str)) + ! if (att_len > len(att_val)) & + ! call MOM_error(FATAL, trim(hdr)//": Insufficiently long string passed in to read "//trim(att_str)) + allocate(character(att_len) :: att_val) + + if (rc == NF90_NOERR) then + rc = NF90_get_att(ncid, varid, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading "//trim(att_str)) + endif + endif + endif + if (present(found)) found = (rc == NF90_NOERR) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + endif + + if (do_broadcast) then + ! Communicate the string length + info(1) = att_len ; info(2) = 0 ; if (do_read .and. found) info(2) = 1 + call broadcast(info, 2, blocking=.true.) + if (present(found)) then + found = (info(2) /= 0) + if (.not. found) return + endif + att_len = info(1) + + if (att_len > 0) then + ! These extra copies are here because broadcast only supports arrays of strings. + allocate(character(att_len) :: tmp_str(1)) + if (.not.do_read) allocate(character(att_len) :: att_val) + if (do_read) tmp_str(1) = att_val + call broadcast(tmp_str, att_len, blocking=.true.) + att_val = tmp_str(1) + elseif (.not.allocated(att_val)) then + allocate(character(4) :: att_val) ; att_val = '' + endif + elseif (.not.allocated(att_val)) then + allocate(character(4) :: att_val) ; att_val = '' + endif +end subroutine read_attribute_str + + +!> Read a 32-bit integer global or variable attribute +subroutine read_attribute_int32(filename, attname, att_val, varname, found, all_read, ncid_in) + character(len=*), intent(in) :: filename !< Name of the file to read + character(len=*), intent(in) :: attname !< Name of the attribute to read + integer(kind=int32), intent(out) :: att_val !< The value of the attribute + character(len=*), optional, intent(in) :: varname !< The name of the variable whose attribute will + !! be read. If missing, read a global attribute. + logical, optional, intent(out) :: found !< Returns true if the attribute is found + logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this + !! routine actually do the read, otherwise only + !! root PE reads and then broadcasts the results. + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. + + logical :: do_read, do_broadcast + integer :: rc, ncid, varid, is_found + character(len=256) :: hdr + hdr = "read_attribute_int32" + att_val = 0 + + do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read + do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read + + if (do_read) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid, success=found) + if (present(found)) then ; if (.not.found) do_read = .false. ; endif + endif + endif + + if (do_read) then + rc = NF90_ENOTATT + if (present(varname)) then ! Read a variable attribute + call get_varid(varname, ncid, filename, varid, match_case=.false., found=found) + if (varid >= 0) then ! The named variable does exist, and found would be true. + rc = NF90_get_att(ncid, varid, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading att "//& + trim(attname)//" for "//trim(varname)//" from "//trim(filename)) + endif + else ! Read a global attribute + rc = NF90_get_att(ncid, NF90_GLOBAL, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading global att "//trim(attname)//" from "//trim(filename)) + endif + if (present(found)) found = (rc == NF90_NOERR) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + endif + + if (do_broadcast) then + if (present(found)) then + is_found = 0 ; if (is_root_pe() .and. found) is_found = 1 + call broadcast(is_found, blocking=.false.) + endif + call broadcast(att_val, blocking=.true.) + if (present(found)) found = (is_found /= 0) + endif + +end subroutine read_attribute_int32 + + +!> Read a 64-bit integer global or variable attribute +subroutine read_attribute_int64(filename, attname, att_val, varname, found, all_read, ncid_in) + character(len=*), intent(in) :: filename !< Name of the file to read + character(len=*), intent(in) :: attname !< Name of the attribute to read + integer(kind=int64), intent(out) :: att_val !< The value of the attribute + character(len=*), optional, intent(in) :: varname !< The name of the variable whose attribute will + !! be read. If missing, read a global attribute. + logical, optional, intent(out) :: found !< Returns true if the attribute is found + logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this + !! routine actually do the read, otherwise only + !! root PE reads and then broadcasts the results. + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. + + logical :: do_read, do_broadcast + integer :: rc, ncid, varid, is_found + character(len=256) :: hdr + hdr = "read_attribute_int64" + att_val = 0 + + do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read + do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read + + if (do_read) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid, success=found) + if (present(found)) then ; if (.not.found) do_read = .false. ; endif + endif + endif + + if (do_read) then + rc = NF90_ENOTATT + if (present(varname)) then ! Read a variable attribute + call get_varid(varname, ncid, filename, varid, match_case=.false., found=found) + if (varid >= 0) then ! The named variable does exist, and found would be true. + rc = NF90_get_att(ncid, varid, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading att "//& + trim(attname)//" for "//trim(varname)//" from "//trim(filename)) + endif + else ! Read a global attribute + rc = NF90_get_att(ncid, NF90_GLOBAL, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading global att "//trim(attname)//" from "//trim(filename)) + endif + if (present(found)) found = (rc == NF90_NOERR) + + rc = NF90_close(ncid) + endif + + if (do_broadcast) then + if (present(found)) then + is_found = 0 ; if (is_root_pe() .and. found) is_found = 1 + call broadcast(is_found, blocking=.false.) + endif + call broadcast(att_val, blocking=.true.) + if (present(found)) found = (is_found /= 0) + endif + +end subroutine read_attribute_int64 + +!> Read a real global or variable attribute +subroutine read_attribute_real(filename, attname, att_val, varname, found, all_read, ncid_in) + character(len=*), intent(in) :: filename !< Name of the file to read + character(len=*), intent(in) :: attname !< Name of the attribute to read + real, intent(out) :: att_val !< The value of the attribute [arbitrary] + character(len=*), optional, intent(in) :: varname !< The name of the variable whose attribute will + !! be read. If missing, read a global attribute. + logical, optional, intent(out) :: found !< Returns true if the attribute is found + logical, optional, intent(in) :: all_read !< If present and true, all PEs that call this + !! routine actually do the read, otherwise only + !! root PE reads and then broadcasts the results. + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. + + logical :: do_read, do_broadcast + integer :: rc, ncid, varid, is_found + character(len=256) :: hdr + hdr = "read_attribute_real" + att_val = 0.0 + + do_read = is_root_pe() ; if (present(all_read)) do_read = all_read .or. do_read + do_broadcast = .true. ; if (present(all_read)) do_broadcast = .not.all_read + + if (do_read) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_read(filename, ncid, success=found) + if (present(found)) then ; if (.not.found) do_read = .false. ; endif + endif + endif + + if (do_read) then + rc = NF90_ENOTATT + if (present(varname)) then ! Read a variable attribute + call get_varid(varname, ncid, filename, varid, match_case=.false., found=found) + if (varid >= 0) then ! The named variable does exist, and found would be true. + rc = NF90_get_att(ncid, varid, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading att "//& + trim(attname)//" for "//trim(varname)//" from "//trim(filename)) + endif + else ! Read a global attribute + rc = NF90_get_att(ncid, NF90_GLOBAL, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //& + " Difficulties reading global att "//trim(attname)//" from "//trim(filename)) + endif + if (present(found)) found = (rc == NF90_NOERR) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + endif + + if (do_broadcast) then + if (present(found)) then + is_found = 0 ; if (is_root_pe() .and. found) is_found = 1 + call broadcast(is_found, blocking=.false.) + endif + call broadcast(att_val, blocking=.true.) + if (present(found)) found = (is_found /= 0) + endif + +end subroutine read_attribute_real + +!> Open a netcdf file for reading, with error handling +subroutine open_file_to_read(filename, ncid, success) + character(len=*), intent(in) :: filename !< path and name of the file to open for reading + integer, intent(out) :: ncid !< The netcdf handle for the file + logical, optional, intent(out) :: success !< Returns true if the file was opened, or if this + !! argument is not present, failure is fatal error. + ! Local variables + integer rc + + rc = NF90_open(trim(filename), NF90_NOWRITE, ncid) + if (present(success)) then + success = (rc == NF90_NOERR) + elseif (rc /= NF90_NOERR) then + call MOM_error(FATAL, "Difficulties opening "//trim(filename)//" - "//trim(NF90_STRERROR(rc)) ) + endif + +end subroutine open_file_to_read + +!> Close a netcdf file that had been opened for reading, with error handling +subroutine close_file_to_read(ncid, filename) + integer, intent(inout) :: ncid !< The netcdf handle for the file to close + character(len=*), optional, intent(in) :: filename !< path and name of the file to close + integer :: rc + if (ncid >= 0) then + rc = NF90_close(ncid) + if (present(filename) .and. (rc /= NF90_NOERR)) then + call MOM_error(WARNING, "Difficulties closing "//trim(filename)//": "//trim(NF90_STRERROR(rc))) + elseif (rc /= NF90_NOERR) then + call MOM_error(WARNING, "Difficulties closing file: "//trim(NF90_STRERROR(rc))) + endif + endif + ncid = -1 +end subroutine close_file_to_read + +!> get_varid finds the netcdf handle for the potentially case-insensitive variable name in a file +subroutine get_varid(varname, ncid, filename, varid, match_case, found) + character(len=*), intent(in) :: varname !< The name of the variable that is being sought + integer, intent(in) :: ncid !< The open netcdf handle for the file + character(len=*), intent(in) :: filename !< name of the file to read, used here in messages + integer, intent(out) :: varid !< The netcdf handle for the variable + logical, optional, intent(in) :: match_case !< If false, allow for variables name matches to be + !! case insensitive, but take a perfect match if + !! found. The default is true. + logical, optional, intent(out) :: found !< Returns true if the attribute is found + + logical :: var_found, insensitive + character(len=256) :: name + integer, allocatable :: varids(:) + integer :: nvars, status, n + + varid = -1 + var_found = .false. + insensitive = .false. ; if (present(match_case)) insensitive = .not.match_case + + if (insensitive) then + ! This code ounddoes a case-insensitive search for a variable in the file. + status = NF90_inquire(ncid, nVariables=nvars) + if (present(found) .and. ((status /= NF90_NOERR) .or. (nvars < 1))) then + found = .false. ; return + elseif (status /= NF90_NOERR) then + call MOM_error(FATAL, "get_varid: Difficulties getting the number of variables in file "//& + trim(filename)//" - "//trim(NF90_STRERROR(status))) + elseif (nvars < 1) then + call MOM_error(FATAL, "get_varid: There appear not to be any variables in "//trim(filename)) + endif + + allocate(varids(nvars)) + + status = nf90_inq_varids(ncid, nvars, varids) + if (status /= NF90_NOERR) then + call MOM_error(WARNING, "get_varid: Difficulties getting the variable IDs in file "//& + trim(filename)//" - "//trim(NF90_STRERROR(status))) + nvars = -1 ! Full error handling will occur after the do-loop. + endif + + do n = 1,nvars + status = nf90_inquire_variable(ncid, varids(n), name=name) + if (status /= NF90_NOERR) then + call MOM_error(WARNING, "get_varid: Difficulties getting a variable name in file "//& + trim(filename)//" - "//trim(NF90_STRERROR(status))) + endif + + if (trim(lowercase(name)) == trim(lowercase(varname))) then + if (var_found) then + call MOM_error(WARNING, "get_varid: Two variables match the case-insensitive name "//& + trim(varname)//" in file "//trim(filename)) + ! Replace the first variable if the second one is a case-sensitive match + if (trim(name) == trim(varname)) varid = varids(n) + else + varid = varids(n) ; var_found = .true. + endif + endif + enddo + if (present(found)) found = var_found + if ((.not.var_found) .and. .not.present(found)) call MOM_error(FATAL, & + "get_varid: variable "//trim(varname)//" was not found in file "//trim(filename)) + + deallocate(varids) + else + status = NF90_INQ_VARID(ncid, trim(varname), varid) + if (present(found)) found = (status == NF90_NOERR) + if ((status /= NF90_NOERR) .and. .not.present(found)) then + call MOM_error(FATAL, "get_varid: Difficulties getting a variable id for "//& + trim(varname)//" in file "//trim(filename)//" - "//trim(NF90_STRERROR(status))) + endif + endif + +end subroutine get_varid + +!> Verify that a file contains a named variable with the expected units. +subroutine verify_variable_units(filename, varname, expected_units, msg, ierr, alt_units) + character(len=*), intent(in) :: filename !< File name + character(len=*), intent(in) :: varname !< Variable name + character(len=*), intent(in) :: expected_units !< Expected units of variable + character(len=*), intent(inout) :: msg !< Message to use for errors + logical, intent(out) :: ierr !< True if an error occurs + character(len=*), optional, intent(in) :: alt_units !< Alterate acceptable units of variable + + ! Local variables + character (len=200) :: units + logical :: units_correct, success + integer :: i, ncid, status, vid + + if (.not.is_root_pe()) then ! Only the root PE should do the verification. + ierr = .false. ; msg = '' ; return + endif + + ierr = .true. + call open_file_to_read(filename, ncid, success) + if (.not.success) then + msg = 'File not found: '//trim(filename) + return + endif + + status = NF90_INQ_VARID(ncid, trim(varname), vid) + if (status /= NF90_NOERR) then + msg = 'Var not found: '//trim(varname) + else + status = NF90_GET_ATT(ncid, vid, "units", units) + if (status /= NF90_NOERR) then + msg = 'Attribute not found: units' + else + ! NF90_GET_ATT can return attributes with null characters, which TRIM will not truncate. + ! This loop replaces any null characters with a space so that the subsequent check + ! between the read units and the expected units will pass + do i=1,LEN_TRIM(units) + if (units(i:i) == CHAR(0)) units(i:i) = " " + enddo + + units_correct = (trim(units) == trim(expected_units)) + if (present(alt_units)) then + units_correct = units_correct .or. (trim(units) == trim(alt_units)) + endif + if (units_correct) then + ierr = .false. + msg = '' + else + msg = 'Units incorrect: '//trim(units)//' /= '//trim(expected_units) + endif + endif + endif + + status = NF90_close(ncid) + +end subroutine verify_variable_units + +!> Returns a vardesc type whose elements have been filled with the provided +!! fields. The argument name is required, while the others are optional and +!! have default values that are empty strings or are appropriate for a 3-d +!! tracer field at the tracer cell centers. +function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_name, & + cmor_units, cmor_longname, conversion, caller, position, dim_names, & + extra_axes, fixed) result(vd) + character(len=*), intent(in) :: name !< variable name + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: hor_grid !< A character string indicating the horizontal + !! position of this variable + character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name + character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable + character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name + real , optional, intent(in) :: conversion !< for unit conversions, such as needed to + !! convert from intensive to extensive + !! [various] or [a A-1 ~> 1] + character(len=*), optional, intent(in) :: caller !< The calling routine for error messages + integer, optional, intent(in) :: position !< A coded integer indicating the horizontal position + !! of this variable if it has such dimensions. + !! Valid values include CORNER, CENTER, EAST_FACE + !! NORTH_FACE, and 0 for no horizontal dimensions. + character(len=*), dimension(:), & + optional, intent(in) :: dim_names !< The names of the dimensions of this variable + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time + logical, optional, intent(in) :: fixed !< If true, this does not evolve with time + type(vardesc) :: vd !< vardesc type that is created + + character(len=120) :: cllr + cllr = "var_desc" + if (present(caller)) cllr = trim(caller) + + call safe_string_copy(name, vd%name, "vd%name", cllr) + + vd%longname = "" ; vd%units = "" + vd%hor_grid = 'h' ; vd%position = CENTER ; vd%z_grid = 'L' ; vd%t_grid = 's' + if (present(dim_names)) vd%z_grid = '1' ! In this case the names are used to set the non-horizontal axes + if (present(fixed)) then ; if (fixed) vd%t_grid = '1' ; endif + + vd%cmor_field_name = "" + vd%cmor_units = "" + vd%cmor_longname = "" + vd%conversion = 1.0 + vd%dim_names(:) = "" + + call modify_vardesc(vd, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, position=position, dim_names=dim_names, & + cmor_field_name=cmor_field_name, cmor_units=cmor_units, & + cmor_longname=cmor_longname, conversion=conversion, caller=cllr, & + extra_axes=extra_axes) + +end function var_desc + + +!> This routine modifies the named elements of a vardesc type. +!! All arguments are optional, except the vardesc type to be modified. +subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & + cmor_field_name, cmor_units, cmor_longname, conversion, caller, position, dim_names, & + extra_axes) + type(vardesc), intent(inout) :: vd !< vardesc type that is modified + character(len=*), optional, intent(in) :: name !< name of variable + character(len=*), optional, intent(in) :: units !< units of variable + character(len=*), optional, intent(in) :: longname !< long name of variable + character(len=*), optional, intent(in) :: hor_grid !< horizontal staggering of variable + character(len=*), optional, intent(in) :: z_grid !< vertical staggering of variable + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name + character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable + character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name + real , optional, intent(in) :: conversion !< A multiplicative factor for unit conversions, + !! such as needed to convert from intensive to + !! extensive or dimensional consistency testing + !! [various] or [a A-1 ~> 1] + character(len=*), optional, intent(in) :: caller !< The calling routine for error messages + integer, optional, intent(in) :: position !< A coded integer indicating the horizontal position + !! of this variable if it has such dimensions. + !! Valid values include CORNER, CENTER, EAST_FACE + !! NORTH_FACE, and 0 for no horizontal dimensions. + character(len=*), dimension(:), & + optional, intent(in) :: dim_names !< The names of the dimensions of this variable + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time + + character(len=120) :: cllr + integer :: n + + cllr = "mod_vardesc" ; if (present(caller)) cllr = trim(caller) + + if (present(name)) call safe_string_copy(name, vd%name, "vd%name", cllr) + + if (present(longname)) call safe_string_copy(longname, vd%longname, & + "vd%longname of "//trim(vd%name), cllr) + if (present(units)) call safe_string_copy(units, vd%units, & + "vd%units of "//trim(vd%name), cllr) + if (present(position)) then + vd%position = position + select case (position) + case (CENTER) ; vd%hor_grid = 'T' + case (CORNER) ; vd%hor_grid = 'Bu' + case (EAST_FACE) ; vd%hor_grid = 'Cu' + case (NORTH_FACE) ; vd%hor_grid = 'Cv' + case (0) ; vd%hor_grid = '1' + case default + call MOM_error(FATAL, "modify_vardesc: "//trim(vd%name)//" has unrecognized position argument") + end select + endif + if (present(hor_grid)) then + call safe_string_copy(hor_grid, vd%hor_grid, "vd%hor_grid of "//trim(vd%name), cllr) + vd%position = position_from_horgrid(vd%hor_grid) + if (present(caller) .and. (vd%position == -1)) then + call MOM_error(FATAL, "modify_vardesc called by "//trim(caller)//": "//trim(vd%name)//& + " has an unrecognized hor_grid argument "//trim(vd%hor_grid)) + elseif (vd%position == -1) then + call MOM_error(FATAL, "modify_vardesc called with bad hor_grid argument "//trim(vd%hor_grid)) + endif + endif + if (present(z_grid)) call safe_string_copy(z_grid, vd%z_grid, & + "vd%z_grid of "//trim(vd%name), cllr) + if (present(t_grid)) call safe_string_copy(t_grid, vd%t_grid, & + "vd%t_grid of "//trim(vd%name), cllr) + + if (present(cmor_field_name)) call safe_string_copy(cmor_field_name, vd%cmor_field_name, & + "vd%cmor_field_name of "//trim(vd%name), cllr) + if (present(cmor_units)) call safe_string_copy(cmor_units, vd%cmor_units, & + "vd%cmor_units of "//trim(vd%name), cllr) + if (present(cmor_longname)) call safe_string_copy(cmor_longname, vd%cmor_longname, & + "vd%cmor_longname of "//trim(vd%name), cllr) + + if (present(dim_names)) then + do n=1,min(5,size(dim_names)) ; if (len_trim(dim_names(n)) > 0) then + call safe_string_copy(dim_names(n), vd%dim_names(n), "vd%dim_names of "//trim(vd%name), cllr) + endif ; enddo + endif + + if (present(extra_axes)) then + do n=1,size(extra_axes) ; if (len_trim(extra_axes(n)%name) > 0) then + vd%extra_axes(n) = extra_axes(n) + endif ; enddo + endif + +end subroutine modify_vardesc + +integer function position_from_horgrid(hor_grid) + character(len=*), intent(in) :: hor_grid !< horizontal staggering of variable + + select case (trim(hor_grid)) + case ('h') ; position_from_horgrid = CENTER + case ('q') ; position_from_horgrid = CORNER + case ('u') ; position_from_horgrid = EAST_FACE + case ('v') ; position_from_horgrid = NORTH_FACE + case ('T') ; position_from_horgrid = CENTER + case ('Bu') ; position_from_horgrid = CORNER + case ('Cu') ; position_from_horgrid = EAST_FACE + case ('Cv') ; position_from_horgrid = NORTH_FACE + case ('1') ; position_from_horgrid = 0 + case default ; position_from_horgrid = -1 ! This is a bad-value flag. + end select +end function position_from_horgrid + +!> Store information that can be used to create an axis in a subsequent call to create_file. +subroutine set_axis_info(axis, name, units, longname, ax_size, ax_data, cartesian, sense) + type(axis_info), intent(inout) :: axis !< A type with information about a named axis + character(len=*), intent(in) :: name !< The name of this axis for use in files + character(len=*), optional, intent(in) :: units !< The units of the axis labels + character(len=*), optional, intent(in) :: longname !< Long name of the axis variable + integer, optional, intent(in) :: ax_size !< The number of elements in this axis + real, dimension(:), optional, intent(in) :: ax_data !< The values of the data on the axis [arbitrary] + character(len=*), optional, intent(in) :: cartesian !< A variable indicating which direction this axis + !! axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' (the default) for none. + integer, optional, intent(in) :: sense !< This is 1 for axes whose values increase upward, or -1 + !! if they increase downward. The default, 0, is ignored. + + call safe_string_copy(name, axis%name, "axis%name of "//trim(name), "set_axis_info") + ! Set the default values. + axis%longname = trim(axis%name) ; axis%units = "" ; axis%cartesian = "N" ; axis%sense = 0 + + if (present(longname)) call safe_string_copy(longname, axis%longname, & + "axis%longname of "//trim(name), "set_axis_info") + if (present(units)) call safe_string_copy(units, axis%units, & + "axis%units of "//trim(name), "set_axis_info") + if (present(cartesian)) call safe_string_copy(cartesian, axis%cartesian, & + "axis%cartesian of "//trim(name), "set_axis_info") + if (present(sense)) axis%sense = sense + + if (.not.(present(ax_size) .or. present(ax_data)) ) then + call MOM_error(FATAL, "set_axis_info called for "//trim(name)//& + "without either an ax_size or an ax_data argument.") + elseif (present(ax_size) .and. present(ax_data)) then + if (size(ax_data) /= ax_size) call MOM_error(FATAL, "set_axis_info called for "//trim(name)//& + "with an inconsistent value of ax_size and size of ax_data.") + endif + + if (present(ax_size)) then + axis%ax_size = ax_size + else + axis%ax_size = size(ax_data) + endif + if (present(ax_data)) then + allocate(axis%ax_data(axis%ax_size)) ; axis%ax_data(:) = ax_data(:) + endif + +end subroutine set_axis_info + +!> Delete the information in an array of axis_info types and deallocate memory in them. +subroutine delete_axis_info(axes) + type(axis_info), dimension(:), intent(inout) :: axes !< An array with information about named axes + + integer :: n + do n=1,size(axes) + axes(n)%name = "" ; axes(n)%longname = "" ; axes(n)%units = "" ; axes(n)%cartesian = "N" + axes(n)%sense = 0 ; axes(n)%ax_size = 0 + if (allocated(axes(n)%ax_data)) deallocate(axes(n)%ax_data) + enddo +end subroutine delete_axis_info + + +!> Retrieve the information from an axis_info type. +subroutine get_axis_info(axis,name,longname,units,cartesian,ax_size,ax_data) + type(axis_info), intent(in) :: axis !< An axis type + character(len=*), intent(out), optional :: name !< The axis name. + character(len=*), intent(out), optional :: longname !< The axis longname. + character(len=*), intent(out), optional :: units !< The axis units. + character(len=*), intent(out), optional :: cartesian !< The cartesian attribute + !! of the axis [X,Y,Z,T]. + integer, intent(out), optional :: ax_size !< The size of the axis. + real, optional, allocatable, dimension(:), intent(out) :: ax_data !< The axis label data [arbitrary] + + if (present(ax_data)) then + if (allocated(ax_data)) deallocate(ax_data) + allocate(ax_data(axis%ax_size)) + ax_data(:) = axis%ax_data + endif + + if (present(name)) name = axis%name + if (present(longname)) longname = axis%longname + if (present(units)) units = axis%units + if (present(cartesian)) cartesian = axis%cartesian + if (present(ax_size)) ax_size = axis%ax_size + +end subroutine get_axis_info + +!> Store information that can be used to create an attribute in a subsequent call to create_file. +subroutine set_attribute_info(attribute, name, str_value) + type(attribute_info), intent(inout) :: attribute !< A type with information about a named attribute + character(len=*), intent(in) :: name !< The name of this attribute for use in files + character(len=*), intent(in) :: str_value !< The value of this attribute + + attribute%name = trim(name) + attribute%att_val = trim(str_value) +end subroutine set_attribute_info + +!> Delete the information in an array of attribute_info types and deallocate memory in them. +subroutine delete_attribute_info(atts) + type(attribute_info), dimension(:), intent(inout) :: atts !< An array of global attributes + + integer :: n + do n=1,size(atts) + if (allocated(atts(n)%name)) deallocate(atts(n)%name) + if (allocated(atts(n)%att_val)) deallocate(atts(n)%att_val) + enddo +end subroutine delete_attribute_info + + +!> This function returns the CMOR standard name given a CMOR longname, based on +!! the standard pattern of character conversions. +function cmor_long_std(longname) result(std_name) + character(len=*), intent(in) :: longname !< The CMOR longname being converted + character(len=len(longname)) :: std_name !< The CMOR standard name generated from longname + + integer :: k + + std_name = lowercase(longname) + + do k=1, len_trim(std_name) + if (std_name(k:k) == ' ') std_name(k:k) = '_' + enddo + +end function cmor_long_std + +!> This routine queries vardesc +subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & + cmor_field_name, cmor_units, cmor_longname, conversion, caller, & + extra_axes, position, dim_names) + type(vardesc), intent(in) :: vd !< vardesc type that is queried + character(len=*), optional, intent(out) :: name !< name of variable + character(len=*), optional, intent(out) :: units !< units of variable + character(len=*), optional, intent(out) :: longname !< long name of variable + character(len=*), optional, intent(out) :: hor_grid !< horizontal staggering of variable + character(len=*), optional, intent(out) :: z_grid !< verticle staggering of variable + character(len=*), optional, intent(out) :: t_grid !< time description: s, p, or 1 + character(len=*), optional, intent(out) :: cmor_field_name !< CMOR name + character(len=*), optional, intent(out) :: cmor_units !< CMOR physical dimensions of variable + character(len=*), optional, intent(out) :: cmor_longname !< CMOR long name + real , optional, intent(out) :: conversion !< for unit conversions, such as needed to + !! convert from intensive to extensive + !! [various] or [a A-1 ~> 1] + character(len=*), optional, intent(in) :: caller !< calling routine? + type(axis_info), dimension(5), & + optional, intent(out) :: extra_axes !< dimensions other than space-time + integer, optional, intent(out) :: position !< A coded integer indicating the horizontal position + !! of this variable if it has such dimensions. + !! Valid values include CORNER, CENTER, EAST_FACE + !! NORTH_FACE, and 0 for no horizontal dimensions. + character(len=*), dimension(:), & + optional, intent(out) :: dim_names !< The names of the dimensions of this variable + + integer :: n + integer, parameter :: nmax_extraaxes = 5 + character(len=120) :: cllr, varname + cllr = "mod_vardesc" + if (present(caller)) cllr = trim(caller) + + if (present(name)) call safe_string_copy(vd%name, name, & + "vd%name of "//trim(vd%name), cllr) + if (present(longname)) call safe_string_copy(vd%longname, longname, & + "vd%longname of "//trim(vd%name), cllr) + if (present(units)) call safe_string_copy(vd%units, units, & + "vd%units of "//trim(vd%name), cllr) + if (present(hor_grid)) call safe_string_copy(vd%hor_grid, hor_grid, & + "vd%hor_grid of "//trim(vd%name), cllr) + if (present(z_grid)) call safe_string_copy(vd%z_grid, z_grid, & + "vd%z_grid of "//trim(vd%name), cllr) + if (present(t_grid)) call safe_string_copy(vd%t_grid, t_grid, & + "vd%t_grid of "//trim(vd%name), cllr) + + if (present(cmor_field_name)) call safe_string_copy(vd%cmor_field_name, cmor_field_name, & + "vd%cmor_field_name of "//trim(vd%name), cllr) + if (present(cmor_units)) call safe_string_copy(vd%cmor_units, cmor_units, & + "vd%cmor_units of "//trim(vd%name), cllr) + if (present(cmor_longname)) call safe_string_copy(vd%cmor_longname, cmor_longname, & + "vd%cmor_longname of "//trim(vd%name), cllr) + if (present(position)) then + position = vd%position + if (position == -1) position = position_from_horgrid(vd%hor_grid) + endif + if (present(dim_names)) then + do n=1,min(5,size(dim_names)) + call safe_string_copy(vd%dim_names(n), dim_names(n), "vd%dim_names of "//trim(vd%name), cllr) + enddo + endif + + if (present(extra_axes)) then + ! save_restart expects 5 extra axes (can be empty) + do n=1, nmax_extraaxes + if (vd%extra_axes(n)%ax_size>=1) then + extra_axes(n) = vd%extra_axes(n) + else + ! return an empty axis + write(varname,"('dummy',i1.1)") n + call set_axis_info(extra_axes(n), name=trim(varname), ax_size=1) + endif + enddo + endif + +end subroutine query_vardesc + + +!> Read a scalar from file using infrastructure I/O. +subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain, & + global_file, file_may_be_4d) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: fieldname !< Field variable name + real, intent(inout) :: data !< Field value in arbitrary units [A ~> a] + integer, optional, intent(in) :: timelevel !< Time level to read in file + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< Model domain decomposition + logical, optional, intent(in) :: global_file !< If true, read from a single file + logical, optional, intent(in) :: file_may_be_4d !< If true, fields may be stored + !! as 4d arrays in the file. + + call read_field(filename, fieldname, data, & + timelevel=timelevel, scale=scale, MOM_Domain=MOM_Domain, & + global_file=global_file, file_may_be_4d=file_may_be_4d & + ) +end subroutine MOM_read_data_0d + + +!> Read a scalar integer from file using infrastructure I/O. +subroutine MOM_read_data_0d_int(filename, fieldname, data, timelevel) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: fieldname !< Field variable name + integer, intent(inout) :: data !< Field value + integer, optional, intent(in) :: timelevel !< Time level to read in file + + call read_field(filename, fieldname, data, timelevel=timelevel) +end subroutine MOM_read_data_0d_int + + +!> Read a 1d array from file using infrastructure I/O. +subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain, & + global_file, file_may_be_4d) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: fieldname !< Field variable name + real, dimension(:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] + integer, optional, intent(in) :: timelevel !< Time level to read in file + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< Model domain decomposition + logical, optional, intent(in) :: global_file !< If true, read from a single file + logical, optional, intent(in) :: file_may_be_4d !< If true, fields may be stored + !! as 4d arrays in the file. + + call read_field(filename, fieldname, data, & + timelevel=timelevel, scale=scale, MOM_Domain=MOM_Domain, & + global_file=global_file, file_may_be_4d=file_may_be_4d & + ) +end subroutine MOM_read_data_1d + + +!> Read a 1d integer array from file using infrastructure I/O. +subroutine MOM_read_data_1d_int(filename, fieldname, data, timelevel) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: fieldname !< Field variable name + integer, dimension(:), intent(inout) :: data !< Field value + integer, optional, intent(in) :: timelevel !< Time level to read in file + + call read_field(filename, fieldname, data, timelevel=timelevel) +end subroutine MOM_read_data_1d_int + + +!> Read a 2d array from file using infrastructure I/O. +subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale, global_file, file_may_be_4d) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: fieldname !< Field variable name + real, dimension(:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] + type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + integer, optional, intent(in) :: timelevel !< Time level to read in file + integer, optional, intent(in) :: position !< Grid positioning flag + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + logical, optional, intent(in) :: global_file !< If true, read from a single file + logical, optional, intent(in) :: file_may_be_4d !< If true, fields may be stored + !! as 4d arrays in the file. + + integer :: turns ! Number of quarter-turns from input to model grid + real, allocatable :: data_in(:,:) ! Field array on the input grid in arbitrary units [A ~> a] + + turns = MOM_domain%turns + if (turns == 0) then + call read_field(filename, fieldname, data, MOM_Domain, & + timelevel=timelevel, position=position, scale=scale, & + global_file=global_file, file_may_be_4d=file_may_be_4d & + ) + else + call allocate_rotated_array(data, [1,1], -turns, data_in) + call read_field(filename, fieldname, data_in, MOM_Domain%domain_in, & + timelevel=timelevel, position=position, scale=scale, & + global_file=global_file, file_may_be_4d=file_may_be_4d & + ) + call rotate_array(data_in, turns, data) + deallocate(data_in) + endif +end subroutine MOM_read_data_2d + + +!> Read a 2d array (which might have halos) from a file using native netCDF I/O. +subroutine read_netCDF_data_2d(filename, fieldname, values, MOM_Domain, & + timelevel, position, rescale) + character(len=*), intent(in) :: filename + !< Input filename + character(len=*), intent(in) :: fieldname + !< Field variable name + real, intent(inout) :: values(:,:) + !< Field values read from the file. It would be intent(out) but for the + !! need to preserve any initialized values in the halo regions. + type(MOM_domain_type), intent(in) :: MOM_Domain + !< Model domain decomposition + integer, optional, intent(in) :: timelevel + !< Time level to read in file + integer, optional, intent(in) :: position + !< Grid positioning flag + real, optional, intent(in) :: rescale + !< Rescale factor, omitting this is the same as setting it to 1. + + integer :: turns + ! Number of quarter-turns from input to model grid + real, allocatable :: values_in(:,:) + ! Field array on the unrotated input grid + type(MOM_netcdf_file) :: handle + ! netCDF file handle + + ! General-purpose IO will require the following arguments, but they are not + ! yet implemented, so we raise an error if they are present. + + ! Fields are currently assumed on cell centers, and position is unsupported + if (present(position)) & + call MOM_error(FATAL, 'read_netCDF_data: position is not yet supported.') + + ! Timelevels are not yet supported + if (present(timelevel)) & + call MOM_error(FATAL, 'read_netCDF_data: timelevel is not yet supported.') + + call handle%open(filename, action=READONLY_FILE, MOM_domain=MOM_domain) + call handle%update() + + turns = MOM_domain%turns + if (turns == 0) then + call handle%read(fieldname, values, rescale=rescale) + else + call allocate_rotated_array(values, [1,1], -turns, values_in) + call handle%read(fieldname, values_in, rescale=rescale) + call rotate_array(values_in, turns, values) + deallocate(values_in) + endif + + call handle%close() +end subroutine read_netCDF_data_2d + + +!> Read a 2d region array from file using infrastructure I/O. +subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale, turns) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: fieldname !< Field variable name + real, dimension(:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] + integer, dimension(:), intent(in) :: start !< Starting index for each axis. + !! In 2d, start(3:4) must be 1. + integer, dimension(:), intent(in) :: nread !< Number of values to read along each axis. + !! In 2d, nread(3:4) must be 1. + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< Model domain decomposition + logical, optional, intent(in) :: no_domain !< If true, field does not use + !! domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + integer, optional, intent(in) :: turns !< Number of quarter turns from + !! input to model grid + + integer :: qturns ! Number of quarter turns + real, allocatable :: data_in(:,:) ! Field array on the input grid in arbitrary units [A ~> a] + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call read_field(filename, fieldname, data, start, nread, & + MOM_Domain=MOM_Domain, no_domain=no_domain, scale=scale & + ) + else + call allocate_rotated_array(data, [1,1], -qturns, data_in) + call read_field(filename, fieldname, data_in, start, nread, & + MOM_Domain=MOM_Domain%domain_in, no_domain=no_domain, scale=scale & + ) + call rotate_array(data_in, qturns, data) + deallocate(data_in) + endif +end subroutine MOM_read_data_2d_region + + +!> Read a 3d array from file using infrastructure I/O. +subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale, global_file, file_may_be_4d) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: fieldname !< Field variable name + real, dimension(:,:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] + type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + integer, optional, intent(in) :: timelevel !< Time level to read in file + integer, optional, intent(in) :: position !< Grid positioning flag + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + logical, optional, intent(in) :: global_file !< If true, read from a single file + logical, optional, intent(in) :: file_may_be_4d !< If true, fields may be stored + !! as 4d arrays in the file. + + integer :: turns ! Number of quarter-turns from input to model grid + real, allocatable :: data_in(:,:,:) ! Field array on the input grid in arbitrary units [A ~> a] + + turns = MOM_domain%turns + if (turns == 0) then + call read_field(filename, fieldname, data, MOM_Domain, & + timelevel=timelevel, position=position, scale=scale, & + global_file=global_file, file_may_be_4d=file_may_be_4d & + ) + else + call allocate_rotated_array(data, [1,1,1], -turns, data_in) + call read_field(filename, fieldname, data_in, MOM_Domain%domain_in, & + timelevel=timelevel, position=position, scale=scale, & + global_file=global_file, file_may_be_4d=file_may_be_4d & + ) + call rotate_array(data_in, turns, data) + deallocate(data_in) + endif +end subroutine MOM_read_data_3d + +!> Read a 3d region array from file using infrastructure I/O. +subroutine MOM_read_data_3d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale, turns) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: fieldname !< Field variable name + real, dimension(:,:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] + integer, dimension(:), intent(in) :: start !< Starting index for each axis. + integer, dimension(:), intent(in) :: nread !< Number of values to read along each axis. + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< Model domain decomposition + logical, optional, intent(in) :: no_domain !< If true, field does not use + !! domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + integer, optional, intent(in) :: turns !< Number of quarter turns from + !! input to model grid + + integer :: qturns ! Number of quarter turns + real, allocatable :: data_in(:,:,:) ! Field array on the input grid in arbitrary units [A ~> a] + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call read_field(filename, fieldname, data, start, nread, & + MOM_Domain=MOM_Domain, no_domain=no_domain, scale=scale & + ) + else + call allocate_rotated_array(data, [1,1,1], -qturns, data_in) + call read_field(filename, fieldname, data_in, start, nread, & + MOM_Domain=MOM_Domain%domain_in, no_domain=no_domain, scale=scale & + ) + call rotate_array(data_in, qturns, data) + deallocate(data_in) + endif +end subroutine MOM_read_data_3d_region + +!> Read a 4d array from file using infrastructure I/O. +subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale, global_file) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: fieldname !< Field variable name + real, dimension(:,:,:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] + type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + integer, optional, intent(in) :: timelevel !< Time level to read in file + integer, optional, intent(in) :: position !< Grid positioning flag + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + logical, optional, intent(in) :: global_file !< If true, read from a single file + + integer :: turns ! Number of quarter-turns from input to model grid + real, allocatable :: data_in(:,:,:,:) ! Field array on the input grid in arbitrary units [A ~> a] + + turns = MOM_domain%turns + + if (turns == 0) then + call read_field(filename, fieldname, data, MOM_Domain, & + timelevel=timelevel, position=position, scale=scale, & + global_file=global_file & + ) + else + ! Read field along the input grid and rotate to the model grid + call allocate_rotated_array(data, [1,1,1,1], -turns, data_in) + call read_field(filename, fieldname, data_in, MOM_Domain%domain_in, & + timelevel=timelevel, position=position, scale=scale, & + global_file=global_file & + ) + call rotate_array(data_in, turns, data) + deallocate(data_in) + endif +end subroutine MOM_read_data_4d + + +!> Read a 2d vector tuple from file using infrastructure I/O. +subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + timelevel, stagger, scalar_pair, scale) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: u_fieldname !< Field variable name in u + character(len=*), intent(in) :: v_fieldname !< Field variable name in v + real, dimension(:,:), intent(inout) :: u_data !< Field value at u points in arbitrary units [A ~> a] + real, dimension(:,:), intent(inout) :: v_data !< Field value at v points in arbitrary units [A ~> a] + type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + integer, optional, intent(in) :: timelevel !< Time level to read in file + integer, optional, intent(in) :: stagger !< Grid staggering flag + logical, optional, intent(in) :: scalar_pair !< True if tuple is not a vector + real, optional, intent(in) :: scale !< A scaling factor that the vector is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + + integer :: turns ! Number of quarter-turns from input to model grid + real, allocatable :: u_data_in(:,:), v_data_in(:,:) ! [uv] on the input grid in arbitrary units [A ~> a] + + turns = MOM_Domain%turns + if (turns == 0) then + call read_vector(filename, u_fieldname, v_fieldname, & + u_data, v_data, MOM_domain, timelevel=timelevel, stagger=stagger, & + scalar_pair=scalar_pair, scale=scale & + ) + else + call allocate_rotated_array(u_data, [1,1], -turns, u_data_in) + call allocate_rotated_array(v_data, [1,1], -turns, v_data_in) + call read_vector(filename, u_fieldname, v_fieldname, & + u_data_in, v_data_in, MOM_domain%domain_in, timelevel=timelevel, & + stagger=stagger, scalar_pair=scalar_pair, scale=scale & + ) + if (scalar_pair) then + call rotate_array_pair(u_data_in, v_data_in, turns, u_data, v_data) + else + call rotate_vector(u_data_in, v_data_in, turns, u_data, v_data) + endif + deallocate(v_data_in) + deallocate(u_data_in) + endif +end subroutine MOM_read_vector_2d + + +!> Read a 3d vector tuple from file using infrastructure I/O. +subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + timelevel, stagger, scalar_pair, scale) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: u_fieldname !< Field variable name in u + character(len=*), intent(in) :: v_fieldname !< Field variable name in v + real, dimension(:,:,:), intent(inout) :: u_data !< Field value in u in arbitrary units [A ~> a] + real, dimension(:,:,:), intent(inout) :: v_data !< Field value in v in arbitrary units [A ~> a] + type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + integer, optional, intent(in) :: timelevel !< Time level to read in file + integer, optional, intent(in) :: stagger !< Grid staggering flag + logical, optional, intent(in) :: scalar_pair !< True if tuple is not a vector + real, optional, intent(in) :: scale !< A scaling factor that the vector is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + + integer :: turns ! Number of quarter-turns from input to model grid + real, allocatable :: u_data_in(:,:,:), v_data_in(:,:,:) ! [uv] on the input grid in arbitrary units [A ~> a] + + turns = MOM_Domain%turns + if (turns == 0) then + call read_vector(filename, u_fieldname, v_fieldname, & + u_data, v_data, MOM_domain, timelevel=timelevel, stagger=stagger, & + scalar_pair=scalar_pair, scale=scale & + ) + else + call allocate_rotated_array(u_data, [1,1,1], -turns, u_data_in) + call allocate_rotated_array(v_data, [1,1,1], -turns, v_data_in) + call read_vector(filename, u_fieldname, v_fieldname, & + u_data_in, v_data_in, MOM_domain%domain_in, timelevel=timelevel, & + stagger=stagger, scalar_pair=scalar_pair, scale=scale & + ) + if (scalar_pair) then + call rotate_array_pair(u_data_in, v_data_in, turns, u_data, v_data) + else + call rotate_vector(u_data_in, v_data_in, turns, u_data, v_data) + endif + deallocate(v_data_in) + deallocate(u_data_in) + endif +end subroutine MOM_read_vector_3d + +!> Write a 4d field to an output file, potentially with rotation +subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value in the units used in the file [a] + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + + real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units [a] or + ! rescaled [A ~> a] then [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if ((qturns == 0) .and. (scale_fac == 1.0)) then + call write_field(IO_handle, field_md, MOM_domain, field, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + else + call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + if (scale_fac /= 1.0) call rescale_comp_data(MOM_Domain, field_rot, scale_fac) + call write_field(IO_handle, field_md, MOM_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + deallocate(field_rot) + endif +end subroutine MOM_write_field_legacy_4d + + +!> Write a 3d field to an output file, potentially with rotation +subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value in the units used in the file [a] + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + + + real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units [a] or + ! rescaled [A ~> a] then [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if ((qturns == 0) .and. (scale_fac == 1.0)) then + call write_field(IO_handle, field_md, MOM_domain, field, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + else + call allocate_rotated_array(field, [1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + if (scale_fac /= 1.0) call rescale_comp_data(MOM_Domain, field_rot, scale_fac) + call write_field(IO_handle, field_md, MOM_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + deallocate(field_rot) + endif +end subroutine MOM_write_field_legacy_3d + + +!> Write a 2d field to an output file, potentially with rotation +subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + + + real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units [a] or + ! rescaled [A ~> a] then [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if ((qturns == 0) .and. (scale_fac == 1.0)) then + call write_field(IO_handle, field_md, MOM_domain, field, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + else + call allocate_rotated_array(field, [1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + if (scale_fac /= 1.0) call rescale_comp_data(MOM_Domain, field_rot, scale_fac) + call write_field(IO_handle, field_md, MOM_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + deallocate(field_rot) + endif +end subroutine MOM_write_field_legacy_2d + + +!> Write a 1d field to an output file +subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_value, scale) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, dimension(:), intent(in) :: field !< Field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + + + real, dimension(:), allocatable :: array ! A rescaled copy of field [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] + integer :: i + + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if (scale_fac == 1.0) then + call write_field(IO_handle, field_md, field, tstamp=tstamp) + else + allocate(array(size(field))) + array(:) = scale_fac * field(:) + if (present(fill_value)) then + do i=1,size(field) ; if (field(i) == fill_value) array(i) = fill_value ; enddo + endif + call write_field(IO_handle, field_md, array, tstamp=tstamp) + deallocate(array) + endif +end subroutine MOM_write_field_legacy_1d + + +!> Write a 0d field to an output file +subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_value, scale) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, intent(in) :: field !< Field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + + real :: scaled_val ! A rescaled copy of field [a] + + scaled_val = field + if (present(scale)) scaled_val = scale*field + if (present(fill_value)) then ; if (field == fill_value) scaled_val = fill_value ; endif + + call write_field(IO_handle, field_md, scaled_val, tstamp=tstamp) +end subroutine MOM_write_field_legacy_0d + + +!> Write a 4d field to an output file, potentially with rotation +subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write + real, optional, intent(in) :: tstamp !< Model timestamp + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that the field is + !! multiplied by before it is written + + real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units or rescaled + real :: scale_fac ! A scaling factor to use before writing the array + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if ((qturns == 0) .and. (scale_fac == 1.0)) then + call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + else + call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + if (scale_fac /= 1.0) call rescale_comp_data(MOM_Domain, field_rot, scale_fac) + call IO_handle%write_field(field_md, MOM_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + deallocate(field_rot) + endif +end subroutine MOM_write_field_4d + +!> Write a 3d field to an output file, potentially with rotation +subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write + real, optional, intent(in) :: tstamp !< Model timestamp + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that the field is + !! multiplied by before it is written + + real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units or rescaled + real :: scale_fac ! A scaling factor to use before writing the array + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if ((qturns == 0) .and. (scale_fac == 1.0)) then + call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + else + call allocate_rotated_array(field, [1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + if (scale_fac /= 1.0) call rescale_comp_data(MOM_Domain, field_rot, scale_fac) + call IO_handle%write_field(field_md, MOM_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + deallocate(field_rot) + endif +end subroutine MOM_write_field_3d + +!> Write a 2d field to an output file, potentially with rotation +subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field !< Unrotated field to write + real, optional, intent(in) :: tstamp !< Model timestamp + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that the field is + !! multiplied by before it is written + + real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units + real :: scale_fac ! A scaling factor to use before writing the array + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if ((qturns == 0) .and. (scale_fac == 1.0)) then + call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + else + call allocate_rotated_array(field, [1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + if (scale_fac /= 1.0) call rescale_comp_data(MOM_Domain, field_rot, scale_fac) + call IO_handle%write_field(field_md, MOM_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + deallocate(field_rot) + endif +end subroutine MOM_write_field_2d + +!> Write a 1d field to an output file +subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + real, dimension(:), intent(in) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: scale !< A scaling factor that the field is + !! multiplied by before it is written + + real, dimension(:), allocatable :: array ! A rescaled copy of field + real :: scale_fac ! A scaling factor to use before writing the array + integer :: i + + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if (scale_fac == 1.0) then + call IO_handle%write_field(field_md, field, tstamp=tstamp) + else + allocate(array(size(field))) + array(:) = scale_fac * field(:) + if (present(fill_value)) then + do i=1,size(field) ; if (field(i) == fill_value) array(i) = fill_value ; enddo + endif + call IO_handle%write_field(field_md, array, tstamp=tstamp) + deallocate(array) + endif +end subroutine MOM_write_field_1d + +!> Write a 0d field to an output file +subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, scale) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + real, intent(in) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: scale !< A scaling factor that the field is + !! multiplied by before it is written + real :: scaled_val ! A rescaled copy of field + + scaled_val = field + if (present(scale)) scaled_val = scale*field + if (present(fill_value)) then ; if (field == fill_value) scaled_val = fill_value ; endif + + call IO_handle%write_field(field_md, scaled_val, tstamp=tstamp) +end subroutine MOM_write_field_0d + +!> Given filename and fieldname, this subroutine returns the size of the field in the file +subroutine field_size(filename, fieldname, sizes, field_found, no_domain, ndims, ncid_in) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The name of the variable whose sizes are returned + integer, dimension(:), intent(inout) :: sizes !< The sizes of the variable in each dimension + logical, optional, intent(out) :: field_found !< This indicates whether the field was found in + !! the input file. Without this argument, there + !! is a fatal error if the field is not found. + logical, optional, intent(in) :: no_domain !< If present and true, do not check for file + !! names with an appended tile number. If + !! ndims is present, the default changes to true. + integer, optional, intent(out) :: ndims !< The number of dimensions to the variable + integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the + !! file is opened and closed within this routine. + + if (present(ndims)) then + if (present(no_domain)) then ; if (.not.no_domain) call MOM_error(FATAL, & + "field_size does not support the ndims argument when no_domain is present and false.") + endif + call get_var_sizes(filename, fieldname, ndims, sizes, match_case=.false., ncid_in=ncid_in) + if (present(field_found)) field_found = (ndims >= 0) + if ((ndims < 0) .and. .not.present(field_found)) then + call MOM_error(FATAL, "Variable "//trim(fieldname)//" not found in "//trim(filename) ) + endif + else + call get_field_size(filename, fieldname, sizes, field_found=field_found, no_domain=no_domain) + endif + +end subroutine field_size + + +!> Copies a string +subroutine safe_string_copy(str1, str2, fieldnm, caller) + character(len=*), intent(in) :: str1 !< The string being copied + character(len=*), intent(out) :: str2 !< The string being copied into + character(len=*), optional, intent(in) :: fieldnm !< The name of the field for error messages + character(len=*), optional, intent(in) :: caller !< The calling routine for error messages + + if (len(trim(str1)) > len(str2)) then + if (present(fieldnm) .and. present(caller)) then + call MOM_error(FATAL, trim(caller)//" attempted to copy the overly long"//& + " string "//trim(str1)//" into "//trim(fieldnm)) + else + call MOM_error(FATAL, "safe_string_copy: The string "//trim(str1)//& + " is longer than its intended target.") + endif + endif + str2 = trim(str1) +end subroutine safe_string_copy + +!> Returns a name with "%#E" or "%E" replaced with the ensemble member number. +function ensembler(name, ens_no_in) result(en_nm) + character(len=*), intent(in) :: name !< The name to be modified + integer, optional, intent(in) :: ens_no_in !< The number of the current ensemble member + character(len=len(name)) :: en_nm !< The name encoded with the ensemble number + + ! This function replaces "%#E" or "%E" with the ensemble number anywhere it + ! occurs in name, with %E using 4 or 6 digits (depending on the ensemble size) + ! and %#E using # digits, where # is a number from 1 to 9. + + character(len=len(name)) :: tmp + character(10) :: ens_num_char + character(3) :: code_str + integer :: ens_no + integer :: n, is + + en_nm = trim(name) + if (index(name,"%") == 0) return + + if (present(ens_no_in)) then + ens_no = ens_no_in + else + ens_no = get_ensemble_id() + endif + + write(ens_num_char, '(I10)') ens_no ; ens_num_char = adjustl(ens_num_char) + do + is = index(en_nm,"%E") + if (is == 0) exit + if (len(en_nm) < len(trim(en_nm)) + len(trim(ens_num_char)) - 2) & + call MOM_error(FATAL, "MOM_io ensembler: name "//trim(name)// & + " is not long enough for %E expansion for ens_no "//trim(ens_num_char)) + tmp = en_nm(1:is-1)//trim(ens_num_char)//trim(en_nm(is+2:)) + en_nm = tmp + enddo + + if (index(name,"%") == 0) return + + write(ens_num_char, '(I10.10)') ens_no + do n=1,9 ; do + write(code_str, '("%",I1,"E")') n + + is = index(en_nm,code_str) + if (is == 0) exit + if (ens_no < 10**n) then + if (len(en_nm) < len(trim(en_nm)) + n-3) call MOM_error(FATAL, & + "MOM_io ensembler: name "//trim(name)//" is not long enough for %E expansion.") + tmp = en_nm(1:is-1)//trim(ens_num_char(11-n:10))//trim(en_nm(is+3:)) + else + call MOM_error(FATAL, "MOM_io ensembler: Ensemble number is too large "//& + "to be encoded with "//code_str//" in "//trim(name)) + endif + en_nm = tmp + enddo ; enddo + +end function ensembler + +!> Provide a string to append to filenames, to differentiate ensemble members, for example. +subroutine get_filename_appendix(suffix) + character(len=*), intent(out) :: suffix !< A string to append to filenames + + call get_filename_suffix(suffix) +end subroutine get_filename_appendix + +!> Write a file version number to the log file or other output file +subroutine write_version_number(version, tag, unit) + character(len=*), intent(in) :: version !< A string that contains the routine name and version + character(len=*), optional, intent(in) :: tag !< A tag name to add to the message + integer, optional, intent(in) :: unit !< An alternate unit number for output + + call write_version(version, tag, unit) +end subroutine write_version_number + + +!> Open a single namelist file that is potentially readable by all PEs. +function open_namelist_file(file) result(unit) + character(len=*), optional, intent(in) :: file !< The file to open, by default "input.nml" + integer :: unit !< The opened unit number of the namelist file + unit = MOM_namelist_file(file) +end function open_namelist_file + +!> Checks the iostat argument that is returned after reading a namelist variable and writes a +!! message if there is an error. +function check_nml_error(IOstat, nml_name) result(ierr) + integer, intent(in) :: IOstat !< An I/O status field from a namelist read call + character(len=*), intent(in) :: nml_name !< The name of the namelist + integer :: ierr !< A copy of IOstat that is returned to preserve legacy function behavior + call check_namelist_error(IOstat, nml_name) + ierr = IOstat +end function check_nml_error + +!> Initialize the MOM_io module +subroutine MOM_io_init(param_file) + type(param_file_type), intent(in) :: param_file !< structure indicating the open file to + !! parse for model parameter values. + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_io" ! This module's name. + + call log_version(param_file, mdl, version) + +end subroutine MOM_io_init +!> Returns the dimension variable information for a netCDF variable +subroutine get_var_axes_info(filename, fieldname, axes_info) + character(len=*), intent(in) :: filename !< A filename from which to read + character(len=*), intent(in) :: fieldname !< The name of the field to read + type(axis_info), dimension(4), intent(inout) :: axes_info !< A returned array of field axis information + + !! local variables + integer :: rcode + logical :: success + integer :: ncid, varid, ndims + integer :: id, jd, kd + integer, dimension(4) :: dims, dim_id + character(len=128) :: dim_name(4) + integer, dimension(1) :: start, count + !! cartesian axis data + real, allocatable, dimension(:) :: x ! x-axis labels, often [degrees_E] or [km] or [m] + real, allocatable, dimension(:) :: y ! y-axis labels, often [degrees_N] or [km] or [m] + real, allocatable, dimension(:) :: z ! vertical axis labels [various], often [m] or [kg m-3] + + + call open_file_to_read(filename, ncid, success=success) + + rcode = NF90_INQ_VARID(ncid, trim(fieldname), varid) + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(fieldname)//& + " in file "//trim(filename)//" in hinterp_extrap") + + rcode = NF90_INQUIRE_VARIABLE(ncid, varid, ndims=ndims, dimids=dims) + if (rcode /= 0) call MOM_error(FATAL, "Error inquiring about the dimensions of "//trim(fieldname)//& + " in file "//trim(filename)//" in hinterp_extrap") + if (ndims < 3) call MOM_error(FATAL,"Variable "//trim(fieldname)//" in file "//trim(filename)// & + " has too few dimensions to be read as a 3-d array.") + rcode = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 data for "// & + trim(fieldname)//" in file "// trim(filename)//" in hinterp_extrap") + rcode = NF90_INQ_VARID(ncid, dim_name(1), dim_id(1)) + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& + " in file "//trim(filename)//" in hinterp_extrap") + rcode = NF90_INQUIRE_DIMENSION(ncid, dims(2), dim_name(2), len=jd) + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 data for "// & + trim(fieldname)//" in file "// trim(filename)//" in hinterp_extrap") + rcode = NF90_INQ_VARID(ncid, dim_name(2), dim_id(2)) + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(2))//& + " in file "//trim(filename)//" in hinterp_extrap") + rcode = NF90_INQUIRE_DIMENSION(ncid, dims(3), dim_name(3), len=kd) + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 data for "// & + trim(fieldname)//" in file "// trim(filename)//" in hinterp_extrap") + rcode = NF90_INQ_VARID(ncid, dim_name(3), dim_id(3)) + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(3))//& + " in file "//trim(filename)//" in hinterp_extrap") + allocate(x(id), y(jd), z(kd)) + + start = 1 ; count = 1 ; count(1) = id + rcode = NF90_GET_VAR(ncid, dim_id(1), x, start, count) + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 values for var_name "// & + trim(fieldname)//",dim_name "//trim(dim_name(1))//" in file "// trim(filename)//" in hinterp_extrap") + start = 1 ; count = 1 ; count(1) = jd + rcode = NF90_GET_VAR(ncid, dim_id(2), y, start, count) + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 values for var_name "// & + trim(fieldname)//",dim_name "//trim(dim_name(2))//" in file "// trim(filename)//" in hinterp_extrap") + start = 1 ; count = 1 ; count(1) = kd + rcode = NF90_GET_VAR(ncid, dim_id(3), z, start, count) + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 values for var_name "// & + trim(fieldname//",dim_name "//trim(dim_name(3)))//" in file "// trim(filename)//" in hinterp_extrap") + + call set_axis_info(axes_info(1), name=trim(dim_name(1)), ax_size=id, ax_data=x,cartesian='X') + call set_axis_info(axes_info(2), name=trim(dim_name(2)), ax_size=jd, ax_data=y,cartesian='Y') + call set_axis_info(axes_info(3), name=trim(dim_name(3)), ax_size=kd, ax_data=z,cartesian='Z') + + call close_file_to_read(ncid, filename) + + deallocate(x,y,z) + +end subroutine get_var_axes_info +!> \namespace mom_io +!! +!! This file contains a number of subroutines that manipulate +!! NetCDF files and handle input and output of fields. These +!! subroutines, along with their purpose, are: +!! +!! * create_file: create a new file and set up structures that are +!! needed for subsequent output and write out the coordinates. +!! * reopen_file: reopen an existing file for writing and set up +!! structures that are needed for subsequent output. +!! * open_input_file: open the indicated file for reading only. +!! * close_file: close an open file. +!! * synch_file: flush the buffers, completing all pending output. +!! +!! * write_field: write a field to an open file. +!! * write_time: write a value of the time axis to an open file. +!! * read_data: read a variable from an open file. +!! * read_time: read a time from an open file. +!! +!! * name_output_file: provide a name for an output file based on a +!! name root and the time of the output. +!! * find_input_file: find a file that has been previously written by +!! MOM and named by name_output_file and open it for reading. +!! +!! * handle_error: write an error code and quit. + +end module MOM_io diff --git a/framework/MOM_io_file.F90 b/framework/MOM_io_file.F90 new file mode 100644 index 0000000000..c6d86a008b --- /dev/null +++ b/framework/MOM_io_file.F90 @@ -0,0 +1,1823 @@ +!> This module contains the MOM file handler types +module MOM_io_file + +! This file is part of MOM6. See LICENSE.md for the license. + +use, intrinsic :: iso_fortran_env, only : int64 + +use MOM_domains, only : MOM_domain_type, domain1D +use MOM_domains, only : clone_MOM_domain +use MOM_domains, only : deallocate_MOM_domain +use MOM_io_infra, only : file_type, get_file_info, get_file_fields +use MOM_io_infra, only : open_file, close_file, flush_file +use MOM_io_infra, only : fms2_file_is_open => file_is_open +use MOM_io_infra, only : fieldtype +use MOM_io_infra, only : get_file_times, axistype +use MOM_io_infra, only : write_field, write_metadata +use MOM_io_infra, only : get_field_atts +use MOM_io_infra, only : read_field_chksum +use MOM_io_infra, only : SINGLE_FILE + +use MOM_hor_index, only : hor_index_type +use MOM_hor_index, only : hor_index_init + +use MOM_netcdf, only : netcdf_file_type +use MOM_netcdf, only : netcdf_axis +use MOM_netcdf, only : netcdf_field +use MOM_netcdf, only : open_netcdf_file +use MOM_netcdf, only : close_netcdf_file +use MOM_netcdf, only : flush_netcdf_file +use MOM_netcdf, only : register_netcdf_axis +use MOM_netcdf, only : register_netcdf_field +use MOM_netcdf, only : write_netcdf_field +use MOM_netcdf, only : write_netcdf_axis +use MOM_netcdf, only : write_netcdf_attribute +use MOM_netcdf, only : get_netcdf_size +use MOM_netcdf, only : get_netcdf_fields +use MOM_netcdf, only : read_netcdf_field + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_error_handler, only : is_root_PE + +implicit none ; private + +public :: MOM_file +public :: MOM_infra_file +public :: MOM_netcdf_file +public :: MOM_axis +public :: MOM_field + + +! Internal types + +! NOTE: MOM_axis and MOM_field do not contain the actual axes and fields stored +! in the file. They are very thin wrappers to the keys (as strings) used to +! reference the associated object inside of the MOM_file. + +!> Handle for axis in MOM file +type :: MOM_axis + character(len=:), allocatable :: label + !< Identifier for the axis in handle's list +end type MOM_axis + + +!> Linked list of framework axes +type :: axis_list_infra + private + type(axis_node_infra), pointer :: head => null() + !< Head of axis linked list + type(axis_node_infra), pointer :: tail => null() + !< Tail of axis linked list +contains + !> Initialize the framework axis list + procedure :: init => initialize_axis_list_infra + !> Append a new axis to the framework axis list + procedure :: append => append_axis_list_infra + !> Get an axis from the framework axis list + procedure :: get => get_axis_list_infra + !> Deallocate the framework axis list + procedure :: finalize => finalize_axis_list_infra +end type axis_list_infra + + +!> Framework axis linked list node +type :: axis_node_infra + private + character(len=:), allocatable :: label + !< Axis identifier + type(axis_node_infra), pointer :: next => null() + !< Pointer to next axis node + type(axistype) :: axis + !< Axis node contents +end type axis_node_infra + + +!> Linked list of framework axes +type :: axis_list_nc + private + type(axis_node_nc), pointer :: head => null() + !< Head of axis linked list + type(axis_node_nc), pointer :: tail => null() + !< Tail of axis linked list +contains + !> Initialize the netCDF axis list + procedure :: init => initialize_axis_list_nc + !> Append a new axis to the netCDF axis list + procedure :: append => append_axis_list_nc + !> Get an axis from the netCDF axis list + procedure :: get => get_axis_list_nc + !> Deallocate the netCDF axis list + procedure :: finalize => finalize_axis_list_nc +end type axis_list_nc + + +!> Framework axis linked list node +type :: axis_node_nc + private + character(len=:), allocatable :: label + !< Axis identifier + type(axis_node_nc), pointer :: next => null() + !< Pointer to next axis node + type(netcdf_axis) :: axis + !< Axis node contents +end type axis_node_nc + + +!> Handle for field in MOM file +type :: MOM_field + character(len=:), allocatable :: label + !< Identifier for the field in the handle's list +end type MOM_field + + +!> Linked list of framework fields +type :: field_list_infra + private + type(field_node_infra), pointer :: head => null() + !< Head of field linked list + type(field_node_infra), pointer :: tail => null() + !< Tail of field linked list +contains + !> Initialize the framework field list + procedure :: init => initialize_field_list_infra + !> Append a new axis to the framework field list + procedure :: append => append_field_list_infra + !> Get an axis from the framework field list + procedure :: get => get_field_list_infra + !> Deallocate the framework field list + procedure :: finalize => finalize_field_list_infra +end type field_list_infra + + +!> Framework field linked list node +type :: field_node_infra + private + character(len=:), allocatable :: label + !< Field identifier + type(fieldtype) :: field + !< Field node contents + type(field_node_infra), pointer :: next => null() + !< Pointer to next field node +end type field_node_infra + + +!> Linked list of framework fields +type :: field_list_nc + private + type(field_node_nc), pointer :: head => null() + !< Head of field linked list + type(field_node_nc), pointer :: tail => null() + !< Tail of field linked list +contains + !> Initialize the netCDF field list + procedure :: init => initialize_field_list_nc + !> Append a new axis to the netCDF field list + procedure :: append => append_field_list_nc + !> Get an axis from the netCDF field list + procedure :: get => get_field_list_nc + !> Deallocate the netCDF field list + procedure :: finalize => finalize_field_list_nc +end type field_list_nc + + +!> Framework field linked list node +type :: field_node_nc + private + character(len=:), allocatable :: label + !< Field identifier + type(netcdf_field) :: field + !< Field node contents + type(field_node_nc), pointer :: next => null() + !< Pointer to next field node +end type field_node_nc + + +!> Generic MOM file abstraction for common operations +type, abstract :: MOM_file + private + + contains + + !> Open a file and connect to the MOM_file object + procedure(i_open_file), deferred :: open + !> Close the MOM file + procedure(i_close_file), deferred :: close + !> Flush buffered output to the MOM file + procedure(i_flush_file), deferred :: flush + + !> Register an axis to the MOM file + procedure(i_register_axis), deferred :: register_axis + !> Register a field to the MOM file + procedure(i_register_field), deferred :: register_field + !> Write metadata to the MOM file + procedure(i_write_attribute), deferred :: write_attribute + + !> Write field to a MOM file + generic :: write_field => & + write_field_4d, & + write_field_3d, & + write_field_2d, & + write_field_1d, & + write_field_0d, & + write_field_axis + + !> Write a 4D field to the MOM file + procedure(i_write_field_4d), deferred :: write_field_4d + !> Write a 3D field to the MOM file + procedure(i_write_field_3d), deferred :: write_field_3d + !> Write a 2D field to the MOM file + procedure(i_write_field_2d), deferred :: write_field_2d + !> Write a 1D field to the MOM file + procedure(i_write_field_1d), deferred :: write_field_1d + !> Write a 0D field to the MOM file + procedure(i_write_field_0d), deferred :: write_field_0d + !> Write an axis field to the MOM file + procedure(i_write_field_axis), deferred :: write_field_axis + + !> Return true if MOM file has been opened + procedure(i_file_is_open), deferred :: file_is_open + !> Return number of dimensions, variables, or time levels in a MOM file + procedure(i_get_file_info), deferred :: get_file_info + !> Get field objects from a MOM file + procedure(i_get_file_fields), deferred :: get_file_fields + !> Get attributes from a field + procedure(i_get_field_atts), deferred :: get_field_atts + !> Get checksum from a field + procedure(i_read_field_chksum), deferred :: read_field_chksum +end type MOM_file + + +!> MOM file from the supporting framework ("infra") layer +type, extends(MOM_file) :: MOM_infra_file + private + + type(MOM_domain_type), public, pointer :: domain => null() + !< Internal domain used for single-file IO + + ! NOTE: This will be made private after the API transition + type(file_type), public :: handle_infra + !< Framework-specific file handler content + type(axis_list_infra) :: axes + !< List of axes in file + type(field_list_infra) :: fields + !< List of fields in file + + contains + + !> Open a framework file and connect to the MOM_file object + procedure :: open => open_file_infra + !> Close the MOM framework file + procedure :: close => close_file_infra + !> Flush buffered output to the MOM framework file + procedure :: flush => flush_file_infra + + !> Register an axis to the MOM framework file + procedure :: register_axis => register_axis_infra + !> Register a field to the MOM framework file + procedure :: register_field => register_field_infra + !> Write global metadata to the MOM framework file + procedure :: write_attribute => write_attribute_infra + + !> Write a 4D field to the MOM framework file + procedure :: write_field_4d => write_field_4d_infra + !> Write a 3D field to the MOM framework file + procedure :: write_field_3d => write_field_3d_infra + !> Write a 2D field to the MOM framework file + procedure :: write_field_2d => write_field_2d_infra + !> Write a 1D field to the MOM framework file + procedure :: write_field_1d => write_field_1d_infra + !> Write a 0D field to the MOM framework file + procedure :: write_field_0d => write_field_0d_infra + !> Write an axis field to the MOM framework file + procedure :: write_field_axis => write_field_axis_infra + + !> Return true if MOM infra file has been opened + procedure :: file_is_open => file_is_open_infra + !> Return number of dimensions, variables, or time levels in a MOM infra file + procedure :: get_file_info => get_file_info_infra + !> Get field metadata from a MOM infra file + procedure :: get_file_fields => get_file_fields_infra + !> Get attributes from a field + procedure :: get_field_atts => get_field_atts_infra + !> Get checksum from a field + procedure :: read_field_chksum => read_field_chksum_infra + + ! MOM_infra_file methods + ! NOTE: These could naturally reside in MOM_file but is currently not needed. + + !> Get time levels of a MOM framework file + procedure :: get_file_times => get_file_times_infra + + !> Get the fields as fieldtypes from a file + procedure :: get_file_fieldtypes + ! NOTE: This is provided to support the legacy API and may be removed. +end type MOM_infra_file + + +!> MOM file using netCDF backend +type, extends(MOM_file) :: MOM_netcdf_file + private + + !> Framework-specific file handler content + type(netcdf_file_type) :: handle_nc + !> List of netCDF axes + type(axis_list_nc) :: axes + !> List of netCDF fields + type(field_list_nc) :: fields + !> True if the file has been opened + logical :: is_open = .false. + !> True if I/O content is domain-decomposed + logical :: domain_decomposed = .false. + !> True if I/O content is domain-decomposed + type(hor_index_type) :: HI + + contains + + !> Open a framework file and connect to the MOM_netcdf_file object + procedure :: open => open_file_nc + !> Close the MOM netcdf file + procedure :: close => close_file_nc + !> Flush buffered output to the MOM netcdf file + procedure :: flush => flush_file_nc + + !> Register an axis to the MOM netcdf file + procedure :: register_axis => register_axis_nc + !> Register a field to the MOM netcdf file + procedure :: register_field => register_field_nc + !> Write global metadata to the MOM netcdf file + procedure :: write_attribute => write_attribute_nc + + !> Write a 4D field to the MOM netcdf file + procedure :: write_field_4d => write_field_4d_nc + !> Write a 3D field to the MOM netcdf file + procedure :: write_field_3d => write_field_3d_nc + !> Write a 2D field to the MOM netcdf file + procedure :: write_field_2d => write_field_2d_nc + !> Write a 1D field to the MOM netcdf file + procedure :: write_field_1d => write_field_1d_nc + !> Write a 0D field to the MOM netcdf file + procedure :: write_field_0d => write_field_0d_nc + !> Write an axis field to the MOM netcdf file + procedure :: write_field_axis => write_field_axis_nc + + !> Return true if MOM netcdf file has been opened + procedure :: file_is_open => file_is_open_nc + !> Return number of dimensions, variables, or time levels in a MOM netcdf file + procedure :: get_file_info => get_file_info_nc + !> Get field metadata from a MOM netcdf file + procedure :: get_file_fields => get_file_fields_nc + !> Get attributes from a netCDF field + procedure :: get_field_atts => get_field_atts_nc + !> Get checksum from a netCDF field + procedure :: read_field_chksum => read_field_chksum_nc + + ! NOTE: These are currently exclusive to netCDF I/O but could be generalized + !> Read the values of a netCDF field + procedure :: read => get_field_nc + !> Update the axes and fields descriptors of a MOM netCDF file + procedure :: update => update_file_contents_nc +end type MOM_netcdf_file + + +interface + !> Interface for opening a MOM file + subroutine i_open_file(handle, filename, action, MOM_domain, threading, fileset) + import :: MOM_file, MOM_domain_type + + class(MOM_file), intent(inout) :: handle + !< The handle for the opened file + character(len=*), intent(in) :: filename + !< The path name of the file being opened + integer, optional, intent(in) :: action + !< A flag indicating whether the file can be read or written to and how + !! to handle existing files. The default is WRITE_ONLY. + type(MOM_domain_type), optional, intent(in) :: MOM_Domain + !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: threading + !< A flag indicating whether one (SINGLE_FILE) or multiple PEs (MULTIPLE) + !! participate in I/O. With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset + !< A flag indicating whether multiple PEs doing I/O due to + !! threading=MULTIPLE write to the same file (SINGLE_FILE) or to one file + !! per PE (MULTIPLE, the default). + end subroutine i_open_file + + + !> Interface for closing a MOM file + subroutine i_close_file(handle) + import :: MOM_file + class(MOM_file), intent(inout) :: handle + !< The MOM file to be closed + end subroutine i_close_file + + + !> Interface for flushing I/O in a MOM file + subroutine i_flush_file(handle) + import :: MOM_file + class(MOM_file), intent(in) :: handle + !< The MOM file to be flushed + end subroutine i_flush_file + + + !> Interface to register an axis to a MOM file + function i_register_axis(handle, label, units, longname, cartesian, sense, & + domain, data, edge_axis, calendar) result(axis) + import :: MOM_file, MOM_axis, domain1D + + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: label + !< The name in the file of this axis + character(len=*), intent(in) :: units + !< The units of this axis + character(len=*), intent(in) :: longname + !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian + !< A variable indicating which direction this axis corresponds with. + !! Valid values include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense + !< This is 1 for axes whose values increase upward, or -1 if they + !! increase downward. + type(domain1D), optional, intent(in) :: domain + !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data + !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis + !< If true, this axis marks an edge of the tracer cells + character(len=*), optional, intent(in) :: calendar + !< The name of the calendar used with a time axis + type(MOM_axis) :: axis + !< IO handle for axis in MOM_file + end function i_register_axis + + + !> Interface to register a field to a netCDF file + function i_register_field(handle, axes, label, units, longname, & + pack, standard_name, checksum) result(field) + import :: MOM_file, MOM_axis, MOM_field, int64 + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axes(:) + !< Handles for the axis used for this variable + character(len=*), intent(in) :: label + !< The name in the file of this variable + character(len=*), intent(in) :: units + !< The units of this variable + character(len=*), intent(in) :: longname + !< The long description of this variable + integer, optional, intent(in) :: pack + !< A precision reduction factor with which the variable. The default, 1, + !! has no reduction, but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name + !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), optional, intent(in) :: checksum + !< Checksum values that can be used to verify reads. + type(MOM_field) :: field + !< IO handle for field in MOM_file + end function i_register_field + + + !> Interface for writing global metata to a MOM file + subroutine i_write_attribute(handle, name, attribute) + import :: MOM_file + class(MOM_file), intent(in) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: name + !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute + !< The value of this attribute + end subroutine i_write_attribute + + + !> Interface to write_field_4d() + subroutine i_write_field_4d(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + import :: MOM_file, MOM_field, MOM_domain_type + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + end subroutine i_write_field_4d + + + !> Interface to write_field_3d() + subroutine i_write_field_3d(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + import :: MOM_file, MOM_field, MOM_domain_type + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + end subroutine i_write_field_3d + + + !> Interface to write_field_2d() + subroutine i_write_field_2d(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + import :: MOM_file, MOM_field, MOM_domain_type + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + end subroutine i_write_field_2d + + + !> Interface to write_field_1d() + subroutine i_write_field_1d(handle, field_md, field, tstamp) + import :: MOM_file, MOM_field + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, dimension(:), intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + end subroutine i_write_field_1d + + + !> Interface to write_field_0d() + subroutine i_write_field_0d(handle, field_md, field, tstamp) + import :: MOM_file, MOM_field + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + end subroutine i_write_field_0d + + + !> Interface to write_field_axis() + subroutine i_write_field_axis(handle, axis) + import :: MOM_file, MOM_axis + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axis + !< An axis type variable with information to write + end subroutine i_write_field_axis + + + !> Interface to file_is_open() + logical function i_file_is_open(handle) + import :: MOM_file + class(MOM_file), intent(in) :: handle + !< Handle to a file to inquire about + end function i_file_is_open + + + !> Interface to get_file_info() + subroutine i_get_file_info(handle, ndim, nvar, ntime) + import :: MOM_file + class(MOM_file), intent(in) :: handle + !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim + !< The number of dimensions in the file + integer, optional, intent(out) :: nvar + !< The number of variables in the file + integer, optional, intent(out) :: ntime + !< The number of time levels in the file + end subroutine i_get_file_info + + + !> Interface to get_file_fields() + subroutine i_get_file_fields(handle, fields) + import :: MOM_file, MOM_field + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for I/O + type(MOM_field), dimension(:), intent(inout) :: fields + !< Field-type descriptions of all of the variables in a file. + end subroutine i_get_file_fields + + + !> Interface to get_field_atts() + subroutine i_get_field_atts(handle, field, name, units, longname, checksum) + import :: MOM_file, MOM_field, int64 + class(MOM_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field to extract information from + character(len=*), optional, intent(out) :: name + !< The variable name + character(len=*), optional, intent(out) :: units + !< The units of the variable + character(len=*), optional, intent(out) :: longname + !< The long name of the variable + integer(kind=int64), optional, intent(out) :: checksum(:) + !< The checksums of the variable in a file + end subroutine i_get_field_atts + + + !> Interface to read_field_chksum + subroutine i_read_field_chksum(handle, field, chksum, valid_chksum) + import :: MOM_file, MOM_field, int64 + class(MOM_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field whose checksum attribute is to be read + integer(kind=int64), intent(out) :: chksum + !< The checksum for the field. + logical, intent(out) :: valid_chksum + !< If true, chksum has been successfully read + end subroutine i_read_field_chksum +end interface + +contains + +!> Initialize the linked list of framework axes +subroutine initialize_axis_list_infra(list) + class(axis_list_infra), intent(inout) :: list + + ! Pre-allocate the first node and set the tail to this empty node + allocate(list%head) + list%tail => list%head +end subroutine initialize_axis_list_infra + + +!> Append a new axis to the list +subroutine append_axis_list_infra(list, axis, label) + class(axis_list_infra), intent(inout) :: list + type(axistype), intent(in) :: axis + character(len=*), intent(in) :: label + + type(axis_node_infra), pointer :: empty_node + + ! Transfer value to tail + list%tail%label = label + list%tail%axis = axis + + ! Extend list to next empty node + allocate(empty_node) + list%tail%next => empty_node + list%tail => empty_node +end subroutine append_axis_list_infra + + +!> Get axis based on label +function get_axis_list_infra(list, label) result(axis) + class(axis_list_infra), intent(in) :: list + character(len=*), intent(in) :: label + type(axistype) :: axis + + type(axis_node_infra), pointer :: node + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => list%head + do while(associated(node%next)) + if (node%label == label) exit + node => node%next + enddo + if (.not. associated(node)) & + call MOM_error(FATAL, "axis associated with " // label // " not found.") + + axis = node%axis +end function get_axis_list_infra + + +!> Deallocate axes of list +subroutine finalize_axis_list_infra(list) + class(axis_list_infra), intent(inout) :: list + + type(axis_node_infra), pointer :: node, next_node + + node => list%head + do while(associated(node)) + next_node => node + node => node%next + deallocate(next_node) + enddo +end subroutine finalize_axis_list_infra + + +!> Initialize the linked list of framework axes +subroutine initialize_axis_list_nc(list) + class(axis_list_nc), intent(inout) :: list + + ! Pre-allocate the first node and set the tail to this empty node + allocate(list%head) + list%tail => list%head +end subroutine initialize_axis_list_nc + + +!> Append a new axis to the list +subroutine append_axis_list_nc(list, axis, label) + class(axis_list_nc), intent(inout) :: list + type(netcdf_axis), intent(in) :: axis + character(len=*), intent(in) :: label + + type(axis_node_nc), pointer :: empty_node + + ! Transfer value to tail + list%tail%label = label + list%tail%axis = axis + + ! Extend list to next empty node + allocate(empty_node) + list%tail%next => empty_node + list%tail => empty_node +end subroutine append_axis_list_nc + + +!> Get axis based on label +function get_axis_list_nc(list, label) result(axis) + class(axis_list_nc), intent(in) :: list + character(len=*), intent(in) :: label + type(netcdf_axis) :: axis + + type(axis_node_nc), pointer :: node + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => list%head + do while(associated(node%next)) + if (node%label == label) exit + node => node%next + enddo + if (.not. associated(node)) & + call MOM_error(FATAL, "axis associated with " // label // " not found.") + + axis = node%axis +end function get_axis_list_nc + + +!> Deallocate axes of list +subroutine finalize_axis_list_nc(list) + class(axis_list_nc), intent(inout) :: list + + type(axis_node_nc), pointer :: node, next_node + + node => list%head + do while(associated(node)) + next_node => node + node => node%next + deallocate(next_node) + enddo +end subroutine finalize_axis_list_nc + + +!> Initialize the linked list of framework axes +subroutine initialize_field_list_infra(list) + class(field_list_infra), intent(inout) :: list + + ! Pre-allocate the first node and set the tail to this empty node + allocate(list%head) + list%tail => list%head +end subroutine initialize_field_list_infra + + +!> Append a new field to the list +subroutine append_field_list_infra(list, field, label) + class(field_list_infra), intent(inout) :: list + type(fieldtype), intent(in) :: field + character(len=*), intent(in) :: label + + type(field_node_infra), pointer :: empty_node + + ! Transfer value to tail + list%tail%label = label + list%tail%field = field + + ! Extend list to next empty node + allocate(empty_node) + list%tail%next => empty_node + list%tail => empty_node +end subroutine append_field_list_infra + + +!> Get axis based on label +function get_field_list_infra(list, label) result(field) + class(field_list_infra), intent(in) :: list + character(len=*), intent(in) :: label + type(fieldtype) :: field + + type(field_node_infra), pointer :: node + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => list%head + do while(associated(node%next)) + if (node%label == label) exit + node => node%next + enddo + if (.not. associated(node)) & + call MOM_error(FATAL, "field associated with " // label // " not found.") + + field = node%field +end function get_field_list_infra + + +!> Deallocate fields of list +subroutine finalize_field_list_infra(list) + class(field_list_infra), intent(inout) :: list + + type(field_node_infra), pointer :: node, next_node + + node => list%head + do while(associated(node)) + next_node => node + node => node%next + deallocate(next_node) + enddo +end subroutine finalize_field_list_infra + + +!> Initialize the linked list of framework axes +subroutine initialize_field_list_nc(list) + class(field_list_nc), intent(inout) :: list + + ! Pre-allocate the first node and set the tail to this empty node + allocate(list%head) + list%tail => list%head +end subroutine initialize_field_list_nc + + +!> Append a new field to the list +subroutine append_field_list_nc(list, field, label) + class(field_list_nc), intent(inout) :: list + type(netcdf_field), intent(in) :: field + character(len=*), intent(in) :: label + + type(field_node_nc), pointer :: empty_node + + ! Transfer value to tail + list%tail%label = label + list%tail%field = field + + ! Extend list to next empty node + allocate(empty_node) + list%tail%next => empty_node + list%tail => empty_node +end subroutine append_field_list_nc + + +!> Get axis based on label +function get_field_list_nc(list, label) result(field) + class(field_list_nc), intent(in) :: list + character(len=*), intent(in) :: label + type(netcdf_field) :: field + + type(field_node_nc), pointer :: node + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => list%head + do while(associated(node%next)) + if (node%label == label) exit + node => node%next + enddo + if (.not. associated(node)) & + call MOM_error(FATAL, "field associated with " // label // " not found.") + + field = node%field +end function get_field_list_nc + + +!> Deallocate fields of list +subroutine finalize_field_list_nc(list) + class(field_list_nc), intent(inout) :: list + + type(field_node_nc), pointer :: node, next_node + + node => list%head + do while(associated(node)) + next_node => node + node => node%next + deallocate(next_node) + enddo +end subroutine finalize_field_list_nc + + +!> Open a MOM framework file +subroutine open_file_infra(handle, filename, action, MOM_domain, threading, fileset) + class(MOM_infra_file), intent(inout) :: handle + character(len=*), intent(in) :: filename + integer, intent(in), optional :: action + type(MOM_domain_type), optional, intent(in) :: MOM_domain + integer, intent(in), optional :: threading + integer, intent(in), optional :: fileset + + logical :: use_single_file_domain + ! True if the domain is replaced with a single-file IO layout. + + use_single_file_domain = .false. + if (present(MOM_domain) .and. present(fileset)) then + if (fileset == SINGLE_FILE) & + use_single_file_domain = .true. + endif + + if (use_single_file_domain) then + call clone_MOM_domain(MOM_domain, handle%domain, io_layout=[1,1]) + call open_file(handle%handle_infra, filename, action=action, & + MOM_domain=handle%domain, threading=threading, fileset=fileset) + else + call open_file(handle%handle_infra, filename, action=action, & + MOM_domain=MOM_domain, threading=threading, fileset=fileset) + endif + + call handle%axes%init() + call handle%fields%init() +end subroutine open_file_infra + +!> Close a MOM framework file +subroutine close_file_infra(handle) + class(MOM_infra_file), intent(inout) :: handle + + if (associated(handle%domain)) & + call deallocate_MOM_domain(handle%domain) + + call close_file(handle%handle_infra) + call handle%axes%finalize() + call handle%fields%finalize() +end subroutine close_file_infra + +!> Flush the buffer of a MOM framework file +subroutine flush_file_infra(handle) + class(MOM_infra_file), intent(in) :: handle + + call flush_file(handle%handle_infra) +end subroutine flush_file_infra + + +!> Register an axis to the MOM framework file +function register_axis_infra(handle, label, units, longname, & + cartesian, sense, domain, data, edge_axis, calendar) result(axis) + + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: label + !< The name in the file of this axis + character(len=*), intent(in) :: units + !< The units of this axis + character(len=*), intent(in) :: longname + !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian + !< A variable indicating which direction this axis corresponds with. + !! Valid values include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense + !< This is 1 for axes whose values increase upward, or -1 if they increase + !! downward. + type(domain1D), optional, intent(in) :: domain + !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data + !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis + !< If true, this axis marks an edge of the tracer cells + character(len=*), optional, intent(in) :: calendar + !< The name of the calendar used with a time axis + type(MOM_axis) :: axis + !< The axis type where this information is stored + + type(axistype) :: ax_infra + + ! Create new infra axis and assign to pre-allocated tail of axes + call write_metadata(handle%handle_infra, ax_infra, label, units, longname, & + cartesian=cartesian, sense=sense, domain=domain, data=data, & + edge_axis=edge_axis, calendar=calendar) + + call handle%axes%append(ax_infra, label) + axis%label = label +end function register_axis_infra + + +!> Register a field to the MOM framework file +function register_field_infra(handle, axes, label, units, longname, pack, & + standard_name, checksum) result(field) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), dimension(:), intent(in) :: axes + !< Handles for the axis used for this variable + character(len=*), intent(in) :: label + !< The name in the file of this variable + character(len=*), intent(in) :: units + !< The units of this variable + character(len=*), intent(in) :: longname + !< The long description of this variable + integer, optional, intent(in) :: pack + !< A precision reduction factor with which the variable. The default, 1, + !! has no reduction, but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name + !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), optional, intent(in) :: checksum + !< Checksum values that can be used to verify reads. + type(MOM_field) :: field + !< The field type where this information is stored + + type(fieldtype) :: field_infra + type(axistype), allocatable :: field_axes(:) + integer :: i + + ! Construct array of framework axes + allocate(field_axes(size(axes))) + do i = 1, size(axes) + field_axes(i) = handle%axes%get(axes(i)%label) + enddo + + call write_metadata(handle%handle_infra, field_infra, field_axes, label, & + units, longname, pack=pack, standard_name=standard_name, checksum=checksum) + + call handle%fields%append(field_infra, label) + field%label = label +end function register_field_infra + + +!> Write a 4D field to the MOM framework file +subroutine write_field_4d_infra(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field_md%label) + call write_field(handle%handle_infra, field_infra, MOM_domain, field, & + tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) +end subroutine write_field_4d_infra + + +!> Write a 3D field to the MOM framework file +subroutine write_field_3d_infra(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field_md%label) + call write_field(handle%handle_infra, field_infra, MOM_domain, field, & + tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) +end subroutine write_field_3d_infra + + +!> Write a 2D field to the MOM framework file +subroutine write_field_2d_infra(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field_md%label) + call write_field(handle%handle_infra, field_infra, MOM_domain, field, & + tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) +end subroutine write_field_2d_infra + + +!> Write a 1D field to the MOM framework file +subroutine write_field_1d_infra(handle, field_md, field, tstamp) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, dimension(:), intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field_md%label) + call write_field(handle%handle_infra, field_infra, field, tstamp=tstamp) +end subroutine write_field_1d_infra + + +!> Write a 0D field to the MOM framework file +subroutine write_field_0d_infra(handle, field_md, field, tstamp) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field_md%label) + call write_field(handle%handle_infra, field_infra, field, tstamp=tstamp) +end subroutine write_field_0d_infra + + +!> Write an axis field to the MOM framework file +subroutine write_field_axis_infra(handle, axis) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axis + !< An axis type variable with information to write + + type(axistype) :: axis_infra + !< An axis type variable with information to write + + axis_infra = handle%axes%get(axis%label) + call write_field(handle%handle_infra, axis_infra) +end subroutine write_field_axis_infra + + +!> Write global metadata to the MOM framework file +subroutine write_attribute_infra(handle, name, attribute) + class(MOM_infra_file), intent(in) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: name + !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute + !< The value of this attribute + + call write_metadata(handle%handle_infra, name, attribute) +end subroutine write_attribute_infra + + +!> True if the framework file has been opened +logical function file_is_open_infra(handle) + class(MOM_infra_file), intent(in) :: handle + !< Handle to a file to inquire about + + file_is_open_infra = fms2_file_is_open(handle%handle_infra) +end function file_is_open_infra + + +!> Return number of dimensions, variables, or time levels in a MOM infra file +subroutine get_file_info_infra(handle, ndim, nvar, ntime) + class(MOM_infra_file), intent(in) :: handle + !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim + !< The number of dimensions in the file + integer, optional, intent(out) :: nvar + !< The number of variables in the file + integer, optional, intent(out) :: ntime + !< The number of time levels in the file + + call get_file_info(handle%handle_infra, ndim, nvar, ntime) +end subroutine get_file_info_infra + + +!> Return the field metadata associated with a MOM framework file +subroutine get_file_fields_infra(handle, fields) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for I/O + type(MOM_field), intent(inout) :: fields(:) + !< Field-type descriptions of all of the variables in a file. + + type(fieldtype), allocatable :: fields_infra(:) + integer :: i + character(len=64) :: label + + allocate(fields_infra(size(fields))) + call get_file_fields(handle%handle_infra, fields_infra) + + do i = 1, size(fields) + call get_field_atts(fields_infra(i), name=label) + call handle%fields%append(fields_infra(i), trim(label)) + fields(i)%label = trim(label) + enddo +end subroutine get_file_fields_infra + + +!> Get time levels of a MOM framework file +subroutine get_file_times_infra(handle, time_values, ntime) + class(MOM_infra_file), intent(in) :: handle + !< Handle for a file that is open for I/O + real, allocatable, dimension(:), intent(inout) :: time_values + !< The real times for the records in file. + integer, optional, intent(out) :: ntime + !< The number of time levels in the file + + call get_file_times(handle%handle_infra, time_values, ntime=ntime) +end subroutine get_file_times_infra + + +!> Get attributes from a field +subroutine get_field_atts_infra(handle, field, name, units, longname, checksum) + class(MOM_infra_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field to extract information from + character(len=*), optional, intent(out) :: name + !< The variable name + character(len=*), optional, intent(out) :: units + !< The units of the variable + character(len=*), optional, intent(out) :: longname + !< The long name of the variable + integer(kind=int64), optional, intent(out) :: checksum(:) + !< The checksums of the variable in a file + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field%label) + call get_field_atts(field_infra, name, units, longname, checksum) +end subroutine get_field_atts_infra + + +!> Interface to read_field_chksum +subroutine read_field_chksum_infra(handle, field, chksum, valid_chksum) + class(MOM_infra_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field whose checksum attribute is to be read + integer(kind=int64), intent(out) :: chksum + !< The checksum for the field. + logical, intent(out) :: valid_chksum + !< If true, chksum has been successfully read + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field%label) + call read_field_chksum(field_infra, chksum, valid_chksum) +end subroutine read_field_chksum_infra + +!> Get the native (fieldtype) fields of a MOM framework file +subroutine get_file_fieldtypes(handle, fields) + class(MOM_infra_file), intent(in) :: handle + type(fieldtype), intent(out) :: fields(:) + + type(field_node_infra), pointer :: node + integer :: i + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => handle%fields%head + do i = 1, size(fields) + if (.not. associated(node%next)) & + call MOM_error(FATAL, 'fields(:) size exceeds number of registered fields.') + fields(i) = node%field + node => node%next + enddo +end subroutine get_file_fieldtypes + + +! MOM_netcdf_file methods + +!> Open a MOM netCDF file +subroutine open_file_nc(handle, filename, action, MOM_domain, threading, fileset) + class(MOM_netcdf_file), intent(inout) :: handle + character(len=*), intent(in) :: filename + integer, intent(in), optional :: action + type(MOM_domain_type), optional, intent(in) :: MOM_domain + integer, intent(in), optional :: threading + integer, intent(in), optional :: fileset + + if (.not. present(MOM_domain) .and. .not. is_root_PE()) return + + call open_netcdf_file(handle%handle_nc, filename, action) + handle%is_open = .true. + + if (present(MOM_domain)) then + handle%domain_decomposed = .true. + + ! Input files use unrotated indexing. + if (associated(MOM_domain%domain_in)) then + call hor_index_init(MOM_domain%domain_in, handle%HI) + else + call hor_index_init(MOM_domain, handle%HI) + endif + endif + + call handle%axes%init() + call handle%fields%init() +end subroutine open_file_nc + + +!> Close a MOM netCDF file +subroutine close_file_nc(handle) + class(MOM_netcdf_file), intent(inout) :: handle + + if (.not. handle%domain_decomposed .and. .not. is_root_PE()) return + + handle%is_open = .false. + call close_netcdf_file(handle%handle_nc) +end subroutine close_file_nc + + +!> Flush the buffer of a MOM netCDF file +subroutine flush_file_nc(handle) + class(MOM_netcdf_file), intent(in) :: handle + + if (.not. is_root_PE()) return + + call flush_netcdf_file(handle%handle_nc) +end subroutine flush_file_nc + + +!> Register an axis to the MOM netcdf file +function register_axis_nc(handle, label, units, longname, cartesian, sense, & + domain, data, edge_axis, calendar) result(axis) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a netCDF file that is open for writing + character(len=*), intent(in) :: label + !< The name in the file of this axis + character(len=*), intent(in) :: units + !< The units of this axis + character(len=*), intent(in) :: longname + !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian + !< A variable indicating which direction this axis corresponds with. + !! Valid values include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense + !< This is 1 for axes whose values increase upward, or -1 if they increase + !! downward. + type(domain1D), optional, intent(in) :: domain + !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data + !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis + !< If true, this axis marks an edge of the tracer cells + character(len=*), optional, intent(in) :: calendar + !< The name of the calendar used with a time axis + type(MOM_axis) :: axis + + type(netcdf_axis) :: axis_nc + + if (is_root_PE()) then + axis_nc = register_netcdf_axis(handle%handle_nc, label, units, longname, & + data, cartesian, sense) + + call handle%axes%append(axis_nc, label) + endif + axis%label = label +end function register_axis_nc + + +!> Register a field to the MOM netcdf file +function register_field_nc(handle, axes, label, units, longname, pack, & + standard_name, checksum) result(field) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axes(:) + !< Handles for the axis used for this variable + character(len=*), intent(in) :: label + !< The name in the file of this variable + character(len=*), intent(in) :: units + !< The units of this variable + character(len=*), intent(in) :: longname + !< The long description of this variable + integer, optional, intent(in) :: pack + !< A precision reduction factor with which the variable. The default, 1, + !! has no reduction, but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name + !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), optional, intent(in) :: checksum + !< Checksum values that can be used to verify reads. + type(MOM_field) :: field + + type(netcdf_field) :: field_nc + type(netcdf_axis), allocatable :: axes_nc(:) + integer :: i + + if (is_root_PE()) then + allocate(axes_nc(size(axes))) + do i = 1, size(axes) + axes_nc(i) = handle%axes%get(axes(i)%label) + enddo + + field_nc = register_netcdf_field(handle%handle_nc, label, axes_nc, longname, units) + + call handle%fields%append(field_nc, label) + endif + field%label = label +end function register_field_nc + + +!> Write global metadata to the MOM netcdf file +subroutine write_attribute_nc(handle, name, attribute) + class(MOM_netcdf_file), intent(in) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: name + !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute + !< The value of this attribute + + if (.not. is_root_PE()) return + + call write_netcdf_attribute(handle%handle_nc, name, attribute) +end subroutine write_attribute_nc + + +!> Write a 4D field to the MOM netcdf file +subroutine write_field_4d_nc(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(netcdf_field) :: field_nc + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) +end subroutine write_field_4d_nc + + +!> Write a 3D field to the MOM netcdf file +subroutine write_field_3d_nc(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(netcdf_field) :: field_nc + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) +end subroutine write_field_3d_nc + + +!> Write a 2D field to the MOM netcdf file +subroutine write_field_2d_nc(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(netcdf_field) :: field_nc + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) +end subroutine write_field_2d_nc + + +!> Write a 1D field to the MOM netcdf file +subroutine write_field_1d_nc(handle, field_md, field, tstamp) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, dimension(:), intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + + type(netcdf_field) :: field_nc + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) +end subroutine write_field_1d_nc + + +!> Write a 0D field to the MOM netcdf file +subroutine write_field_0d_nc(handle, field_md, field, tstamp) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + + type(netcdf_field) :: field_nc + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) +end subroutine write_field_0d_nc + + +!> Write an axis field to the MOM netcdf file +subroutine write_field_axis_nc(handle, axis) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axis + !< An axis type variable with information to write + + type(netcdf_axis) :: axis_nc + + if (.not. is_root_PE()) return + + axis_nc = handle%axes%get(axis%label) + call write_netcdf_axis(handle%handle_nc, axis_nc) +end subroutine write_field_axis_nc + + +!> True if the framework file has been opened +logical function file_is_open_nc(handle) + class(MOM_netcdf_file), intent(in) :: handle + !< Handle to a file to inquire about + + file_is_open_nc = handle%is_open +end function file_is_open_nc + + +!> Return number of dimensions, variables, or time levels in a MOM netcdf file +subroutine get_file_info_nc(handle, ndim, nvar, ntime) + class(MOM_netcdf_file), intent(in) :: handle + !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim + !< The number of dimensions in the file + integer, optional, intent(out) :: nvar + !< The number of variables in the file + integer, optional, intent(out) :: ntime + !< The number of time levels in the file + + integer :: ndim_nc, nvar_nc + + if (.not. is_root_PE()) return + + call get_netcdf_size(handle%handle_nc, ndims=ndim_nc, nvars=nvar_nc, nsteps=ntime) + + ! MOM I/O follows legacy FMS behavior and excludes axes from field count + if (present(ndim)) ndim = ndim_nc + if (present(nvar)) nvar = nvar_nc - ndim_nc +end subroutine get_file_info_nc + + +!> Update the axes and fields descriptors of a MOM netCDF file +subroutine update_file_contents_nc(handle) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for I/O + + type(netcdf_axis), allocatable :: axes_nc(:) + ! netCDF axis descriptors + type(netcdf_field), allocatable :: fields_nc(:) + ! netCDF field descriptors + integer :: i + ! Index counter + + if (.not. handle%domain_decomposed .and. .not. is_root_PE()) return + + call get_netcdf_fields(handle%handle_nc, axes_nc, fields_nc) + + do i = 1, size(axes_nc) + call handle%axes%append(axes_nc(i), axes_nc(i)%label) + enddo + + do i = 1, size(fields_nc) + call handle%fields%append(fields_nc(i), fields_nc(i)%label) + enddo +end subroutine update_file_contents_nc + + +!> Return the field descriptors of a MOM netCDF file +subroutine get_file_fields_nc(handle, fields) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for I/O + type(MOM_field), intent(inout) :: fields(:) + !< Field-type descriptions of all of the variables in a file. + + type(field_node_nc), pointer :: node => null() + ! Current field list node + integer :: n + ! Field counter + + if (.not. is_root_PE()) return + + ! Generate the manifest of axes and fields + call handle%update() + + n = 0 + node => handle%fields%head + do while (associated(node%next)) + n = n + 1 + fields(n)%label = trim(node%label) + node => node%next + enddo +end subroutine get_file_fields_nc + + +!> Get attributes from a netCDF field +subroutine get_field_atts_nc(handle, field, name, units, longname, checksum) + class(MOM_netcdf_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field to extract information from + character(len=*), optional, intent(out) :: name + !< The variable name + character(len=*), optional, intent(out) :: units + !< The units of the variable + character(len=*), optional, intent(out) :: longname + !< The long name of the variable + integer(kind=int64), optional, intent(out) :: checksum(:) + !< The checksums of the variable in a file + + call MOM_error(FATAL, 'get_field_atts over netCDF is not yet implemented.') +end subroutine get_field_atts_nc + + +!> Interface to read_field_chksum +subroutine read_field_chksum_nc(handle, field, chksum, valid_chksum) + class(MOM_netcdf_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field whose checksum attribute is to be read + integer(kind=int64), intent(out) :: chksum + !< The checksum for the field. + logical, intent(out) :: valid_chksum + !< If true, chksum has been successfully read + + call MOM_error(FATAL, 'read_field_chksum over netCDF is not yet implemented.') +end subroutine read_field_chksum_nc + + +!> Read the values of a netCDF field into an array that might have halos +subroutine get_field_nc(handle, label, values, rescale) + class(MOM_netcdf_file), intent(in) :: handle + !< Handle of netCDF file to be read + character(len=*), intent(in) :: label + !< Field variable name + real, intent(inout) :: values(:,:) + !< Field values read from the file. It would be intent(out) but for the + !! need to preserve any initialized values in the halo regions. + real, optional, intent(in) :: rescale + !< A multiplicative rescaling factor for the values that are read. + !! Omitting this is the same as setting it to 1. + + logical :: data_domain + ! True if values matches the data domain size + logical :: compute_domain + ! True if values matches the compute domain size + type(netcdf_field) :: field_nc + ! netCDF field associated with label + integer :: isc, iec, jsc, jec + ! Index bounds of compute domain + integer :: isd, ied, jsd, jed + ! Index bounds of data domain + integer :: iscl, iecl, jscl, jecl + ! Local 1-based index bounds of compute domain + integer :: bounds(2,2) + ! Index bounds of domain + real, allocatable :: values_c(:,:) + ! Field values on the compute domain, used for copying to a data domain + + isc = handle%HI%isc + iec = handle%HI%iec + jsc = handle%HI%jsc + jec = handle%HI%jec + + isd = handle%HI%isd + ied = handle%HI%ied + jsd = handle%HI%jsd + jed = handle%HI%jed + + data_domain = all(shape(values) == [ied-isd+1, jed-jsd+1]) + compute_domain = all(shape(values) == [iec-isc+1, jec-jsc+1]) + + ! NOTE: Data on face and vertex points is not yet supported. This is a + ! temporary check to detect such cases, but may be removed in the future. + if (.not. (compute_domain .or. data_domain)) & + call MOM_error(FATAL, 'get_field_nc: Only compute and data domains ' // & + 'are currently supported.') + + field_nc = handle%fields%get(label) + + if (data_domain) & + allocate(values_c(1:iec-isc+1,1:jec-jsc+1)) + + if (handle%domain_decomposed) then + bounds(1,:) = [isc, jsc] + [handle%HI%idg_offset, handle%HI%jdg_offset] + bounds(2,:) = [iec, jec] + [handle%HI%idg_offset, handle%HI%jdg_offset] + if (data_domain) then + call read_netcdf_field(handle%handle_nc, field_nc, values_c, bounds=bounds) + else + call read_netcdf_field(handle%handle_nc, field_nc, values, bounds=bounds) + endif + else + if (data_domain) then + call read_netcdf_field(handle%handle_nc, field_nc, values_c) + else + call read_netcdf_field(handle%handle_nc, field_nc, values) + endif + endif + + if (data_domain) then + iscl = isc - isd + 1 + iecl = iec - isd + 1 + jscl = jsc - jsd + 1 + jecl = jec - jsd + 1 + + values(iscl:iecl,jscl:jecl) = values_c(:,:) + else + iscl = 1 + iecl = iec - isc + 1 + jscl = 1 + jecl = jec - jsc + 1 + endif + + ! NOTE: It is more efficient to do the rescale in-place while copying + ! values_c(:,:) to values(:,:). But since rescale is only present for + ! debugging, we can probably disregard this impact on performance. + if (present(rescale)) then + if (rescale /= 1.0) then + values(iscl:iecl,jscl:jecl) = rescale * values(iscl:iecl,jscl:jecl) + endif + endif +end subroutine get_field_nc + + +!> \namespace MOM_IO_file +!! +!! This file defines the MOM_file classes used to inferface with the internal +!! IO handlers, such as the configured "infra" layer (FMS) or native netCDF. +!! +!! `MOM_file`: The generic class used to reference any file type +!! Cannot be used in a variable declaration. +!! +!! `MOM_infra_file`: A file handler for use by the infra layer. Currently this +!! means an FMS file, such a restart or diagnostic output. +!! +!! `MOM_netcdf_file`: A netCDF file handler for MOM-specific I/O. This may +!! include operations outside the scope of FMS or other infra frameworks. + +end module MOM_io_file diff --git a/framework/MOM_memory_macros.h b/framework/MOM_memory_macros.h new file mode 100644 index 0000000000..6ac3e7566b --- /dev/null +++ b/framework/MOM_memory_macros.h @@ -0,0 +1,191 @@ +!//! \brief Memory macros +!//! \details This is a header file to define macros for static and dynamic memory allocation. +!//! Define STATIC_MEMORY_ in MOM_memory.h for static memory allocation. +!//! Otherwise dynamic memory allocation will be assumed. +!//! +!//! For explanation of symmetric and non-symmetric memory modes see \ref Horizontal_Indexing. +!//! \file MOM_memory_macros.h + +#ifdef STATIC_MEMORY_ +!/* Static memory allocation section */ + +!/// Deallocates array x when using dynamic memory mode. Does nothing in static memory mode. +# define DEALLOC_(x) +!/// Allocates array x when using dynamic memory mode. Does nothing in static memory mode. +# define ALLOC_(x) +!/// Attaches the ALLOCATABLE attribute to an array in dynamic memory mode. Does nothing in static memory mode. +# define ALLOCABLE_ +!/// Attaches the POINTER attribute to an array in dynamic memory mode. Does nothing in static memory mode. +# define PTR_ +!/// Nullify a pointer in dynamic memory mode. Does nothing in static memory mode. +# define TO_NULL_ + +!/* These are the macros that should be used when setting up ALLOCABLE_ or PTR_ (heap) variables. */ + +!/// Expands to : in dynamic memory mode, or is the i-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or v- points. +# define NIMEM_ (((NIGLOBAL_-1)/NIPROC_)+1+2*NIHALO_) +!/// Expands to : in dynamic memory mode, or is the j-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or u- points. +# define NJMEM_ (((NJGLOBAL_-1)/NJPROC_)+1+2*NJHALO_) + +# ifdef SYMMETRIC_MEMORY_ +!/// Expands to : or 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or u- points. +# define NIMEMB_ 0:NIMEM_ +!/// Expands to : or 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or v- points. +# define NJMEMB_ 0:NJMEM_ +# else +!/// Expands to : or 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or u- points. +# define NIMEMB_ NIMEM_ +!/// Expands to : or 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or v- points. +# define NJMEMB_ NJMEM_ +# endif +!/// Expands to : in dynamic memory mode, or to NIMEMB_ in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or v- points. +# define NIMEMB_PTR_ NIMEMB_ +!/// Expands to : in dynamic memory mode, or to NJMEMB_ in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or u- points. +# define NJMEMB_PTR_ NJMEMB_ +!/// Expands to 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. +!/// Use for always-symmetric heap (ALLOCABLE_ or PTR_) variables at q- or u- points. +# define NIMEMB_SYM_ 0:NIMEM_ +!/// Expands to 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. +!/// Use for always-symmetric heap (ALLOCABLE_ or PTR_) variables at q- or v- points. +# define NJMEMB_SYM_ 0:NJMEM_ +!/// Expands to : in dynamic memory mode or is to the number of layers in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) layer variables. +# define NKMEM_ NK_ +!/// Expands to 0: in dynamic memory mode or to 0:NK_ in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) interface variables. +# define NKMEM0_ 0:NK_ +!/// Expands to : in dynamic memory mode or to NK_+1 in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) interface variables. +# define NK_INTERFACE_ NK_+1 +!/// Expands to : or 1. UNKNOWN PURPOSE! +# define C1_ 1 +!/// Expands to : or 2. UNKNOWN PURPOSE! +# define C2_ 2 +!/// Expands to : or 3. UNKNOWN PURPOSE! +# define C3_ 3 + +!/* These are the macros that should be used for subroutine arguments or for automatically allocated (stack) variables. */ + +!/// The i-shape of a dummy argument staggered at h- or v-points. +# define SZI_(G) NIMEM_ +!/// The j-shape of a dummy argument staggered at h- or u-points. +# define SZJ_(G) NJMEM_ +!/// The k-shape of a layer dummy argument. +# define SZK_(G) NK_ +!/// The k-shape of an interface dummy argument. +# define SZK0_(G) 0:NK_ +!/// The i-shape of a dummy argument staggered at q- or u-points. +# define SZIB_(G) NIMEMB_ +!/// The j-shape of a dummy argument staggered at q- or v-points. +# define SZJB_(G) NJMEMB_ +!/// The i-shape of a symmetric dummy argument staggered at q- or u-points. +# define SZIBS_(G) 0:NIMEM_ +!/// The j-shape of a symmetric dummy argument staggered at q- or v-points. +# define SZJBS_(G) 0:NJMEM_ + +#else +!/* Dynamic memory allocation section */ + +!/// Deallocates array x when using dynamic memory mode. Does nothing in static memory mode. +# define DEALLOC_(x) deallocate(x) +!/// Allocates array x when using dynamic memory mode. Does nothing in static memory mode. +# define ALLOC_(x) allocate(x) +!/// Attaches the ALLOCATABLE attribute to an array in dynamic memory mode. Does nothing in static memory mode. +# define ALLOCABLE_ ,allocatable +!/// Attaches the POINTER attribute to an array in dynamic memory mode. Does nothing in static memory mode. +# define PTR_ ,pointer +!/// Nullify a pointer in dynamic memory mode. Does nothing in static memory mode. +# define TO_NULL_ =>NULL() + +!/* These are the macros that should be used when setting up ALLOCABLE_ or PTR_ (heap) variables. */ + +!/// Expands to : in dynamic memory mode, or is the i-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or v- points. +# define NIMEM_ : +!/// Expands to : in dynamic memory mode, or is the j-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or u- points. +# define NJMEM_ : +!/// Expands to : in dynamic memory mode, or to NIMEMB_ in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or v- points. +# define NIMEMB_PTR_ : +!/// Expands to : in dynamic memory mode, or to NJMEMB_ in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or u- points. +# define NJMEMB_PTR_ : +# ifdef SYMMETRIC_MEMORY_ +!/// Expands to : or 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or u- points. +# define NIMEMB_ 0: +!/// Expands to : or 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or v- points. +# define NJMEMB_ 0: +# else +!/// Expands to : or 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or u- points. +# define NIMEMB_ : +!/// Expands to : or 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or v- points. +# define NJMEMB_ : +# endif +!/// Expands to 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. +!/// Use for always-symmetric heap (ALLOCABLE_ or PTR_) variables at q- or u- points. +# define NIMEMB_SYM_ 0: +!/// Expands to 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. +!/// Use for always-symmetric heap (ALLOCABLE_ or PTR_) variables at q- or v- points. +# define NJMEMB_SYM_ 0: +!/// Expands to : in dynamic memory mode or is to the number of layers in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) layer variables. +# define NKMEM_ : +!/// Expands to 0: in dynamic memory mode or to 0:NK_ in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) interface variables. +# define NKMEM0_ 0: +!/// Expands to : in dynamic memory mode or to NK_+1 in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) interface variables. +# define NK_INTERFACE_ : +!/// Expands to : or 1. UNKNOWN PURPOSE! +# define C1_ : +!/// Expands to : or 2. UNKNOWN PURPOSE! +# define C2_ : +!/// Expands to : or 3. UNKNOWN PURPOSE! +# define C3_ : + +!/// \todo Explain or remove C1_, C2_ and C3_ + +!/* These are the macros that should be used for subroutine arguments or for automatically allocated (stack) variables. */ + +!/// The i-shape of a dummy argument staggered at h- or v-points. +# define SZI_(G) G%isd:G%ied +!/// The j-shape of a dummy argument staggered at h- or u-points. +# define SZJ_(G) G%jsd:G%jed +!/// The k-shape of a layer dummy argument. +# define SZK_(G) G%ke +!/// The k-shape of an interface dummy argument. +# define SZK0_(G) 0:G%ke +!/// The i-shape of a dummy argument staggered at q- or u-points. +# define SZIB_(G) G%IsdB:G%IedB +!/// The j-shape of a dummy argument staggered at q- or v-points. +# define SZJB_(G) G%JsdB:G%JedB +!/// The i-shape of a symmetric dummy argument staggered at q- or u-points. +# define SZIBS_(G) G%isd-1:G%ied +!/// The j-shape of a symmetric dummy argument staggered at q- or v-points. +# define SZJBS_(G) G%jsd-1:G%jed + +#endif + +!/* These dynamic size macros always give the same results (for now). */ + +!/// The i-shape of a dynamic dummy argument staggered at h- or v-points. +#define SZDI_(G) G%isd:G%ied +!/// The i-shape of a dynamic dummy argument staggered at q- or u-points. +#define SZDIB_(G) G%IsdB:G%IedB +!/// The j-shape of a dynamic dummy argument staggered at h- or u-points. +#define SZDJ_(G) G%jsd:G%jed +!/// The j-shape of a dynamic dummy argument staggered at q- or v-points. +#define SZDJB_(G) G%JsdB:G%JedB diff --git a/framework/MOM_netcdf.F90 b/framework/MOM_netcdf.F90 new file mode 100644 index 0000000000..95e6aa7bb7 --- /dev/null +++ b/framework/MOM_netcdf.F90 @@ -0,0 +1,796 @@ +!> MOM6 interface to netCDF operations +module MOM_netcdf + +! This file is part of MOM6. See LICENSE.md for the license. + +use, intrinsic :: iso_fortran_env, only : real32, real64 + +use netcdf, only : nf90_create, nf90_open, nf90_close +use netcdf, only : nf90_sync +use netcdf, only : NF90_CLOBBER, NF90_NOCLOBBER, NF90_WRITE, NF90_NOWRITE +use netcdf, only : nf90_enddef +use netcdf, only : nf90_def_dim, nf90_def_var +use netcdf, only : NF90_UNLIMITED +use netcdf, only : nf90_get_var +use netcdf, only : nf90_put_var, nf90_put_att +use netcdf, only : NF90_FLOAT, NF90_DOUBLE +use netcdf, only : nf90_strerror, NF90_NOERR +use netcdf, only : NF90_GLOBAL +use netcdf, only : nf90_inquire, nf90_inquire_dimension, nf90_inquire_variable +use netcdf, only : nf90_inq_dimids, nf90_inq_varids +use netcdf, only : NF90_MAX_NAME + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_io_infra, only : READONLY_FILE, WRITEONLY_FILE +use MOM_io_infra, only : APPEND_FILE, OVERWRITE_FILE + +implicit none ; private + +public :: netcdf_file_type +public :: netcdf_axis +public :: netcdf_field +public :: open_netcdf_file +public :: close_netcdf_file +public :: flush_netcdf_file +public :: register_netcdf_axis +public :: register_netcdf_field +public :: write_netcdf_field +public :: write_netcdf_axis +public :: write_netcdf_attribute +public :: get_netcdf_size +public :: get_netcdf_fields +public :: read_netcdf_field + + +!> Internal time value used to indicate an uninitialized time +real, parameter :: NULLTIME = -1 +! NOTE: For now, we use the FMS-compatible value, but may change in the future. + + +!> netCDF file abstraction +type :: netcdf_file_type + private + integer :: ncid + !< netCDF file ID + character(len=:), allocatable :: filename + !< netCDF filename + logical :: define_mode + !< True if file is in define mode. + integer :: time_id + !< Time axis variable ID + real :: time + !< Current model time + integer :: time_level + !< Current time level for output +end type netcdf_file_type + + +!> Dimension axis for a netCDF file +type :: netcdf_axis + private + character(len=:), allocatable, public :: label + !< Axis label name + real, allocatable :: points(:) + !< Grid points along the axis + integer :: dimid + !< netCDF dimension ID associated with axis + integer :: varid + !< netCDF variable ID associated with axis +end type netcdf_axis + + +!> Field variable for a netCDF file +type netcdf_field + private + character(len=:), allocatable, public :: label + !< Variable name + integer :: varid + !< netCDF variable ID for field +end type netcdf_field + + +!> Write values to a field of a netCDF file +interface write_netcdf_field + module procedure write_netcdf_field_4d + module procedure write_netcdf_field_3d + module procedure write_netcdf_field_2d + module procedure write_netcdf_field_1d + module procedure write_netcdf_field_0d +end interface write_netcdf_field + +contains + +subroutine open_netcdf_file(handle, filename, mode) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + character(len=*), intent(in) :: filename + !< netCDF filename + integer, intent(in), optional :: mode + !< Input MOM I/O mode + + integer :: io_mode + ! MOM I/O mode + integer :: cmode + ! netCDF creation mode + integer :: rc + ! nf90_create return code + character(len=:), allocatable :: msg + ! netCDF error message buffer + + ! I/O configuration + io_mode = WRITEONLY_FILE + if (present(mode)) io_mode = mode + + ! Translate the MOM I/O config to the netCDF mode + select case(io_mode) + case (WRITEONLY_FILE) + rc = nf90_create(filename, nf90_noclobber, handle%ncid) + handle%define_mode = .true. + case (OVERWRITE_FILE) + rc = nf90_create(filename, nf90_clobber, handle%ncid) + handle%define_mode = .true. + case (APPEND_FILE) + rc = nf90_open(filename, nf90_write, handle%ncid) + handle%define_mode = .false. + case (READONLY_FILE) + rc = nf90_open(filename, nf90_nowrite, handle%ncid) + handle%define_mode = .false. + case default + call MOM_error(FATAL, & + 'open_netcdf_file: File ' // filename // ': Unknown mode.') + end select + call check_netcdf_call(rc, 'open_netcdf_file', 'File ' // filename) + + handle%filename = filename + + ! FMS writes the filename as an attribute + if (any(io_mode == [WRITEONLY_FILE, OVERWRITE_FILE])) & + call write_netcdf_attribute(handle, 'filename', filename) +end subroutine open_netcdf_file + + +!> Close an opened netCDF file. +subroutine close_netcdf_file(handle) + type(netcdf_file_type), intent(in) :: handle + + integer :: rc + + rc = nf90_close(handle%ncid) + call check_netcdf_call(rc, 'close_netcdf_file', & + 'File "' // handle%filename // '"') +end subroutine close_netcdf_file + + +!> Flush buffered output to the netCDF file +subroutine flush_netcdf_file(handle) + type(netcdf_file_type), intent(in) :: handle + + integer :: rc + + rc = nf90_sync(handle%ncid) + call check_netcdf_call(rc, 'flush_netcdf_file', & + 'File "' // handle%filename // '"') +end subroutine flush_netcdf_file + + +!> Change netCDF mode of handle from 'define' to 'write'. +subroutine enable_netcdf_write(handle) + type(netcdf_file_type), intent(inout) :: handle + + integer :: rc + + if (handle%define_mode) then + rc = nf90_enddef(handle%ncid) + call check_netcdf_call(rc, 'enable_netcdf_write', & + 'File "' // handle%filename // '"') + handle%define_mode = .false. + endif +end subroutine enable_netcdf_write + + +!> Register a netCDF variable +function register_netcdf_field(handle, label, axes, longname, units) & + result(field) + type(netcdf_file_type), intent(in) :: handle + !< netCDF file handle + character(len=*), intent(in) :: label + !< netCDF field name in the file + type(netcdf_axis), intent(in) :: axes(:) + !< Axes along which field is defined + character(len=*), intent(in) :: longname + !< Long name of the netCDF field + character(len=*), intent(in) :: units + !< Field units of measurement + type(netcdf_field) :: field + !< netCDF field + + integer :: rc + ! netCDF function return code + integer :: i + ! Loop index + integer, allocatable :: dimids(:) + ! netCDF dimension IDs of axes + integer :: xtype + ! netCDF data type + + ! Gather the axis netCDF dimension IDs + allocate(dimids(size(axes))) + dimids(:) = [(axes(i)%dimid, i = 1, size(axes))] + + ! Determine the corresponding netCDF data type + ! TODO: Support a `pack`-like argument + select case (kind(1.0)) + case (real32) + xtype = NF90_FLOAT + case (real64) + xtype = NF90_DOUBLE + case default + call MOM_error(FATAL, "register_netcdf_axis: Unknown kind(real).") + end select + + ! Register the field variable + rc = nf90_def_var(handle%ncid, label, xtype, dimids, field%varid) + call check_netcdf_call(rc, 'register_netcdf_field', & + 'File "' // handle%filename // '", Field "' // label // '"') + + ! Assign attributes + + rc = nf90_put_att(handle%ncid, field%varid, 'long_name', longname) + call check_netcdf_call(rc, 'register_netcdf_field', & + 'Attribute "long_name" of variable "' // label // '" in file "' & + // handle%filename // '"') + + rc = nf90_put_att(handle%ncid, field%varid, 'units', units) + call check_netcdf_call(rc, 'register_netcdf_field', & + 'Attribute "units" of variable "' // label // '" in file "' & + // handle%filename // '"') +end function register_netcdf_field + + +!> Create an axis and associated dimension in a netCDF file +function register_netcdf_axis(handle, label, units, longname, points, & + cartesian, sense) result(axis) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + character(len=*), intent(in) :: label + !< netCDF axis name in the file + character(len=*), intent(in), optional :: units + !< Axis units of measurement + character(len=*), intent(in), optional :: longname + !< Long name of the axis + real, intent(in), optional :: points(:) + !< Values of axis points (for fixed axes) + character(len=*), intent(in), optional :: cartesian + !< Character denoting axis direction: X, Y, Z, T, or N for none + integer, intent(in), optional :: sense + !< Axis direction; +1 if axis increases upward or -1 if downward + + type(netcdf_axis) :: axis + !< netCDF coordinate axis + + integer :: xtype + ! netCDF external data type + integer :: rc + ! netCDF function return code + logical :: unlimited + ! True if the axis is unlimited in size (e.g. time) + integer :: axis_size + ! Either the number of points in the axis, or unlimited flag + integer :: axis_sense + ! Axis direction; +1 if axis increases upward or -1 if downward + character(len=:), allocatable :: sense_attr + ! CF-compiant value of sense attribute (as 'positive') + + ! Create the axis dimension + unlimited = .false. + if (present(cartesian)) then + if (cartesian == 'T') unlimited = .true. + endif + + ! Either the axis is explicitly set with data or is declared as unlimited + if (present(points) .eqv. unlimited) then + call MOM_error(FATAL, & + "Axis must either have explicit points or be a time axis ('T').") + endif + + if (present(points)) then + axis_size = size(points) + allocate(axis%points(axis_size)) + axis%points(:) = points(:) + else + axis_size = NF90_UNLIMITED + endif + + rc = nf90_def_dim(handle%ncid, label, axis_size, axis%dimid) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Dimension "' // label // '" in file "' // handle%filename // '"') + + ! Determine the corresponding netCDF data type + ! TODO: Support a `pack`-like argument + select case (kind(1.0)) + case (real32) + xtype = NF90_FLOAT + case (real64) + xtype = NF90_DOUBLE + case default + call MOM_error(FATAL, "register_netcdf_axis: Unknown kind(real).") + end select + + ! Create a variable corresponding to the axis + rc = nf90_def_var(handle%ncid, label, xtype, axis%dimid, axis%varid) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Variable ' // label // ' in file ' // handle%filename) + + ! Define the time axis, if available + if (unlimited) then + handle%time_id = axis%varid + handle%time_level = 0 + handle%time = NULLTIME + endif + + ! Assign attributes if present + if (present(longname)) then + rc = nf90_put_att(handle%ncid, axis%varid, 'long_name', longname) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Attribute ''long_name'' of variable ' // label // ' in file ' & + // handle%filename) + endif + + if (present(units)) then + rc = nf90_put_att(handle%ncid, axis%varid, 'units', units) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Attribute ''units'' of variable ' // label // ' in file ' & + // handle%filename) + endif + + if (present(cartesian)) then + rc = nf90_put_att(handle%ncid, axis%varid, 'cartesian_axis', cartesian) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Attribute ''cartesian_axis'' of variable ' // label // ' in file ' & + // handle%filename) + endif + + axis_sense = 0 + if (present(sense)) axis_sense = sense + + if (axis_sense /= 0) then + select case (axis_sense) + case (1) + sense_attr = 'up' + case (-1) + sense_attr = 'down' + case default + call MOM_error(FATAL, 'register_netcdf_axis: sense must be either ' & + // '0, 1, or -1.') + end select + rc = nf90_put_att(handle%ncid, axis%varid, 'positive', sense_attr) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Attribute "positive" of variable "' // label // '" in file "' & + // handle%filename // '"') + endif +end function register_netcdf_axis + + +!> Write a 4D array to a compatible netCDF field +subroutine write_netcdf_field_4d(handle, field, values, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: values(:,:,:,:) + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(5) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(:4) = 1 + start(5) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, values, start) + else + rc = nf90_put_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_4d + + +!> Write a 3D array to a compatible netCDF field +subroutine write_netcdf_field_3d(handle, field, values, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: values(:,:,:) + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(4) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(:3) = 1 + start(4) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, values, start) + else + rc = nf90_put_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_3d + + +!> Write a 2D array to a compatible netCDF field +subroutine write_netcdf_field_2d(handle, field, values, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: values(:,:) + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(3) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(:2) = 1 + start(3) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, values, start) + else + rc = nf90_put_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_2d + + +!> Write a 1D array to a compatible netCDF field +subroutine write_netcdf_field_1d(handle, field, values, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: values(:) + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(2) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(1) = 1 + start(2) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, values, start) + else + rc = nf90_put_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_1d + + +!> Write a scalar to a compatible netCDF field +subroutine write_netcdf_field_0d(handle, field, scalar, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: scalar + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(1) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(1) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, scalar, start) + else + rc = nf90_put_var(handle%ncid, field%varid, scalar) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_0d + + +!> Write axis points to associated netCDF variable +subroutine write_netcdf_axis(handle, axis) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_axis), intent(in) :: axis + !< field variable + + integer :: rc + ! netCDF return code + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + rc = nf90_put_var(handle%ncid, axis%varid, axis%points) + call check_netcdf_call(rc, 'write_netcdf_axis', & + 'File "' // handle%filename // '", Axis "' // axis%label // '"') +end subroutine write_netcdf_axis + + +!> Write a global attribute to a netCDF file +subroutine write_netcdf_attribute(handle, label, attribute) + type(netcdf_file_type), intent(in) :: handle + !< netCDF file handle + character(len=*), intent(in) :: label + !< File attribute + character(len=*), intent(in) :: attribute + !< File attribute value + + integer :: rc + ! netCDF return code + + rc = nf90_put_att(handle%ncid, NF90_GLOBAL, label, attribute) + call check_netcdf_call(rc, 'write_netcdf_attribute', & + 'File "' // handle%filename // '", Attribute "' // label // '"') +end subroutine write_netcdf_attribute + + +! This is a thin interface to nf90_inquire, designed to mirror the existing +! I/O API. A more axis-aware system might not need this, but for now it's here +!> Get the number of dimensions, variables, and timesteps in a netCDF file +subroutine get_netcdf_size(handle, ndims, nvars, nsteps) + type(netcdf_file_type), intent(in) :: handle + !< netCDF input file + integer, intent(out), optional :: ndims + !< number of dimensions in the file + integer, intent(out), optional :: nvars + !< number of variables in the file + integer, intent(out), optional :: nsteps + !< number of values in the file's unlimited axis + + integer :: rc + ! netCDF return code + integer :: unlimited_dimid + ! netCDF dimension ID for unlimited time axis + + rc = nf90_inquire(handle%ncid, & + nDimensions=ndims, & + nVariables=nvars, & + unlimitedDimId=unlimited_dimid & + ) + call check_netcdf_call(rc, 'get_netcdf_size', & + 'File "' // handle%filename // '"') + + rc = nf90_inquire_dimension(handle%ncid, unlimited_dimid, len=nsteps) + call check_netcdf_call(rc, 'get_netcdf_size', & + 'File "' // handle%filename // '"') +end subroutine get_netcdf_size + + +!> Get the metadata of the registered fields in a netCDF file +subroutine get_netcdf_fields(handle, axes, fields) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_axis), intent(inout), allocatable :: axes(:) + !< netCDF file axes + type(netcdf_field), intent(inout), allocatable :: fields(:) + !< netCDF file fields + + integer :: ndims + ! Number of netCDF dimensions + integer :: nvars + ! Number of netCDF dimensions + type(netcdf_field), allocatable :: vars(:) + ! netCDF variables in handle + integer :: nfields + ! Number of fields in the file (i.e. non-axis variables) + integer, allocatable :: dimids(:) + ! netCDF dimension IDs of file + integer, allocatable :: varids(:) + ! netCDF variable IDs of file + integer :: unlim_dimid + ! netCDF dimension ID for the unlimited axis variable, if present + integer :: unlim_index + ! Index of the unlimited axis in axes(:), if present + character(len=NF90_MAX_NAME) :: label + ! Current dimension or variable label + integer :: len + ! Current dimension length + integer :: rc + ! netCDF return code + integer :: grp_ndims, grp_nvars + ! Group-based counts for nf90_inq_* (unused) + logical :: is_axis + ! True if the current variable is an axis + integer :: i, j, n + + integer, save :: no_parent_groups = 0 + ! Flag indicating exclusion of parent groups in netCDF file + ! NOTE: This must be passed as a variable, and cannot be declared as a + ! parameter. + + rc = nf90_inquire(handle%ncid, & + nDimensions=ndims, & + nVariables=nvars, & + unlimitedDimId=unlim_dimid & + ) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // handle%filename // '"') + + allocate(dimids(ndims)) + rc = nf90_inq_dimids(handle%ncid, grp_ndims, dimids, no_parent_groups) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // handle%filename // '"') + + allocate(varids(nvars)) + rc = nf90_inq_varids(handle%ncid, grp_nvars, varids) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // trim(handle%filename) // '"') + + ! Initialize unlim_index with an unreachable value (outside [1,ndims]) + unlim_index = -1 + + allocate(axes(ndims)) + do i = 1, ndims + rc = nf90_inquire_dimension(handle%ncid, dimids(i), name=label, len=len) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // trim(handle%filename) // '"') + + ! Check for the unlimited axis + if (dimids(i) == unlim_dimid) unlim_index = i + + axes(i)%dimid = dimids(i) + axes(i)%label = trim(label) + allocate(axes(i)%points(len)) + enddo + + ! We cannot know if every axis also has a variable representation, so we + ! over-allocate vars(:) and fill as fields are identified. + allocate(vars(nvars)) + + nfields = 0 + do i = 1, nvars + rc = nf90_inquire_variable(handle%ncid, varids(i), name=label) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // trim(handle%filename) // '"') + + ! Check if variable is an axis + is_axis = .false. + do j = 1, ndims + if (label == axes(j)%label) then + rc = nf90_get_var(handle%ncid, varids(i), axes(j)%points) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // trim(handle%filename) // '"') + axes(j)%varid = varids(i) + + if (j == unlim_index) then + handle%time_id = varids(i) + handle%time_level = size(axes(j)%points) + handle%time = NULLTIME + endif + + is_axis = .true. + exit + endif + enddo + if (is_axis) cycle + + nfields = nfields + 1 + vars(nfields)%label = trim(label) + vars(nfields)%varid = varids(i) + enddo + + allocate(fields(nfields)) + fields(:) = vars(:nfields) +end subroutine get_netcdf_fields + + +!> Read the values of a field from a netCDF file +subroutine read_netcdf_field(handle, field, values, bounds) + type(netcdf_file_type), intent(in) :: handle + type(netcdf_field), intent(in) :: field + real, intent(out) :: values(:,:) + integer, optional, intent(in) :: bounds(2,2) + + integer :: rc + ! netCDF return code + integer :: istart(2) + ! Axis start index + integer :: icount(2) + ! Axis index count + + if (present(bounds)) then + istart(:) = bounds(1,:) + icount(:) = bounds(2,:) - bounds(1,:) + 1 + rc = nf90_get_var(handle%ncid, field%varid, values, start=istart, count=icount) + else + rc = nf90_get_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'read_netcdf_field', & + 'File "' // trim(handle%filename) // '", Field "' // trim(field%label) // '"') +end subroutine read_netcdf_field + + +!> Set the current timestep of an open netCDF file +subroutine update_netcdf_timestep(handle, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + real, intent(in) :: time + !< New model time + + integer :: start(1) + !< Time axis start index array + integer :: rc + !< netCDF return code + + if (time > handle%time + epsilon(time)) then + handle%time = time + handle%time_level = handle%time_level + 1 + + ! Write new value to time axis + start = [handle%time_level] + rc = nf90_put_var(handle%ncid, handle%time_id, time, start=start) + call check_netcdf_call(rc, 'update_netcdf_timestep', & + 'File "' // handle%filename // '"') + endif +end subroutine update_netcdf_timestep + + +!> Check netCDF function return codes, report the error log, and abort the run. +subroutine check_netcdf_call(ncerr, header, message) + integer, intent(in) :: ncerr + !< netCDF error code + character(len=*), intent(in) :: header + !< Message header (usually calling subroutine) + character(len=*), intent(in) :: message + !< Error message (usually action which instigated the error) + + character(len=:), allocatable :: errmsg + ! Full error message, including netCDF message + + if (ncerr /= nf90_noerr) then + errmsg = trim(header) // ": " // trim(message) // new_line('/') & + // trim(nf90_strerror(ncerr)) + call MOM_error(FATAL, errmsg) + endif +end subroutine check_netcdf_call + +end module MOM_netcdf diff --git a/framework/MOM_random.F90 b/framework/MOM_random.F90 new file mode 100644 index 0000000000..f5e996d3e4 --- /dev/null +++ b/framework/MOM_random.F90 @@ -0,0 +1,600 @@ +!> Provides gridded random number capability +module MOM_random + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_hor_index, only : hor_index_type +use MOM_time_manager, only : time_type, set_date, get_date + +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit +use iso_fortran_env, only : int32 + +implicit none ; private + +public :: random_0d_constructor +public :: random_01 +public :: random_01_CB +public :: random_norm +public :: random_2d_constructor +public :: random_2d_01 +public :: random_2d_norm +public :: random_unit_tests + +! Private period parameters for the Mersenne Twister +integer, parameter :: & + blockSize = 624, & !< Size of the state vector + M = 397, & !< Pivot element in state vector + MATRIX_A = -1727483681, & !< constant vector a (0x9908b0dfUL) + UMASK = ibset(0, 31), & !< most significant w-r bits (0x80000000UL) + LMASK = 2147483647 !< least significant r bits (0x7fffffffUL) + +! Private tempering parameters for the Mersenne Twister +integer, parameter :: TMASKB= -1658038656, & !< (0x9d2c5680UL) + TMASKC= -272236544 !< (0xefc60000UL) + +!> A private type used by the Mersenne Twistor +type randomNumberSequence + integer :: currentElement !< Index into state vector + integer, dimension(0:blockSize -1) :: state !< State vector +end type randomNumberSequence + +!> Container for pseudo-random number generators +type, public :: PRNG ; private + + !> Scalar random number generator for whole model + type(randomNumberSequence) :: stream0d + + !> Random number generator for each cell on horizontal grid + type(randomNumberSequence), dimension(:,:), allocatable :: stream2d + +end type PRNG + +contains + +!> Returns a random number between 0 and 1 +real function random_01(CS) + type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators + + random_01 = getRandomReal(CS%stream0d) + +end function random_01 + +!> Returns a random number between 0 and 1 +!! See https://arxiv.org/abs/2004.06278. Not an exact reproduction of "squares" because Fortran +!! doesn't have a uint64 type, and not all compilers provide integers with > 64 bits... +real function random_01_CB(ctr, key) + use iso_fortran_env, only : int64 + integer, intent(in) :: ctr !< ctr should be incremented each time you call the function + integer, intent(in) :: key !< key is like a seed: use a different key for each random stream + integer(kind=int64) :: x, y, z ! Follows "Squares" naming convention + + x = (ctr + 1) * (key + 65536) ! 65536 added because keys below that don't work. + y = (ctr + 1) * (key + 65536) + z = y + (key + 65536) + x = x*x + y + x = ior(ishft(x,32),ishft(x,-32)) + x = x*x + z + x = ior(ishft(x,32),ishft(x,-32)) + x = x*x + y + x = ior(ishft(x,32),ishft(x,-32)) + x = x*x + z + random_01_CB = .5*(1. + .5*real(int(ishft(x,-32)))/real(2**30)) + +end function + +!> Returns an approximately normally distributed random number with mean 0 and variance 1 +real function random_norm(CS) + type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators + ! Local variables + integer :: i + + random_norm = getRandomReal(CS%stream0d) - 0.5 + do i = 1,11 + random_norm = random_norm + ( getRandomReal(CS%stream0d) - 0.5 ) + enddo + +end function random_norm + +!> Generates random numbers between 0 and 1 for each cell of the model grid +subroutine random_2d_01(CS, HI, rand) + type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 + ! Local variables + integer :: i,j + + do j = HI%jsd,HI%jed + do i = HI%isd,HI%ied + rand(i,j) = getRandomReal( CS%stream2d(i,j) ) + enddo + enddo + +end subroutine random_2d_01 + +!> Returns an approximately normally distributed random number with mean 0 and variance 1 +!! for each cell of the model grid +subroutine random_2d_norm(CS, HI, rand) + type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 + ! Local variables + integer :: i,j,n + + do j = HI%jsd,HI%jed + do i = HI%isd,HI%ied + rand(i,j) = getRandomReal( CS%stream2d(i,j) ) - 0.5 + enddo + do n = 1,11 + do i = HI%isd,HI%ied + rand(i,j) = rand(i,j) + ( getRandomReal( CS%stream2d(i,j) ) - 0.5 ) + enddo + enddo + enddo + +end subroutine random_2d_norm + +!> Constructor for scalar PRNG. Can be used to reset the sequence. +subroutine random_0d_constructor(CS, Time, seed) + type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators + type(time_type), intent(in) :: Time !< Current model time + integer, intent(in) :: seed !< Seed for PRNG + ! Local variables + integer :: tseed + + tseed = seed_from_time(Time) + tseed = ieor(tseed, seed) + CS%stream0d = new_RandomNumberSequence(tseed) + +end subroutine random_0d_constructor + +!> Constructor for gridded PRNG. Can be used to reset the sequence. +subroutine random_2d_constructor(CS, HI, Time, seed) + type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(time_type), intent(in) :: Time !< Current model time + integer, intent(in) :: seed !< Seed for PRNG + ! Local variables + integer :: i,j,sseed,tseed + + if (.not. allocated(CS%stream2d)) allocate( CS%stream2d(HI%isd:HI%ied,HI%jsd:HI%jed) ) + + tseed = seed_from_time(Time) + + tseed = ieor(tseed*9007, seed) + do j = HI%jsd,HI%jed + do i = HI%isd,HI%ied + sseed = seed_from_index(HI, i, j) + sseed = ieor(tseed, sseed*7993) + CS%stream2d(i,j) = new_RandomNumberSequence(sseed) + enddo + enddo + +end subroutine random_2d_constructor + +!> Return a seed derived as hash of values in Time +integer function seed_from_time(Time) + type(time_type), intent(in) :: Time !< Current model time + ! Local variables + integer :: yr,mo,dy,hr,mn,sc,s1,s2 + + call get_date(Time,yr,mo,dy,hr,mn,sc) + s1 = sc + 61*(mn + 61*hr) + 379 ! Range 379 .. 89620 + ! Fun fact: 2147483647 is the eighth Mersenne prime. + ! This is not the reason for using 2147483647 here. It is the + ! largest integer of kind=4. + s2 = modulo(dy + 32*(mo + 13*yr), 2147483647_4) ! Range 0 .. 2147483646 + seed_from_time = ieor(s1*4111, s2) + +end function seed_from_time + +!> Create seed from position index +integer function seed_from_index(HI, i, j) + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + integer, intent(in) :: i !< i-index (of h-cell) + integer, intent(in) :: j !< j-index (of h-cell) + ! Local variables + integer :: ig, jg, ni, nj + + ni = HI%niglobal + nj = HI%njglobal + ! Periodicity is assumed here but does not break non-periodic models + ig = mod(HI%idg_offset + i - 1 + ni, ni)+1 + jg = max(HI%jdg_offset + j, 0) + if (jg>nj) then ! Tri-polar hard-coded until we put needed info in HI **TODO** + jg = 2*nj+1-jg + ig = ni+1-ig + endif + seed_from_index = ig + ni*(jg-1) + +end function seed_from_index + +!> Destructor for PRNG +subroutine random_destruct(CS) + type(PRNG), pointer :: CS !< Container for pseudo-random number generators + + if (allocated(CS%stream2d)) deallocate(CS%stream2d) + !deallocate(CS) +end subroutine random_destruct + +!> Return an initialized twister using seed +!! +!! Code was based on initialize_scaler() from the FMS implementation of the Mersenne Twistor +function new_RandomNumberSequence(seed) result(twister) + integer, intent(in) :: seed !< Seed to initialize twister + type(randomNumberSequence) :: twister !< The Mersenne Twister container + ! Local variables + integer :: i + + twister%state(0) = iand(seed, -1) + do i = 1, blockSize - 1 ! ubound(twister%state) + twister%state(i) = 1812433253 * ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30)) + i + twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines + end do + twister%currentElement = blockSize +end function new_RandomNumberSequence + +!> Return a random integer on interval [0,0xffffffff] +!! +!! Code was based on getRandomInt() from the FMS implementation of the Mersenne Twistor +integer function getRandomInt(twister) + type(randomNumberSequence), intent(inout) :: twister !< The Mersenne Twister container + + if (twister%currentElement >= blockSize) call nextState(twister) + getRandomInt = temper(twister%state(twister%currentElement)) + twister%currentElement = twister%currentElement + 1 + +end function getRandomInt + +!> Return a random real number on interval [0,1] +!! +!! Code was based on getRandomReal() from the FMS implementation of the Mersenne Twistor +double precision function getRandomReal(twister) + type(randomNumberSequence), intent(inout) :: twister + ! Local variables + integer :: localInt + + localInt = getRandomInt(twister) + if (localInt < 0) then + getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0) + else + getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0) + end if +end function getRandomReal + +!> Merge bits of u and v +integer function mixbits(u, v) + integer, intent(in) :: u !< An integer + integer, intent(in) :: v !< An integer + + mixbits = ior(iand(u, UMASK), iand(v, LMASK)) +end function mixbits + +!> Twist bits of u and v +integer function twist(u, v) + integer, intent(in) :: u !< An integer + integer, intent(in) :: v !< An integer + ! Local variable + integer, parameter, dimension(0:1) :: t_matrix = (/ 0, MATRIX_A /) + + twist = ieor(ishft(mixbits(u, v), -1), t_matrix(iand(v, 1))) + twist = ieor(ishft(mixbits(u, v), -1), t_matrix(iand(v, 1))) +end function twist + +!> Update internal state of twister to the next state in the sequence +subroutine nextState(twister) + type(randomNumberSequence), intent(inout) :: twister !< Container for the Mersenne Twister + ! Local variables + integer :: k + + do k = 0, blockSize - M - 1 + twister%state(k) = ieor(twister%state(k + M), & + twist(twister%state(k), twister%state(k + 1))) + end do + do k = blockSize - M, blockSize - 2 + twister%state(k) = ieor(twister%state(k + M - blockSize), & + twist(twister%state(k), twister%state(k + 1))) + end do + twister%state(blockSize - 1) = ieor(twister%state(M - 1), & + twist(twister%state(blockSize - 1), twister%state(0))) + twister%currentElement = 0 +end subroutine nextState + +!> Tempering of bits in y +elemental integer function temper(y) + integer, intent(in) :: y !< An integer + ! Local variables + integer :: x + + x = ieor(y, ishft(y, -11)) + x = ieor(x, iand(ishft(x, 7), TMASKB)) + x = ieor(x, iand(ishft(x, 15), TMASKC)) + temper = ieor(x, ishft(x, -18)) +end function temper + +!> Runs some statistical tests on the PRNG +logical function random_unit_tests(verbose) + logical :: verbose !< True if results should be written to stdout + ! Local variables + type(PRNG) :: test_rng ! Generator + type(time_type) :: Time ! Model time + real :: r1, r2, r3 ! Some random numbers and re-used work variables + real :: mean, var, ar1, std ! Some statistics + integer :: stdunit ! For messages + integer, parameter :: n_samples = 800 + integer :: i, j, ni, nj + ! Fake being on a decomposed domain + type(hor_index_type), pointer :: HI => null() !< Not the real HI + real, dimension(:,:), allocatable :: r2d ! Random numbers + + ! Fake a decomposed domain + ni = 6 + nj = 9 + allocate(HI) + HI%isd = 0 + HI%ied = ni+1 + HI%jsd = 0 + HI%jed = nj+1 + HI%niglobal = ni + HI%njglobal = nj + HI%idg_offset = 0 + HI%jdg_offset = 0 + + random_unit_tests = .false. + stdunit = stdout + write(stdunit,'(1x,a)') '==== MOM_random: random_unit_tests =======================' + + if (verbose) write(stdunit,'(1x,"random: ",a)') '-- Time-based seeds ---------------------' + ! Check time-based seed generation + Time = set_date(1903, 11, 21, 13, 47, 29) + i = seed_from_time(Time) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, i==212584341, 'time seed 1903/11/21 13:47:29', ivalue=i) + Time = set_date(1903, 11, 22, 13, 47, 29) + i = seed_from_time(Time) + random_unit_tests = random_unit_tests .or.& + test_fn(verbose, i==212584342, 'time seed 1903/11/22 13:47:29', ivalue=i) + Time = set_date(1903, 11, 21, 13, 47, 30) + i = seed_from_time(Time) + random_unit_tests = random_unit_tests .or.& + test_fn(verbose, i==212596634, 'time seed 1903/11/21 13:47:30', ivalue=i) + + if (verbose) write(stdunit,'(1x,"random: ",a)') '-- PRNG tests ---------------------------' + ! Generate a random number, r1 + call random_0d_constructor(test_rng, Time, 1) + r1 = random_01(test_rng) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r1-4.75310122e-2)<1.e-9, 'first call', r1) + + ! Check that we get a different number, r2, on a second call + r2 = random_01(test_rng) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2-2.71289742e-1)<1.e-9, 'consecutive test', r2) + + ! Check that we can reproduce r1 by resetting the seed + call random_0d_constructor(test_rng, Time, 1) + r2 = random_01(test_rng) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2-r1)==0., 'reproduce test', r2) + + ! Check that we get a different number, r2, with a different seed but same date + call random_0d_constructor(test_rng, Time, 2) + r2 = random_01(test_rng) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2-7.15508473e-1)<1.e-9, 'different seed test', r2) + + ! Check that we get a different number, r2, for a different date but same seed + Time = set_date(1903, 11, 21, 13, 0, 29) + call random_0d_constructor(test_rng, Time, 1) + r2 = random_01(test_rng) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2-9.56667163e-1)<1.e-9, 'different date test', r2) + + if (verbose) write(stdunit,'(1x,"random: ",a)') '-- index-based seeds --------------------' + ! Check index-based seed + i = seed_from_index(HI,1,1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, i==1, 'seed from index (1,1)', ivalue=i) + j = seed_from_index(HI,ni+1,1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, j==i, 'seed from index (n+1,1)', ivalue=j) + i = seed_from_index(HI,ni,1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, i==6, 'seed from index (n,1)', ivalue=i) + j = seed_from_index(HI,0,1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, j==i, 'seed from index (0,1)', ivalue=j) + i = seed_from_index(HI,1,nj) + random_unit_tests = random_unit_tests .or. test_fn(verbose, i==49, 'seed from index (1,n)', ivalue=i) + j = seed_from_index(HI,ni,nj+1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, j==i, 'seed from index (n,n+1)', ivalue=j) + i = seed_from_index(HI,ni,nj) + random_unit_tests = random_unit_tests .or. test_fn(verbose, i==54, 'seed from index (n,n)', ivalue=i) + j = seed_from_index(HI,1,nj+1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, j==i, 'seed from index (1,n+1)', ivalue=j) + + if (.not.random_unit_tests) write(stdunit,'(1x,a)') 'Passed unit tests' + ! The rest of these are not unit tests but statistical tests and as such + ! could fail for different sample sizes but happen to pass here. + + ! Check statistics of large samples for uniform generator + mean = 0. ; var = 0. ; ar1 = 0. ; r2 = 0. + do i = 1, n_samples + r1 = random_01(test_rng) - 0.5 + mean = mean + r1 + var = var + r1**2 + ar1 = ar1 + r1*r2 + r2 = r1 ! Keep copy of last value + enddo + mean = mean / real(n_samples) ! Expected mean is 0 + var = var / real(n_samples) ! Expected variance is 1/12 + ar1 = ar1 / real(n_samples-1) ! Autocovariance + std = sqrt(var) ! Expected std is sqrt(1/12) + r2 = mean*sqrt(real(12*n_samples)) ! Normalized error in mean + r3 = std*sqrt(12.) ! Normalized standard deviation + r1 = ( ar1 * sqrt(real(n_samples-1)) ) / var + if (verbose) then + write(stdunit,'(1x,"random: ",a)') '-- Uniform -0.5 .. 0.5 generator --------' + write(stdunit,'(1x,"random: ",a,f12.9)') 'mean =',mean,'std =',std,'AR1 =',ar1 + write(stdunit,'(1x,"random: ",a,f12.9)') 'norm. mean =',r2, & + 'norm. std =',r3,'norm. AR1 =',r1 + endif + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2)<2., & + 'n>>1, mean within 2 sigma [uniform]', r2) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r3-1.)<1./sqrt(real(n_samples)), & + 'n>>1, std ~ 1/sqrt(12) [uniform]', r3-1.) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r1)<2., & + 'n>>1, AR1 < std/sqrt(n) [uniform]', r1) + + ! Check statistics of large samples for normal generator + mean = 0. ; var = 0. ; ar1 = 0. ; r2 = 0. + do i = 1, n_samples + r1 = random_norm(test_rng) + mean = mean + r1 + var = var + r1**2 + ar1 = ar1 + r1*r2 + r2 = r1 ! Keep copy of last value for AR calculation + enddo + mean = mean / real(n_samples) + var = var / real(n_samples) + ar1 = ar1 / real(n_samples) + std = sqrt(var) + r3 = 1./sqrt(real(n_samples)) ! Standard error of mean + r2 = mean*sqrt(real(n_samples)) ! Normalized error in mean + r3 = std ! Normalized standard deviation + r1 = ( ar1 * sqrt(real(n_samples-1)) ) / var + if (verbose) then + write(stdunit,'(1x,"random: ",a)') '-- Normal distribution generator --------' + write(stdunit,'(1x,"random: ",a,f12.9)') 'mean =',mean,'std =',std,'AR1 =',ar1 + write(stdunit,'(1x,"random: ",a,f12.9)') 'norm. error in mean =',r2, & + 'norm. standard deviation =',r3,'norm. AR1 =',r1 + endif + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2)<2., & + 'n>>1, mean within 2 sigma [norm]', r2) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r3-1.)<1./sqrt(real(n_samples)), & + 'n>>1, std ~ 1 [norm]', r3-1.) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r1)<2., & + 'n>>1, AR1 < std/sqrt(n) [norm]', r1) + + if (verbose) write(stdunit,'(1x,"random: ",a)') '-- 2d PRNG ------------------------------' + ! Check 2d random number generator 0..1 + allocate( r2d(HI%isd:HI%ied,HI%jsd:HI%jed) ) + call random_2d_constructor(test_rng, HI, Time, 123) + r2d(:,:) = -999. ! Use -9. to detect unset values + call random_2d_01(test_rng, HI, r2d) + if (any(abs(r2d(:,:)+999.)<=0.)) random_unit_tests=.true. + r1 = minval(r2d) + r2 = maxval(r2d) + random_unit_tests = random_unit_tests .or. test_fn(verbose, r1>=0., '2d all set', r1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, r2<=1., '2d all valid', r2) + mean = sum( r2d(1:ni,1:nj) - 0.5 )/real(ni*nj) + var = sum( (r2d(1:ni,1:nj) - 0.5 - mean)**2 )/real(ni*nj) + std = sqrt(var) + r3 = 1./sqrt(real(12*ni*nj)) ! Standard error of mean + r2 = mean*sqrt(real(12*ni*nj)) ! Normalized error in mean + r3 = std*sqrt(12.) ! Normalized standard deviation + if (verbose) then + write(stdunit,'(1x,"random: ",a)') '2D uniform 0..1 generator' + write(stdunit,'(1x,"random: ",a,f12.9)') 'mean =',mean,'std =',std + write(stdunit,'(1x,"random: ",a,f12.9)') 'norm. error in mean =',r2 + write(stdunit,'(1x,"random: ",a,f12.9)') 'norm. standard deviation =',r3 + endif + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2)<2., & + '2d, mean within 2 sigma [uniform]', r2) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r3-1.)<1./sqrt(real(ni*nj)), & + '2d, std ~ 1/sqrt(12) [uniform]', r3-1.) + if (verbose) then + write(stdunit,'(1x,"random:")') + write(stdunit,'(1x,"random:",8f8.5)') r2d + write(stdunit,'(1x,"random:")') + endif + + ! Check 2d normal random number generator + call random_2d_norm(test_rng, HI, r2d) + mean = sum( r2d(1:ni,1:nj) )/real(ni*nj) + var = sum( r2d(1:ni,1:nj)**2 )/real(ni*nj) + std = sqrt(var) + r3 = 1./sqrt(real(ni*nj)) ! Standard error of mean + r2 = mean*sqrt(real(ni*nj)) ! Normalized error in mean + r3 = std ! Normalized standard deviation + if (verbose) then + write(stdunit,'(1x,"random: ",a)') '2D normal generator' + write(stdunit,'(1x,"random: ",a,f12.9)') 'mean =',mean,'std =',std + write(stdunit,'(1x,"random: ",a,f12.9)') 'norm. error in mean =',r2 + write(stdunit,'(1x,"random: ",a,f12.9)') 'norm. standard deviation =',r3 + endif + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2)<2., & + '2d, mean within 2 sigma [norm]', r2) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r3-1.)<1./sqrt(real(ni*nj)), & + '2d, std ~ 1/sqrt(12) [norm]', r3-1.) + + ! Clean up + deallocate(r2d) + deallocate(HI) + + if (.not.random_unit_tests) write(stdunit,'(1x,a)') 'Passed statistical tests' + +end function random_unit_tests + +!> Convenience function for reporting result of test +logical function test_fn(verbose, good, label, rvalue, ivalue) + logical, intent(in) :: verbose !< Verbosity + logical, intent(in) :: good !< True if pass, false otherwise + character(len=*), intent(in) :: label !< Label for messages + real, intent(in) :: rvalue !< Result of calculation + integer, intent(in) :: ivalue !< Result of calculation + optional :: rvalue, ivalue + + if (present(ivalue)) then + if (.not. good) then + write(stdout,'(1x,a,i10,1x,a,a)') 'random: result =',ivalue,label,' <------- FAIL!' + write(stderr,'(1x,a,i10,1x,a,a)') 'random: result =',ivalue,label,' <------- FAIL!' + elseif (verbose) then + write(stdout,'(1x,a,i10,1x,a)') 'random: result =',ivalue,label + endif + else + if (.not. good) then + write(stdout,'(1x,a,1pe15.8,1x,a,a)') 'random: result =',rvalue,label,' <------- FAIL!' + write(stderr,'(1x,a,1pe15.8,1x,a,a)') 'random: result =',rvalue,label,' <------- FAIL!' + elseif (verbose) then + write(stdout,'(1x,a,1pe15.8,1x,a)') 'random: result =',rvalue,label + endif + endif + test_fn = .not. good + +end function test_fn + +end module MOM_random + +!> \namespace mom_random +!! +!! Provides MOM6 implementation of the Mersenne Twistor, copied from the FMS implementation +!! which was originally written by Robert Pincus (Robert.Pincus@colorado.edu). +!! We once used the FMS implementation directly but since random numers do not need to be +!! infrastructure specific, and because MOM6 should be infrastructure agnostic, we have copied +!! the parts of MT that we used here. +!! +!! Example usage: +!! \code +!! type(PRNG) :: rng +!! real :: rn +!! call random_0d_constructor(rng, Time, seed) ! Call this each time-step +!! rn = random_01(rng) +!! rn = random_norm(rng) +!! +!! type(PRNG) :: rng +!! real, dimension(:,:) :: rn2d +!! call random_2d_constructor(rng, HI, Time, seed) ! Call this each time-step +!! call random_2d_01(rng, HI, rn2d) +!! call random_2d_norm(rng, HI, rn2d) +!! +!! Note: reproducibility across restarts is implemented by using time-derived +!! seeds to pass to the Mersenne twister. It is therefore important that any +!! PRNG type be re-initialized each time-step. +!! \endcode diff --git a/framework/MOM_restart.F90 b/framework/MOM_restart.F90 new file mode 100644 index 0000000000..06f4abc065 --- /dev/null +++ b/framework/MOM_restart.F90 @@ -0,0 +1,2214 @@ +!> The MOM6 facility for reading and writing restart files, and querying what has been read. +module MOM_restart + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_checksums, only : chksum => rotated_field_chksum +use MOM_domains, only : PE_here, num_PEs, AGRID, BGRID_NE, CGRID_NE +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : create_MOM_file, file_exists +use MOM_io, only : MOM_infra_file, MOM_field +use MOM_io, only : MOM_read_data, read_data, MOM_write_field, field_exists +use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc, get_filename_appendix +use MOM_io, only : MULTIPLE, READONLY_FILE, SINGLE_FILE +use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_io, only : axis_info, get_axis_info +use MOM_string_functions, only : lowercase +use MOM_time_manager, only : time_type, time_type_to_real, real_to_time +use MOM_time_manager, only : days_in_month, get_date, set_date +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +public restart_init, restart_end, restore_state, register_restart_field +public save_restart, query_initialized, set_initialized, only_read_from_restarts +public restart_registry_lock, restart_init_end, vardesc +public restart_files_exist, determine_is_new_run, is_new_run +public register_restart_field_as_obsolete, register_restart_pair +public lock_check + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. +! The functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + +!> A type for making arrays of pointers to 4-d arrays +type p4d + real, dimension(:,:,:,:), pointer :: p => NULL() !< A pointer to a 4d array in arbitrary rescaled units [A ~> a] +end type p4d + +!> A type for making arrays of pointers to 3-d arrays +type p3d + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3d array in arbitrary rescaled units [A ~> a] +end type p3d + +!> A type for making arrays of pointers to 2-d arrays +type p2d + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2d array in arbitrary rescaled units [A ~> a] +end type p2d + +!> A type for making arrays of pointers to 1-d arrays +type p1d + real, dimension(:), pointer :: p => NULL() !< A pointer to a 1d array in arbitrary rescaled units [A ~> a] +end type p1d + +!> A type for making arrays of pointers to scalars +type p0d + real, pointer :: p => NULL() !< A pointer to a scalar in arbitrary rescaled units [A ~> a] +end type p0d + +!> A structure with information about a single restart field +type field_restart + type(vardesc) :: vars !< Description of a field that is to be read from or written + !! to the restart file. + logical :: mand_var !< If .true. the run will abort if this field is not successfully + !! read from the restart file. + logical :: initialized !< .true. if this field has been read from the restart file. + character(len=32) :: var_name !< A name by which a variable may be queried. + real :: conv = 1.0 !< A factor by which a restart field should be multiplied before it + !! is written to a restart file, usually to convert it to MKS or + !! other standard units [a A-1 ~> 1]. When read, the restart field + !! is multiplied by the Adcroft reciprocal of this factor. +end type field_restart + +!> A structure to store information about restart fields that are no longer used +type obsolete_restart + character(len=32) :: field_name !< Name of restart field that is no longer in use + character(len=32) :: replacement_name !< Name of replacement restart field, if applicable +end type obsolete_restart + +!> A restart registry and the control structure for restarts +type, public :: MOM_restart_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: restart !< restart is set to .true. if the run has been started from a full restart + !! file. Otherwise some fields must be initialized approximately. + integer :: novars = 0 !< The number of restart fields that have been registered. + integer :: num_obsolete_vars = 0 !< The number of obsolete restart fields that have been registered. + logical :: parallel_restartfiles !< If true, the IO layout is used to group processors that write + !! to the same restart file or each processor writes its own + !! (numbered) restart file. If false, a single restart file is + !! generated after internally combining output from all PEs. + logical :: new_run !< If true, the input filenames and restart file existence will + !! result in a new run that is not initialized from restart files. + logical :: new_run_set = .false. !< If true, new_run has been determined for this restart_CS. + logical :: checksum_required !< If true, require the restart checksums to match and error out otherwise. + !! Users may want to avoid this comparison if for example the restarts are + !! made from a run with a different mask_table than the current run, + !! in which case the checksums will not match and cause crash. + character(len=240) :: restartfile !< The name or name root for MOM restart files. + integer :: turns !< Number of quarter turns from input to model domain + logical :: locked = .false. !< If true this registry has been locked and no further restart + !! fields can be added without explicitly unlocking the registry. + + !> An array of descriptions of the registered fields + type(field_restart), pointer :: restart_field(:) => NULL() + + !> An array of obsolete restart fields + type(obsolete_restart), pointer :: restart_obsolete(:) => NULL() + + !>@{ Pointers to the fields that have been registered for restarts + type(p0d), pointer :: var_ptr0d(:) => NULL() + type(p1d), pointer :: var_ptr1d(:) => NULL() + type(p2d), pointer :: var_ptr2d(:) => NULL() + type(p3d), pointer :: var_ptr3d(:) => NULL() + type(p4d), pointer :: var_ptr4d(:) => NULL() + !>@} + integer :: max_fields !< The maximum number of restart fields +end type MOM_restart_CS + +!> Register fields for restarts +interface register_restart_field + module procedure register_restart_field_ptr4d, register_restart_field_4d + module procedure register_restart_field_ptr3d, register_restart_field_3d + module procedure register_restart_field_ptr2d, register_restart_field_2d + module procedure register_restart_field_ptr1d, register_restart_field_1d + module procedure register_restart_field_ptr0d, register_restart_field_0d +end interface + +!> Register a pair of restart fields whose rotations map onto each other +interface register_restart_pair + module procedure register_restart_pair_ptr2d + module procedure register_restart_pair_ptr3d + module procedure register_restart_pair_ptr4d +end interface register_restart_pair + +!> Indicate whether a field has been read from a restart file +interface query_initialized + module procedure query_initialized_name + module procedure query_initialized_0d, query_initialized_0d_name + module procedure query_initialized_1d, query_initialized_1d_name + module procedure query_initialized_2d, query_initialized_2d_name + module procedure query_initialized_3d, query_initialized_3d_name + module procedure query_initialized_4d, query_initialized_4d_name +end interface + +!> Specify that a field has been initialized, even if it was not read from a restart file +interface set_initialized + module procedure set_initialized_name, set_initialized_0d_name + module procedure set_initialized_1d_name, set_initialized_2d_name + module procedure set_initialized_3d_name, set_initialized_4d_name +end interface + +!> Read optional variables from restart files. +interface only_read_from_restarts + module procedure only_read_restart_field_4d + module procedure only_read_restart_field_3d + module procedure only_read_restart_field_2d +! module procedure only_read_restart_field_1d +! module procedure only_read_restart_field_0d + module procedure only_read_restart_pair_3d +end interface + +contains + +!> Register a restart field as obsolete +subroutine register_restart_field_as_obsolete(field_name, replacement_name, CS) + character(*), intent(in) :: field_name !< Name of restart field that is no longer in use + character(*), intent(in) :: replacement_name !< Name of replacement restart field, if applicable + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + CS%num_obsolete_vars = CS%num_obsolete_vars+1 + CS%restart_obsolete(CS%num_obsolete_vars)%field_name = field_name + CS%restart_obsolete(CS%num_obsolete_vars)%replacement_name = replacement_name +end subroutine register_restart_field_as_obsolete + +!> Register a 3-d field for restarts, providing the metadata in a structure +subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS, conversion) + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] + type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "register_restart_field: Module must be initialized before it is used.") + + call lock_check(CS, var_desc) + + CS%novars = CS%novars+1 + if (CS%novars > CS%max_fields) return ! This is an error that will be reported + ! once the total number of fields is known. + + CS%restart_field(CS%novars)%vars = var_desc + CS%restart_field(CS%novars)%mand_var = mandatory + CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion + call query_vardesc(CS%restart_field(CS%novars)%vars, & + name=CS%restart_field(CS%novars)%var_name, & + caller="register_restart_field_ptr3d") + + CS%var_ptr3d(CS%novars)%p => f_ptr + CS%var_ptr4d(CS%novars)%p => NULL() + CS%var_ptr2d(CS%novars)%p => NULL() + CS%var_ptr1d(CS%novars)%p => NULL() + CS%var_ptr0d(CS%novars)%p => NULL() + +end subroutine register_restart_field_ptr3d + +!> Register a 4-d field for restarts, providing the metadata in a structure +subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS, conversion) + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] + type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "register_restart_field: Module must be initialized before it is used.") + + call lock_check(CS, var_desc) + + CS%novars = CS%novars+1 + if (CS%novars > CS%max_fields) return ! This is an error that will be reported + ! once the total number of fields is known. + + CS%restart_field(CS%novars)%vars = var_desc + CS%restart_field(CS%novars)%mand_var = mandatory + CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion + call query_vardesc(CS%restart_field(CS%novars)%vars, & + name=CS%restart_field(CS%novars)%var_name, & + caller="register_restart_field_ptr4d") + + CS%var_ptr4d(CS%novars)%p => f_ptr + CS%var_ptr3d(CS%novars)%p => NULL() + CS%var_ptr2d(CS%novars)%p => NULL() + CS%var_ptr1d(CS%novars)%p => NULL() + CS%var_ptr0d(CS%novars)%p => NULL() + +end subroutine register_restart_field_ptr4d + +!> Register a 2-d field for restarts, providing the metadata in a structure +subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS, conversion) + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] + type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "register_restart_field: Module must be initialized before it is used.") + + call lock_check(CS, var_desc) + + CS%novars = CS%novars+1 + if (CS%novars > CS%max_fields) return ! This is an error that will be reported + ! once the total number of fields is known. + + CS%restart_field(CS%novars)%vars = var_desc + CS%restart_field(CS%novars)%mand_var = mandatory + CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion + call query_vardesc(CS%restart_field(CS%novars)%vars, & + name=CS%restart_field(CS%novars)%var_name, & + caller="register_restart_field_ptr2d") + + CS%var_ptr2d(CS%novars)%p => f_ptr + CS%var_ptr4d(CS%novars)%p => NULL() + CS%var_ptr3d(CS%novars)%p => NULL() + CS%var_ptr1d(CS%novars)%p => NULL() + CS%var_ptr0d(CS%novars)%p => NULL() + +end subroutine register_restart_field_ptr2d + +!> Register a 1-d field for restarts, providing the metadata in a structure +subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS, conversion) + real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] + type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "register_restart_field: Module must be initialized before it is used.") + + call lock_check(CS, var_desc) + + CS%novars = CS%novars+1 + if (CS%novars > CS%max_fields) return ! This is an error that will be reported + ! once the total number of fields is known. + + CS%restart_field(CS%novars)%vars = var_desc + CS%restart_field(CS%novars)%mand_var = mandatory + CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion + call query_vardesc(CS%restart_field(CS%novars)%vars, & + name=CS%restart_field(CS%novars)%var_name, & + caller="register_restart_field_ptr1d") + + CS%var_ptr1d(CS%novars)%p => f_ptr + CS%var_ptr4d(CS%novars)%p => NULL() + CS%var_ptr3d(CS%novars)%p => NULL() + CS%var_ptr2d(CS%novars)%p => NULL() + CS%var_ptr0d(CS%novars)%p => NULL() + +end subroutine register_restart_field_ptr1d + +!> Register a 0-d field for restarts, providing the metadata in a structure +subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS, conversion) + real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] + type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "register_restart_field: Module must be initialized before it is used.") + + call lock_check(CS, var_desc) + + CS%novars = CS%novars+1 + if (CS%novars > CS%max_fields) return ! This is an error that will be reported + ! once the total number of fields is known. + + CS%restart_field(CS%novars)%vars = var_desc + CS%restart_field(CS%novars)%mand_var = mandatory + CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion + call query_vardesc(CS%restart_field(CS%novars)%vars, & + name=CS%restart_field(CS%novars)%var_name, & + caller="register_restart_field_ptr0d") + + CS%var_ptr0d(CS%novars)%p => f_ptr + CS%var_ptr4d(CS%novars)%p => NULL() + CS%var_ptr3d(CS%novars)%p => NULL() + CS%var_ptr2d(CS%novars)%p => NULL() + CS%var_ptr1d(CS%novars)%p => NULL() + +end subroutine register_restart_field_ptr0d + + +!> Register a pair of rotationally equivalent 2d restart fields +subroutine register_restart_pair_ptr2d(a_ptr, b_ptr, a_desc, b_desc, & + mandatory, CS, conversion) + real, dimension(:,:), target, intent(in) :: a_ptr !< First field pointer + !! in arbitrary rescaled units [A ~> a] + real, dimension(:,:), target, intent(in) :: b_ptr !< Second field pointer + !! in arbitrary rescaled units [A ~> a] + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + + call lock_check(CS, a_desc) + + if (modulo(CS%turns, 2) /= 0) then + call register_restart_field(b_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion) + else + call register_restart_field(a_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion) + endif +end subroutine register_restart_pair_ptr2d + + +!> Register a pair of rotationally equivalent 3d restart fields +subroutine register_restart_pair_ptr3d(a_ptr, b_ptr, a_desc, b_desc, & + mandatory, CS, conversion) + real, dimension(:,:,:), target, intent(in) :: a_ptr !< First field pointer + !! in arbitrary rescaled units [A ~> a] + real, dimension(:,:,:), target, intent(in) :: b_ptr !< Second field pointer + !! in arbitrary rescaled units [A ~> a] + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + + call lock_check(CS, a_desc) + + if (modulo(CS%turns, 2) /= 0) then + call register_restart_field(b_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion) + else + call register_restart_field(a_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion) + endif +end subroutine register_restart_pair_ptr3d + + +!> Register a pair of rotationally equivalent 2d restart fields +subroutine register_restart_pair_ptr4d(a_ptr, b_ptr, a_desc, b_desc, & + mandatory, CS, conversion) + real, dimension(:,:,:,:), target, intent(in) :: a_ptr !< First field pointer + !! in arbitrary rescaled units [A ~> a] + real, dimension(:,:,:,:), target, intent(in) :: b_ptr !< Second field pointer + !! in arbitrary rescaled units [A ~> a] + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + + call lock_check(CS, a_desc) + + if (modulo(CS%turns, 2) /= 0) then + call register_restart_field(b_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion) + else + call register_restart_field(a_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion) + endif +end subroutine register_restart_pair_ptr4d + + +! The following provide alternate interfaces to register restarts. + +!> Register a 4-d field for restarts, providing the metadata as individual arguments +subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units, conversion, & + hor_grid, z_grid, t_grid, extra_axes) + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] + character(len=*), intent(in) :: name !< variable name to be used in the restart file + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent + character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time + + type(vardesc) :: vd + character(len=32), dimension(:), allocatable :: dim_names + integer :: n, n_extradims + + ! first 2 dimensions in dim_names are reserved for i,j + ! so extra_dimensions are shifted to index 3. + ! this is designed not to break the behavior in SIS2 + ! (see register_restart_field_4d in SIS_restart.F90) + if (present(extra_axes)) then + n_extradims = size(extra_axes) + allocate(dim_names(n_extradims+2)) + dim_names(1) = "" + dim_names(2) = "" + do n=3,n_extradims+2 + dim_names(n) = extra_axes(n-2)%name + enddo + endif + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart: " // & + "register_restart_field_4d: Module must be initialized before "//& + "it is used to register "//trim(name)) + + call lock_check(CS, name=name) + + if (present(extra_axes)) then + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, dim_names=dim_names, extra_axes=extra_axes) + else + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid) + endif + + call register_restart_field_ptr4d(f_ptr, vd, mandatory, CS, conversion) + +end subroutine register_restart_field_4d + +!> Register a 3-d field for restarts, providing the metadata as individual arguments +subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units, conversion, & + hor_grid, z_grid, t_grid, extra_axes) + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] + character(len=*), intent(in) :: name !< variable name to be used in the restart file + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent + character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time + + type(vardesc) :: vd + character(len=32), dimension(:), allocatable :: dim_names + integer :: n, n_extradims + + ! first 2 dimensions in dim_names are reserved for i,j + ! so extra_dimensions are shifted to index 3. + ! this is designed not to break the behavior in SIS2 + ! (see register_restart_field_4d in SIS_restart.F90) + if (present(extra_axes)) then + n_extradims = size(extra_axes) + allocate(dim_names(n_extradims+2)) + dim_names(1) = "" + dim_names(2) = "" + do n=3,n_extradims+2 + dim_names(n) = extra_axes(n-2)%name + enddo + endif + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart: " // & + "register_restart_field_3d: Module must be initialized before "//& + "it is used to register "//trim(name)) + + call lock_check(CS, name=name) + + if (present(extra_axes)) then + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, dim_names=dim_names, extra_axes=extra_axes) + else + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid) + endif + + call register_restart_field_ptr3d(f_ptr, vd, mandatory, CS, conversion) + +end subroutine register_restart_field_3d + +!> Register a 2-d field for restarts, providing the metadata as individual arguments +subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units, conversion, & + hor_grid, z_grid, t_grid) + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] + character(len=*), intent(in) :: name !< variable name to be used in the restart file + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent + character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, '1' if absent + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + + type(vardesc) :: vd + character(len=8) :: Zgrid + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart: " // & + "register_restart_field_2d: Module must be initialized before "//& + "it is used to register "//trim(name)) + + zgrid = '1' ; if (present(z_grid)) zgrid = z_grid + + call lock_check(CS, name=name) + + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=zgrid, t_grid=t_grid) + + call register_restart_field_ptr2d(f_ptr, vd, mandatory, CS, conversion) + +end subroutine register_restart_field_2d + +!> Register a 1-d field for restarts, providing the metadata as individual arguments +subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units, conversion, & + hor_grid, z_grid, t_grid) + real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] + character(len=*), intent(in) :: name !< variable name to be used in the restart file + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, '1' if absent + character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + + type(vardesc) :: vd + character(len=8) :: hgrid + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart: " // & + "register_restart_field_3d: Module must be initialized before "//& + "it is used to register "//trim(name)) + + hgrid = '1' ; if (present(hor_grid)) hgrid = hor_grid + + call lock_check(CS, name=name) + + vd = var_desc(name, units=units, longname=longname, hor_grid=hgrid, & + z_grid=z_grid, t_grid=t_grid) + + call register_restart_field_ptr1d(f_ptr, vd, mandatory, CS, conversion) + +end subroutine register_restart_field_1d + +!> Register a 0-d field for restarts, providing the metadata as individual arguments +subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units, conversion, & + t_grid) + real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] + character(len=*), intent(in) :: name !< variable name to be used in the restart file + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + + type(vardesc) :: vd + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart: " // & + "register_restart_field_0d: Module must be initialized before "//& + "it is used to register "//trim(name)) + + call lock_check(CS, name=name) + + vd = var_desc(name, units=units, longname=longname, hor_grid='1', & + z_grid='1', t_grid=t_grid) + + call register_restart_field_ptr0d(f_ptr, vd, mandatory, CS, conversion) + +end subroutine register_restart_field_0d + + +!> query_initialized_name determines whether a named field has been successfully +!! read from a restart file or has otherwise been recorded as being initialized. +function query_initialized_name(name, CS) result(query_initialized) + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical :: query_initialized + + integer :: m, n + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + query_initialized = .false. + n = CS%novars+1 + do m=1,CS%novars + if (trim(name) == CS%restart_field(m)%var_name) then + if (CS%restart_field(m)%initialized) query_initialized = .true. + n = m ; exit + endif + enddo + if ((n==CS%novars+1) .and. (is_root_pe())) & + call MOM_error(NOTE,"MOM_restart: Unknown restart variable "//name// & + " queried for initialization.") + + if ((is_root_pe()) .and. query_initialized) & + call MOM_error(NOTE,"MOM_restart: "//name// & + " initialization confirmed by name.") + +end function query_initialized_name + +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. +function query_initialized_0d(f_ptr, CS) result(query_initialized) + real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical :: query_initialized + + integer :: m, n + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + query_initialized = .false. + n = CS%novars+1 + do m=1,CS%novars + if (associated(CS%var_ptr0d(m)%p,f_ptr)) then + if (CS%restart_field(m)%initialized) query_initialized = .true. + n = m ; exit + endif + enddo + +end function query_initialized_0d + +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. +function query_initialized_1d(f_ptr, CS) result(query_initialized) + real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical :: query_initialized + + integer :: m, n + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + query_initialized = .false. + n = CS%novars+1 + do m=1,CS%novars + if (associated(CS%var_ptr1d(m)%p,f_ptr)) then + if (CS%restart_field(m)%initialized) query_initialized = .true. + n = m ; exit + endif + enddo + +end function query_initialized_1d + +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. +function query_initialized_2d(f_ptr, CS) result(query_initialized) + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical :: query_initialized + + integer :: m, n + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + query_initialized = .false. + n = CS%novars+1 + do m=1,CS%novars + if (associated(CS%var_ptr2d(m)%p,f_ptr)) then + if (CS%restart_field(m)%initialized) query_initialized = .true. + n = m ; exit + endif + enddo + +end function query_initialized_2d + +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. +function query_initialized_3d(f_ptr, CS) result(query_initialized) + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical :: query_initialized + + integer :: m, n + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + query_initialized = .false. + n = CS%novars+1 + do m=1,CS%novars + if (associated(CS%var_ptr3d(m)%p,f_ptr)) then + if (CS%restart_field(m)%initialized) query_initialized = .true. + n = m ; exit + endif + enddo + +end function query_initialized_3d + +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. +function query_initialized_4d(f_ptr, CS) result(query_initialized) + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical :: query_initialized + + integer :: m, n + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + query_initialized = .false. + n = CS%novars+1 + do m=1,CS%novars + if (associated(CS%var_ptr4d(m)%p,f_ptr)) then + if (CS%restart_field(m)%initialized) query_initialized = .true. + n = m ; exit + endif + enddo + +end function query_initialized_4d + +!> Indicate whether the field stored in f_ptr or with the specified variable +!! name has been initialized from a restart file. +function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) + real, target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical :: query_initialized + + integer :: m, n + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + query_initialized = .false. + n = CS%novars+1 + do m=1,CS%novars + if (associated(CS%var_ptr0d(m)%p,f_ptr)) then + if (CS%restart_field(m)%initialized) query_initialized = .true. + n = m ; exit + endif + enddo + if (n==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + query_initialized = query_initialized_name(name, CS) + endif + +end function query_initialized_0d_name + +!> Indicate whether the field stored in f_ptr or with the specified variable +!! name has been initialized from a restart file. +function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) + real, dimension(:), & + target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical :: query_initialized + + integer :: m, n + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + query_initialized = .false. + n = CS%novars+1 + do m=1,CS%novars + if (associated(CS%var_ptr1d(m)%p,f_ptr)) then + if (CS%restart_field(m)%initialized) query_initialized = .true. + n = m ; exit + endif + enddo + if (n==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + query_initialized = query_initialized_name(name, CS) + endif + +end function query_initialized_1d_name + +!> Indicate whether the field stored in f_ptr or with the specified variable +!! name has been initialized from a restart file. +function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) + real, dimension(:,:), & + target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical :: query_initialized + + integer :: m, n + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + query_initialized = .false. + n = CS%novars+1 + do m=1,CS%novars + if (associated(CS%var_ptr2d(m)%p,f_ptr)) then + if (CS%restart_field(m)%initialized) query_initialized = .true. + n = m ; exit + endif + enddo + if (n==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + query_initialized = query_initialized_name(name, CS) + endif + +end function query_initialized_2d_name + +!> Indicate whether the field stored in f_ptr or with the specified variable +!! name has been initialized from a restart file. +function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical :: query_initialized + + integer :: m, n + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + query_initialized = .false. + n = CS%novars+1 + do m=1,CS%novars + if (associated(CS%var_ptr3d(m)%p,f_ptr)) then + if (CS%restart_field(m)%initialized) query_initialized = .true. + n = m ; exit + endif + enddo + if (n==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE, "MOM_restart: Unable to find "//name//" queried by pointer, "//& + "possibly because of the suspect comparison of pointers by ASSOCIATED.") + query_initialized = query_initialized_name(name, CS) + endif + +end function query_initialized_3d_name + +!> Indicate whether the field stored in f_ptr or with the specified variable +!! name has been initialized from a restart file. +function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical :: query_initialized + + integer :: m, n + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + query_initialized = .false. + n = CS%novars+1 + do m=1,CS%novars + if (associated(CS%var_ptr4d(m)%p,f_ptr)) then + if (CS%restart_field(m)%initialized) query_initialized = .true. + n = m ; exit + endif + enddo + if (n==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE, "MOM_restart: Unable to find "//name//" queried by pointer, "//& + "possibly because of the suspect comparison of pointers by ASSOCIATED.") + query_initialized = query_initialized_name(name, CS) + endif + +end function query_initialized_4d_name + +!> set_initialized_name records that a named field has been initialized. +subroutine set_initialized_name(name, CS) + character(len=*), intent(in) :: name !< The name of the field that is being set + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + integer :: m + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "set_initialized: Module must be initialized before it is used.") + + do m=1,CS%novars ; if (trim(name) == trim(CS%restart_field(m)%var_name)) then + CS%restart_field(m)%initialized = .true. ; exit + endif ; enddo + + if ((m==CS%novars+1) .and. (is_root_pe())) & + call MOM_error(NOTE,"MOM_restart: Unknown restart variable "//name// & + " used in set_initialized call.") + +end subroutine set_initialized_name + +!> Record that the array in f_ptr with the given name has been initialized. +subroutine set_initialized_0d_name(f_ptr, name, CS) + real, target, intent(in) :: f_ptr !< The variable that has been initialized [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that has been initialized + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + integer :: m + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "set_initialized: Module must be initialized before it is used.") + + do m=1,CS%novars ; if (associated(CS%var_ptr0d(m)%p,f_ptr)) then + CS%restart_field(m)%initialized = .true. ; exit + endif ; enddo + + if (m==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + call set_initialized_name(name, CS) + endif + +end subroutine set_initialized_0d_name + +!> Record that the array in f_ptr with the given name has been initialized. +subroutine set_initialized_1d_name(f_ptr, name, CS) + real, dimension(:), & + target, intent(in) :: f_ptr !< The array that has been initialized [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that has been initialized + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + integer :: m + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "set_initialized: Module must be initialized before it is used.") + + do m=1,CS%novars ; if (associated(CS%var_ptr1d(m)%p,f_ptr)) then + CS%restart_field(m)%initialized = .true. ; exit + endif ; enddo + + if (m==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + call set_initialized_name(name, CS) + endif + +end subroutine set_initialized_1d_name + +!> Record that the array in f_ptr with the given name has been initialized. +subroutine set_initialized_2d_name(f_ptr, name, CS) + real, dimension(:,:), & + target, intent(in) :: f_ptr !< The array that has been initialized [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that has been initialized + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + integer :: m + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "set_initialized: Module must be initialized before it is used.") + + do m=1,CS%novars ; if (associated(CS%var_ptr2d(m)%p,f_ptr)) then + CS%restart_field(m)%initialized = .true. ; exit + endif ; enddo + + if (m==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + call set_initialized_name(name, CS) + endif + +end subroutine set_initialized_2d_name + +!> Record that the array in f_ptr with the given name has been initialized. +subroutine set_initialized_3d_name(f_ptr, name, CS) + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< The array that has been initialized [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that has been initialized + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + integer :: m + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "set_initialized: Module must be initialized before it is used.") + + do m=1,CS%novars ; if (associated(CS%var_ptr3d(m)%p,f_ptr)) then + CS%restart_field(m)%initialized = .true. ; exit + endif ; enddo + + if (m==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + call set_initialized_name(name, CS) + endif + +end subroutine set_initialized_3d_name + +!> Record that the array in f_ptr with the given name has been initialized. +subroutine set_initialized_4d_name(f_ptr, name, CS) + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< The array that has been initialized [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that has been initialized + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + integer :: m + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "set_initialized: Module must be initialized before it is used.") + + do m=1,CS%novars ; if (associated(CS%var_ptr4d(m)%p,f_ptr)) then + CS%restart_field(m)%initialized = .true. ; exit + endif ; enddo + + if (m==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + call set_initialized_name(name, CS) + endif + +end subroutine set_initialized_4d_name + + +!====================== only_read_from_restarts variants ======================= + +!> Try to read a named 4-d field from the restart files +subroutine only_read_restart_field_4d(varname, f_ptr, G, CS, position, filename, directory, success, scale) + character(len=*), intent(in) :: varname !< The variable name to be used in the restart file + real, dimension(:,:,:,:), intent(inout) :: f_ptr !< The array for the field to be read + !! in arbitrary rescaled units [A ~> a] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + integer, optional, intent(in) :: position !< A coded integer indicating the horizontal + !! position of this variable + character(len=*), optional, intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. + logical, optional, intent(out) :: success !< True if the field was read successfully + real, optional, intent(in) :: scale !< A factor by which the field will be scaled + !! [A a-1 ~> 1] to convert from the units in + !! the file to the internal units of this field + + ! Local variables + character(len=:), allocatable :: file_path ! The full path to the file with the variable + logical :: found ! True if the variable was found. + logical :: is_global ! True if the variable is in a global file. + + found = find_var_in_restart_files(varname, G, CS, file_path, filename, directory, is_global) + + if (found) then + call MOM_read_data(file_path, varname, f_ptr, G%domain, timelevel=1, position=position, & + scale=scale, global_file=is_global) + endif + if (present(success)) success = found + +end subroutine only_read_restart_field_4d + +!> Try to read a named 3-d field from the restart files +subroutine only_read_restart_field_3d(varname, f_ptr, G, CS, position, filename, directory, success, scale) + character(len=*), intent(in) :: varname !< The variable name to be used in the restart file + real, dimension(:,:,:), intent(inout) :: f_ptr !< The array for the field to be read + !! in arbitrary rescaled units [A ~> a] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + integer, optional, intent(in) :: position !< A coded integer indicating the horizontal + !! position of this variable + character(len=*), optional, intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. + logical, optional, intent(out) :: success !< True if the field was read successfully + real, optional, intent(in) :: scale !< A factor by which the field will be scaled + !! [A a-1 ~> 1] to convert from the units in + !! the file to the internal units of this field + + ! Local variables + character(len=:), allocatable :: file_path ! The full path to the file with the variable + logical :: found ! True if the variable was found. + logical :: is_global ! True if the variable is in a global file. + + found = find_var_in_restart_files(varname, G, CS, file_path, filename, directory, is_global) + + if (found) then + call MOM_read_data(file_path, varname, f_ptr, G%domain, timelevel=1, position=position, & + scale=scale, global_file=is_global) + endif + if (present(success)) success = found + +end subroutine only_read_restart_field_3d + +!> Try to read a named 2-d field from the restart files +subroutine only_read_restart_field_2d(varname, f_ptr, G, CS, position, filename, directory, success, scale) + character(len=*), intent(in) :: varname !< The variable name to be used in the restart file + real, dimension(:,:), intent(inout) :: f_ptr !< The array for the field to be read + !! in arbitrary rescaled units [A ~> a] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + integer, optional, intent(in) :: position !< A coded integer indicating the horizontal + !! position of this variable + character(len=*), optional, intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. + logical, optional, intent(out) :: success !< True if the field was read successfully + real, optional, intent(in) :: scale !< A factor by which the field will be scaled + !! [A a-1 ~> 1] to convert from the units in + !! the file to the internal units of this field + + ! Local variables + character(len=:), allocatable :: file_path ! The full path to the file with the variable + logical :: found ! True if the variable was found. + logical :: is_global ! True if the variable is in a global file. + + found = find_var_in_restart_files(varname, G, CS, file_path, filename, directory, is_global) + + if (found) then + call MOM_read_data(file_path, varname, f_ptr, G%domain, timelevel=1, position=position, & + scale=scale, global_file=is_global) + endif + if (present(success)) success = found + +end subroutine only_read_restart_field_2d + + +!> Try to read a named 3-d field from the restart files +subroutine only_read_restart_pair_3d(a_ptr, b_ptr, a_name, b_name, G, CS, & + stagger, filename, directory, success, scale) + real, dimension(:,:,:), intent(inout) :: a_ptr !< The array for the first field to be read + !! in arbitrary rescaled units [A ~> a] + real, dimension(:,:,:), intent(inout) :: b_ptr !< The array for the second field to be read + !! in arbitrary rescaled units [A ~> a] + character(len=*), intent(in) :: a_name !< The first variable name to be used in the restart file + character(len=*), intent(in) :: b_name !< The second variable name to be used in the restart file + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + integer, optional, intent(in) :: stagger !< A coded integer indicating the horizontal + !! position of this pair of variables + character(len=*), optional, intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. + logical, optional, intent(out) :: success !< True if the field was read successfully + real, optional, intent(in) :: scale !< A factor by which the fields will be scaled + !! [A a-1 ~> 1] to convert from the units in + !! the file to the internal units of this field + + ! Local variables + character(len=:), allocatable :: file_path_a ! The full path to the file with the first variable + character(len=:), allocatable :: file_path_b ! The full path to the file with the second variable + integer :: a_pos, b_pos ! A coded position for the two variables. + logical :: a_found, b_found ! True if the variables were found. + logical :: global_a, global_b ! True if the variables are in global files. + + a_found = find_var_in_restart_files(a_name, G, CS, file_path_a, filename, directory, global_a) + b_found = find_var_in_restart_files(b_name, G, CS, file_path_b, filename, directory, global_b) + + a_pos = EAST_FACE ; b_pos = NORTH_FACE + if (present(stagger)) then ; select case (stagger) + case (AGRID) ; a_pos = CENTER ; b_pos = CENTER + case (BGRID_NE) ; a_pos = CORNER ; b_pos = CORNER + case (CGRID_NE) ; a_pos = EAST_FACE ; b_pos = NORTH_FACE + case default ; a_pos = EAST_FACE ; b_pos = NORTH_FACE + end select ; endif + + if (a_found .and. b_found) then + call MOM_read_data(file_path_a, a_name, a_ptr, G%domain, timelevel=1, position=a_pos, & + scale=scale, global_file=global_b, file_may_be_4d=.true.) + call MOM_read_data(file_path_b, b_name, b_ptr, G%domain, timelevel=1, position=b_pos, & + scale=scale, global_file=global_b, file_may_be_4d=.true.) + endif + if (present(success)) success = (a_found .and. b_found) + +end subroutine only_read_restart_pair_3d + +!> Return an indication of whether the named variable is in the restart files, and provide the full path +!! to the restart file in which a variable is found. +function find_var_in_restart_files(varname, G, CS, file_path, filename, directory, is_global) result (found) + character(len=*), intent(in) :: varname !< The variable name to be used in the restart file + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + character(len=:), allocatable, intent(out) :: file_path !< The full path to the file in which the + !! variable is found + character(len=*), optional, intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. + logical, optional, intent(out) :: is_global !< True if the file is global. + logical :: found !< True if the named variable was found in the restart files. + + ! Local variables + character(len=240), allocatable, dimension(:) :: file_paths ! The possible file names. + character(len=:), allocatable :: dir ! The directory to read from. + character(len=:), allocatable :: fname ! The list of file names. + logical, allocatable, dimension(:) :: global_file ! True if the file is global + integer :: n, num_files + + dir = "./INPUT/" ; if (present(directory)) dir = trim(directory) + + ! Set the default return values. + found = .false. + file_path = "" + if (present(is_global)) is_global = .false. + + fname = 'r' + if (present(filename)) then + if (.not.((LEN_TRIM(filename) == 1) .and. (filename(1:1) == 'F'))) fname = filename + endif + + num_files = get_num_restart_files(fname, dir, G, CS) + if (num_files == 0) return + allocate(file_paths(num_files), global_file(num_files)) + num_files = open_restart_units(fname, dir, G, CS, file_paths=file_paths, global_files=global_file) + + do n=1,num_files ; if (field_exists(file_paths(n), varname, MOM_Domain=G%domain)) then + found = .true. + file_path = file_paths(n) + if (present(is_global)) is_global = global_file(n) + exit + endif ; enddo + + deallocate(file_paths, global_file) + +end function find_var_in_restart_files + +!====================== end of the only_read_from_restarts variants ======================= + + +!> save_restart saves all registered variables to restart files. +subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_rest_files, write_IC) + character(len=*), intent(in) :: directory !< The directory where the restart files + !! are to be written + type(time_type), intent(in) :: time !< The current model time + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp + !! to the restart file names + character(len=*), optional, intent(in) :: filename !< A filename that overrides the name in CS%restartfile + type(verticalGrid_type), & + optional, intent(in) :: GV !< The ocean's vertical grid structure + integer, optional, intent(out) :: num_rest_files !< number of restart files written + logical, optional, intent(in) :: write_IC !< If present and true, initial conditions + !! are being written + + ! Local variables + type(vardesc) :: vars(CS%max_fields) ! Descriptions of the fields that + ! are to be read from the restart file. + type(MOM_field) :: fields(CS%max_fields) ! Opaque types containing metadata describing + ! each variable that will be written. + character(len=512) :: restartpath ! The restart file path (dir/file). + character(len=256) :: restartname ! The restart file name (no dir). + character(len=8) :: suffix ! A suffix (like _2) that is appended + ! to the name of files after the first. + integer(kind=8) :: var_sz, size_in_file ! The size in bytes of each variable + ! and the variables already in a file. + integer(kind=8), parameter :: max_file_size = 4294967292_8 ! The maximum size in bytes for the + ! starting position of each variable in a file's record, + ! based on the use of NetCDF 3.6 or later. For earlier + ! versions of NetCDF, the value was 2147483647_8. + integer :: start_var, next_var ! The starting variables of the + ! current and next files. + type(MOM_infra_file) :: IO_handle ! The I/O handle of the open fileset + integer :: m, nz, na + integer :: num_files ! The number of restart files that will be used. + integer :: seconds, days, year, month, hour, minute + character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. + real :: conv ! Shorthand for the conversion factor [a A-1 ~> 1] + real :: restart_time ! The model time at whic the restart file is being written [days] + character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs + integer :: length ! The length of a text string. + integer(kind=8) :: check_val(CS%max_fields,1) + integer :: isL, ieL, jsL, jeL, pos + integer :: turns + integer, parameter :: nmax_extradims = 5 + type(axis_info), dimension(:), allocatable :: extra_axes + + turns = CS%turns + + allocate (extra_axes(nmax_extradims)) + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "save_restart: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + ! With parallel read & write, it is possible to disable the following... + num_files = 0 + next_var = 0 + nz = 1 ; if (present(GV)) nz = GV%ke + + restart_time = time_type_to_real(time) / 86400.0 + + restartname = trim(CS%restartfile) + if (present(filename)) restartname = trim(filename) + if (PRESENT(time_stamped)) then ; if (time_stamped) then + call get_date(time, year, month, days, hour, minute, seconds) + ! Compute the year-day, because I don't like months. - RWH + do m=1,month-1 + days = days + days_in_month(set_date(year, m, 2, 0, 0, 0)) + enddo + seconds = seconds + 60*minute + 3600*hour + if (year <= 9999) then + write(restartname,'("_Y",I4.4,"_D",I3.3,"_S",I5.5)') year, days, seconds + elseif (year <= 99999) then + write(restartname,'("_Y",I5.5,"_D",I3.3,"_S",I5.5)') year, days, seconds + else + write(restartname,'("_Y",I10.10,"_D",I3.3,"_S",I5.5)') year, days, seconds + endif + restartname = trim(CS%restartfile)//trim(restartname) + endif ; endif + + ! Determine if there is a filename_appendix (used for ensemble runs). + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + length = len_trim(restartname) + if (restartname(length-2:length) == '.nc') then + restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' + else + restartname = restartname(1:length) //'.'//trim(filename_appendix) + endif + endif + + next_var = 1 + do while (next_var <= CS%novars ) + start_var = next_var + size_in_file = 8*(2*G%Domain%niglobal+2*G%Domain%njglobal+2*nz+1000) + + do m=start_var,CS%novars + call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, caller="save_restart", & + extra_axes=extra_axes) + + var_sz = get_variable_byte_size(hor_grid, z_grid, t_grid, G, nz) + ! factor in size of extra axes, or multiply by 1 + do na=1,nmax_extradims + var_sz = var_sz*extra_axes(na)%ax_size + enddo + + if ((m==start_var) .OR. (size_in_file < max_file_size-var_sz)) then + size_in_file = size_in_file + var_sz + else ; exit + endif + + enddo + next_var = m + + restartpath = trim(directory) // trim(restartname) + + if (num_files < 10) then + write(suffix,'("_",I1)') num_files + else + write(suffix,'("_",I2)') num_files + endif + + length = len_trim(restartpath) + if (length < 3) then ! This case is very uncommon but this test avoids segmentation-faults. + if (num_files > 0) restartpath = trim(restartpath) // suffix + restartpath = trim(restartpath)//".nc" + elseif (restartpath(length-2:length) == ".nc") then + if (num_files > 0) restartpath = restartpath(1:length-3)//trim(suffix)//".nc" + else + if (num_files > 0) restartpath = trim(restartpath) // suffix + restartpath = trim(restartpath)//".nc" + endif + + do m=start_var,next_var-1 + vars(m-start_var+1) = CS%restart_field(m)%vars + enddo + call query_vardesc(vars(1), t_grid=t_grid, hor_grid=hor_grid, caller="save_restart") + t_grid = adjustl(t_grid) + if (t_grid(1:1) /= 'p') & + call modify_vardesc(vars(1), t_grid='s', caller="save_restart") + select case (hor_grid) + case ('q') ; pos = CORNER + case ('h') ; pos = CENTER + case ('u') ; pos = EAST_FACE + case ('v') ; pos = NORTH_FACE + case ('Bu') ; pos = CORNER + case ('T') ; pos = CENTER + case ('Cu') ; pos = EAST_FACE + case ('Cv') ; pos = NORTH_FACE + case ('1') ; pos = 0 + case default ; pos = 0 + end select + + !Prepare the checksum of the restart fields to be written to restart files + if (modulo(turns, 2) /= 0) then + call get_checksum_loop_ranges(G, pos, jsL, jeL, isL, ieL) + else + call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) + endif + do m=start_var,next_var-1 + conv = CS%restart_field(m)%conv + if (associated(CS%var_ptr3d(m)%p)) then + check_val(m-start_var+1,1) = chksum(conv*CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), turns=-turns) + elseif (associated(CS%var_ptr2d(m)%p)) then + check_val(m-start_var+1,1) = chksum(conv*CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), turns=-turns) + elseif (associated(CS%var_ptr4d(m)%p)) then + check_val(m-start_var+1,1) = chksum(conv*CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:), turns=-turns) + elseif (associated(CS%var_ptr1d(m)%p)) then + check_val(m-start_var+1,1) = chksum(conv*CS%var_ptr1d(m)%p(:)) + elseif (associated(CS%var_ptr0d(m)%p)) then + check_val(m-start_var+1,1) = chksum(conv*CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) + endif + enddo + + if (CS%parallel_restartfiles) then + call create_MOM_file(IO_handle, trim(restartpath), vars, next_var-start_var, & + fields, MULTIPLE, G=G, GV=GV, checksums=check_val, extra_axes=extra_axes) + else + call create_MOM_file(IO_handle, trim(restartpath), vars, next_var-start_var, & + fields, SINGLE_FILE, G=G, GV=GV, checksums=check_val, extra_axes=extra_axes) + endif + + do m=start_var,next_var-1 + if (associated(CS%var_ptr3d(m)%p)) then + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr3d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv, turns=-turns) + elseif (associated(CS%var_ptr2d(m)%p)) then + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr2d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv, turns=-turns) + elseif (associated(CS%var_ptr4d(m)%p)) then + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr4d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv, turns=-turns) + elseif (associated(CS%var_ptr1d(m)%p)) then + call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr1d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv) + elseif (associated(CS%var_ptr0d(m)%p)) then + call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr0d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv) + endif + enddo + + call IO_handle%close() + + num_files = num_files+1 + + enddo + + if (present(num_rest_files)) num_rest_files = num_files + +end subroutine save_restart + +!> restore_state reads the model state from previously generated files. All +!! restart variables are read from the first file in the input filename list +!! in which they are found. +subroutine restore_state(filename, directory, day, G, CS) + character(len=*), intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), intent(in) :: directory !< The directory in which to find restart files + type(time_type), intent(out) :: day !< The time of the restarted run + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + ! Local variables + real :: scale ! A scaling factor for reading a field [A a-1 ~> 1] to convert + ! from the units in the file to the internal units of this field + real :: conv ! The output conversion factor for writing a field [a A-1 ~> 1] + character(len=512) :: mesg ! A message for warnings. + character(len=80) :: varname ! A variable's name. + integer :: num_file ! The number of files (restart files and others + ! explicitly in filename) that are open. + integer :: i, n, m, missing_fields + integer :: isL, ieL, jsL, jeL + integer :: nvar, ntime, pos + + type(MOM_infra_file) :: IO_handles(CS%max_fields) ! The I/O units of all open files. + character(len=200) :: unit_path(CS%max_fields) ! The file names. + logical :: unit_is_global(CS%max_fields) ! True if the file is global. + + character(len=8) :: hor_grid ! Variable grid info. + real :: t1, t2 ! Two times from the start of different files [days]. + real, allocatable :: time_vals(:) ! Times from a file extracted with getl_file_times [days] + type(MOM_field), allocatable :: fields(:) + logical :: is_there_a_checksum ! Is there a valid checksum that should be checked. + integer(kind=8) :: checksum_file ! The checksum value recorded in the input file. + integer(kind=8) :: checksum_data ! The checksum value for the data that was read in. + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "restore_state: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + ! Get NetCDF ids for all of the restart files. + if ((LEN_TRIM(filename) == 1) .and. (filename(1:1) == 'F')) then + num_file = open_restart_units('r', directory, G, CS, IO_handles=IO_handles, & + file_paths=unit_path, global_files=unit_is_global) + else + num_file = open_restart_units(filename, directory, G, CS, IO_handles=IO_handles, & + file_paths=unit_path, global_files=unit_is_global) + endif + + if (num_file == 0) then + write(mesg,'("Unable to find any restart files specified by ",A," in directory ",A,".")') & + trim(filename), trim(directory) + call MOM_error(FATAL,"MOM_restart: "//mesg) + endif + + ! Get the time from the first file in the list that has one. + do n=1,num_file + call IO_handles(n)%get_file_times(time_vals, ntime) + if (ntime < 1) cycle + + t1 = time_vals(1) + deallocate(time_vals) + + day = real_to_time(t1*86400.0) + exit + enddo + + if (n>num_file) call MOM_error(WARNING,"MOM_restart: " // & + "No times found in restart files.") + + ! Check the remaining files for different times and issue a warning + ! if they differ from the first time. + do m = n+1,num_file + call IO_handles(n)%get_file_times(time_vals, ntime) + if (ntime < 1) cycle + + t2 = time_vals(1) + deallocate(time_vals) + + if (t1 /= t2 .and. is_root_PE()) then + write(mesg,'("WARNING: Restart file ",I2," has time ",F10.4,"whereas & + &simulation is restarted at ",F10.4," (differing by ",F10.4,").")')& + m,t1,t2,t1-t2 + call MOM_error(WARNING, "MOM_restart: "//mesg) + endif + enddo + + ! Read each variable from the first file in which it is found. + do n=1,num_file + call IO_handles(n)%get_file_info(nvar=nvar) + + allocate(fields(nvar)) + call IO_handles(n)%get_file_fields(fields(1:nvar)) + + do m=1, nvar + call IO_handles(n)%get_field_atts(fields(m), name=varname) + do i=1,CS%num_obsolete_vars + if (adjustl(lowercase(trim(varname))) == adjustl(lowercase(trim(CS%restart_obsolete(i)%field_name)))) then + call MOM_error(FATAL, "MOM_restart restore_state: Attempting to use obsolete restart field "//& + trim(varname)//" - the new corresponding restart field is "//& + trim(CS%restart_obsolete(i)%replacement_name)) + endif + enddo + enddo + + missing_fields = 0 + + do m=1,CS%novars + if (CS%restart_field(m)%initialized) cycle + call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, & + caller="restore_state") + select case (hor_grid) + case ('q') ; pos = CORNER + case ('h') ; pos = CENTER + case ('u') ; pos = EAST_FACE + case ('v') ; pos = NORTH_FACE + case ('Bu') ; pos = CORNER + case ('T') ; pos = CENTER + case ('Cu') ; pos = EAST_FACE + case ('Cv') ; pos = NORTH_FACE + case ('1') ; pos = 0 + case default ; pos = 0 + end select + conv = CS%restart_field(m)%conv + if (conv == 0.0) then ; scale = 1.0 ; else ; scale = 1.0 / conv ; endif + + call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) + do i=1, nvar + call IO_handles(n)%get_field_atts(fields(i), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(CS%restart_field(m)%var_name))) then + checksum_data = -1 + if (CS%checksum_required) then + call IO_handles(n)%read_field_chksum(fields(i), checksum_file, is_there_a_checksum) + else + checksum_file = -1 + is_there_a_checksum = .false. ! Do not need to do data checksumming. + endif + + if (associated(CS%var_ptr1d(m)%p)) then + ! Read a 1d array, which should be invariant to domain decomposition. + call MOM_read_data(unit_path(n), varname, CS%var_ptr1d(m)%p, & + timelevel=1, scale=scale, MOM_Domain=G%Domain) + if (is_there_a_checksum) checksum_data = chksum(conv*CS%var_ptr1d(m)%p(:)) + elseif (associated(CS%var_ptr0d(m)%p)) then ! Read a scalar... + call MOM_read_data(unit_path(n), varname, CS%var_ptr0d(m)%p, & + timelevel=1, scale=scale, MOM_Domain=G%Domain) + if (is_there_a_checksum) checksum_data = chksum(conv*CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) + elseif (associated(CS%var_ptr2d(m)%p)) then ! Read a 2d array. + if (pos /= 0) then + call MOM_read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & + G%Domain, timelevel=1, position=pos, scale=scale) + else ! This array is not domain-decomposed. This variant may be under-tested. + call MOM_error(FATAL, & + "MOM_restart does not support 2-d arrays without domain decomposition.") + ! call read_data(unit_path(n), varname, CS%var_ptr2d(m)%p,no_domain=.true., timelevel=1) + endif + if (is_there_a_checksum) checksum_data = chksum(conv*CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) + elseif (associated(CS%var_ptr3d(m)%p)) then ! Read a 3d array. + if (pos /= 0) then + call MOM_read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & + G%Domain, timelevel=1, position=pos, scale=scale) + else ! This array is not domain-decomposed. This variant may be under-tested. + call MOM_error(FATAL, & + "MOM_restart does not support 3-d arrays without domain decomposition.") + ! call read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, no_domain=.true., timelevel=1) + endif + if (is_there_a_checksum) checksum_data = chksum(conv*CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) + elseif (associated(CS%var_ptr4d(m)%p)) then ! Read a 4d array. + if (pos /= 0) then + call MOM_read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & + G%Domain, timelevel=1, position=pos, scale=scale, global_file=unit_is_global(n)) + else ! This array is not domain-decomposed. This variant may be under-tested. + call MOM_error(FATAL, & + "MOM_restart does not support 4-d arrays without domain decomposition.") + ! call read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, no_domain=.true., timelevel=1) + endif + if (is_there_a_checksum) checksum_data = chksum(conv*CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) + else + call MOM_error(FATAL, "MOM_restart restore_state: No pointers set for "//trim(varname)) + endif + + if (is_root_pe() .and. is_there_a_checksum .and. (checksum_file /= checksum_data)) then + write (mesg,'(a,Z16,a,Z16,a)') "Checksum of input field "// trim(varname)//" ",checksum_data,& + " does not match value ", checksum_file, & + " stored in "//trim(unit_path(n)//"." ) + call MOM_error(FATAL, "MOM_restart(restore_state): "//trim(mesg) ) + endif + + CS%restart_field(m)%initialized = .true. + exit ! Start search for next restart variable. + endif + enddo + if (i>nvar) missing_fields = missing_fields+1 + enddo + + deallocate(fields) + if (missing_fields == 0) exit + enddo + + do n=1,num_file + call IO_handles(n)%close() + enddo + + ! Check whether any mandatory fields have not been found. + CS%restart = .true. + do m=1,CS%novars + if (.not.(CS%restart_field(m)%initialized)) then + CS%restart = .false. + if (CS%restart_field(m)%mand_var) then + call MOM_error(FATAL,"MOM_restart: Unable to find mandatory variable " & + //trim(CS%restart_field(m)%var_name)//" in restart files.") + endif + endif + enddo + + ! Lock the restart registry so that no further variables can be registered. + CS%locked = .true. + +end subroutine restore_state + +!> restart_files_exist determines whether any restart files exist. +function restart_files_exist(filename, directory, G, CS) + character(len=*), intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), intent(in) :: directory !< The directory in which to find restart files + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical :: restart_files_exist !< The function result, which indicates whether + !! any of the explicitly or automatically named + !! restart files exist in directory + integer :: num_files + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "restart_files_exist: Module must be initialized before it is used.") + + if ((LEN_TRIM(filename) == 1) .and. (filename(1:1) == 'F')) then + num_files = get_num_restart_files('r', directory, G, CS) + else + num_files = get_num_restart_files(filename, directory, G, CS) + endif + restart_files_exist = (num_files > 0) +end function restart_files_exist + +!> determine_is_new_run determines from the value of filename and the existence +!! automatically named restart files in directory whether this would be a new, +!! and as a side effect stores this information in CS. +function determine_is_new_run(filename, directory, G, CS) result(is_new_run) + character(len=*), intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), intent(in) :: directory !< The directory in which to find restart files + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + logical :: is_new_run !< The function result, which indicates whether + !! this is a new run, based on the value of + !! filename and whether restart files exist + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "determine_is_new_run: Module must be initialized before it is used.") + + if (LEN_TRIM(filename) > 1) then + CS%new_run = .false. + elseif (LEN_TRIM(filename) == 0) then + CS%new_run = .true. + elseif (filename(1:1) == 'n') then + CS%new_run = .true. + elseif (filename(1:1) == 'F') then + CS%new_run = (get_num_restart_files('r', directory, G, CS) == 0) + else + CS%new_run = .false. + endif + + CS%new_run_set = .true. + is_new_run = CS%new_run +end function determine_is_new_run + +!> is_new_run returns whether this is going to be a new run based on the +!! information stored in CS by a previous call to determine_is_new_run. +function is_new_run(CS) + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + + logical :: is_new_run !< The function result, which had been stored in CS during + !! a previous call to determine_is_new_run + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "is_new_run: Module must be initialized before it is used.") + + if (.not.CS%new_run_set) call MOM_error(FATAL, "MOM_restart " // & + "determine_is_new_run must be called for a restart file before is_new_run.") + + is_new_run = CS%new_run +end function is_new_run + +!> open_restart_units determines the number of existing restart files and optionally opens +!! them and returns unit ids, paths and whether the files are global or spatially decomposed. +function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, & + global_files) result(num_files) + character(len=*), intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), intent(in) :: directory !< The directory in which to find restart files + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + + type(MOM_infra_file), dimension(:), & + optional, intent(out) :: IO_handles !< The I/O handles of all opened files + character(len=*), dimension(:), & + optional, intent(out) :: file_paths !< The full paths to open files + logical, dimension(:), & + optional, intent(out) :: global_files !< True if a file is global + + integer :: num_files !< The number of files (both automatically named restart + !! files and others explicitly in filename) that have been opened. + + ! Local variables + character(len=256) :: filepath ! The path (dir/file) to the file being opened. + character(len=256) :: fname ! The name of the current file. + character(len=8) :: suffix ! A suffix (like "_2") that is added to any + ! additional restart files. + integer :: num_restart ! The number of restart files that have already + ! been opened using their numbered suffix. + integer :: start_char ! The location of the starting character in the + ! current file name. + integer :: nf ! The number of files that have been found so far + integer :: m, length + logical :: still_looking ! If true, the code is still looking for automatically named files + logical :: fexists ! True if a file has been found + character(len=32) :: filename_appendix = '' ! Filename appendix for ensemble runs + character(len=80) :: restartname + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "open_restart_units: Module must be initialized before it is used.") + + ! Get NetCDF ids for all of the restart files. + num_restart = 0 ; nf = 0 ; start_char = 1 + do while (start_char <= len_trim(filename) ) + do m=start_char,len_trim(filename) + if (filename(m:m) == ' ') exit + enddo + fname = filename(start_char:m-1) + start_char = m + do while (start_char <= len_trim(filename)) + if (filename(start_char:start_char) == ' ') then + start_char = start_char + 1 + else + exit + endif + enddo + + if ((fname(1:1)=='r') .and. ( len_trim(fname) == 1)) then + still_looking = (num_restart <= 0) ! Avoid going through the file list twice. + do while (still_looking) + restartname = trim(CS%restartfile) + + ! Determine if there is a filename_appendix (used for ensemble runs). + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + length = len_trim(restartname) + if (restartname(length-2:length) == '.nc') then + restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' + else + restartname = restartname(1:length) //'.'//trim(filename_appendix) + endif + endif + filepath = trim(directory) // trim(restartname) + + if (num_restart < 10) then + write(suffix,'("_",I1)') num_restart + else + write(suffix,'("_",I2)') num_restart + endif + if (num_restart > 0) filepath = trim(filepath) // suffix + + filepath = trim(filepath)//".nc" + + num_restart = num_restart + 1 + ! Look for a global netCDF file. + inquire(file=filepath, exist=fexists) + if (fexists) then + nf = nf + 1 + if (present(IO_handles)) & + call IO_handles(nf)%open(trim(filepath), READONLY_FILE, & + MOM_domain=G%Domain, threading=MULTIPLE, fileset=SINGLE_FILE) + if (present(global_files)) global_files(nf) = .true. + if (present(file_paths)) file_paths(nf) = filepath + elseif (CS%parallel_restartfiles) then + ! Look for decomposed files using the I/O Layout. + fexists = file_exists(filepath, G%Domain) + if (fexists) then + nf = nf + 1 + if (present(IO_handles)) & + call IO_handles(nf)%open(trim(filepath), READONLY_FILE, MOM_domain=G%Domain) + if (present(global_files)) global_files(nf) = .false. + if (present(file_paths)) file_paths(nf) = filepath + endif + endif + + if (fexists) then + if (is_root_pe() .and. (present(IO_handles))) & + call MOM_error(NOTE, "MOM_restart: MOM run restarted using : "//trim(filepath)) + else + still_looking = .false. ; exit + endif + enddo ! while (still_looking) loop + else + filepath = trim(directory)//trim(fname) + inquire(file=filepath, exist=fexists) + if (.not. fexists) filepath = trim(filepath)//".nc" + + inquire(file=filepath, exist=fexists) + if (fexists) then + nf = nf + 1 + if (present(IO_handles)) & + call IO_handles(nf)%open(trim(filepath), READONLY_FILE, & + MOM_Domain=G%Domain, threading=MULTIPLE, fileset=SINGLE_FILE) + if (present(global_files)) global_files(nf) = .true. + if (present(file_paths)) file_paths(nf) = filepath + if (is_root_pe() .and. (present(IO_handles))) & + call MOM_error(NOTE,"MOM_restart: MOM run restarted using : "//trim(filepath)) + else + if (present(IO_handles)) & + call MOM_error(WARNING,"MOM_restart: Unable to find restart file : "//trim(filepath)) + endif + + endif + enddo ! while (start_char < len_trim(filename)) loop + num_files = nf + +end function open_restart_units + +!> get_num_restart_files returns the number of existing restart files that match the provided +!! directory structure and other information stored in the control structure and optionally +!! also provides the full paths to these files. +function get_num_restart_files(filenames, directory, G, CS, file_paths) result(num_files) + character(len=*), intent(in) :: filenames !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), intent(in) :: directory !< The directory in which to find restart files + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + character(len=*), dimension(:), & + optional, intent(out) :: file_paths !< The full paths to the restart files. + + integer :: num_files !< The function result, the number of files (both automatically named + !! restart files and others explicitly in filename) that have been opened + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "get_num_restart_files: Module must be initialized before it is used.") + + ! This call uses open_restart_units without the optional arguments needed to actually + ! open the files to determine the number of restart files. + num_files = open_restart_units(filenames, directory, G, CS, file_paths=file_paths) + +end function get_num_restart_files + + +!> Initialize this module and set up a restart control structure. +subroutine restart_init(param_file, CS, restart_root) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object that is allocated here + character(len=*), optional, & + intent(in) :: restart_root !< A filename root that overrides the value + !! set by RESTARTFILE to enable the use of this module by + !! other components than MOM. + + logical :: rotate_index + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_restart" ! This module's name. + logical :: all_default ! If true, all parameters are using their default values. + + if (associated(CS)) then + call MOM_error(WARNING, "restart_init called with an associated control structure.") + return + endif + allocate(CS) + + CS%initialized = .true. + + ! Determine whether all paramters are set to their default values. + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", CS%parallel_restartfiles, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "MAX_FIELDS", CS%max_fields, default=100, do_not_log=.true.) + call get_param(param_file, mdl, "RESTART_CHECKSUMS_REQUIRED", CS%checksum_required, & + default=.true., do_not_log=.true.) + all_default = ((.not.CS%parallel_restartfiles) .and. (CS%max_fields == 100) .and. & + (CS%checksum_required)) + if (.not.present(restart_root)) then + call get_param(param_file, mdl, "RESTARTFILE", CS%restartfile, & + default="MOM.res", do_not_log=.true.) + all_default = (all_default .and. (trim(CS%restartfile) == trim("MOM.res"))) + endif + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "", all_default=all_default) + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", CS%parallel_restartfiles, & + "If true, the IO layout is used to group processors that write to the same "//& + "restart file or each processor writes its own (numbered) restart file. "//& + "If false, a single restart file is generated combining output from all PEs.", & + default=.false.) + + if (present(restart_root)) then + CS%restartfile = restart_root + call log_param(param_file, mdl, "RESTARTFILE from argument", CS%restartfile) + else + call get_param(param_file, mdl, "RESTARTFILE", CS%restartfile, & + "The name-root of the restart file.", default="MOM.res") + endif + call get_param(param_file, mdl, "MAX_FIELDS", CS%max_fields, & + "The maximum number of restart fields that can be used.", & + default=100) + call get_param(param_file, mdl, "RESTART_CHECKSUMS_REQUIRED", CS%checksum_required, & + "If true, require the restart checksums to match and error out otherwise. "//& + "Users may want to avoid this comparison if for example the restarts are "//& + "made from a run with a different mask_table than the current run, "//& + "in which case the checksums will not match and cause crash.",& + default=.true.) + + ! Maybe not the best place to do this? + call get_param(param_file, mdl, "ROTATE_INDEX", rotate_index, & + default=.false., do_not_log=.true.) + + CS%turns = 0 + if (rotate_index) then + call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & + default=1, do_not_log=.true.) + endif + + allocate(CS%restart_field(CS%max_fields)) + allocate(CS%restart_obsolete(CS%max_fields)) + allocate(CS%var_ptr0d(CS%max_fields)) + allocate(CS%var_ptr1d(CS%max_fields)) + allocate(CS%var_ptr2d(CS%max_fields)) + allocate(CS%var_ptr3d(CS%max_fields)) + allocate(CS%var_ptr4d(CS%max_fields)) + + CS%locked = .false. + +end subroutine restart_init + +!> Issue an error message if the restart_registry is locked. +subroutine lock_check(CS, var_desc, name) + type(MOM_restart_CS), intent(in) :: CS !< A MOM_restart_CS object (intent in) + type(vardesc), optional, intent(in) :: var_desc !< A structure with metadata about this variable + character(len=*), optional, intent(in) :: name !< variable name to be used in the restart file + + character(len=256) :: var_name ! A variable name. + + if (CS%locked) then + if (present(var_desc)) then + call query_vardesc(var_desc, name=var_name) + call MOM_error(FATAL, "Attempted to register "//trim(var_name)//" but the restart registry is locked.") + elseif (present(name)) then + call MOM_error(FATAL, "Attempted to register "//trim(name)//" but the restart registry is locked.") + else + call MOM_error(FATAL, "Attempted to register a variable but the restart registry is locked.") + endif + endif + +end subroutine lock_check + +!> Lock the restart registry so that an error is issued if any further restart variables are registered. +subroutine restart_registry_lock(CS, unlocked) + type(MOM_restart_CS), intent(inout) :: CS !< A MOM_restart_CS object (intent inout) + logical, optional, intent(in) :: unlocked !< If present and true, unlock the registry + + CS%locked = .true. + if (present(unlocked)) CS%locked = .not.unlocked +end subroutine restart_registry_lock + +!> Indicate that all variables have now been registered and lock the registry. +subroutine restart_init_end(CS) + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object + + if (associated(CS)) then + CS%locked = .true. + + if (CS%novars == 0) call restart_end(CS) + endif + +end subroutine restart_init_end + +!> Deallocate memory associated with a MOM_restart_CS variable. +subroutine restart_end(CS) + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object + + if (associated(CS%restart_field)) deallocate(CS%restart_field) + if (associated(CS%restart_obsolete)) deallocate(CS%restart_obsolete) + if (associated(CS%var_ptr0d)) deallocate(CS%var_ptr0d) + if (associated(CS%var_ptr1d)) deallocate(CS%var_ptr1d) + if (associated(CS%var_ptr2d)) deallocate(CS%var_ptr2d) + if (associated(CS%var_ptr3d)) deallocate(CS%var_ptr3d) + if (associated(CS%var_ptr4d)) deallocate(CS%var_ptr4d) + deallocate(CS) + +end subroutine restart_end + +subroutine restart_error(CS) + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + + character(len=16) :: num ! String for error messages + + if (CS%novars > CS%max_fields) then + write(num,'(I0)') CS%novars + call MOM_error(FATAL,"MOM_restart: Too many fields registered for " // & + "restart. Set MAX_FIELDS to be at least " // & + trim(adjustl(num)) // " in the MOM input file.") + else + call MOM_error(FATAL,"MOM_restart: Unspecified fatal error.") + endif +end subroutine restart_error + +!> Return bounds for computing checksums to store in restart files +subroutine get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer, intent(in) :: pos !< An integer indicating staggering of variable + integer, intent(out) :: isL !< i-start for checksum + integer, intent(out) :: ieL !< i-end for checksum + integer, intent(out) :: jsL !< j-start for checksum + integer, intent(out) :: jeL !< j-end for checksum + + ! Regular non-symmetric compute domain + isL = G%isc-G%isd+1 + ieL = G%iec-G%isd+1 + jsL = G%jsc-G%jsd+1 + jeL = G%jec-G%jsd+1 + + ! Expand range east or south for symmetric arrays + if (G%symmetric) then + if ((pos == EAST_FACE) .or. (pos == CORNER)) then ! For u-, q-points only + if (G%idg_offset == 0) isL = isL - 1 ! include western edge in checksums only for western PEs + endif + if ((pos == NORTH_FACE) .or. (pos == CORNER)) then ! For v-, q-points only + if (G%jdg_offset == 0) jsL = jsL - 1 ! include western edge in checksums only for southern PEs + endif + endif + +end subroutine get_checksum_loop_ranges + +!> get the size of a variable in bytes +function get_variable_byte_size(hor_grid, z_grid, t_grid, G, num_z) result(var_sz) + character(len=8), intent(in) :: hor_grid !< The horizontal grid string to interpret + character(len=8), intent(in) :: z_grid !< The vertical grid string to interpret + character(len=8), intent(in) :: t_grid !< A time string to interpret + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer, intent(in) :: num_z !< The number of vertical layers in the grid + integer(kind=8) :: var_sz !< The function result, the size in bytes of a variable + + ! Local variables + integer :: var_periods ! The number of entries in a time-periodic axis + character(len=8) :: t_grid_read, t_grid_tmp ! Modified versions of t_grid + + if (trim(hor_grid) == '1') then + var_sz = 8 + else ! This may be an overestimate, as it is based on symmetric-memory corner points. + var_sz = 8*(G%Domain%niglobal+1)*(G%Domain%njglobal+1) + endif + + select case (trim(z_grid)) + case ('L') ; var_sz = var_sz * num_z + case ('i') ; var_sz = var_sz * (num_z+1) + end select + + t_grid_tmp = adjustl(t_grid) + if (t_grid_tmp(1:1) == 'p') then + if (len_trim(t_grid_tmp(2:8)) > 0) then + var_periods = -1 + t_grid_read = adjustl(t_grid_tmp(2:8)) + read(t_grid_read,*) var_periods + if (var_periods > 1) var_sz = var_sz * var_periods + endif + endif + +end function get_variable_byte_size + +end module MOM_restart diff --git a/framework/MOM_safe_alloc.F90 b/framework/MOM_safe_alloc.F90 new file mode 100644 index 0000000000..8960e8e358 --- /dev/null +++ b/framework/MOM_safe_alloc.F90 @@ -0,0 +1,149 @@ +!> Convenience functions for safely allocating memory without +!! accidentally reallocating pointer and causing memory leaks. +module MOM_safe_alloc + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public safe_alloc_ptr, safe_alloc_alloc + +!> Allocate a pointer to a 1-d, 2-d or 3-d array +interface safe_alloc_ptr + module procedure safe_alloc_ptr_3d_3arg, safe_alloc_ptr_3d_6arg, safe_alloc_ptr_2d_2arg + module procedure safe_alloc_ptr_3d, safe_alloc_ptr_2d, safe_alloc_ptr_1d +end interface safe_alloc_ptr + +!> Allocate a 2-d or 3-d allocatable array +interface safe_alloc_alloc + module procedure safe_alloc_allocatable_3d, safe_alloc_allocatable_2d + module procedure safe_alloc_allocatable_3d_6arg +end interface safe_alloc_alloc + +! This combined interface might work with a later version of Fortran, but +! it fails with the gnu F90 compiler. +! +! interface safe_alloc +! module procedure safe_alloc_ptr_3d_2arg, safe_alloc_ptr_2d_2arg +! module procedure safe_alloc_ptr_3d, safe_alloc_ptr_2d, safe_alloc_ptr_1d +! module procedure safe_alloc_allocatable_3d, safe_alloc_allocatable_2d +! end interface safe_alloc + +contains + +!> Allocate a pointer to a 1-d array +subroutine safe_alloc_ptr_1d(ptr, i1, i2) + real, dimension(:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: i1 !< The size of the array, or its starting index if i2 is present + integer, optional, intent(in) :: i2 !< The ending index of the array + if (.not.associated(ptr)) then + if (present(i2)) then + allocate(ptr(i1:i2), source=0.0) + else + allocate(ptr(i1), source=0.0) + endif + endif +end subroutine safe_alloc_ptr_1d + +!> Allocate a pointer to a 2-d array based on its dimension sizes +subroutine safe_alloc_ptr_2d_2arg(ptr, ni, nj) + real, dimension(:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: ni !< The size of the 1st dimension of the array + integer, intent(in) :: nj !< The size of the 2nd dimension of the array + if (.not.associated(ptr)) then + allocate(ptr(ni,nj), source=0.0) + endif +end subroutine safe_alloc_ptr_2d_2arg + +!> Allocate a pointer to a 3-d array based on its dimension sizes +subroutine safe_alloc_ptr_3d_3arg(ptr, ni, nj, nk) + real, dimension(:,:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: ni !< The size of the 1st dimension of the array + integer, intent(in) :: nj !< The size of the 2nd dimension of the array + integer, intent(in) :: nk !< The size of the 3rd dimension of the array + if (.not.associated(ptr)) then + allocate(ptr(ni,nj,nk), source=0.0) + endif +end subroutine safe_alloc_ptr_3d_3arg + +!> Allocate a pointer to a 2-d array based on its index starting and ending values +subroutine safe_alloc_ptr_2d(ptr, is, ie, js, je) + real, dimension(:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension + if (.not.associated(ptr)) then + allocate(ptr(is:ie,js:je), source=0.0) + endif +end subroutine safe_alloc_ptr_2d + +!> Allocate a pointer to a 3-d array based on its index starting and ending values +subroutine safe_alloc_ptr_3d(ptr, is, ie, js, je, nk) + real, dimension(:,:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension + integer, intent(in) :: nk !< The size to allocate for the 3rd dimension + if (.not.associated(ptr)) then + allocate(ptr(is:ie,js:je,nk), source=0.0) + endif +end subroutine safe_alloc_ptr_3d + +!> Allocate a pointer to a 3-d array based on its index starting and ending values +subroutine safe_alloc_ptr_3d_6arg(ptr, is, ie, js, je, ks, ke) + real, dimension(:,:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension + integer, intent(in) :: ks !< The start index to allocate for the 3rd dimension + integer, intent(in) :: ke !< The end index to allocate for the 3rd dimension + if (.not.associated(ptr)) then + allocate(ptr(is:ie,js:je,ks:ke), source=0.0) + endif +end subroutine safe_alloc_ptr_3d_6arg + + +!> Allocate a 2-d allocatable array based on its index starting and ending values +subroutine safe_alloc_allocatable_2d(ptr, is, ie, js, je) + real, dimension(:,:), allocatable :: ptr !< An allocatable array to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension + if (.not.allocated(ptr)) then + allocate(ptr(is:ie,js:je), source=0.0) + endif +end subroutine safe_alloc_allocatable_2d + +!> Allocate a 3-d allocatable array based on its index starting and ending values +!! and k-index size +subroutine safe_alloc_allocatable_3d(ptr, is, ie, js, je, nk) + real, dimension(:,:,:), allocatable :: ptr !< An allocatable array to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension + integer, intent(in) :: nk !< The size to allocate for the 3rd dimension + if (.not.allocated(ptr)) then + allocate(ptr(is:ie,js:je,nk), source=0.0) + endif +end subroutine safe_alloc_allocatable_3d + +!> Allocate a 3-d allocatable array based on its 6 index starting and ending values +subroutine safe_alloc_allocatable_3d_6arg(ptr, is, ie, js, je, ks, ke) + real, dimension(:,:,:), allocatable :: ptr !< An allocatable array to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension + integer, intent(in) :: ks !< The start index to allocate for the 3rd dimension + integer, intent(in) :: ke !< The end index to allocate for the 3rd dimension + if (.not.allocated(ptr)) then + allocate(ptr(is:ie,js:je,ks:ke), source=0.0) + endif +end subroutine safe_alloc_allocatable_3d_6arg + +end module MOM_safe_alloc diff --git a/framework/MOM_string_functions.F90 b/framework/MOM_string_functions.F90 new file mode 100644 index 0000000000..65aa864f4e --- /dev/null +++ b/framework/MOM_string_functions.F90 @@ -0,0 +1,427 @@ +!> Handy functions for manipulating strings +module MOM_string_functions + +! This file is part of MOM6. See LICENSE.md for the license. + +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit + +implicit none ; private + +public lowercase, uppercase +public left_int, left_ints +public left_real, left_reals +public string_functions_unit_tests +public extractWord +public extract_word +public extract_integer +public extract_real +public remove_spaces +public slasher + +contains + +!> Return a string in which all uppercase letters have been replaced by +!! their lowercase counterparts. +function lowercase(input_string) + character(len=*), intent(in) :: input_string !< The string to modify + character(len=len(input_string)) :: lowercase !< The modified output string +! This function returns a string in which all uppercase letters have been +! replaced by their lowercase counterparts. It is loosely based on the +! lowercase function in mpp_util.F90. + integer, parameter :: co=iachar('a')-iachar('A') ! case offset + integer :: k + + lowercase = input_string + do k=1, len_trim(input_string) + if (lowercase(k:k) >= 'A' .and. lowercase(k:k) <= 'Z') & + lowercase(k:k) = achar(ichar(lowercase(k:k))+co) + enddo +end function lowercase + +!> Return a string in which all uppercase letters have been replaced by +!! their lowercase counterparts. +function uppercase(input_string) + character(len=*), intent(in) :: input_string !< The string to modify + character(len=len(input_string)) :: uppercase !< The modified output string +! This function returns a string in which all lowercase letters have been +! replaced by their uppercase counterparts. It is loosely based on the +! uppercase function in mpp_util.F90. + integer, parameter :: co=iachar('A')-iachar('a') ! case offset + integer :: k + + uppercase = input_string + do k=1, len_trim(input_string) + if (uppercase(k:k) >= 'a' .and. uppercase(k:k) <= 'z') & + uppercase(k:k) = achar(ichar(uppercase(k:k))+co) + enddo +end function uppercase + +!> Returns a character string of a left-formatted integer +!! e.g. "123 " (assumes 19 digit maximum) +function left_int(i) + integer, intent(in) :: i !< The integer to convert to a string + character(len=19) :: left_int !< The output string + + character(len=19) :: tmp + write(tmp(1:19),'(I19)') i + write(left_int(1:19),'(A)') adjustl(tmp) +end function left_int + +!> Returns a character string of a comma-separated, compact formatted, +!! integers e.g. "1, 2, 3, 4" +function left_ints(i) + integer, intent(in) :: i(:) !< The array of integers to convert to a string + character(len=1320) :: left_ints !< The output string + + character(len=1320) :: tmp + integer :: j + write(left_ints(1:1320),'(A)') trim(left_int(i(1))) + if (size(i)>1) then + do j=2,size(i) + tmp=left_ints + write(left_ints(1:1320),'(A,", ",A)') trim(tmp),trim(left_int(i(j))) + enddo + endif +end function left_ints + +!> Returns a left-justified string with a real formatted like '(G)' +function left_real(val) + real, intent(in) :: val !< The real variable to convert to a string + character(len=32) :: left_real !< The output string + + integer :: l, ind + + if ((abs(val) < 1.0e4) .and. (abs(val) >= 1.0e-3)) then + write(left_real, '(F30.11)') val + if (.not.isFormattedFloatEqualTo(left_real,val)) then + write(left_real, '(F30.12)') val + if (.not.isFormattedFloatEqualTo(left_real,val)) then + write(left_real, '(F30.13)') val + if (.not.isFormattedFloatEqualTo(left_real,val)) then + write(left_real, '(F30.14)') val + if (.not.isFormattedFloatEqualTo(left_real,val)) then + write(left_real, '(F30.15)') val + if (.not.isFormattedFloatEqualTo(left_real,val)) then + write(left_real, '(F30.16)') val + endif + endif + endif + endif + endif + do + l = len_trim(left_real) + if ((l<2) .or. (left_real(l-1:l) == ".0") .or. & + (left_real(l:l) /= "0")) exit + left_real(l:l) = " " + enddo + elseif (val == 0.) then + left_real = "0.0" + else + if ((abs(val) <= 1.0e-100) .or. (abs(val) >= 1.0e100)) then + write(left_real(1:32), '(ES24.14E3)') val + if (.not.isFormattedFloatEqualTo(left_real,val)) & + write(left_real(1:32), '(ES24.15E3)') val + else + write(left_real(1:32), '(ES23.14)') val + if (.not.isFormattedFloatEqualTo(left_real,val)) & + write(left_real(1:32), '(ES23.15)') val + endif + do + ind = index(left_real,"0E") + if (ind == 0) exit + if (left_real(ind-1:ind-1) == ".") exit + left_real = left_real(1:ind-1)//left_real(ind+1:) + enddo + endif + left_real = adjustl(left_real) +end function left_real + +!> Returns a character string of a comma-separated, compact formatted, reals +!! e.g. "1., 2., 5*3., 5.E2" +function left_reals(r,sep) + real, intent(in) :: r(:) !< The array of real variables to convert to a string + character(len=*), optional, intent(in) :: sep !< The separator between + !! successive values, by default it is ', '. + character(len=:), allocatable :: left_reals !< The output string + + integer :: j, n, ns + logical :: doWrite + character(len=10) :: separator + + n=1 ; doWrite=.true. ; left_reals='' + if (present(sep)) then + separator=sep ; ns=len(sep) + else + separator=', ' ; ns=2 + endif + do j=1,size(r) + doWrite=.true. + if (j0) then ! Write separator if a number has already been written + left_reals = left_reals // separator(1:ns) + endif + if (n>1) then + left_reals = left_reals // trim(left_int(n)) // "*" // trim(left_real(r(j))) + else + left_reals = left_reals // trim(left_real(r(j))) + endif + n=1 + endif + enddo +end function left_reals + +!> Returns True if the string can be read/parsed to give the exact value of "val" +function isFormattedFloatEqualTo(str, val) + character(len=*), intent(in) :: str !< The string to parse + real, intent(in) :: val !< The real value to compare with + logical :: isFormattedFloatEqualTo + ! Local variables + real :: scannedVal + + isFormattedFloatEqualTo=.false. + read(str(1:),*,err=987) scannedVal + if (scannedVal == val) isFormattedFloatEqualTo=.true. + 987 return +end function isFormattedFloatEqualTo + +!> Returns the string corresponding to the nth word in the argument +!! or "" if the string is not long enough. Both spaces and commas +!! are interpreted as separators. +character(len=120) function extractWord(string, n) + character(len=*), intent(in) :: string !< The string to scan + integer, intent(in) :: n !< Number of word to extract + + extractWord = extract_word(string, ' ,', n) + +end function extractWord + +!> Returns the string corresponding to the nth word in the argument +!! or "" if the string is not long enough. Words are delineated +!! by the mandatory separators argument. +character(len=120) function extract_word(string, separators, n) + character(len=*), intent(in) :: string !< String to scan + character(len=*), intent(in) :: separators !< Characters to use for delineation + integer, intent(in) :: n !< Number of word to extract + ! Local variables + integer :: ns, i, b, e, nw + logical :: lastCharIsSeperator + extract_word = '' + lastCharIsSeperator = .true. + ns = len_trim(string) + i = 0; b=0; e=0; nw=0 + do while (i Returns the integer corresponding to the nth word in the argument. +integer function extract_integer(string, separators, n, missing_value) + character(len=*), intent(in) :: string !< String to scan + character(len=*), intent(in) :: separators !< Characters to use for delineation + integer, intent(in) :: n !< Number of word to extract + integer, optional, intent(in) :: missing_value !< Value to assign if word is missing + ! Local variables + character(len=20) :: word + + word = extract_word(string, separators, n) + + if (len_trim(word)>0) then + read(word(1:len_trim(word)),*) extract_integer + else + if (present(missing_value)) then + extract_integer = missing_value + else + extract_integer = 0 + endif + endif + +end function extract_integer + +!> Returns the real corresponding to the nth word in the argument. +real function extract_real(string, separators, n, missing_value) + character(len=*), intent(in) :: string !< String to scan + character(len=*), intent(in) :: separators !< Characters to use for delineation + integer, intent(in) :: n !< Number of word to extract + real, optional, intent(in) :: missing_value !< Value to assign if word is missing + ! Local variables + character(len=20) :: word + + word = extract_word(string, separators, n) + + if (len_trim(word)>0) then + read(word(1:len_trim(word)),*) extract_real + else + if (present(missing_value)) then + extract_real = missing_value + else + extract_real = 0 + endif + endif + +end function extract_real + +!> Returns string with all spaces removed. +character(len=120) function remove_spaces(string) + character(len=*), intent(in) :: string !< String to scan + ! Local variables + integer :: ns, i, o + logical :: lastCharIsSeperator + lastCharIsSeperator = .true. + ns = len_trim(string) + i = 0; o = 0 + do while (i Returns true if a unit test of string_functions fails. +logical function string_functions_unit_tests(verbose) + ! Arguments + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + integer :: i(5) = (/ -1, 1, 3, 3, 0 /) + real :: r(8) = (/ 0., 1., -2., 1.3, 3.E-11, 3.E-11, 3.E-11, -5.1E12 /) + logical :: fail, v + fail = .false. + v = verbose + write(stdout,*) '==== MOM_string_functions: string_functions_unit_tests ===' + fail = fail .or. localTestS(v,left_int(-1),'-1') + fail = fail .or. localTestS(v,left_ints(i(:)),'-1, 1, 3, 3, 0') + fail = fail .or. localTestS(v,left_real(0.),'0.0') + fail = fail .or. localTestS(v,left_reals(r(:)),'0.0, 1.0, -2.0, 1.3, 3*3.0E-11, -5.1E+12') + fail = fail .or. localTestS(v,left_reals(r(:),sep=' '),'0.0 1.0 -2.0 1.3 3*3.0E-11 -5.1E+12') + fail = fail .or. localTestS(v,left_reals(r(:),sep=','),'0.0,1.0,-2.0,1.3,3*3.0E-11,-5.1E+12') + fail = fail .or. localTestS(v,extractWord("One Two,Three",1),"One") + fail = fail .or. localTestS(v,extractWord("One Two,Three",2),"Two") + fail = fail .or. localTestS(v,extractWord("One Two,Three",3),"Three") + fail = fail .or. localTestS(v,extractWord("One Two, Three",3),"Three") + fail = fail .or. localTestS(v,extractWord(" One Two,Three",1),"One") + fail = fail .or. localTestS(v,extract_word("One,Two,Three",",",3),"Three") + fail = fail .or. localTestS(v,extract_word("One,Two,Three",",",4),"") + fail = fail .or. localTestS(v,remove_spaces("1 2 3"),"123") + fail = fail .or. localTestS(v,remove_spaces(" 1 2 3"),"123") + fail = fail .or. localTestS(v,remove_spaces("1 2 3 "),"123") + fail = fail .or. localTestS(v,remove_spaces("123"),"123") + fail = fail .or. localTestS(v,remove_spaces(" "),"") + fail = fail .or. localTestS(v,remove_spaces(""),"") + fail = fail .or. localTestI(v,extract_integer("1","",1),1) + fail = fail .or. localTestI(v,extract_integer("1,2,3",",",1),1) + fail = fail .or. localTestI(v,extract_integer("1,2",",",2),2) + fail = fail .or. localTestI(v,extract_integer("1,2",",",3),0) + fail = fail .or. localTestI(v,extract_integer("1,2",",",4,4),4) + fail = fail .or. localTestR(v,extract_real("1.","",1),1.) + fail = fail .or. localTestR(v,extract_real("1.,2.,3.",",",1),1.) + fail = fail .or. localTestR(v,extract_real("1.,2.",",",2),2.) + fail = fail .or. localTestR(v,extract_real("1.,2.",",",3),0.) + fail = fail .or. localTestR(v,extract_real("1.,2.",",",4,4.),4.) + if (.not. fail) write(stdout,*) 'Pass' + string_functions_unit_tests = fail +end function string_functions_unit_tests + +!> True if str1 does not match str2. False otherwise. +logical function localTestS(verbose,str1,str2) + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), intent(in) :: str1 !< String + character(len=*), intent(in) :: str2 !< String + localTestS=.false. + if (trim(str1)/=trim(str2)) localTestS=.true. + if (localTestS .or. verbose) then + write(stdout,*) '>'//trim(str1)//'<' + if (localTestS) then + write(stdout,*) trim(str1),':',trim(str2), '<-- FAIL' + write(stderr,*) trim(str1),':',trim(str2), '<-- FAIL' + endif + endif +end function localTestS + +!> True if i1 is not equal to i2. False otherwise. +logical function localTestI(verbose,i1,i2) + logical, intent(in) :: verbose !< If true, write results to stdout + integer, intent(in) :: i1 !< Integer + integer, intent(in) :: i2 !< Integer + localTestI=.false. + if (i1/=i2) localTestI=.true. + if (localTestI .or. verbose) then + write(stdout,*) i1,i2 + if (localTestI) then + write(stdout,*) i1,'!=',i2, '<-- FAIL' + write(stderr,*) i1,'!=',i2, '<-- FAIL' + endif + endif +end function localTestI + +!> True if r1 is not equal to r2. False otherwise. +logical function localTestR(verbose,r1,r2) + logical, intent(in) :: verbose !< If true, write results to stdout + real, intent(in) :: r1 !< Float + real, intent(in) :: r2 !< Float + localTestR=.false. + if (r1/=r2) localTestR=.true. + if (localTestR .or. verbose) then + write(stdout,*) r1,r2 + if (localTestR) then + write(stdout,*) r1,'!=',r2, '<-- FAIL' + write(stderr,*) r1,'!=',r2, '<-- FAIL' + endif + endif +end function localTestR + +!> Returns a directory name that is terminated with a "/" or "./" if the +!! argument is an empty string. +function slasher(dir) + character(len=*), intent(in) :: dir !< A directory to be terminated with a "/" + !! or changed to "./" if it is blank. + character(len=len(dir)+2) :: slasher + + if (len_trim(dir) == 0) then + slasher = "./" + elseif (dir(len_trim(dir):len_trim(dir)) == '/') then + slasher = trim(dir) + else + slasher = trim(dir)//"/" + endif +end function slasher + +!> \namespace mom_string_functions +!! +!! By Alistair Adcroft and Robert Hallberg, last updated Sept. 2013. +!! +!! The functions here perform a set of useful manipulations of +!! character strings. Although they are a part of MOM6, the do not +!! require any other MOM software to be useful. + +end module MOM_string_functions diff --git a/framework/MOM_unique_scales.F90 b/framework/MOM_unique_scales.F90 new file mode 100644 index 0000000000..6572678c06 --- /dev/null +++ b/framework/MOM_unique_scales.F90 @@ -0,0 +1,356 @@ +!> This module provides tools that can be used to check the uniqueness of the dimensional +!! scaling factors used by the MOM6 ocean model or other models +module MOM_unique_scales + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, assert, MOM_get_verbosity + +implicit none ; private + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +public check_scaling_uniqueness, scales_to_powers + +contains + +!> This subroutine does a checks whether the provided dimensional scaling factors give a unique +!! overall scaling for each of the combinations of units in description, and suggests a better +!! combination if it is not unique. However, this subroutine does nothing if the verbosity level +!! for this run is below 3. +subroutine check_scaling_uniqueness(component, descs, weights, key, scales, max_powers) + character(len=*), intent(in) :: component !< The name of the component (e.g., MOM6) to use in messages + character(len=*), intent(in) :: descs(:) !< The descriptions for each combination of units + integer, intent(in) :: weights(:) !< A list of the weights for each described combination + character(len=*), intent(in) :: key(:) !< The key for the unit scaling + integer, intent(in) :: scales(:) !< The powers of 2 that give the scaling for each unit in key + integer, optional, intent(in) :: max_powers !< The maximum range of powers of 2 to search for + !! suggestions of better scaling factors, or 0 to avoid + !! suggesting improved factors. + + ! Local variables + integer, dimension(size(key)) :: next_scales, prev_scales, better_scales + character(len=512) :: mesg + character(len=64) :: msg_frag + integer, dimension(size(key), size(weights)) :: list + integer :: verbosity + logical :: same_key + integer :: orig_cost, test_cost, better_cost, prev_cost ! Various squared-weight mismatch costs. + integer :: better_dp ! The absolute change in powers with the better estimate. + integer :: ndims, ns, m, n, i, p, itt, max_itt, max_pow + + call assert((size(scales) == size(key)), "check_scaling_factors: Mismatched scales and key sizes.") + call assert((size(descs) == size(weights)), "check_scaling_factors: Mismatched descs and weights.") + + verbosity = MOM_get_verbosity() + ! Skip the rest of this routine if it would not write anything out. + if (verbosity < 3) return + + ndims = size(key) + ns = size(weights) + max_pow = 0 ; if (present(max_powers)) max_pow = max_powers + + list(:,:) = 0 + do n=1,ns + call encode_dim_powers(descs(n), key, list(:,n)) + enddo + + if (verbosity >= 7) then + write(mesg, '(I8)') ns + call MOM_mesg(trim(component)//": Extracted "//trim(adjustl(mesg))//" unit combinations from the list.") + mesg = "Dim Key: [" + do i=1,ndims ; mesg = trim(mesg)//" "//trim(key(i)) ; enddo + mesg = trim(mesg)//"]:" + call MOM_mesg(mesg) + do n=1,ns + call MOM_mesg(trim(component)//": Extracted ["//trim(int_array_msg(list(:,n)))//"] from "//trim(descs(n))) + enddo + + do n=1,ns ; do m=1,n-1 + same_key = .true. + do i=1,ndims ; if (list(i,n) /= list(i,m)) same_key = .false. ; enddo + if (same_key) then + call MOM_mesg(trim(component)//": The same powers occur for "//& + trim(descs(n))//" and "//trim(descs(m))//"." ) + endif + enddo ; enddo + endif + + orig_cost = non_unique_scales(scales, list, descs, weights, silent=(verbosity<4)) + + max_itt = 3*ndims ! Do up to 3 iterations for each rescalable dimension. + if (orig_cost /= 0) then + call MOM_mesg(trim(component)//": The dimensional scaling factors are not unique.") + prev_cost = orig_cost + prev_scales(:) = scales(:) + do itt=1,max_itt + ! Iterate to find a better solution. + better_scales(:) = prev_scales(:) + better_cost = prev_cost + better_dp = 0 + do i=1,ndims + if (scales(i) == 0) cycle ! DO not optimize unscaled dimensions. + next_scales(:) = prev_scales(:) + do p=-max_pow,max_pow + if ((p==0) .or. (p==prev_scales(i))) cycle + next_scales(i) = p + test_cost = non_unique_scales(next_scales, list, descs, weights, silent=.true.) + if ((test_cost < better_cost) .or. & + ((test_cost == better_cost) .and. (abs(p-prev_scales(i)) < better_dp))) then + ! This is a better scaling or has the same weighted mismatches but smaller + ! changes in rescaling factors, so it could be the next guess. + better_scales(:) = next_scales(:) + better_cost = test_cost + better_dp = abs(p - prev_scales(i)) + endif + enddo + enddo + if (better_cost < prev_cost) then + ! Store the new best guess and try again. + prev_scales(:) = better_scales(:) + prev_cost = better_cost + else ! No further optimization is possible. + exit + endif + if (better_cost == 0) exit + if (verbosity >= 7) then + write(mesg, '("Iteration ",I2," scaling cost reduced from ",I8," with original scales to ", I8)') & + itt, orig_cost, better_cost + call MOM_mesg(trim(component)//": "//trim(mesg)//" with revised scaling factors.") + endif + enddo + if (prev_cost < orig_cost) then + test_cost = non_unique_scales(prev_scales, list, descs, weights, silent=(verbosity<4)) + mesg = trim(component)//": Suggested improved scales: " + do i=1,ndims ; if ((prev_scales(i) /= scales(i)) .and. (scales(i) /= 0)) then + write(msg_frag, '(I3)') prev_scales(i) + mesg = trim(mesg)//" "//trim(key(i))//"_RESCALE_POWER = "//trim(adjustl(msg_frag)) + endif ; enddo + call MOM_mesg(mesg) + + write(mesg, '(I8)') orig_cost + write(msg_frag, '(I8)') test_cost + mesg = trim(component)//": Scaling overlaps reduced from "//trim(adjustl(mesg))//& + " with original scales to "//trim(adjustl(msg_frag))//" with suggested scales." + call MOM_mesg(mesg) + endif + + endif + +end subroutine check_scaling_uniqueness + +!> Convert a unit scaling descriptor into an array of the dimensions of powers given in the key +subroutine encode_dim_powers(scaling, key, dim_powers) + + character(len=*), intent(in) :: scaling !< The unit description that will be converted + character(len=*), dimension(:), intent(in) :: key(:) !< The key for the unit scaling + integer, dimension(size(key)), intent(out) :: dim_powers !< The dimensions in scaling of each + !! element of they key. + + ! Local variables + character(len=:), allocatable :: actstr ! The full active remaining string to be parsed. + character(len=:), allocatable :: fragment ! The space-delimited fragment being parsed. + character(len=:), allocatable :: dimnm ! The probable dimension name + character(len=11) :: numbers ! The list of characters that could make up the exponent. + ! character(len=128) :: mesg + integer :: istart, iend, ieq, ief, ipow ! Positions in strings. + integer :: dp ! The power for this dimension. + integer :: ndim ! The number of dimensional scaling factors to consider. + integer :: n + + dim_powers(:) = 0 + + iend = index(scaling, "~>") - 1 + if (iend < 1) return + + ! Parse the key. + ndim = size(key) + numbers = "-0123456789" + + ! Strip away any leading square brace. + istart = index(scaling(:iend), "[") + 1 + ! If there is an "=" in the string, start after this. + ieq = index(scaling(istart:iend), "=", back=.true.) + if (ieq > 0) istart = istart + ieq + + ! Set up the active string to work on. + actstr = trim(adjustl(scaling(istart:iend))) + do ! Loop over each of the elements in the unit scaling descriptor. + if (len_trim(actstr) == 0) exit + ief = index(actstr, " ") - 1 + if (ief <= 0) ief = len_trim(actstr) + fragment = actstr(:ief) + ipow = scan(fragment, "-") + if (ipow == 0) ipow = scan(fragment, numbers) + + if (ipow == 0) then ! There is no exponent + dimnm = fragment + dp = 1 + ! call MOM_mesg("Parsing powerless fragment "//trim(fragment)//" from "//trim(scaling)) + else + if (verify(fragment(ipow:), numbers) == 0) then + read(fragment(ipow:),*) dp + dimnm = fragment(:ipow-1) + ! write(mesg, '(I3)') dp + ! call MOM_mesg("Parsed fragment "//trim(fragment)//" from "//trim(scaling)//& + ! " as "//trim(dimnm)//trim(adjustl(mesg))) + else + dimnm = fragment + dp = 1 + ! call MOM_mesg("Unparsed fragment "//trim(fragment)//" from "//trim(scaling)) + endif + endif + + do n=1,ndim + if (trim(dimnm) == trim(key(n))) then + dim_powers(n) = dim_powers(n) + dp + exit + endif + enddo + + ! Remove the leading fragment that has been parsed from actstr + actstr = trim(adjustl(actstr(ief+1:))) + enddo + +end subroutine encode_dim_powers + +!> Find the integer power of two that describe each of the scaling factors, or return 0 for +!! scaling factors that are not exceptionally close to an integer power of 2. +subroutine scales_to_powers(scale, pow2) + real, intent(in) :: scale(:) !< The scaling factor for each dimension + integer, intent(out) :: pow2(:) !< The exact powers of 2 for each scale, or 0 for non-exact powers of 2. + + real :: log2_sc ! The log base 2 of an element of scale + integer :: n, ndim + + ndim = size(scale) + + ! Find the integer power of two for the scaling factors, but skip the analysis of any factors + ! that are not close enough to being integer powers of 2. + do n=1,ndim + if (abs(scale(n)) > 0.0) then + log2_sc = log(abs(scale(n))) / log(2.0) + else + log2_sc = 0.0 + endif + if (abs(log2_sc - nint(log2_sc)) < 1.0e-6) then + ! This is close to an integer power of two. + pow2(n) = nint(log2_sc) + else + ! This is not being scaled by an integer power of 2, so return 0. + pow2(n) = 0 + endif + enddo + +end subroutine scales_to_powers + +!> Determine from the list of scaling factors and the unit combinations that are in use whether +!! all these combinations scale uniquely. +integer function non_unique_scales(scales, list, descs, weights, silent) + integer, intent(in) :: scales(:) !< The power of 2 that gives the scaling factor for each dimension + integer, intent(in) :: list(:,:) !< A list of the integers for each scaling + character(len=*), intent(in) :: descs(:) !< The unit descriptions that have been converted + integer, intent(in) :: weights(:) !< A list of the weights for each scaling + logical, optional, intent(in) :: silent !< If present and true, do not write any output. + + ! Local variables + integer, dimension(size(weights)) :: res_pow ! The net rescaling power for each combination. + integer, dimension(size(weights)) :: wt_merge ! The merged weights of scaling factors with common powers + ! for the dimensions being tested. + logical :: same_key, same_scales, verbose + character(len=256) :: mesg + integer :: nonzero_count ! The number of non-zero scaling factors + integer :: ndim ! The number of dimensional scaling factors to work with + integer :: i, n, m, ns + + non_unique_scales = -9999 ! Set return value to a _dummy_ value + + verbose = .true. ; if (present(silent)) verbose = .not.silent + + ndim = size(scales) + ns = size(descs) + call assert((size(scales) == size(list, 1)), "non_unique_scales: Mismatched scales and list sizes.") + call assert((size(descs) == size(list, 2)), "non_unique_scales: Mismatched descs and list sizes.") + call assert((size(descs) == size(weights)), "non_unique_scales: Mismatched descs and weights.") + + ! Return .true. if all scaling powers are 0, or there is only one scaling factor in use. + nonzero_count = 0 ; do n=1,ndim ; if (scales(n) /= 0) nonzero_count = nonzero_count + 1 ; enddo + if (nonzero_count <= 1) return + + ! Figure out which unit combinations are unique for the set of dimensions and scaling factors + ! that are being tested, and combine the weights for scaling factors. + wt_merge(:) = weights(:) + do n=1,ns ; do m=1,n-1 + same_key = .true. + same_scales = .true. + do i=1,ndim + if (list(i,n) /= list(i,m)) same_key = .false. + if ((scales(i) /= 0) .and. (list(i,n) /= list(i,m))) same_scales = .false. + enddo + if (same_key .or. same_scales) then + if (wt_merge(n) > wt_merge(m)) then + wt_merge(n) = wt_merge(n) + wt_merge(m) + wt_merge(m) = 0 + else + wt_merge(m) = wt_merge(m) + wt_merge(n) + wt_merge(n) = 0 + endif + endif + if (wt_merge(n) == 0) exit ! Go to the next value of n. + enddo ; enddo + + do n=1,ns + res_pow(n) = 0 + do i=1,ndim + res_pow(n) = res_pow(n) + scales(i) * list(i,n) + enddo + enddo + + ! Determine the weighted cost of non-unique scaling factors. + non_unique_scales = 0 + do n=1,ns ; if (wt_merge(n) > 0) then ; do m=1,n-1 ; if (wt_merge(m) > 0) then + if (res_pow(n) == res_pow(m)) then + ! Use the product of the weights as the cost, as this should be vaguely proportional to + ! the likelihood that these factors would be combined in an expression. + non_unique_scales = min(non_unique_scales + wt_merge(n) * wt_merge(m), 99999999) + if (verbose) then + write(mesg, '(I8)') res_pow(n) + call MOM_mesg("The factors "//trim(descs(n))//" and "//trim(descs(m))//" both scale to "//& + trim(adjustl(mesg))//" for the given powers.") + + ! call MOM_mesg("Powers ["//trim(int_array_msg(list(:,n)))//"] and ["//& + ! trim(int_array_msg(list(:,m)))//"] with rescaling by ["//& + ! trim(int_array_msg(scales))//"]") + endif + endif + endif ; enddo ; endif ; enddo + +end function non_unique_scales + +!> Return a string the elements of an array of integers +function int_array_msg(array) + integer, intent(in) :: array(:) !< The array whose values are to be written. + character(len=16*size(array)) :: int_array_msg + + character(len=12) :: msg_frag + integer :: i, ni + ni = size(array) + + int_array_msg = "" + if (ni < 1) return + + do i=1,ni + write(msg_frag, '(I8)') array(i) + msg_frag = adjustl(msg_frag) + if (i == 1) then + int_array_msg = trim(msg_frag) + else + int_array_msg = trim(int_array_msg)//" "//trim(msg_frag) + endif + enddo +end function int_array_msg + +end module MOM_unique_scales diff --git a/framework/MOM_unit_scaling.F90 b/framework/MOM_unit_scaling.F90 new file mode 100644 index 0000000000..868352102e --- /dev/null +++ b/framework/MOM_unit_scaling.F90 @@ -0,0 +1,262 @@ +!> Provides a transparent unit rescaling type to facilitate dimensional consistency testing +module MOM_unit_scaling + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type + +implicit none ; private + +! 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, T, R and Q, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the rescaled +! combination is a nondimensional variable, the notation would be "a slope [Z L-1 ~> nondim]", +! but if (as the case for the variables here), the rescaled combination is exactly 1, the right +! notation would be something like "a dimensional scaling factor [Z m-1 ~> 1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +public unit_scaling_init, unit_no_scaling_init, unit_scaling_end, fix_restart_unit_scaling + +!> Describes various unit conversion factors +type, public :: unit_scale_type + real :: m_to_Z !< A constant that translates distances in meters to the units of depth [Z m-1 ~> 1] + real :: Z_to_m !< A constant that translates distances in the units of depth to meters [m Z-1 ~> 1] + real :: m_to_L !< A constant that translates lengths in meters to the units of horizontal lengths [L m-1 ~> 1] + real :: L_to_m !< A constant that translates lengths in the units of horizontal lengths to meters [m L-1 ~> 1] + real :: s_to_T !< A constant that translates time intervals in seconds to the units of time [T s-1 ~> 1] + real :: T_to_s !< A constant that translates the units of time to seconds [s T-1 ~> 1] + real :: R_to_kg_m3 !< A constant that translates the units of density to kilograms per meter cubed [kg m-3 R-1 ~> 1] + real :: kg_m3_to_R !< A constant that translates kilograms per meter cubed to the units of density [R m3 kg-1 ~> 1] + real :: Q_to_J_kg !< A constant that translates the units of enthalpy to Joules per kilogram [J kg-1 Q-1 ~> 1] + real :: J_kg_to_Q !< A constant that translates Joules per kilogram to the units of enthalpy [Q kg J-1 ~> 1] + real :: C_to_degC !< A constant that translates the units of temperature to degrees Celsius [degC C-1 ~> 1] + real :: degC_to_C !< A constant that translates degrees Celsius to the units of temperature [C degC-1 ~> 1] + real :: S_to_ppt !< A constant that translates the units of salinity to parts per thousand [ppt S-1 ~> 1] + real :: ppt_to_S !< A constant that translates parts per thousand to the units of salinity [S ppt-1 ~> 1] + + ! These are useful combinations of the fundamental scale conversion factors above. + real :: Z_to_L !< Convert vertical distances to lateral lengths [L Z-1 ~> 1] + real :: L_to_Z !< Convert lateral lengths to vertical distances [Z L-1 ~> 1] + real :: L_T_to_m_s !< Convert lateral velocities from L T-1 to m s-1 [T m L-1 s-1 ~> 1] + real :: m_s_to_L_T !< Convert lateral velocities from m s-1 to L T-1 [L s T-1 m-1 ~> 1] + real :: L_T2_to_m_s2 !< Convert lateral accelerations from L T-2 to m s-2 [L s2 T-2 m-1 ~> 1] + real :: Z2_T_to_m2_s !< Convert vertical diffusivities from Z2 T-1 to m2 s-1 [T m2 Z-2 s-1 ~> 1] + real :: m2_s_to_Z2_T !< Convert vertical diffusivities from m2 s-1 to Z2 T-1 [Z2 s T-1 m-2 ~> 1] + real :: W_m2_to_QRZ_T !< Convert heat fluxes from W m-2 to Q R Z T-1 [Q R Z m2 T-1 W-1 ~> 1] + real :: QRZ_T_to_W_m2 !< Convert heat fluxes from Q R Z T-1 to W m-2 [W T Q-1 R-1 Z-1 m-2 ~> 1] + ! Not used enough: real :: kg_m2_to_RZ !< Convert mass loads from kg m-2 to R Z [R Z m2 kg-1 ~> 1] + real :: RZ_to_kg_m2 !< Convert mass loads from R Z to kg m-2 [kg R-1 Z-1 m-2 ~> 1] + real :: kg_m2s_to_RZ_T !< Convert mass fluxes from kg m-2 s-1 to R Z T-1 [R Z m2 s T-1 kg-1 ~> 1] + real :: RZ_T_to_kg_m2s !< Convert mass fluxes from R Z T-1 to kg m-2 s-1 [T kg R-1 Z-1 m-2 s-1 ~> 1] + real :: RZ3_T3_to_W_m2 !< Convert turbulent kinetic energy fluxes from R Z3 T-3 to W m-2 [W T3 R-1 Z-3 m-2 ~> 1] + real :: W_m2_to_RZ3_T3 !< Convert turbulent kinetic energy fluxes from W m-2 to R Z3 T-3 [R Z3 m2 T-3 W-1 ~> 1] + real :: RL2_T2_to_Pa !< Convert pressures from R L2 T-2 to Pa [Pa T2 R-1 L-2 ~> 1] + real :: RLZ_T2_to_Pa !< Convert wind stresses from R L Z T-2 to Pa [Pa T2 R-1 L-1 Z-1 ~> 1] + real :: Pa_to_RL2_T2 !< Convert pressures from Pa to R L2 T-2 [R L2 T-2 Pa-1 ~> 1] + real :: Pa_to_RLZ_T2 !< Convert wind stresses from Pa to R L Z T-2 [R L Z T-2 Pa-1 ~> 1] + + ! These are no longer used for changing scaling across restarts. + real :: m_to_Z_restart = 1.0 !< A copy of the m_to_Z that is used in restart files. + real :: m_to_L_restart = 1.0 !< A copy of the m_to_L that is used in restart files. + real :: s_to_T_restart = 1.0 !< A copy of the s_to_T that is used in restart files. + real :: kg_m3_to_R_restart = 1.0 !< A copy of the kg_m3_to_R that is used in restart files. + real :: J_kg_to_Q_restart = 1.0 !< A copy of the J_kg_to_Q that is used in restart files. +end type unit_scale_type + +contains + +!> Allocates and initializes the ocean model unit scaling type +subroutine unit_scaling_init( param_file, US ) + type(param_file_type), intent(in) :: param_file !< Parameter file handle/type + type(unit_scale_type), pointer :: US !< A dimensional unit scaling type + + ! This routine initializes a unit_scale_type structure (US). + + ! Local variables + integer :: Z_power, L_power, T_power, R_power, Q_power, C_power, S_power + real :: Z_rescale_factor, L_rescale_factor, T_rescale_factor, R_rescale_factor, Q_rescale_factor + real :: C_rescale_factor, S_rescale_factor + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=16) :: mdl = "MOM_unit_scaling" + + if (associated(US)) call MOM_error(FATAL, & + 'unit_scaling_init: called with an associated US pointer.') + allocate(US) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, & + "Parameters for doing unit scaling of variables.", debugging=.true.) + call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of depths and heights. Valid values range from -300 to 300.", & + default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of lateral distances. Valid values range from -300 to 300.", & + default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of time. Valid values range from -300 to 300.", & + default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of density. Valid values range from -300 to 300.", & + default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of heat content. Valid values range from -300 to 300.", & + default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "C_RESCALE_POWER", C_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of temperature. Valid values range from -300 to 300.", & + default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "S_RESCALE_POWER", S_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of salinity. Valid values range from -300 to 300.", & + default=0, debuggingParam=.true.) + + if (abs(Z_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "Z_RESCALE_POWER is outside of the valid range of -300 to 300.") + if (abs(L_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "L_RESCALE_POWER is outside of the valid range of -300 to 300.") + if (abs(T_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "T_RESCALE_POWER is outside of the valid range of -300 to 300.") + if (abs(R_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "R_RESCALE_POWER is outside of the valid range of -300 to 300.") + if (abs(Q_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "Q_RESCALE_POWER is outside of the valid range of -300 to 300.") + if (abs(C_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "C_RESCALE_POWER is outside of the valid range of -300 to 300.") + if (abs(S_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "S_RESCALE_POWER is outside of the valid range of -300 to 300.") + + Z_rescale_factor = 1.0 + if (Z_power /= 0) Z_rescale_factor = 2.0**Z_power + US%Z_to_m = 1.0 * Z_rescale_factor + US%m_to_Z = 1.0 / Z_rescale_factor + + L_rescale_factor = 1.0 + if (L_power /= 0) L_rescale_factor = 2.0**L_power + US%L_to_m = 1.0 * L_rescale_factor + US%m_to_L = 1.0 / L_rescale_factor + + T_rescale_factor = 1.0 + if (T_power /= 0) T_rescale_factor = 2.0**T_power + US%T_to_s = 1.0 * T_rescale_factor + US%s_to_T = 1.0 / T_rescale_factor + + R_rescale_factor = 1.0 + if (R_power /= 0) R_rescale_factor = 2.0**R_power + US%R_to_kg_m3 = 1.0 * R_rescale_factor + US%kg_m3_to_R = 1.0 / R_rescale_factor + + Q_Rescale_factor = 1.0 + if (Q_power /= 0) Q_Rescale_factor = 2.0**Q_power + US%Q_to_J_kg = 1.0 * Q_Rescale_factor + US%J_kg_to_Q = 1.0 / Q_Rescale_factor + + C_Rescale_factor = 1.0 + if (C_power /= 0) C_Rescale_factor = 2.0**C_power + US%C_to_degC = 1.0 * C_Rescale_factor + US%degC_to_C = 1.0 / C_Rescale_factor + + S_Rescale_factor = 1.0 + if (S_power /= 0) S_Rescale_factor = 2.0**S_power + US%S_to_ppt = 1.0 * S_Rescale_factor + US%ppt_to_S = 1.0 / S_Rescale_factor + + call set_unit_scaling_combos(US) +end subroutine unit_scaling_init + +!> Allocates and initializes the ocean model unit scaling type to unscaled values. +subroutine unit_no_scaling_init(US) + type(unit_scale_type), pointer :: US !< A dimensional unit scaling type + + if (associated(US)) call MOM_error(FATAL, & + 'unit_scaling_init: called with an associated US pointer.') + allocate(US) + + US%Z_to_m = 1.0 ; US%m_to_Z = 1.0 + US%L_to_m = 1.0 ; US%m_to_L = 1.0 + US%T_to_s = 1.0 ; US%s_to_T = 1.0 + US%R_to_kg_m3 = 1.0 ; US%kg_m3_to_R = 1.0 + US%Q_to_J_kg = 1.0 ; US%J_kg_to_Q = 1.0 + US%C_to_degC = 1.0 ; US%degC_to_C = 1.0 + US%S_to_ppt = 1.0 ; US%ppt_to_S = 1.0 + + call set_unit_scaling_combos(US) +end subroutine unit_no_scaling_init + +!> This subroutine sets useful combinations of the fundamental scale conversion factors +!! in the unit scaling type. +subroutine set_unit_scaling_combos(US) + type(unit_scale_type), intent(inout) :: US !< A dimensional unit scaling type + + ! Convert vertical to horizontal length scales and the reverse: + US%Z_to_L = US%Z_to_m * US%m_to_L + US%L_to_Z = US%L_to_m * US%m_to_Z + ! Horizontal velocities: + US%L_T_to_m_s = US%L_to_m * US%s_to_T + US%m_s_to_L_T = US%m_to_L * US%T_to_s + ! Horizontal accelerations: + US%L_T2_to_m_s2 = US%L_to_m * US%s_to_T**2 + ! It does not look like US%m_s2_to_L_T2 would be used, so it does not exist. + ! Vertical diffusivities and viscosities: + US%Z2_T_to_m2_s = US%Z_to_m**2 * US%s_to_T + US%m2_s_to_Z2_T = US%m_to_Z**2 * US%T_to_s + ! Column mass loads: + US%RZ_to_kg_m2 = US%R_to_kg_m3 * US%Z_to_m + ! It does not seem like US%kg_m2_to_RZ would be used enough in MOM6 to justify its existence. + ! Vertical mass fluxes: + US%kg_m2s_to_RZ_T = US%kg_m3_to_R * US%m_to_Z * US%T_to_s + US%RZ_T_to_kg_m2s = US%R_to_kg_m3 * US%Z_to_m * US%s_to_T + ! Turbulent kinetic energy vertical fluxes: + US%RZ3_T3_to_W_m2 = US%R_to_kg_m3 * US%Z_to_m**3 * US%s_to_T**3 + US%W_m2_to_RZ3_T3 = US%kg_m3_to_R * US%m_to_Z**3 * US%T_to_s**3 + ! Vertical heat fluxes: + US%W_m2_to_QRZ_T = US%J_kg_to_Q * US%kg_m3_to_R * US%m_to_Z * US%T_to_s + US%QRZ_T_to_W_m2 = US%Q_to_J_kg * US%R_to_kg_m3 * US%Z_to_m * US%s_to_T + ! Pressures: + US%RL2_T2_to_Pa = US%R_to_kg_m3 * US%L_T_to_m_s**2 + US%Pa_to_RL2_T2 = US%kg_m3_to_R * US%m_s_to_L_T**2 + ! Wind stresses: + US%RLZ_T2_to_Pa = US%R_to_kg_m3 * US%L_T_to_m_s**2 * US%Z_to_L + US%Pa_to_RLZ_T2 = US%kg_m3_to_R * US%m_s_to_L_T**2 * US%L_to_Z + +end subroutine set_unit_scaling_combos + +!> Set the unit scaling factors for output to restart files to the unit scaling +!! factors for this run. +subroutine fix_restart_unit_scaling(US, unscaled) + type(unit_scale_type), intent(inout) :: US !< A dimensional unit scaling type + logical, optional, intent(in) :: unscaled !< If true, set the restart factors as though the + !! model would be unscaled, which is appropriate if the + !! scaling is undone when writing a restart file. + + US%m_to_Z_restart = 1.0 ! US%m_to_Z + US%m_to_L_restart = 1.0 ! US%m_to_L + US%s_to_T_restart = 1.0 ! US%s_to_T + US%kg_m3_to_R_restart = 1.0 ! US%kg_m3_to_R + US%J_kg_to_Q_restart = 1.0 ! US%J_kg_to_Q + + if (present(unscaled)) then ; if (unscaled) then + US%m_to_Z_restart = 1.0 + US%m_to_L_restart = 1.0 + US%s_to_T_restart = 1.0 + US%kg_m3_to_R_restart = 1.0 + US%J_kg_to_Q_restart = 1.0 + endif ; endif + +end subroutine fix_restart_unit_scaling + +!> Deallocates a unit scaling structure. +subroutine unit_scaling_end( US ) + type(unit_scale_type), pointer :: US !< A dimensional unit scaling type + + deallocate( US ) + +end subroutine unit_scaling_end + +end module MOM_unit_scaling diff --git a/framework/MOM_unit_testing.F90 b/framework/MOM_unit_testing.F90 new file mode 100644 index 0000000000..312914933c --- /dev/null +++ b/framework/MOM_unit_testing.F90 @@ -0,0 +1,306 @@ +module MOM_unit_testing + +use posix, only : chmod +use posix, only : sigsetjmp +use posix, only : sigjmp_buf + +use MOM_coms, only : num_PEs, sync_PEs +use MOM_error_handler, only : is_root_pe +use MOM_error_handler, only : disable_fatal_errors +use MOM_error_handler, only : enable_fatal_errors + +implicit none ; private + +public :: string +public :: create_test_file +public :: delete_test_file +public :: TestSuite + + +!> String container type +type :: string + character(len=:), allocatable :: s + !< Internal character array of string +end type string + + +!> String constructor +interface string + module procedure init_string_char + module procedure init_string_int +end interface string + + +!> A generalized instance of a unit test function +type :: UnitTest + private + procedure(), nopass, pointer :: proc => null() + !< Unit test function/subroutine + procedure(), nopass, pointer :: cleanup => null() + !< Cleanup function to be run after proc + character(len=:), allocatable :: name + !< Unit test name (usually set to name of proc) + logical :: is_fatal + !< True if proc() is expected to fail +contains + procedure :: run => run_unit_test + !< Run the unit test function, proc +end type UnitTest + + +!> Unit test constructor +interface UnitTest + module procedure create_unit_test_basic + module procedure create_unit_test_full +end interface UnitTest + + +!> Collection of unit tests +type :: TestSuite + private + type(UnitTestNode), pointer :: head => null() + !< Head of the unit test linked list + type(UnitTestNode), pointer :: tail => null() + !< Tail of the unit test linked list (pre-allocated and unconfigured) + + ! Public API + procedure(), nopass, pointer, public :: cleanup => null() + !< Default cleanup function for unit tests in suite +contains + private + procedure :: add_basic => add_unit_test_basic + !< Add a unit test without a cleanup function + procedure :: add_full => add_unit_test_full + !< Add a unit test with an explicit cleanup function + generic, public :: add => add_basic, add_full + !< Add a unit test to the test suite + procedure, public :: run => run_test_suite + !< Run all unit tests in the suite +end type TestSuite + + +!> TestSuite constructor +interface TestSuite + module procedure create_test_suite +end interface TestSuite + + +!> UnitTest node of TestSuite's linked list +type :: UnitTestNode + private + type(UnitTest), pointer :: test => null() + !< Node contents + type(UnitTestNode), pointer :: next => null() + !< Pointer to next node in list +end type UnitTestNode + +contains + +!> Return a new unit test without a cleanup function +function create_unit_test_basic(proc, name, fatal) result(test) + procedure() :: proc + !< Subroutine which defines the unit test + character(len=*), intent(in) :: name + !< Name of the unit test + logical, intent(in), optional :: fatal + !< True if the test is expected to raise a FATAL error + type(UnitTest) :: test + + procedure(), pointer :: cleanup + cleanup => null() + + test = create_unit_test_full(proc, name, fatal, cleanup) +end function create_unit_test_basic + + +!> Return a new unit test with an explicit cleanup function +function create_unit_test_full(proc, name, fatal, cleanup) result(test) + procedure() :: proc + !< Subroutine which defines the unit test + character(len=*), intent(in) :: name + !< Name of the unit test + logical, optional :: fatal + !< True if the test is expected to raise a FATAL error + procedure() :: cleanup + !< Cleanup subroutine, called after test + type(UnitTest) :: test + + test%proc => proc + test%name = name + test%is_fatal = .false. + if (present(fatal)) test%is_fatal = fatal + test%cleanup => cleanup +end function create_unit_test_full + + +!> Launch a unit test with a custom cleanup procedure +subroutine run_unit_test(test) + class(UnitTest), intent(in) :: test + + type(sigjmp_buf) :: env + integer :: rc + + call sync_PEs + + ! FIXME: Some FATAL tests under MPI are unable to recover after jumpback, so + ! we disable these tests for now. + if (test%is_fatal .and. num_PEs() > 1) return + + if (test%is_fatal) then + rc = sigsetjmp(env, 1) + if (rc == 0) then + call disable_fatal_errors(env) + call test%proc + endif + call enable_fatal_errors + else + call test%proc + endif + + if (associated(test%cleanup)) call test%cleanup +end subroutine run_unit_test + + +!> Return a new test suite +function create_test_suite() result(suite) + type(TestSuite) :: suite + + ! Setup the head node, but do not populate it + allocate(suite%head) + suite%tail => suite%head +end function create_test_suite + + +subroutine add_unit_test_basic(suite, test, name, fatal) + class(TestSuite), intent(inout) :: suite + procedure() :: test + character(len=*), intent(in) :: name + logical, intent(in), optional :: fatal + + procedure(), pointer :: cleanup + + cleanup => null() + if (associated(suite%cleanup)) cleanup => suite%cleanup + + call add_unit_test_full(suite, test, name, fatal, cleanup) +end subroutine add_unit_test_basic + + +subroutine add_unit_test_full(suite, test, name, fatal, cleanup) + class(TestSuite), intent(inout) :: suite + procedure() :: test + character(len=*), intent(in) :: name + procedure() :: cleanup + logical, intent(in), optional :: fatal + + type(UnitTest), pointer :: utest + type(UnitTestNode), pointer :: node + + ! Populate the current tail + allocate(utest) + utest = UnitTest(test, name, fatal, cleanup) + suite%tail%test => utest + + ! Create and append the new (empty) node, and update the tail + allocate(node) + suite%tail%next => node + suite%tail => node +end subroutine add_unit_test_full + + +subroutine run_test_suite(suite) + class(TestSuite), intent(in) :: suite + + type(UnitTestNode), pointer :: node + + node => suite%head + do while(associated(node%test)) + ! TODO: Capture FMS stdout/stderr + print '(/a)', "=== "//node%test%name + + call node%test%run + if (associated(node%test%cleanup)) call node%test%cleanup + + node => node%next + enddo +end subroutine run_test_suite + + +!> Initialize string with a character array. +function init_string_char(c) result(str) + character(len=*), dimension(:), intent(in) :: c + !< List of character arrays + type(string), dimension(size(c)) :: str + !< String output + + integer :: i + + do i = 1, size(c) + str(i)%s = c(i) + enddo +end function init_string_char + + +!> Convert an integer to a string +function init_string_int(n) result(str) + integer, intent(in) :: n + !< Integer input + type(string) :: str + !< String output + + ! TODO: Estimate this with integer arithmetic + character(1 + floor(log10(real(abs(n)))) + (1 - sign(1, n))/2) :: chr + + write(chr, '(i0)') n + str = string(chr) +end function init_string_int + + +!> Create a text file for unit testing +subroutine create_test_file(filename, lines, mode) + character(len=*), intent(in) :: filename + !< Name of file to be created + type(string), intent(in), optional :: lines(:) + !< list of strings to write to file + integer, optional, intent(in) :: mode + !< Permissions of new file + + integer :: param_unit + integer :: i + integer :: rc + logical :: sync + + if (is_root_PE()) then + open(newunit=param_unit, file=filename, status='replace') + if (present(lines)) then + do i = 1, size(lines) + write(param_unit, '(a)') lines(i)%s + enddo + endif + close(param_unit) + if (present(mode)) rc = chmod(filename, mode) + endif + call sync_PEs +end subroutine create_test_file + + +!> Delete a file created during testing +subroutine delete_test_file(filename) + character(len=*), intent(in) :: filename + !< Name of file to be deleted + + logical :: is_file, is_open + integer :: io_unit + + if (is_root_PE()) then + inquire(file=filename, exist=is_file, opened=is_open, number=io_unit) + + if (is_file) then + if (.not. is_open) open(newunit=io_unit, file=filename) + close(io_unit, status='delete') + endif + endif + call sync_PEs +end subroutine delete_test_file + +end module MOM_unit_testing diff --git a/framework/MOM_write_cputime.F90 b/framework/MOM_write_cputime.F90 new file mode 100644 index 0000000000..025dcad2ac --- /dev/null +++ b/framework/MOM_write_cputime.F90 @@ -0,0 +1,227 @@ +!> A module to monitor the overall CPU time used by MOM6 and project when to stop the model +module MOM_write_cputime + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : sum_across_PEs, num_pes +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe +use MOM_io, only : open_ASCII_file, close_file, APPEND_FILE, WRITEONLY_FILE +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_time_manager, only : time_type, get_time, operator(>) + +implicit none ; private + +public write_cputime, MOM_write_cputime_init, MOM_write_cputime_end, write_cputime_start_clock + +!----------------------------------------------------------------------- + +integer :: CLOCKS_PER_SEC = 1000 !< The number of clock cycles per second, used by the system clock +integer :: MAX_TICKS = 1000 !< The number of ticks per second, used by the system clock + +!> A control structure that regulates the writing of CPU time +type, public :: write_cputime_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + real :: maxcpu !< The maximum amount of CPU time per processor + !! for which MOM should run before saving a restart + !! file and quitting with a return value that + !! indicates that further execution is required to + !! complete the simulation [wall-clock seconds]. + type(time_type) :: Start_time !< The start time of the simulation. + !! Start_time is set in MOM_initialization.F90 + real :: startup_cputime !< The CPU time used in the startup phase of the model [clock_cycles]. + real :: prev_cputime = 0.0 !< The last measured CPU time [clock_cycles]. + real :: dn_dcpu_min = -1.0 !< The minimum derivative of timestep with CPU time [steps clock_cycles-1]. + real :: cputime2 = 0.0 !< The accumulated CPU time [clock_cycles]. + integer :: previous_calls = 0 !< The number of times write_CPUtime has been called. + integer :: prev_n = 0 !< The value of n from the last call. + integer :: fileCPU_ascii= -1 !< The unit number of the CPU time file. + character(len=200) :: CPUfile !< The name of the CPU time file. +end type write_cputime_CS + +contains + +!> Evaluate the CPU time returned by SYSTEM_CLOCK at the start of a run +subroutine write_cputime_start_clock(CS) + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous + !! call to MOM_write_cputime_init. + integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK + if (.not.associated(CS)) allocate(CS) + + call SYSTEM_CLOCK(new_cputime, CLOCKS_PER_SEC, MAX_TICKS) + CS%prev_cputime = new_cputime +end subroutine write_cputime_start_clock + +!> Initialize the MOM_write_cputime module. +subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + character(len=*), intent(in) :: directory !< The directory where the CPU time file goes. + type(time_type), intent(in) :: Input_start_time !< The start model time of the simulation. + type(write_cputime_CS), pointer :: CS !< A pointer that may be set to point to the + !! control structure for this module. + + ! Local variables + integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = 'MOM_write_cputime' ! This module's name. + logical :: all_default ! If true, all parameters are using their default values. + + if (.not.associated(CS)) then + allocate(CS) + call SYSTEM_CLOCK(new_cputime, CLOCKS_PER_SEC, MAX_TICKS) + CS%prev_cputime = new_cputime + endif + + CS%initialized = .true. + + ! Read all relevant parameters and write them to the model log. + + ! Determine whether all parameters are set to their default values. + call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, units="wall-clock seconds", default=-1.0, do_not_log=.true.) + call get_param(param_file, mdl, "CPU_TIME_FILE", CS%CPUfile, default="CPU_stats", do_not_log=.true.) + all_default = (CS%maxcpu == -1.0) .and. (trim(CS%CPUfile) == trim("CPU_stats")) + + call log_version(param_file, mdl, version, "", all_default=all_default) + call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, & + "The maximum amount of cpu time per processor for which "//& + "MOM should run before saving a restart file and "//& + "quitting with a return value that indicates that a "//& + "further run is required to complete the simulation. "//& + "If automatic restarts are not desired, use a negative "//& + "value for MAXCPU. MAXCPU has units of wall-clock "//& + "seconds, so the actual CPU time used is larger by a "//& + "factor of the number of processors used.", & + units="wall-clock seconds", default=-1.0) + call get_param(param_file, mdl, "CPU_TIME_FILE", CS%CPUfile, & + "The file into which CPU time is written.",default="CPU_stats") + CS%CPUfile = trim(directory)//trim(CS%CPUfile) + call log_param(param_file, mdl, "directory/CPU_TIME_FILE", CS%CPUfile) +#ifdef STATSLABEL + CS%CPUfile = trim(CS%CPUfile)//"."//trim(adjustl(STATSLABEL)) +#endif + + CS%Start_time = Input_start_time + +end subroutine MOM_write_cputime_init + +!> Close the MOM_write_cputime module. +subroutine MOM_write_cputime_end(CS) + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous + !! call to MOM_write_cputime_init. + + if (.not.associated(CS)) return + + ! Flush and close the output files. + if (is_root_pe() .and. CS%fileCPU_ascii > 0) then + flush(CS%fileCPU_ascii) + call close_file(CS%fileCPU_ascii) + endif + + deallocate(CS) + +end subroutine MOM_write_cputime_end + +!> This subroutine assesses how much CPU time the model has taken and determines how long the model +!! should be run before it saves a restart file and stops itself. Optionally this may also be used +!! to trigger this module's end routine. +subroutine write_cputime(day, n, CS, nmax, call_end) + type(time_type), intent(inout) :: day !< The current model time. + integer, intent(in) :: n !< The time step number of the current execution. + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous + !! call to MOM_write_cputime_init. + integer, optional, intent(inout) :: nmax !< The number of iterations after which to stop so + !! that the simulation will not run out of CPU time. + logical, optional, intent(in) :: call_end !< If true, also call MOM_write_cputime_end. + + ! Local variables + real :: d_cputime ! The change in CPU time since the last call + ! this subroutine [clock_cycles] + integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK [clock_cycles] + real :: reday ! The time in days, including fractional days [days] + integer :: start_of_day ! The number of seconds since the start of the day + integer :: num_days ! The number of days in the time + + if (.not.associated(CS)) call MOM_error(FATAL, & + "write_energy: Module must be initialized before it is used.") + + if (.not.CS%initialized) call MOM_error(FATAL, & + "write_cputime: Module must be initialized before it is used.") + + call SYSTEM_CLOCK(new_cputime, CLOCKS_PER_SEC, MAX_TICKS) +! The following lines extract useful information even if the clock has rolled +! over, assuming a 32-bit SYSTEM_CLOCK. With more bits, rollover is essentially +! impossible. Negative fluctuations of less than 10 seconds are not interpreted +! as the clock rolling over. This should be unnecessary but is sometimes needed +! on the GFDL SGI/O3k. + if (new_cputime < CS%prev_cputime-(10.0*CLOCKS_PER_SEC)) then + d_cputime = new_cputime - CS%prev_cputime + MAX_TICKS + else + d_cputime = new_cputime - CS%prev_cputime + endif + + call sum_across_PEs(d_cputime) + if (CS%previous_calls == 0) CS%startup_cputime = d_cputime + + CS%cputime2 = CS%cputime2 + d_cputime + + if ((CS%previous_calls >= 1) .and. (CS%maxcpu > 0.0)) then + ! Determine the slowest rate at which time steps are executed. + if ((n > CS%prev_n) .and. (d_cputime > 0.0) .and. & + ((CS%dn_dcpu_min*d_cputime < (n - CS%prev_n)) .or. & + (CS%dn_dcpu_min < 0.0))) & + CS%dn_dcpu_min = (n - CS%prev_n) / d_cputime + if (present(nmax) .and. (CS%dn_dcpu_min >= 0.0)) then + ! Have the model stop itself after 95% of the CPU time has been used. + nmax = n + INT( CS%dn_dcpu_min * & + (0.95*CS%maxcpu * REAL(num_pes())*CLOCKS_PER_SEC - & + (CS%startup_cputime + CS%cputime2)) ) +! write(mesg,*) "Resetting nmax to ",nmax," at day",reday +! call MOM_mesg(mesg) + endif + endif + CS%prev_cputime = new_cputime ; CS%prev_n = n + + call get_time(day, start_of_day, num_days) + reday = REAL(num_days)+ (REAL(start_of_day)/86400.0) + + ! Reopen or create a text output file. + if ((CS%previous_calls == 0) .and. (is_root_pe())) then + if (day > CS%Start_time) then + call open_ASCII_file(CS%fileCPU_ascii, trim(CS%CPUfile), action=APPEND_FILE) + else + call open_ASCII_file(CS%fileCPU_ascii, trim(CS%CPUfile), action=WRITEONLY_FILE) + endif + endif + + if (is_root_pe()) then + if (CS%previous_calls == 0) then + write(CS%fileCPU_ascii, & + '("Startup CPU time: ", F12.3, " sec summed across", I5, " PEs.")') & + (CS%startup_cputime / CLOCKS_PER_SEC), num_pes() + write(CS%fileCPU_ascii,*)" Day, Step number, CPU time, CPU time change" + endif + write(CS%fileCPU_ascii,'(F12.3,", ",I11,", ",F12.3,", ",F12.3)') & + reday, n, (CS%cputime2 / real(CLOCKS_PER_SEC)), & + d_cputime / real(CLOCKS_PER_SEC) + + flush(CS%fileCPU_ascii) + endif + CS%previous_calls = CS%previous_calls + 1 + + if (present(call_end)) then + if (call_end) call MOM_write_cputime_end(CS) + endif + +end subroutine write_cputime + +!> \namespace mom_write_cputime +!! +!! By Robert Hallberg, May 2006. +!! +!! This file contains the subroutine (write_cputime) that writes +!! the summed CPU time across all processors to an output file. In +!! addition, write_cputime estimates how many more time steps can be +!! taken before 95% of the available CPU time is used, so that the +!! model can be checkpointed at that time. + +end module MOM_write_cputime diff --git a/framework/_Diagnostics.dox b/framework/_Diagnostics.dox new file mode 100644 index 0000000000..0be318f580 --- /dev/null +++ b/framework/_Diagnostics.dox @@ -0,0 +1,234 @@ +/*! \page Diagnostics Diagnostics + +\brief Controlling run-time diagnostics and how to add diagnostics to the code + +MOM6 diagnostics are orchestrated via the FMS diag_manager, as for previous versions of MOM. +However, because MOM6 is a general coordinate model, the model native-coordinae output can be less familiar to users of earlier generations of MOM. +To alleviate this problem, MOM6 provides both "native" and "remapped" diagnostics; +the former being diagnostics in the actual model coordinate space, and the latter in user-defined coordinates. + +\section diag_table The "diag_table" + +At run-time, diagnostics are controlled by the input file `diag_table` which is interpreted but the FMS package diag_manager. + +The diag_table file has three kinds of section: Title, File and Field. The title section is mandatory and always the first. +There can be multiple file and field sections, typically either in pairs or grouped in to all files and all fields, +but always with the file section preceding the corresponding field section. + +\subsection diag_table_title Title section + +The first two lines are mandatory and comprise a line with a title and a line with six integers defining a base date against which time will be referenced. + +``` +"My ocean-only test case" +1900 1 1 0 0 0 +``` + + +\subsection diag_table_files File section + +This section defines an arbitrary number of files that will be created. +Each file is limited to a single rate of either sampling or time-averaging. + +``` +"file_name", output_freq, "output_freq_units", file_format, "time_axis_units", "time_axis_name" +``` + +- `file_name` : The name of the file that contains diagnostics at the given frequency (excluding the ".nc" extension). + +- `output_freq` : The period between records in `file_name`, if positive. + Special values of 0 mean write every time step and -1 write only at the end of the run. + +- `output_freq_units` : The units in which `output_freq` is given. + Valid values are "years", "months", "days", "hours", "minutes" or "seconds". + +- `file_format` : Always set to 1, meaning netcdf. + +- `time_axis_units` : The units to use for the time-axis in the file. + Valid values are "years", "months", "days", "hours", "minutes" or "seconds". + +- `time_axis_name` : The name of the time-axis (usually "Time"). + +Optional entries in the file line allow the generation of multiple files are intervals: + +``` +"file_name", output_freq, "output_freq_units", file_format, "time_axis_units", "time_axis_name"[, new_file_freq, "new_file_freq_units"[, "start_time"[, file_duration, "file_duration_units"]]] +``` + +- file_name : The base name of the file that contains diagnostics at the given frequency (excluding the ".nc" extension). + The strings %%yr, %%mo, %%dy, %%hr %%mi, %%sc are expanded to the current year, month, day, hour, minute and second respectively, with new files created every new_file_freq. + +- `new_file_freq` : The period between generation of new files. + +- `new_file_freq_units` : The units in which `new_file_freq` is given. + +- `start_time`, `file_duration`, `file_duration_units` : Even finer grain control of output files. + + +\subsection diag_table_fields Field section + +An arbitrary number of lines, one per diagnostic field: + +``` +"module_name", "field_name", "output_name", "file_name", "time_sampling", "reduction_method", "regional_section", packing +``` + +- `module_name` : Name of the component model. + For native ocean variables this should be "ocean_model". + See \ref remapped_diagnostics for non-native vertical-grid diagnostics in the ocean model. + +- `field_name` : The name of the variable as registered in the model. + +- `output_name` " The name of the variable as it will appear in the file. + This is usually the same as the `field_name` but can be used to rename a diagnostic. + +- `file_name` : One of the files defined above in the section \ref diag_table_files. + +- `time_sampling` : Always set to "all". + +- `reduction_method` : "none" means sample or snapshot. + "average" or "mean" performs a time-average. + "min" or "max" diagnose the minium or maxium over each time period. + +- `regional_section` : "none" means global output. A string of six space separated numbers, "lon_min lon_max lat_min lat_max vert_min vert_max", limits the diagnostic to a region. + +- `packing` : Data representation in the file. 1 means "real*8", 2 means "real*4", 4 mean 16-bit integers, 8 means 1-byte. + + +\subsection diag_table_example Example + + +``` +"OM4 1/4 degree" +1900 1 1 0 0 0 + +# Static file +"ocean_static", -1, "months", 1, "days", "time" # ocean_static is a protected name. Do not change this line. +"ocean_model", "deptho", "deptho", "ocean_static", "all", "none", "none", 2 +"ocean_model", "geolon", "geolon", "ocean_static", "all", "none", "none", 2 +"ocean_model", "geolat", "geolat", "ocean_static", "all", "none", "none", 2 +"ocean_model", "wet", "wet", "ocean_static", "all", "none", "none", 2 + +# High-frequency file +"surf_%4yr_%3dy", 1, "hours", 1, "days", "time", 1, "months" +"ocean_model","SSH","SSH","surf_%4yr_%3dy","all","none","none",2 + +# Daily averages +"ocean_daily", 1, "days", 1, "days", "time" +"ocean_model", "tos", "tos", "ocean_daily", "all", "mean", "none",2 + +# Monthly averages +"ocean_month", 1, "months", 1, "days", "time" +"ocean_model", "thetao", "thetao", "ocean_month", "all", "mean", "none",2 + +# Annual averages +"ocean_annual", 12, "months", 1, "days", "time" +"ocean_model", "thetao", "thetao", "ocean_annual", "all", "mean", "none",2 + +# Vertical section +"ocean_Bering_Strait", 5, "days", 1, "days", "time" +"ocean_model", "thetao","thetao", "ocean_Bering_Strait", "all", "mean", "-171.4 -168.7 66.1 66.1 -1 -1",2 +``` + + +\section native_diagnostics Native diagnostics + +The list of available diagnostics is dependent on the particular configuration of the model. +For this reason the model writes a record of the available diagnostic fields at run-time into a file "available_diags.*". +See, for example, [available_diags.000000](https://github.com/NOAA-GFDL/MOM6-examples/blob/dev/master/ocean_only/global_ALE/z/available_diags.000000) for the global_ALE z-coordinate ocean-only test case. + +Diagnostic fields in the module "ocean_model" refer to the native variables or diagnostics in the native grid. +Since the model can be run in arbitrary coordinates, say in hybrid-coordinate mode, then native-space diagnostics can be potentially confusing. +Native diagnostics are useful when examining exactly what the model is doing, +or if the vertical coordinate of the model is configured to be a natural coordinate such as pure isopycnal or z* geopotential. + + +\section remapped_diagnostics Vertically remapped diagnostics + +Alternative vertical coordinates can be configured for diagnostic purposes only. + +The run-time parameter `NUM_DIAG_COORDS` controls how many diagnostic coordinates to use. + +The run-time parameter `DIAG_COORDS` defines the mapping between each coordinate, the name of the module in the diag_table and run-time parameter names that define the coordinate. +A list of string tuples, separated by commas, with each tuple in the form of MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME. +`MODULE_SUFFIX` is the string appended to "ocean_model" to create a module in the diag_table. +`PARAMETER_SUFFIX` is the string appended to "DiAG_COORD_DEF", and other parameters, used to control the generation of the named coordinate. +`COORDINATE_NAME` is a name understood by the MOM6 regridding module. Valid examples are "ZSTAR", "SIGMA", "RHO", etc. + +By default, `NUM_DIAG_COORDS=1` and `DIAG_COORDS="z Z ZSTAR"`, meaning the module "ocean_model_z" provides diagnostics in "z*" coordinates and uses the parameter `DIAG_COORD_DEF_Z`. + +For example, multiple z*-coordinates could be used for diagnostics with +``` +NUM_DIAG_COORDS = 2 +DIAG_COORDS = "z 01 ZSTAR,abc 02 ZSTAR" +DIAG_COORD_DEF_01 = "WOA09" +DIAG_COORD_DEF_02 = "UNIFORM:10,20." +``` +would create the diag_manager modules "ocean_model_z" and "ocean_model_abc". + +The above is equivalent to +``` +NUM_DIAG_COORDS = 2 +DIAG_COORDS = "z ZA ZSTAR,abc ZB ZSTAR" +DIAG_COORD_DEF_ZA = "WOA09" +DIAG_COORD_DEF_ZB = "UNIFORM:10,20." +``` + +To obtain a diagnostic of monthly-averaged potential temperature in both these coordinate systems the diag_table must include the lines + +``` +"ocean_month_z", 1, "months", 1, "days", "time" +"ocean_month_abc", 1, "months", 1, "days", "time" +"ocean_model_z", "temp", "temp", "ocean_month_z", "all", "mean", "none",2 +"ocean_model_abc", "temp", "temp", "ocean_month_abc", "all", "mean", "none",2 +``` + + +\subsection diag_table_vertical_coords Diagnostic vertical coordinates + +For each of the `NUM_DIAG_COORDS` vertical coordinates listed in `DIAG_COORDS` the corresponding `DIAG_COORD_DEF_%` parameter must be provided. +It can take the following values: +- PARAM : In this case, a corresponding parameter `DIAG_COORD_RES_%` is read that lists the deltas for each level in the coordinate. + For example, DIAG_COODS="z Z ZTAR", DIAG_COORD_DEF_Z="PARAM", DIAG_COORD_RES_Z=5,10,10,15 creates z*-level with 5,10,10,15 meters thicknesses. +- UNIFORM : Uniform distribution down to the maximum depth of the model using the same number of levels as he model. +- UNIFORM:N : Uniform distribution down to the maximum depth of the model using `N` levels. +- UNIFORM:N,D : Uniform distribution of `N` levels with thickness `D`. +- FILE:filename,varname : Reads vector of coordinate thicknesses from field "varname" from file "filename". +- FILE:filename,interfaces=varname : Reads vector of coordinate positions from field "varname" from file "filename". +- WOA09 : Z-levels that correspond to the World Ocean Atlas, 2009, standard levels down to and including the maximum depth of the model. +- WOA09:N : The first `N` levels of the World Ocean Atlas, 2009, standard levels. + + + +\section diagnostics_implementation APIs for diagnostics + +The multiple diagnostic-coordinates are implemented in a layer that sits on top of the FMS diag_manager known as the mom6_diag_mediator. + +A diagnostic is registered with register_diag_field() which is an API that looks similar to the FMS diag_manager routine of the same name: +``` +diag_id = register_diag_field(module_name, diag_name, axes, ...) +``` + +The MOM6 version of this routine optionally allows the specification of CMOR names in addition to the native names which then registers the diagnostic twice, once with each name. + +For each of the native and CMOR names, the diagnostic is registered in the native module "ocean_model", corresponding to the native model coordinate, and a module associated with each of the diagnostic coordinates. + +For each diagnostic coordinate, a horizontally-averaged diagnostic is also registered. + +In all, for each 3D diagnostic, the are 2 + 4N diagnostics registered, where N is the number of diagnostic coordinates. +As a result, the global_ALE examples have of order 900 total diagnostics available in the shipped configuration. + + +The data is made available to the diag_manager via a call to post_data() which is a wrapper that does all the vertical remapping before calling FMS's send_data(): +``` +call post_data(diag_id, data, diag_control) +``` + +\subsection diag_post_frequency Artifacts of posting frequency for diagnostics + +Variables area "posted" for i/o or averaging to the diag_manager (via MOM6's diag_mediator) at different frequencies relative to each other. +This is because the MOM6 algorithm takes the form of nested sub-cycles with different time-steps in each loop (e.g. barotropic solver with dynamics). +A consequence of this is that a time average of a related quantities may appear to be inconsistent since the diagnostic posted with higher frequency may not vary linearly between the end-points seen on the longer time-step. +The differences are usually small, but if you see large differences it might indicate you should re-examine the time-steps used for the various sub-cycles. + +*/ diff --git a/framework/_Dimensional_consistency.dox b/framework/_Dimensional_consistency.dox new file mode 100644 index 0000000000..0657724381 --- /dev/null +++ b/framework/_Dimensional_consistency.dox @@ -0,0 +1,85 @@ +/*! \page Dimensional_consistency Dimensional Consistency Testing + +\section section_Dimensional_consistency Dimensional Consistency Testing + + MOM6 uses a unique system for testing the dimensional consistency of all of +its expressions. The internal representations of dimensional variables are +rescaled by integer powers of 2 that depend on their units, with all input and +output being rescaled back to their original MKS units. By choosing different +powers of 2 for different units, the internal representations with different +units scale differently, so dimensionally inconsistent expressions will not +reproduce, but dimensionally inconsistent expressions give bitwise identical +results. So, for example, if horizontal lengths scale by a factor of 2^6=64, +and time is scaled by a factor of 2^4=16, horizontal velocities will scale by a +factor of 2^(6-4)=4. In this case, expressions that combine velocities, all +terms would scale by the same factor of 4. By contrast, if there were an +expression where a variable with units of length were added to one with the +units of a velocity, the results would scale inconsistently, and answers would +change with different scaling factors. + + What makes these integer powers of 2 special is the way that floating point +numbers are written as an O(1) mantissa times 2 raised to an integer exponent +between +/-1024. Multiplication by an integer power of 2 is just an integer +shift in the exponent, so as long as the model is not rescaled by an overly +large factor to encounter overflows and the model is not relying on automatic +underflows being converted to 0, all floating point operations can be carried +with one scale, and then rescaled to obtain identical answers. MOM6 has the +option to explicitly handle all relevant cases of underflows, and it can be +demonstrated to give identical answers when each of its units are scaled by +factors ranging from 2^-140 ~= 7.2e-43 to 2^140 ~= 1.4e42. + + When running with rescaling factors other than 2^0 = 1, there are some extra +array copies and multiplies of input fields or diagnostic output, so it is +slightly more efficient not to actively use the dimensional rescaling. For +production runs, we typically set all of the rescaling powers to 0, but for +debugging code problems, this rescaling can be an invaluable tool, especially +when combined with the very verbose runtime setting DEBUG=True in a MOM_input or +MOM_override file. Diffs of the output from runs with different scaling factors +readily highlights the earliest instances of differences, which can be used to +track down any dimensionally inconsistent expressions. Similarly, dimensional +inconsistencies in diagnostics is easily tracked down by comparing the output +from a pair of runs. + + All real variables in MOM6 should have comments describing their purpose, +along with their rescaled units and their mks counterparts with notation like +"! A velocity [L T-1 ~> m s-1]". If the units vary with the Boussinesq +approximation, the Boussinesq variant is given first. When variables are read +in, their dimensions are usually specified with a 'scale=' optional argument on +the MOM_get_param or MOM_read_data call, while the unscaling of diagnostics is +specified with a 'conversion=' factor. In both cases, these arguments it next +to a text string specifying the variable's units, which can then be check easily +for self-consistency. + + Currently in MOM6, the following dimensions have unique scaling, along with +the notation used to describe these variables in comments: + +\li Time, scaled by 2^T_RESCALE_POWER, denoted as [T ~> s] +\li Horizontal length, scaled by 2^L_RESCALE_POWER, denoted as [L ~> m] +\li Vertical height, scaled by 2^Z_RESCALE_POWER, denoted as [Z ~> m] +\li Vertical thickness, scaled by 2^H_RESCALE_POWER, denoted as [H ~> m or kg m-2] +\li Density, scaled by 2^R_RESCALE_POWER, denoted as [R ~> kg m-3] +\li Enthalpy (or heat content), scaled by 2^Q_RESCALE_POWER, denoted as [Q ~> J kg-1] + + These rescaling capabilities are also used by the SIS2 sea ice model, but it +does uses a non-Boussinesq mass scale of [R Z ~> kg m-2] for ice thicknesses, +rather than having a separate scaling factor (of [H ~> m or kg m-2]) that varies +between the Boussinesq and non-Boussinesq modes like MOM6 does. The actual +powers used in the scaling are specified separately for MOM6 and SIS2 and +need not be the same. + + Each of these units can be scaled in separate test runs, or all of them can be +rescaled simultaneously. In the latter case, MOM_unique_scales.F90 provides +tools to evaluate whether the specific combinations of units used by a model +scale by unique powers, and it can suggest scaling factors that provides unique +combinations of rescaling factors for the dimensions being tested, using a +cost-function based on the frequency with which units are used in the model (and +specified inside of MOM_check_scaling.F90), with a cost going as the product of +the frequency of units that resolve to the same scaling factor. + + A separate set of scaling factors could also be used for different chemical +tracer concentrations, for example. In this case, the tools in +MOM_unique_scales.F90 could still be used, but there would need to be a separate +equivalent of the unit_scaling_type with variables that are appropriate to the +units of the tracers. + +*/ diff --git a/framework/_Domain_decomposition.dox b/framework/_Domain_decomposition.dox new file mode 100644 index 0000000000..21fe27ade3 --- /dev/null +++ b/framework/_Domain_decomposition.dox @@ -0,0 +1,29 @@ +/*! \page Domain_Decomposition Domain Decomposition + +\section section_domain_decomp Domain Decomposition + +MOM6 supports serial, OpenMP, and MPI computations, with the user +choosing between them at run time. All are accomplished +through domain decomposition in the horizontal. All of the +horizontal operations are explicit with a relatively small +footprint, so the tiling is a logical choice. Some goals in the +parallel design of MOM6 were: + +\li Don't hard-code the number of processes. +\li MPI and OpenMP share the same basic structure. +\li Don't break the serial optimizations. +\li Same result as serial code for any number of processes. +\li Portability - able to run on any (Unix) system. + +The whole horizontal MOM6 grid is shown in \ref section_Memory. +The computations are done over the cells inside the darker line; +the cells are numbered 1 to NIGLOBAL in the \f$x\f$-direction and +1 to NJGLOBAL in the \f$y\f$-direction. Those looking ahead to +running in parallel would be wise to include factors of two and three in +their choice of NIGLOBAL and NJGLOBAL when building new grids. MOM6 will run in +parallel with any values of these, but the computations +might not be load-balanced. + +\section section_wide_halos Wide Halos + +*/ diff --git a/framework/_Global_grids.dox b/framework/_Global_grids.dox new file mode 100644 index 0000000000..078edbc487 --- /dev/null +++ b/framework/_Global_grids.dox @@ -0,0 +1,9 @@ +/*! \page Global_Grids Global Orthogonal Grids + +\brief Global Orthogonal Grids + +\section Dipole Dipole Grids + +\section Tripole Tripole Grids + +*/ diff --git a/framework/_Horizontal_indexing.dox b/framework/_Horizontal_indexing.dox new file mode 100644 index 0000000000..e68c38ac0f --- /dev/null +++ b/framework/_Horizontal_indexing.dox @@ -0,0 +1,103 @@ +/*! \page Horizontal_Indexing Horizontal indexing and memory + +\brief Conventions for staggering of variables and loops over 2d/3d arrays + +MOM6 is written in Fortran90 and uses the `i,j,k` order of indexing. +`i` corresponds to the fastest index (stride-1 in memory) and thus should be the inner-most loop variable. +We often refer to the i-direction as the x- or zonal direction, and similarly to the j-direction as y- or meridional direction. +The model can use curvilinear grids/coordinates in the horizontal and so these labels have loose meanings but convenient. + +\section section_Staggering Loops and staggered variables + +Many variables are staggered horizontally with respect to each other. +The dynamics and tracer equations are discretized on an Arakawa C grid. +Staggered variables must still have integer indices and we use a north-east convention centered on the h-points. +These means a variable with indices `i,j` will be either collocated, to the east, to the north, or to the north-east of the h-point with the same indices. + +\image html Arakawa_C_grid.png MOM6 uses an Arakawa C grid staggering of variables with a North-East indexing convention. "Cells" refer to the control volumes around tracer- or h-point located variables unless labelled otherwise. +\image latex Arakawa_C_grid.png MOM6 uses an Arakawa C grid staggering of variables with a North-East indexing convention. "Cells" refer to the control volumes around tracer- or h-point located variables unless labelled otherwise. + +\subsection Soft_convention Soft convention for loop variables + +To ease reading the code we use a "soft" convection (soft because there is no syntax checking) where an upper-case index variable can be interpreted as the lower-case index variable plus \f$\frac{1}{2}\f$. + +For example, when a loop is over h-points collocated variables +- the do-loop statements will be for lower-case `i,j` variables +- references to h-point variables will be `h(i,j)`, `D(i+1,j)`, etc. +- references to u-point variables will be `u(I,j)` (meaning \f$u_{i+\frac{1}{2},j}\f$), `u(I-1,j)` (meaning \f$u_{i-\frac{1}{2},j}\f$), etc. +- references to v-point variables will be `v(i,J)` (meaning \f$v_{i,j+\frac{1}{2}}\f$), `u(I-1,j)` (meaning \f$u_{i,j-\frac{1}{2}}\f$), etc. +- references to q-point variables will be `q(I,J)` (meaning \f$q_{i+\frac{1}{2},j+\frac{1}{2}}\f$), etc. + +In contrast, when a loop is over u-points collocated variables +- the do-loop statements will be for upper-case `I` and lower-case `j` variables +- the expression \f$ u_{i+\frac{1}{2},j} ( h_{i,j} + h_{i+1,j} ) \f$ is `u(I,j) * ( h(i,j) + h(i+1,j)`. + + +\section section_Memory Declaration of variables + +\image html Horizontal_NE_indexing_nonsym.png Non-symmetric mode: All arrays are declared with the same shape `(isd:ied,jsd:jed)`. +\image latex Horizontal_NE_indexing_nonsym.png Non-symmetric mode: All arrays are declared with the same shape `(isd:ied,jsd:jed)`. + +\image html Horizontal_NE_indexing_sym.png Symmetric mode: Arrays have different shapes depending on their staggering location on the Arakawa C grid. +\image latex Horizontal_NE_indexing_sym.png Symmetric mode: Arrays have different shapes depending on their staggering location on the Arakawa C grid. + +A field is described by 2D or 3D arrays which are distributed across parallel processors. +Each processor only sees a small window of the global field. +The processor "owns" the computational domain (red in above figure) but arrays are extended horizontally with halos which are intermittently updated with the values from neighboring processors. +The halo regions (blue in above figure) may not always be up-to-date. +Data in halo regions (blue in above figure) will be overwritten my mpp_updates. + +MOM6 has two memory models, "symmetric" and "non-symmetric". +In non-symmetric mode all arrays are given the same shape. +The consequence of this is that there are fewer staggered variables to the south-west of the computational domain. +An operator applied at h-point locations involving u- or v- point data can not have as wide a stencil on the south-west side of the processor domain as it can on the north-east side. + +In symmetric mode, declarations are dependent on the variables staggered location on the Arakawa C grid. +This allows loops to be symmetric and stencils to be applied more uniformly. + +In the code, declarations are consistent with the symmetric memory model. +The non-symmetric mode is implemented by setting the start values of the staggered data domain to be the same as the non-staggered start value. + +The horizontal index type (mom_hor_index::hor_index_type) provides the data domain start values. +The values are also copied into the mom_grid::ocean_grid_type for convenience although we might deprecate this convenience in the future. + +Declarations of h-point data take the form: +- `real, dimension(HI%%isd:HI%%ied, HI%%jsd:HI%%jed) :: D !< Depth at h-points (m)` +- `real, dimension(HI%%isd:HI%%ied, HI%%jsd:HI%%jed, GV%%ke) :: h !< Layer thickness (H units)` + +Declarations of u-point data take the form: +- `real, dimension(HI%%IsdB:HI%%IedB, HI%%jsd:HI%%jed) :: Du !< Depth at u-points (m)` +- `real, dimension(HI%%IsdB:HI%%IedB, HI%%jsd:HI%%jed, GV%%ke) :: h !< Zonal flow (m/s)` + +Declarations of v-point data take the form: +- `real, dimension(HI%%isd:HI%%ied, HI%%JsdB:HI%%JedB) :: Dv !< Depth at v-points (m)` +- `real, dimension(HI%%isd:HI%%ied, HI%%JsdB:HI%%JedB, GV%%ke) :: h !< Zonal flow (m/s)` + +Declarations of q-point data take the form: +- `real, dimension(HI%%IsdB:HI%%IedB, HI%%JsdB:HI%%JedB) :: Dq !< Depth at q-points (m)` +- `real, dimension(HI%%IsdB:HI%%IedB, HI%%JsdB:HI%%JedB, GV%%ke) :: vort !< Vertical componentof vorticity (s-1)` + +The file MOM_memory_macros.h provides the macros `SZI_`, `SZJ_`, `SZIB_` and `SZJB_` that help make the above more concise: +- `real, dimension(SZI_(HI), SZJ_(HI)) :: D !< Depth at h-points (m)` +- `real, dimension(SZIB_(HI), SZJ_(HI)) :: Du !< Depth at u-points (m)` +- `real, dimension(SZI_(HI), SZJB_(HI)) :: Dv !< Depth at v-points (m)` +- `real, dimension(SZIB_(HI), SZJB_(HI)) :: Dq !< Depth at q-points (m)` + +See MOM_memory_macros.h for the complete list of macros used in various memory modes. + +\section Global_index Calculating a global index + +For the most part MOM6 code should be independent of an equivalent absolute global index. +There are exceptions and when the global index of a cell `i,j` is needed is can be calculated as follows: + + `i_global = i + HI%%idg_offset` + +Before the mom_hor_index::hor_index_type was introduced, this conversion was done use variables in the mom_grid::ocean_grid_type: + + `i_global = (i-G%%isd) + G%%isd_global` + +which is no longer preferred. + +Note that a global index only makes sense for a rectangular global domain. If the domain is a Mosaic of connected tiles (e.g. size tiles of a cube) the global indices (i,j) become meaningless. + +*/ diff --git a/framework/_Parallel_IO.dox b/framework/_Parallel_IO.dox new file mode 100644 index 0000000000..585448b6c2 --- /dev/null +++ b/framework/_Parallel_IO.dox @@ -0,0 +1,10 @@ +/*! \page Parallel_IO Parallel I/O + +\brief Parallel I/O + +The model can be told to write a different output file per process. This may or may +not save time, and is a bad idea on Lustre filesystems. If the model is writing +individual files per process, one can combine them using the mppnccombine program from +the [FRE-nctools package](https://github.com/NOAA-GFDL/FRE-NCtools). + +*/ diff --git a/framework/_Regional_grids.dox b/framework/_Regional_grids.dox new file mode 100644 index 0000000000..b99dbed942 --- /dev/null +++ b/framework/_Regional_grids.dox @@ -0,0 +1,9 @@ +/*! \page Regional_Grids Regional Orthogonal Grids + +\brief Regional Orthogonal Grids + +\section map_projections Map Projections + +\section OBC_segments Open Boundary Segments + +*/ diff --git a/framework/_Runtime_parameter_system.dox b/framework/_Runtime_parameter_system.dox new file mode 100644 index 0000000000..a6b86fbfc6 --- /dev/null +++ b/framework/_Runtime_parameter_system.dox @@ -0,0 +1,82 @@ +/*! \page Runtime_Parameter_System Run-time Parameter System + +\brief How run-time parameters work in MOM6 + +MOM6 has an extensive set of parameters that are set at run-time by parsing an input file. Many parameters have default values and are not required to be in the input file, although there are a number of parameters that must be set for the model to run. The numerous examples provided with the MOM6 code mostly differ in their run-time parameters (although some add other components, like sea-ice), and comparison between these examples is an excellent way to get a broad overview of many of MOM6's parameters and how they might be set. + +\section reading_params Getting parameters into MOM6 + +Run-time parameters are provided to the model in two phases: + +1. A very small set of logistical parameters are read as namelist variables from the FMS parameter file `input.nml`. One of these logistical parameters is a list of ascii files that contain all the other run-time parameters. +2. All of the above-named parameter files are scanned for MOM6 model parameters, default values assigned and replaced, conflicts detected and various parameter summaries logged to files and/or the standard output. + +\subsection mom6_namelist Namelist parameters (`input.nml`) + +All FMS derived MOM6 parameters reside in the namelist `MOM_input_nml` in the file `input.nml`. The parameters are: +- `input_filename` - If equal to "n" will run a new run (i.e. will not read a restart file). If equal to "r" MOM6 will attempt to read a restart file. +- `parameter_filename` - A list of file names containing the MOM6 internal run-time parameters. Typically `param_files="MOM6_input","MOM6_override"` where the file MOM6_input contains all the non-default parameters that define a "baseline" experiment and MOM6_override will be either empty (for baseline) or contain a few parameters that define a "derived" experiment (that differs from the baseline). This helps keep the parameter lists concise and enables easy comparison of parameters in related experiments. +- `restart_input_dir`, `restart_output_dir`, and `output_directory` - These specify the directories for reading input files, writing restart files, and writing many non-restart files. + +\subsection fms_params Other MOM6-relevant FMS parameters + +The namelist ocean_solo_nml may have the integer parameters secs, hours, days, months and years, which dictate how long the FMS ocean driver will try to run the model each run-segment. + +\subsection param_syntax MOM6 parameter file syntax + +The general syntax for an entry in a MOM6 parameter file is +\code{.unparsed} +[!]#[override] PARAMETER_NAME = value[,value][...][!comments] +\endcode + +Parameter names must be constructed from the characters `[A-Za-z0-9_]` and by soft convention are upper case. The `!` character is a remark or comment indicator; all subsequent text on that line is ignored. + +Parameters that are not specified in the parameter files may assume a default value. It is not an error to specify a parameter more than once with the same value. It is an error to specify different values. + +The keyword \#override indicates that this parameter specification takes precedence over other specifications. It is **not** an error to have two \#override specifications for a single parameter with the same values. It is an error to have two \#override statements with different values. + +Some illustrations: +\code{.unparsed} +DO_THIS = True ! Set the Boolean to .TRUE. +DO_THAT = False ! Set the Boolean to .FALSE. +NXYZ = 5 ! Set the value to NXYZ to 5 +HALF = 0.5 ! Set the value of HALF to 0.5 +NAME = "abc" ! Set the string NAME to 'abc' +VECTOR = 1.0,2.0 ! Set the array VECTOR to [1.0, 2.0] +NAMES = 'abc','xyz' ! Set the strings NAMES to 'abc','xyz' +#override DO_THIS = False ! Set the Boolean to .FALSE., ignoring the above specification +#override HALF = 0.25 ! Set the value of HALF to 0.25, ignoring the above value +#override HALF = 0.25 ! Same as the above value of HALF to 0.25 so is accepted +\endcode + +\subsection param_logging Logging of parameters + +The subroutine that reads MOM6 parameters has also serves to log every parameter to a file set by DOCUMENT_FILE, usually "MOM6_parameter_doc". In addition to the name of the variable being read, these calls contain a brief description, along with a description of the units and the default value (if any) or an indication that there is no default and that the variable must be present. For example, `DT` is always required to be present: +\code{.f90} + call get_param(param_file, module, "DT", CS%dt, & + "The (baroclinic) dynamics time step. The time-step that \n"//& + "is actually used will be an integer fraction of the \n"//& + "forcing time-step (DT_FORCING in ocean-only mode or the \n"//& + "coupling timestep in coupled mode.)", units="s", & + fail_if_missing=.true.) +\endcode + +At run-time, two levels of logging are performed, depending on the value of the parameter `MINIMAL_DOCUMENTATION`: + +- (TRUE) The end result of the combination of default values, assignments and overrides are recorded with default and current values, description and units, for all parameters. +- (FALSE) The minimal list of required and non-default value parameters are recorded with current values, description and units only for those parameters needed to reproduce the configuration. + +Either of the generated logging files can be used as inputs and yield the same configuration. + +In addition, there are also calls that log derived quantities (e.g., a time-step that is derived from a CFL number, or the full path to an input file) without reading anything in. + +\subsection param_checking Error checking of parameters and parameter files + +There are several techniques that are used for error checking on MOM6 parameters: + +- Some parameters have internal error messages if they are set to nonsensical values. +- No parameter can be set twice inconsistently without an explicit \#override specification. +- If the run-time parameter REPORT_UNUSED_PARAMS is true, a warning will be issued for any entries in the input parameter files that are not read in, for instance if they are misspelled. +- Setting the run-time parameter FATAL_UNUSED_PARAMS to true causes a fatal error that will bring down the model if there are any unused entries in the input parameter files. + +*/ diff --git a/framework/_Testing.dox b/framework/_Testing.dox new file mode 100644 index 0000000000..c28f384da5 --- /dev/null +++ b/framework/_Testing.dox @@ -0,0 +1,145 @@ +/*! \page Testing Testing + +\brief MOM6 Validation and Verification + +In the software engineering world, people talk about validation and verification of +their codes. Verification is the confirmation of design specifications, such as: + +\li Does it compile on the target platform? +\li Is it dimensionally consistent? +\li Do answers change with the number of processes? +\li Do answers change after a restart? + +Validation is a little trickier: + +\li Does the model meet operational needs? +\li Does it produce realistic simulations? +\li Are relevant physical features present? +\li Can I reproduce my old simulations? + +There are a number of ways in which MOM6 is tested before each commit, especially +commits to the shared dev/main branch. + +\section Travis Travis Testing + +When pushing code to github, it is possible to set it up so that testing is performed +automatically by travis. For MOM6, the .travis.yml file is executed, causing the code to +be compiled and then run on all the tests in the .testing directory. It is also possible +to run these tests on your local machine, but you might have to do some setup first. See +\sa ../../../.testing/README.md +for more information. + +\section Consortium_testing Consortium Testing + +For commits to the dev/main branch, there is an opportunity for all +consortium members to weigh in on proposed updates. A view of the +consortium is shown here: + +\image html consortium.png "The MOM6 consortium." +\image latex consortium.png "The MOM6 consortium." + +Each group is expected to have their own tests and to keep track of +expected answers when these tests are run to be compared to prior answers +after the code is updated. Answer-changing updates have to be evaluated +carefully, though there are circumstances in which the new answers may well be +"better". + +\section Novel_tests Novel Tests + +There are two classes of tests which MOM6 performs within the .testing suite +which could be considered unusual, but which can be quite useful for finding bugs. + +\subsection Scalings Scaling tests + +The equations of motion can be multiplied by factors of two without changing +answers. One can use that to scale each of six units by a different factor of two +to check for consistent use of units. For instance, the equation: + +\f[ + u^{n+1} = u^n + \Delta t \times \cal{F} +\f] + +can be scaled as: + +\f[ + {2^{L-T}} u^{n+1} = {2^{L-T}} u^n + {2^T} + \Delta t \times {2^{L-2T}} \cal{F} +\f] + +MOM6 has been recoded to include six different scale factors: + + +
Dimensional scale factors
Unit Scaling Name +
s T Time +
m L Horizontal length +
m H Layer thickness +
m Z Vertical length +
kg/m3 R Density +
J/kg Q Enthalpy +
+ +You can add these integer scaling factors through the runtime parameters +X_RESCALE_POWER, where X is one of T, L, H, Z, R, or Q. The valid range +for these is -300 to 300. + +When adding contributions to MOM6, this coding style with the scale +factors must be maintained. For example, if you add new parameters to +read from the input file: +\code +call get_param(..., "DT", ... , scale=US%s_to_T) +\endcode + +This is also required for explicit contants, though we are trying to move those out +of the code: +\code +ustar = 0.01 * US%m_to_Z * US%T_to_s +\endcode + +or for adding diagnostics: +\code +call register_diag_field(..., "u", ... , & + conversion=US%L_T_to_m_s) +\endcode +\sa \ref mom_unit_scaling + +\subsection Rotations Rotational tests + +By setting the runtime option ROTATE_INDEX to True, the model rotates +the domain by some number of 90 degree turns. This option can be used +to look for bugs in which east-west operations do not match north-south +operations. It changes the order of array elements as shown here: + +\image html Rotated_indices.png "The original non-rotated domain is shown on the left while the right shows the domain rotated counterclockwise by 90 degrees. The array values are shown by the (invariant) colors, while the array indices (and dimensions) change." +\image latex Rotated_indices.png "The original non-rotated domain is shown on the left while the right shows the domain rotated counterclockwise by 90 degrees. The array values are shown by the (invariant) colors, while the array indices (and dimensions) change." + +It only currently runs in serial mode. One can ask for rotations of 90, 180, or +270 degrees, but only 90 degree turns are supported if there are open boundaries. + +Because order matters in numerical computations, care must be taken for +four-way averages to match between rotated and non-rotated runs. Say you want to +compute the following quantity: + +\f[ + \phi_{i,j}^{(c)} = \frac{1}{4} (\phi_A + \phi_B + \phi_C + \phi_D) +\f] + +as shown in this diagram: + +\image html Diagonals1.png "Four h points around a q point." + +You might write this first as: +\f[ + \frac{1}{4} ((\phi_A + \phi_B) + (\phi_C + \phi_D)) +\f] +as shown on the left in this figure: + +\image html Diagonals2.png "Naive grouping of terms on the left, diagonal grouping of terms on the right." + +However, the round-off errors could give differing answers when +rotated. Instead, you want to group the terms on the diagonal as shown +in the right of the above figure and here: +\f[ + \frac{1}{4} ((\phi_A + \phi_D) + (\phi_B + \phi_C)) +\f] + +*/ diff --git a/framework/_Vertical_grids.dox b/framework/_Vertical_grids.dox new file mode 100644 index 0000000000..1231a5bd42 --- /dev/null +++ b/framework/_Vertical_grids.dox @@ -0,0 +1,13 @@ +/*! \page Vertical_Grids Vertical Grids + +\section vert_layer Layered + +\section vert_z_star Z-Star + +\section vert_sigma Sigma + +\section vert_rho Rho + +\section vert_hybrid Hybrid + +*/ diff --git a/framework/posix.F90 b/framework/posix.F90 new file mode 100644 index 0000000000..fffb619cba --- /dev/null +++ b/framework/posix.F90 @@ -0,0 +1,484 @@ +!> Interface to the libc POSIX API +#include "posix.h" + +module posix + +use, intrinsic :: iso_c_binding, only : c_char +use, intrinsic :: iso_c_binding, only : c_int +use, intrinsic :: iso_c_binding, only : c_long +use, intrinsic :: iso_c_binding, only : c_null_char +use, intrinsic :: iso_c_binding, only : c_funptr +use, intrinsic :: iso_c_binding, only : c_funloc +use, intrinsic :: iso_c_binding, only : c_f_procpointer + +implicit none + +!> Container for file metadata from stat +!! +!! NOTE: This is currently just a placeholder containing fields, such as size, +!! uid, mode, etc. A readable Fortran type may be used in the future. +type, bind(c) :: stat_buf + private + character(kind=c_char) :: state(SIZEOF_STAT_BUF) + !< Byte array containing file metadata +end type stat_buf + +!> Container for the jump point buffer created by setjmp(). +!! +!! The buffer typically contains the current register values, stack pointers, +!! and any information required to restore the process state. +type, bind(c) :: jmp_buf + private + character(kind=c_char) :: state(SIZEOF_JMP_BUF) + !< Unstructured array of bytes used to store the process state +end type jmp_buf + +!> Container for the jump point buffer (with signals) created by sigsetjmp() +!! +!! In addition to the content stored by `jmp_buf`, it also stores signal state. +type, bind(c) :: sigjmp_buf + private + character(kind=c_char) :: state(SIZEOF_SIGJMP_BUF) + !< Unstructured array of bytes used to store the process state +end type sigjmp_buf + +! POSIX signals +integer, parameter :: SIGUSR1 = POSIX_SIGUSR1 + !< Signal number for SIGUSR1 (user-defined signal 1) + +interface + !> C interface to POSIX chmod() + !! Users should use the Fortran-defined chmod() function. + function chmod_posix(path, mode) result(rc) bind(c, name="chmod") + ! #include + ! int chmod(const char *path, mode_t mode); + import :: c_char, c_int + + character(kind=c_char), dimension(*), intent(in) :: path + !< Zero-delimited file path + integer(kind=c_int), value, intent(in) :: mode + !< File permission to be assigned to file. + integer(kind=c_int) :: rc + !< Function return code + end function chmod_posix + + !> C interface to POSIX mkdir() + !! Users should use the Fortran-defined mkdir() function. + function mkdir_posix(path, mode) result(rc) bind(c, name="mkdir") + ! #include + ! int mkdir(const char *path, mode_t mode); + import :: c_char, c_int + + character(kind=c_char), dimension(*), intent(in) :: path + !< Zero-delimited file path + integer(kind=c_int), value, intent(in) :: mode + !< File permission to be assigned to file. + integer(kind=c_int) :: rc + !< Function return code + end function mkdir_posix + + !> C interface to POSIX stat() + !! Users should use the Fortran-defined stat() function. + function stat_posix(path, buf) result(rc) bind(c, name="stat") + import :: c_char, stat_buf, c_int + + character(kind=c_char), dimension(*), intent(in) :: path + !< Pathname of a POSIX file + type(stat_buf), intent(in) :: buf + !< Information describing the file if it exists + integer(kind=c_int) :: rc + !< Function return code + end function + + !> C interface to POSIX signal() + !! Users should use the Fortran-defined signal() function. + function signal_posix(sig, func) result(handle) bind(c, name="signal") + ! #include + ! void (*signal(int sig, void (*func)(int)))(int); + import :: c_int, c_funptr + + integer(kind=c_int), value, intent(in) :: sig + !< Signal to be configured + type(c_funptr), value, intent(in) :: func + !< Function handle to be called when `sig` is raised + type(c_funptr) :: handle + !< Prior handle for sig to be replaced by `func` + end function signal_posix + + !> C interface to POSIX kill() + !! Users should use the Fortran-defined kill() function. + function kill_posix(pid, sig) result(rc) bind(c, name="kill") + ! #include + ! int kill(pid_t pid, int sig); + import :: c_int + + integer(kind=c_int), value, intent(in) :: pid + !< Process ID which is to receive the signal + integer(kind=c_int), value, intent(in) :: sig + !< Signal to be sent to the process + integer(kind=c_int) :: rc + !< Function return code + end function kill_posix + + !> C interface to POSIX getpid() + !! Users should use the Fortran-defined getpid() function. + function getpid_posix() result(pid) bind(c, name="getpid") + ! #include + ! pid_t getpid(void); + import :: c_long + + integer(kind=c_long) :: pid + !< Process ID of the current process. + end function getpid_posix + + !> C interface to POSIX getppid() + !! Users should use the Fortran-defined getppid() function. + function getppid_posix() result(pid) bind(c, name="getppid") + ! #include + ! pid_t getppid(void); + import :: c_long + + integer(kind=c_long) :: pid + !< Process ID of the parent process to the current process. + end function getppid_posix + + !> C interface to POSIX sleep() + !! Users should use the Fortran-defined sleep() function. + function sleep_posix(seconds) result(rc) bind(c, name="sleep") + ! #include + ! unsigned int sleep(unsigned int seconds); + import :: c_int + + integer(kind=c_int), value, intent(in) :: seconds + !< Number of real-time seconds which the thread should sleep + integer(kind=c_int) :: rc + !< Function return code + end function + + ! NOTE: The C setjmp and sigsetjmp functions *must* be called explicitly by + ! the Fortran code, rather than through a wrapper Fortran function. + ! + ! Otherwise, setjmp() will capture the stack inside the wrapper, rather than + ! the point where setjmp() is called. + ! + ! Hence, we remove the `_posix` suffix and call these explicitly. + ! (The integer kind <-> c_int conversion will need to be addressed.) + + ! NOTE: POSIX explicitly says setjmp/sigsetjmp may be either a function or a + ! macro, and thus bind() may point to a nonexistent function. + ! e.g. sigsetjmp is a macro to __sigsetjmp in glibc, so we use a macro. + + !> Save the current program execution state to `env`. + !! + !! This function creates a snapshot of the process state to `env`, which can + !! be restored by calling `longjmp`. When `setjmp` is called, the function + !! returns 0. When `longjmp` is later called, the program is restored to the + !! point where `setjmp` was called, except it now returns a value (rc) as + !! specified by `longjmp`. + function setjmp(env) result(rc) bind(c, name=SETJMP_NAME) + ! #include + ! int setjmp(jmp_buf env); + import :: jmp_buf, c_int + + type(jmp_buf), intent(in) :: env + !< Current process state + integer(kind=c_int) :: rc + !< Function return code; set to 0 if setjmp() was called, otherwise + !! specified by the corresponding longjmp() call. + end function setjmp + + !> Save the current execution and ,optionally, the signal state to `env`. + !! + !! This function creates a snapshot of the process state to `env`, which can + !! be restored by calling `longjmp`. When `setjmp` is called, the function + !! returns 0. When `longjmp` is later called, the program is restored to the + !! point where `setjmp` was called, except it now returns a value (rc) as + !! specified by `longjmp`. + !! + !! If `savesigs` is set to a nonzero value, then the signal state is included + !! in the program state. + function sigsetjmp(env, savesigs) result(rc) bind(c, name=SIGSETJMP_NAME) + ! #include + ! int sigsetjmp(jmp_buf env, int savesigs); + import :: sigjmp_buf, c_int + + type(sigjmp_buf), intent(in) :: env + !< Current process state + integer(kind=c_int), value, intent(in) :: savesigs + !< Flag to enable signal state when set to a nonzero value + integer(kind=c_int) :: rc + !< Function return code; set to 0 if sigsetjmp() was called, otherwise + !! specified by the corresponding siglongjmp() call. + end function sigsetjmp + + !> C interface to POSIX longjmp() + !! Users should use the Fortran-defined longjmp() function. + subroutine longjmp_posix(env, val) bind(c, name=LONGJMP_NAME) + ! #include + ! int longjmp(jmp_buf env, int val); + import :: jmp_buf, c_int + + type(jmp_buf), intent(in) :: env + !< Process state to restore + integer(kind=c_int), value, intent(in) :: val + !< Return code sent to setjmp() + end subroutine longjmp_posix + + !> C interface to POSIX siglongjmp() + !! Users should use the Fortran-defined siglongjmp() function. + subroutine siglongjmp_posix(env, val) bind(c, name=SIGLONGJMP_NAME) + ! #include + ! int siglongjmp(jmp_buf env, int val); + import :: sigjmp_buf, c_int + + type(sigjmp_buf), intent(in) :: env + !< Process state to restore + integer(kind=c_int), value, intent(in) :: val + !< Return code sent to sigsetjmp() + end subroutine siglongjmp_posix + + ! Note on types: + ! mode_t: + ! "According to POSIX, it shall be an integer type." + ! pid_t: + ! "According to POSIX, it shall be a signed integer type, and the + ! implementation shall support one or more programming environments where + ! the width of pid_t is no greater than the width of the type long. + ! jmp_buf: + ! This is a strongly platform-dependent variable, large enough to contain + ! a complete copy of the process execution state (registers, stack, etc). + ! sigjmp_buf: + ! A more comprehensive version of jmp_buf which contains signal state. +end interface + +abstract interface + !> Function interface for signal handlers + subroutine handler_interface(sig) + integer, intent(in) :: sig + !> Input signal to handler + end subroutine +end interface + +contains + +!> Change mode of a file +!! +!! This changes the file permission of file `path` to `mode` following POSIX +!! conventions. If successful, it returns zero. Otherwise, it returns -1. +function chmod(path, mode) result(rc) + character(len=*), intent(in) :: path + integer, intent(in) :: mode + integer :: rc + + integer(kind=c_int) :: mode_c + integer(kind=c_int) :: rc_c + + mode_c = int(mode, kind=c_int) + rc_c = chmod_posix(path//c_null_char, mode_c) + rc = int(rc_c) +end function chmod + +!> Create a file directory +!! +!! This creates a new directory named `path` with permissons set by `mode`. +!! If successful, it returns zero. Otherwise, it returns -1. +function mkdir(path, mode) result(rc) + character(len=*), intent(in) :: path + integer, intent(in) :: mode + integer :: rc + + integer(kind=c_int) :: mode_c + integer(kind=c_int) :: rc_c + + mode_c = int(mode, kind=c_int) + rc_c = mkdir_posix(path//c_null_char, mode_c) + rc = int(rc_c) +end function mkdir + +!> Get file status +!! +!! This obtains information about the named file and writes it to buf. +!! If found, it returns zero. Otherwise, it returns -1. +function stat(path, buf) result(rc) + character(len=*), intent(in) :: path + !< Pathname of file to be inspected + type(stat_buf), intent(out) :: buf + !< Buffer containing information about the file if it exists + ! NOTE: Currently the contents of buf are not readable, but we could move + ! the contents into a readable Fortran type. + integer :: rc + !< Function return code + + integer(kind=c_int) :: rc_c + + rc_c = stat_posix(path//c_null_char, buf) + + rc = int(rc_c) +end function stat + +!> Create a signal handler `handle` to be called when `sig` is detected. +!! +!! If successful, the previous handler for `sig` is returned. Otherwise, +!! SIG_ERR is returned. +function signal(sig, func) result(handle) + integer, intent(in) :: sig + procedure(handler_interface) :: func + procedure(handler_interface), pointer :: handle + + integer(kind=c_int) :: sig_c + type(c_funptr) :: handle_c + + sig_c = int(sig, kind=c_int) + handle_c = signal_posix(sig_c, c_funloc(func)) + call c_f_procpointer(handle_c, handle) +end function signal + +!> Send signal `sig` to process `pid`. +!! +!! If successful, this function returns 0. Otherwise, it returns -1. +function kill(pid, sig) result(rc) + integer, intent(in) :: pid + integer, intent(in) :: sig + integer :: rc + + integer(kind=c_int) :: pid_c, sig_c, rc_c + + pid_c = int(pid, kind=c_int) + sig_c = int(sig, kind=c_int) + rc_c = kill_posix(pid_c, sig_c) + rc = int(rc_c) +end function kill + +!> Get the ID of the current process. +function getpid() result(pid) + integer :: pid + + integer(kind=c_long) :: pid_c + + pid_c = getpid_posix() + pid = int(pid_c) +end function getpid + +!> Get the ID of the parent process of the current process. +function getppid() result(pid) + integer :: pid + + integer(kind=c_long) :: pid_c + + pid_c = getppid_posix() + pid = int(pid_c) +end function getppid + +!> Force the process to a sleep state for `seconds` seconds. +!! +!! The sleep state may be interrupted by a signal. If it sleeps for the entire +!! duration, then it returns 0. Otherwise, it returns the number of seconds +!! remaining at the point of interruption. +function sleep(seconds) result(rc) + ! NOTE: This function may replace an existing compiler `sleep()` extension. + integer, intent(in) :: seconds + integer :: rc + + integer(kind=c_int) :: seconds_c + integer(kind=c_int) :: rc_c + + seconds_c = int(seconds, kind=c_int) + rc_c = sleep_posix(seconds_c) + rc = int(rc_c) +end function sleep + +!> Restore program to state saved by `env`, and return the value `val`. +!! +!! This "nonlocal goto" alters program execution to the state stored in `env` +!! produced by a prior execution of `setjmp`. Program execution is moved +!! back to this `setjmp`, except the function will now return `val`. +subroutine longjmp(env, val) + type(jmp_buf), intent(in) :: env + integer, intent(in) :: val + + integer(kind=c_int) :: val_c + + val_c = int(val, kind=c_int) + call longjmp_posix(env, val_c) +end subroutine longjmp + +!> Restore program to state saved by `env`, and return the value `val`. +!! +!! This "nonlocal goto" alters program execution to the state stored in `env` +!! produced by a prior execution of `setjmp`. Program execution is moved back +!! to this `setjmp`, except the function will now return `val`. +!! +!! `siglongjmp` behaves in the same manner as `longjmp`, but also provides +!! predictable handling of the signal state. +subroutine siglongjmp(env, val) + type(sigjmp_buf), intent(in) :: env + integer, intent(in) :: val + + integer(kind=c_int) :: val_c + + val_c = int(val, kind=c_int) + call siglongjmp_posix(env, val_c) +end subroutine siglongjmp + + +! Symbols in may be platform-dependent and may not exist if defined +! as a macro. The following functions permit compilation when they are +! unavailable, and report a runtime error if used in the program. + +!> Placeholder function for a missing or unconfigured setjmp +function setjmp_missing(env) result(rc) bind(c) + type(jmp_buf), intent(in) :: env + !< Current process state (unused) + integer(kind=c_int) :: rc + !< Function return code (unused) + + print '(a)', 'ERROR: setjmp() is not implemented in this build.' + print '(a)', 'Recompile with autoconf or -DSETJMP_NAME=\"\".' + error stop + + ! NOTE: compilers may expect a return value, even if it is unreachable + rc = -1 +end function setjmp_missing + +!> Placeholder function for a missing or unconfigured longjmp +subroutine longjmp_missing(env, val) bind(c) + type(jmp_buf), intent(in) :: env + !< Current process state (unused) + integer(kind=c_int), value, intent(in) :: val + !< Enable signal state flag (unused) + + print '(a)', 'ERROR: longjmp() is not implemented in this build.' + print '(a)', 'Recompile with autoconf or -DLONGJMP_NAME=\"\".' + error stop +end subroutine longjmp_missing + +!> Placeholder function for a missing or unconfigured sigsetjmp +function sigsetjmp_missing(env, savesigs) result(rc) bind(c) + type(sigjmp_buf), intent(in) :: env + !< Current process state (unused) + integer(kind=c_int), value, intent(in) :: savesigs + !< Enable signal state flag (unused) + integer(kind=c_int) :: rc + !< Function return code (unused) + + print '(a)', 'ERROR: sigsetjmp() is not implemented in this build.' + print '(a)', 'Recompile with autoconf or -DSIGSETJMP_NAME=\"\".' + error stop + + ! NOTE: compilers may expect a return value, even if it is unreachable + rc = -1 +end function sigsetjmp_missing + +!> Placeholder function for a missing or unconfigured siglongjmp +subroutine siglongjmp_missing(env, val) bind(c) + type(sigjmp_buf), intent(in) :: env + !< Current process state (unused) + integer(kind=c_int), value, intent(in) :: val + !< Enable signal state flag (unused) + + print '(a)', 'ERROR: siglongjmp() is not implemented in this build.' + print '(a)', 'Recompile with autoconf or -DSIGLONGJMP_NAME=\"\".' + error stop +end subroutine siglongjmp_missing + +end module posix diff --git a/framework/posix.h b/framework/posix.h new file mode 100644 index 0000000000..c4b09e1285 --- /dev/null +++ b/framework/posix.h @@ -0,0 +1,44 @@ +#ifndef MOM6_POSIX_H_ +#define MOM6_POSIX_H_ + +! STAT_BUF_SIZE should be set to sizeof(stat). +! The default value is based on glibc 2.28. +#ifndef SIZEOF_STAT_BUF +#define SIZEOF_STAT_BUF 144 +#endif + +! JMP_BUF_SIZE should be set to sizeof(jmp_buf). +! If unset, then use a typical glibc value (25 long ints) +#ifndef SIZEOF_JMP_BUF +#define SIZEOF_JMP_BUF 200 +#endif + +! If unset, assume jmp_buf and sigjmp_buf are equivalent (as in glibc). +#ifndef SIZEOF_SIGJMP_BUF +#define SIZEOF_SIGJMP_BUF SIZEOF_JMP_BUF +#endif + +! Wrappers to are disabled on default. +#ifndef SETJMP_NAME +#define SETJMP_NAME "setjmp_missing" +#endif + +#ifndef LONGJMP_NAME +#define LONGJMP_NAME "longjmp_missing" +#endif + +#ifndef SIGSETJMP_NAME +#define SIGSETJMP_NAME "sigsetjmp_missing" +#endif + +#ifndef SIGLONGJMP_NAME +#define SIGLONGJMP_NAME "siglongjmp_missing" +#endif + +! This should be defined by ; +! If unset, we use the most common (x86) value +#ifndef POSIX_SIGUSR1 +#define POSIX_SIGUSR1 10 +#endif + +#endif diff --git a/framework/testing/MOM_file_parser_tests.F90 b/framework/testing/MOM_file_parser_tests.F90 new file mode 100644 index 0000000000..c0a31c39c4 --- /dev/null +++ b/framework/testing/MOM_file_parser_tests.F90 @@ -0,0 +1,1924 @@ +module MOM_file_parser_tests + +use posix, only : chmod + +use MOM_file_parser, only : param_file_type +use MOM_file_parser, only : open_param_file +use MOM_file_parser, only : close_param_file +use MOM_file_parser, only : read_param +use MOM_file_parser, only : log_param +use MOM_file_parser, only : get_param +use MOM_file_parser, only : log_version +use MOM_file_parser, only : clearParameterBlock +use MOM_file_parser, only : openParameterBlock +use MOM_file_parser, only : closeParameterBlock + +use MOM_time_manager, only : time_type +use MOM_time_manager, only : set_date +use MOM_time_manager, only : set_ticks_per_second +use MOM_time_manager, only : set_calendar_type +use MOM_time_manager, only : NOLEAP, NO_CALENDAR + +use MOM_error_handler, only : assert +use MOM_error_handler, only : MOM_error +use MOM_error_handler, only : FATAL + +use MOM_unit_testing, only : TestSuite +use MOM_unit_testing, only : string +use MOM_unit_testing, only : create_test_file +use MOM_unit_testing, only : delete_test_file + +implicit none ; private + +public :: run_file_parser_tests + +character(len=*), parameter :: param_filename = 'TEST_input' +character(len=*), parameter :: missing_param_filename = 'MISSING_input' +character(len=*), parameter :: netcdf_param_filename = 'TEST_input.nc' + +character(len=*), parameter :: sample_param_name = 'SAMPLE_PARAMETER' +character(len=*), parameter :: missing_param_name = 'MISSING_PARAMETER' + +character(len=*), parameter :: module_name = "SAMPLE_module" +character(len=*), parameter :: module_version = "SAMPLE_version" +character(len=*), parameter :: module_desc = "Description here" + +character(len=9), parameter :: param_docfiles(4) = [ & + "all ", & + "debugging", & + "layout ", & + "short " & +] + +contains + +subroutine test_open_param_file + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call close_param_file(param) +end subroutine test_open_param_file + + +subroutine test_close_param_file_quiet + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call close_param_file(param, quiet_close=.true.) +end subroutine test_close_param_file_quiet + + +subroutine test_open_param_file_component + type(param_file_type) :: param + integer :: i + + call create_test_file(param_filename) + + call open_param_file(param_filename, param, component="TEST") + call close_param_file(param, component="TEST") +end subroutine test_open_param_file_component + + +subroutine cleanup_open_param_file_component + integer :: i + + call delete_test_file(param_filename) + do i = 1, 4 + call delete_test_file("TEST_parameter_doc."//param_docfiles(i)) + enddo +end subroutine cleanup_open_param_file_component + + +subroutine test_open_param_file_docdir + ! TODO: Make a new directory...? + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param, doc_file_dir='./') + call close_param_file(param) +end subroutine test_open_param_file_docdir + + +subroutine test_open_param_file_empty_filename + type(param_file_type) :: param + + call open_param_file('', param) + ! FATAL; return to program +end subroutine test_open_param_file_empty_filename + + +subroutine test_open_param_file_long_name + !> Store filename in a variable longer than FILENAME_LENGTH + type(param_file_type) :: param + character(len=250) :: long_filename + + long_filename = param_filename + + call create_test_file(long_filename) + + call open_param_file(long_filename, param) + call close_param_file(param) +end subroutine test_open_param_file_long_name + + +subroutine test_missing_param_file + type(param_file_type) :: param + logical :: file_exists + + inquire(file=missing_param_filename, exist=file_exists) + if (file_exists) call MOM_error(FATAL, "Missing file already exists!") + + call open_param_file(missing_param_filename, param) + ! FATAL; return to program +end subroutine test_missing_param_file + + +subroutine test_open_param_file_ioerr + type(param_file_type) :: param + ! NOTE: Induce an I/O error in open() by making the file unreadable + + call create_test_file(param_filename, mode=int(o'000')) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_open_param_file_ioerr + + +subroutine cleanup_open_param_file_ioerr + integer :: rc + + rc = chmod(param_filename, int(o'700')) + call cleanup_file_parser() +end subroutine cleanup_open_param_file_ioerr + + +subroutine test_open_param_file_netcdf + type(param_file_type) :: param + + call create_test_file(netcdf_param_filename) + + call open_param_file(netcdf_param_filename, param) + ! FATAL; return to program +end subroutine test_open_param_file_netcdf + + +subroutine cleanup_open_param_file_netcdf + integer :: param_unit + logical :: is_open + + call delete_test_file(netcdf_param_filename) +end subroutine cleanup_open_param_file_netcdf + + +subroutine test_open_param_file_checkable + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param, checkable=.false.) + call close_param_file(param) +end subroutine test_open_param_file_checkable + + +subroutine test_reopen_param_file + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call open_param_file(param_filename, param) + call close_param_file(param) +end subroutine test_reopen_param_file + + +subroutine test_open_param_file_no_doc + type(param_file_type) :: param + type(string) :: lines(1) + + lines(1) = string('DOCUMENT_FILE = ""') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call close_param_file(param) +end subroutine test_open_param_file_no_doc + + +subroutine test_read_param_int + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = '123' + integer, parameter :: sample_result = 123 + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_int + + +subroutine test_read_param_int_missing + type(param_file_type) :: param + integer :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_int_missing + + +subroutine test_read_param_int_undefined + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines = string('#undef ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_int_undefined + + +subroutine test_read_param_int_type_err + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = not_an_integer') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_int_type_err + + +subroutine test_read_param_int_array + type(param_file_type) :: param + integer :: sample(3) + type(string) :: lines(1) + character(len=*), parameter :: sample_input = '1, 2, 3' + integer, parameter :: sample_result(3) = [1, 2, 3] + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(all(sample == sample_result), 'Incorrect value') +end subroutine test_read_param_int_array + + +subroutine test_read_param_int_array_missing + type(param_file_type) :: param + integer :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_int_array_missing + + +subroutine test_read_param_int_array_undefined + type(param_file_type) :: param + integer :: sample(3) + type(string) :: lines(1) + + lines = string('#undef ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_int_array_undefined + + +subroutine test_read_param_int_array_type_err + type(param_file_type) :: param + integer :: sample(3) + type(string) :: lines(1) + + lines = string(sample_param_name // ' = not_an_int_array') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_int_array_type_err + + +subroutine test_read_param_real + type(param_file_type) :: param + real :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = '3.14' + real, parameter :: sample_result = 3.14 + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_real + + +subroutine test_read_param_real_missing + type(param_file_type) :: param + real :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_real_missing + + +subroutine test_read_param_real_undefined + type(param_file_type) :: param + real :: sample + type(string) :: lines(1) + + lines = string('#undef ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_real_undefined + + +subroutine test_read_param_real_type_err + type(param_file_type) :: param + real :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = not_a_real') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_real_type_err + + +subroutine test_read_param_real_array + type(param_file_type) :: param + real :: sample(3) + type(string) :: lines(1) + character(len=*), parameter :: sample_input = '1., 2., 3.' + real, parameter :: sample_result(3) = [1., 2., 3.] + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(all(sample == sample_result), 'Incorrect value') +end subroutine test_read_param_real_array + + +subroutine test_read_param_real_array_missing + type(param_file_type) :: param + real :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_real_array_missing + + +subroutine test_read_param_real_array_undefined + type(param_file_type) :: param + real :: sample(3) + type(string) :: lines(1) + + lines = string('#undef ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_real_array_undefined + + +subroutine test_read_param_real_array_type_err + type(param_file_type) :: param + real :: sample(3) + type(string) :: lines(1) + + lines = string(sample_param_name // ' = not_a_real_array') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_real_array_type_err + + +subroutine test_read_param_logical + type(param_file_type) :: param + logical :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = 'True' + logical, parameter :: sample_result = .true. + + lines = string(sample_param_name // ' = ' // sample_input) + + !lines = string(sample_param_name // ' = True') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample .eqv. sample_result, 'Incorrect value') +end subroutine test_read_param_logical + + +subroutine test_read_param_logical_missing + type(param_file_type) :: param + logical :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_logical_missing + + +subroutine test_read_param_char_no_delim + type(param_file_type) :: param + character(len=8) :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = "abcdefgh" + character(len=*), parameter :: sample_result = "abcdefgh" + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_char_no_delim + + +subroutine test_read_param_char_quote_delim + type(param_file_type) :: param + character(len=8) :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = '"abcdefgh"' + character(len=*), parameter :: sample_result = "abcdefgh" + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_char_quote_delim + + +subroutine test_read_param_char_apostrophe_delim + type(param_file_type) :: param + character(len=8) :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = "'abcdefgh'" + character(len=*), parameter :: sample_result = "abcdefgh" + + lines = string(sample_param_name // " = " // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_char_apostrophe_delim + + +subroutine test_read_param_char_missing + type(param_file_type) :: param + character(len=8) :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_char_missing + + +subroutine test_read_param_char_array + type(param_file_type) :: param + character(len=3) :: sample(3) + type(string) :: lines(1) + character(len=*), parameter :: sample_input = '"abc", "def", "ghi"' + character(len=*), parameter :: sample_result(3) = ["abc", "def", "ghi"] + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(all(sample == sample_result), 'Incorrect value') +end subroutine test_read_param_char_array + + +subroutine test_read_param_char_array_missing + type(param_file_type) :: param + character(len=8) :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_char_array_missing + + +subroutine test_read_param_time_date + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 1980-01-01 00:00:00') + call create_test_file(param_filename, lines) + + call set_calendar_type(NOLEAP) + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) +end subroutine test_read_param_time_date + + +subroutine test_read_param_time_date_bad_format + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 1980--01--01 00::00::00') + call create_test_file(param_filename, lines) + + call set_calendar_type(NOLEAP) + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_time_date_bad_format + + +subroutine test_read_param_time_tuple + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 1980,1,1,0,0,0') + call create_test_file(param_filename, lines) + + call set_calendar_type(NOLEAP) + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) +end subroutine test_read_param_time_tuple + + +subroutine test_read_param_time_bad_tuple + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 1980, 1') + call create_test_file(param_filename, lines) + + call set_calendar_type(NOLEAP) + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_time_bad_tuple + + +subroutine test_read_param_time_bad_tuple_values + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 0, 0, 0, 0, 0, 0') + call create_test_file(param_filename, lines) + + call set_calendar_type(NOLEAP) + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_time_bad_tuple_values + + +subroutine test_read_param_time_unit + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 0.5') + call create_test_file(param_filename, lines) + + call set_calendar_type(NOLEAP) + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample, timeunit=86400.) + call close_param_file(param) +end subroutine test_read_param_time_unit + + +subroutine test_read_param_time_missing + type(param_file_type) :: param + type(time_type) :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_time_missing + + +subroutine test_read_param_time_undefined + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string('#undef ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_time_undefined + + +subroutine test_read_param_time_type_err + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 1., 2., 3., 4., 5., 6.') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_time_type_err + +! Generic parameter tests + +subroutine test_read_param_unused_fatal + type(param_file_type) :: param + type(string) :: lines(2) + + lines = [ & + string('FATAL_UNUSED_PARAMS = True'), & + string(sample_param_name // ' = 1') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call close_param_file(param) + ! FATAL; return to program +end subroutine test_read_param_unused_fatal + + +subroutine test_read_param_replace_tabs + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = "1" + integer, parameter :: sample_result = 1 + character, parameter :: tab = achar(9) + + lines = string(sample_param_name // tab // '=' // tab // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_replace_tabs + + +subroutine test_read_param_pad_equals + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = "1" + integer, parameter :: sample_result = 1 + + lines = string(sample_param_name // '=' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_pad_equals + + +subroutine test_read_param_multiline_param + type(param_file_type) :: param + integer :: sample + type(string) :: lines(2) + integer, parameter :: sample_result = 1 + character, parameter :: backslash = achar(92) + + lines = [ & + string(sample_param_name // ' = ' // backslash), & + string(' 1') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect result') +end subroutine test_read_param_multiline_param + + +subroutine test_read_param_multiline_param_unclosed + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + character, parameter :: backslash = achar(92) + + lines = string(sample_param_name // ' = ' // backslash) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_read_param_multiline_param_unclosed + + +subroutine test_read_param_multiline_comment + type(param_file_type) :: param + integer :: sample + + type(string) :: lines(6) + + lines = [ & + string('/* First C comment line'), & + string(' Second C comment line */'), & + string('// First C++ comment line'), & + string('// Second C++ comment line'), & + string('! First Fortran comment line'), & + string('! Second Fortran comment line') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call close_param_file(param) +end subroutine test_read_param_multiline_comment + + +subroutine test_read_param_multiline_comment_unclosed + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines = string('/* Unclosed C comment') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_read_param_multiline_comment_unclosed + + +subroutine test_read_param_misplaced_quote + type(param_file_type) :: param + character(len=20) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = "abc') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_read_param_misplaced_quote + + +subroutine test_read_param_define + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + integer, parameter :: sample_result = 2 + + lines = string('#define ' // sample_param_name // ' 2') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_define + + +subroutine test_read_param_define_as_flag + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines = string('#define ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) +end subroutine test_read_param_define_as_flag + + +subroutine test_read_param_override + type(param_file_type) :: param + integer :: sample + type(string) :: lines(2) + integer, parameter :: sample_result = 2 + + lines = [ & + string(sample_param_name // ' = 1'), & + string('#override ' // sample_param_name // ' = 2') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_override + + +subroutine test_read_param_override_misplaced + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines(1) = string('#define #override ' // sample_param_name // ' = 1') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_read_param_override_misplaced + + +subroutine test_read_param_override_twice + type(param_file_type) :: param + integer :: sample + type(string) :: lines(3) + + lines = [ & + string(sample_param_name // ' = 1'), & + string('#override ' // sample_param_name // ' = 2'), & + string('#override ' // sample_param_name // ' = 3') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_override_twice + + +subroutine test_read_param_override_repeat + type(param_file_type) :: param + integer :: sample + type(string) :: lines(3) + + lines = [ & + string(sample_param_name // ' = 1'), & + string('#override ' // sample_param_name // ' = 2'), & + string('#override ' // sample_param_name // ' = 2') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_override_repeat + + +subroutine test_read_param_override_warn_chain + type(param_file_type) :: param + integer :: sample + character(len=*), parameter :: other_param_name = 'OTHER_PARAMETER' + type(string) :: lines(4) + + lines = [ & + string(other_param_name // ' = 1'), & + string(sample_param_name // ' = 2'), & + string('#override ' // other_param_name // ' = 3'), & + string('#override ' // sample_param_name // ' = 4') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! First invoke the "other" override, adding it to the chain + call read_param(param, other_param_name, sample) + ! Now invoke the "sample" override, with "other" in the chain + call read_param(param, sample_param_name, sample) + ! Finally, re-invoke the "other" override, having already been issued. + call read_param(param, other_param_name, sample) + call close_param_file(param) +end subroutine test_read_param_override_warn_chain + + +subroutine test_read_param_assign_after_override + type(param_file_type) :: param + integer :: sample + type(string) :: lines(2) + + lines = [ & + string('#override ' // sample_param_name // ' = 2'), & + string(sample_param_name // ' = 3') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) +end subroutine test_read_param_assign_after_override + + +subroutine test_read_param_override_no_def + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines(1) = string('#override ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_override_no_def + + +subroutine test_read_param_assign_twice + type(param_file_type) :: param + integer :: sample + type(string) :: lines(2) + + lines = [ & + string(sample_param_name // ' = 1'), & + string(sample_param_name // ' = 2') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_assign_twice + + +subroutine test_read_param_assign_repeat + type(param_file_type) :: param + integer :: sample + type(string) :: lines(2) + + lines = [ & + string(sample_param_name // ' = 1'), & + string(sample_param_name // ' = 1') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) +end subroutine test_read_param_assign_repeat + + +subroutine test_read_param_null_stmt + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines(1) = string(sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_null_stmt + + +subroutine test_read_param_assign_in_define + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines = string('#define ' // sample_param_name // ' = 1') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_assign_in_define + +!-- Blocks + +subroutine test_read_param_block + type(param_file_type) :: param + integer :: sample + type(string) :: lines(3) + integer, parameter :: sample_result = 123 + + lines = [ & + string('ABC%'), & + string('ABC%' // sample_param_name // ' = 123'), & + string('%ABC') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call openParameterBlock(param, 'ABC') + call read_param(param, sample_param_name, sample) + call closeParameterBlock(param) + call clearParameterBlock(param) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_block + + +! TODO: This test fails due to an implementation issue. +subroutine test_read_param_block_stack + type(param_file_type) :: param + integer :: sample + type(string) :: lines(5) + + lines = [ & + string('ABC%'), & + string('DEF%'), & + string(sample_param_name // ' = 123'), & + string('DEF%'), & + string('%ABC') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call openParameterBlock(param, 'ABC') + call openParameterBlock(param, 'DEF') + call read_param(param, sample_param_name, sample) + call closeParameterBlock(param) + call clearParameterBlock(param) + call close_param_file(param) +end subroutine test_read_param_block_stack + + +! NOTE: This is a simpler version of the block_stack test which works +subroutine test_read_param_block_inline_stack + type(param_file_type) :: param + integer :: sample + type(string) :: lines(3) + + lines = [ & + string('ABC%'), & + string('DEF%' // sample_param_name // ' = 123'), & + string('%ABC') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call openParameterBlock(param, 'ABC') + call openParameterBlock(param, 'DEF') + call read_param(param, sample_param_name, sample) + call closeParameterBlock(param) + call clearParameterBlock(param) + call close_param_file(param) +end subroutine test_read_param_block_inline_stack + + +subroutine test_read_param_block_empty_pop + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call openParameterBlock(param, '%') + call openParameterBlock(param, 'ABC') + call closeParameterBlock(param) + call closeParameterBlock(param) + ! FATAL; return to program +end subroutine test_read_param_block_empty_pop + + +subroutine test_read_param_block_close_unnamed + type(param_file_type) :: param + type(string) :: lines(2) + + lines = [ & + string('ABC%'), & + string('%ABC') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call openParameterBlock(param, 'ABC') + call closeParameterBlock(param) + call closeParameterBlock(param) + ! FATAL; return to program +end subroutine test_read_param_block_close_unnamed + + +subroutine test_read_param_block_close_unopened + type(param_file_type) :: param + type(string) :: lines(1) + + lines = string('%CBA') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_read_param_block_close_unopened + + +subroutine test_read_param_block_unmatched + type(param_file_type) :: param + type(string) :: lines(2) + + lines = [ & + string('ABC%'), & + string('%CBA') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_read_param_block_unmatched + + +subroutine test_open_unallocated_block + type(param_file_type) :: param + character(len=*), parameter :: block_name = "ABC" + + call openParameterBlock(param, block_name) + ! FATAL; return to program +end subroutine test_open_unallocated_block + + +subroutine test_close_unallocated_block + type(param_file_type) :: param + + call closeParameterBlock(param) + ! FATAL; return to program +end subroutine test_close_unallocated_block + + +subroutine test_clear_unallocated_block + type(param_file_type) :: param + + call clearParameterBlock(param) + ! FATAL; return to program +end subroutine test_clear_unallocated_block + + +subroutine test_read_param_block_outside_block + type(param_file_type) :: param + integer :: sample + type(string) :: lines(3) + + lines = [ & + string('ABC%'), & + string(sample_param_name // ' = 1'), & + string('%ABC') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) +end subroutine test_read_param_block_outside_block + +!--- + +subroutine test_log_version_cs + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call log_version(param, module_name, module_version, desc=module_desc) + call close_param_file(param) +end subroutine test_log_version_cs + + +subroutine test_log_version_plain + call log_version(module_name, module_version) +end subroutine test_log_version_plain + + +subroutine test_log_param_int + type(param_file_type) :: param + integer, parameter :: sample = 1 + character(len=*), parameter :: desc = "Parameter description" + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call log_param(param, module_name, sample_param_name, sample, desc=desc) + call close_param_file(param) +end subroutine test_log_param_int + + +subroutine test_log_param_int_array + type(param_file_type) :: param + integer, parameter :: sample(3) = [1, 2, 3] + character(len=*), parameter :: desc = "Parameter description" + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call log_param(param, module_name, sample_param_name, sample, desc=desc) + call close_param_file(param) +end subroutine test_log_param_int_array + + +subroutine test_log_param_real + type(param_file_type) :: param + real, parameter :: sample = 1. + character(len=*), parameter :: desc = "Parameter description" + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call log_param(param, module_name, sample_param_name, sample, desc=desc, units="") + call close_param_file(param) +end subroutine test_log_param_real + + +subroutine test_log_param_real_array + type(param_file_type) :: param + real, parameter :: sample(3) = [1., 2., 3.] + character(len=*), parameter :: desc = "Parameter description" + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call log_param(param, module_name, sample_param_name, sample, desc=desc, units="") + call close_param_file(param) +end subroutine test_log_param_real_array + + +subroutine test_log_param_time + type(param_file_type) :: param + type(time_type) :: sample + character(len=*), parameter :: desc = "Parameter description" + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 1980,1,1,0,0,0') + + call set_calendar_type(NOLEAP) + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call log_param(param, module_name, sample_param_name, sample, desc=desc) + call close_param_file(param) +end subroutine test_log_param_time + + +subroutine test_log_param_time_as_date + type(param_file_type) :: param + type(time_type) :: sample + character(len=*), parameter :: desc = "Parameter description" + + call set_calendar_type(NOLEAP) + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + sample = set_date(1980, 1, 1, 0, 0, 0) + call log_param(param, module_name, sample_param_name, sample, desc=desc, & + log_date=.true.) + call close_param_file(param) +end subroutine test_log_param_time_as_date + + +subroutine test_log_param_time_as_date_default + type(param_file_type) :: param + type(time_type) :: sample + type(time_type) :: default_date + character(len=*), parameter :: desc = "Parameter description" + + call set_calendar_type(NOLEAP) + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + + call set_ticks_per_second(60) + default_date = set_date(1980, 1, 1, 0, 0, 0, 30) + call log_param(param, module_name, sample_param_name, sample, desc=desc, & + log_date=.true., default=default_date) + + call set_ticks_per_second(300) + default_date = set_date(1980, 1, 1, 0, 0, 0, 150) + call log_param(param, module_name, sample_param_name, sample, desc=desc, & + log_date=.true., default=default_date) + + call close_param_file(param) +end subroutine test_log_param_time_as_date_default + + +subroutine test_log_param_time_as_date_tick + type(param_file_type) :: param + type(time_type) :: sample + character(len=*), parameter :: desc = "Parameter description" + + call set_calendar_type(NOLEAP) + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call log_param(param, module_name, sample_param_name, sample, desc=desc, & + log_date=.true.) + call close_param_file(param) +end subroutine test_log_param_time_as_date_tick + + +subroutine test_log_param_time_with_unit + type(param_file_type) :: param + type(time_type) :: sample + type(time_type) :: default_date + character(len=*), parameter :: desc = "Parameter description" + character(len=*), parameter :: sample_units = "days since whatever" + + call set_calendar_type(NOLEAP) + call create_test_file(param_filename) + + call set_ticks_per_second(60) + sample = set_date(1980, 1, 1, 0, 0, 0, 30) + + default_date = set_date(1980, 1, 1, 0, 0, 0, 30) + + call open_param_file(param_filename, param) + call log_param(param, module_name, sample_param_name, sample, desc=desc, & + units=sample_units, timeunit=86400., default=default_date) + call close_param_file(param) +end subroutine test_log_param_time_with_unit + + +subroutine test_log_param_time_with_timeunit + type(param_file_type) :: param + type(time_type) :: sample + integer :: i + character(len=*), parameter :: desc = "Parameter description" + real, parameter :: timeunits(5) = [1., 3600., 86400., 3.1e7, 1e8] + + call set_calendar_type(NOLEAP) + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + do i = 1,5 + call log_param(param, module_name, sample_param_name, sample, desc=desc, & + timeunit=timeunits(i)) + enddo + call close_param_file(param) +end subroutine test_log_param_time_with_timeunit + +!---- + +subroutine test_get_param_int + type(param_file_type) :: param + integer :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample) + call close_param_file(param) +end subroutine test_get_param_int + + +subroutine test_get_param_int_no_read_no_log + type(param_file_type) :: param + integer :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_int_no_read_no_log + + +subroutine test_get_param_int_array + type(param_file_type) :: param + integer :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample) + call close_param_file(param) +end subroutine test_get_param_int_array + + +subroutine test_get_param_int_array_no_read_no_log + type(param_file_type) :: param + integer :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_int_array_no_read_no_log + + +subroutine test_get_param_real + type(param_file_type) :: param + real :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, units="") + call close_param_file(param) +end subroutine test_get_param_real + + +subroutine test_get_param_real_no_read_no_log + type(param_file_type) :: param + real :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, units="", & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_real_no_read_no_log + + +subroutine test_get_param_real_array + type(param_file_type) :: param + real :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, units="") + call close_param_file(param) +end subroutine test_get_param_real_array + + +subroutine test_get_param_real_array_no_read_no_log + type(param_file_type) :: param + real :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, units="", & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_real_array_no_read_no_log + + +subroutine test_get_param_char + type(param_file_type) :: param + character(len=8) :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample) + call close_param_file(param) +end subroutine test_get_param_char + + +subroutine test_get_param_char_no_read_no_log + type(param_file_type) :: param + character(len=8) :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_char_no_read_no_log + + +subroutine test_get_param_char_array + type(param_file_type) :: param + character(len=8) :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample) + call close_param_file(param) +end subroutine test_get_param_char_array + + +subroutine test_get_param_logical + type(param_file_type) :: param + logical :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample) + call close_param_file(param) +end subroutine test_get_param_logical + + +subroutine test_get_param_logical_no_read_no_log + type(param_file_type) :: param + logical :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_logical_no_read_no_log + + +subroutine test_get_param_logical_default + type(param_file_type) :: param + logical :: sample + logical, parameter :: default_value = .false. + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, & + default=default_value) + call close_param_file(param) +end subroutine test_get_param_logical_default + + +subroutine test_get_param_time + type(param_file_type) :: param + type(time_type) :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample) + call close_param_file(param) +end subroutine test_get_param_time + + +subroutine test_get_param_time_no_read_no_log + type(param_file_type) :: param + type(time_type) :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_time_no_read_no_log + + +! Utility functions +! TODO: Move to a generic testing module + +subroutine cleanup_file_parser + integer :: i + + call delete_test_file(param_filename) + do i = 1, 4 + call delete_test_file("MOM_parameter_doc."//param_docfiles(i)) + enddo + + call set_calendar_type(NO_CALENDAR) +end subroutine cleanup_file_parser + + +subroutine run_file_parser_tests + ! testing... + type(TestSuite) :: suite + + ! Delete any pre-existing test parameter files + call cleanup_file_parser + + ! Build the test suite + suite = TestSuite() + suite%cleanup => cleanup_file_parser + + call suite%add(test_open_param_file, "test_open_param_file") + + call suite%add(test_close_param_file_quiet, "test_close_param_file_quiet") + + call suite%add(test_open_param_file_component, "test_open_param_file_component", & + cleanup=cleanup_open_param_file_component) + + call suite%add(test_open_param_file_docdir, "test_open_param_file_docdir") + + call suite%add(test_open_param_file_empty_filename, & + "test_open_param_file_empty_filename", fatal=.true.) + + call suite%add(test_open_param_file_long_name, & + "test_open_param_file_longname") + + call suite%add(test_missing_param_file, "test_missing_param_file", & + fatal=.true.) + + call suite%add(test_open_param_file_ioerr, "test_open_param_file_ioerr", & + fatal=.true., cleanup=cleanup_open_param_file_ioerr) + + call suite%add(test_open_param_file_checkable, & + "test_open_param_file_checkable") + + call suite%add(test_reopen_param_file, "test_reopen_param_file") + + call suite%add(test_open_param_file_netcdf, "test_open_param_file_netcdf", & + fatal=.true., cleanup=cleanup_open_param_file_netcdf) + + call suite%add(test_open_param_file_no_doc, "test_open_param_file_no_doc") + + call suite%add(test_read_param_int, "test_read_param_int") + + call suite%add(test_read_param_int_missing, "test_read_param_int_missing", & + fatal=.true.) + + call suite%add(test_read_param_int_undefined, & + "test_read_param_int_undefined", fatal=.true.) + + call suite%add(test_read_param_int_type_err, & + "test_read_param_int_type_err", fatal=.true.) + + call suite%add(test_read_param_int_array, "test_read_param_int_array") + + call suite%add(test_read_param_int_array_missing, & + "test_read_param_int_array_missing", fatal=.true.) + + call suite%add(test_read_param_int_array_undefined, & + "test_read_param_int_array_undefined", fatal=.true.) + + call suite%add(test_read_param_int_array_type_err, & + "test_read_param_int_array_type_err", fatal=.true.) + + call suite%add(test_read_param_real, "test_read_param_real") + + call suite%add(test_read_param_real_missing, & + "test_read_param_real_missing", fatal=.true.) + + call suite%add(test_read_param_real_undefined, & + "test_read_param_real_undefined", fatal=.true.) + + call suite%add(test_read_param_real_type_err, & + "test_read_param_real_type_err", fatal=.true.) + + call suite%add(test_read_param_real_array, "test_read_param_real_array") + + call suite%add(test_read_param_real_array_missing, & + "test_read_param_real_array_missing", fatal=.true.) + + call suite%add(test_read_param_real_array_undefined, & + "test_read_param_real_array_undefined", fatal=.true.) + + call suite%add(test_read_param_real_array_type_err, & + "test_read_param_real_array_type_err", fatal=.true.) + + call suite%add(test_read_param_logical, "test_read_param_logical") + + call suite%add(test_read_param_logical_missing, & + "test_read_param_logical_missing", fatal=.true.) + + call suite%add(test_read_param_char_no_delim, & + "test_read_param_char_no_delim") + + call suite%add(test_read_param_char_quote_delim, & + "test_read_param_char_quote_delim") + + call suite%add(test_read_param_char_apostrophe_delim, & + "test_read_param_char_apostrophe_delim") + + call suite%add(test_read_param_char_missing, & + "test_read_param_char_missing", fatal=.true.) + + call suite%add(test_read_param_char_array, "test_read_param_char_array") + + call suite%add(test_read_param_char_array_missing, & + "test_read_param_char_array_missing", fatal=.true.) + + call suite%add(test_read_param_time_date, "test_read_param_time_date") + + call suite%add(test_read_param_time_date_bad_format, & + "test_read_param_time_date_bad_format", fatal=.true.) + + call suite%add(test_read_param_time_tuple, "test_read_param_time_tuple") + + call suite%add(test_read_param_time_bad_tuple, & + "test_read_param_time_bad_tuple", fatal=.true.) + + call suite%add(test_read_param_time_bad_tuple_values, & + "test_read_param_time_bad_tuple_values", fatal=.true.) + + call suite%add(test_read_param_time_missing, & + "test_read_param_time_missing", fatal=.true.) + + call suite%add(test_read_param_time_undefined, & + "test_read_param_time_undefined", fatal=.true.) + + call suite%add(test_read_param_time_type_err, & + "test_read_param_time_type_err", fatal=.true.) + + call suite%add(test_read_param_time_unit, "test_read_param_time_unit") + + call suite%add(test_read_param_unused_fatal, & + "test_read_param_unused_fatal", fatal=.true.) + + call suite%add(test_read_param_multiline_comment, & + "test_read_param_multiline_comment") + + call suite%add(test_read_param_multiline_comment_unclosed, & + "test_read_param_multiline_comment_unclosed", fatal=.true.) + + call suite%add(test_read_param_multiline_param, & + "test_read_param_multiline_param") + + call suite%add(test_read_param_multiline_param_unclosed, & + "test_read_param_multiline_param_unclosed", fatal=.true.) + + call suite%add(test_read_param_replace_tabs, "test_read_param_replace_tabs") + + call suite%add(test_read_param_pad_equals, "test_read_param_pad_equals") + + call suite%add(test_read_param_misplaced_quote, & + "test_read_param_misplaced_quote", fatal=.true.) + + call suite%add(test_read_param_define, "test_read_param_define") + + call suite%add(test_read_param_define_as_flag, & + "test_read_param_define_as_flag") + + call suite%add(test_read_param_override, "test_read_param_override") + + call suite%add(test_read_param_override_misplaced, & + "test_read_param_override_misplaced", fatal=.true.) + + call suite%add(test_read_param_override_twice, & + "test_read_param_override_twice", fatal=.true.) + + call suite%add(test_read_param_override_repeat, & + "test_read_param_override_repeat", fatal=.true.) + + call suite%add(test_read_param_override_warn_chain, & + "test_read_param_override_warn_chain") + + call suite%add(test_read_param_override_no_def, & + "test_read_param_override_no_def", fatal=.true.) + + call suite%add(test_read_param_assign_after_override, & + "test_read_param_assign_after_override") + + call suite%add(test_read_param_assign_twice, & + "test_read_param_assign_twice", fatal=.true.) + + call suite%add(test_read_param_assign_repeat, & + "test_read_param_assign_repeat") + + call suite%add(test_read_param_null_stmt, "test_read_param_null_stmt", & + fatal=.true.) + + call suite%add(test_read_param_assign_in_define, & + "test_read_param_assign_in_define", fatal=.true.) + + call suite%add(test_read_param_block, "test_read_param_block") + + ! FIXME: Test does not pass + !call suite%add(test_read_param_block_stack, "test_read_param_block_stack") + + call suite%add(test_read_param_block_inline_stack, & + "test_read_param_block_inline_stack") + + call suite%add(test_read_param_block_empty_pop, & + "test_read_param_block_empty_pop", fatal=.true.) + + call suite%add(test_read_param_block_close_unopened, & + "test_read_param_block_close_unopened", fatal=.true.) + + call suite%add(test_read_param_block_close_unnamed, & + "test_read_param_block_close_unnamed", fatal=.true.) + + call suite%add(test_read_param_block_unmatched, & + "test_read_param_block_unmatched", fatal=.true.) + + call suite%add(test_read_param_block_outside_block, & + "test_read_param_block_outside_block") + + call suite%add(test_open_unallocated_block, "test_open_unallocated_block", & + fatal=.true.) + + call suite%add(test_close_unallocated_block, & + "test_close_unallocated_block", fatal=.true.) + + call suite%add(test_clear_unallocated_block, & + "test_clear_unallocated_block", fatal=.true.) + + call suite%add(test_log_version_cs, "test_log_version_cs") + + call suite%add(test_log_version_plain, "test_log_version_plain") + + call suite%add(test_log_param_int, "test_log_param_int") + + call suite%add(test_log_param_int_array, "test_log_param_int_array") + + call suite%add(test_log_param_real, "test_log_param_real") + + call suite%add(test_log_param_real_array, "test_log_param_real_array") + + call suite%add(test_log_param_time, "test_log_param_time") + + call suite%add(test_log_param_time_as_date, "test_log_param_time_as_date") + + call suite%add(test_log_param_time_as_date_default, & + "test_log_param_time_as_date_default") + + call suite%add(test_log_param_time_as_date_tick, & + "test_log_param_time_as_date_tick") + + call suite%add(test_log_param_time_with_unit, & + "test_log_param_time_with_unit") + + call suite%add(test_log_param_time_with_timeunit, & + "test_log_param_time_with_timeunit") + + call suite%add(test_get_param_int, "test_get_param_int") + + call suite%add(test_get_param_int_no_read_no_log, & + "test_get_param_int_no_read_no_log") + + call suite%add(test_get_param_int_array, "test_get_param_int_array") + + call suite%add(test_get_param_int_array_no_read_no_log, & + "test_get_param_int_array_no_read_no_log") + + call suite%add(test_get_param_real, "test_get_param_real") + + call suite%add(test_get_param_real_no_read_no_log, & + "test_get_param_real_n_read_no_log") + + call suite%add(test_get_param_real_array, "test_get_param_real_array") + + call suite%add(test_get_param_real_array_no_read_no_log, & + "test_get_param_real_array_no_read_no_log") + + call suite%add(test_get_param_char, "test_get_param_char") + + call suite%add(test_get_param_char_no_read_no_log, & + "test_get_param_char_no_read_no_log") + + call suite%add(test_get_param_char_array, "test_get_param_char_array") + + call suite%add(test_get_param_logical, "test_get_param_logical") + + call suite%add(test_get_param_logical_default, & + "test_get_param_logical_default") + + call suite%add(test_get_param_logical_no_read_no_log, & + "test_get_param_logical_no_read_no_log") + + call suite%add(test_get_param_time, "test_get_param_time") + + call suite%add(test_get_param_time_no_read_no_log, & + "test_get_param_time_np_read_no_log") + + call suite%run() +end subroutine run_file_parser_tests + +end module MOM_file_parser_tests diff --git a/framework/version_variable.h b/framework/version_variable.h new file mode 100644 index 0000000000..7cccf999fe --- /dev/null +++ b/framework/version_variable.h @@ -0,0 +1,5 @@ +#ifdef _FILE_VERSION + character(len=*), parameter :: version = _FILE_VERSION +#else + character(len=*), parameter :: version = 'unknown' +#endif diff --git a/ice_shelf/MOM_ice_shelf.F90 b/ice_shelf/MOM_ice_shelf.F90 new file mode 100644 index 0000000000..b435b0a677 --- /dev/null +++ b/ice_shelf/MOM_ice_shelf.F90 @@ -0,0 +1,2361 @@ +!> Implements the thermodynamic aspects of ocean / ice-shelf interactions, +!! along with a crude placeholder for a later implementation of full +!! ice shelf dynamics, all using the MOM framework and coding style. +module MOM_ice_shelf + +! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only : rotate_array +use MOM_constants, only : hlf +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE +use MOM_coms, only : num_PEs +use MOM_data_override, only : data_override +use MOM_diag_mediator, only : MOM_diag_ctrl=>diag_ctrl +use MOM_IS_diag_mediator, only : post_data=>post_IS_data +use MOM_IS_diag_mediator, only : register_diag_field=>register_MOM_IS_diag_field, safe_alloc_ptr +use MOM_IS_diag_mediator, only : set_IS_axes_info, diag_ctrl, time_type +use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end +use MOM_IS_diag_mediator, only : set_IS_diag_mediator_grid +use MOM_IS_diag_mediator, only : enable_averages, disable_averaging +use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_infrastructure_init +use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_close_registration +use MOM_domains, only : MOM_domains_init, pass_var, pass_vector, clone_MOM_domain +use MOM_domains, only : TO_ALL, CGRID_NE, BGRID_NE, CORNER +use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_grid, only : MOM_grid_init, ocean_grid_type +use MOM_grid_initialize, only : set_grid_metrics +use MOM_hor_index, only : hor_index_type, hor_index_init +use MOM_hor_index, only : rotate_hor_index +use MOM_fixed_initialization, only : MOM_initialize_topography +use MOM_fixed_initialization, only : MOM_initialize_rotation +use user_initialization, only : user_initialize_topography +use MOM_io, only : field_exists, file_exists, MOM_read_data, write_version_number +use MOM_io, only : slasher, fieldtype, vardesc, var_desc +use MOM_io, only : close_file, SINGLE_FILE, MULTIPLE +use MOM_restart, only : register_restart_field, save_restart +use MOM_restart, only : restart_init, restore_state, MOM_restart_CS, register_restart_pair +use MOM_time_manager, only : time_type, time_type_to_real, real_to_time, operator(>), operator(-) +use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid +use MOM_transcribe_grid, only : rotate_dyngrid +use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling +use MOM_variables, only : surface, allocate_surface_state +use MOM_variables, only : rotate_surface_state +use MOM_forcing_type, only : forcing, allocate_forcing_type, MOM_forcing_chksum +use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, MOM_mech_forcing_chksum +use MOM_forcing_type, only : copy_common_forcing_fields, rotate_forcing, rotate_mech_forcing +use MOM_get_input, only : directories, Get_MOM_input +use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze, EOS_domain +use MOM_EOS, only : EOS_type, EOS_init +use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf, write_ice_shelf_energy +use MOM_ice_shelf_dynamics, only : register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn +use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve, change_in_draft +use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end +use MOM_ice_shelf_initialize, only : initialize_ice_thickness +!MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary +use MOM_ice_shelf_state, only : ice_shelf_state, ice_shelf_state_end, ice_shelf_state_init +use user_shelf_init, only : USER_initialize_shelf_mass, USER_update_shelf_mass +use user_shelf_init, only : user_ice_shelf_CS +use MOM_coms, only : reproducing_sum +use MOM_spatial_means, only : global_area_integral +use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum +use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init +use MOM_interpolate, only : external_field + +implicit none ; private + +#include +#ifdef SYMMETRIC_MEMORY_ +# define GRID_SYM_ .true. +#else +# define GRID_SYM_ .false. +#endif + +public shelf_calc_flux, initialize_ice_shelf, ice_shelf_end, ice_shelf_query +public ice_shelf_save_restart, solo_step_ice_shelf, add_shelf_forces +public initialize_ice_shelf_fluxes, initialize_ice_shelf_forces + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure that contains ice shelf parameters and diagnostics handles +type, public :: ice_shelf_CS ; private + ! Parameters + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control + !! structure for the ice shelves + type(ocean_grid_type), pointer :: Grid_in => NULL() !< un-rotated input grid metric + type(hor_index_type), pointer :: HI_in => NULL() !< Pointer to a horizontal indexing structure for + !! incoming data which has not been rotated. + type(hor_index_type), pointer :: HI => NULL() !< Pointer to a horizontal indexing structure for + !! incoming data which has not been rotated. + logical :: rotate_index = .false. !< True if index map is rotated + integer :: turns !< The number of quarter turns for rotation testing. + type(ocean_grid_type), pointer :: Grid => NULL() !< Grid for the ice-shelf model + type(unit_scale_type), pointer :: & + US => NULL() !< A structure containing various unit conversion factors + type(ocean_grid_type), pointer :: ocn_grid => NULL() !< A pointer to the ocean model grid + !! The rest is private + real :: flux_factor = 1.0 !< A factor that can be used to turn off ice shelf + !! melting (flux_factor = 0) [nondim]. + character(len=128) :: restart_output_dir = ' ' !< The directory in which to write restart files + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + type(ice_shelf_dyn_CS), pointer :: dCS => NULL() !< The control structure for the ice-shelf dynamics. + + real, pointer, dimension(:,:) :: & + utide => NULL() !< An unresolved tidal velocity [L T-1 ~> m s-1] + + real :: ustar_bg !< A minimum value for ustar under ice shelves [Z T-1 ~> m s-1]. + real :: ustar_max !< A maximum value for ustar under ice shelves, or a negative value to + !! have no limit [Z T-1 ~> m s-1]. + real :: cdrag !< drag coefficient under ice shelves [nondim]. + real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: Cp !< The heat capacity of sea water [Q C-1 ~> J kg-1 degC-1]. + real :: Rho_ocn !< A reference ocean density [R ~> kg m-3]. + real :: Cp_ice !< The heat capacity of fresh ice [Q C-1 ~> J kg-1 degC-1]. + real :: gamma_t !< The (fixed) turbulent exchange velocity in the + !< 2-equation formulation [Z T-1 ~> m s-1]. + real :: Salin_ice !< The salinity of shelf ice [S ~> ppt]. + real :: Temp_ice !< The core temperature of shelf ice [C ~> degC]. + real :: kv_ice !< The viscosity of ice [L4 Z-2 T-1 ~> m2 s-1]. + real :: density_ice !< A typical density of ice [R ~> kg m-3]. + real :: kv_molec !< The molecular kinematic viscosity of sea water [Z2 T-1 ~> m2 s-1]. + real :: kd_molec_salt!< The molecular diffusivity of salt [Z2 T-1 ~> m2 s-1]. + real :: kd_molec_temp!< The molecular diffusivity of heat [Z2 T-1 ~> m2 s-1]. + real :: Lat_fusion !< The latent heat of fusion [Q ~> J kg-1]. + real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation + real :: Gamma_S_3EQ !< Nondimensional salt-transfer coefficient, used in the 3Eq. formulation + !< This number should be specified by the user. + real :: col_mass_melt_threshold !< An ocean column mass below the iceshelf below which melting + !! does not occur [R Z ~> kg m-2] + logical :: mass_from_file !< Read the ice shelf mass from a file every dt + logical :: ustar_shelf_from_vel !< If true, use the surface velocities, and not the previous + !! values of the stresses to set ustar. + + !!!! PHYSICAL AND NUMERICAL PARAMETERS FOR ICE DYNAMICS !!!!!! + + real :: time_step !< this is the shortest timestep that the ice shelf sees [T ~> s], and + !! is equal to the forcing timestep (it is passed in when the shelf + !! is initialized - so need to reorganize MOM driver. + !! it will be the prognostic timestep ... maybe. + + logical :: solo_ice_sheet !< whether the ice model is running without being + !! coupled to the ocean + logical :: GL_regularize !< whether to regularize the floatation condition + !! at the grounding line a la Goldberg Holland Schoof 2009 + logical :: GL_couple !< whether to let the floatation condition be + !!determined by ocean column thickness means update_OD_ffrac + !! will be called (note: GL_regularize and GL_couple + !! should be exclusive) + logical :: calve_to_mask !< If true, calve any ice that passes outside of a masked area + real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. + real :: T0 !< temperature at ocean surface in the restoring region [C ~> degC] + real :: S0 !< Salinity at ocean surface in the restoring region [S ~> ppt]. + real :: input_flux !< The vertically integrated inward ice thickness flux per + !! unit face length at an upstream boundary [Z L T-1 ~> m2 s-1] + real :: input_thickness !< Ice thickness at an upstream open boundary [Z ~> m]. + + type(time_type) :: Time !< The component's time. + type(EOS_type) :: eqn_of_state !< Type that indicates the equation of state to use. + logical :: active_shelf_dynamics !< True if the ice shelf mass changes as a result + !! the dynamic ice-shelf model. + logical :: shelf_mass_is_dynamic !< True if ice shelf mass changes over time. If true, ice + !! shelf dynamics will be initialized + logical :: data_override_shelf_fluxes !< True if the ice shelf surface mass fluxes can be + !! written using the data_override feature (only for MOSAIC grids) + logical :: override_shelf_movement !< If true, user code specifies the shelf movement + !! instead of using the dynamic ice-shelf mode. + logical :: isthermo !< True if the ice shelf can exchange heat and + !! mass with the underlying ocean. + logical :: threeeq !< If true, the 3 equation consistency equations are + !! used to calculate the flux at the ocean-ice + !! interface. + logical :: insulator !< If true, ice shelf is a perfect insulator + logical :: const_gamma !< If true, gamma_T is specified by the user. + logical :: constant_sea_level !< if true, apply an evaporative, heat and salt + !! fluxes. It will avoid large increase in sea level. + logical :: constant_sea_level_misomip !< If true, constant_sea_level fluxes are applied only over + !! the surface sponge cells from the ISOMIP/MISOMIP configuration + real :: min_ocean_mass_float !< The minimum ocean mass per unit area before the ice + !! shelf is considered to float when constant_sea_level + !! is used [R Z ~> kg m-2] + real :: cutoff_depth !< Depth above which melt is set to zero (>= 0) [Z ~> m]. + logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. + real :: TFr_0_0 !< The freezing point at 0 pressure and 0 salinity [C ~> degC] + real :: dTFr_dS !< Partial derivative of freezing temperature with + !! salinity [C S-1 ~> degC ppt-1] + real :: dTFr_dp !< Partial derivative of freezing temperature with + !! pressure [C T2 R-1 L-2 ~> degC Pa-1] + real :: Zeta_N !< The stability constant xi_N = 0.052 from Holland & Jenkins '99 + !! divided by the von Karman constant VK. Was 1/8. + real :: Vk !< Von Karman's constant - dimensionless + real :: Rc !< critical flux Richardson number. + logical :: buoy_flux_itt_bug !< If true, fixes buoyancy iteration bug + logical :: salt_flux_itt_bug !< If true, fixes salt iteration bug + real :: buoy_flux_itt_threshold !< Buoyancy iteration threshold for convergence + + !>@{ Diagnostic handles + integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & + id_tfreeze = -1, id_tfl_shelf = -1, & + id_thermal_driving = -1, id_haline_driving = -1, & + id_u_ml = -1, id_v_ml = -1, id_sbdry = -1, & + id_h_shelf = -1, id_dhdt_shelf, id_h_mask = -1, & + id_surf_elev = -1, id_bathym = -1, & + id_area_shelf_h = -1, & + id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1, & + id_shelf_sfc_mass_flux = -1 + !>@} + + type(external_field) :: mass_handle + !< Handle for reading the time interpolated ice shelf mass from a file + type(external_field) :: area_handle + !< Handle for reading the time interpolated ice shelf area from a file + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. + type(user_ice_shelf_CS), pointer :: user_CS => NULL() !< A pointer to the control structure for + !! user-supplied modifications to the ice shelf code. + + logical :: debug !< If true, write verbose checksums for debugging purposes + !! and use reproducible sums +end type ice_shelf_CS + +!>@{ CPU time clock IDs +integer :: id_clock_shelf=-1 !< CPU Clock for the ice shelf code +integer :: id_clock_pass=-1 !< CPU Clock for ice shelf group pass calls +!>@} + +contains + +!> Calculates fluxes between the ocean and ice-shelf using the three-equations +!! formulation (optional to use just two equations). +!! See \ref section_ICE_SHELF_equations +subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) + type(surface), target, intent(inout) :: sfc_state_in !< A structure containing fields that + !! describe the surface state of the ocean. The + !! intent is only inout to allow for halo updates. + type(forcing), target, intent(inout) :: fluxes_in !< structure containing pointers to any + !! possible thermodynamic or mass-flux forcing fields. + type(time_type), intent(in) :: Time !< Start time of the fluxes. + real, intent(in) :: time_step_in !< Length of time over which these fluxes + !! will be applied [T ~> s]. + type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to initialize_ice_shelf. + + ! Local variables + type(ocean_grid_type), pointer :: G => NULL() !< The grid structure used by the ice shelf. + type(unit_scale_type), pointer :: US => NULL() !< Pointer to a structure containing + !! various unit conversion factors + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + + type(surface), pointer :: sfc_state => NULL() + type(forcing), pointer :: fluxes => NULL() + + real, dimension(SZI_(CS%grid)) :: & + Rhoml, & !< Ocean mixed layer density [R ~> kg m-3]. + dR0_dT, & !< Partial derivative of the mixed layer density + !< with temperature [R C-1 ~> kg m-3 degC-1]. + dR0_dS, & !< Partial derivative of the mixed layer density + !< with salinity [R S-1 ~> kg m-3 ppt-1]. + p_int !< The pressure at the ice-ocean interface [R L2 T-2 ~> Pa]. + + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & + exch_vel_t, & !< Sub-shelf thermal exchange velocity [Z T-1 ~> m s-1] + exch_vel_s !< Sub-shelf salt exchange velocity [Z T-1 ~> m s-1] + + real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & + mass_flux !< Total mass flux of freshwater across the ice-ocean interface. [R Z L2 T-1 ~> kg s-1] + real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & + haline_driving !< (SSS - S_boundary) ice-ocean + !! interface, positive for melting and negative for freezing [S ~> ppt]. + !! This is computed as part of the ISOMIP diagnostics. + real :: time_step !< Length of time over which these fluxes will be applied [T ~> s]. + real :: Itime_step !< Inverse of the length of time over which these fluxes will be applied [T-1 ~> s-1] + real :: VK !< Von Karman's constant - dimensionless + real :: ZETA_N !< This is the stability constant xi_N = 0.052 from Holland & Jenkins '99 + !! divided by the von Karman constant VK. Was 1/8. [nondim] + real :: RC !< critical flux Richardson number. + real :: I_ZETA_N !< The inverse of ZETA_N [nondim]. + real :: I_LF !< The inverse of the latent heat of fusion [Q-1 ~> kg J-1]. + real :: I_VK !< The inverse of the Von Karman constant [nondim]. + real :: PR, SC !< The Prandtl number and Schmidt number [nondim]. + + ! 3 equations formulation variables + real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & + Sbdry !< Salinities in the ocean at the interface with the ice shelf [S ~> ppt]. + real :: Sbdry_it ! The boundary salinity at an iteration [S ~> ppt] + real :: S_a ! A variable used to find salt roots [S-1 ~> ppt-1] + real :: S_b ! A variable used to find salt roots [nondim] + real :: S_c ! A variable used to find salt roots [S ~> ppt] + real :: dS_it !< The interface salinity change during an iteration [S ~> ppt]. + real :: hBL_neut !< The neutral boundary layer thickness [Z ~> m]. + real :: hBL_neut_h_molec !< The ratio of the neutral boundary layer thickness + !! to the molecular boundary layer thickness [nondim]. + real :: wT_flux !< The downward vertical flux of heat just inside the ocean [C Z T-1 ~> degC m s-1]. + real :: wB_flux !< The downward vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3]. + real :: dB_dS !< The derivative of buoyancy with salinity [Z T-2 S-1 ~> m s-2 ppt-1]. + real :: dB_dT !< The derivative of buoyancy with temperature [Z T-2 C-1 ~> m s-2 degC-1]. + real :: I_n_star ! [nondim] + real :: n_star_term ! A term in the expression for nstar [T3 Z-2 ~> s3 m-2] + real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] + real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in [T3 Z-2 ~> s3 m-2] + real :: dT_ustar ! The difference between the freezing point and the ocean boundary layer + ! temperature times the friction velocity [C Z T-1 ~> degC m s-1] + real :: dS_ustar ! The difference between the salinity at the ice-ocean interface and the ocean + ! boundary layer salinity times the friction velocity [S Z T-1 ~> ppt m s-1] + real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1] + real :: Gam_turb ! [nondim] + real :: Gam_mol_t, Gam_mol_s ! Relative coefficients of molecular diffusivities [nondim] + real :: RhoCp ! A typical ocean density times the heat capacity of water [Q R C-1 ~> J m-3 degC-1] + real :: ln_neut + real :: mass_exch ! A mass exchange rate [R Z T-1 ~> kg m-2 s-1] + real :: Sb_min, Sb_max ! Minimum and maximum boundary salinities [S ~> ppt] + real :: dS_min, dS_max ! Minimum and maximum salinity changes [S ~> ppt] + ! Variables used in iterating for wB_flux. + real :: wB_flux_new, dDwB_dwB_in + real :: I_Gam_T, I_Gam_S + real :: dG_dwB ! The derivative of Gam_turb with wB [T3 Z-2 ~> s3 m-2] + real :: taux2, tauy2 ! The squared surface stresses [R2 L2 Z2 T-4 ~> Pa2]. + real :: u2_av, v2_av ! The ice-area weighted average squared ocean velocities [L2 T-2 ~> m2 s-2] + real :: asu1, asu2 ! Ocean areas covered by ice shelves at neighboring u- + real :: asv1, asv2 ! and v-points [L2 ~> m2]. + real :: I_au, I_av ! The Adcroft reciprocals of the ice shelf areas at adjacent points [L-2 ~> m-2] + real :: Irho0 ! The inverse of the mean density times a unit conversion factor [R-1 L Z-1 ~> m3 kg-1] + logical :: Sb_min_set, Sb_max_set + logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. + logical :: coupled_GL ! If true, the grounding line position is determined based on + ! coupled ice-ocean dynamics. + + real, parameter :: c2_3 = 2.0/3.0 + character(len=160) :: mesg ! The text of an error message + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, is, ie, js, je, ied, jed, it1, it3 + + if (.not. associated(CS)) call MOM_error(FATAL, "shelf_calc_flux: "// & + "initialize_ice_shelf must be called before shelf_calc_flux.") + call cpu_clock_begin(id_clock_shelf) + + G => CS%grid ; US => CS%US + ISS => CS%ISS + time_step = time_step_in + + 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) + endif + + if (CS%rotate_index) then + allocate(sfc_state) + call rotate_surface_state(sfc_state_in, sfc_state, CS%Grid, CS%turns) + allocate(fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes) + call rotate_forcing(fluxes_in, fluxes, CS%turns) + else + sfc_state => sfc_state_in + fluxes => fluxes_in + endif + ! useful parameters + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed + ZETA_N = CS%Zeta_N + VK = CS%Vk + RC = CS%Rc + I_ZETA_N = 1.0 / ZETA_N + I_LF = 1.0 / CS%Lat_fusion + SC = CS%kv_molec/CS%kd_molec_salt + PR = CS%kv_molec/CS%kd_molec_temp + I_VK = 1.0/VK + RhoCp = CS%Rho_ocn * CS%Cp + + !first calculate molecular component + Gam_mol_t = 12.5 * (PR**c2_3) - 6.0 + Gam_mol_s = 12.5 * (SC**c2_3) - 6.0 + + ! GMM, zero some fields of the ice shelf structure (ice_shelf_CS) + ! these fields are already set to zero during initialization + ! However, they seem to be changed somewhere and, for diagnostic + ! reasons, it is better to set them to zero again. + exch_vel_t(:,:) = 0.0 ; exch_vel_s(:,:) = 0.0 + ISS%tflux_shelf(:,:) = 0.0 ; ISS%water_flux(:,:) = 0.0 + ISS%salt_flux(:,:) = 0.0 ; ISS%tflux_ocn(:,:) = 0.0 ; ISS%tfreeze(:,:) = 0.0 + ! define Sbdry to avoid Run-Time Check Failure, when melt is not computed. + haline_driving(:,:) = 0.0 + Sbdry(:,:) = sfc_state%sss(:,:) + + !update time + CS%Time = Time + + if (CS%override_shelf_movement) then + CS%time_step = time_step + ! update shelf mass + if (CS%mass_from_file) call update_shelf_mass(G, US, CS, ISS, Time) + endif + + if (CS%debug) then + call hchksum(fluxes_in%frac_shelf_h, "frac_shelf_h before apply melting", CS%Grid_in%HI, haloshift=0) + call hchksum(sfc_state_in%sst, "sst before apply melting", CS%Grid_in%HI, haloshift=0, scale=US%C_to_degC) + call hchksum(sfc_state_in%sss, "sss before apply melting", CS%Grid_in%HI, haloshift=0, scale=US%S_to_ppt) + call uvchksum("[uv]_ml before apply melting", sfc_state_in%u, sfc_state_in%v, & + CS%Grid_in%HI, haloshift=0, scale=US%L_T_to_m_s) + call hchksum(sfc_state_in%ocean_mass, "ocean_mass before apply melting", CS%Grid_in%HI, haloshift=0, & + scale=US%RZ_to_kg_m2) + endif + + ! Calculate the friction velocity under ice shelves, using taux_shelf and tauy_shelf if possible. + if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then + call pass_vector(sfc_state%taux_shelf, sfc_state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) + endif + Irho0 = US%Z_to_L / CS%Rho_ocn + do j=js,je ; do i=is,ie ; if (fluxes%frac_shelf_h(i,j) > 0.0) then + taux2 = 0.0 ; tauy2 = 0.0 ; u2_av = 0.0 ; v2_av = 0.0 + asu1 = (ISS%area_shelf_h(i-1,j) + ISS%area_shelf_h(i,j)) + asu2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i+1,j)) + asv1 = (ISS%area_shelf_h(i,j-1) + ISS%area_shelf_h(i,j)) + asv2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) + I_au = 0.0 ; if (asu1 + asu2 > 0.0) I_au = 1.0 / (asu1 + asu2) + I_av = 0.0 ; if (asv1 + asv2 > 0.0) I_av = 1.0 / (asv1 + asv2) + if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then + taux2 = (asu1 * sfc_state%taux_shelf(I-1,j)**2 + asu2 * sfc_state%taux_shelf(I,j)**2 ) * I_au + tauy2 = (asv1 * sfc_state%tauy_shelf(i,J-1)**2 + asv2 * sfc_state%tauy_shelf(i,J)**2 ) * I_av + endif + u2_av = (asu1 * sfc_state%u(I-1,j)**2 + asu2 * sfc_state%u(I,j)**2) * I_au + v2_av = (asv1 * sfc_state%v(i,J-1)**2 + asu2 * sfc_state%v(i,J)**2) * I_av + + if ((taux2 + tauy2 > 0.0) .and. .not.CS%ustar_shelf_from_vel) then + if (CS%ustar_max >= 0.0) then + fluxes%ustar_shelf(i,j) = MIN(CS%ustar_max, MAX(CS%ustar_bg, US%L_to_Z * & + sqrt(Irho0 * sqrt(taux2 + tauy2) + CS%cdrag*CS%utide(i,j)**2))) + else + fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_to_Z * & + sqrt(Irho0 * sqrt(taux2 + tauy2) + CS%cdrag*CS%utide(i,j)**2)) + endif + else ! Take care of the cases when taux_shelf is not set or not allocated. + fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_TO_Z * & + sqrt(CS%cdrag*((u2_av + v2_av) + CS%utide(i,j)**2))) + endif + else ! There is no shelf here. + fluxes%ustar_shelf(i,j) = 0.0 + endif ; enddo ; enddo + + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + ! Find the pressure at the ice-ocean interface, averaged only over the + ! part of the cell covered by ice shelf. + do i=is,ie ; p_int(i) = CS%g_Earth * ISS%mass_shelf(i,j) ; enddo + + ! Calculate insitu densities and expansion coefficients + call calculate_density(sfc_state%sst(:,j), sfc_state%sss(:,j), p_int, Rhoml(:), & + CS%eqn_of_state, EOSdom) + call calculate_density_derivs(sfc_state%sst(:,j), sfc_state%sss(:,j), p_int, & + dR0_dT, dR0_dS, CS%eqn_of_state, EOSdom) + + do i=is,ie + if ((sfc_state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & + (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then + + if (CS%threeeq) then + ! Iteratively determine a self-consistent set of fluxes, with the ocean + ! salinity just below the ice-shelf as the variable that is being + ! iterated for. + + ustar_h = fluxes%ustar_shelf(i,j) + + ! Estimate the neutral ocean boundary layer thickness as the minimum of the + ! reported ocean mixed layer thickness and the neutral Ekman depth. + absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & + (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) + if (absf*sfc_state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = sfc_state%Hml(i,j) + else ; hBL_neut = (VK*ustar_h) / absf ; endif + hBL_neut_h_molec = ZETA_N * ((hBL_neut * ustar_h) / (5.0 * CS%kv_molec)) + + ! Determine the mixed layer buoyancy flux, wB_flux. + dB_dS = (US%L_to_Z**2*CS%g_Earth / Rhoml(i)) * dR0_dS(i) + dB_dT = (US%L_to_Z**2*CS%g_Earth / Rhoml(i)) * dR0_dT(i) + ln_neut = 0.0 ; if (hBL_neut_h_molec > 1.0) ln_neut = log(hBL_neut_h_molec) + + if (CS%find_salt_root) then + ! Solve for the skin salinity using the linearized liquidus parameters and + ! balancing the turbulent fresh water flux in the near-boundary layer with + ! the net fresh water or salt added by melting: + ! (Cp/Lat_fusion)*Gamma_T_3Eq*(TFr_skin-T_ocn) = Gamma_S_3Eq*(S_skin-S_ocn)/S_skin + + ! S_a is always < 0.0 with a realistic expression for the freezing point. + S_a = CS%dTFr_dS * CS%Gamma_T_3EQ * CS%Cp + S_b = CS%Gamma_T_3EQ*CS%Cp*(CS%TFr_0_0 + CS%dTFr_dp*p_int(i) - sfc_state%sst(i,j)) - & + CS%Lat_fusion * CS%Gamma_S_3EQ ! S_b Can take either sign, but is usually negative. + S_c = CS%Lat_fusion * CS%Gamma_S_3EQ * sfc_state%sss(i,j) ! Always >= 0 + + if (S_c == 0.0) then ! The solution for fresh water. + Sbdry(i,j) = 0.0 + elseif (S_a < 0.0) then ! This is the usual ocean case + if (S_b < 0.0) then ! This is almost always the case + Sbdry(i,j) = 2.0*S_c / (-S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) + else + Sbdry(i,j) = (S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) / (-2.*S_a) + endif + elseif ((S_a == 0.0) .and. (S_b < 0.0)) then ! It should be the case that S_b < 0. + Sbdry(i,j) = -S_c / S_b + else + call MOM_error(FATAL, "Impossible conditions found in 3-equation skin salinity calculation.") + endif + + ! Safety check + if (Sbdry(i,j) < 0.) then + write(mesg,*) 'sfc_state%sss(i,j) = ',US%S_to_ppt*sfc_state%sss(i,j), & + 'S_a, S_b, S_c', US%ppt_to_S*S_a, S_b, US%S_to_ppt*S_c + call MOM_error(WARNING, mesg, .true.) + call MOM_error(FATAL, "shelf_calc_flux: Negative salinity (Sbdry).") + endif + else + ! Guess sss as the iteration starting point for the boundary salinity. + Sbdry(i,j) = sfc_state%sss(i,j) ; Sb_max_set = .false. + Sb_min_set = .false. + endif !find_salt_root + + do it1 = 1,20 + ! Determine the potential temperature at the ice-ocean interface. + ! The following two lines are equivalent: + ! call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state, scale_from_EOS=.true.) + call calculate_TFreeze(Sbdry(i:i,j), p_int(i:i), ISS%tfreeze(i:i,j), CS%eqn_of_state) + + dT_ustar = (ISS%tfreeze(i,j) - sfc_state%sst(i,j)) * ustar_h + dS_ustar = (Sbdry(i,j) - sfc_state%sss(i,j)) * ustar_h + + ! First, determine the buoyancy flux assuming no effects of stability + ! on the turbulence. Following H & J '99, this limit also applies + ! when the buoyancy flux is destabilizing. + + if (CS%const_gamma) then ! if using a constant gamma_T + ! note the different form, here I_Gam_T is NOT 1/Gam_T! + I_Gam_T = CS%Gamma_T_3EQ + I_Gam_S = CS%Gamma_S_3EQ + else + Gam_turb = I_VK * (ln_neut + (0.5 * I_ZETA_N - 1.0)) + I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) + I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) + endif + + wT_flux = dT_ustar * I_Gam_T + wB_flux = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux + + if (wB_flux < 0.0) then + ! The buoyancy flux is stabilizing and will reduce the turbulent + ! fluxes, and iteration is required. + n_star_term = (ZETA_N * hBL_neut * VK) / (RC * ustar_h**3) + do it3 = 1,30 + ! n_star <= 1.0 is the ratio of working boundary layer thickness + ! to the neutral thickness. + ! hBL = n_star*hBL_neut ; hSub = 1/8*n_star*hBL + + I_n_star = sqrt(1.0 - n_star_term * wB_flux) + dIns_dwB = 0.5 * n_star_term / I_n_star + if (hBL_neut_h_molec > I_n_star**2) then + Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + & + (0.5*I_ZETA_N*I_n_star - 1.0)) + dG_dwB = I_VK * ( -2.0 / I_n_star + (0.5 * I_ZETA_N)) * dIns_dwB + else + ! The layer dominated by molecular viscosity is smaller than + ! the assumed boundary layer. This should be rare! + Gam_turb = I_VK * (0.5 * I_ZETA_N*I_n_star - 1.0) + dG_dwB = I_VK * (0.5 * I_ZETA_N) * dIns_dwB + endif + + if (CS%const_gamma) then ! if using a constant gamma_T + ! note the different form, here I_Gam_T is NOT 1/Gam_T! + I_Gam_T = CS%Gamma_T_3EQ + I_Gam_S = CS%Gamma_S_3EQ + else + I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) + I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) + endif + + wT_flux = dT_ustar * I_Gam_T + wB_flux_new = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux + + ! Find the root where wB_flux_new = wB_flux. + if (abs(wB_flux_new - wB_flux) < CS%buoy_flux_itt_threshold*(abs(wB_flux_new) + abs(wB_flux))) exit + + dDwB_dwB_in = dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + & + dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 + ! This is Newton's method without any bounds. Should bounds be needed? + wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in + ! Update wB_flux + if (CS%buoy_flux_itt_bug) wB_flux = wB_flux_new + enddo !it3 + endif + + ISS%tflux_ocn(i,j) = RhoCp * wT_flux + exch_vel_t(i,j) = ustar_h * I_Gam_T + exch_vel_s(i,j) = ustar_h * I_Gam_S + + ! Calculate the heat flux inside the ice shelf. + ! Vertical adv/diff as in H+J 1999, equations (26) & approx from (31). + ! Q_ice = density_ice * CS%Cp_ice * K_ice * dT/dz (at interface) + ! vertical adv/diff as in H+J 1999, equations (31) & (26)... + ! dT/dz ~= min( (lprec/(density_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) + ! If this approximation is not made, iterations are required... See H+J Fig 3. + + if (ISS%tflux_ocn(i,j) >= 0.0) then + ! Freezing occurs due to downward ocean heat flux, so zero iout ce heat flux. + ISS%water_flux(i,j) = -I_LF * ISS%tflux_ocn(i,j) + ISS%tflux_shelf(i,j) = 0.0 + else + if (CS%insulator) then + !no conduction/perfect insulator + ISS%tflux_shelf(i,j) = 0.0 + ISS%water_flux(i,j) = I_LF * (ISS%tflux_shelf(i,j) - ISS%tflux_ocn(i,j)) + + else + ! With melting, from H&J 1999, eqs (31) & (26)... + ! Q_ice ~= Cp_ice * (CS%Temp_Ice-T_freeze) * lprec + ! RhoLF*lprec = Q_ice - ISS%tflux_ocn(i,j) + ! lprec = -(ISS%tflux_ocn(i,j)) / (CS%Lat_fusion + Cp_ice * (T_freeze-CS%Temp_Ice)) + ISS%water_flux(i,j) = -ISS%tflux_ocn(i,j) / & + (CS%Lat_fusion + CS%Cp_ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) + + ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) + CS%Lat_fusion*ISS%water_flux(i,j) + endif + + endif + !other options: dTi/dz linear through shelf, with draft in [Z ~> m], KTI in [Z2 T-1 ~> m2 s-1] + ! dTi_dz = (CS%Temp_Ice - ISS%tfreeze(i,j)) / draft(i,j) + ! ISS%tflux_shelf(i,j) = Rho_Ice * CS%Cp_ice * KTI * dTi_dz + + + if (CS%find_salt_root) then + exit ! no need to do interaction, so exit loop + else + + mass_exch = exch_vel_s(i,j) * CS%Rho_ocn + Sbdry_it = (sfc_state%sss(i,j) * mass_exch + CS%Salin_ice * ISS%water_flux(i,j)) / & + (mass_exch + ISS%water_flux(i,j)) + dS_it = Sbdry_it - Sbdry(i,j) + if (abs(dS_it) < 1.0e-4*(0.5*(sfc_state%sss(i,j) + Sbdry(i,j) + 1.0e-10*US%ppt_to_S))) exit + + if (dS_it < 0.0) then ! Sbdry is now the upper bound. + if (Sb_max_set) then + if (Sbdry(i,j) > Sb_max) & + call MOM_error(FATAL,"shelf_calc_flux: Irregular iteration for Sbdry (max).") + endif + Sb_max = Sbdry(i,j) ; dS_max = dS_it ; Sb_max_set = .true. + else ! Sbdry is now the lower bound. + if (Sb_min_set) then + if (Sbdry(i,j) < Sb_min) & + call MOM_error(FATAL, "shelf_calc_flux: Irregular iteration for Sbdry (min).") + endif + Sb_min = Sbdry(i,j) ; dS_min = dS_it ; Sb_min_set = .true. + endif ! dS_it < 0.0 + + if (Sb_min_set .and. Sb_max_set) then + ! Use the false position method for the next iteration. + Sbdry(i,j) = Sb_min + (Sb_max-Sb_min) * (dS_min / (dS_min - dS_max)) + else + Sbdry(i,j) = Sbdry_it + endif ! Sb_min_set + + if (.not.CS%salt_flux_itt_bug) Sbdry(i,j) = Sbdry_it + + endif ! CS%find_salt_root + + enddo !it1 + ! Check for non-convergence and/or non-boundedness? + + else + ! In the 2-equation form, the mixed layer turbulent exchange velocity + ! is specified and large enough that the ocean salinity at the interface + ! is about the same as the boundary layer salinity. + ! The following two lines are equivalent: + ! call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state, scale_from_EOS=.true.) + call calculate_TFreeze(sfc_state%SSS(i:i,j), p_int(i:i), ISS%tfreeze(i:i,j), CS%eqn_of_state) + + exch_vel_t(i,j) = CS%gamma_t + ISS%tflux_ocn(i,j) = RhoCp * exch_vel_t(i,j) * (ISS%tfreeze(i,j) - sfc_state%sst(i,j)) + ISS%tflux_shelf(i,j) = 0.0 + ISS%water_flux(i,j) = -I_LF * ISS%tflux_ocn(i,j) + Sbdry(i,j) = 0.0 + endif + elseif (ISS%area_shelf_h(i,j) > 0.0) then ! This is an ice-sheet, not a floating shelf. + ISS%tflux_ocn(i,j) = 0.0 + else ! There is no ice shelf or sheet here. + ISS%tflux_ocn(i,j) = 0.0 + endif + +! haline_driving(i,j) = sfc_state%sss(i,j) - Sbdry(i,j) + + enddo ! i-loop + enddo ! j-loop + + + do j=js,je ; do i=is,ie + ! ISS%water_flux = net liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] + fluxes%iceshelf_melt(i,j) = ISS%water_flux(i,j) * CS%flux_factor + + if ((sfc_state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & + (ISS%area_shelf_h(i,j) > 0.0) .and. (CS%isthermo)) then + + ! Set melt to zero above a cutoff pressure (CS%Rho_ocn*CS%cutoff_depth*CS%g_Earth). + ! This is needed for the ISOMIP test case. + if (ISS%mass_shelf(i,j) < CS%Rho_ocn*CS%cutoff_depth) then + ISS%water_flux(i,j) = 0.0 + fluxes%iceshelf_melt(i,j) = 0.0 + endif + ! Compute haline driving, which is one of the diags. used in ISOMIP + if (exch_vel_s(i,j)>0.) haline_driving(i,j) = (ISS%water_flux(i,j) * Sbdry(i,j)) / (CS%Rho_ocn * exch_vel_s(i,j)) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! + !1)Check if haline_driving computed above is consistent with + ! haline_driving = sfc_state%sss - Sbdry + !if (fluxes%iceshelf_melt(i,j) /= 0.0) then + ! if (haline_driving(i,j) /= (sfc_state%sss(i,j) - Sbdry(i,j))) then + ! write(mesg,*) 'at i,j=',i,j,' haline_driving, sss-Sbdry',US%S_to_ppt*haline_driving(i,j), & + ! US%S_to_ppt*(sfc_state%sss(i,j) - Sbdry(i,j)) + ! call MOM_error(FATAL, & + ! "shelf_calc_flux: Inconsistency in melt and haline_driving"//trim(mesg)) + ! endif + !endif + + ! 2) check if |melt| > 0 when ustar_shelf = 0. + ! this should never happen + if ((abs(fluxes%iceshelf_melt(i,j))>0.0) .and. (fluxes%ustar_shelf(i,j) == 0.0)) then + write(mesg,*) "|melt| = ",fluxes%iceshelf_melt(i,j)," > 0 and ustar_shelf = 0. at i,j", i, j + call MOM_error(FATAL, "shelf_calc_flux: "//trim(mesg)) + endif + !!!!!!!!!!!!!!!!!!!!!!!!!!!!End of safety checks !!!!!!!!!!!!!!!!!!! + elseif (ISS%area_shelf_h(i,j) > 0.0) then + ! This is grounded ice, that could be modified to melt if a geothermal heat flux were used. + haline_driving(i,j) = 0.0 + ISS%water_flux(i,j) = 0.0 + fluxes%iceshelf_melt(i,j) = 0.0 + endif ! area_shelf_h + + ! mass flux [R Z L2 T-1 ~> kg s-1], part of ISOMIP diags. + mass_flux(i,j) = ISS%water_flux(i,j) * ISS%area_shelf_h(i,j) + enddo ; enddo ! i- and j-loops + + if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then + call cpu_clock_begin(id_clock_pass) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain) + call cpu_clock_end(id_clock_pass) + endif + + ! Melting has been computed, now is time to update thickness and mass + if ( CS%override_shelf_movement .and. (.not.CS%mass_from_file)) then + call change_thickness_using_melt(ISS, G, US, time_step, fluxes, CS%density_ice, CS%debug) + + if (CS%debug) then + call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0, & + scale=US%RZ_to_kg_m2) + endif + endif + + ! Melting has been computed, now is time to update thickness and mass with dynamic ice shelf + if (CS%active_shelf_dynamics) then + + ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) + + call change_thickness_using_melt(ISS, G, US, time_step, fluxes, CS%density_ice, CS%debug) + + if (CS%debug) then + call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0, & + scale=US%RZ_to_kg_m2) + endif + + call change_thickness_using_precip(CS, ISS, G, US, fluxes, 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 + + update_ice_vel = .false. + coupled_GL = (CS%GL_couple .and. .not. CS%solo_ice_sheet) + + ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. + ! when we decide on how to do it + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, & + sfc_state%ocean_mass, coupled_GL) + + Itime_step = 1./time_step + do j=js,je ; do i=is,ie + ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j))*Itime_step + enddo; enddo + endif + + if (CS%shelf_mass_is_dynamic) & + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & + time_step=real_to_time(US%T_to_s*time_step) ) + + if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) + + ! pass on the updated ice sheet geometry (for pressure on ocean) and thermodynamic data + call add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) + + call enable_averages(time_step, Time, CS%diag) + if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, ISS%mass_shelf, CS%diag) + if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) + if (CS%id_ustar_shelf > 0) call post_data(CS%id_ustar_shelf, fluxes%ustar_shelf, CS%diag) + if (CS%id_shelf_sfc_mass_flux > 0) call post_data(CS%id_shelf_sfc_mass_flux, fluxes%shelf_sfc_mass_flux, CS%diag) + + if (CS%id_melt > 0) call post_data(CS%id_melt, fluxes%iceshelf_melt, CS%diag) + if (CS%id_thermal_driving > 0) call post_data(CS%id_thermal_driving, (sfc_state%sst-ISS%tfreeze), CS%diag) + if (CS%id_Sbdry > 0) call post_data(CS%id_Sbdry, Sbdry, CS%diag) + if (CS%id_haline_driving > 0) call post_data(CS%id_haline_driving, haline_driving, CS%diag) + if (CS%id_mass_flux > 0) call post_data(CS%id_mass_flux, mass_flux, CS%diag) + if (CS%id_u_ml > 0) call post_data(CS%id_u_ml, sfc_state%u, CS%diag) + if (CS%id_v_ml > 0) call post_data(CS%id_v_ml, sfc_state%v, CS%diag) + if (CS%id_tfreeze > 0) call post_data(CS%id_tfreeze, ISS%tfreeze, CS%diag) + if (CS%id_tfl_shelf > 0) call post_data(CS%id_tfl_shelf, ISS%tflux_shelf, CS%diag) + if (CS%id_exch_vel_t > 0) call post_data(CS%id_exch_vel_t, exch_vel_t, CS%diag) + if (CS%id_exch_vel_s > 0) call post_data(CS%id_exch_vel_s, exch_vel_s, CS%diag) + if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) + if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) + if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) + call disable_averaging(CS%diag) + + + call cpu_clock_end(id_clock_shelf) + + if (CS%rotate_index) then +! call rotate_surface_state(sfc_state, sfc_state_in, CS%Grid_in, -CS%turns) + call rotate_forcing(fluxes,fluxes_in,-CS%turns) + endif + + + if (CS%debug) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, CS%US, haloshift=0) + +end subroutine shelf_calc_flux + +!> Changes the thickness (mass) of the ice shelf based on sub-ice-shelf melting +subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ice, debug) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: time_step !< The time step for this update [T ~> s]. + type(forcing), intent(inout) :: fluxes !< structure containing pointers to any possible + !! thermodynamic or mass-flux forcing fields. + real, intent(in) :: density_ice !< The density of ice-shelf ice [R ~> kg m-3]. + logical, optional, intent(in) :: debug !< If present and true, write chksums + + ! locals + real :: I_rho_ice ! Ice specific volume [R-1 ~> m3 kg-1] + integer :: i, j + + I_rho_ice = 1.0 / density_ice + + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + ! first, zero out fluxes applied during previous time step + if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 + if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 + if (associated(fluxes%frac_shelf_h)) fluxes%frac_shelf_h(i,j) = 0.0 + if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 + + if (ISS%water_flux(i,j) * time_step / density_ice < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - ISS%water_flux(i,j) * time_step / density_ice + else + ! the ice is about to melt away, so set thickness, area, and mask to zero + ! NOTE: this is not mass conservative should maybe scale salt & heat flux for this cell + ISS%h_shelf(i,j) = 0.0 + ISS%hmask(i,j) = 0.0 + ISS%area_shelf_h(i,j) = 0.0 + endif + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * density_ice + endif + enddo ; enddo + + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain) + +end subroutine change_thickness_using_melt + +!> This subroutine adds the mechanical forcing fields and perhaps shelf areas, based on +!! the ice state in ice_shelf_CS. +subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_call) + type(ocean_grid_type), intent(in) :: Ocn_grid !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ice_shelf_CS), pointer :: CS !< This module's control structure. + type(mech_forcing), intent(inout) :: forces !< A structure with the + !! driving mechanical forces + logical, optional, intent(in) :: do_shelf_area !< If true find the shelf-covered areas. + logical, optional, intent(in) :: external_call !< If true the incoming forcing type + !! is using the input grid metric and needs + !! to be rotated. + type(ocean_grid_type), pointer :: G => NULL() !< A pointer to the ocean grid metric. +! type(mech_forcing), target :: forces !< A structure with the driving mechanical forces + real :: kv_rho_ice ! The viscosity of ice divided by its density [L4 T-1 R-1 Z-2 ~> m5 kg-1 s-1]. + real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. + logical :: find_area ! If true find the shelf areas at u & v points. + logical :: rotate = .false. + type(ice_shelf_state), pointer :: ISS => NULL() ! A structure with elements that describe + ! the ice-shelf state + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + + if (present(external_call)) rotate=external_call + + if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & + (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & + call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") + + if (CS%rotate_index .and. rotate) then + call MOM_error(FATAL,"add_shelf_forces: Rotation not implemented for ice shelves.") + ! allocate(forces) + ! call allocate_mech_forcing(forces_in, CS%Grid, forces) + ! call rotate_mech_forcing(forces_in, CS%turns, forces) + ! else + ! if ((Ocn_grid%isc /= CS%Grid%isc) .or. (Ocn_grid%iec /= CS%Grid%iec) .or. & + ! (Ocn_grid%jsc /= CS%Grid%jsc) .or. (Ocn_grid%jec /= CS%Grid%jec)) & + ! call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") + + ! forces=>forces_in + endif + + G=>CS%Grid + + + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + + ISS => CS%ISS + + find_area = .true. ; if (present(do_shelf_area)) find_area = do_shelf_area + + if (find_area) then + ! The frac_shelf is set over the widest possible area. Could it be smaller? + do j=jsd,jed ; do I=isd,ied-1 + forces%frac_shelf_u(I,j) = 0.0 + if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%areaCu(I,j) > 0.0)) & + forces%frac_shelf_u(I,j) = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i+1,j)) / & + (G%areaT(i,j) + G%areaT(i+1,j)) + enddo ; enddo + do J=jsd,jed-1 ; do i=isd,ied + forces%frac_shelf_v(i,J) = 0.0 + if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%areaCv(i,J) > 0.0)) & + forces%frac_shelf_v(i,J) = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) / & + (G%areaT(i,j) + G%areaT(i,j+1)) + enddo ; enddo + call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) + endif + + do j=js,je ; do i=is,ie + press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * ISS%mass_shelf(i,j)) + if (associated(forces%p_surf)) then + if (.not.forces%accumulate_p_surf) forces%p_surf(i,j) = 0.0 + forces%p_surf(i,j) = forces%p_surf(i,j) + press_ice + endif + if (associated(forces%p_surf_full)) then + if (.not.forces%accumulate_p_surf) forces%p_surf_full(i,j) = 0.0 + forces%p_surf_full(i,j) = forces%p_surf_full(i,j) + press_ice + endif + enddo ; enddo + + ! For various reasons, forces%rigidity_ice_[uv] is always updated here. Note + ! that it may have been zeroed out where IOB is translated to forces and + ! contributions from icebergs and the sea-ice pack added subsequently. + !### THE RIGIDITY SHOULD ALSO INCORPORATE AREAL-COVERAGE INFORMATION. + kv_rho_ice = CS%kv_ice / CS%density_ice + do j=js,je ; do I=is-1,ie + if (.not.forces%accumulate_rigidity) forces%rigidity_ice_u(I,j) = 0.0 + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + & + kv_rho_ice * min(ISS%mass_shelf(i,j), ISS%mass_shelf(i+1,j)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + if (.not.forces%accumulate_rigidity) forces%rigidity_ice_v(i,J) = 0.0 + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + & + kv_rho_ice * min(ISS%mass_shelf(i,j), ISS%mass_shelf(i,j+1)) + enddo ; enddo + + if (CS%debug) then + call uvchksum("rigidity_ice_[uv]", forces%rigidity_ice_u, & + forces%rigidity_ice_v, CS%Grid%HI, symmetric=.true., & + scale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) + call uvchksum("frac_shelf_[uv]", forces%frac_shelf_u, & + forces%frac_shelf_v, CS%Grid%HI, symmetric=.true., & + scalar_pair=.true.) + endif + + ! if (CS%rotate_index .and. rotate) then + ! call rotate_mech_forcing(forces, -CS%turns, forces_in) + ! ! TODO: deallocate mech forcing? + ! endif + +end subroutine add_shelf_forces + +!> This subroutine adds the ice shelf pressure to the fluxes type. +subroutine add_shelf_pressure(Ocn_grid, US, CS, fluxes) + type(ocean_grid_type), intent(in) :: Ocn_grid !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ice_shelf_CS), intent(in) :: CS !< This module's control structure. + type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be updated. + + type(ocean_grid_type), pointer :: G => NULL() ! A pointer to ocean's grid structure. + real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. + integer :: i, j, is, ie, js, je + + G=>CS%Grid + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if ((CS%grid%isc /= G%isc) .or. (CS%grid%iec /= G%iec) .or. & + (CS%grid%jsc /= G%jsc) .or. (CS%grid%jec /= G%jec)) & + call MOM_error(FATAL,"add_shelf_pressure: Incompatible ocean and ice shelf grids.") + + do j=js,je ; do i=is,ie + press_ice = (CS%ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * CS%ISS%mass_shelf(i,j)) + if (associated(fluxes%p_surf)) then + if (.not.fluxes%accumulate_p_surf) fluxes%p_surf(i,j) = 0.0 + fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + press_ice + endif + if (associated(fluxes%p_surf_full)) then + if (.not.fluxes%accumulate_p_surf) fluxes%p_surf_full(i,j) = 0.0 + fluxes%p_surf_full(i,j) = fluxes%p_surf_full(i,j) + press_ice + endif + enddo ; enddo + +end subroutine add_shelf_pressure + +!> Updates surface fluxes that are influenced by sub-ice-shelf melting +subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ice_shelf_CS), pointer :: CS !< This module's control structure. + type(surface), intent(inout) :: sfc_state !< Surface ocean state + type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. + real, intent(in) :: time_step !< Time step over which fluxes are applied + ! local variables + real :: frac_shelf !< The fractional area covered by the ice shelf [nondim]. + real :: frac_open !< The fractional area of the ocean that is not covered by the ice shelf [nondim]. + real :: delta_mass_shelf !< Change in ice shelf mass over one time step [R Z m2 T-1 ~> kg s-1] + real :: balancing_flux !< The fresh water flux that balances the integrated melt flux [R Z T-1 ~> kg m-2 s-1] + real :: balancing_area !< total area where the balancing flux is applied [m2] + type(time_type) :: dTime !< The time step as a time_type + type(time_type) :: Time0 !< The previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: bal_frac !< Fraction of the cell where the mass flux + !! balancing the net melt flux occurs, 0 to 1 [nondim] + real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass + !! at at previous time (Time-dt) [R Z ~> kg m-2] + real, dimension(SZDI_(G),SZDJ_(G)) :: delta_float_mass !< The change in the floating mass between + !! the two timesteps at (Time) and (Time-dt) [R Z ~> kg m-2]. + real, dimension(SZDI_(G),SZDJ_(G)) :: last_h_shelf !< Ice shelf thickness [Z ~> m] + !! at at previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: last_hmask !< Ice shelf mask [nondim] + !! at at previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: last_area_shelf_h !< Ice shelf area [L2 ~> m2] + !! at at previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: delta_draft !< change in ice shelf draft thickness [L ~> m] + !! since previous time (Time-dt) + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + + character(len=160) :: mesg ! The text of an error message + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + + if ((CS%grid%isc /= G%isc) .or. (CS%grid%iec /= G%iec) .or. & + (CS%grid%jsc /= G%jsc) .or. (CS%grid%jec /= G%jec)) & + call MOM_error(FATAL,"add_shelf_flux: Incompatible ocean and ice shelf grids.") + + ISS => CS%ISS + + + call add_shelf_pressure(G, US, CS, fluxes) + + ! Determine ustar and the square magnitude of the velocity in the + ! bottom boundary layer. Together these give the TKE source and + ! vertical decay scale. + + if (CS%debug) then + if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then + call uvchksum("tau[xy]_shelf", sfc_state%taux_shelf, sfc_state%tauy_shelf, & + G%HI, haloshift=0, scale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + endif + endif + + if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then + do j=jsd,jed ; do i=isd,ied + if (G%areaT(i,j) > 0.0) & + fluxes%frac_shelf_h(i,j) = min(1.0, ISS%area_shelf_h(i,j) * G%IareaT(i,j)) + enddo ; enddo + endif + + if (CS%debug) then + call MOM_forcing_chksum("Before adding shelf fluxes", fluxes, G, CS%US, haloshift=0) + endif + + do j=js,je ; do i=is,ie ; if (ISS%area_shelf_h(i,j) > 0.0) then + ! Replace fluxes intercepted by the ice shelf with fluxes from the ice shelf + frac_shelf = min(1.0, ISS%area_shelf_h(i,j) * G%IareaT(i,j)) + frac_open = max(0.0, 1.0 - frac_shelf) + + if (associated(fluxes%sw)) fluxes%sw(i,j) = frac_open * fluxes%sw(i,j) + if (associated(fluxes%sw_vis_dir)) fluxes%sw_vis_dir(i,j) = frac_open * fluxes%sw_vis_dir(i,j) + if (associated(fluxes%sw_vis_dif)) fluxes%sw_vis_dif(i,j) = frac_open * fluxes%sw_vis_dif(i,j) + if (associated(fluxes%sw_nir_dir)) fluxes%sw_nir_dir(i,j) = frac_open * fluxes%sw_nir_dir(i,j) + if (associated(fluxes%sw_nir_dif)) fluxes%sw_nir_dif(i,j) = frac_open * fluxes%sw_nir_dif(i,j) + if (associated(fluxes%lw)) fluxes%lw(i,j) = frac_open * fluxes%lw(i,j) + if (associated(fluxes%latent)) fluxes%latent(i,j) = frac_open * fluxes%latent(i,j) + if (associated(fluxes%evap)) fluxes%evap(i,j) = frac_open * fluxes%evap(i,j) + if (associated(fluxes%lprec)) then + if (ISS%water_flux(i,j) > 0.0) then + fluxes%lprec(i,j) = frac_shelf*ISS%water_flux(i,j)*CS%flux_factor + frac_open * fluxes%lprec(i,j) + else + fluxes%lprec(i,j) = frac_open * fluxes%lprec(i,j) + fluxes%evap(i,j) = fluxes%evap(i,j) + frac_shelf*ISS%water_flux(i,j)*CS%flux_factor + endif + endif + + if (associated(fluxes%sens)) & + fluxes%sens(i,j) = frac_shelf*ISS%tflux_ocn(i,j)*CS%flux_factor + frac_open * fluxes%sens(i,j) + ! The salt flux should be mostly from sea ice, so perhaps none should be intercepted and this should be changed. + if (associated(fluxes%salt_flux)) & + fluxes%salt_flux(i,j) = frac_shelf * ISS%salt_flux(i,j)*CS%flux_factor + frac_open * fluxes%salt_flux(i,j) + endif ; enddo ; enddo + + if (CS%debug) then + call hchksum(ISS%water_flux, "water_flux add shelf fluxes", G%HI, haloshift=0, scale=US%RZ_T_to_kg_m2s) + call hchksum(ISS%tflux_ocn, "tflux_ocn add shelf fluxes", G%HI, haloshift=0, scale=US%QRZ_T_to_W_m2) + call MOM_forcing_chksum("After adding shelf fluxes", fluxes, G, CS%US, haloshift=0) + endif + + ! Keep sea level constant by removing mass via a balancing flux that might be applied + ! in the open ocean or the sponge region (via virtual precip, vprec). Apply additional + ! salt/heat fluxes so that the resultant surface buoyancy forcing is ~ 0. + ! This is needed for some of the ISOMIP+ experiments. + + if (CS%constant_sea_level) then + if (.not. associated(fluxes%salt_flux)) allocate(fluxes%salt_flux(ie,je)) + if (.not. associated(fluxes%vprec)) allocate(fluxes%vprec(ie,je)) + fluxes%salt_flux(:,:) = 0.0 ; fluxes%vprec(:,:) = 0.0 + + ! take into account changes in mass (or thickness) when imposing ice shelf mass + if (CS%override_shelf_movement .and. CS%mass_from_file) then + dTime = real_to_time(US%T_to_s*CS%time_step) + + ! Compute changes in mass after at least one full time step + if (CS%Time > dTime) then + Time0 = CS%Time - dTime + do j=js,je ; do i=is,ie + last_hmask(i,j) = ISS%hmask(i,j) ; last_area_shelf_h(i,j) = ISS%area_shelf_h(i,j) + enddo ; enddo + call time_interp_external(CS%mass_handle, Time0, last_mass_shelf) + do j=js,je ; do i=is,ie + ! This should only be done if time_interp_extern did an update. + last_mass_shelf(i,j) = US%kg_m3_to_R*US%m_to_Z * last_mass_shelf(i,j) ! Rescale after time_interp + last_h_shelf(i,j) = last_mass_shelf(i,j) / CS%density_ice + enddo ; enddo + + ! apply calving + if (CS%min_thickness_simple_calve > 0.0) then + call ice_shelf_min_thickness_calve(G, last_h_shelf, last_area_shelf_h, last_hmask, & + CS%min_thickness_simple_calve, halo=0) + ! convert to mass again + do j=js,je ; do i=is,ie + last_mass_shelf(i,j) = last_h_shelf(i,j) * CS%density_ice + enddo ; enddo + endif + + ! get total ice shelf mass at (Time-dt) and (Time), in kg + do j=js,je ; do i=is,ie + ! Just consider the change in the mass of the floating shelf. + if ((sfc_state%ocean_mass(i,j) > CS%min_ocean_mass_float) .and. & + (ISS%area_shelf_h(i,j) > 0.0)) then + delta_float_mass(i,j) = ISS%mass_shelf(i,j) - last_mass_shelf(i,j) + else + delta_float_mass(i,j) = 0.0 + endif + enddo ; enddo + delta_mass_shelf = global_area_integral(delta_float_mass, G, tmp_scale=US%RZ_to_kg_m2, & + area=ISS%area_shelf_h) / CS%time_step + else! first time step + delta_mass_shelf = 0.0 + endif + else + if (CS%active_shelf_dynamics) then ! change in ice_shelf draft + do j=js,je ; do i=is,ie + last_h_shelf(i,j) = ISS%h_shelf(i,j) - time_step * ISS%dhdt_shelf(i,j) + enddo ; enddo + call change_in_draft(CS%dCS, G, last_h_shelf, ISS%h_shelf, delta_draft) + + !this currently assumes area_shelf_h is constant over the time step + delta_mass_shelf = global_area_integral(delta_draft, G, tmp_scale=US%RZ_to_kg_m2, & + area=ISS%area_shelf_h) & + * CS%Rho_ocn / CS%time_step + else ! ice shelf mass does not change + delta_mass_shelf = 0.0 + endif + endif + + ! average total melt flux over sponge area (ISOMIP/MISOMIP only) or open ocean (general case) + do j=js,je ; do i=is,ie + if (CS%constant_sea_level_misomip) then !for ismip/misomip only + if (G%geoLonT(i,j) >= 790.0) then + bal_frac(i,j) = max(1.0 - ISS%area_shelf_h(i,j) * G%IareaT(i,j), 0.0) + else + bal_frac(i,j) = 0.0 + endif + elseif ((G%mask2dT(i,j) > 0.0) .and. (ISS%area_shelf_h(i,j) * G%IareaT(i,j) < 1.0)) then !general case + bal_frac(i,j) = max(1.0 - ISS%area_shelf_h(i,j) * G%IareaT(i,j), 0.0) + else + bal_frac(i,j) = 0.0 + endif + enddo ; enddo + + balancing_area = global_area_integral(bal_frac, G, area=G%areaT) + if (balancing_area > 0.0) then + balancing_flux = ( global_area_integral(ISS%water_flux, G, tmp_scale=US%RZ_T_to_kg_m2s, & + area=ISS%area_shelf_h) + & + delta_mass_shelf ) / balancing_area + else + balancing_flux = 0.0 + endif + + ! apply fluxes + do j=js,je ; do i=is,ie + if (bal_frac(i,j) > 0.0) then + ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] + fluxes%vprec(i,j) = -balancing_flux + fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [Q R Z T-1 ~> W m-2] + fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3*US%S_to_ppt ! [1e-3 S R Z T-1 ~> kgSalt m-2 s-1] + endif + enddo ; enddo + + if (CS%debug) then + write(mesg,*) 'Balancing flux (kg/(m^2 s)), dt = ', balancing_flux*US%RZ_T_to_kg_m2s, US%T_to_s*CS%time_step + call MOM_mesg(mesg) + call MOM_forcing_chksum("After constant sea level", fluxes, G, CS%US, haloshift=0) + endif + + endif ! constant_sea_level + +end subroutine add_shelf_flux + + +!> Initializes shelf model data, parameters and diagnostics +subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, directory, forces_in, & + fluxes_in, sfc_state_in, solo_ice_sheet_in) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure + type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(MOM_diag_ctrl), pointer :: diag !< This is a pointer to the MOM diag CS + !! which will be discarded + type(time_type), intent(in) :: Time_init !< The time at initialization. + character(len=*), intent(in) :: directory !< The directory where the energy file goes. + + type(mech_forcing), optional, target, intent(inout) :: forces_in !< A structure with the driving mechanical forces + type(forcing), optional, target, intent(inout) :: fluxes_in !< A structure containing pointers to any + !! possible thermodynamic or mass-flux forcing fields. + type(surface), target, optional, intent(inout) :: sfc_state_in !< A structure containing fields that + !! describe the surface state of the ocean. The + !! intent is only inout to allow for halo updates. + logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether + !! a solo ice-sheet driver. + + type(ocean_grid_type), pointer :: G => NULL(), OG => NULL() ! Pointers to grids for convenience. + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + type(directories) :: dirs + type(dyn_horgrid_type), pointer :: dG => NULL() + real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic. + real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered + ! to be floating when CONST_SEA_LEVEL = True [Z ~> m]. + real :: cdrag, drag_bg_vel + logical :: new_sim, save_IC + !This include declares and sets the variable "version". +# include "version_variable.h" + character(len=200) :: IC_file, inputdir ! Input file names or paths + character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq + integer :: wd_halos(2) + logical :: read_TideAmp, debug + logical :: global_indexing + character(len=240) :: Tideamp_file ! Input file names + character(len=80) :: tideamp_var ! Input file variable names + real :: utide ! A tidal velocity [L T-1 ~> m s-1] + real :: col_thick_melt_thresh ! An ocean column thickness below which iceshelf melting + ! does not occur [Z ~> m] + real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for storing ice shelf input data + + type(surface), pointer :: sfc_state => NULL() + type(vardesc) :: u_desc, v_desc + + if (associated(CS)) then + call MOM_error(FATAL, "MOM_ice_shelf.F90, initialize_ice_shelf: "// & + "called with an associated control structure.") + return + endif + allocate(CS) + + ! Go through all of the infrastructure initialization calls, since this is + ! being treated as an independent component that just happens to use the + ! MOM's grid and infrastructure. + call Get_MOM_Input(dirs=dirs) + + call MOM_IS_diag_mediator_infrastructure_init() + + ! Determining the internal unit scaling factors for this run. + call unit_scaling_init(param_file, CS%US) + + call get_param(param_file, mdl, "ROTATE_INDEX", CS%rotate_index, & + "Enable rotation of the horizontal indices.", default=.false., & + debuggingParam=.true.) + + call get_param(param_file, "MOM", "GLOBAL_INDEXING", global_indexing, & + "If true, use a global lateral indexing convention, so "//& + "that corresponding points on different processors have "//& + "the same index. This does not work with static memory.", & + default=.false., layoutParam=.true.) + + ! Set up the ice-shelf domain and grid + wd_halos(:)=0 + allocate(CS%Grid) + call MOM_domains_init(CS%Grid%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& + domain_name='MOM_Ice_Shelf_in') + !allocate(CS%Grid_in%HI) + !call hor_index_init(CS%Grid%Domain, CS%Grid%HI, param_file, & + ! local_indexing=.not.global_indexing) + call MOM_grid_init(CS%Grid, param_file, CS%US) + + ! if (CS%rotate_index) then + ! ! TODO: Index rotation currently only works when index rotation does not + ! ! change the MPI rank of each domain. Resolving this will require a + ! ! modification to FMS PE assignment. + ! ! For now, we only permit single-core runs. + + ! if (num_PEs() /= 1) & + ! call MOM_error(FATAL, "Index rotation is only supported on one PE.") + + ! call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & + ! "Number of counterclockwise quarter-turn index rotations.", & + ! default=1, debuggingParam=.true.) + ! ! NOTE: If indices are rotated, then CS%Grid and CS%Grid_in must both be initialized. + ! ! If not rotated, then CS%Grid_in and CS%Ggrid are the same grid. + ! allocate(CS%Grid) + ! !allocate(CS%HI) + ! call clone_MOM_domain(CS%Grid_in%Domain, CS%Grid%Domain,turns=CS%turns) + ! call rotate_hor_index(CS%Grid_in%HI, CS%turns, CS%Grid%HI) + ! call MOM_grid_init(CS%Grid, param_file, CS%US, CS%HI) + ! call create_dyn_horgrid(dG, CS%Grid%HI) + ! call create_dyn_horgrid(dG_in, CS%Grid_in%HI) + ! call clone_MOM_domain(CS%Grid_in%Domain, dG_in%Domain) + ! ! Set up the bottom depth, G%D either analytically or from file + ! call set_grid_metrics(dG_in,param_file,CS%US) + ! call MOM_initialize_topography(dG_in%bathyT, CS%Grid_in%max_depth, dG_in, param_file) + ! call rescale_dyn_horgrid_bathymetry(dG_in, CS%US%Z_to_m) + ! call rotate_dyngrid(dG_in, dG, CS%US, CS%turns) + ! call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) + ! else + !CS%Grid=>CS%Grid_in + dG => NULL() + !CS%Grid%HI=>CS%Grid_in%HI + call create_dyn_horgrid(dG, CS%Grid%HI) + call clone_MOM_domain(CS%Grid%Domain,dG%Domain) + call set_grid_metrics(dG,param_file,CS%US) + ! Set up the bottom depth, dG%bathyT, either analytically or from file + call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file, CS%US) + call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) + call destroy_dyn_horgrid(dG) +! endif + G => CS%Grid ; CS%Grid_in => CS%Grid + + allocate(CS%diag) + call MOM_IS_diag_mediator_init(G, CS%US, param_file, CS%diag, component='MOM_IceShelf') + ! This call sets up the diagnostic axes. These are needed, + ! e.g. to generate the target grids below. + call set_IS_axes_info(G, param_file, CS%diag) + + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + + ! The ocean grid possibly uses different symmetry. + if (associated(ocn_grid)) then ; CS%ocn_grid => ocn_grid + else ; CS%ocn_grid => CS%grid ; endif + + ! Convenience pointers + OG => CS%ocn_grid + US => CS%US + + ! Are we being called from the solo ice-sheet driver? When called by the ocean + ! model solo_ice_sheet_in is not preset. + CS%solo_ice_sheet = .false. + if (present(solo_ice_sheet_in)) CS%solo_ice_sheet = solo_ice_sheet_in + + !if (present(Time_in)) Time = Time_in + + + CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) + call get_param(param_file, mdl, "DEBUG_IS", CS%debug, & + "If true, write verbose debugging messages for the ice shelf.", & + default=debug) + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", CS%shelf_mass_is_dynamic, & + "If true, the ice sheet mass can evolve with time.", & + default=.false.) + if (CS%shelf_mass_is_dynamic) then + call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", CS%override_shelf_movement, & + "If true, user provided code specifies the ice-shelf "//& + "movement instead of the dynamic ice model.", default=.false.) + CS%active_shelf_dynamics = .not.CS%override_shelf_movement + call get_param(param_file, mdl, "DATA_OVERRIDE_SHELF_FLUXES", & + CS%data_override_shelf_fluxes, & + "If true, the data override feature is used to write "//& + "the surface mass flux deposition. This option is only "//& + "available for MOSAIC grid types.", default=.false.) + call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & + "If true, regularize the floatation condition at the "//& + "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) + call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & + "If true, let the floatation condition be determined by "//& + "ocean column thickness. This means that update_OD_ffrac "//& + "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & + default=.false., do_not_log=CS%GL_regularize) + if (CS%GL_regularize) CS%GL_couple = .false. + if (CS%solo_ice_sheet) CS%GL_couple = .false. + endif + + call get_param(param_file, mdl, "SHELF_THERMO", CS%isthermo, & + "If true, use a thermodynamically interactive ice shelf.", & + default=.false.) + call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%Lat_fusion, & + "The latent heat of fusion.", units="J/kg", default=hlf, scale=US%J_kg_to_Q) + call get_param(param_file, mdl, "SHELF_THREE_EQN", CS%threeeq, & + "If true, use the three equation expression of "//& + "consistency to calculate the fluxes at the ice-ocean "//& + "interface.", default=.true.) + call get_param(param_file, mdl, "SHELF_INSULATOR", CS%insulator, & + "If true, the ice shelf is a perfect insulator "//& + "(no conduction).", default=.false.) + call get_param(param_file, mdl, "MELTING_CUTOFF_DEPTH", CS%cutoff_depth, & + "Depth above which the melt is set to zero (it must be >= 0) "//& + "Default value won't affect the solution.", units="m", default=0.0, scale=US%m_to_Z) + if (CS%cutoff_depth < 0.) & + call MOM_error(WARNING,"Initialize_ice_shelf: MELTING_CUTOFF_DEPTH must be >= 0.") + + call get_param(param_file, mdl, "CONST_SEA_LEVEL", CS%constant_sea_level, & + "If true, apply evaporative, heat and salt fluxes in "//& + "the sponge region. This will avoid a large increase "//& + "in sea level. This option is needed for some of the "//& + "ISOMIP+ experiments (Ocean3 and Ocean4). "//& + "IMPORTANT: it is not currently possible to do "//& + "prefect restarts using this flag.", default=.false.) + call get_param(param_file, mdl, "CONST_SEA_LEVEL_MISOMIP", CS%constant_sea_level_misomip, & + "If true, constant_sea_level fluxes are applied only over "//& + "the surface sponge cells from the ISOMIP/MISOMIP configuration", default=.false.) + call get_param(param_file, mdl, "MIN_OCEAN_FLOAT_THICK", dz_ocean_min_float, & + "The minimum ocean thickness above which the ice shelf is considered to be "//& + "floating when CONST_SEA_LEVEL = True.", & + default=0.1, units="m", scale=US%m_to_Z, do_not_log=.not.CS%constant_sea_level) + + call get_param(param_file, mdl, "ISOMIP_S_SUR_SPONGE", CS%S0, & + "Surface salinity in the restoring region.", & + default=33.8, units='ppt', scale=US%ppt_to_S, do_not_log=.true.) + + call get_param(param_file, mdl, "ISOMIP_T_SUR_SPONGE", CS%T0, & + "Surface temperature in the restoring region.", & + default=-1.9, units='degC', scale=US%degC_to_C, do_not_log=.true.) + + call get_param(param_file, mdl, "SHELF_3EQ_GAMMA", CS%const_gamma, & + "If true, user specifies a constant nondimensional heat-transfer coefficient "//& + "(GAMMA_T_3EQ), from which the default salt-transfer coefficient is set "//& + "as GAMMA_T_3EQ/35. This is used with SHELF_THREE_EQN.", default=.false.) + call get_param(param_file, mdl, "SHELF_S_ROOT", CS%find_salt_root, & + "If SHELF_S_ROOT = True, salinity at the ice/ocean interface (Sbdry) "//& + "is computed from a quadratic equation. Otherwise, the previous "//& + "interactive method to estimate Sbdry is used.", & + default=.false., do_not_log=.not.CS%threeeq) + if (.not.CS%threeeq) then + call get_param(param_file, mdl, "SHELF_2EQ_GAMMA_T", CS%gamma_t, & + "If SHELF_THREE_EQN is false, this the fixed turbulent "//& + "exchange velocity at the ice-ocean interface.", & + units="m s-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) + endif + if (CS%const_gamma .or. CS%find_salt_root) then + call get_param(param_file, mdl, "SHELF_3EQ_GAMMA_T", CS%Gamma_T_3EQ, & + "Nondimensional heat-transfer coefficient.", & + units="nondim", default=2.2e-2) + call get_param(param_file, mdl, "SHELF_3EQ_GAMMA_S", CS%Gamma_S_3EQ, & + "Nondimensional salt-transfer coefficient.", & + default=CS%Gamma_T_3EQ/35.0, units="nondim") + endif + + call get_param(param_file, mdl, "ICE_SHELF_MASS_FROM_FILE", & + CS%mass_from_file, "Read the mass of the "//& + "ice shelf (every time step) from a file.", default=.false.) + + if (CS%find_salt_root) then ! read liquidus coeffs. + call get_param(param_file, mdl, "TFREEZE_S0_P0", CS%TFr_0_0, & + "this is the freezing potential temperature at "//& + "S=0, P=0.", units="degC", default=0.0, scale=US%degC_to_C, do_not_log=.true.) + call get_param(param_file, mdl, "DTFREEZE_DS", CS%dTFr_dS, & + "this is the derivative of the freezing potential temperature with salinity.", & + units="degC psu-1", default=-0.054, scale=US%degC_to_C*US%S_to_ppt, do_not_log=.true.) + call get_param(param_file, mdl, "DTFREEZE_DP", CS%dTFr_dp, & + "this is the derivative of the freezing potential temperature with pressure.", & + units="degC Pa-1", default=0.0, scale=US%degC_to_C*US%RL2_T2_to_Pa, do_not_log=.true.) + endif + + call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & + "The gravitational acceleration of the Earth.", & + units="m s-2", default=9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "C_P", CS%Cp, & + "The heat capacity of sea water, approximated as a constant. "//& + "The default value is from the TEOS-10 definition of conservative temperature.", & + units="J kg-1 K-1", default=3991.86795711963, scale=US%J_kg_to_Q*US%C_to_degC) + call get_param(param_file, mdl, "RHO_0", CS%Rho_ocn, & + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, & + "The heat capacity of ice.", units="J kg-1 K-1", scale=US%J_kg_to_Q*US%C_to_degC, & + default=2.10e3) + if (CS%constant_sea_level) CS%min_ocean_mass_float = dz_ocean_min_float*CS%Rho_ocn + + call get_param(param_file, mdl, "ICE_SHELF_FLUX_FACTOR", CS%flux_factor, & + "Non-dimensional factor applied to shelf thermodynamic fluxes.", & + units="none", default=1.0) + + call get_param(param_file, mdl, "KV_ICE", CS%kv_ice, & + "The viscosity of the ice.", & + units="m2 s-1", default=1.0e10, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KV_MOLECULAR", CS%kv_molec, & + "The molecular kinematic viscosity of sea water at the freezing temperature.", & + units="m2 s-1", default=1.95e-6, scale=US%m2_s_to_Z2_T) + call get_param(param_file, mdl, "ICE_SHELF_SALINITY", CS%Salin_ice, & + "The salinity of the ice inside the ice shelf.", & + units="psu", default=0.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "ICE_SHELF_TEMPERATURE", CS%Temp_ice, & + "The temperature at the center of the ice shelf.", & + units="degC", default=-15.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "KD_SALT_MOLECULAR", CS%kd_molec_salt, & + "The molecular diffusivity of salt in sea water at the "//& + "freezing point.", units="m2 s-1", default=8.02e-10, scale=US%m2_s_to_Z2_T) + call get_param(param_file, mdl, "KD_TEMP_MOLECULAR", CS%kd_molec_temp, & + "The molecular diffusivity of heat in sea water at the "//& + "freezing point.", units="m2 s-1", default=1.41e-7, scale=US%m2_s_to_Z2_T) + call get_param(param_file, mdl, "DT_FORCING", CS%time_step, & + "The time step for changing forcing, coupling with other "//& + "components, or potentially writing certain diagnostics. "//& + "The default value is given by DT.", units="s", default=0.0, scale=US%s_to_T) + + call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", col_thick_melt_thresh, & + "The minimum ocean column thickness where melting is allowed.", & + units="m", scale=US%m_to_Z, default=0.0) + CS%col_mass_melt_threshold = CS%Rho_ocn * col_thick_melt_thresh + + call get_param(param_file, mdl, "READ_TIDEAMP", read_TIDEAMP, & + "If true, read a file (given by TIDEAMP_FILE) containing "//& + "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) + call get_param(param_file, mdl, "ICE_SHELF_LINEAR_SHELF_FRAC", CS%Zeta_N, & + "Ratio of HJ99 stability constant xi_N (ratio of maximum "//& + "mixing length to planetary boundary layer depth in "//& + "neutrally stable conditions) to the von Karman constant", & + units="nondim", default=0.13) + call get_param(param_file, mdl, "ICE_SHELF_VK_CNST", CS%Vk, & + "Von Karman constant.", & + units="nondim", default=0.40) + call get_param(param_file, mdl, "ICE_SHELF_RC", CS%Rc, & + "Critical flux Richardson number for ice melt ", & + units="nondim", default=0.20) + call get_param(param_file, mdl, "ICE_SHELF_BUOYANCY_FLUX_ITT_BUG", CS%buoy_flux_itt_bug, & + "Bug fix of buoyancy iteration", default=.true.) + call get_param(param_file, mdl, "ICE_SHELF_SALT_FLUX_ITT_BUG", CS%salt_flux_itt_bug, & + "Bug fix of salt iteration", default=.true.) + call get_param(param_file, mdl, "ICE_SHELF_BUOYANCY_FLUX_ITT_THRESHOLD", CS%buoy_flux_itt_threshold, & + "Convergence criterion of Newton's method for ice shelf "//& + "buoyancy iteration.", units="nondim", default=1.0e-4) + + if (PRESENT(sfc_state_in)) then + allocate(sfc_state) + ! assuming frazil is enabled in ocean. This could break some configurations? + call allocate_surface_state(sfc_state_in, CS%Grid_in, use_temperature=.true., & + do_integrals=.true., omit_frazil=.false., use_iceshelves=.true.) + if (CS%rotate_index) then + call rotate_surface_state(sfc_state_in, sfc_state,CS%Grid, CS%turns) + else + sfc_state=>sfc_state_in + endif + endif + + + call safe_alloc_ptr(CS%utide,isd,ied,jsd,jed) ; CS%utide(:,:) = 0.0 + + if (read_TIDEAMP) then + call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & + "The path to the file containing the spatially varying tidal amplitudes.", & + default="tideamp.nc") + call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & + "The name of the tidal amplitude variable in the input file.", & + default="tideamp") + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + TideAmp_file = trim(inputdir) // trim(TideAmp_file) + if (CS%rotate_index) then + allocate(tmp2d(CS%Grid_in%isd:CS%Grid_in%ied,CS%Grid_in%jsd:CS%Grid_in%jed), source=0.0) + call MOM_read_data(TideAmp_file, tideamp_var, tmp2d, CS%Grid_in%domain, timelevel=1, scale=US%m_s_to_L_T) + call rotate_array(tmp2d, CS%turns, CS%utide) + deallocate(tmp2d) + else + call MOM_read_data(TideAmp_file, tideamp_var, CS%utide, CS%Grid%domain, timelevel=1, scale=US%m_s_to_L_T) + endif + else + call get_param(param_file, mdl, "UTIDE", utide, & + "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & + units="m s-1", default=0.0 , scale=US%m_s_to_L_T) + CS%utide(:,:) = utide + endif + + call EOS_init(param_file, CS%eqn_of_state, US) + + !! new parameters that need to be in MOM_input + + if (CS%active_shelf_dynamics) then + + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & + "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) + + call get_param(param_file, mdl, "INPUT_FLUX_ICE_SHELF", CS%input_flux, & + "volume flux at upstream boundary", units="m2 s-1", default=0., scale=US%m_to_Z*US%m_s_to_L_T) + call get_param(param_file, mdl, "INPUT_THICK_ICE_SHELF", CS%input_thickness, & + "flux thickness at upstream boundary", units="m", default=1000., scale=US%m_to_Z) + else + ! This is here because of inconsistent defaults. I don't know why. RWH + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & + "A typical density of ice.", units="kg m-3", default=900.0, scale=US%kg_m3_to_R) + endif + call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & + CS%min_thickness_simple_calve, & + "Min thickness rule for the very simple calving law",& + units="m", default=0.0, scale=US%m_to_Z) + + call get_param(param_file, mdl, "USTAR_SHELF_BG", CS%ustar_bg, & + "The minimum value of ustar under ice shelves.", & + units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) + call get_param(param_file, mdl, "CDRAG_SHELF", cdrag, & + "CDRAG is the drag coefficient relating the magnitude of "//& + "the velocity field to the surface stress.", units="nondim", & + default=0.003) + CS%cdrag = cdrag + if (CS%ustar_bg <= 0.0) then + call get_param(param_file, mdl, "DRAG_BG_VEL_SHELF", drag_bg_vel, & + "DRAG_BG_VEL is either the assumed bottom velocity (with "//& + "LINEAR_DRAG) or an unresolved velocity that is "//& + "combined with the resolved velocity to estimate the "//& + "velocity magnitude.", units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) + if (CS%cdrag*drag_bg_vel > 0.0) CS%ustar_bg = sqrt(CS%cdrag)*drag_bg_vel + endif + call get_param(param_file, mdl, "USTAR_SHELF_FROM_VEL", CS%ustar_shelf_from_vel, & + "If true, use the surface velocities to set the friction velocity under ice "//& + "shelves instead of using the previous values of the stresses.", & + default=.true.) + call get_param(param_file, mdl, "USTAR_SHELF_MAX", CS%ustar_max, & + "The maximum value of ustar under ice shelves, or a negative value for no limit.", & + units="m s-1", default=-1.0, scale=US%m_to_Z*US%T_to_s, & + do_not_log=CS%ustar_shelf_from_vel) + + ! Allocate and initialize state variables to default values + call ice_shelf_state_init(CS%ISS, CS%grid) + ISS => CS%ISS + + new_sim = .false. + if ((dirs%input_filename(1:1) == 'n') .and. & + (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. + + ISS%area_shelf_h(:,:)=0.0 + ISS%h_shelf(:,:)=0.0 + ISS%hmask(:,:)=0.0 + ISS%mass_shelf(:,:)=0.0 + + if (CS%override_shelf_movement .and. CS%mass_from_file) then + + ! initialize the ids for reading shelf mass from a netCDF + call initialize_shelf_mass(G, param_file, CS, ISS) + + if (new_sim) then + ! new simulation, initialize ice thickness as in the static case + call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%Grid, CS%Grid_in, US, param_file, & + CS%rotate_index, CS%turns) + + ! next make sure mass is consistent with thickness + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2) .or. (ISS%hmask(i,j)==3)) then + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice + endif + enddo ; enddo + + if (CS%min_thickness_simple_calve > 0.0) & + call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & + CS%min_thickness_simple_calve) + endif + endif + + if (CS%active_shelf_dynamics) then + ! the only reason to initialize boundary conds is if the shelf is dynamic - MJH + + ! call initialize_ice_shelf_boundary ( CS%u_face_mask_bdry, CS%v_face_mask_bdry, & + ! CS%u_flux_bdry_val, CS%v_flux_bdry_val, & + ! CS%u_bdry_val, CS%v_bdry_val, CS%h_bdry_val, & + ! ISS%hmask, G, param_file) + + endif + + ! Set up the restarts. + + call restart_init(param_file, CS%restart_CSp, "Shelf.res") + call register_restart_field(ISS%mass_shelf, "shelf_mass", .true., CS%restart_CSp, & + "Ice shelf mass", "kg m-2", conversion=US%RZ_to_kg_m2) + call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & + "Ice shelf area in cell", "m2", conversion=US%L_to_m**2) + call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & + "ice sheet/shelf thickness", "m", conversion=US%Z_to_m) + if (PRESENT(sfc_state_in)) then + if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then + u_desc = var_desc("taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & + hor_grid='Cu',z_grid='1') + v_desc = var_desc("tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & + hor_grid='Cv',z_grid='1') + call register_restart_pair(sfc_state%taux_shelf, sfc_state%tauy_shelf, u_desc, v_desc, & + .false., CS%restart_CSp, conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + endif + endif + + if (CS%active_shelf_dynamics) then + call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & + "ice sheet/shelf thickness mask" ,"none") + endif + + if (CS%active_shelf_dynamics) then + ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics + call register_ice_shelf_dyn_restarts(CS%Grid_in, US, param_file, CS%dCS, CS%restart_CSp) + endif + + !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file + !if (.not. CS%solo_ice_sheet) then + ! call register_restart_field(fluxes%ustar_shelf, "ustar_shelf", .false., CS%restart_CSp, & + ! "Friction velocity under ice shelves", "m s-1", conversion=US%Z_to_m*US%s_to_T) + !endif + + CS%restart_output_dir = dirs%restart_output_dir + + + + if (new_sim .and. (.not. (CS%override_shelf_movement .and. CS%mass_from_file))) then + ! This model is initialized internally or from a file. + call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%Grid, CS%Grid_in, US, param_file,& + CS%rotate_index, CS%turns) + ! next make sure mass is consistent with thickness + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2) .or. (ISS%hmask(i,j) == 3)) then + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice + endif + enddo ; enddo + if (CS%debug) then + call hchksum(ISS%mass_shelf, "IS init: mass_shelf", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) + call hchksum(ISS%area_shelf_h, "IS init: area_shelf", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) + call hchksum(ISS%hmask, "IS init: hmask", G%HI, haloshift=0) + endif + + ! else ! Previous block for new_sim=.T., this block restores the state. + elseif (.not.new_sim) then + ! This line calls a subroutine that reads the initial conditions from a restart file. + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: Restoring ice shelf from file.") + call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, G, CS%restart_CSp) + + endif ! .not. new_sim + +! do j=G%jsc,G%jec ; do i=G%isc,G%iec +! ISS%area_shelf_h(i,j) = ISS%area_shelf_h(i,j)*G%mask2dT(i,j) +! enddo ; enddo + + id_clock_shelf = cpu_clock_id('Ice shelf', grain=CLOCK_COMPONENT) + id_clock_pass = cpu_clock_id(' Ice shelf halo updates', grain=CLOCK_ROUTINE) + + call cpu_clock_begin(id_clock_pass) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(G%bathyT, G%domain) + call cpu_clock_end(id_clock_pass) + + do j=jsd,jed ; do i=isd,ied + if (ISS%area_shelf_h(i,j) > G%areaT(i,j)) then + call MOM_error(WARNING,"Initialize_ice_shelf: area_shelf_h exceeds G%areaT.") + ISS%area_shelf_h(i,j) = G%areaT(i,j) + endif + enddo ; enddo + + if (CS%debug) then + call hchksum(ISS%area_shelf_h, "IS init: area_shelf_h", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) + endif + + CS%Time = Time + + if (CS%active_shelf_dynamics .and. .not.CS%isthermo) then + ISS%water_flux(:,:) = 0.0 + endif + + if (CS%shelf_mass_is_dynamic) & + call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, CS%diag, new_sim, & + Time_init, directory, solo_ice_sheet_in) + + call fix_restart_unit_scaling(US, unscaled=.true.) + + call get_param(param_file, mdl, "SAVE_INITIAL_CONDS", save_IC, & + "If true, save the ice shelf initial conditions.", default=.false.) + if (save_IC) call get_param(param_file, mdl, "SHELF_IC_OUTPUT_FILE", IC_file,& + "The name-root of the output file for the ice shelf initial conditions.", & + default="MOM_Shelf_IC") + + if (save_IC .and. .not.((dirs%input_filename(1:1) == 'r') .and. & + (LEN_TRIM(dirs%input_filename) == 1))) then + call save_restart(dirs%output_directory, CS%Time, CS%Grid_in, CS%restart_CSp, & + filename=IC_file, write_ic=.true.) + endif + + CS%id_area_shelf_h = register_diag_field('ice_shelf_model', 'area_shelf_h', CS%diag%axesT1, CS%Time, & + 'Ice Shelf Area in cell', 'meter2', conversion=US%L_to_m**2) + CS%id_shelf_mass = register_diag_field('ice_shelf_model', 'shelf_mass', CS%diag%axesT1, CS%Time, & + 'mass of shelf', 'kg/m^2', conversion=US%RZ_to_kg_m2) + CS%id_h_shelf = register_diag_field('ice_shelf_model', 'h_shelf', CS%diag%axesT1, CS%Time, & + 'ice shelf thickness', 'm', conversion=US%Z_to_m) + CS%id_dhdt_shelf = register_diag_field('ice_shelf_model', 'dhdt_shelf', CS%diag%axesT1, CS%Time, & + 'change in ice shelf thickness over time', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + CS%id_mass_flux = register_diag_field('ice_shelf_model', 'mass_flux', CS%diag%axesT1,& + CS%Time, 'Total mass flux of freshwater across the ice-ocean interface.', & + 'kg/s', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2) + + if (CS%const_gamma) then ! use ISOMIP+ eq. with rho_fw = 1000. kg m-3 + meltrate_conversion = 86400.0*365.0*US%Z_to_m*US%s_to_T / (1000.0*US%kg_m3_to_R) + else ! use original eq. + meltrate_conversion = 86400.0*365.0*US%Z_to_m*US%s_to_T / CS%density_ice + endif + CS%id_melt = register_diag_field('ice_shelf_model', 'melt', CS%diag%axesT1, CS%Time, & + 'Ice Shelf Melt Rate', 'm yr-1', conversion=meltrate_conversion) + CS%id_thermal_driving = register_diag_field('ice_shelf_model', 'thermal_driving', CS%diag%axesT1, CS%Time, & + 'pot. temp. in the boundary layer minus freezing pot. temp. at the ice-ocean interface.', & + 'Celsius', conversion=US%C_to_degC) + CS%id_haline_driving = register_diag_field('ice_shelf_model', 'haline_driving', CS%diag%axesT1, CS%Time, & + 'salinity in the boundary layer minus salinity at the ice-ocean interface.', & + 'psu', conversion=US%S_to_ppt) + CS%id_Sbdry = register_diag_field('ice_shelf_model', 'sbdry', CS%diag%axesT1, CS%Time, & + 'salinity at the ice-ocean interface.', 'psu', conversion=US%S_to_ppt) + CS%id_u_ml = register_diag_field('ice_shelf_model', 'u_ml', CS%diag%axesCu1, CS%Time, & + 'Eastward vel. in the boundary layer (used to compute ustar)', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_v_ml = register_diag_field('ice_shelf_model', 'v_ml', CS%diag%axesCv1, CS%Time, & + 'Northward vel. in the boundary layer (used to compute ustar)', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_exch_vel_s = register_diag_field('ice_shelf_model', 'exch_vel_s', CS%diag%axesT1, CS%Time, & + 'Sub-shelf salinity exchange velocity', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + CS%id_exch_vel_t = register_diag_field('ice_shelf_model', 'exch_vel_t', CS%diag%axesT1, CS%Time, & + 'Sub-shelf thermal exchange velocity', 'm s-1' , conversion=US%Z_to_m*US%s_to_T) + CS%id_tfreeze = register_diag_field('ice_shelf_model', 'tfreeze', CS%diag%axesT1, CS%Time, & + 'In Situ Freezing point at ice shelf interface', 'degC', conversion=US%C_to_degC) + CS%id_tfl_shelf = register_diag_field('ice_shelf_model', 'tflux_shelf', CS%diag%axesT1, CS%Time, & + 'Heat conduction into ice shelf', 'W m-2', conversion=-US%QRZ_T_to_W_m2) + CS%id_ustar_shelf = register_diag_field('ice_shelf_model', 'ustar_shelf', CS%diag%axesT1, CS%Time, & + 'Fric vel under shelf', 'm/s', conversion=US%Z_to_m*US%s_to_T) + if (CS%active_shelf_dynamics) then + CS%id_h_mask = register_diag_field('ice_shelf_model', 'h_mask', CS%diag%axesT1, CS%Time, & + 'ice shelf thickness mask', 'none') + CS%id_shelf_sfc_mass_flux = register_diag_field('ice_shelf_model', 'sfc_mass_flux', CS%diag%axesT1, CS%Time, & + 'ice shelf surface mass flux deposition from atmosphere', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + endif + call MOM_IS_diag_mediator_close_registration(CS%diag) + + if (present(fluxes_in)) call initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) + if (present(forces_in)) call initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) + +end subroutine initialize_ice_shelf + +subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(forcing), target, intent(inout) :: fluxes_in !< A structure containing pointers to any + !! possible thermodynamic or mass-flux forcing fields. + + ! Local variables + type(ocean_grid_type), pointer :: G => NULL() ! Pointers to grids for convenience. + type(forcing), pointer :: fluxes => NULL() + integer :: i, j, isd, ied, jsd, jed + + G => CS%Grid + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + + ! Allocate the arrays for passing ice-shelf data through the forcing type. + if (.not. CS%solo_ice_sheet) then + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes.") + ! GMM: the following assures that water/heat fluxes are just allocated + ! when SHELF_THERMO = True. These fluxes are necessary if one wants to + ! use either ENERGETICS_SFC_PBL (ALE mode) or BULKMIXEDLAYER (layer mode). + call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & + press=.true., water=CS%isthermo, heat=CS%isthermo, shelf_sfc_accumulation=CS%active_shelf_dynamics, & + tau_mag=.true.) + else + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") + call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & + press=.true., shelf_sfc_accumulation = CS%active_shelf_dynamics, tau_mag=.true.) + endif + if (CS%rotate_index) then + allocate(fluxes) + call allocate_forcing_type(fluxes_in, CS%Grid, fluxes) + call rotate_forcing(fluxes_in, fluxes, CS%turns) + else + fluxes=>fluxes_in + endif + + do j=jsd,jed ; do i=isd,ied + if (G%areaT(i,j)>0.) fluxes%frac_shelf_h(i,j) = CS%ISS%area_shelf_h(i,j) / G%areaT(i,j) + enddo ; enddo + if (CS%debug) call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) + call add_shelf_pressure(ocn_grid, US, CS, fluxes) + + if (CS%rotate_index) & + call rotate_forcing(fluxes, fluxes_in, -CS%turns) + +end subroutine initialize_ice_shelf_fluxes + +subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces + + ! Local variables + type(mech_forcing), pointer :: forces => NULL() + + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating forces.") + call allocate_mech_forcing(CS%Grid_in, forces_in, ustar=.true., shelf=.true., press=.true., tau_mag=.true.) + if (CS%rotate_index) then + allocate(forces) + call allocate_mech_forcing(forces_in, CS%Grid, forces) + call rotate_mech_forcing(forces_in, CS%turns, forces) + else + forces=>forces_in + endif + + call add_shelf_forces(ocn_grid, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) + + if (CS%rotate_index) & + call rotate_mech_forcing(forces, -CS%turns, forces_in) + +end subroutine initialize_ice_shelf_forces + +!> Initializes shelf mass based on three options (file, zero and user) +subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(inout) :: ISS !< The ice shelf state type that is being updated + logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted + + integer :: i, j, is, ie, js, je + logical :: read_shelf_area, new_sim_2 + character(len=240) :: config, inputdir, shelf_file, filename + character(len=120) :: shelf_mass_var ! The name of shelf mass in the file. + character(len=120) :: shelf_area_var ! The name of shelf area in the file. + character(len=40) :: mdl = "MOM_ice_shelf" + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + new_sim_2 = .true. ; if (present(new_sim)) new_sim_2 = new_sim + + call get_param(param_file, mdl, "ICE_SHELF_CONFIG", config, & + "A string that specifies how the ice shelf is "//& + "initialized. Valid options include:\n"//& + " \tfile\t Read from a file.\n"//& + " \tzero\t Set shelf mass to 0 everywhere.\n"//& + " \tUSER\t Call USER_initialize_shelf_mass.\n", & + fail_if_missing=.true.) + + select case ( trim(config) ) + case ("file") + + call time_interp_external_init() + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + call get_param(param_file, mdl, "SHELF_FILE", shelf_file, & + "If DYNAMIC_SHELF_MASS = True, OVERRIDE_SHELF_MOVEMENT = True "//& + "and ICE_SHELF_MASS_FROM_FILE = True, this is the file from "//& + "which to read the shelf mass and area.", & + default="shelf_mass.nc") + call get_param(param_file, mdl, "SHELF_MASS_VAR", shelf_mass_var, & + "The variable in SHELF_FILE with the shelf mass.", & + default="shelf_mass") + call get_param(param_file, mdl, "READ_SHELF_AREA", read_shelf_area, & + "If true, also read the area covered by ice-shelf from SHELF_FILE.", & + default=.false.) + + filename = trim(slasher(inputdir))//trim(shelf_file) + call log_param(param_file, mdl, "INPUTDIR/SHELF_FILE", filename) + + CS%mass_handle = init_external_field(filename, shelf_mass_var, & + MOM_domain=CS%Grid_in%Domain, verbose=CS%debug) + + if (read_shelf_area) then + call get_param(param_file, mdl, "SHELF_AREA_VAR", shelf_area_var, & + "The variable in SHELF_FILE with the shelf area.", & + default="shelf_area") + + CS%area_handle = init_external_field(filename, shelf_area_var, & + MOM_domain=CS%Grid_in%Domain) + endif + + if (.not.file_exists(filename, CS%Grid_in%Domain)) call MOM_error(FATAL, & + " initialize_shelf_mass: Unable to open "//trim(filename)) + + case ("zero") + do j=js,je ; do i=is,ie + ISS%mass_shelf(i,j) = 0.0 + ISS%area_shelf_h(i,j) = 0.0 + enddo ; enddo + + case ("USER") + call USER_initialize_shelf_mass(ISS%mass_shelf, ISS%area_shelf_h, & + ISS%h_shelf, ISS%hmask, G, CS%US, CS%user_CS, param_file, new_sim_2) + + case default ; call MOM_error(FATAL,"initialize_ice_shelf: "// & + "Unrecognized ice shelf setup "//trim(config)) + end select + +end subroutine initialize_shelf_mass +!> This subroutine applies net accumulation/ablation at the top surface to the dynamic ice shelf. +!>>acc_rate[m-s]=surf_mass_flux/density_ice is ablation/accumulation rate +!>>positive for accumulation negative for ablation +subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time) + type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(forcing), intent(in) :: fluxes !< A structure of surface fluxes that + !! includes surface mass flux + type(time_type), intent(in) :: Time !< The current model time + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: time_step !< The time step for this update [T ~> s]. + + ! locals + integer :: i, j + real ::I_rho_ice + + I_rho_ice = 1.0 / CS%density_ice + + !update time +! CS%Time = Time + + +! CS%time_step = time_step + ! update surface mass flux rate +! if (CS%surf_mass_flux_from_file) call update_surf_mass_flux(G, US, CS, ISS, Time) + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + + if (-fluxes%shelf_sfc_mass_flux(i,j) * time_step * I_rho_ice < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%h_shelf(i,j) + fluxes%shelf_sfc_mass_flux(i,j) * time_step * I_rho_ice + else + ! the ice is about to ablate, so set thickness, area, and mask to zero + ! NOTE: this is not mass conservative should maybe scale salt & heat flux for this cell + ISS%h_shelf(i,j) = 0.0 + ISS%hmask(i,j) = 0.0 + ISS%area_shelf_h(i,j) = 0.0 + endif + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * CS%density_ice + endif + enddo ; enddo + + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.true.) + +end subroutine change_thickness_using_precip + + +!> Updates the ice shelf mass using data from a file. +subroutine update_shelf_mass(G, US, CS, ISS, Time) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(inout) :: ISS !< The ice shelf state type that is being updated + type(time_type), intent(in) :: Time !< The current model time + + ! local variables + integer :: i, j, is, ie, js, je + real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for storing ice shelf input data + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + + if (CS%rotate_index) then + allocate(tmp2d(CS%Grid_in%isc:CS%Grid_in%iec,CS%Grid_in%jsc:CS%Grid_in%jec), source=0.0) + else + allocate(tmp2d(is:ie,js:je), source=0.0) + endif + + call time_interp_external(CS%mass_handle, Time, tmp2d) + call rotate_array(tmp2d, CS%turns, ISS%mass_shelf) + deallocate(tmp2d) + + ! This should only be done if time_interp_external did an update. + do j=js,je ; do i=is,ie + ISS%mass_shelf(i,j) = US%kg_m3_to_R*US%m_to_Z * ISS%mass_shelf(i,j) ! Rescale after time_interp + enddo ; enddo + + do j=js,je ; do i=is,ie + ISS%area_shelf_h(i,j) = 0.0 + ISS%hmask(i,j) = 0. + if (ISS%mass_shelf(i,j) > 0.0) then + ISS%area_shelf_h(i,j) = G%areaT(i,j) + ISS%h_shelf(i,j) = ISS%mass_shelf(i,j) / CS%density_ice + ISS%hmask(i,j) = 1. + endif + enddo ; enddo + + !call USER_update_shelf_mass(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, & + ! ISS%hmask, CS%grid, CS%user_CS, Time, .true.) + + if (CS%min_thickness_simple_calve > 0.0) then + call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & + CS%min_thickness_simple_calve, halo=0) + endif + + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.true.) + +end subroutine update_shelf_mass + +!> Save the ice shelf restart file +subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf, data_override_shelf_fluxes) + type(ice_shelf_CS), pointer :: CS !< ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< A pointer to an ocean grid control structure. + real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: frac_shelf_h !< Ice shelf area fraction [nondim]. + real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass_shelf ! kg m-2] + logical, optional :: data_override_shelf_fluxes !< If true, shelf fluxes can be written using + !! the data_override capability (only for MOSAIC grids) + + integer :: i, j + + if (present(frac_shelf_h)) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + frac_shelf_h(i,j) = 0.0 + if (G%areaT(i,j)>0.) frac_shelf_h(i,j) = CS%ISS%area_shelf_h(i,j) / G%areaT(i,j) + enddo ; enddo + endif + + if (present(mass_shelf)) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + mass_shelf(i,j) = 0.0 + if (G%areaT(i,j)>0.) mass_shelf(i,j) = CS%ISS%mass_shelf(i,j) + enddo ; enddo + 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 + endif + +end subroutine ice_shelf_query + +!> Save the ice shelf restart file +subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_suffix) + type(ice_shelf_CS), pointer :: CS !< ice shelf control structure + type(time_type), intent(in) :: Time !< model time at this call + character(len=*), optional, intent(in) :: directory !< An optional directory into which to write + !! these restart files. + logical, optional, intent(in) :: time_stamped !< f true, the restart file names include + !! a unique time stamp. The default is false. + character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a + !! time-stamp) to append to the restart file names. + ! local variables + type(ocean_grid_type), pointer :: G => NULL() + character(len=200) :: restart_dir + + G => CS%grid + + if (present(directory)) then ; restart_dir = directory + else ; restart_dir = CS%restart_output_dir ; endif + + call save_restart(restart_dir, Time, CS%grid_in, CS%restart_CSp, time_stamped) + +end subroutine ice_shelf_save_restart + +!> Deallocates all memory associated with this module +subroutine ice_shelf_end(CS) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + + if (.not.associated(CS)) return + + call ice_shelf_state_end(CS%ISS) + + if (CS%active_shelf_dynamics) call ice_shelf_dyn_end(CS%dCS) + + call MOM_IS_diag_mediator_end(CS%diag) + deallocate(CS) + +end subroutine ice_shelf_end + +!> This routine is for stepping a stand-alone ice shelf model without an ocean. +subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in, fluxes_in) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(time_type), intent(in) :: time_interval !< The time interval for this update [s]. + integer, intent(inout) :: nsteps !< The running number of ice shelf steps. + type(time_type), intent(inout) :: Time !< The current model time + real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step [T ~> s]. + type(forcing), optional, target, intent(inout) :: fluxes_in !< A structure containing pointers to any + !! possible thermodynamic or mass-flux forcing fields. + type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the ocean's grid structure + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + real :: remaining_time ! The remaining time in this call [T ~> s] + real :: time_step ! The internal time step during this call [T ~> s] + real :: full_time_step ! The external time step (sum of internal time steps) during this call [T ~> s] + real :: Ifull_time_step ! The inverse of the external time step [T-1 ~> s-1] + real :: min_time_step ! The minimal required timestep that would indicate a fatal problem [T ~> s] + character(len=240) :: mesg + logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. + logical :: coupled_GL ! If true the grounding line position is determined based on + ! coupled ice-ocean dynamics. + integer :: is, ie, js, je, i, j + + G => CS%grid + US => CS%US + ISS => CS%ISS + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + remaining_time = US%s_to_T*time_type_to_real(time_interval) + full_time_step = remaining_time + Ifull_time_step = 1./full_time_step + + if (present (min_time_step_in)) then + min_time_step = min_time_step_in + else + min_time_step = 1000.0*US%s_to_T ! At 1 km resolution this would imply ice is moving at ~1 meter per second + endif + + write (mesg,*) "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/(365. * 86400.) + call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) + + ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) + + do while (remaining_time > 0.0) + nsteps = nsteps+1 + + ! If time_interval is not too long, this is unnecessary. + time_step = min(ice_time_step_CFL(CS%dCS, ISS, G), remaining_time) + + write (mesg,*) "Ice model timestep = ", US%T_to_s*time_step, " seconds" + if ((time_step < min_time_step) .and. (time_step < remaining_time)) then + call MOM_error(FATAL, "MOM_ice_shelf:solo_step_ice_shelf: abnormally small timestep "//mesg) + else + call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) + endif + + call change_thickness_using_precip(CS, ISS, G, US, fluxes_in, time_step, Time) + + remaining_time = remaining_time - time_step + + ! If the last mini-timestep is a day or less, we cannot expect velocities to change by much. + ! Do not update the velocities if the last step is very short. + update_ice_vel = ((time_step > min_time_step) .or. (remaining_time > 0.0)) + coupled_GL = .false. + + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, must_update_vel=update_ice_vel) + + enddo + + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & + time_step=real_to_time(US%T_to_s*time_step) ) + do j=js,je ; do i=is,ie + ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j)) * Ifull_time_step + enddo; enddo + + call enable_averages(full_time_step, Time, CS%diag) + if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) + if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) + if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) + if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) + call disable_averaging(CS%diag) + +end subroutine solo_step_ice_shelf + +!> \namespace mom_ice_shelf +!! +!! \section section_ICE_SHELF +!! +!! This module implements the thermodynamic aspects of ocean/ice-shelf +!! inter-actions using the MOM framework and coding style. +!! +!! Derived from code by Chris Little, early 2010. +!! +!! The ice-sheet dynamics subroutines do the following: +!! initialize_shelf_mass - Initializes the ice shelf mass distribution. +!! - Initializes h_shelf, h_mask, area_shelf_h +!! - CURRENTLY: initializes mass_shelf as well, but this is unnecessary, as mass_shelf is initialized based on +!! h_shelf and density_ice immediately afterwards. Possibly subroutine should be renamed +!! update_shelf_mass - updates ice shelf mass via netCDF file +!! USER_update_shelf_mass (TODO). +!! solo_step_ice_shelf - called only in ice-only mode. +!! shelf_calc_flux - after melt rate & fluxes are calculated, ice dynamics are done. Currently mass_shelf is +!! updated immediately after ice_shelf_advect in fully dynamic mode. +!! +!! NOTES: be aware that hmask(:,:) has a number of functions; it is used for front advancement, +!! for subroutines in the velocity solve, and for thickness boundary conditions (this last one may be removed). +!! in other words, interfering with its updates will have implications you might not expect. +!! +!! Overall issues: Many variables need better documentation and units and the +!! subgrid on which they are discretized. +!! +!! \subsection section_ICE_SHELF_equations ICE_SHELF equations +!! +!! The three fundamental equations are: +!! Heat flux +!! \f[ \qquad \rho_w C_{pw} \gamma_T (T_w - T_b) = \rho_i \dot{m} L_f \f] +!! Salt flux +!! \f[ \qquad \rho_w \gamma_s (S_w - S_b) = \rho_i \dot{m} S_b \f] +!! Freezing temperature +!! \f[ \qquad T_b = a S_b + b + c P \f] +!! +!! where .... +!! +!! \subsection section_ICE_SHELF_references References +!! +!! Asay-Davis, Xylar S., Stephen L. Cornford, Benjamin K. Galton-Fenzi, Rupert M. Gladstone, G. Hilmar Gudmundsson, +!! David M. Holland, Paul R. Holland, and Daniel F. Martin. Experimental design for three interrelated marine ice sheet +!! and ocean model intercomparison projects: MISMIP v. 3 (MISMIP+), ISOMIP v. 2 (ISOMIP+) and MISOMIP v. 1 (MISOMIP1). +!! Geoscientific Model Development 9, no. 7 (2016): 2471. +!! +!! Goldberg, D. N., et al. Investigation of land ice-ocean interaction with a fully coupled ice-ocean model: 1. +!! Model description and behavior. Journal of Geophysical Research: Earth Surface 117.F2 (2012). +!! +!! Goldberg, D. N., et al. Investigation of land ice-ocean interaction with a fully coupled ice-ocean model: 2. +!! Sensitivity to external forcings. Journal of Geophysical Research: Earth Surface 117.F2 (2012). +!! +!! Holland, David M., and Adrian Jenkins. Modeling thermodynamic ice-ocean interactions at the base of an ice shelf. +!! Journal of Physical Oceanography 29.8 (1999): 1787-1800. + +end module MOM_ice_shelf diff --git a/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/ice_shelf/MOM_ice_shelf_diag_mediator.F90 new file mode 100644 index 0000000000..dabb075cf3 --- /dev/null +++ b/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -0,0 +1,761 @@ +!> Convenient wrappers to the FMS diag_manager interfaces with additional diagnostic capabilies. +module MOM_IS_diag_mediator + +! This file is a part of SIS2. See LICENSE.md for the license. + +use MOM_coms, only : PE_here +use MOM_diag_manager_infra, only : MOM_diag_manager_init, send_data_infra, MOM_diag_axis_init +use MOM_diag_manager_infra, only : EAST, NORTH +use MOM_diag_manager_infra, only : register_static_field_infra +use MOM_diag_manager_infra, only : register_diag_field_infra +use MOM_error_handler, only : MOM_error, FATAL, is_root_pe, assert +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc +use MOM_string_functions, only : lowercase, uppercase, slasher +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +public MOM_IS_diag_mediator_infrastructure_init +public set_IS_axes_info, post_IS_data, register_MOM_IS_diag_field, time_type +public register_MOM_IS_static_field +public safe_alloc_ptr, safe_alloc_alloc +public enable_averaging, disable_averaging, query_averaging_enabled +public enable_averages +public MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end, set_IS_diag_mediator_grid +public MOM_IS_diag_mediator_close_registration, get_diag_time_end +public MOM_diag_axis_init, register_static_field_infra + +!> 2D/3D axes type to contain 1D axes handles and pointers to masks +type, public :: axesType + character(len=15) :: id !< The id string for this particular combination of handles. + integer :: rank !< Number of dimensions in the list of axes. + integer, dimension(:), allocatable :: handles !< Handles to 1D axes. + type(diag_ctrl), pointer :: diag_cs => null() !< A structure that is used to regulate diagnostic output +end type axesType + +!> This type is used to represent a diagnostic at the diag_mediator level. +type, private :: diag_type + logical :: in_use !< This diagnostic is in use + integer :: fms_diag_id !< underlying FMS diag id + character(len=24) :: name !< The diagnostic name + real :: conversion_factor = 0. !< A factor to multiply data by before posting to FMS, if non-zero. + real, pointer, dimension(:,:) :: mask2d => null() !< A 2-d mask on the data domain for this diagnostic [nondim] + real, pointer, dimension(:,:) :: mask2d_comp => null() !< A 2-d mask on the computational domain + !! for this diagnostic [nondim] +end type diag_type + +!> The SIS_diag_ctrl data type contains times to regulate diagnostics along with masks and +!! axes to use with diagnostics, and a list of structures with data about each diagnostic. +type, public :: diag_ctrl + integer :: doc_unit = -1 !< The unit number of a diagnostic documentation file. + !! This file is open if doc_unit is > 0. + + ! The following fields are used for the output of the data. + ! These give the computational-domain sizes, and are relative to a start value + ! of 1 in memory for the tracer-point arrays. + integer :: is !< The start i-index of cell centers within the computational domain + integer :: ie !< The end i-index of cell centers within the computational domain + integer :: js !< The start j-index of cell centers within the computational domain + integer :: je !< The end j-index of cell centers within the computational domain + ! These give the memory-domain sizes, and can be start at any value on each PE. + integer :: isd !< The start i-index of cell centers within the data domain + integer :: ied !< The end i-index of cell centers within the data domain + integer :: jsd !< The start j-index of cell centers within the data domain + integer :: jed !< The end j-index of cell centers within the data domain + real :: time_int !< The time interval for any fields that are offered for averaging [s]. + type(time_type) :: time_end !< The end time of the valid interval for any offered field. + logical :: ave_enabled = .false. !< .true. if averaging is enabled. + + !>@{ The following are 3D and 2D axis groups defined for output. The names indicate + !! the horizontal locations (B, T, Cu, or Cv), vertical locations (L, i, or 1) and + !! thickness categories (c, c0, or 1). + type(axesType) :: axesBL, axesTL, axesCuL, axesCvL + type(axesType) :: axesBi, axesTi, axesCui, axesCvi + type(axesType) :: axesBc, axesTc, axesCuc, axesCvc + type(axesType) :: axesBc0, axesTc0, axesCuc0, axesCvc0 + type(axesType) :: axesB1, axesT1, axesCu1, axesCv1 + !!@} + + ! Mask arrays for diagnostics + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points + real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corners + real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-faces + real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-faces + !> Computational domain mask arrays for diagnostics. + real, dimension(:,:), pointer :: mask2dT_comp => null() + +#define DIAG_ALLOC_CHUNK_SIZE 15 + type(diag_type), dimension(:), allocatable :: diags !< The array of diagnostics + integer :: next_free_diag_id !< The next unused diagnostic ID + !> default missing value to be sent to ALL diagnostics registerations [various] + real :: missing_value = -1.0e34 + + type(unit_scale_type), pointer :: US => null() !< A dimensional unit scaling type + +end type diag_ctrl + +contains + +!> Set up the grid and axis information for use by the ice shelf model. +subroutine set_IS_axes_info(G, param_file, diag_cs, axes_set_name) + type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + character(len=*), optional, intent(in) :: axes_set_name !< A name to use for this set of axes. + !! The default is "ice". +! This subroutine sets up the grid and axis information for use by the ice shelf model. + + ! Local variables + integer :: id_xq, id_yq, id_xh, id_yh + logical :: Cartesian_grid + character(len=80) :: grid_config, units_temp, set_name + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_IS_diag_mediator" ! This module's name. + + set_name = "ice_shelf" ; if (present(axes_set_name)) set_name = trim(axes_set_name) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version) + call get_param(param_file, mdl, "GRID_CONFIG", grid_config, & + "The method for defining the horizontal grid. Valid "//& + "entries include:\n"//& + "\t file - read the grid from GRID_FILE \n"//& + "\t mosaic - read the grid from a mosaic grid file \n"//& + "\t cartesian - a Cartesian grid \n"//& + "\t spherical - a spherical grid \n"//& + "\t mercator - a Mercator grid", fail_if_missing=.true.) + + G%x_axis_units = "degrees_E" ; G%y_axis_units = "degrees_N" + G%x_ax_unit_short = "degrees_E" ; G%y_ax_unit_short = "degrees_N" + + if (index(lowercase(trim(grid_config)),"cartesian") > 0) then + ! This is a cartesian grid, and may have different axis units. + Cartesian_grid = .true. + call get_param(param_file, mdl, "AXIS_UNITS", units_temp, & + "The units for the x- and y- axis labels. AXIS_UNITS "//& + "should be defined as 'k' for km, 'm' for m, or 'd' "//& + "for degrees of latitude and longitude (the default). "//& + "Except on a Cartesian grid, only degrees are currently "//& + "implemented.", default='degrees') + if (units_temp(1:1) == 'k') then + G%x_axis_units = "kilometers" ; G%y_axis_units = "kilometers" + G%x_ax_unit_short = "km" ; G%y_ax_unit_short = "km" + elseif (units_temp(1:1) == 'm') then + G%x_axis_units = "meters" ; G%y_axis_units = "meters" + G%x_ax_unit_short = "m" ; G%y_ax_unit_short = "m" + endif + call log_param(param_file, mdl, "explicit AXIS_UNITS", G%x_axis_units) + else + Cartesian_grid = .false. + endif + + if (G%symmetric) then + id_xq = MOM_diag_axis_init('xB', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & + 'Boundary point nominal longitude', G%Domain, position=EAST, set_name=set_name) + id_yq = MOM_diag_axis_init('yB', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & + 'Boundary point nominal latitude', G%Domain, position=NORTH, set_name=set_name) + + else + id_xq = MOM_diag_axis_init('xB', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & + 'Boundary point nominal longitude', G%Domain, position=EAST, set_name=set_name) + id_yq = MOM_diag_axis_init('yB', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'Boundary point nominal latitude', G%Domain, position=NORTH, set_name=set_name) + + endif + id_xh = MOM_diag_axis_init('xT', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & + 'T point nominal longitude', G%Domain, set_name=set_name) + id_yh = MOM_diag_axis_init('yT', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'T point nominal latitude', G%Domain, set_name=set_name) + + ! Axis groupings for 2-D arrays. + call defineAxes(diag_cs, [id_xh, id_yh], diag_cs%axesT1) + call defineAxes(diag_cs, [id_xq, id_yq], diag_cs%axesB1) + call defineAxes(diag_cs, [id_xq, id_yh], diag_cs%axesCu1) + call defineAxes(diag_cs, [id_xh, id_yq], diag_cs%axesCv1) + +end subroutine set_IS_axes_info + +!> Define an a group of axes from a list of handles +subroutine defineAxes(diag_cs, handles, axes) + ! Defines "axes" from list of handle and associates mask + type(diag_ctrl), target, intent(in) :: diag_cs !< A structure that is used to regulate diagnostic output + integer, dimension(:), intent(in) :: handles !< A set of axis handles that define the axis group + type(axesType), intent(out) :: axes !< A group of axes that is set up here + + ! Local variables + integer :: n + n = size(handles) + if (n<1 .or. n>3) call MOM_error(FATAL,"defineAxes: wrong size for list of handles!") + allocate( axes%handles(n) ) + axes%id = i2s(handles, n) ! Identifying string + axes%rank = n + axes%handles(:) = handles(:) + axes%diag_cs => diag_cs ! A (circular) link back to the MOM_IS_diag_ctrl structure +end subroutine defineAxes + +!> Set up the current grid for the diag mediator +subroutine set_IS_diag_mediator_grid(G, diag_cs) + type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type + type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + + diag_cs%is = G%isc - (G%isd-1) ; diag_cs%ie = G%iec - (G%isd-1) + diag_cs%js = G%jsc - (G%jsd-1) ; diag_cs%je = G%jec - (G%jsd-1) + diag_cs%isd = G%isd ; diag_cs%ied = G%ied ; diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed +end subroutine set_IS_diag_mediator_grid + +!> Offer a 2d diagnostic field for output or averaging +subroutine post_IS_data(diag_field_id, field, diag_cs, is_static, mask) + integer, intent(in) :: diag_field_id !< the id for an output variable returned by a + !! previous call to register_diag_field. + real, target, intent(in) :: field(:,:) !< The 2-d array being offered for output or averaging. + type(diag_ctrl), target, & + intent(in) :: diag_cs !< A structure that is used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + logical, optional, intent(in) :: mask(:,:) !< If present, use this logical array as the data mask. + + ! Local variables + real, dimension(:,:), pointer :: locfield + logical :: used, is_stat + logical :: i_data, j_data + integer :: isv, iev, jsv, jev, i, j + integer :: fms_diag_id + type(diag_type), pointer :: diag => NULL() + + locfield => NULL() + is_stat = .false. ; if (present(is_static)) is_stat = is_static + + ! Get a pointer to the diag type for this id, and the FMS-level diag id. + call assert(diag_field_id < diag_cs%next_free_diag_id, & + 'post_IS_data: Unregistered diagnostic id') + diag => diag_cs%diags(diag_field_id) + fms_diag_id = diag%fms_diag_id + + ! Determine the proper array indices, noting that because of the (:,:) + ! declaration of field, symmetric arrays are using a SW-grid indexing, + ! but non-symmetric arrays are using a NE-grid indexing. Send_data + ! actually only uses the difference between ie and is to determine + ! the output data size and assumes that halos are symmetric. + isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je + + if ( size(field,1) == diag_cs%ied-diag_cs%isd +1 ) then + isv = diag_cs%is ; iev = diag_cs%ie ; i_data = .true. ! Data domain + elseif ( size(field,1) == diag_cs%ied-diag_cs%isd +2 ) then + isv = diag_cs%is ; iev = diag_cs%ie+1 ; i_data = .true. ! Symmetric data domain + elseif ( size(field,1) == diag_cs%ie-diag_cs%is +1 ) then + isv = 1 ; iev = diag_cs%ie + 1-diag_cs%is ; i_data = .false. ! Computational domain + elseif ( size(field,1) == diag_cs%ie-diag_cs%is +2 ) then + isv = 1 ; iev = diag_cs%ie + 2-diag_cs%is ; i_data = .false. ! Symmetric computational domain + else + call MOM_error(FATAL,"post_MOM_IS_data_2d: peculiar size in i-direction of "//trim(diag%name)) + endif + if ( size(field,2) == diag_cs%jed-diag_cs%jsd +1 ) then + jsv = diag_cs%js ; jev = diag_cs%je ; j_data = .true. ! Data domain + elseif ( size(field,2) == diag_cs%jed-diag_cs%jsd +2 ) then + jsv = diag_cs%js ; jev = diag_cs%je+1 ; j_data = .true. ! Symmetric data domain + elseif ( size(field,2) == diag_cs%je-diag_cs%js +1 ) then + jsv = 1 ; jev = diag_cs%je + 1-diag_cs%js ; j_data = .false. ! Computational domain + elseif ( size(field,1) == diag_cs%je-diag_cs%js +2 ) then + jsv = 1 ; jev = diag_cs%je + 2-diag_cs%js ; j_data = .false. ! Symmetric computational domain + else + call MOM_error(FATAL,"post_MOM_IS_data_2d: peculiar size in j-direction "//trim(diag%name)) + endif + + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then + allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2) ) ) + do j=jsv,jev ; do i=isv,iev + if (field(i,j) == diag_cs%missing_value) then + locfield(i,j) = diag_cs%missing_value + else + locfield(i,j) = field(i,j) * diag%conversion_factor + endif + enddo ; enddo + locfield(isv:iev,jsv:jev) = field(isv:iev,jsv:jev) * diag%conversion_factor + else + locfield => field + endif + + ! Handle cases where the data and computational domain are the same size. + if (diag_cs%ied-diag_cs%isd == diag_cs%ie-diag_cs%is) i_data = j_data + if (diag_cs%jed-diag_cs%jsd == diag_cs%je-diag_cs%js) j_data = i_data + + if (present(mask)) then + if ((size(field,1) /= size(mask,1)) .or. & + (size(field,2) /= size(mask,2))) then + call MOM_error(FATAL, "post_MOM_IS_data_2d: post_MOM_IS_data called with a mask "//& + "that does not match the size of field "//trim(diag%name)) + endif + elseif ( i_data .NEQV. j_data ) then + call MOM_error(FATAL, "post_MOM_IS_data_2d: post_MOM_IS_data called for "//& + trim(diag%name)//" with mixed computational and data domain array sizes.") + endif + + if (is_stat) then + if (present(mask)) then + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, mask=mask) + elseif(i_data .and. associated(diag%mask2d)) then +! used = send_data(fms_diag_id, locfield, & +! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%mask2d) + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) + elseif((.not.i_data) .and. associated(diag%mask2d_comp)) then +! used = send_data(fms_diag_id, locfield, & +! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%mask2d_comp) + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) + else + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) + endif + elseif (diag_cs%ave_enabled) then + if (present(mask)) then + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int, mask=mask) +! used = send_data(fms_diag_id, locfield, & +! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & +! time=diag_cs%time_end, weight=diag_cs%time_int) + elseif(i_data .and. associated(diag%mask2d)) then +! used = send_data(fms_diag_id, locfield, & +! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & +! time=diag_cs%time_end, weight=diag_cs%time_int, rmask=diag%mask2d) + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int) + elseif((.not.i_data) .and. associated(diag%mask2d_comp)) then +! used = send_data(fms_diag_id, locfield, & +! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & +! time=diag_cs%time_end, weight=diag_cs%time_int, rmask=diag%mask2d_comp) + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int) + else + used = send_data_infra(fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int) + endif + endif + + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) ) deallocate( locfield ) + +end subroutine post_IS_data + + +!> Enable the accumulation of time averages over the specified time interval. +subroutine enable_averaging(time_int_in, time_end_in, diag_cs) + real, intent(in) :: time_int_in !< The time interval over which any values + !! that are offered are valid [s]. + type(time_type), intent(in) :: time_end_in !< The end time of the valid interval. + type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + ! This subroutine enables the accumulation of time averages over the specified time interval. + +! if (num_file==0) return + diag_cs%time_int = time_int_in + diag_cs%time_end = time_end_in + diag_cs%ave_enabled = .true. +end subroutine enable_averaging + +! Put a block on averaging any offered fields. +subroutine disable_averaging(diag_cs) + type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + + diag_cs%time_int = 0.0 + diag_cs%ave_enabled = .false. + +end subroutine disable_averaging + +!> Enable the accumulation of time averages over the specified time interval in time units. +subroutine enable_averages(time_int, time_end, diag_CS, T_to_s) + real, intent(in) :: time_int !< The time interval over which any values + !! that are offered are valid [T ~> s]. + type(time_type), intent(in) :: time_end !< The end time of the valid interval. + type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output + real, optional, intent(in) :: T_to_s !< A conversion factor for time_int to seconds [s T-1 ~> 1]. + ! This subroutine enables the accumulation of time averages over the specified time interval. + + if (present(T_to_s)) then + diag_cs%time_int = time_int*T_to_s + elseif (associated(diag_CS%US)) then + diag_cs%time_int = time_int*diag_CS%US%T_to_s + else + diag_cs%time_int = time_int + endif + diag_cs%time_end = time_end + diag_cs%ave_enabled = .true. +end subroutine enable_averages + +!> Indicate whether averaging diagnostics is currently enabled +logical function query_averaging_enabled(diag_cs, time_int, time_end) + type(diag_ctrl), intent(in) :: diag_cs !< A structure that is used to regulate diagnostic output + real, optional, intent(out) :: time_int !< The current setting of diag_cs%time_int [s]. + type(time_type), optional, intent(out) :: time_end !< The current setting of diag_cs%time_end. + + if (present(time_int)) time_int = diag_cs%time_int + if (present(time_end)) time_end = diag_cs%time_end + query_averaging_enabled = diag_cs%ave_enabled +end function query_averaging_enabled + +!> This subroutine initializes the diag_manager via the MOM6 infrastructure +subroutine MOM_IS_diag_mediator_infrastructure_init(err_msg) + character(len=*), optional, intent(out) :: err_msg !< An error message + + call MOM_diag_manager_init(err_msg=err_msg) +end subroutine MOM_IS_diag_mediator_infrastructure_init + +!> Return the currently specified valid end time for diagnostics +function get_diag_time_end(diag_cs) + type(diag_ctrl), intent(in) :: diag_cs !< A structure that is used to regulate diagnostic output + type(time_type) :: get_diag_time_end + +! This function returns the valid end time for diagnostics that are handled +! outside of the MOM6 infrastructure, such as via the generic tracer code. + + get_diag_time_end = diag_cs%time_end +end function get_diag_time_end + +!> Returns the "MOM_IS_diag_mediator" handle for a group of diagnostics derived from one field. +function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count, conversion) result (register_diag_field) + integer :: register_diag_field !< The returned diagnostic handle + character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axesType), intent(in) :: axes !< The axis group for this field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_IS_data calls (not used in MOM?) + logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM_IS?) + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + + ! Local variables + character(len=240) :: mesg + real :: MOM_missing_value + integer :: primary_id, fms_id + type(diag_ctrl), pointer :: diag_cs => NULL() ! A structure that is used + ! to regulate diagnostic output + type(diag_type), pointer :: diag => NULL() + + MOM_missing_value = axes%diag_cs%missing_value + if (present(missing_value)) MOM_missing_value = missing_value + + diag_cs => axes%diag_cs + primary_id = -1 + + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count) + if (fms_id > 0) then + primary_id = get_new_diag_id(diag_cs) + diag => diag_cs%diags(primary_id) + diag%fms_diag_id = fms_id + if (len(field_name) > len(diag%name)) then + diag%name = field_name(1:len(diag%name)) + else ; diag%name = field_name ; endif + + if (present(conversion)) diag%conversion_factor = conversion + endif + + if (is_root_pe() .and. diag_CS%doc_unit > 0) then + if (primary_id > 0) then + mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Used]' + else + mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Unused]' + endif + write(diag_CS%doc_unit, '(a)') trim(mesg) + if (present(long_name)) call describe_option("long_name", long_name, diag_CS) + if (present(units)) call describe_option("units", units, diag_CS) + if (present(standard_name)) & + call describe_option("standard_name", standard_name, diag_CS) + endif + + !Decide what mask to use based on the axes info + if (primary_id > 0) then + !2d masks + if (axes%rank == 2) then + diag%mask2d => null() ; diag%mask2d_comp => null() + if (axes%id == diag_cs%axesT1%id) then + diag%mask2d => diag_cs%mask2dT + diag%mask2d_comp => diag_cs%mask2dT_comp + elseif (axes%id == diag_cs%axesB1%id) then + diag%mask2d => diag_cs%mask2dBu + elseif (axes%id == diag_cs%axesCu1%id) then + diag%mask2d => diag_cs%mask2dCu + elseif (axes%id == diag_cs%axesCv1%id) then + diag%mask2d => diag_cs%mask2dCv + ! else + ! call SIS_error(FATAL, "SIS_diag_mediator:register_diag_field: " // & + ! "unknown axes for diagnostic variable "//trim(field_name)) + endif + else + call MOM_error(FATAL, "MOM_IS_diag_mediator:register_diag_field: " // & + "unknown axes for diagnostic variable "//trim(field_name)) + endif + endif ! if (primary_id>-1) + + register_diag_field = primary_id + +end function register_MOM_IS_diag_field + +!> Registers a static diagnostic, returning an integer handle +integer function register_MOM_IS_static_field(module_name, field_name, axes, & + long_name, units, missing_value, range, mask_variant, standard_name, & + do_not_log, interp_method, tile_count) + integer :: register_static_field !< The returned diagnostic handle + character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axesType), intent(in) :: axes !< The axis group for this field + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_IS_data calls (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM_IS?) + + ! Local variables + real :: MOM_missing_value + integer :: primary_id, fms_id + type(diag_ctrl), pointer :: diag_cs !< A structure that is used to regulate diagnostic output + + MOM_missing_value = axes%diag_cs%missing_value + if (present(missing_value)) MOM_missing_value = missing_value + + diag_cs => axes%diag_cs + primary_id = -1 + + fms_id = register_static_field_infra(module_name, field_name, axes%handles, & + long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + do_not_log=do_not_log, & + interp_method=interp_method, tile_count=tile_count) + if (fms_id > 0) then + primary_id = get_new_diag_id(diag_cs) + diag_cs%diags(primary_id)%fms_diag_id = fms_id + endif + + register_static_field = primary_id + +end function register_MOM_IS_static_field + +!> Add a description of an option to the documentation file +subroutine describe_option(opt_name, value, diag_CS) + character(len=*), intent(in) :: opt_name !< The name of the option + character(len=*), intent(in) :: value !< The value of the option + type(diag_ctrl), intent(in) :: diag_CS !< Diagnostic being documented + + ! Local variables + character(len=240) :: mesg + integer :: len_ind + + len_ind = len_trim(value) + + mesg = " ! "//trim(opt_name)//": "//trim(value) + write(diag_CS%doc_unit, '(a)') trim(mesg) +end subroutine describe_option + +!> Convert the first n elements (up to 3) of an integer array to an underscore delimited string. +function i2s(a, n_in) + integer, dimension(:), intent(in) :: a !< The array of integers to translate + integer, optional , intent(in) :: n_in !< The number of elements to translate, by default all + character(len=15) :: i2s !< The returned string + + ! Local variables + character(len=15) :: i2s_temp + integer :: i,n + + n = size(a) + if (present(n_in)) n = n_in + + i2s = '' + do i=1,n + write (i2s_temp, '(I4.4)') a(i) + i2s = trim(i2s) //'_'// trim(i2s_temp) + enddo + i2s = adjustl(i2s) +end function i2s + +!> Initialize the MOM_IS diag_mediator and opens the available diagnostics file. +subroutine MOM_IS_diag_mediator_init(G, US, param_file, diag_cs, component, err_msg, & + doc_file_dir) + type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type + type(unit_scale_type), target, intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + character(len=*), optional, intent(in) :: component !< An opitonal component name + character(len=*), optional, intent(out) :: err_msg !< A string for a returned error message + character(len=*), optional, intent(in) :: doc_file_dir !< A directory in which to create the file + + ! This subroutine initializes the diag_mediator and the diag_manager. + ! The grid type should have its dimensions set by this point, but it + ! is not necessary that the metrics and axis labels be set up yet. + + ! Local variables + integer :: ios, new_unit + logical :: opened, new_file + character(len=8) :: this_pe + character(len=240) :: doc_file, doc_file_dflt, doc_path + character(len=40) :: doc_file_param + character(len=40) :: mdl = "MOM_IS_diag_mediator" ! This module's name. + + call MOM_diag_manager_init(err_msg=err_msg) + + ! Allocate list of all diagnostics + allocate(diag_cs%diags(DIAG_ALLOC_CHUNK_SIZE)) + diag_cs%next_free_diag_id = 1 + diag_cs%diags(:)%in_use = .false. + + diag_cs%US => US + diag_cs%is = G%isc - (G%isd-1) ; diag_cs%ie = G%iec - (G%isd-1) + diag_cs%js = G%jsc - (G%jsd-1) ; diag_cs%je = G%jec - (G%jsd-1) + diag_cs%isd = G%isd ; diag_cs%ied = G%ied ; diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed + + if (is_root_pe() .and. (diag_CS%doc_unit < 0)) then + if (present(component)) then + doc_file_dflt = trim(component)//".available_diags" + doc_file_param = trim(uppercase(component))//"_AVAILABLE_DIAGS_FILE" + else + write(this_pe,'(i6.6)') PE_here() + doc_file_dflt = "MOM_IS.available_diags."//this_pe + doc_file_param = "AVAILABLE_MOM_IS_DIAGS_FILE" + endif + call get_param(param_file, mdl, trim(doc_file_param), doc_file, & + "A file into which to write a list of all available "//& + "ice shelf diagnostics that can be included in a diag_table.", & + default=doc_file_dflt) + if (len_trim(doc_file) > 0) then + new_file = .true. ; if (diag_CS%doc_unit /= -1) new_file = .false. + ! Find an unused unit number. + do new_unit=512,42,-1 + inquire( new_unit, opened=opened) + if (.not.opened) exit + enddo + + if (opened) call MOM_error(FATAL, & + "diag_mediator_init failed to find an unused unit number.") + + doc_path = doc_file + if (present(doc_file_dir)) then ; if (len_trim(doc_file_dir) > 0) then + doc_path = trim(slasher(doc_file_dir))//trim(doc_file) + endif ; endif + + diag_CS%doc_unit = new_unit + + if (new_file) then + open(diag_CS%doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='REPLACE', iostat=ios) + else ! This file is being reopened, and should be appended. + open(diag_CS%doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='OLD', position='APPEND', iostat=ios) + endif + inquire(diag_CS%doc_unit, opened=opened) + if ((.not.opened) .or. (ios /= 0)) then + call MOM_error(FATAL, "Failed to open available diags file "//trim(doc_path)//".") + endif + endif + endif + + call diag_masks_set(G, -1.0e34, diag_cs) + +end subroutine MOM_IS_diag_mediator_init + +subroutine diag_masks_set(G, missing_value, diag_cs) +! Setup the 2d masks for diagnostics + type(ocean_grid_type), target, intent(in) :: G !< The horizontal grid type + real, intent(in) :: missing_value !< A fill value for missing points + type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + + ! Local variables + integer :: i, j + + + diag_cs%mask2dT => G%mask2dT + diag_cs%mask2dBu => G%mask2dBu + diag_cs%mask2dCu => G%mask2dCu + diag_cs%mask2dCv => G%mask2dCv + + allocate(diag_cs%mask2dT_comp(G%isc:G%iec,G%jsc:G%jec)) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + diag_cs%mask2dT_comp(i,j) = diag_cs%mask2dT(i,j) + enddo ; enddo + + + diag_cs%missing_value = missing_value + +end subroutine diag_masks_set + +!> Prevent the registration of additional diagnostics, so that the creation of files can occur +subroutine MOM_IS_diag_mediator_close_registration(diag_CS) + type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output + + if (diag_CS%doc_unit > -1) then + close(diag_CS%doc_unit) ; diag_CS%doc_unit = -2 + endif + +end subroutine MOM_IS_diag_mediator_close_registration + +!> Deallocate memory associated with the MOM_IS diag mediator +subroutine MOM_IS_diag_mediator_end(diag_CS) + type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output + + if (diag_CS%doc_unit > -1) then + close(diag_CS%doc_unit) ; diag_CS%doc_unit = -3 + endif + +end subroutine MOM_IS_diag_mediator_end + +!> Allocate a new diagnostic id, noting that it may be necessary to expand the diagnostics array. +function get_new_diag_id(diag_cs) + + integer :: get_new_diag_id !< The returned ID for the new diagnostic + type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + + ! Local variables + type(diag_type), dimension(:), allocatable :: tmp + integer :: i + + if (diag_cs%next_free_diag_id > size(diag_cs%diags)) then + call assert(diag_cs%next_free_diag_id - size(diag_cs%diags) == 1, & + 'get_new_diag_id: inconsistent diag id') + + ! Increase the size of diag_cs%diags and copy data over. + ! Do not use move_alloc() because it is not supported by Fortran 90 + allocate(tmp(size(diag_cs%diags))) + tmp(:) = diag_cs%diags(:) + deallocate(diag_cs%diags) + allocate(diag_cs%diags(size(tmp) + DIAG_ALLOC_CHUNK_SIZE)) + diag_cs%diags(1:size(tmp)) = tmp(:) + deallocate(tmp) + + ! Initialise new part of the diag array. + do i=diag_cs%next_free_diag_id, size(diag_cs%diags) + diag_cs%diags(i)%in_use = .false. + enddo + endif + + get_new_diag_id = diag_cs%next_free_diag_id + diag_cs%next_free_diag_id = diag_cs%next_free_diag_id + 1 + +end function get_new_diag_id + +end module MOM_IS_diag_mediator diff --git a/ice_shelf/MOM_ice_shelf_dynamics.F90 b/ice_shelf/MOM_ice_shelf_dynamics.F90 new file mode 100644 index 0000000000..ec49081baf --- /dev/null +++ b/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -0,0 +1,4099 @@ +!> Implements a crude placeholder for a later implementation of full +!! ice shelf dynamics. +module MOM_ice_shelf_dynamics + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE +use MOM_IS_diag_mediator, only : post_data=>post_IS_data +use MOM_IS_diag_mediator, only : register_diag_field=>register_MOM_IS_diag_field, safe_alloc_ptr +!use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_init, set_IS_diag_mediator_grid +use MOM_IS_diag_mediator, only : diag_ctrl, time_type, enable_averages, disable_averaging +use MOM_domains, only : MOM_domains_init, clone_MOM_domain +use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER, CENTER +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_grid, only : MOM_grid_init, ocean_grid_type +use MOM_io, only : file_exists, slasher, MOM_read_data +use MOM_io, only : open_ASCII_file, get_filename_appendix +use MOM_io, only : APPEND_FILE, WRITEONLY_FILE +use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_time_manager, only : time_type, get_time, set_time, time_type_to_real, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) +use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init +!MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary +use MOM_ice_shelf_state, only : ice_shelf_state +use MOM_coms, only : reproducing_sum, max_across_PEs, min_across_PEs +use MOM_checksums, only : hchksum, qchksum +use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_channel,initialize_ice_flow_from_file +use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_from_file,initialize_ice_C_basal_friction +use MOM_ice_shelf_initialize, only : initialize_ice_AGlen +implicit none ; private + +#include + +public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf +public ice_time_step_CFL, ice_shelf_dyn_end, change_in_draft, write_ice_shelf_energy +public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> The control structure for the ice shelf dynamics. +type, public :: ice_shelf_dyn_CS ; private + real, pointer, dimension(:,:) :: u_shelf => NULL() !< the zonal velocity of the ice shelf/sheet + !! on q-points (B grid) [L T-1 ~> m s-1] + real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet + !! on q-points (B grid) [L T-1 ~> m s-1] + real, pointer, dimension(:,:) :: taudx_shelf => NULL() !< the driving stress of the ice shelf/sheet + !! on q-points (C grid) [R L2 T-2 ~> Pa] + real, pointer, dimension(:,:) :: taudy_shelf => NULL() !< the meridional stress of the ice shelf/sheet + !! on q-points (C grid) [R L2 T-2 ~> Pa] + real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid + !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, + !! not vertices. Will represent boundary conditions on computational boundary + !! (or permanent boundary between fast-moving and near-stagnant ice + !! FOR NOW: 1=interior bdry, 0=no-flow boundary, 2=stress bdry condition, + !! 3=inhomogeneous Dirichlet boundary for u and v, 4=flux boundary: at these + !! faces a flux will be specified which will override velocities; a homogeneous + !! velocity condition will be specified (this seems to give the solver less + !! difficulty) 5=inhomogenous Dirichlet boundary for u only. 6=inhomogenous + !! Dirichlet boundary for v only + real, pointer, dimension(:,:) :: v_face_mask => NULL() !< A mask for velocity boundary conditions on the C-grid + !! v-face, with valued defined similarly to u_face_mask, but 5 is Dirichlet for v + !! and 6 is Dirichlet for u + real, pointer, dimension(:,:) :: u_face_mask_bdry => NULL() !< A duplicate copy of u_face_mask? + real, pointer, dimension(:,:) :: v_face_mask_bdry => NULL() !< A duplicate copy of v_face_mask? + real, pointer, dimension(:,:) :: u_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell + !! through open boundary u-faces (where u_face_mask=4) [Z L T-1 ~> m2 s-1] + real, pointer, dimension(:,:) :: v_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell + !! through open boundary v-faces (where v_face_mask=4) [Z L T-1 ~> m2 s-1]?? + ! needed where u_face_mask is equal to 4, similarly for v_face_mask + real, pointer, dimension(:,:) :: umask => NULL() !< u-mask on the actual degrees of freedom (B grid) + !! 1=normal node, 3=inhomogeneous boundary node, + !! 0 - no flow node (will also get ice-free nodes) + real, pointer, dimension(:,:) :: vmask => NULL() !< v-mask on the actual degrees of freedom (B grid) + !! 1=normal node, 3=inhomogeneous boundary node, + !! 0 - no flow node (will also get ice-free nodes) + real, pointer, dimension(:,:) :: calve_mask => NULL() !< a mask to prevent the ice shelf front from + !! advancing past its initial position (but it may retreat) + real, pointer, dimension(:,:) :: t_shelf => NULL() !< Vertically integrated temperature in the ice shelf/stream, + !! on corner-points (B grid) [C ~> degC] + real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. + real, pointer, dimension(:,:,:) :: ice_visc => NULL() !< Glen's law ice viscosity (Pa s), + !! in [R L2 T-1 ~> kg m-1 s-1]. + !! at either 1 (cell-centered) or 4 quadrature points per cell + real, pointer, dimension(:,:) :: AGlen_visc => NULL() !< Ice-stiffness parameter in Glen's law ice viscosity, + !! often in [Pa-3 s-1] if n_Glen is 3. + real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries + !! [L yr-1 ~> m yr-1] + real, pointer, dimension(:,:) :: v_bdry_val => NULL() !< The meridional ice velocity at inflowing boundaries + !! [L yr-1 ~> m yr-1] + real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [Z ~> m]. + real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [C ~> degC]. + + real, pointer, dimension(:,:) :: bed_elev => NULL() !< The bed elevation used for ice dynamics [Z ~> m], + !! relative to mean sea-level. This is + !! the same as G%bathyT+Z_ref, when below sea-level. + !! Sign convention: positive below sea-level, negative above. + + real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area-integrated taub_beta field + !! (m2 Pa s m-1, or kg s-1) related to the nonlinear part + !! of "linearized" basal stress (Pa) [R L3 T-1 ~> kg s-1] + !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 + real, pointer, dimension(:,:) :: C_basal_friction => NULL()!< Coefficient in sliding law tau_b = C u^(n_basal_fric), + !! units= Pa (m s-1)^(n_basal_fric) + real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av [Z ~> m]. + real, pointer, dimension(:,:) :: ground_frac_rt => NULL() !< A running total for calculating ground_frac. + real, pointer, dimension(:,:) :: OD_av => NULL() !< The time average open ocean depth [Z ~> m]. + real, pointer, dimension(:,:) :: ground_frac => NULL() !< Fraction of the time a cell is "exposed", i.e. the column + !! thickness is below a threshold and interacting with the rock [nondim]. When this + !! is 1, the ice-shelf is grounded + real, pointer, dimension(:,:) :: float_cond => NULL() !< If GL_regularize=true, indicates cells containing + !! the grounding line (float_cond=1) or not (float_cond=0) + real, pointer, dimension(:,:,:,:) :: Phi => NULL() !< The gradients of bilinear basis elements at Gaussian + !! 4 quadrature points surrounding the cell vertices [L-1 ~> m-1]. + real, pointer, dimension(:,:,:) :: PhiC => NULL() !< The gradients of bilinear basis elements at 1 cell-centered + !! quadrature point per cell [L-1 ~> m-1]. + real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() !< Quadrature structure weights at subgridscale + !! locations for finite element calculations [nondim] + integer :: OD_rt_counter = 0 !< A counter of the number of contributions to OD_rt. + + real :: velocity_update_time_step !< The time interval over which to update the ice shelf velocity + !! using the nonlinear elliptic equation, or 0 to update every timestep [T ~> s]. + ! DNGoldberg thinks this should be done no more often than about once a day + ! (maybe longer) because it will depend on ocean values that are averaged over + ! this time interval, and solving for the equilibrated flow will begin to lose + ! meaning if it is done too frequently. + real :: elapsed_velocity_time !< The elapsed time since the ice velocities were last updated [T ~> s]. + + real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. + real :: density_ice !< A typical density of ice [R ~> kg m-3]. + + logical :: advect_shelf !< If true (default), advect ice shelf and evolve thickness + logical :: alternate_first_direction_IS !< If true, alternate whether the x- or y-direction + !! updates occur first in directionally split parts of the calculation. + integer :: first_direction_IS !< An integer that indicates which direction is + !! to be updated first in directionally split + !! parts of the ice sheet calculation (e.g. advection). + real :: first_dir_restart_IS = -1.0 !< A real copy of CS%first_direction_IS for use in restart files + integer :: visc_qps !< The number of quadrature points per cell (1 or 4) on which to calculate ice viscosity. + character(len=40) :: ice_viscosity_compute !< Specifies whether the ice viscosity is computed internally + !! according to Glen's flow law; is constant (for debugging purposes) + !! or using observed strain rates and read from a file + logical :: GL_regularize !< Specifies whether to regularize the floatation condition + !! at the grounding line as in Goldberg Holland Schoof 2009 + integer :: n_sub_regularize + !< partition of cell over which to integrate for + !! interpolated grounding line the (rectangular) is + !! divided into nxn equally-sized rectangles, over which + !! basal contribution is integrated (iterative quadrature) + logical :: GL_couple !< whether to let the floatation condition be + !! determined by ocean column thickness means update_OD_ffrac + !! will be called (note: GL_regularize and GL_couple + !! should be exclusive) + + real :: CFL_factor !< A factor used to limit subcycled advective timestep in uncoupled runs + !! i.e. dt <= CFL_factor * min(dx / u) [nondim] + + real :: n_glen !< Nonlinearity exponent in Glen's Law [nondim] + real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [T-1 ~> s-1]. + real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) [nondim] + logical :: CoulombFriction !< Use Coulomb friction law (Schoof 2005, Gagliardini et al 2007) + real :: CF_MinN !< Minimum Coulomb friction effective pressure [Pa] + real :: CF_PostPeak !< Coulomb friction post peak exponent [nondim] + real :: CF_Max !< Coulomb friction maximum coefficient [nondim] + real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean + !! circulation or thermodynamics. It is used to estimate the + !! gravitational driving force at the shelf front (until we think of + !! a better way to do it, but any difference will be negligible). + real :: thresh_float_col_depth !< The water column depth over which the shelf if considered to be floating + logical :: moving_shelf_front !< Specify whether to advance shelf front (and calve). + logical :: calve_to_mask !< If true, calve off the ice shelf when it passes the edge of a mask. + real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. + real :: T_shelf_missing !< An ice shelf temperature to use where there is no ice shelf [C ~> degC] + real :: cg_tolerance !< The tolerance in the CG solver, relative to initial residual, that + !! determines when to stop the conjugate gradient iterations [nondim]. + real :: nonlinear_tolerance !< The fractional nonlinear tolerance, relative to the initial error, + !! that sets when to stop the iterative velocity solver [nondim] + integer :: cg_max_iterations !< The maximum number of iterations that can be used in the CG solver + integer :: nonlin_solve_err_mode !< 1: exit vel solve based on nonlin residual + !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol) where | | is infty-norm + !! 3: exit based on change of norm + + ! for write_ice_shelf_energy + type(time_type) :: energysavedays !< The interval between writing the energies + !! and other integral quantities of the run. + type(time_type) :: energysavedays_geometric !< The starting interval for computing a geometric + !! progression of time deltas between calls to + !! write_energy. This interval will increase by a factor of 2. + !! after each call to write_energy. + logical :: energysave_geometric !< Logical to control whether calls to write_energy should + !! follow a geometric progression + type(time_type) :: write_energy_time !< The next time to write to the energy file. + type(time_type) :: geometric_end_time !< Time at which to stop the geometric progression + !! of calls to write_energy and revert to the standard + !! energysavedays interval + real :: timeunit !< The length of the units for the time axis and certain input parameters + !! including ENERGYSAVEDAYS [s]. + type(time_type) :: Start_time !< The start time of the simulation. + ! Start_time is set in MOM_initialization.F90 + integer :: prev_IS_energy_calls = 0 !< The number of times write_ice_shelf_energy has been called. + integer :: IS_fileenergy_ascii !< The unit number of the ascii version of the energy file. + character(len=200) :: IS_energyfile !< The name of the ice sheet energy file with path. + + ! ids for outputting intermediate thickness in advection subroutine (debugging) + !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 + + logical :: debug !< If true, write verbose checksums for debugging purposes + !! and use reproducible sums + logical :: module_is_initialized = .false. !< True if this module has been initialized. + + !>@{ Diagnostic handles + integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & + id_taudx_shelf = -1, id_taudy_shelf = -1, id_bed_elev = -1, & + id_ground_frac = -1, id_col_thick = -1, id_OD_av = -1, id_float_cond = -1, & + id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1, id_t_mask = -1 + !>@} + ! ids for outputting intermediate thickness in advection subroutine (debugging) + !>@{ Diagnostic handles for debugging + integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1, & + id_visc_shelf = -1, id_taub = -1 + !>@} + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. + +end type ice_shelf_dyn_CS + +!> A container for loop bounds +type :: loop_bounds_type ; private + !>@{ Loop bounds + integer :: ish, ieh, jsh, jeh + !>@} +end type loop_bounds_type + +contains + +!> used for flux limiting in advective subroutines Van Leer limiter (source: Wikipedia) +!! The return value is between 0 and 2 [nondim]. +function slope_limiter(num, denom) + real, intent(in) :: num !< The numerator of the ratio used in the Van Leer slope limiter + real, intent(in) :: denom !< The denominator of the ratio used in the Van Leer slope limiter + real :: slope_limiter ! The slope limiter value, between 0 and 2 [nondim]. + real :: r ! The ratio of num/denom [nondim] + + if (denom == 0) then + slope_limiter = 0 + elseif (num*denom <= 0) then + slope_limiter = 0 + else + r = num/denom + slope_limiter = (r+abs(r))/(1+abs(r)) + endif + +end function slope_limiter + +!> Calculate area of quadrilateral. +function quad_area (X, Y) + real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral [L ~> m]. + real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral [L ~> m]. + real :: quad_area ! Computed area [L2 ~> m2] + real :: p2, q2, a2, c2, b2, d2 + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + + p2 = (X(4)-X(1))**2 + (Y(4)-Y(1))**2 ; q2 = (X(3)-X(2))**2 + (Y(3)-Y(2))**2 + a2 = (X(3)-X(4))**2 + (Y(3)-Y(4))**2 ; c2 = (X(1)-X(2))**2 + (Y(1)-Y(2))**2 + b2 = (X(2)-X(4))**2 + (Y(2)-Y(4))**2 ; d2 = (X(3)-X(1))**2 + (Y(3)-Y(1))**2 + quad_area = .25 * sqrt(4*P2*Q2-(B2+D2-A2-C2)**2) + +end function quad_area + +!> This subroutine is used to register any fields related to the ice shelf +!! dynamics that should be written to or read from the restart file. +subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) + type(ocean_grid_type), intent(inout) :: G !< The grid type describing the ice shelf grid. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + + ! Local variables + real :: T_shelf_missing ! An ice shelf temperature to use where there is no ice shelf [C ~> degC] + logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics + character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (associated(CS)) then + call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, register_ice_shelf_dyn_restarts: "// & + "called with an associated control structure.") + return + endif + allocate(CS) + + override_shelf_movement = .false. ; active_shelf_dynamics = .false. + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & + "If true, the ice sheet mass can evolve with time.", & + default=.false., do_not_log=.true.) + if (shelf_mass_is_dynamic) then + call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, & + "If true, user provided code specifies the ice-shelf "//& + "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.) + active_shelf_dynamics = .not.override_shelf_movement + endif + + if (active_shelf_dynamics) then + call get_param(param_file, mdl, "MISSING_SHELF_TEMPERATURE", T_shelf_missing, & + "An ice shelf temperature to use where there is no ice shelf.",& + units="degC", default=-10.0, scale=US%degC_to_C, do_not_log=.true.) + + call get_param(param_file, mdl, "NUMBER_OF_ICE_VISCOSITY_QUADRATURE_POINTS", CS%visc_qps, & + "Number of ice viscosity quadrature points. Either 1 (cell-centered) for 4", & + units="none", default=1) + if (CS%visc_qps/=1 .and. CS%visc_qps/=4) call MOM_error (FATAL, & + "NUMBER OF ICE_VISCOSITY_QUADRATURE_POINTS must be 1 or 4") + + call get_param(param_file, mdl, "FIRST_DIRECTION_IS", CS%first_direction_IS, & + "An integer that indicates which direction goes first "//& + "in parts of the code that use directionally split "//& + "updates (e.g. advection), with even numbers (or 0) used for x- first "//& + "and odd numbers used for y-first.", default=0) + call get_param(param_file, mdl, "ALTERNATE_FIRST_DIRECTION_IS", CS%alternate_first_direction_IS, & + "If true, after every advection call, alternate whether the x- or y- "//& + "direction advection updates occur first. "//& + "If this is true, FIRST_DIRECTION applies at the start of a new run or if "//& + "the next first direction can not be found in the restart file.", default=.false.) + + allocate(CS%u_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%v_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%t_shelf(isd:ied,jsd:jed), source=T_shelf_missing) ! [C ~> degC] + allocate(CS%ice_visc(isd:ied,jsd:jed,CS%visc_qps), source=0.0) + allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] + allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L3 T-1 ~> kg s-1] + allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (m-1 s)^n_sliding] + allocate(CS%OD_av(isd:ied,jsd:jed), source=0.0) + allocate(CS%ground_frac(isd:ied,jsd:jed), source=0.0) + allocate(CS%taudx_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%taudy_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%bed_elev(isd:ied,jsd:jed), source=0.0) + allocate(CS%u_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%v_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%u_face_mask_bdry(IsdB:IedB,JsdB:JedB), source=-2.0) + allocate(CS%v_face_mask_bdry(IsdB:iedB,JsdB:JedB), source=-2.0) + allocate(CS%h_bdry_val(isd:ied,jsd:jed), source=0.0) + + ! additional restarts for ice shelf state + call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & + "ice sheet/shelf u-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') + call register_restart_field(CS%v_shelf, "v_shelf", .false., restart_CS, & + "ice sheet/shelf v-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') + call register_restart_field(CS%u_bdry_val, "u_bdry_val", .false., restart_CS, & + "ice sheet/shelf boundary u-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') + call register_restart_field(CS%v_bdry_val, "v_bdry_val", .false., restart_CS, & + "ice sheet/shelf boundary v-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') + call register_restart_field(CS%u_face_mask_bdry, "u_face_mask_bdry", .false., restart_CS, & + "ice sheet/shelf boundary u-mask", "nondim", hor_grid='Bu') + call register_restart_field(CS%v_face_mask_bdry, "v_face_mask_bdry", .false., restart_CS, & + "ice sheet/shelf boundary v-mask", "nondim", hor_grid='Bu') + + call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & + "Average open ocean depth in a cell", "m", conversion=US%Z_to_m) + call register_restart_field(CS%ground_frac, "ground_frac", .true., restart_CS, & + "fractional degree of grounding", "nondim") + call register_restart_field(CS%C_basal_friction, "C_basal_friction", .true., restart_CS, & + "basal sliding coefficients", "Pa (m s-1)^n_sliding") + call register_restart_field(CS%AGlen_visc, "AGlen_visc", .true., restart_CS, & + "ice-stiffness parameter", "Pa-3 s-1") + call register_restart_field(CS%h_bdry_val, "h_bdry_val", .false., restart_CS, & + "ice thickness at the boundary", "m", conversion=US%Z_to_m) + call register_restart_field(CS%bed_elev, "bed elevation", .true., restart_CS, & + "bed elevation", "m", conversion=US%Z_to_m) + call register_restart_field(CS%first_dir_restart_IS, "first_direction_IS", .false., restart_CS, & + "Indicator of the first direction in split ice shelf calculations.", "nondim") + endif + +end subroutine register_ice_shelf_dyn_restarts + +!> Initializes shelf model data, parameters and diagnostics +subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, & + Input_start_time, directory, solo_ice_sheet_in) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure + type(ocean_grid_type), intent(inout) :: G !< The grid type describing the ice shelf grid. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. + logical, intent(in) :: new_sim !< If true this is a new simulation, otherwise + !! has been started from a restart file. + type(time_type), intent(in) :: Input_start_time !< The start time of the simulation. + character(len=*), intent(in) :: directory !< The directory where the ice sheet energy file goes. + logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether + !! a solo ice-sheet driver. + + ! Local variables + real :: T_shelf_bdry ! A default ice shelf temperature to use for ice flowing + ! in through open boundaries [C ~> degC] + !This include declares and sets the variable "version". +# include "version_variable.h" + character(len=200) :: IC_file,filename,inputdir + character(len=40) :: var_name + character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. + logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics + logical :: debug + integer :: i, j, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + character(len=200) :: IS_energyfile ! The name of the energy file. + character(len=32) :: filename_appendix = '' ! FMS appendix to filename for ensemble runs + + Isdq = G%isdB ; Iedq = G%iedB ; Jsdq = G%jsdB ; Jedq = G%jedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (.not.associated(CS)) then + call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn: "// & + "called with an associated control structure.") + return + endif + if (CS%module_is_initialized) then + call MOM_error(WARNING, "MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn was "//& + "called with a control structure that has already been initialized.") + endif + CS%module_is_initialized = .true. + + CS%diag => diag ! ; CS%Time => Time + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) + call get_param(param_file, mdl, "DEBUG_IS", CS%debug, & + "If true, write verbose debugging messages for the ice shelf.", & + default=debug) + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & + "If true, the ice sheet mass can evolve with time.", & + default=.false.) + override_shelf_movement = .false. ; active_shelf_dynamics = .false. + if (shelf_mass_is_dynamic) then + call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, & + "If true, user provided code specifies the ice-shelf "//& + "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.) + active_shelf_dynamics = .not.override_shelf_movement + + call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & + "If true, regularize the floatation condition at the "//& + "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) + call get_param(param_file, mdl, "GROUNDING_LINE_INTERP_SUBGRID_N", CS%n_sub_regularize, & + "The number of sub-partitions of each cell over which to "//& + "integrate for the interpolated grounding line. Each cell "//& + "is divided into NxN equally-sized rectangles, over which the "//& + "basal contribution is integrated by iterative quadrature.", & + default=0) + call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & + "If true, let the floatation condition be determined by "//& + "ocean column thickness. This means that update_OD_ffrac "//& + "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & + default=.false., do_not_log=CS%GL_regularize) + if (CS%GL_regularize) CS%GL_couple = .false. + if (present(solo_ice_sheet_in)) then + if (solo_ice_sheet_in) CS%GL_couple = .false. + endif + if (CS%GL_regularize .and. (CS%n_sub_regularize == 0)) call MOM_error (FATAL, & + "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") + call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", CS%CFL_factor, & + "A factor used to limit timestep as CFL_FACTOR * min (\Delta x / u). "//& + "This is only used with an ice-only model.", units="nondim", default=0.25) + endif + call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & + "avg ocean density used in floatation cond", & + units="kg m-3", default=1035., scale=US%kg_m3_to_R) + if (active_shelf_dynamics) then + call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", CS%velocity_update_time_step, & + "seconds between ice velocity calcs", units="s", scale=US%s_to_T, & + fail_if_missing=.true.) + call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & + "The gravitational acceleration of the Earth.", & + units="m s-2", default=9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) + + call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & + "nonlinearity exponent in Glen's Law", & + units="none", default=3.) + call get_param(param_file, mdl, "MIN_STRAIN_RATE_GLEN", CS%eps_glen_min, & + "min. strain rate to avoid infinite Glen's law viscosity", & + units="s-1", default=1.e-19, scale=US%T_to_s) + call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_fric, & + "Exponent in sliding law \tau_b = C u^(n_basal_fric)", & + units="none", fail_if_missing=.true.) + call get_param(param_file, mdl, "USE_COULOMB_FRICTION", CS%CoulombFriction, & + "Use Coulomb Friction Law", & + units="none", default=.false., fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_MinN", CS%CF_MinN, & + "Minimum Coulomb friction effective pressure", & + units="Pa", default=1.0, fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_PostPeak", CS%CF_PostPeak, & + "Coulomb friction post peak exponent", & + units="none", default=1.0, fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_Max", CS%CF_Max, & + "Coulomb friction maximum coefficient", & + units="none", default=0.5, fail_if_missing=.false.) + + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & + "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & + "tolerance in CG solver, relative to initial residual", units="nondim", default=1.e-6) + call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", CS%nonlinear_tolerance, & + "nonlin tolerance in iterative velocity solve", units="nondim", default=1.e-6) + call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", CS%cg_max_iterations, & + "max iteratiions in CG solver", default=2000) + call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", CS%thresh_float_col_depth, & + "min ocean thickness to consider ice *floating*; "//& + "will only be important with use of tides", & + units="m", default=1.e-3, scale=US%m_to_Z) + call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & + "Choose whether nonlin error in vel solve is based on nonlinear "//& + "residual (1), relative change since last iteration (2), or change in norm (3)", default=1) + + call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & + "Specify whether to advance shelf front (and calve).", & + default=.false.) + call get_param(param_file, mdl, "CALVE_TO_MASK", CS%calve_to_mask, & + "If true, do not allow an ice shelf where prohibited by a mask.", & + default=.false.) + call get_param(param_file, mdl, "ADVECT_SHELF", CS%advect_shelf, & + "If true, advect ice shelf and evolve thickness", & + default=.true.) + call get_param(param_file, mdl, "ICE_VISCOSITY_COMPUTE", CS%ice_viscosity_compute, & + "If MODEL, compute ice viscosity internally using 1 or 4 quadrature points,"//& + "if OBS read from a file,"//& + "if CONSTANT a constant value (for debugging).", & + default="MODEL") + + if ((CS%visc_qps/=1) .and. (trim(CS%ice_viscosity_compute) /= "MODEL")) then + call MOM_error(FATAL, "NUMBER_OF_ICE_VISCOSITY_QUADRATURE_POINTS must be 1 unless ICE_VISCOSITY_COMPUTE==MODEL.") + endif + call get_param(param_file, mdl, "INFLOW_SHELF_TEMPERATURE", T_shelf_bdry, & + "A default ice shelf temperature to use for ice flowing in through "//& + "open boundaries.", units="degC", default=-15.0, scale=US%degC_to_C) + endif + call get_param(param_file, mdl, "MISSING_SHELF_TEMPERATURE", CS%T_shelf_missing, & + "An ice shelf temperature to use where there is no ice shelf.",& + units="degC", default=-10.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", CS%min_thickness_simple_calve, & + "Min thickness rule for the VERY simple calving law",& + units="m", default=0.0, scale=US%m_to_Z) + + !for write_ice_shelf_energy + ! Note that the units of CS%Timeunit are the MKS units of [s]. + call get_param(param_file, mdl, "TIMEUNIT", CS%Timeunit, & + "The time unit in seconds a number of input fields", & + units="s", default=86400.0) + if (CS%Timeunit < 0.0) CS%Timeunit = 86400.0 + call get_param(param_file, mdl, "ENERGYSAVEDAYS",CS%energysavedays, & + "The interval in units of TIMEUNIT between saves of the "//& + "energies of the run and other globally summed diagnostics.",& + default=set_time(0,days=1), timeunit=CS%Timeunit) + call get_param(param_file, mdl, "ENERGYSAVEDAYS_GEOMETRIC",CS%energysavedays_geometric, & + "The starting interval in units of TIMEUNIT for the first call "//& + "to save the energies of the run and other globally summed diagnostics. "//& + "The interval increases by a factor of 2. after each call to write_ice_shelf_energy.",& + default=set_time(seconds=0), timeunit=CS%Timeunit) + if ((time_type_to_real(CS%energysavedays_geometric) > 0.) .and. & + (CS%energysavedays_geometric < CS%energysavedays)) then + CS%energysave_geometric = .true. + else + CS%energysave_geometric = .false. + endif + CS%Start_time = Input_start_time + call get_param(param_file, mdl, "ICE_SHELF_ENERGYFILE", IS_energyfile, & + "The file to use to write the energies and globally "//& + "summed diagnostics.", default="ice_shelf.stats") + !query fms_io if there is a filename_appendix (for ensemble runs) + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + IS_energyfile = trim(IS_energyfile) //'.'//trim(filename_appendix) + endif + + CS%IS_energyfile = trim(slasher(directory))//trim(IS_energyfile) + call log_param(param_file, mdl, "output_path/ENERGYFILE", CS%IS_energyfile) +#ifdef STATSLABEL + CS%IS_energyfile = trim(CS%IS_energyfile)//"."//trim(adjustl(STATSLABEL)) +#endif + + ! Allocate memory in the ice shelf dynamics control structure that was not + ! previously allocated for registration for restarts. + + if (active_shelf_dynamics) then + allocate( CS%t_bdry_val(isd:ied,jsd:jed), source=T_shelf_bdry) ! [C ~> degC] + allocate( CS%u_face_mask(Isdq:Iedq,Jsdq:Jedq), source=0.0) + allocate( CS%v_face_mask(Isdq:Iedq,Jsdq:Jedq), source=0.0) + allocate( CS%u_flux_bdry_val(Isdq:Iedq,jsd:jed), source=0.0) + allocate( CS%v_flux_bdry_val(isd:ied,Jsdq:Jedq), source=0.0) + allocate( CS%umask(Isdq:Iedq,Jsdq:Jedq), source=-1.0) + allocate( CS%vmask(Isdq:Iedq,Jsdq:Jedq), source=-1.0) + allocate( CS%tmask(Isdq:Iedq,Jsdq:Jedq), source=-1.0) + allocate( CS%float_cond(isd:ied,jsd:jed)) + + CS%OD_rt_counter = 0 + allocate( CS%OD_rt(isd:ied,jsd:jed), source=0.0) + allocate( CS%ground_frac_rt(isd:ied,jsd:jed), source=0.0) + + if (CS%calve_to_mask) then + allocate( CS%calve_mask(isd:ied,jsd:jed), source=0.0) + endif + + allocate(CS%Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) + do j=G%jsd,G%jed ; do i=G%isd,G%ied + call bilinear_shape_fn_grid(G, i, j, CS%Phi(:,:,i,j)) + enddo; enddo + + if (CS%GL_regularize) then + allocate(CS%Phisub(2,2,CS%n_sub_regularize,CS%n_sub_regularize,2,2), source=0.0) + call bilinear_shape_functions_subgrid(CS%Phisub, CS%n_sub_regularize) + endif + + if ((trim(CS%ice_viscosity_compute) == "MODEL") .and. CS%visc_qps==1) then + !for calculating viscosity and 1 cell-centered quadrature point per cell + allocate(CS%PhiC(1:8,G%isc:G%iec,G%jsc:G%jec), source=0.0) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call bilinear_shape_fn_grid_1qp(G, i, j, CS%PhiC(:,i,j)) + enddo; enddo + endif + + CS%elapsed_velocity_time = 0.0 + + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + endif + + ! Take additional initialization steps, for example of dependent variables. + if (active_shelf_dynamics .and. .not.new_sim) then + + ! this is unfortunately necessary; if grid is not symmetric the boundary values + ! of u and v are otherwise not set till the end of the first linear solve, and so + ! viscosity is not calculated correctly. + ! This has to occur after init_boundary_values or some of the arrays on the + ! right hand side have not been set up yet. + if (.not. G%symmetric) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if ((i+G%idg_offset) == (G%domain%nihalo+1)) then + if (CS%u_face_mask(I-1,j) == 3) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) + elseif (CS%u_face_mask(I-1,j) == 5) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) + elseif (CS%u_face_mask(I-1,j) == 6) then + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) + endif + endif + if ((j+G%jdg_offset) == (G%domain%njhalo+1)) then + if (CS%v_face_mask(i,J-1) == 3) then + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) + elseif (CS%v_face_mask(i,J-1) == 5) then + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) + elseif (CS%v_face_mask(i,J-1) == 6) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) + endif + endif + enddo ; enddo + endif + + call pass_var(CS%OD_av,G%domain, complete=.false.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%basal_traction, G%domain, complete=.false.) + call pass_var(CS%AGlen_visc, G%domain, complete=.false.) + call pass_var(CS%bed_elev, G%domain, complete=.false.) + call pass_var(CS%C_basal_friction, G%domain, complete=.false.) + call pass_var(CS%h_bdry_val, G%domain, complete=.true.) + call pass_var(CS%ice_visc, G%domain) + + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.true.) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + endif + + if (active_shelf_dynamics) then + if (CS%first_dir_restart_IS > -1.0) then + CS%first_direction_IS = modulo(NINT(CS%first_dir_restart_IS), 2) + else + CS%first_dir_restart_IS = real(modulo(CS%first_direction_IS, 2)) + endif + + ! If we are calving to a mask, i.e. if a mask exists where a shelf cannot, read the mask from a file. + if (CS%calve_to_mask) then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading calving_mask") + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "CALVING_MASK_FILE", IC_file, & + "The file with a mask for where calving might occur.", & + default="ice_shelf_h.nc") + call get_param(param_file, mdl, "CALVING_MASK_VARNAME", var_name, & + "The variable to use in masking calving.", & + default="area_shelf_h") + + filename = trim(inputdir)//trim(IC_file) + call log_param(param_file, mdl, "INPUTDIR/CALVING_MASK_FILE", filename) + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " calving mask file: Unable to open "//trim(filename)) + + call MOM_read_data(filename,trim(var_name),CS%calve_mask,G%Domain) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%calve_mask(i,j) > 0.0) CS%calve_mask(i,j) = 1.0 + enddo ; enddo + call pass_var(CS%calve_mask,G%domain) + 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, complete=.false.) + + ! initialize ice-stiffness AGlen + call initialize_ice_AGlen(CS%AGlen_visc, CS%ice_viscosity_compute, G, US, param_file) + call pass_var(CS%AGlen_visc, G%domain, complete=.false.) + + !initialize boundary conditions + call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & + CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & + ISS%hmask, ISS%h_shelf, G, US, param_file ) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(CS%h_bdry_val, G%domain, complete=.true.) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.false.) + + !initialize ice flow characteristic (velocities, bed elevation under the grounded part, etc) from file + call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf, CS%ground_frac, & + G, US, param_file) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE, complete=.true.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%bed_elev, G%domain, complete=.true.) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + endif + ! Register diagnostics. + 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) + CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesB1, Time, & + 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) + CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesB1, Time, & + 'x-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_taudy_shelf = register_diag_field('ice_shelf_model','taudy_shelf',CS%diag%axesB1, Time, & + 'y-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_u_mask = register_diag_field('ice_shelf_model','u_mask',CS%diag%axesB1, Time, & + 'mask for u-nodes', 'none') + CS%id_v_mask = register_diag_field('ice_shelf_model','v_mask',CS%diag%axesB1, Time, & + 'mask for v-nodes', 'none') + CS%id_ground_frac = register_diag_field('ice_shelf_model','ice_ground_frac',CS%diag%axesT1, Time, & + 'fraction of cell that is grounded', 'none') + CS%id_float_cond = register_diag_field('ice_shelf_model','float_cond',CS%diag%axesT1, Time, & + 'sub-cell grounding cells', 'none') + CS%id_col_thick = register_diag_field('ice_shelf_model','col_thick',CS%diag%axesT1, Time, & + 'ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) + CS%id_visc_shelf = register_diag_field('ice_shelf_model','ice_visc',CS%diag%axesT1, Time, & + 'vi-viscosity', 'Pa m s', conversion=US%RL2_T2_to_Pa*US%Z_to_m*US%T_to_s) !vertically integrated viscosity + CS%id_taub = register_diag_field('ice_shelf_model','taub_beta',CS%diag%axesT1, Time, & + 'taub', 'MPa s m-1', conversion=1e-6*US%RL2_T2_to_Pa/(365.0*86400.0*US%L_T_to_m_s)) + CS%id_OD_av = register_diag_field('ice_shelf_model','OD_av',CS%diag%axesT1, Time, & + 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) + endif + + if (new_sim) then + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) + endif + +end subroutine initialize_ice_shelf_dyn + + +subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(time_type), intent(in) :: Time !< The current model time + + integer :: i, j, iters, isd, ied, jsd, jed + real :: rhoi_rhow + real :: OD ! Depth of open water below the ice shelf [Z ~> m] + type(time_type) :: dummy_time +! + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + dummy_time = set_time(0,0) + isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + do j=jsd,jed + do i=isd,ied + OD = CS%bed_elev(i,j) - rhoi_rhow * ISS%h_shelf(i,j) + if (OD >= 0) then + ! ice thickness does not take up whole ocean column -> floating + CS%OD_av(i,j) = OD + CS%ground_frac(i,j) = 0. + else + CS%OD_av(i,j) = 0. + CS%ground_frac(i,j) = 1. + endif + 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) +end subroutine initialize_diagnostic_fields + +!> This function returns the global maximum advective timestep that can be taken based on the current +!! ice velocities. Because it involves finding a global minimum, it can be surprisingly expensive. +function ice_time_step_CFL(CS, ISS, G) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real :: ice_time_step_CFL !< The maximum permitted timestep based on the ice velocities [T ~> s]. + + real :: dt_local, min_dt ! These should be the minimum stable timesteps at a CFL of 1 [T ~> s] + real :: min_vel ! A minimal velocity for estimating a timestep [L T-1 ~> m s-1] + integer :: i, j + + min_dt = 5.0e17*G%US%s_to_T ! The starting maximum is roughly the lifetime of the universe. + min_vel = (1.0e-12/(365.0*86400.0)) * G%US%m_s_to_L_T + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0 .or. ISS%hmask(i,j)==3) then + dt_local = 2.0*G%areaT(i,j) / & + ((G%dyCu(I,j) * max(abs(CS%u_shelf(I,J) + CS%u_shelf(I,j-1)), min_vel) + & + G%dyCu(I-1,j)* max(abs(CS%u_shelf(I-1,J)+ CS%u_shelf(I-1,j-1)), min_vel)) + & + (G%dxCv(i,J) * max(abs(CS%v_shelf(i,J) + CS%v_shelf(i-1,J)), min_vel) + & + G%dxCv(i,J-1)* max(abs(CS%v_shelf(i,J-1)+ CS%v_shelf(i-1,J-1)), min_vel))) + + min_dt = min(min_dt, dt_local) + endif ; enddo ; enddo ! i- and j- loops + + call min_across_PEs(min_dt) + + ice_time_step_CFL = CS%CFL_factor * min_dt + +end function ice_time_step_CFL + +!> This subroutine updates the ice shelf velocities, mass, stresses and properties due to the +!! ice shelf dynamics. +subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled_grounding, must_update_vel) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, intent(in) :: time_step !< time step [T ~> s] + type(time_type), intent(in) :: Time !< The current model time + real, dimension(SZDI_(G),SZDJ_(G)), & + optional, intent(in) :: ocean_mass !< If present this is the mass per unit area + !! of the ocean [R Z ~> kg m-2]. + logical, optional, intent(in) :: coupled_grounding !< If true, the grounding line is + !! determined by coupled ice-ocean dynamics + logical, optional, intent(in) :: must_update_vel !< Always update the ice velocities if true. + real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y ! Pa] + real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc !< area-averaged vertically integrated ice viscosity + !! [R L2 Z T-1 ~> Pa s m] + real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr !< area-averaged taub_beta field related to basal traction, + !! [R L1 T-1 ~> Pa s m-1] + integer :: iters + logical :: update_ice_vel, coupled_GL + + update_ice_vel = .false. + if (present(must_update_vel)) update_ice_vel = must_update_vel + + coupled_GL = .false. + if (present(ocean_mass) .and. present(coupled_grounding)) coupled_GL = coupled_grounding +! + if (CS%advect_shelf) then + call ice_shelf_advect(CS, ISS, G, time_step, Time) + if (CS%alternate_first_direction_IS) then + CS%first_direction_IS = modulo(CS%first_direction_IS+1,2) + CS%first_dir_restart_IS = real(CS%first_direction_IS) + endif + endif + CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step + if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. + + 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(:,:)) + CS%GL_couple=.false. + 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 (CS%elapsed_velocity_time >= CS%velocity_update_time_step) then + call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) + if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) + 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%IareaBu(:,:) + call post_data(CS%id_taudx_shelf, taud_x, CS%diag) + endif + if (CS%id_taudy_shelf > 0) then + taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaBu(:,:) + call post_data(CS%id_taudy_shelf, taud_y, CS%diag) + endif + if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac, CS%diag) + if (CS%id_float_cond > 0) call post_data(CS%id_float_cond, CS%float_cond, 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 + if (CS%visc_qps==4) then + ice_visc(:,:) = (0.25 * G%IareaT(:,:)) * & + ((CS%ice_visc(:,:,1) + CS%ice_visc(:,:,4)) + (CS%ice_visc(:,:,2) + CS%ice_visc(:,:,3))) + else + ice_visc(:,:) = CS%ice_visc(:,:,1)*G%IareaT(:,:) + endif + 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) + + call disable_averaging(CS%diag) + + CS%elapsed_velocity_time = 0.0 + endif + +end subroutine update_ice_shelf + +!> Writes the total ice shelf kinetic energy and mass to an ascii file +subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: mass !< The mass per unit area of the ice shelf + !! or sheet [R Z ~> kg m-2] + type(time_type), intent(in) :: day !< The current model time. + type(time_type), optional, intent(in) :: time_step !< The current time step + ! Local variables + type(time_type) :: dt ! A time_type version of the timestep. + real, dimension(SZDI_(G),SZDJ_(G)) :: tmp1 ! A temporary array used in reproducing sums [various] + real :: KE_tot, mass_tot, KE_scale_factor, mass_scale_factor + integer :: is, ie, js, je, isr, ier, jsr, jer, i, j + character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str + integer :: start_of_day, num_days + real :: reday ! Time in units given by CS%Timeunit, but often [days] + + ! write_energy_time is the next integral multiple of energysavedays. + if (present(time_step)) then + dt = time_step + else + dt = set_time(seconds=2) + endif + + !CS%prev_IS_energy_calls tracks the ice sheet step, which is outputted in the energy file. + if (CS%prev_IS_energy_calls == 0) then + if (CS%energysave_geometric) then + if (CS%energysavedays_geometric < CS%energysavedays) then + CS%write_energy_time = day + CS%energysavedays_geometric + CS%geometric_end_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + else + CS%write_energy_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + endif + else + CS%write_energy_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + endif + elseif (day + (dt/2) <= CS%write_energy_time) then + CS%prev_IS_energy_calls = CS%prev_IS_energy_calls + 1 + return ! Do not write this step + else ! Determine the next write time before proceeding + if (CS%energysave_geometric) then + if (CS%write_energy_time + CS%energysavedays_geometric >= & + CS%geometric_end_time) then + CS%write_energy_time = CS%geometric_end_time + CS%energysave_geometric = .false. ! stop geometric progression + else + CS%write_energy_time = CS%write_energy_time + CS%energysavedays_geometric + endif + CS%energysavedays_geometric = CS%energysavedays_geometric*2 + else + CS%write_energy_time = CS%write_energy_time + CS%energysavedays + endif + endif + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) + + !calculate KE using cell-centered ice shelf velocity + tmp1(:,:)=0.0 + KE_scale_factor = US%L_to_m**2 * (US%RZ_to_kg_m2 * US%L_T_to_m_s**2) + do j=js,je ; do i=is,ie + tmp1(i,j) = (KE_scale_factor * 0.03125) * (G%areaT(i,j) * mass(i,j)) * & + (((CS%u_shelf(I-1,J-1)+CS%u_shelf(I,J))+(CS%u_shelf(I,J-1)+CS%u_shelf(I-1,J)))**2 + & + ((CS%v_shelf(I-1,J-1)+CS%v_shelf(I,J))+(CS%v_shelf(I,J-1)+CS%v_shelf(I-1,J)))**2) + enddo; enddo + + KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) + + !calculate mass + tmp1(:,:)=0.0 + mass_scale_factor = US%L_to_m**2 * US%RZ_to_kg_m2 + do j=js,je ; do i=is,ie + tmp1(i,j) = mass_scale_factor * (mass(i,j) * G%areaT(i,j)) + enddo; enddo + + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) + + if (is_root_pe()) then ! Only the root PE actually writes anything. + if (day > CS%Start_time) then + call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=APPEND_FILE) + else + call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=WRITEONLY_FILE) + if (abs(CS%timeunit - 86400.0) < 1.0) then + write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Day,"8x,"Energy/Mass,",13x,"Total Mass")') + write(CS%IS_fileenergy_ascii,'(12x,"[days]",10x,"[m2 s-2]",17x,"[kg]")') + else + if ((CS%timeunit >= 0.99) .and. (CS%timeunit < 1.01)) then + time_units = " [seconds] " + elseif ((CS%timeunit >= 3599.0) .and. (CS%timeunit < 3601.0)) then + time_units = " [hours] " + elseif ((CS%timeunit >= 86399.0) .and. (CS%timeunit < 86401.0)) then + time_units = " [days] " + elseif ((CS%timeunit >= 3.0e7) .and. (CS%timeunit < 3.2e7)) then + time_units = " [years] " + else + write(time_units,'(9x,"[",es8.2," s] ")') CS%timeunit + endif + + write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Time,"7x,"Energy/Mass,",13x,"Total Mass")') + write(CS%IS_fileenergy_ascii,'(A25,3x,"[m2 s-2]",17x,"[kg]")') time_units + endif + endif + + call get_time(day, start_of_day, num_days) + + if (abs(CS%timeunit - 86400.0) < 1.0) then + reday = REAL(num_days)+ (REAL(start_of_day)/86400.0) + else + reday = REAL(num_days)*(86400.0/CS%timeunit) + REAL(start_of_day)/abs(CS%timeunit) + endif + + if (reday < 1.0e8) then ; write(day_str, '(F12.3)') reday + elseif (reday < 1.0e11) then ; write(day_str, '(F15.3)') reday + else ; write(day_str, '(ES15.9)') reday ; endif + + if (CS%prev_IS_energy_calls < 1000000) then ; write(n_str, '(I6)') CS%prev_IS_energy_calls + elseif (CS%prev_IS_energy_calls < 10000000) then ; write(n_str, '(I7)') CS%prev_IS_energy_calls + elseif (CS%prev_IS_energy_calls < 100000000) then ; write(n_str, '(I8)') CS%prev_IS_energy_calls + else ; write(n_str, '(I10)') CS%prev_IS_energy_calls ; endif + + write(CS%IS_fileenergy_ascii,'(A,",",A,", En ",ES22.16,", M ",ES11.5)') & + trim(n_str), trim(day_str), KE_tot/mass_tot, mass_tot + endif + + CS%prev_IS_energy_calls = CS%prev_IS_energy_calls + 1 +end subroutine write_ice_shelf_energy + +!> This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. +!! Additionally, it will update the volume of ice in partially-filled cells, and update +!! hmask accordingly +subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< time step [T ~> s] + type(time_type), intent(in) :: Time !< The current model time + + +! 3/8/11 DNG +! +! This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. +! ADDITIONALLY, it will update the volume of ice in partially-filled cells, and update +! hmask accordingly +! +! The flux overflows are included here. That is because they will be used to advect 3D scalars +! into partial cells + + real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_flux1, h_after_flux2 ! Ice thicknesses [Z ~> m]. + real, dimension(SZDIB_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] + real, dimension(SZDI_(G),SZDJB_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] + type(loop_bounds_type) :: LB + integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec, stencil + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + uh_ice(:,:) = 0.0 + vh_ice(:,:) = 0.0 + + h_after_flux1(:,:) = 0.0 + h_after_flux2(:,:) = 0.0 + ! call MOM_mesg("MOM_ice_shelf.F90: ice_shelf_advect called") + + do j=jsd,jed ; do i=isd,ied ; if (CS%h_bdry_val(i,j) /= 0.0) then + ISS%h_shelf(i,j) = CS%h_bdry_val(i,j) + endif ; enddo ; enddo + + stencil = 2 + if (modulo(CS%first_direction_IS,2)==0) then + !x first + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil + if (LB%jsh < jsd) call MOM_error(FATAL, & + "ice_shelf_advect: Halo is too small for the ice thickness advection stencil.") + call ice_shelf_advect_thickness_x(CS, G, LB, time_step, ISS%hmask, ISS%h_shelf, h_after_flux1, uh_ice) + call pass_var(h_after_flux1, G%domain) + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + call ice_shelf_advect_thickness_y(CS, G, LB, time_step, ISS%hmask, h_after_flux1, h_after_flux2, vh_ice) + else + ! y first + LB%ish = G%isc-stencil ; LB%ieh = G%iec+stencil ; LB%jsh = G%jsc ; LB%jeh = G%jec + if (LB%ish < isd) call MOM_error(FATAL, & + "ice_shelf_advect: Halo is too small for the ice thickness advection stencil.") + call ice_shelf_advect_thickness_y(CS, G, LB, time_step, ISS%hmask, ISS%h_shelf, h_after_flux1, vh_ice) + call pass_var(h_after_flux1, G%domain) + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + call ice_shelf_advect_thickness_x(CS, G, LB, time_step, ISS%hmask, h_after_flux1, h_after_flux2, uh_ice) + endif + call pass_var(h_after_flux2, G%domain) + + do j=jsd,jed + do i=isd,ied + if (ISS%hmask(i,j) == 1) ISS%h_shelf(i,j) = h_after_flux2(i,j) + enddo + enddo + + if (CS%moving_shelf_front) then + call shelf_advance_front(CS, ISS, G, ISS%hmask, uh_ice, vh_ice) + if (CS%min_thickness_simple_calve > 0.0) then + call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & + CS%min_thickness_simple_calve) + endif + if (CS%calve_to_mask) then + call calve_to_mask(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%calve_mask) + endif + endif + + do j=jsc,jec; do i=isc,iec + ISS%mass_shelf(i,j) = (ISS%h_shelf(i,j) * CS%density_ice) * (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) + enddo; enddo + + call pass_var(ISS%mass_shelf, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.true.) + + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + +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) + 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 + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] + integer, intent(out) :: iters !< The number of iterations used in the solver. + type(time_type), intent(in) :: Time !< The current model time + + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: taudx !< Driving x-stress at q-points [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: taudy !< Driving y-stress at q-points [R L3 Z T-2 ~> kg m s-2] + !real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] + !real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! If GL_regularize=true, indicates cells containing + ! the grounding line (float_cond=1) or not (float_cond=0) + real, dimension(SZDIB_(G),SZDJB_(G)) :: Normvec ! Used for convergence + character(len=160) :: mesg ! The text of an error message + integer :: conv_flag, i, j, k,l, iter + integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, nodefloat + real :: err_max, err_tempu, err_tempv, err_init, max_vel, tempu, tempv, Norm, PrevNorm + real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] + integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. + + isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + + taudx(:,:) = 0.0 ; taudy(:,:) = 0.0 + Au(:,:) = 0.0 ; Av(:,:) = 0.0 + + ! need to make these conditional on GL interpolation + CS%float_cond(:,:) = 0.0 ; H_node(:,:) = 0.0 + !CS%ground_frac(:,:) = 0.0 + + if (.not. CS%GL_couple) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) > 0) then + CS%ground_frac(i,j) = 1.0 + CS%OD_av(i,j) =0.0 + endif + enddo ; enddo + endif + + call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) + call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) + ! This is to determine which cells contain the grounding line, the criterion being that the cell + ! is ice-covered, with some nodes floating and some grounded flotation condition is estimated by + ! assuming topography is cellwise constant and H is bilinear in a cell; floating where + ! rho_i/rho_w * H_node - D is negative + + ! need to make this conditional on GL interp + + if (CS%GL_regularize) then + + call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node) + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + nodefloat = 0 + + do l=0,1 ; do k=0,1 + if ((ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j)==3) .and. & + (rhoi_rhow * H_node(i-1+k,j-1+l) - CS%bed_elev(i,j) <= 0)) then + nodefloat = nodefloat + 1 + endif + enddo ; enddo + if ((nodefloat > 0) .and. (nodefloat < 4)) then + CS%float_cond(i,j) = 1.0 + CS%ground_frac(i,j) = 1.0 + endif + enddo ; enddo + + call pass_var(CS%float_cond, G%Domain, complete=.false.) + + endif + + call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) + call pass_var(CS%basal_traction, G%domain, complete=.true.) + call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) + call pass_var(CS%ice_visc, G%domain) + + ! This makes sure basal stress is only applied when it is supposed to be + if (CS%GL_regularize) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if (CS%ground_frac(i,j)/=1.0) CS%basal_traction(i,j) = 0.0 + enddo ; enddo + else + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + enddo ; enddo + endif + + if (CS%nonlin_solve_err_mode == 1) then + + Au(:,:) = 0.0 ; Av(:,:) = 0.0 + + call CG_action(CS, Au, Av, u_shlf, v_shlf, CS%Phi, CS%Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, CS%float_cond, CS%bed_elev, CS%basal_traction, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + + err_init = 0 ; err_tempu = 0 ; err_tempv = 0 + do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB + if (CS%umask(I,J) == 1) then + err_tempu = ABS(Au(I,J) - taudx(I,J)) + if (err_tempu >= err_init) err_init = err_tempu + endif + if (CS%vmask(I,J) == 1) then + err_tempv = ABS(Av(I,J) - taudy(I,J)) + if (err_tempv >= err_init) err_init = err_tempv + endif + enddo ; enddo + + call max_across_PEs(err_init) + elseif (CS%nonlin_solve_err_mode == 3) then + Normvec=0.0 + ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. + Is_sum = G%isc + (1-G%IsdB) + Ie_sum = G%iecB + (1-G%IsdB) + ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. + if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) + + Js_sum = G%jsc + (1-G%JsdB) + Je_sum = G%jecB + (1-G%JsdB) + ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. + if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (u_shlf(I,J)**2 * US%L_T_to_m_s**2) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (v_shlf(I,J)**2 * US%L_T_to_m_s**2) + enddo; enddo + Norm = reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum ) + Norm = sqrt(Norm) + endif + + u_last(:,:) = u_shlf(:,:) ; v_last(:,:) = v_shlf(:,:) + + !! begin loop + + do iter=1,50 + + call ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, CS%float_cond, & + ISS%hmask, conv_flag, iters, time, CS%Phi, CS%Phisub) + + if (CS%debug) then + call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) + call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) + endif + + write(mesg,*) "ice_shelf_solve_outer: linear solve done in ",iters," iterations" + call MOM_mesg(mesg, 5) + + call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) + call pass_var(CS%basal_traction, G%domain, complete=.true.) + call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) + call pass_var(CS%ice_visc, G%domain) + + ! makes sure basal stress is only applied when it is supposed to be + if (CS%GL_regularize) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if (CS%ground_frac(i,j)/=1.0) CS%basal_traction(i,j) = 0.0 + enddo ; enddo + else + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + enddo ; enddo + endif + + if (CS%nonlin_solve_err_mode == 1) then + + Au(:,:) = 0 ; Av(:,:) = 0 + + call CG_action(CS, Au, Av, u_shlf, v_shlf, CS%Phi, CS%Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, CS%float_cond, CS%bed_elev, CS%basal_traction, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + + err_max = 0 + + do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB + if (CS%umask(I,J) == 1) then + err_tempu = ABS(Au(I,J) - taudx(I,J)) + if (err_tempu >= err_max) err_max = err_tempu + endif + if (CS%vmask(I,J) == 1) then + err_tempv = ABS(Av(I,J) - taudy(I,J)) + if (err_tempv >= err_max) err_max = err_tempv + endif + enddo ; enddo + + call max_across_PEs(err_max) + + elseif (CS%nonlin_solve_err_mode == 2) then + + err_max=0. ; max_vel = 0 ; tempu = 0 ; tempv = 0 ; err_tempu = 0 + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(I,J) == 1) then + err_tempu = ABS(u_last(I,J)-u_shlf(I,J)) + if (err_tempu >= err_max) err_max = err_tempu + tempu = u_shlf(I,J) + else + tempu = 0.0 + endif + if (CS%vmask(I,J) == 1) then + err_tempv = MAX(ABS(v_last(I,J)-v_shlf(I,J)), err_tempu) + if (err_tempv >= err_max) err_max = err_tempv + tempv = SQRT(v_shlf(I,J)**2 + tempu**2) + endif + if (tempv >= max_vel) max_vel = tempv + enddo ; enddo + + u_last(:,:) = u_shlf(:,:) + v_last(:,:) = v_shlf(:,:) + + call max_across_PEs(max_vel) + call max_across_PEs(err_max) + err_init = max_vel + + elseif (CS%nonlin_solve_err_mode == 3) then + PrevNorm=Norm; Norm=0.0; Normvec=0.0 + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (u_shlf(I,J)**2 * US%L_T_to_m_s**2) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (v_shlf(I,J)**2 * US%L_T_to_m_s**2) + enddo; enddo + Norm = reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum ) + Norm = sqrt(Norm) + err_max=2.*abs(Norm-PrevNorm); err_init=Norm+PrevNorm + endif + + write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init + call MOM_mesg(mesg, 5) + + if (err_max <= CS%nonlinear_tolerance * err_init) then + exit + endif + + enddo + + write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init + call MOM_mesg(mesg) + write(mesg,*) "ice_shelf_solve_outer: exiting nonlinear solve after ",iter," iterations" + call MOM_mesg(mesg) + +end subroutine ice_shelf_solve_outer + +subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, float_cond, & + hmask, conv_flag, iters, time, Phi, Phisub) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: taudx !< The x-direction driving stress [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: taudy !< The y-direction driving stress [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< If GL_regularize=true, indicates cells containing + !! the grounding line (float_cond=1) or not (float_cond=0) + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + integer, intent(out) :: conv_flag !< A flag indicating whether (1) or not (0) the + !! iterations have converged to the specified tolerance + integer, intent(out) :: iters !< The number of iterations used in the solver. + type(time_type), intent(in) :: Time !< The current model time + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & + intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations [nondim] +! one linear solve (nonlinear iteration) of the solution for velocity + +! in this subroutine: +! boundary contributions are added to taud to get the RHS +! diagonal of matrix is found (for Jacobi precondition) +! CG iteration is carried out for max. iterations or until convergence + +! assumed - u, v, taud, visc, basal_traction are valid on the halo + + real, dimension(SZDIB_(G),SZDJB_(G)) :: & + Ru, Rv, & ! Residuals in the stress calculations [R L3 Z T-2 ~> m kg s-2] + Ru_old, Rv_old, & ! Previous values of Ru and Rv [R L3 Z T-2 ~> m kg s-2] + Zu, Zv, & ! Contributions to velocity changes [L T-1 ~> m s-1] + Zu_old, Zv_old, & ! Previous values of Zu and Zv [L T-1 ~> m s-1] + DIAGu, DIAGv, & ! Diagonals with units like Ru/Zu [R L2 Z T-1 ~> kg s-1] + RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2] + Au, Av, & ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] + Du, Dv, & ! Velocity changes [L T-1 ~> m s-1] + sum_vec, sum_vec_2 !, & + !ubd, vbd ! Boundary stress contributions [R L3 Z T-2 ~> kg m s-2] + real :: beta_k, dot_p1, resid0, cg_halo + real :: alpha_k ! A scaling factor for iterative corrections [nondim] + real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1] + ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] + real :: resid2_scale ! A scaling factor for redimensionalizing the global squared residuals + ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] + real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] + integer :: iter, i, j, isd, ied, jsd, jed, isc, iec, jsc, jec, is, js, ie, je + integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. + integer :: isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo + + isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + + Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 + Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 ; RHSu(:,:) = 0 ; RHSv(:,:) = 0 + Du(:,:) = 0 ; Dv(:,:) = 0 + dot_p1 = 0 + + ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. + Is_sum = G%isc + (1-G%IsdB) + Ie_sum = G%iecB + (1-G%IsdB) + ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. + if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) + + Js_sum = G%jsc + (1-G%JsdB) + Je_sum = G%jecB + (1-G%JsdB) + ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. + if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) + + RHSu(:,:) = taudx(:,:) + RHSv(:,:) = taudy(:,:) + + call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE, complete=.false.) + + call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & + hmask, rhoi_rhow, Phi, Phisub, DIAGu, DIAGv) + + call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE, complete=.false.) + + call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & + G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) + + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE, complete=.true.) + + Ru(:,:) = (RHSu(:,:) - Au(:,:)) + Rv(:,:) = (RHSv(:,:) - Av(:,:)) + resid_scale = (US%L_to_m**2*US%s_to_T)*(US%RZ_to_kg_m2*US%L_T_to_m_s**2) + resid2_scale = ((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2 + + sum_vec(:,:) = 0.0 + do j=jscq,jecq ; do i=iscq,iecq + if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 + if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 + enddo ; enddo + + dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) + + resid0 = sqrt(dot_p1) + + do j=jsdq,jedq + do i=isdq,iedq + if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) Zu(I,J) = Ru(I,J) / DIAGu(I,J) + if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) Zv(I,J) = Rv(I,J) / DIAGv(I,J) + enddo + enddo + + Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) + + cg_halo = 3 + conv_flag = 0 + + !!!!!!!!!!!!!!!!!! + !! !! + !! MAIN CG LOOP !! + !! !! + !!!!!!!!!!!!!!!!!! + + ! initially, c-grid data is valid up to 3 halo nodes out + + do iter = 1,CS%cg_max_iterations + + ! assume asymmetry + ! thus we can never assume that any arrays are legit more than 3 vertices past + ! the computational domain - this is their state in the initial iteration + + + is = iscq - cg_halo ; ie = iecq + cg_halo + js = jscq - cg_halo ; je = jecq + cg_halo + + Au(:,:) = 0 ; Av(:,:) = 0 + + call CG_action(CS, Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & + G, US, is, ie, js, je, rhoi_rhow) + + ! Au, Av valid region moves in by 1 + + call pass_vector(Au,Av,G%domain, TO_ALL, BGRID_NE) + + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + + do j=jscq,jecq ; do i=iscq,iecq + if (CS%umask(I,J) == 1) then + sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_2(I,J) = resid_scale * (Du(I,J) * Au(I,J)) + endif + if (CS%vmask(I,J) == 1) then + sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Dv(I,J) * Av(I,J)) + endif + enddo ; enddo + + alpha_k = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / & + reproducing_sum( sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum ) + + + do j=jsd,jed ; do i=isd,ied + if (CS%umask(I,J) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(I,J) + if (CS%vmask(I,J) == 1) v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(I,J) + enddo ; enddo + + do j=jsd,jed ; do i=isd,ied + if (CS%umask(I,J) == 1) then + Ru_old(I,J) = Ru(I,J) ; Zu_old(I,J) = Zu(I,J) + endif + if (CS%vmask(I,J) == 1) then + Rv_old(I,J) = Rv(I,J) ; Zv_old(I,J) = Zv(I,J) + endif + enddo ; enddo + +! Ru(:,:) = Ru(:,:) - alpha_k * Au(:,:) +! Rv(:,:) = Rv(:,:) - alpha_k * Av(:,:) + + do j=jsd,jed + do i=isd,ied + if (CS%umask(I,J) == 1) Ru(I,J) = Ru(I,J) - alpha_k * Au(I,J) + if (CS%vmask(I,J) == 1) Rv(I,J) = Rv(I,J) - alpha_k * Av(I,J) + enddo + enddo + + do j=jsdq,jedq + do i=isdq,iedq + if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) then + Zu(I,J) = Ru(I,J) / DIAGu(I,J) + endif + if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) then + Zv(I,J) = Rv(I,J) / DIAGv(I,J) + endif + enddo + enddo + + ! R,u,v,Z valid region moves in by 1 + + ! beta_k = (Z \dot R) / (Zold \dot Rold) + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + + do j=jscq,jecq ; do i=iscq,iecq + if (CS%umask(I,J) == 1) then + sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_2(I,J) = resid_scale * (Zu_old(I,J) * Ru_old(I,J)) + endif + if (CS%vmask(I,J) == 1) then + sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Zv_old(I,J) * Rv_old(I,J)) + endif + enddo ; enddo + + beta_k = reproducing_sum(sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / & + reproducing_sum(sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum ) + +! Du(:,:) = Zu(:,:) + beta_k * Du(:,:) +! Dv(:,:) = Zv(:,:) + beta_k * Dv(:,:) + + do j=jsd,jed + do i=isd,ied + if (CS%umask(I,J) == 1) Du(I,J) = Zu(I,J) + beta_k * Du(I,J) + if (CS%vmask(I,J) == 1) Dv(I,J) = Zv(I,J) + beta_k * Dv(I,J) + enddo + enddo + + ! D valid region moves in by 1 + + sum_vec(:,:) = 0.0 + do j=jscq,jecq ; do i=iscq,iecq + if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 + if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 + enddo ; enddo + + dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) + dot_p1 = sqrt(dot_p1) + + + if (dot_p1 <= (CS%cg_tolerance * resid0)) then + iters = iter + conv_flag = 1 + exit + endif + + cg_halo = cg_halo - 1 + + if (cg_halo == 0) then + ! pass vectors + call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE, complete=.true.) + cg_halo = 3 + endif + + enddo ! end of CG loop + + do j=jsdq,jedq + do i=isdq,iedq + if (CS%umask(I,J) == 3) then + u_shlf(I,J) = CS%u_bdry_val(I,J) + elseif (CS%umask(I,J) == 0) then + u_shlf(I,J) = 0 + endif + + if (CS%vmask(I,J) == 3) then + v_shlf(I,J) = CS%v_bdry_val(I,J) + elseif (CS%vmask(I,J) == 0) then + v_shlf(I,J) = 0 + endif + enddo + enddo + + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) + if (conv_flag == 0) then + iters = CS%cg_max_iterations + endif + +end subroutine ice_shelf_solve_inner + +subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after_uflux, uh_ice) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. + real, intent(in) :: time_step !< The time step for this update [T ~> s]. + 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(in) :: h0 !< The initial ice shelf thicknesses [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes [Z ~> m]. + real, dimension(SZDIB_(G),SZDJ_(G)), & + intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] + + ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells + ! if there is an input bdry condition, the thickness there will be set in initialization + + + integer :: i, j + integer :: ish, ieh, jsh, jeh + real :: u_face ! Zonal velocity at a face [L T-1 ~> m s-1] + real :: h_face ! Thickness at a face for transport [Z ~> m] + real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] + +! is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec +! isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed +! i_off = G%idg_offset ; j_off = G%jdg_offset + + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh + + ! hmask coded values: 1) fully covered; 2) partly covered - no export; 3) Specified boundary condition + ! relevant u_face_mask coded values: 1) Normal interior point; 4) Specified flux BC + + do j=jsh,jeh ; do I=ish-1,ieh + if (CS%u_face_mask(I,j) == 4.) then ! The flux itself is a specified boundary condition. + uh_ice(I,j) = (time_step * G%dyCu(I,j)) * CS%u_flux_bdry_val(I,j) + elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i+1,j) == 1 .or. hmask(i+1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) + h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. + + if (u_face > 0) then + if (hmask(i,j) == 3) then ! This is a open boundary inflow from the west + h_face = CS%h_bdry_val(i,j) + elseif (hmask(i,j) == 1) then ! There can be eastward flow through this face. + if ((hmask(i-1,j) == 1 .or. hmask(i-1,j) == 3) .and. & + (hmask(i+1,j) == 1 .or. hmask(i+1,j) == 3)) then + slope_lim = slope_limiter(h0(i,j)-h0(i-1,j), h0(i+1,j)-h0(i,j)) + ! This is a 2nd-order centered scheme with a slope limiter. We could try PPM here. + h_face = h0(i,j) - slope_lim * (0.5 * (h0(i,j)-h0(i+1,j))) + else + h_face = h0(i,j) + endif + endif + else + if (hmask(i+1,j) == 3) then ! This is a open boundary inflow from the east + h_face = CS%h_bdry_val(i+1,j) + elseif (hmask(i+1,j) == 1) then + if ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .and. & + (hmask(i+2,j) == 1 .or. hmask(i+2,j) == 3)) then + slope_lim = slope_limiter(h0(i+1,j)-h0(i,j), h0(i+2,j)-h0(i+1,j)) + h_face = h0(i+1,j) - slope_lim * (0.5 * (h0(i+2,j)-h0(i+1,j))) + else + h_face = h0(i+1,j) + endif + endif + endif + + uh_ice(I,j) = (time_step * G%dyCu(I,j)) * (u_face * h_face) + else + uh_ice(I,j) = 0.0 + endif + enddo ; enddo + + do j=jsh,jeh ; do i=ish,ieh + if (hmask(i,j) /= 3) & + h_after_uflux(i,j) = h0(i,j) + (uh_ice(I-1,j) - uh_ice(I,j)) * G%IareaT(i,j) + + ! Update the masks of cells that have gone from no ice to partial ice. + if ((hmask(i,j) == 0) .and. ((uh_ice(I-1,j) > 0.0) .or. (uh_ice(I,j) < 0.0))) hmask(i,j) = 2 + enddo ; enddo + +end subroutine ice_shelf_advect_thickness_x + +subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after_vflux, vh_ice) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. + real, intent(in) :: time_step !< The time step for this update [T ~> s]. + 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(in) :: h0 !< The initial ice shelf thicknesses [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_vflux !< The ice shelf thicknesses after + !! the meridional mass fluxes [Z ~> m]. + real, dimension(SZDI_(G),SZDJB_(G)), & + intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] + + ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells + ! if there is an input bdry condition, the thickness there will be set in initialization + + + integer :: i, j + integer :: ish, ieh, jsh, jeh + real :: v_face ! Pseudo-meridional velocity at a face [L T-1 ~> m s-1] + real :: h_face ! Thickness at a face for transport [Z ~> m] + real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] + + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh + + ! hmask coded values: 1) fully covered; 2) partly covered - no export; 3) Specified boundary condition + ! relevant u_face_mask coded values: 1) Normal interior point; 4) Specified flux BC + + do J=jsh-1,jeh ; do i=ish,ieh + if (CS%v_face_mask(i,J) == 4.) then ! The flux itself is a specified boundary condition. + vh_ice(i,J) = (time_step * G%dxCv(i,J)) * CS%v_flux_bdry_val(i,J) + elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i,j+1) == 1 .or. hmask(i,j+1) == 3)) then + v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) + h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. + + if (v_face > 0) then + if (hmask(i,j) == 3) then ! This is a open boundary inflow from the south + h_face = CS%h_bdry_val(i,j) + elseif (hmask(i,j) == 1) then ! There can be northward flow through this face. + if ((hmask(i,j-1) == 1 .or. hmask(i,j-1) == 3) .and. & + (hmask(i,j+1) == 1 .or. hmask(i,j+1) == 3)) then + slope_lim = slope_limiter(h0(i,j)-h0(i,j-1), h0(i,j+1)-h0(i,j)) + ! This is a 2nd-order centered scheme with a slope limiter. We could try PPM here. + h_face = h0(i,j) - slope_lim * (0.5 * (h0(i,j)-h0(i,j+1))) + else + h_face = h0(i,j) + endif + endif + else + if (hmask(i,j+1) == 3) then ! This is a open boundary inflow from the north + h_face = CS%h_bdry_val(i,j+1) + elseif (hmask(i,j+1) == 1) then + if ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .and. & + (hmask(i,j+2) == 1 .or. hmask(i,j+2) == 3)) then + slope_lim = slope_limiter(h0(i,j+1)-h0(i,j), h0(i,j+2)-h0(i,j+1)) + h_face = h0(i,j+1) - slope_lim * (0.5 * (h0(i,j+2)-h0(i,j+1))) + else + h_face = h0(i,j+1) + endif + endif + endif + + vh_ice(i,J) = (time_step * G%dxCv(i,J)) * (v_face * h_face) + else + vh_ice(i,J) = 0.0 + endif + enddo ; enddo + + do j=jsh,jeh ; do i=ish,ieh + if (hmask(i,j) /= 3) & + h_after_vflux(i,j) = h0(i,j) + (vh_ice(i,J-1) - vh_ice(i,J)) * G%IareaT(i,j) + + ! Update the masks of cells that have gone from no ice to partial ice. + if ((hmask(i,j) == 0) .and. ((vh_ice(i,J-1) > 0.0) .or. (vh_ice(i,J) < 0.0))) hmask(i,j) = 2 + enddo ; enddo + +end subroutine ice_shelf_advect_thickness_y + +subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + 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(SZDIB_(G),SZDJ_(G)), & + intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] + real, dimension(SZDI_(G),SZDJB_(G)), & + intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] + + ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, + ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary + + ! if any cells go from partial to complete, we then must set the thickness, update hmask accordingly, + ! and divide the overflow across the adjacent EMPTY (not partly-covered) cells. + ! (it is highly unlikely there will not be any; in which case this will need to be rethought.) + + ! most likely there will only be one "overflow". If not, though, a pass_var of all relevant variables + ! is done; there will therefore be a loop which, in practice, will hopefully not have to go through + ! many iterations + + ! when 3d advected scalars are introduced, they will be impacted by what is done here + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, isc, iec, jsc, jec, n_flux, k, iter_count + integer :: i_off, j_off + integer :: iter_flag + + real :: h_reference ! A reference thicknesss based on neighboring cells [Z ~> m] + real :: h_reference_ew !contribution to reference thickness from east + west cells [Z ~> m] + real :: h_reference_ns !contribution to reference thickness from north + south cells [Z ~> m] + real :: tot_flux ! The total ice mass flux [Z L2 ~> m3] + real :: tot_flux_ew ! The contribution to total ice mass flux from east + west cells [Z L2 ~> m3] + real :: tot_flux_ns ! The contribution to total ice mass flux from north + south cells [Z L2 ~> m3] + real :: partial_vol ! The volume covered by ice shelf [Z L2 ~> m3] + real :: dxdyh ! Cell area [L2 ~> m2] + character(len=160) :: mesg ! The text of an error message + integer, dimension(4) :: mapi, mapj, new_partial + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter ! The ice volume flux into the + ! cell through the 4 cell boundaries [Z L2 ~> m3]. + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter_replace ! An updated ice volume flux into the + ! cell through the 4 cell boundaries [Z L2 ~> m3]. + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + i_off = G%idg_offset ; j_off = G%jdg_offset + iter_count = 0 ; iter_flag = 1 + + flux_enter(:,:,:) = 0.0 + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 + if ((hmask(i,j) == 0) .or. (hmask(i,j) == 2)) then + flux_enter(i,j,1) = max(uh_ice(I-1,j), 0.0) + flux_enter(i,j,2) = max(-uh_ice(I,j), 0.0) + flux_enter(i,j,3) = max(vh_ice(i,J-1), 0.0) + flux_enter(i,j,4) = max(-vh_ice(i,J), 0.0) + endif + enddo ; enddo + + mapi(1) = -1 ; mapi(2) = 1 ; mapi(3:4) = 0 + mapj(3) = -1 ; mapj(4) = 1 ; mapj(1:2) = 0 + + do while (iter_flag == 1) + + iter_flag = 0 + + if (iter_count > 0) then + flux_enter(:,:,:) = flux_enter_replace(:,:,:) + endif + flux_enter_replace(:,:,:) = 0.0 + + iter_count = iter_count + 1 + + ! if iter_count >= 3 then some halo updates need to be done... + + do j=jsc-1,jec+1 + + if (((j+j_off) <= G%domain%njglobal) .AND. & + ((j+j_off) >= 1)) then + + do i=isc-1,iec+1 + + if (((i+i_off) <= G%domain%niglobal) .AND. & + ((i+i_off) >= 1)) then + ! first get reference thickness by averaging over cells that are fluxing into this cell + n_flux = 0 + h_reference_ew = 0.0 + h_reference_ns = 0.0 + tot_flux_ew = 0.0 + tot_flux_ns = 0.0 + + do k=1,2 + if (flux_enter(i,j,k) > 0) then + n_flux = n_flux + 1 + h_reference_ew = h_reference_ew + flux_enter(i,j,k) * ISS%h_shelf(i+2*k-3,j) + !h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) + tot_flux_ew = tot_flux_ew + flux_enter(i,j,k) + flux_enter(i,j,k) = 0.0 + endif + enddo + + do k=1,2 + if (flux_enter(i,j,k+2) > 0) then + n_flux = n_flux + 1 + h_reference_ns = h_reference_ns + flux_enter(i,j,k+2) * ISS%h_shelf(i,j+2*k-3) + !h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) + tot_flux_ns = tot_flux_ns + flux_enter(i,j,k+2) + flux_enter(i,j,k+2) = 0.0 + endif + enddo + + h_reference = h_reference_ew + h_reference_ns + tot_flux = tot_flux_ew + tot_flux_ns + + if (n_flux > 0) then + dxdyh = G%areaT(i,j) + h_reference = h_reference / tot_flux + !h_reference = h_reference / real(n_flux) + partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux + + if ((partial_vol / G%areaT(i,j)) == h_reference) then ! cell is exactly covered, no overflow + if (ISS%hmask(i,j)/=3) ISS%hmask(i,j) = 1 + ISS%h_shelf(i,j) = h_reference + ISS%area_shelf_h(i,j) = G%areaT(i,j) + elseif ((partial_vol / G%areaT(i,j)) < h_reference) then + ISS%hmask(i,j) = 2 + ! ISS%mass_shelf(i,j) = partial_vol * CS%density_ice + ISS%area_shelf_h(i,j) = partial_vol / h_reference + ISS%h_shelf(i,j) = h_reference + else + + if (ISS%hmask(i,j)/=3) ISS%hmask(i,j) = 1 + ISS%area_shelf_h(i,j) = G%areaT(i,j) + !h_temp(i,j) = h_reference + partial_vol = partial_vol - h_reference * G%areaT(i,j) + + iter_flag = 1 + + n_flux = 0 ; new_partial(:) = 0 + + do k=1,2 + if (CS%u_face_mask(I-2+k,j) == 2) then + n_flux = n_flux + 1 + elseif (ISS%hmask(i+2*k-3,j) == 0) then + n_flux = n_flux + 1 + new_partial(k) = 1 + endif + if (CS%v_face_mask(i,J-2+k) == 2) then + n_flux = n_flux + 1 + elseif (ISS%hmask(i,j+2*k-3) == 0) then + n_flux = n_flux + 1 + new_partial(k+2) = 1 + endif + enddo + + if (n_flux == 0) then ! there is nowhere to put the extra ice! + ISS%h_shelf(i,j) = h_reference + partial_vol / G%areaT(i,j) + else + ISS%h_shelf(i,j) = h_reference + + do k=1,2 + if (new_partial(k) == 1) & + flux_enter_replace(i+2*k-3,j,3-k) = partial_vol / real(n_flux) + if (new_partial(k+2) == 1) & + flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux) + enddo + endif + + endif ! Parital_vol test. + endif ! n_flux gt 0 test. + + endif + enddo ! j-loop + endif + enddo + + ! call max_across_PEs(iter_flag) + + enddo ! End of do while(iter_flag) loop + + call max_across_PEs(iter_count) + + if (is_root_pe() .and. (iter_count > 1)) then + write(mesg,*) "shelf_advance_front: ", iter_count, " max iterations" + call MOM_mesg(mesg, 5) + endif + +end subroutine shelf_advance_front + +!> Apply a very simple calving law using a minimum thickness rule +subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickness_calve, halo) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h !< The area per cell covered by + !! the ice shelf [L2 ~> m2]. + 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, intent(in) :: thickness_calve !< The thickness at which to trigger calving [Z ~> m]. + integer, optional, intent(in) :: halo !< The number of halo points to use. If not present, + !! work on the entire data domain. + integer :: i, j, is, ie, js, je + + if (present(halo)) then + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + else + is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed + endif + + do j=js,je ; do i=is,ie +! if ((h_shelf(i,j) < CS%thickness_calve) .and. (hmask(i,j) == 1) .and. & +! (CS%ground_frac(i,j) == 0.0)) then + if ((h_shelf(i,j) < thickness_calve) .and. (area_shelf_h(i,j) > 0.)) then + h_shelf(i,j) = 0.0 + area_shelf_h(i,j) = 0.0 + hmask(i,j) = 0.0 + endif + enddo ; enddo + +end subroutine ice_shelf_min_thickness_calve + +subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h !< The area per cell covered by + !! the ice shelf [L2 ~> m2]. + 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(in) :: calve_mask !< A mask that indicates where the ice + !! shelf can exist, and where it will calve. + + integer :: i,j + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((calve_mask(i,j) == 0.0) .and. (hmask(i,j) /= 0.0)) then + h_shelf(i,j) = 0.0 + area_shelf_h(i,j) = 0.0 + hmask(i,j) = 0.0 + endif + enddo ; enddo + +end subroutine calve_to_mask + +!> Calculate driving stress using cell-centered bed elevation and ice thickness +subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: OD !< ocean floor depth at tracer points [Z ~> m]. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: taudx !< X-direction driving stress at q-points [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: taudy !< Y-direction driving stress at q-points [R L3 Z T-2 ~> kg m s-2] + + +! driving stress! + +! ! taudx and taudy will hold driving stress in the x- and y- directions when done. +! they will sit on the BGrid, and so their size depends on whether the grid is symmetric +! +! Since this is a finite element solve, they will actually have the form \int \Phi_i rho g h \nabla s +! +! OD -this is important and we do not yet know where (in MOM) it will come from. It represents +! "average" ocean depth -- and is needed to find surface elevation +! (it is assumed that base_ice = bed + OD) + + real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S ! surface elevation [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)) :: sx_e, sy_e !element contributions to driving stress + real :: rho, rhow, rhoi_rhow ! Ice and ocean densities [R ~> kg m-3] + real :: sx, sy ! Ice shelf top slopes [Z L-1 ~> nondim] + real :: neumann_val ! [R Z L2 T-2 ~> kg s-2] + real :: dxh, dyh,Dx,Dy ! Local grid spacing [L ~> m] + real :: grav ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, is, js, iegq, jegq + integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec + integer :: i_off, j_off + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec +! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed +! iegq = G%iegB ; jegq = G%jegB +! gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 + gisc = 1 ; gjsc = 1 +! giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo + giec = G%domain%niglobal ; gjec = G%domain%njglobal +! is = iscq - 1; js = jscq - 1 + i_off = G%idg_offset ; j_off = G%jdg_offset + + + rho = CS%density_ice + rhow = CS%density_ocean_avg + grav = CS%g_Earth + rhoi_rhow = rho/rhow + ! prelim - go through and calculate S + + if (CS%GL_couple) then + do j=jsc-G%domain%njhalo,jec+G%domain%njhalo + do i=isc-G%domain%nihalo,iec+G%domain%nihalo + S(i,j) = -CS%bed_elev(i,j) + (OD(i,j) + ISS%h_shelf(i,j)) + enddo + enddo + else + ! check whether the ice is floating or grounded + do j=jsc-G%domain%njhalo,jec+G%domain%njhalo + do i=isc-G%domain%nihalo,iec+G%domain%nihalo + if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) <= 0) then + S(i,j) = (1 - rhoi_rhow)*ISS%h_shelf(i,j) + else + S(i,j) = ISS%h_shelf(i,j)-CS%bed_elev(i,j) + endif + enddo + enddo + endif + + call pass_var(S, G%domain) + + sx_e(:,:)=0.0; sy_e(:,:)=0.0 + + do j=jsc-1,jec+1 + do i=isc-1,iec+1 + cnt = 0 + sx = 0 + sy = 0 + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + Dx=dxh + Dy=dyh + if (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 3) then + ! we are inside the global computational bdry, at an ice-filled cell + + ! calculate sx + if ((i+i_off) == gisc) then ! at west computational bdry + if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then + sx = (S(i+1,j)-S(i,j))/dxh + else + sx = 0 + endif + elseif ((i+i_off) == giec) then ! at east computational bdry + if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then + sx = (S(i,j)-S(i-1,j))/dxh + else + sx = 0 + endif + else ! interior + if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then + cnt = cnt+1 + Dx = dxh + G%dxT(i+1,j) + sx = S(i+1,j) + else + sx = S(i,j) + endif + if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then + cnt = cnt+1 + Dx = dxh + G%dxT(i-1,j) + sx = sx - S(i-1,j) + else + sx = sx - S(i,j) + endif + if (cnt == 0) then + sx = 0 + else + sx = sx / Dx + endif + endif + + cnt = 0 + + ! calculate sy, similarly + if ((j+j_off) == gjsc) then ! at south computational bdry + if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then + sy = (S(i,j+1)-S(i,j))/dyh + else + sy = 0 + endif + elseif ((j+j_off) == gjec) then ! at north computational bdry + if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then + sy = (S(i,j)-S(i,j-1))/dyh + else + sy = 0 + endif + else ! interior + if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then + cnt = cnt+1 + Dy = dyh + G%dyT(i,j+1) + sy = S(i,j+1) + else + sy = S(i,j) + endif + if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then + cnt = cnt+1 + Dy = dyh + G%dyT(i,j-1) + sy = sy - S(i,j-1) + else + sy = sy - S(i,j) + endif + if (cnt == 0) then + sy = 0 + else + sy = sy / Dy + endif + endif + + sx_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (ISS%h_shelf(i,j) * sx)) + sy_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (ISS%h_shelf(i,j) * sy)) + + !Stress (Neumann) boundary conditions + if (CS%ground_frac(i,j) == 1) then + neumann_val = ((.5 * grav) * (rho * ISS%h_shelf(i,j)**2 - rhow * CS%bed_elev(i,j)**2)) + else + neumann_val = (.5 * grav) * ((1-rho/rhow) * (rho * ISS%h_shelf(i,j)**2)) + endif + if ((CS%u_face_mask_bdry(I-1,j) == 2) .OR. & + ((ISS%hmask(i-1,j) == 0 .OR. ISS%hmask(i-1,j) == 2) .AND. (i+i_off /= gisc))) then + ! left face of the cell is at a stress boundary + ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated + ! pressure on either side of the face + ! on the ice side, it is rho g h^2 / 2 + ! on the ocean side, it is rhow g (delta OD)^2 / 2 + ! OD can be zero under the ice; but it is ASSUMED on the ice-free side of the face, topography elevation + ! is not above the base of the ice in the current cell + + ! Note the negative sign due to the direction of the normal vector + taudx(I-1,J-1) = taudx(I-1,J-1) - .5 * dyh * neumann_val + taudx(I-1,J) = taudx(I-1,J) - .5 * dyh * neumann_val + endif + + if ((CS%u_face_mask_bdry(I,j) == 2) .OR. & + ((ISS%hmask(i+1,j) == 0 .OR. ISS%hmask(i+1,j) == 2) .and. (i+i_off /= giec))) then + ! east face of the cell is at a stress boundary + taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val + taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val + endif + + if ((CS%v_face_mask_bdry(i,J-1) == 2) .OR. & + ((ISS%hmask(i,j-1) == 0 .OR. ISS%hmask(i,j-1) == 2) .and. (j+j_off /= gjsc))) then + ! south face of the cell is at a stress boundary + taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val + taudy(I,J-1) = taudy(I,J-1) - .5 * dxh * neumann_val + endif + + if ((CS%v_face_mask_bdry(i,J) == 2) .OR. & + ((ISS%hmask(i,j+1) == 0 .OR. ISS%hmask(i,j+1) == 2) .and. (j+j_off /= gjec))) then + ! north face of the cell is at a stress boundary + taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val + taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val + endif + endif + enddo + enddo + + do J=jsc-2,jec+1; do I=isc-2,iec+1 + taudx(I,J) = taudx(I,J) + ((sx_e(i,j)+sx_e(i+1,j+1)) + (sx_e(i+1,j)+sx_e(i,j+1))) + taudy(I,J) = taudy(I,J) + ((sy_e(i,j)+sy_e(i+1,j+1)) + (sy_e(i+1,j)+sy_e(i,j+1))) + enddo; enddo +end subroutine calc_shelf_driving_stress + +! Not used? Seems to be only set up to work for a specific test case with u_face_mask==3 +subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) + type(ice_shelf_dyn_CS),intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(time_type), intent(in) :: Time !< The current model time + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, intent(in) :: input_flux !< The integrated inward ice thickness flux per + !! unit face length [Z L T-1 ~> m2 s-1] + real, intent(in) :: input_thick !< The ice thickness at boundaries [Z ~> m]. + logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted + +! this will be a per-setup function. the boundary values of thickness and velocity +! (and possibly other variables) will be updated in this function + +! FOR RESTARTING PURPOSES: if grid is not symmetric and the model is restarted, we will +! need to update those velocity points not *technically* in any +! computational domain -- if this function gets moves to another module, +! DO NOT TAKE THE RESTARTING BIT WITH IT + integer :: i, j , isd, jsd, ied, jed + integer :: isc, jsc, iec, jec + integer :: i_off, j_off + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + i_off = G%idg_offset ; j_off = G%jdg_offset + + ! this loop results in some values being set twice but... eh. + + do j=jsd,jed + do i=isd,ied + + if (hmask(i,j) == 3) then + CS%h_bdry_val(i,j) = input_thick + endif + + if ((hmask(i,j) == 0) .or. (hmask(i,j) == 1) .or. (hmask(i,j) == 2)) then + if ((i <= iec).and.(i >= isc)) then + if (CS%u_face_mask(I-1,j) == 3) then + CS%u_bdry_val(I-1,J-1) = (1 - ((G%geoLatBu(I-1,J-1) - 0.5*G%len_lat)*2./G%len_lat)**2) * & + 1.5 * input_flux / input_thick + CS%u_bdry_val(I-1,J) = (1 - ((G%geoLatBu(I-1,J) - 0.5*G%len_lat)*2./G%len_lat)**2) * & + 1.5 * input_flux / input_thick + endif + endif + endif + + if (.not.(new_sim)) then + if (.not. G%symmetric) then + if (((i+i_off) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) + endif + if (((j+j_off) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,J-1) == 3)) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) + endif + endif + endif + enddo + enddo + +end subroutine init_boundary_values + + +subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & + ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio) + + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2]. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: vret !< The retarding stresses working at v-points [R L3 Z T-2 ~> kg m s-2]. + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & + intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations [nondim] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: umask !< A coded mask indicating the nature of the + !! zonal flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: vmask !< A coded mask indicating the nature of the + !! meridional flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), & + intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's + !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form + !! and units depend on the basal law exponent. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points + !! relative to sea-level [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. + + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + integer, intent(in) :: is !< The starting i-index to work on + integer, intent(in) :: ie !< The ending i-index to work on + integer, intent(in) :: js !< The starting j-index to work on + integer, intent(in) :: je !< The ending j-index to work on + +! the linear action of the matrix on (u,v) with bilinear finite elements +! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, +! but this may change pursuant to conversations with others +! +! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine +! in order to make less frequent halo updates + +! the linear action of the matrix on (u,v) with bilinear finite elements +! Phi has the form +! Phi(k,q,i,j) - applies to cell i,j + + ! 3 - 4 + ! | | + ! 1 - 2 + +! Phi(2*k-1,q,i,j) gives d(Phi_k)/dx at quadrature point q +! Phi(2*k,q,i,j) gives d(Phi_k)/dy at quadrature point q +! Phi_k is equal to 1 at vertex k, and 0 at vertex l /= k, and bilinear + + real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] + real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] + integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt, qp, qpv + logical :: visc_qp4 + real, dimension(2) :: xquad + real, dimension(2,2) :: Ucell, Vcell, Hcell, Usub, Vsub + real, dimension(2,2,4) :: uret_qp, vret_qp + real, dimension(SZDIB_(G),SZDJB_(G),4) :: uret_b, vret_b + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + + if (CS%visc_qps == 4) then + visc_qp4=.true. + else + visc_qp4=.false. + qpv = 1 + endif + + uret(:,:) = 0.0; vret(:,:)=0.0 + uret_b(:,:,:)=0.0 ; vret_b(:,:,:)=0.0 + + do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then + + uret_qp(:,:,:)=0.0; vret_qp(:,:,:)=0.0 + + do iq=1,2 ; do jq=1,2 + + qp = 2*(jq-1)+iq !current quad point + + uq = (u_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + u_shlf(I,J) * (xquad(iq) * xquad(jq))) + & + (u_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + u_shlf(I-1,J) * (xquad(3-iq) * xquad(jq))) + + vq = (v_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + v_shlf(I,J) * (xquad(iq) * xquad(jq))) + & + (v_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + v_shlf(I-1,J) * (xquad(3-iq) * xquad(jq))) + + ux = (u_shlf(I-1,J-1) * Phi(1,qp,i,j) + & + u_shlf(I,J) * Phi(7,qp,i,j)) + & + (u_shlf(I,J-1) * Phi(3,qp,i,j) + & + u_shlf(I-1,J) * Phi(5,qp,i,j)) + + vx = (v_shlf(I-1,J-1) * Phi(1,qp,i,j) + & + v_shlf(I,J) * Phi(7,qp,i,j)) + & + (v_shlf(I,J-1) * Phi(3,qp,i,j) + & + v_shlf(I-1,J) * Phi(5,qp,i,j)) + + uy = (u_shlf(I-1,J-1) * Phi(2,qp,i,j) + & + u_shlf(I,J) * Phi(8,qp,i,j)) + & + (u_shlf(I,J-1) * Phi(4,qp,i,j) + & + u_shlf(I-1,J) * Phi(6,qp,i,j)) + + vy = (v_shlf(I-1,J-1) * Phi(2,qp,i,j) + & + v_shlf(I,J) * Phi(8,qp,i,j)) + & + (v_shlf(I,J-1) * Phi(4,qp,i,j) + & + v_shlf(I-1,J) * Phi(6,qp,i,j)) + + if (visc_qp4) qpv = qp !current quad point for viscosity + + do jphi=1,2 ; Jtgt = J-2+jphi ; do iphi=1,2 ; Itgt = I-2+iphi + if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = ice_visc(i,j,qpv) * & + ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = ice_visc(i,j,qpv) * & + ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + + if (float_cond(i,j) == 0) then + ilq = 1 ; if (iq == iphi) ilq = 2 + jlq = 1 ; if (jq == jphi) jlq = 2 + if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + & + (basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq)) + if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + & + (basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq)) + endif + enddo ; enddo + enddo ; enddo + + !element contribution to SW node (node 1, which sees the current element as element 4) + uret_b(I-1,J-1,4) = 0.25*((uret_qp(1,1,1)+uret_qp(1,1,4))+(uret_qp(1,1,2)+uret_qp(1,1,3))) + vret_b(I-1,J-1,4) = 0.25*((vret_qp(1,1,1)+vret_qp(1,1,4))+(vret_qp(1,1,2)+vret_qp(1,1,3))) + + !element contribution to NW node (node 3, which sees the current element as element 2) + uret_b(I-1,J ,2) = 0.25*((uret_qp(1,2,1)+uret_qp(1,2,4))+(uret_qp(1,2,2)+uret_qp(1,2,3))) + vret_b(I-1,J ,2) = 0.25*((vret_qp(1,2,1)+vret_qp(1,2,4))+(vret_qp(1,2,2)+vret_qp(1,2,3))) + + !element contribution to SE node (node 2, which sees the current element as element 3) + uret_b(I ,J-1,3) = 0.25*((uret_qp(2,1,1)+uret_qp(2,1,4))+(uret_qp(2,1,2)+uret_qp(2,1,3))) + vret_b(I ,J-1,3) = 0.25*((vret_qp(2,1,1)+vret_qp(2,1,4))+(vret_qp(2,1,2)+vret_qp(2,1,3))) + + !element contribution to NE node (node 4, which sees the current element as element 1) + uret_b(I ,J ,1) = 0.25*((uret_qp(2,2,1)+uret_qp(2,2,4))+(uret_qp(2,2,2)+uret_qp(2,2,3))) + vret_b(I ,J ,1) = 0.25*((vret_qp(2,2,1)+vret_qp(2,2,4))+(vret_qp(2,2,2)+vret_qp(2,2,3))) + + if (float_cond(i,j) == 1) then + Ucell(:,:) = u_shlf(I-1:I,J-1:J) ; Vcell(:,:) = v_shlf(I-1:I,J-1:J) + Hcell(:,:) = H_node(I-1:I,J-1:J) + + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, & + bathyT(i,j), dens_ratio, Usub, Vsub) + + if (umask(I-1,J-1) == 1) uret_b(I-1,J-1,4) = uret_b(I-1,J-1,4) + (Usub(1,1) * basal_trac(i,j)) + if (umask(I-1,J ) == 1) uret_b(I-1,J ,2) = uret_b(I-1,J ,2) + (Usub(1,2) * basal_trac(i,j)) + if (umask(I ,J-1) == 1) uret_b(I ,J-1,3) = uret_b(I ,J-1,3) + (Usub(2,1) * basal_trac(i,j)) + if (umask(I ,J ) == 1) uret_b(I ,J ,1) = uret_b(I ,J ,1) + (Usub(2,2) * basal_trac(i,j)) + + if (vmask(I-1,J-1) == 1) vret_b(I-1,J-1,4) = vret_b(I-1,J-1,4) + (Vsub(1,1) * basal_trac(i,j)) + if (vmask(I-1,J ) == 1) vret_b(I-1,J ,2) = vret_b(I-1,J ,2) + (Vsub(1,2) * basal_trac(i,j)) + if (vmask(I ,J-1) == 1) vret_b(I ,J-1,3) = vret_b(I ,J-1,3) + (Vsub(2,1) * basal_trac(i,j)) + if (vmask(I ,J ) == 1) vret_b(I ,J ,1) = vret_b(I ,J ,1) + (Vsub(2,2) * basal_trac(i,j)) + endif + endif ; enddo ; enddo + + do J=js-1,je ; do I=is-1,ie + uret(I,J) = (uret_b(I,J,1)+uret_b(I,J,4)) + (uret_b(I,J,2)+uret_b(I,J,3)) + vret(I,J) = (vret_b(I,J,1)+vret_b(I,J,4)) + (vret_b(I,J,2)+vret_b(I,J,3)) + enddo; enddo + +end subroutine CG_action + +subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, Vcontr) + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations [nondim] + real, dimension(2,2), intent(in) :: H !< The ice shelf thickness at nodal (corner) points [Z ~> m]. + real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] + real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] + real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points + !! relative to sea-level [Z ~> m]. + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater [nondim] + real, dimension(2,2), intent(out) :: Ucontr !< The areal average of u-velocities where the ice shelf + !! is grounded, or 0 where it is floating [L T-1 ~> m s-1]. + real, dimension(2,2), intent(out) :: Vcontr !< The areal average of v-velocities where the ice shelf + !! is grounded, or 0 where it is floating [L T-1 ~> m s-1]. + + real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: Ucontr_sub, Vcontr_sub ! The contributions to Ucontr and Vcontr + !! at each sub-cell + real, dimension(2,2,SIZE(Phisub,3),SIZE(Phisub,3)) :: uloc_arr !The local sub-cell u-velocity [L T-1 ~> m s-1] + real, dimension(2,2,SIZE(Phisub,3),SIZE(Phisub,3)) :: vloc_arr !The local sub-cell v-velocity [L T-1 ~> m s-1] + real, dimension(2,2) :: Ucontr_q, Vcontr_q !Contributions to a node from each quadrature point in a sub-grid cell + real :: subarea ! The fractional sub-cell area [nondim] + real :: hloc ! The local sub-cell ice thickness [Z ~> m] + integer :: nsub, i, j, qx, qy, m, n + + nsub = size(Phisub,3) + subarea = 1.0 / (nsub**2) + + uloc_arr(:,:,:,:) = 0.0; vloc_arr(:,:,:,:)=0.0 + + do j=1,nsub ; do i=1,nsub; do qy=1,2 ; do qx=1,2 + hloc = (Phisub(qx,qy,i,j,1,1)*H(1,1) + Phisub(qx,qy,i,j,2,2)*H(2,2)) + & + (Phisub(qx,qy,i,j,1,2)*H(1,2) + Phisub(qx,qy,i,j,2,1)*H(2,1)) + if (dens_ratio * hloc - bathyT > 0) then + uloc_arr(qx,qy,i,j) = ((Phisub(qx,qy,i,j,1,1) * U(1,1) + Phisub(qx,qy,i,j,2,2) * U(2,2)) + & + (Phisub(qx,qy,i,j,1,2) * U(1,2) + Phisub(qx,qy,i,j,2,1) * U(2,1))) + vloc_arr(qx,qy,i,j) = ((Phisub(qx,qy,i,j,1,1) * V(1,1) + Phisub(qx,qy,i,j,2,2) * V(2,2)) + & + (Phisub(qx,qy,i,j,1,2) * V(1,2) + Phisub(qx,qy,i,j,2,1) * V(2,1))) + endif + enddo; enddo ; enddo ; enddo + + do n=1,2 ; do m=1,2 ; do j=1,nsub ; do i=1,nsub + do qy=1,2 ; do qx=1,2 + !calculate quadrature point contributions for the sub-cell, to each node + Ucontr_q(qx,qy) = Phisub(qx,qy,i,j,m,n) * uloc_arr(qx,qy,i,j) + Vcontr_q(qx,qy) = Phisub(qx,qy,i,j,m,n) * vloc_arr(qx,qy,i,j) + enddo; enddo + + !calculate sub-cell contribution to each node by summing up quadrature point contributions from the sub-cell + Ucontr_sub(i,j,m,n) = (subarea * 0.25) * ((Ucontr_q(1,1) + Ucontr_q(2,2)) + (Ucontr_q(1,2)+Ucontr_q(2,1))) + Vcontr_sub(i,j,m,n) = (subarea * 0.25) * ((Vcontr_q(1,1) + Vcontr_q(2,2)) + (Vcontr_q(1,2)+Vcontr_q(2,1))) + enddo; enddo ; enddo ; enddo + + !sum up the sub-cell contributions to each node + do n=1,2 ; do m=1,2 + call sum_square_matrix(Ucontr(m,n),Ucontr_sub(:,:,m,n),nsub) + call sum_square_matrix(Vcontr(m,n),Vcontr_sub(:,:,m,n),nsub) + enddo ; enddo + +end subroutine CG_action_subgrid_basal + + +!! Returns the sum of the elements in a square matrix. This sum is bitwise identical even if the matrices are rotated. +subroutine sum_square_matrix(sum_out, mat_in, n) + integer, intent(in) :: n !< The length and width of each matrix in mat_in + real, dimension(n,n), intent(in) :: mat_in !< The n x n matrix whose elements will be summed + real, intent(out) :: sum_out !< The sum of the elements of matrix mat_in + integer :: s0,e0,s1,e1 + + sum_out=0.0 + + s0=1; e0=n + + !start by summing elements on outer edges of matrix + do while (s0 returns the diagonal entries of the matrix for a Jacobi preconditioning +subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, hmask, dens_ratio, & + Phi, Phisub, u_diagonal, v_diagonal) + + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< If GL_regularize=true, indicates cells containing + !! the grounding line (float_cond=1) or not (float_cond=0) + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal + !! (corner) points [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), & + intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's + !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form + !! and units depend on the basal law exponent. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. + + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater [nondim] + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & + intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell vertices [L-1 ~> m-1] + real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations [nondim] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_diagonal !< The diagonal elements of the u-velocity + !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_diagonal !< The diagonal elements of the v-velocity + !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] + + +! returns the diagonal entries of the matrix for a Jacobi preconditioning + + real :: ux, uy, vx, vy ! Interpolated weight gradients [L-1 ~> m-1] + real :: uq, vq + real, dimension(2) :: xquad + real, dimension(2,2) :: Hcell, sub_ground + real, dimension(2,2,4) :: u_diag_qp, v_diag_qp + real, dimension(SZDIB_(G),SZDJB_(G),4) :: u_diag_b, v_diag_b + logical :: visc_qp4 + integer :: i, j, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt, qp, qpv + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + + if (CS%visc_qps == 4) then + visc_qp4=.true. + else + visc_qp4=.false. + qpv = 1 + endif + + u_diag_b(:,:,:)=0.0 + v_diag_b(:,:,:)=0.0 + + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then + + ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j + + u_diag_qp(:,:,:)=0.0; v_diag_qp(:,:,:)=0.0 + + do iq=1,2 ; do jq=1,2 + + qp = 2*(jq-1)+iq !current quad point + if (visc_qp4) qpv = qp !current quad point for viscosity + + do jphi=1,2 ; Jtgt = J-2+jphi ; do iphi=1,2 ; Itgt = I-2+iphi + + ilq = 1 ; if (iq == iphi) ilq = 2 + jlq = 1 ; if (jq == jphi) jlq = 2 + + if (CS%umask(Itgt,Jtgt) == 1) then + + ux = Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + uy = Phi(2*(2*(jphi-1)+iphi),qp,i,j) + vx = 0. + vy = 0. + + u_diag_qp(iphi,jphi,qp) = & + ice_visc(i,j,qpv) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + + if (float_cond(i,j) == 0) then + uq = xquad(ilq) * xquad(jlq) + u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + & + (basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq)) + endif + endif + + if (CS%vmask(Itgt,Jtgt) == 1) then + + vx = Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + vy = Phi(2*(2*(jphi-1)+iphi),qp,i,j) + ux = 0. + uy = 0. + + v_diag_qp(iphi,jphi,qp) = & + ice_visc(i,j,qpv) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + + if (float_cond(i,j) == 0) then + vq = xquad(ilq) * xquad(jlq) + v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + & + (basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq)) + endif + endif + enddo ; enddo + enddo ; enddo + + !element contribution to SW node (node 1, which sees the current element as element 4) + u_diag_b(I-1,J-1,4) = 0.25*((u_diag_qp(1,1,1)+u_diag_qp(1,1,4))+(u_diag_qp(1,1,2)+u_diag_qp(1,1,3))) + v_diag_b(I-1,J-1,4) = 0.25*((v_diag_qp(1,1,1)+v_diag_qp(1,1,4))+(v_diag_qp(1,1,2)+v_diag_qp(1,1,3))) + + !element contribution to NW node (node 3, which sees the current element as element 2) + u_diag_b(I-1,J ,2) = 0.25*((u_diag_qp(1,2,1)+u_diag_qp(1,2,4))+(u_diag_qp(1,2,2)+u_diag_qp(1,2,3))) + v_diag_b(I-1,J ,2) = 0.25*((v_diag_qp(1,2,1)+v_diag_qp(1,2,4))+(v_diag_qp(1,2,2)+v_diag_qp(1,2,3))) + + !element contribution to SE node (node 2, which sees the current element as element 3) + u_diag_b(I ,J-1,3) = 0.25*((u_diag_qp(2,1,1)+u_diag_qp(2,1,4))+(u_diag_qp(2,1,2)+u_diag_qp(2,1,3))) + v_diag_b(I ,J-1,3) = 0.25*((v_diag_qp(2,1,1)+v_diag_qp(2,1,4))+(v_diag_qp(2,1,2)+v_diag_qp(2,1,3))) + + !element contribution to NE node (node 4, which sees the current element as element 1) + u_diag_b(I ,J ,1) = 0.25*((u_diag_qp(2,2,1)+u_diag_qp(2,2,4))+(u_diag_qp(2,2,2)+u_diag_qp(2,2,3))) + v_diag_b(I ,J ,1) = 0.25*((v_diag_qp(2,2,1)+v_diag_qp(2,2,4))+(v_diag_qp(2,2,2)+v_diag_qp(2,2,3))) + + if (float_cond(i,j) == 1) then + Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_diagonal_subgrid_basal(Phisub, Hcell, CS%bed_elev(i,j), dens_ratio, sub_ground) + + if (CS%umask(I-1,J-1) == 1) u_diag_b(I-1,J-1,4) = u_diag_b(I-1,J-1,4) + sub_ground(1,1) * basal_trac(i,j) + if (CS%umask(I-1,J ) == 1) u_diag_b(I-1,J ,2) = u_diag_b(I-1,J ,2) + sub_ground(1,2) * basal_trac(i,j) + if (CS%umask(I ,J-1) == 1) u_diag_b(I ,J-1,3) = u_diag_b(I ,J-1,3) + sub_ground(2,1) * basal_trac(i,j) + if (CS%umask(I ,J ) == 1) u_diag_b(I ,J ,1) = u_diag_b(I ,J ,1) + sub_ground(2,2) * basal_trac(i,j) + + if (CS%vmask(I-1,J-1) == 1) v_diag_b(I-1,J-1,4) = v_diag_b(I-1,J-1,4) + sub_ground(1,1) * basal_trac(i,j) + if (CS%vmask(I-1,J ) == 1) v_diag_b(I-1,J ,2) = v_diag_b(I-1,J ,2) + sub_ground(1,2) * basal_trac(i,j) + if (CS%vmask(I ,J-1) == 1) v_diag_b(I ,J-1,3) = v_diag_b(I ,J-1,3) + sub_ground(2,1) * basal_trac(i,j) + if (CS%vmask(I ,J ) == 1) v_diag_b(I ,J ,1) = v_diag_b(I ,J ,1) + sub_ground(2,2) * basal_trac(i,j) + endif + endif ; enddo ; enddo + + do J=jsc-2,jec+1 ; do I=isc-2,iec+1 + u_diagonal(I,J) = (u_diag_b(I,J,1)+u_diag_b(I,J,4)) + (u_diag_b(I,J,2)+u_diag_b(I,J,3)) + v_diagonal(I,J) = (v_diag_b(I,J,1)+v_diag_b(I,J,4)) + (v_diag_b(I,J,2)+v_diag_b(I,J,3)) + enddo ; enddo + +end subroutine matrix_diagonal + +subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, f_grnd) + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations [nondim] + real, dimension(2,2), intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points [Z ~> m]. + real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater [nondim] + real, dimension(2,2), intent(out) :: f_grnd !< The weighted fraction of the sub-cell where the ice shelf + !! is grounded [nondim] + + real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: f_grnd_sub ! The contributions to nodal f_grnd + !! from each sub-cell + integer, dimension(2,2,SIZE(Phisub,3),SIZE(Phisub,3)) :: grnd_stat !0 at floating quad points, 1 at grounded + real, dimension(2,2) :: f_grnd_q !Contributions to a node from each quadrature point in a sub-grid cell + real :: subarea ! The fractional sub-cell area [nondim] + real :: hloc ! The local sub-region thickness [Z ~> m] + integer :: nsub, i, j, qx, qy, m, n + + nsub = size(Phisub,3) + subarea = 1.0 / (nsub**2) + + grnd_stat(:,:,:,:)=0 + + do j=1,nsub ; do i=1,nsub; do qy=1,2 ; do qx=1,2 + hloc = (Phisub(qx,qy,i,j,1,1)*H_node(1,1) + Phisub(qx,qy,i,j,2,2)*H_node(2,2)) + & + (Phisub(qx,qy,i,j,1,2)*H_node(1,2) + Phisub(qx,qy,i,j,2,1)*H_node(2,1)) + if (dens_ratio * hloc - bathyT > 0) grnd_stat(qx,qy,i,j) = 1 + enddo; enddo ; enddo ; enddo + + do n=1,2 ; do m=1,2 ; do j=1,nsub ; do i=1,nsub + do qy=1,2 ; do qx = 1,2 + f_grnd_q(qx,qy) = grnd_stat(qx,qy,i,j) * Phisub(qx,qy,i,j,m,n)**2 + enddo ; enddo + !calculate sub-cell contribution to each node by summing up quadrature point contributions from the sub-cell + f_grnd_sub(i,j,m,n) = (subarea * 0.25) * ((f_grnd_q(1,1) + f_grnd_q(2,2)) + (f_grnd_q(1,2)+f_grnd_q(2,1))) + enddo ; enddo ; enddo ; enddo + + !sum up the sub-cell contributions to each node + do n=1,2 ; do m=1,2 + call sum_square_matrix(f_grnd(m,n),f_grnd_sub(:,:,m,n),nsub) + enddo ; enddo + +end subroutine CG_diagonal_subgrid_basal + + +!> Update depth integrated viscosity, based on horizontal strain rates +subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + +! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve + + +! this may be subject to change later... to make it "hybrid" +! real, dimension(SZDIB_(G),SZDJB_(G)) :: eII, ux, uy, vx, vy + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, iq, jq + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js, i_off, j_off + real :: Visc_coef, n_g + real :: ux, uy, vx, vy + real :: eps_min ! Velocity shears [T-1 ~> s-1] + logical :: model_qp1, model_qp4 + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + iegq = G%iegB ; jegq = G%jegB + gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 + giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc + is = iscq - 1; js = jscq - 1 + i_off = G%idg_offset ; j_off = G%jdg_offset + + if (trim(CS%ice_viscosity_compute) == "MODEL") then + if (CS%visc_qps==1) then + model_qp1=.true. + model_qp4=.false. + else + model_qp1=.false. + model_qp4=.true. + endif + endif + + n_g = CS%n_glen; eps_min = CS%eps_glen_min + + do j=jsc,jec ; do i=isc,iec + + if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then + + if (trim(CS%ice_viscosity_compute) == "CONSTANT") then + CS%ice_visc(i,j,1) = 1e15 * (US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T) * (G%areaT(i,j) * ISS%h_shelf(i,j)) + ! constant viscocity for debugging + elseif (trim(CS%ice_viscosity_compute) == "OBS") then + if (CS%AGlen_visc(i,j) >0) CS%ice_visc(i,j,1) = CS%AGlen_visc(i,j) * (G%areaT(i,j) * ISS%h_shelf(i,j)) + ! Here CS%Aglen_visc(i,j) is the ice viscosity [Pa s ~> R L2 T-1] computed from obs and read from a file + elseif (model_qp1) then + !calculate viscosity at 1 cell-centered quadrature point per cell + + Visc_coef = (CS%AGlen_visc(i,j))**(-1./n_g) + ! Units of Aglen_visc [Pa-(n_g) s-1] + + ux = (u_shlf(I-1,J-1) * CS%PhiC(1,i,j) + & + u_shlf(I,J) * CS%PhiC(7,i,j)) + & + (u_shlf(I-1,J) * CS%PhiC(5,i,j) + & + u_shlf(I,J-1) * CS%PhiC(3,i,j)) + + vx = (v_shlf(I-1,J-1) * CS%PhiC(1,i,j) + & + v_shlf(I,J) * CS%PhiC(7,i,j)) + & + (v_shlf(I-1,J) * CS%PhiC(5,i,j) + & + v_shlf(I,J-1) * CS%PhiC(3,i,j)) + + uy = (u_shlf(I-1,J-1) * CS%PhiC(2,i,j) + & + u_shlf(I,J) * CS%PhiC(8,i,j)) + & + (u_shlf(I-1,J) * CS%PhiC(6,i,j) + & + u_shlf(I,J-1) * CS%PhiC(4,i,j)) + + vy = (v_shlf(I-1,J-1) * CS%PhiC(2,i,j) + & + v_shlf(I,J) * CS%PhiC(8,i,j)) + & + (v_shlf(I-1,J) * CS%PhiC(6,i,j) + & + v_shlf(I,J-1) * CS%PhiC(4,i,j)) + + CS%ice_visc(i,j,1) = 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)) * & + (US%Pa_to_RL2_T2*US%s_to_T) + elseif (model_qp4) then + !calculate viscosity at 4 quadrature points per cell + + Visc_coef = (CS%AGlen_visc(i,j))**(-1./n_g) + + do iq=1,2 ; do jq=1,2 + + ux = (u_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j) + & + u_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j)) + & + (u_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j) + & + u_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j)) + + vx = (v_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j) + & + v_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j)) + & + (v_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j) + & + v_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j)) + + uy = (u_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j) + & + u_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j)) + & + (u_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j) + & + u_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j)) + + vy = (v_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j) + & + v_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j)) + & + (v_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j) + & + v_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j)) + + CS%ice_visc(i,j,2*(jq-1)+iq) = 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)) * & + (US%Pa_to_RL2_T2*US%s_to_T) + enddo; enddo + endif + endif + enddo ; enddo + +end subroutine calc_shelf_visc + + +!> Update basal shear +subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + +! also this subroutine updates the nonlinear part of the basal traction + +! this may be subject to change later... to make it "hybrid" + + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js + real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] + real :: alpha !Coulomb coefficient [nondim] + real :: Hf !"floatation thickness" for Coulomb friction [Z ~> m] + real :: fN !Effective pressure (ice pressure - ocean pressure) for Coulomb friction [Pa] + real :: fB !for Coulomb Friction [(T L-1)^CS%CF_PostPeak ~> (s m-1)^CS%CF_PostPeak] + real :: fN_scale !To convert effective pressure to mks units during Coulomb friction [Pa T2 R-1 L-2 ~> 1] + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + iegq = G%iegB ; jegq = G%jegB + gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 + giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc + is = iscq - 1; js = jscq - 1 + + eps_min = CS%eps_glen_min + + if (CS%CoulombFriction) then + if (CS%CF_PostPeak/=1.0) THEN + alpha = (CS%CF_PostPeak-1.0)**(CS%CF_PostPeak-1.0) / CS%CF_PostPeak**CS%CF_PostPeak ![nondim] + else + alpha = 1.0 + endif + fN_scale = US%R_to_kg_m3 * US%L_T_to_m_s**2 + endif + + do j=jsd+1,jed + do i=isd+1,ied + if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then + umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 + vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 + unorm = US%L_T_to_m_s * sqrt( (umid**2 + vmid**2) + (eps_min**2 * (G%dxT(i,j)**2 + G%dyT(i,j)**2)) ) + + !Coulomb friction (Schoof 2005, Gagliardini et al 2007) + if (CS%CoulombFriction) then + !Effective pressure + Hf = max((CS%density_ocean_avg/CS%density_ice) * CS%bed_elev(i,j), 0.0) + fN = max(fN_scale*((CS%density_ice * CS%g_Earth) * (ISS%h_shelf(i,j) - Hf)),CS%CF_MinN) + fB = alpha * (CS%C_basal_friction(i,j) / (CS%CF_Max * fN))**(CS%CF_PostPeak/CS%n_basal_fric) + + CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * & + (unorm**(CS%n_basal_fric-1.0) / (1.0 + fB * unorm**CS%CF_PostPeak)**(CS%n_basal_fric))) * & + (US%Pa_to_RLZ_T2*US%L_T_to_m_s) + else + !linear (CS%n_basal_fric=1) or "Weertman"/power-law (CS%n_basal_fric /= 1) + CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * (unorm**(CS%n_basal_fric-1))) * & + (US%Pa_to_RLZ_T2*US%L_T_to_m_s) + endif + endif + enddo + enddo + +end subroutine calc_shelf_taub + +subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: ocean_mass !< The mass per unit area of the ocean [R Z ~> kg m-2]. + logical, intent(in) :: find_avg !< If true, find the average of OD and ffrac, and + !! reset the underlying running sums to 0. + + integer :: isc, iec, jsc, jec, i, j + real :: I_rho_ocean ! A typical specific volume of the ocean [R-1 ~> m3 kg-1] + real :: I_counter + + I_rho_ocean = 1.0 / CS%density_ocean_avg + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + do j=jsc,jec ; do i=isc,iec + CS%OD_rt(i,j) = CS%OD_rt(i,j) + ocean_mass(i,j)*I_rho_ocean + if (ocean_mass(i,j)*I_rho_ocean > CS%thresh_float_col_depth) then + CS%ground_frac_rt(i,j) = CS%ground_frac_rt(i,j) + 1.0 + endif + enddo ; enddo + CS%OD_rt_counter = CS%OD_rt_counter + 1 + + if (find_avg) then + I_counter = 1.0 / real(CS%OD_rt_counter) + do j=jsc,jec ; do i=isc,iec + CS%ground_frac(i,j) = 1.0 - (CS%ground_frac_rt(i,j) * I_counter) + CS%OD_av(i,j) = CS%OD_rt(i,j) * I_counter + + CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0; CS%OD_rt_counter = 0 + enddo ; enddo + + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%OD_av, G%domain, complete=.true.) + endif + +end subroutine update_OD_ffrac + +subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< the thickness of the ice shelf [Z ~> m]. + + integer :: i, j, isd, ied, jsd, jed + real :: rhoi_rhow, OD + + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + do j=jsd,jed + do i=isd,ied + OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf(i,j) + if (OD >= 0) then + ! ice thickness does not take up whole ocean column -> floating + CS%OD_av(i,j) = OD + CS%ground_frac(i,j) = 0. + else + CS%OD_av(i,j) = 0. + CS%ground_frac(i,j) = 1. + endif + enddo + enddo + +end subroutine update_OD_ffrac_uncoupled + +subroutine change_in_draft(CS, G, h_shelf0, h_shelf1, ddraft) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf0 !< the previous thickness of the ice shelf [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf1 !< the current thickness of the ice shelf [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: ddraft !< the change in shelf draft thickness + real :: b0,b1 + integer :: i, j, isc, iec, jsc, jec + real :: rhoi_rhow, OD + + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + ddraft = 0.0 + + do j=jsc,jec + do i=isc,iec + + b0=0.0; b1=0.0 + + if (h_shelf0(i,j)>0.0) then + OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf0(i,j) + if (OD >= 0) then + !floating + b0 = rhoi_rhow * h_shelf0(i,j) + else + b0 = CS%bed_elev(i,j) + endif + endif + + if (h_shelf1(i,j)>0.0) then + OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf1(i,j) + if (OD >= 0) then + !floating + b1 = rhoi_rhow * h_shelf1(i,j) + else + b1 = CS%bed_elev(i,j) + endif + endif + + ddraft(i,j) = b1-b0 + enddo + enddo +end subroutine change_in_draft + +!> This subroutine calculates the gradients of bilinear basis elements that +!! that are centered at the vertices of the cell. Values are calculated at +!! points of gaussian quadrature. +subroutine bilinear_shape_functions (X, Y, Phi, area) + real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral [L ~> m]. + real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral [L ~> m]. + real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + real, intent(out) :: area !< The quadrilateral cell area [L2 ~> m2]. + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + +! this subroutine calculates the gradients of bilinear basis elements that +! that are centered at the vertices of the cell. values are calculated at +! points of gaussian quadrature. (in 1D: .5 * (1 +/- sqrt(1/3)) for [0,1]) +! (ordered in same way as vertices) +! +! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j +! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear +! +! This should be a one-off; once per nonlinear solve? once per lifetime? +! ... will all cells have the same shape and dimension? + + real, dimension(4) :: xquad, yquad ! [nondim] + real :: a,b,c,d ! Various lengths [L ~> m] + real :: xexp, yexp ! [nondim] + integer :: node, qpoint, xnode, ynode + + xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) + xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) + + do qpoint=1,4 + + a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) + b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) + c = -X(1)*(1-xquad(qpoint)) - X(2)*xquad(qpoint) + X(3)*(1-xquad(qpoint)) + X(4)*xquad(qpoint) ! d(x)/d(y*) + d = -Y(1)*(1-xquad(qpoint)) - Y(2)*xquad(qpoint) + Y(3)*(1-xquad(qpoint)) + Y(4)*xquad(qpoint) ! d(y)/d(y*) + + do node=1,4 + + xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) + + if (ynode == 1) then + yexp = 1-yquad(qpoint) + else + yexp = yquad(qpoint) + endif + + if (1 == xnode) then + xexp = 1-xquad(qpoint) + else + xexp = xquad(qpoint) + endif + + Phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c) + Phi(2*node,qpoint) = (-c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c) + + enddo + enddo + + area = quad_area(X, Y) + +end subroutine bilinear_shape_functions + +!> This subroutine calculates the gradients of bilinear basis elements that are centered at the +!! vertices of the cell using a locally orthogoal MOM6 grid. Values are calculated at +!! points of gaussian quadrature. +subroutine bilinear_shape_fn_grid(G, i, j, Phi) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + integer, intent(in) :: i !< The i-index in the grid to work on. + integer, intent(in) :: j !< The j-index in the grid to work on. + real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + +! This subroutine calculates the gradients of bilinear basis elements that +! that are centered at the vertices of the cell. The values are calculated at +! points of gaussian quadrature. (in 1D: .5 * (1 +/- sqrt(1/3)) for [0,1]) +! (ordered in same way as vertices) +! +! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j +! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear +! +! This should be a one-off; once per nonlinear solve? once per lifetime? + + real, dimension(4) :: xquad, yquad ! [nondim] + real :: a, d ! Interpolated grid spacings [L ~> m] + real :: xexp, yexp ! [nondim] + integer :: node, qpoint, xnode, ynode + + xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) + 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 + 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 + d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) + else + d = G%dyCu(I,j) !* xquad(qpoint) + 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*) + + do node=1,4 + xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) + + if (ynode == 1) then + yexp = 1-yquad(qpoint) + else + yexp = yquad(qpoint) + endif + + if (1 == xnode) then + xexp = 1-xquad(qpoint) + else + xexp = xquad(qpoint) + endif + + Phi(2*node-1,qpoint) = ( (d * (2 * xnode - 3)) * yexp ) / (a*d) + Phi(2*node,qpoint) = ( (a * (2 * ynode - 3)) * xexp ) / (a*d) + + enddo + enddo + +end subroutine bilinear_shape_fn_grid + +!> This subroutine calculates the gradients of bilinear basis elements that are centered at the +!! vertices of the cell using a locally orthogoal MOM6 grid. Values are calculated at +!! a sinlge cell-centered quadrature point, which should match the grid cell h-point +subroutine bilinear_shape_fn_grid_1qp(G, i, j, Phi) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + integer, intent(in) :: i !< The i-index in the grid to work on. + integer, intent(in) :: j !< The j-index in the grid to work on. + real, dimension(8), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + +! This subroutine calculates the gradients of bilinear basis elements that +! that are centered at the vertices of the cell. The values are calculated at +! a cell-cented point of gaussian quadrature. (in 1D: .5 for [0,1]) +! (ordered in same way as vertices) +! +! Phi(2*i-1) gives d(Phi_i)/dx at the quadrature point +! Phi(2*i) gives d(Phi_i)/dy at the quadrature point +! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear + + real :: a, d ! Interpolated grid spacings [L ~> m] + real :: xexp=0.5, yexp=0.5 ! [nondim] + integer :: node, qpoint, xnode, ynode + + ! d(x)/d(x*) + if (J>1) then + a = 0.5 * (G%dxCv(i,J-1) + G%dxCv(i,J)) + else + a = G%dxCv(i,J) + endif + + ! d(y)/d(y*) + if (I>1) then + d = 0.5 * (G%dyCu(I-1,j) + G%dyCu(I,j)) + else + d = G%dyCu(I,j) + endif + + do node=1,4 + xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) + Phi(2*node-1) = ( (d * (2 * xnode - 3)) * yexp ) / (a*d) + Phi(2*node) = ( (a * (2 * ynode - 3)) * xexp ) / (a*d) + enddo +end subroutine bilinear_shape_fn_grid_1qp + + +subroutine bilinear_shape_functions_subgrid(Phisub, nsub) + integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction + real, dimension(2,2,nsub,nsub,2,2), & + intent(inout) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations [nondim] + + ! this subroutine is a helper for interpolation of floatation condition + ! for the purposes of evaluating the terms \int (u,v) \phi_i dx dy in a cell that is + ! in partial floatation + ! the array Phisub contains the values of \phi_i (where i is a node of the cell) + ! at quad point j + ! i think this general approach may not work for nonrectangular elements... + ! + + ! Phisub(q1,q2,i,j,k,l) + ! q1: quad point x-index + ! q2: quad point y-index + ! i: subgrid index in x-direction + ! j: subgrid index in y-direction + ! k: basis function x-index + ! l: basis function y-index + + ! e.g. k=1,l=1 => node 1 + ! q1=2,q2=1 => quad point 2 + + ! 3 - 4 + ! | | + ! 1 - 2 + + integer :: i, j, qx, qy + real,dimension(2) :: xquad + real :: x0, y0, x, y, fracx + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + fracx = 1.0/real(nsub) + + do j=1,nsub ; do i=1,nsub + x0 = (i-1) * fracx ; y0 = (j-1) * fracx + do qy=1,2 ; do qx=1,2 + x = x0 + fracx*xquad(qx) + y = y0 + fracx*xquad(qy) + Phisub(qx,qy,i,j,1,1) = (1.0-x) * (1.0-y) + Phisub(qx,qy,i,j,1,2) = (1.0-x) * y + Phisub(qx,qy,i,j,2,1) = x * (1.0-y) + Phisub(qx,qy,i,j,2,2) = x * y + enddo ; enddo + enddo ; enddo + +end subroutine bilinear_shape_functions_subgrid + + +subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face_mask) + type(ice_shelf_dyn_CS),intent(in) :: CS !< A pointer to the ice shelf dynamics control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: umask !< A coded mask indicating the nature of the + !! zonal flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: vmask !< A coded mask indicating the nature of the + !! meridional flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face + ! sets masks for velocity solve + ! ignores the fact that their might be ice-free cells - this only considers the computational boundary + + ! !!!IMPORTANT!!! relies on thickness mask - assumed that this is called after hmask has been updated & halo-updated + + integer :: i, j, k, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + isd = G%isd ; jsd = G%jsd + iegq = G%iegB ; jegq = G%jegB + gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo + giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc + + umask(:,:) = 0 ; vmask(:,:) = 0 + u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0 + + if (G%symmetric) then + is = isd ; js = jsd + else + is = isd+1 ; js = jsd+1 + endif + + do j=js,G%jed; do i=is,G%ied + if (hmask(i,j) == 1 .or. hmask(i,j)==3) then + umask(I-1:I,J-1:J)=1 + vmask(I-1:I,J-1:J)=1 + endif + enddo; enddo + + do j=js,G%jed + do i=is,G%ied + + if ((hmask(i,j) == 1) .OR. (hmask(i,j) == 3)) then + + do k=0,1 + + select case (int(CS%u_face_mask_bdry(I-1+k,j))) + case (5) + umask(I-1+k,J-1:J) = 3. + u_face_mask(I-1+k,j) = 5. + case (3) + umask(I-1+k,J-1:J) = 3. + vmask(I-1+k,J-1:J) = 3. + u_face_mask(I-1+k,j) = 3. + case (6) + vmask(I-1+k,J-1:J) = 3. + u_face_mask(I-1+k,j) = 6. + case (2) + u_face_mask(I-1+k,j) = 2. + case (4) + umask(I-1+k,J-1:J) = 0. + u_face_mask(I-1+k,j) = 4. + case (0) + umask(I-1+k,J-1:J) = 0. + u_face_mask(I-1+k,j) = 0. + case (1) ! stress free x-boundary + umask(I-1+k,J-1:J) = 0. + case default + umask(I-1+k,J-1) = max(1. , umask(I-1+k,J-1)) + umask(I-1+k,J) = max(1. , umask(I-1+k,J)) + end select + enddo + + do k=0,1 + + select case (int(CS%v_face_mask_bdry(i,J-1+k))) + case (5) + vmask(I-1:I,J-1+k) = 3. + v_face_mask(i,J-1+k) = 5. + case (3) + vmask(I-1:I,J-1+k) = 3. + umask(I-1:I,J-1+k) = 3. + v_face_mask(i,J-1+k) = 3. + case (6) + umask(I-1:I,J-1+k) = 3. + v_face_mask(i,J-1+k) = 6. + case (2) + v_face_mask(i,J-1+k) = 2. + case (4) + vmask(I-1:I,J-1+k) = 0. + v_face_mask(i,J-1+k) = 4. + case (0) + vmask(I-1:I,J-1+k) = 0. + v_face_mask(i,J-1+k) = 0. + case (1) ! stress free y-boundary + vmask(I-1:I,J-1+k) = 0. + case default + vmask(I-1,J-1+k) = max(1. , vmask(I-1,J-1+k)) + vmask(I,J-1+k) = max(1. , vmask(I,J-1+k)) + end select + enddo + + + if (i < G%ied) then + if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then + ! east boundary or adjacent to unfilled cell + u_face_mask(I,j) = 2. + endif + endif + + if (i > G%isd) then + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then + !adjacent to unfilled cell + u_face_mask(I-1,j) = 2. + endif + endif + + if (j > G%jsd) then + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then + !adjacent to unfilled cell + v_face_mask(i,J-1) = 2. + endif + endif + + if (j < G%jed) then + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then + !adjacent to unfilled cell + v_face_mask(i,j) = 2. + endif + endif + + + endif + + enddo + enddo + + ! note: if the grid is nonsymmetric, there is a part that will not be transferred with a halo update + ! so this subroutine must update its own symmetric part of the halo + + call pass_vector(u_face_mask, v_face_mask, G%domain, TO_ALL, CGRID_NE) + call pass_vector(umask, vmask, G%domain, TO_ALL, BGRID_NE) + +end subroutine update_velocity_masks + +!> Interpolate the ice shelf thickness from tracer point to nodal points, +!! subject to a mask. +subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< The ice shelf thickness at tracer points [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) + !! points [Z ~> m]. + + integer :: i, j, isc, iec, jsc, jec, num_h, k, l, ic, jc + real :: h_arr(2,2) + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + H_node(:,:) = 0.0 + + ! H_node is node-centered; average over all cells that share that node + ! if no (active) cells share the node then its value there is irrelevant + + do j=jsc-1,jec + do i=isc-1,iec + num_h = 0 + do l=1,2; jc=j-1+l; do k=1,2; ic=i-1+k + if (hmask(ic,jc) == 1.0 .or. hmask(ic,jc) == 3.0) then + h_arr(k,l)=h_shelf(ic,jc) + num_h = num_h + 1 + else + h_arr(k,l)=0.0 + endif + if (num_h > 0) then + H_node(i,j) = ((h_arr(1,1)+h_arr(2,2))+(h_arr(1,2)+h_arr(2,1))) / num_h + endif + enddo; enddo + enddo + enddo + + call pass_var(H_node, G%domain,position=CORNER) + +end subroutine interpolate_H_to_B + +!> Deallocates all memory associated with the ice shelf dynamics module +subroutine ice_shelf_dyn_end(CS) + type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure + + if (.not.associated(CS)) return + + deallocate(CS%u_shelf, CS%v_shelf) + deallocate(CS%taudx_shelf, CS%taudy_shelf) + deallocate(CS%t_shelf, CS%tmask) + deallocate(CS%u_bdry_val, CS%v_bdry_val) + deallocate(CS%u_face_mask, CS%v_face_mask) + deallocate(CS%umask, CS%vmask) + deallocate(CS%u_face_mask_bdry, CS%v_face_mask_bdry) + deallocate(CS%h_bdry_val) + deallocate(CS%float_cond) + + deallocate(CS%ice_visc, CS%AGlen_visc) + deallocate(CS%basal_traction,CS%C_basal_friction) + deallocate(CS%OD_rt, CS%OD_av) + deallocate(CS%t_bdry_val, CS%bed_elev) + deallocate(CS%ground_frac, CS%ground_frac_rt) + + deallocate(CS) + +end subroutine ice_shelf_dyn_end + + +!> This subroutine updates the vertically averaged ice shelf temperature. +subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, intent(in) :: time_step !< The time step for this update [T ~> s]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: melt_rate !< basal melt rate [R Z T-1 ~> kg m-2 s-1] + type(time_type), intent(in) :: Time !< The current model time + +! This subroutine takes the velocity (on the Bgrid) and timesteps +! (HT)_t = - div (uHT) + (adot Tsurf -bdot Tbot) once and then calculates T=HT/H +! +! The flux overflows are included here. That is because they will be used to advect 3D scalars +! into partial cells + + real, dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH ! Integrated temperatures [C Z ~> degC m] + integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec + real :: Tsurf ! Surface air temperature [C ~> degC]. This is hard coded but should be an input argument. + real :: adot ! A surface heat exchange coefficient [R Z T-1 ~> kg m-2 s-1]. + + + ! For now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later + adot = (0.1/(365.0*86400.0))*US%m_to_Z*US%T_to_s * CS%density_ice + Tsurf = -20.0*US%degC_to_C + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + th_after_uflux(:,:) = 0.0 + th_after_vflux(:,:) = 0.0 + + do j=jsd,jed ; do i=isd,ied +! if (ISS%hmask(i,j) > 1) then + if ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then + CS%t_shelf(i,j) = CS%t_bdry_val(i,j) + endif + enddo ; enddo + + do j=jsd,jed ; do i=isd,ied + ! Convert the averge temperature to a depth integrated temperature. + TH(i,j) = CS%t_shelf(i,j)*ISS%h_shelf(i,j) + enddo ; enddo + + + call ice_shelf_advect_temp_x(CS, G, time_step, ISS%hmask, TH, th_after_uflux) + call ice_shelf_advect_temp_y(CS, G, time_step, ISS%hmask, th_after_uflux, th_after_vflux) + + do j=jsc,jec ; do i=isc,iec + ! Convert the integrated temperature back to the average temperature. +! if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if (ISS%h_shelf(i,j) > 0.0) then + CS%t_shelf(i,j) = th_after_vflux(i,j) / ISS%h_shelf(i,j) + else + CS%t_shelf(i,j) = CS%T_shelf_missing + endif +! endif + + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if (ISS%h_shelf(i,j) > 0.0) then + CS%t_shelf(i,j) = CS%t_shelf(i,j) + & + time_step*(adot*Tsurf - melt_rate(i,j)*ISS%tfreeze(i,j))/(CS%density_ice*ISS%h_shelf(i,j)) + else + ! the ice is about to melt away in this case set thickness, area, and mask to zero + ! NOTE: not mass conservative, should maybe scale salt & heat flux for this cell + CS%t_shelf(i,j) = CS%T_shelf_missing + CS%tmask(i,j) = 0.0 + endif + elseif (ISS%hmask(i,j) == 0) then + CS%t_shelf(i,j) = CS%T_shelf_missing + elseif ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then + CS%t_shelf(i,j) = CS%t_bdry_val(i,j) + endif + enddo ; enddo + + call pass_var(CS%t_shelf, G%domain, complete=.false.) + call pass_var(CS%tmask, G%domain, complete=.true.) + + if (CS%debug) then + call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3, scale=US%C_to_degC) + endif + +end subroutine ice_shelf_temp + + +subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update [T ~> s]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h0 !< The initial ice shelf thicknesses times temperature [C Z ~> degC m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_uflux !< The ice shelf thicknesses times temperature after + !! the zonal mass fluxes [C Z ~> degC m] + + ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells + ! if there is an input bdry condition, the thickness there will be set in initialization + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + integer :: i_off, j_off + logical :: at_east_bdry, at_west_bdry + real, dimension(-2:2) :: stencil ! A copy of the neighboring thicknesses times temperatures [C Z ~> degC m] + real :: u_face ! Zonal velocity at a face, positive if out [L T-1 ~> m s-1] + real :: flux_diff ! The difference in fluxes [C Z ~> degC m] + real :: phi ! A limiting ratio [nondim] + + is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + i_off = G%idg_offset ; j_off = G%jdg_offset + + do j=jsd+1,jed-1 + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries + + stencil(:) = 0.0 ! This is probably unnecessary, as the code is written +! if (i+i_off == G%domain%nihalo+G%domain%nihalo) + do i=is,ie + + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then + + if (i+i_off == G%domain%nihalo+1) then + at_west_bdry=.true. + else + at_west_bdry=.false. + endif + + if (i+i_off == G%domain%niglobal+G%domain%nihalo) then + at_east_bdry=.true. + else + at_east_bdry=.false. + endif + + if (hmask(i,j) == 1) then + + h_after_uflux(i,j) = h0(i,j) + + stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 + + flux_diff = 0 + + ! 1ST DO LEFT FACE + + if (CS%u_face_mask(I-1,j) == 4.) then + + flux_diff = flux_diff + G%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j) * & + CS%t_bdry_val(i-1,j) / G%areaT(i,j) + else + + ! get u-velocity at center of left face + u_face = 0.5 * (CS%u_shelf(I-1,J-1) + CS%u_shelf(I-1,J)) + + if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(-1) / G%areaT(i,j) + + elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j) * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(i-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i-2) is not + + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * stencil(-1) + + endif + + elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + + else + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * stencil(0) + endif + endif + endif + + ! NEXT DO RIGHT FACE + + ! get u-velocity at center of eastern face + + if (CS%u_face_mask(I,j) == 4.) then + + flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,j) *& + CS%t_bdry_val(i+1,j) / G%areaT(i,j) + else + + u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) + + if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step * stencil(1) / G%areaT(i,j) + + elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid + + phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * stencil(1) + + endif + + elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + + phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + + else ! h(i+1) is valid (o.w. flux would most likely be out of cell) but h(i+2) is not + + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * stencil(0) + + endif + + endif + + h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff + + endif + + endif + + endif + + enddo ! i loop + + endif + + enddo ! j loop + +end subroutine ice_shelf_advect_temp_x + +subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update [T ~> s]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_after_uflux !< The ice shelf thicknesses times temperature after + !! the zonal mass fluxes [C Z ~> degC m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_vflux !< The ice shelf thicknesses times temperature after + !! the meridional mass fluxes [C Z ~> degC m] + + ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells + ! if there is an input bdry condition, the thickness there will be set in initialization + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + integer :: i_off, j_off + logical :: at_north_bdry, at_south_bdry + real, dimension(-2:2) :: stencil ! A copy of the neighboring thicknesses times temperatures [C Z ~> degC m] + real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out [L T-1 ~> m s-1] + real :: flux_diff ! The difference in fluxes [C Z ~> degC m] + real :: phi + + is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + i_off = G%idg_offset ; j_off = G%jdg_offset + + do i=isd+2,ied-2 + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries + + stencil(:) = 0.0 ! This is probably unnecessary, as the code is written + + do j=js,je + + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then + + if (j+j_off == G%domain%njhalo+1) then + at_south_bdry=.true. + else + at_south_bdry=.false. + endif + if (j+j_off == G%domain%njglobal+G%domain%njhalo) then + at_north_bdry=.true. + else + at_north_bdry=.false. + endif + + if (hmask(i,j) == 1) then + h_after_vflux(i,j) = h_after_uflux(i,j) + + stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 + flux_diff = 0 + + ! 1ST DO south FACE + + if (CS%v_face_mask(i,J-1) == 4.) then + + flux_diff = flux_diff + G%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1) * & + CS%t_bdry_val(i,j-1)/ G%areaT(i,j) + else + + ! get u-velocity at center of west face + v_face = 0.5 * (CS%v_shelf(I-1,J-1) + CS%v_shelf(I,J-1)) + + if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(-1) / G%areaT(i,j) + + elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid + + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(j-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j-2) is not + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * stencil(-1) + endif + + elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + else + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * stencil(0) + endif + + endif + + endif + + ! NEXT DO north FACE + + if (CS%v_face_mask(i,J) == 4.) then + flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) *& + CS%t_bdry_val(i,j+1)/ G%areaT(i,j) + else + + ! get u-velocity at center of east face + v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) + + if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step * stencil(1) / G%areaT(i,j) + elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid + phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(1) + endif + + elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(0) + endif + + endif + + endif + + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff + endif + endif + enddo ! j loop + endif + enddo ! i loop + +end subroutine ice_shelf_advect_temp_y + +end module MOM_ice_shelf_dynamics diff --git a/ice_shelf/MOM_ice_shelf_initialize.F90 b/ice_shelf/MOM_ice_shelf_initialize.F90 new file mode 100644 index 0000000000..f976187c2b --- /dev/null +++ b/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -0,0 +1,704 @@ +!> Initialize ice shelf variables +module MOM_ice_shelf_initialize + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_grid, only : ocean_grid_type +use MOM_array_transform, only : rotate_array +use MOM_hor_index, only : hor_index_type +use MOM_file_parser, only : get_param, read_param, log_param, param_file_type +use MOM_io, only: MOM_read_data, file_exists, field_exists, slasher, CORNER +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_unit_scaling, only : unit_scale_type +use user_shelf_init, only: USER_init_ice_thickness + +implicit none ; private + +#include + +public initialize_ice_thickness +public initialize_ice_shelf_boundary_channel +public initialize_ice_flow_from_file +public initialize_ice_shelf_boundary_from_file +public initialize_ice_C_basal_friction +public initialize_ice_AGlen +public initialize_ice_SMB +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> Initialize ice shelf thickness +subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, PF, rotate_index, turns) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(ocean_grid_type), intent(in) :: G_in !< The ocean's unrotated grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + 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 + logical, intent(in), optional :: rotate_index !< If true, this is a rotation test + integer, intent(in), optional :: turns !< Number of turns for rotation test + + character(len=40) :: mdl = "initialize_ice_thickness" ! This subroutine's name. + character(len=200) :: config + logical :: rotate = .false. + real, allocatable, dimension(:,:) :: tmp1_2d ! Temporary array for storing ice shelf input data + real, allocatable, dimension(:,:) :: tmp2_2d ! Temporary array for storing ice shelf input data + real, allocatable, dimension(:,:) :: tmp3_2d ! Temporary array for storing ice shelf input data + + call get_param(PF, mdl, "ICE_PROFILE_CONFIG", config, & + "This specifies how the initial ice profile is specified. "//& + "Valid values are: CHANNEL, FILE, and USER.", & + fail_if_missing=.true.) + + if (PRESENT(rotate_index)) rotate=rotate_index + + if (rotate) then + allocate(tmp1_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed), source=0.0) + allocate(tmp2_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed), source=0.0) + allocate(tmp3_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed), source=0.0) + select case ( trim(config) ) + case ("CHANNEL") ; call initialize_ice_thickness_channel (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF) + case ("FILE") ; call initialize_ice_thickness_from_file (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF) + case ("USER") ; call USER_init_ice_thickness (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF) + case default ; call MOM_error(FATAL,"MOM_initialize: Unrecognized ice profile setup "//trim(config)) + end select + call rotate_array(tmp1_2d,turns, h_shelf) + call rotate_array(tmp2_2d,turns, area_shelf_h) + call rotate_array(tmp3_2d,turns, hmask) + deallocate(tmp1_2d,tmp2_2d,tmp3_2d) + else + select case ( trim(config) ) + case ("CHANNEL") ; call initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, US, PF) + case ("FILE") ; call initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, US, PF) + case ("USER") ; call USER_init_ice_thickness (h_shelf, area_shelf_h, hmask, G, US, PF) + case default ; call MOM_error(FATAL,"MOM_initialize: Unrecognized ice profile setup "//trim(config)) + end select + endif + +end subroutine initialize_ice_thickness + +!> Initialize ice shelf thickness from file +subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + 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 + + ! This subroutine reads ice thickness and area from a file and puts it into + ! h_shelf [Z ~> m] and area_shelf_h [L2 ~> m2] (and dimensionless) and updates hmask + character(len=200) :: filename,thickness_file,inputdir ! Strings for file/path + character(len=200) :: thickness_varname, area_varname, hmask_varname ! Variable name in file + character(len=40) :: mdl = "initialize_ice_thickness_from_file" ! This subroutine's name. + integer :: i, j, isc, jsc, iec, jec + logical :: hmask_set + real :: len_sidestress, udh + + call MOM_mesg("Initialize_ice_thickness_from_file: reading thickness") + + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(PF, mdl, "ICE_THICKNESS_FILE", thickness_file, & + "The file from which the bathymetry is read.", & + default="ice_shelf_h.nc") + call get_param(PF, mdl, "LEN_SIDE_STRESS", len_sidestress, & + "position past which shelf sides are stress free.", & + default=0.0, units="axis_units") + + filename = trim(inputdir)//trim(thickness_file) + call log_param(PF, mdl, "INPUTDIR/THICKNESS_FILE", filename) + call get_param(PF, mdl, "ICE_THICKNESS_VARNAME", thickness_varname, & + "The name of the thickness variable in ICE_THICKNESS_FILE.", & + default="h_shelf") + call get_param(PF, mdl, "ICE_AREA_VARNAME", area_varname, & + "The name of the area variable in ICE_THICKNESS_FILE.", & + default="area_shelf_h") + hmask_varname="h_mask" + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_topography_from_file: Unable to open "//trim(filename)) + call MOM_read_data(filename, trim(thickness_varname), h_shelf, G%Domain, scale=US%m_to_Z) + call MOM_read_data(filename,trim(area_varname), area_shelf_h, G%Domain, scale=US%m_to_L**2) + if (field_exists(filename, trim(hmask_varname), MOM_domain=G%Domain)) then + call MOM_read_data(filename, trim(hmask_varname), hmask, G%Domain) + hmask_set = .true. + else + call MOM_error(WARNING, "Ice shelf thickness initialized without setting the shelf mask "//& + "from variable "//trim(hmask_varname)//", which does not exist in "//trim(filename)) + hmask_set = .false. + endif + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + if (.not.hmask_set) then + ! Set hmask based on the values in h_shelf. + do j=jsc,jec ; do i=isc,iec + hmask(i,j) = 0.0 + if (h_shelf(i,j) > 0.0) hmask(i,j) = 1.0 + enddo ; enddo + endif + + do j=jsc,jec + do i=isc,iec + + ! taper ice shelf in area where there is no sidestress - + ! but do not interfere with hmask + + if ((len_sidestress > 0.) .and. (G%geoLonCv(i,j) > len_sidestress)) then + udh = exp(-(G%geoLonCv(i,j)-len_sidestress)/5.0) * h_shelf(i,j) + if (udh <= 25.0) then + h_shelf(i,j) = 0.0 + area_shelf_h(i,j) = 0.0 + else + h_shelf(i,j) = udh + endif + endif + + ! update thickness mask + + if (area_shelf_h(i,j) >= G%areaT(i,j)) then + hmask(i,j) = 1. + area_shelf_h(i,j)=G%areaT(i,j) + elseif (area_shelf_h(i,j) == 0.0) then + hmask(i,j) = 0. + elseif ((area_shelf_h(i,j) > 0) .and. (area_shelf_h(i,j) <= G%areaT(i,j))) then + hmask(i,j) = 2. + else + call MOM_error(FATAL,mdl// " AREA IN CELL OUT OF RANGE") + endif + enddo + enddo +end subroutine initialize_ice_thickness_from_file + +!> Initialize ice shelf thickness for a channel configuration +subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + 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_thickness_channel" ! This subroutine's name. + real :: max_draft, min_draft, flat_shelf_width, c1, slope_pos + real :: edge_pos, shelf_slope_scale + integer :: i, j, jsc, jec, jsd, jed, jedg, nyh, isc, iec, isd, ied + integer :: j_off + + jsc = G%jsc ; jec = G%jec ; isc = G%isc ; iec = G%iec + jsd = G%jsd ; jed = G%jed ; isd = G%isd ; ied = G%ied + nyh = G%domain%njhalo ; jedg = G%domain%njglobal+nyh + j_off = G%jdg_offset + + call MOM_mesg(mdl//": setting thickness") + + call get_param(PF, mdl, "SHELF_MAX_DRAFT", max_draft, & + units="m", default=1.0, scale=US%m_to_Z) + call get_param(PF, mdl, "SHELF_MIN_DRAFT", min_draft, & + units="m", default=1.0, scale=US%m_to_Z) + call get_param(PF, mdl, "FLAT_SHELF_WIDTH", flat_shelf_width, & + units="axis_units", default=0.0) + call get_param(PF, mdl, "SHELF_SLOPE_SCALE", shelf_slope_scale, & + units="axis_units", default=0.0) + call get_param(PF, mdl, "SHELF_EDGE_POS_0", edge_pos, & + units="axis_units", default=0.0) +! call get_param(param_file, mdl, "RHO_0", Rho_ocean, & +! "The mean ocean density used with BOUSSINESQ true to "//& +! "calculate accelerations and the mass for conservation "//& +! "properties, or with BOUSSINSEQ false to convert some "//& +! "parameters from vertical units of m to kg m-2.", & +! units="kg m-3", default=1035.0, scale=US%Z_to_m) + + slope_pos = edge_pos - flat_shelf_width + c1 = 0.0 ; if (shelf_slope_scale > 0.0) c1 = 1.0 / shelf_slope_scale + + + do j=G%jsd,G%jed + + if (((j+j_off) <= jedg) .AND. ((j+j_off) >= nyh+1)) then + + do i=G%isc,G%iec + + if ((j >= jsc) .and. (j <= jec)) then + + if (G%geoLonCu(i-1,j) >= edge_pos) then + ! Everything past the edge is open ocean. + area_shelf_h(i,j) = 0.0 + hmask (i,j) = 0.0 + h_shelf (i,j) = 0.0 + else + if (G%geoLonCu(i,j) > edge_pos) then + area_shelf_h(i,j) = G%areaT(i,j) * (edge_pos - G%geoLonCu(i-1,j)) / & + (G%geoLonCu(i,j) - G%geoLonCu(i-1,j)) + hmask (i,j) = 2.0 + else + area_shelf_h(i,j) = G%areaT(i,j) + hmask (i,j) = 1.0 + endif + + if (G%geoLonT(i,j) > slope_pos) then + h_shelf(i,j) = min_draft + else + h_shelf(i,j) = (min_draft + & + (max_draft - min_draft) * & + min(1.0, (c1*(slope_pos - G%geoLonT(i,j)))**2) ) + endif + + endif + endif + + if ((i+G%idg_offset) == G%domain%nihalo+1) then + hmask(i-1,j) = 3.0 + endif + + enddo + endif ; enddo + +end subroutine initialize_ice_thickness_channel + +!> Initialize ice shelf boundary conditions for a channel configuration +subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_bdry, & + u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, u_shelf, v_shelf, h_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) :: 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, 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 + + lenlat = G%len_lat + lenlon = G%len_lon + westlon = G%west_lon + southlat = G%south_lat + + 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 + !--- + !OLD: thickness_bdry_val was used for ice dynamics, and h_bdry_val was not used anywhere except here: + !h_bdry_val(i+1,j) = h_shelf(i+1,j) ; thickness_bdry_val(i+1,j) = h_bdry_val(i+0*1,j) + !--- + !NEW: h_bdry_val is used for ice dynamics instead of thickness_bdry_val, which was removed + h_bdry_val(i+1,j) = h_shelf(i+0*1,j) !why 0*1 + !--- + u_face_mask_bdry(i+1,j) = 5.0 + u_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution + endif + + + ! 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 + + +!> Initialize ice shelf flow from file +subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& + G, US, PF) + 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(SZDI_(G),SZDJ_(G)), & + intent(inout) :: float_cond !< An array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not. [nondim] + 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 + + ! This subroutine reads ice thickness and area from a file and puts it into + ! h_shelf [Z ~> m] and area_shelf_h [L2 ~> m2] (and dimensionless) and updates hmask + character(len=200) :: filename,vel_file,inputdir,bed_topo_file ! Strings for file/path + character(len=200) :: ushelf_varname, vshelf_varname, & + floatfr_varname, bed_varname ! Variable name in file + character(len=40) :: mdl = "initialize_ice_velocity_from_file" ! This subroutine's name. + + call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_velocity_from_file: reading velocity") + + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(PF, mdl, "ICE_VELOCITY_FILE", vel_file, & + "The file from which the velocity is read.", & + default="ice_shelf_vel.nc") + + filename = trim(inputdir)//trim(vel_file) + call log_param(PF, mdl, "INPUTDIR/THICKNESS_FILE", filename) + call get_param(PF, mdl, "ICE_U_VEL_VARNAME", ushelf_varname, & + "The name of the u velocity variable in ICE_VELOCITY_FILE.", & + default="u_shelf") + call get_param(PF, mdl, "ICE_V_VEL_VARNAME", vshelf_varname, & + "The name of the v velocity variable in ICE_VELOCITY_FILE.", & + default="v_shelf") + call get_param(PF, mdl, "ICE_FLOAT_FRAC_VARNAME", floatfr_varname, & + "The name of the ice float fraction (grounding fraction) variable in ICE_VELOCITY_FILE.", & + default="float_frac") + call get_param(PF, mdl, "BED_TOPO_FILE", bed_topo_file, & + "The file from which the bed elevation is read.", & + default="ice_shelf_vel.nc") + call get_param(PF, mdl, "BED_TOPO_VARNAME", bed_varname, & + "The name of the bed elevation variable in ICE_INPUT_FILE.", & + default="depth") + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) + + call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, position=CORNER, scale=US%m_s_to_L_T) + call MOM_read_data(filename, trim(vshelf_varname), v_shelf, G%Domain, position=CORNER, scale=US%m_s_to_L_T) + call MOM_read_data(filename, trim(floatfr_varname), float_cond, G%Domain, scale=1.) + + filename = trim(inputdir)//trim(bed_topo_file) + call MOM_read_data(filename, trim(bed_varname), bed_elev, G%Domain, scale=US%m_to_Z) + + +end subroutine initialize_ice_flow_from_file + +!> Initialize ice shelf b.c.s from file +subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask_bdry, & + u_bdry_val, v_bdry_val, umask, vmask, h_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) :: 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, & + ubdryv_varname, vbdryv_varname, umask_varname, vmask_varname, & + hmsk_varname ! Variable name in file + character(len=40) :: mdl = "initialize_ice_shelf_boundary_from_file" ! This subroutine's name. + + integer :: i, j, isc, jsc, iec, jec + + h_bdry_val(:,:) = 0. + + call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_b_c_s_from_file: reading b.c.s") + + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(PF, mdl, "ICE_SHELF_BC_FILE", bc_file, & + "The file from which the boundary conditions are read.", & + default="ice_shelf_bc.nc") + call get_param(PF, mdl, "ICE_THICKNESS_FILE", icethick_file, & + "The file from which the ice-shelf thickness is read.", & + default="ice_shelf_thick.nc") + call get_param(PF, mdl, "ICE_THICKNESS_MASK_VARNAME", hmsk_varname, & + "The name of the icethickness mask variable in ICE_THICKNESS_FILE.", & + default="h_mask") + + filename = trim(inputdir)//trim(bc_file) + call log_param(PF, mdl, "INPUTDIR/ICE_SHELF_BC_FILE", filename) + call get_param(PF, mdl, "ICE_UBDRYMSK_VARNAME", ufcmskbdry_varname, & + "The name of the ice-shelf ubdrymask variable in ICE_SHELF_BC_FILE.", & + default="ufacemask") + call get_param(PF, mdl, "ICE_VBDRYMSK_VARNAME", vfcmskbdry_varname, & + "The name of the ice-shelf vbdrymask variable in ICE_SHELF_BC_FILE.", & + default="vfacemask") + call get_param(PF, mdl, "ICE_UMASK_VARNAME", umask_varname, & + "The name of the ice-shelf ubdrymask variable in ICE_SHELF_BC_FILE.", & + default="umask") + call get_param(PF, mdl, "ICE_VMASK_VARNAME", vmask_varname, & + "The name of the ice-shelf vbdrymask variable in ICE_SHELF_BC_FILE.", & + default="vmask") + call get_param(PF, mdl, "ICE_UBDRYVAL_VARNAME", ubdryv_varname, & + "The name of the ice-shelf ice_shelf ubdry variable in ICE_SHELF_BC_FILE.", & + default="ubdry_val") + call get_param(PF, mdl, "ICE_VBDRYVAL_VARNAME", vbdryv_varname, & + "The name of the ice-shelf ice_shelf vbdry variable in ICE_SHELF_BC_FILE.", & + default="vbdry_val") + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) + + + call MOM_read_data(filename, trim(ufcmskbdry_varname), u_face_mask_bdry, G%Domain, position=CORNER, & + scale=1.) + call MOM_read_data(filename, trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, position=CORNER, & + scale=1.) + call MOM_read_data(filename, trim(ubdryv_varname), u_bdry_val, G%Domain, position=CORNER, scale=US%m_s_to_L_T) + call MOM_read_data(filename, trim(vbdryv_varname), v_bdry_val, G%Domain, position=CORNER, scale=US%m_s_to_L_T) + call MOM_read_data(filename, trim(umask_varname), umask, G%Domain, position=CORNER, scale=1.) + call MOM_read_data(filename, trim(vmask_varname), vmask, G%Domain, position=CORNER, scale=1.) + filename = trim(inputdir)//trim(icethick_file) + + call MOM_read_data(filename,trim(hmsk_varname), hmask, G%Domain, scale=1.) + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + do j=jsc,jec + do i=isc,iec + if (hmask(i,j) == 3.) then + h_bdry_val(i,j) = h_shelf(i,j) + endif + enddo + enddo + +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 + 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 + +! integer :: i, j + real :: C_friction + character(len=40) :: mdl = "initialize_ice_basal_friction" ! This subroutine's name. + character(len=200) :: config + character(len=200) :: varname + character(len=200) :: inputdir, filename, C_friction_file + + call get_param(PF, mdl, "ICE_BASAL_FRICTION_CONFIG", config, & + "This specifies how the initial basal friction profile is specified. "//& + "Valid values are: CONSTANT and FILE.", & + fail_if_missing=.true.) + + if (trim(config)=="CONSTANT") then + call get_param(PF, mdl, "BASAL_FRICTION_COEFF", C_friction, & + "Coefficient in sliding law.", units="Pa (s m-1)^(n_basal_fric)", default=5.e10) + + 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 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, & + "The variable to use in basal traction.", & + default="tau_b_beta") + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_basal_friction_from_file: Unable to open "//trim(filename)) + + call MOM_read_data(filename,trim(varname),C_basal_friction,G%Domain) + + endif +end subroutine + + +!> Initialize ice-stiffness parameter +subroutine initialize_ice_AGlen(AGlen, ice_viscosity_compute, 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, often in [Pa-3 s-1] + character(len=40) :: ice_viscosity_compute !< Specifies whether the ice viscosity is computed internally + !! according to Glen's flow law; is constant (for debugging purposes) + !! or using observed strain rates and read from a file + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + real :: A_Glen ! Ice-stiffness parameter, often in [Pa-3 s-1] + character(len=40) :: mdl = "initialize_ice_stiffness" ! This subroutine's name. + character(len=200) :: config + character(len=200) :: varname + character(len=200) :: inputdir, filename, AGlen_file + + call get_param(PF, mdl, "ICE_A_GLEN_CONFIG", config, & + "This specifies how the initial ice-stiffness parameter is specified. "//& + "Valid values are: CONSTANT and FILE.", & + fail_if_missing=.true.) + + if (trim(config)=="CONSTANT") then + call get_param(PF, mdl, "A_GLEN", A_Glen, & + "Ice-stiffness parameter.", units="Pa-n_g s-1", default=2.261e-25) + + 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 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, & + "The variable to use as ice-stiffness.", & + default="A_GLEN") + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_stiffness_from_file: Unable to open "//trim(filename)) + + if (trim(ice_viscosity_compute) == "OBS") then + !AGlen is the ice viscosity [Pa s ~> R L2 T-1] computed from obs and read from a file + call MOM_read_data(filename, trim(varname), AGlen, G%Domain, scale=US%Pa_to_RL2_T2*US%s_to_T) + else + !AGlen is the ice stiffness parameter [Pa-n_g s-1] + call MOM_read_data(filename, trim(varname), AGlen, G%Domain) + endif + endif +end subroutine initialize_ice_AGlen + +!> Initialize ice surface mass balance field that is held constant over time +subroutine initialize_ice_SMB(SMB, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: SMB !< Ice surface mass balance parameter, often in [kg m-2 s-1] + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + real :: SMB_val ! Constant ice surface mass balance parameter, often in [kg m-2 s-1] + character(len=40) :: mdl = "initialize_ice_SMB" ! This subroutine's name. + character(len=200) :: config + character(len=200) :: varname + character(len=200) :: inputdir, filename, SMB_file + + call get_param(PF, mdl, "ICE_SMB_CONFIG", config, & + "This specifies how the initial ice surface mass balance parameter is specified. "//& + "Valid values are: CONSTANT and FILE.", & + default="CONSTANT") + + if (trim(config)=="CONSTANT") then + call get_param(PF, mdl, "SMB", SMB_val, & + "Surface mass balance.", units="kg m-2 s-1", default=0.0, scale=US%kg_m2s_to_RZ_T) + + SMB(:,:) = SMB_val + + elseif (trim(config)=="FILE") then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading SMB parameter") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + call get_param(PF, mdl, "ICE_SMB_FILE", SMB_file, & + "The file from which the ice surface mass balance is read.", & + default="ice_SMB.nc") + filename = trim(inputdir)//trim(SMB_file) + call log_param(PF, mdl, "INPUTDIR/ICE_SMB_FILE", filename) + call get_param(PF, mdl, "ICE_SMB_VARNAME", varname, & + "The variable to use as surface mass balance.", & + default="SMB") + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_SMV_from_file: Unable to open "//trim(filename)) + call MOM_read_data(filename,trim(varname), SMB, G%Domain, scale=US%kg_m2s_to_RZ_T) + + endif +end subroutine initialize_ice_SMB +end module MOM_ice_shelf_initialize diff --git a/ice_shelf/MOM_ice_shelf_state.F90 b/ice_shelf/MOM_ice_shelf_state.F90 new file mode 100644 index 0000000000..e6be780073 --- /dev/null +++ b/ice_shelf/MOM_ice_shelf_state.F90 @@ -0,0 +1,102 @@ +!> Implements the thermodynamic aspects of ocean / ice-shelf interactions, +!! along with a crude placeholder for a later implementation of full +!! ice shelf dynamics, all using the MOM framework and coding style. +module MOM_ice_shelf_state + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE +use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_grid, only : MOM_grid_init, ocean_grid_type +use MOM_get_input, only : directories, Get_MOM_input +use MOM_coms, only : reproducing_sum +use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum + +implicit none ; private + +public ice_shelf_state_end, ice_shelf_state_init + +!> Structure that describes the ice shelf state +type, public :: ice_shelf_state + real, pointer, dimension(:,:) :: & + mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or sheet [R Z ~> kg m-2]. + area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf [L2 ~> m2]. + h_shelf => NULL(), & !< the thickness of the shelf [Z ~> m], redundant with mass but may + !! make the code more readable + dhdt_shelf => NULL(), & !< the change in thickness of the shelf over time [Z T-1 ~> m s-1] + hmask => NULL(),& !< Mask used to indicate ice-covered or partiall-covered cells + !! 1: fully covered, solve for velocity here (for now all + !! ice-covered cells are treated the same, this may change) + !! 2: partially covered, do not solve for velocity + !! 0: no ice in cell. + !! 3: bdry condition on thickness set + !! -2 : default (out of computational boundary) + !! NOTE: hmask will change over time and NEEDS TO BE MAINTAINED + !! otherwise the wrong nodes will be included in velocity calcs. + + tflux_ocn => NULL(), & !< The downward sensible ocean heat flux at the + !! ocean-ice interface [Q R Z T-1 ~> W m-2]. + salt_flux => NULL(), & !< The downward salt flux at the ocean-ice + !! interface [kgSalt kgWater-1 R Z T-1 ~> kgSalt m-2 s-1]. + water_flux => NULL(), & !< The net downward liquid water flux at the + !! ocean-ice interface [R Z T-1 ~> kg m-2 s-1]. + tflux_shelf => NULL(), & !< The downward diffusive heat flux in the ice + !! shelf at the ice-ocean interface [Q R Z T-1 ~> W m-2]. + + tfreeze => NULL() !< The freezing point potential temperature + !! at the ice-ocean interface [C ~> degC]. + +end type ice_shelf_state + +contains + +!> Deallocates all memory associated with this module +subroutine ice_shelf_state_init(ISS, G) + type(ice_shelf_state), pointer :: ISS !< A pointer to the ice shelf state structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + + integer :: isd, ied, jsd, jed + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + + if (associated(ISS)) then + call MOM_error(FATAL, "MOM_ice_shelf_state.F90, ice_shelf_state_init: "// & + "called with an associated ice_shelf_state pointer.") + return + endif + allocate(ISS) + + allocate(ISS%mass_shelf(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%area_shelf_h(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%h_shelf(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%dhdt_shelf(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%hmask(isd:ied,jsd:jed), source=-2.0 ) + + allocate(ISS%tflux_ocn(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%water_flux(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%salt_flux(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%tflux_shelf(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%tfreeze(isd:ied,jsd:jed), source=0.0 ) + +end subroutine ice_shelf_state_init + + +!> Deallocates all memory associated with this module +subroutine ice_shelf_state_end(ISS) + type(ice_shelf_state), pointer :: ISS !< A pointer to the ice shelf state structure + + if (.not.associated(ISS)) return + + deallocate(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, ISS%dhdt_shelf, ISS%hmask) + + deallocate(ISS%tflux_ocn, ISS%water_flux, ISS%salt_flux, ISS%tflux_shelf) + deallocate(ISS%tfreeze) + + deallocate(ISS) + +end subroutine ice_shelf_state_end + + +end module MOM_ice_shelf_state diff --git a/ice_shelf/MOM_marine_ice.F90 b/ice_shelf/MOM_marine_ice.F90 new file mode 100644 index 0000000000..8635eb71b5 --- /dev/null +++ b/ice_shelf/MOM_marine_ice.F90 @@ -0,0 +1,206 @@ +!> Routines incorporating the effects of marine ice (sea-ice and icebergs) into +!! the ocean model dynamics and thermodynamics. +module MOM_marine_ice + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_constants, only : hlf +use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl +use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : TO_ALL, Omit_Corners +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : allocate_forcing_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_grid, only : ocean_grid_type +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface + +implicit none ; private + +#include + +public iceberg_forces, iceberg_fluxes, marine_ice_init + +!> Control structure for MOM_marine_ice +type, public :: marine_ice_CS ; private + real :: kv_iceberg !< The viscosity of the icebergs [L4 Z-2 T-1 ~> m2 s-1] (for ice rigidity) + real :: berg_area_threshold !< Fraction of grid cell which iceberg must occupy + !! so that fluxes below are set to zero [nondim]. (0.5 is a + !! good value to use.) Not applied for negative values. + real :: latent_heat_fusion !< Latent heat of fusion [Q ~> J kg-1] + real :: density_iceberg !< A typical density of icebergs [R ~> kg m-3] (for ice rigidity) + + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output. +end type marine_ice_CS + +contains + +!> add_berg_flux_to_shelf adds rigidity and ice-area coverage due to icebergs +!! to the forces type fields, and adds ice-areal coverage and modifies various +!! thermodynamic fluxes due to the presence of icebergs. +subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + logical, intent(in) :: use_ice_shelf !< If true, this configuration uses ice shelves. + real, intent(in) :: time_step !< The coupling time step [T ~> s]. + type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice + + real :: kv_rho_ice ! The viscosity of ice divided by its density [L4 Z-2 T-1 R-1 ~> m5 kg-1 s-1]. + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + !This routine adds iceberg data to the ice shelf data (if ice shelf is used) + !which can then be used to change the top of ocean boundary condition used in + !the ocean model. This routine is taken from the add_shelf_flux subroutine + !within the ice shelf model. + + if (.not.associated(CS)) return + + if (.not.(associated(forces%area_berg) .and. associated(forces%mass_berg) ) ) return + + if (.not.(associated(forces%frac_shelf_u) .and. associated(forces%frac_shelf_v) .and. & + associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)) ) return + + ! This section sets or augments the values of fields in forces. + if (.not. use_ice_shelf) then + forces%frac_shelf_u(:,:) = 0.0 ; forces%frac_shelf_v(:,:) = 0.0 + endif + if (.not. forces%accumulate_rigidity) then + forces%rigidity_ice_u(:,:) = 0.0 ; forces%rigidity_ice_v(:,:) = 0.0 + endif + + call pass_var(forces%area_berg, G%domain, TO_ALL+Omit_corners, halo=1, complete=.false.) + call pass_var(forces%mass_berg, G%domain, TO_ALL+Omit_corners, halo=1, complete=.true.) + kv_rho_ice = CS%kv_iceberg / CS%density_iceberg + do j=js,je ; do I=is-1,ie + if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & + forces%frac_shelf_u(I,j) = forces%frac_shelf_u(I,j) + & + (forces%area_berg(i,j)*G%areaT(i,j) + forces%area_berg(i+1,j)*G%areaT(i+1,j)) / & + (G%areaT(i,j) + G%areaT(i+1,j)) + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + kv_rho_ice * & + min(forces%mass_berg(i,j), forces%mass_berg(i+1,j)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & + forces%frac_shelf_v(i,J) = forces%frac_shelf_v(i,J) + & + (forces%area_berg(i,j)*G%areaT(i,j) + forces%area_berg(i,j+1)*G%areaT(i,j+1)) / & + (G%areaT(i,j) + G%areaT(i,j+1)) + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + kv_rho_ice * & + min(forces%mass_berg(i,j), forces%mass_berg(i,j+1)) + enddo ; enddo + +end subroutine iceberg_forces + +!> iceberg_fluxes adds ice-area-coverage and modifies various +!! thermodynamic fluxes due to the presence of icebergs. +subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(forcing), intent(inout) :: fluxes !< A structure with pointers to themodynamic, + !! tracer and mass exchange forcing fields + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + logical, intent(in) :: use_ice_shelf !< If true, this configuration uses ice shelves. + real, intent(in) :: time_step !< The coupling time step [T ~> s]. + type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice + + real :: fraz ! refreezing rate [R Z T-1 ~> kg m-2 s-1] + real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion times [Q-1 T-1 ~> kg J-1 s-1]. + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + ! This routine adds iceberg data to the ice shelf data (if ice shelf is used) + ! which can then be used to change the top of ocean boundary condition used in + ! the ocean model. This routine is taken from the add_shelf_flux subroutine + ! within the ice shelf model. + + if (.not.associated(CS)) return + if (.not.(associated(fluxes%area_berg) .and. associated(fluxes%ustar_berg) .and. & + associated(fluxes%mass_berg) ) ) return + if (.not.(associated(fluxes%frac_shelf_h) .and. associated(fluxes%ustar_shelf)) ) return + + + if (.not.(associated(fluxes%area_berg) .and. associated(fluxes%ustar_berg) .and. & + associated(fluxes%mass_berg) ) ) return + if (.not. use_ice_shelf) then + fluxes%frac_shelf_h(:,:) = 0. + fluxes%ustar_shelf(:,:) = 0. + endif + do j=jsd,jed ; do i=isd,ied ; if (G%areaT(i,j) > 0.0) then + fluxes%frac_shelf_h(i,j) = fluxes%frac_shelf_h(i,j) + fluxes%area_berg(i,j) + fluxes%ustar_shelf(i,j) = fluxes%ustar_shelf(i,j) + fluxes%ustar_berg(i,j) + endif ; enddo ; enddo + + !Zero'ing out other fluxes under the tabular icebergs + if (CS%berg_area_threshold >= 0.) then + I_dt_LHF = 1.0 / (time_step * CS%latent_heat_fusion) + do j=jsd,jed ; do i=isd,ied + if (fluxes%frac_shelf_h(i,j) > CS%berg_area_threshold) then + ! Only applying for ice shelf covering most of cell. + + if (associated(fluxes%sw)) fluxes%sw(i,j) = 0.0 + if (associated(fluxes%lw)) fluxes%lw(i,j) = 0.0 + if (associated(fluxes%latent)) fluxes%latent(i,j) = 0.0 + if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 + + ! Add frazil formation diagnosed by the ocean model [Q R Z ~> J m-2] in the + ! form of surface layer evaporation [R Z T-1 ~> kg m-2 s-1]. Update lprec in the + ! control structure for diagnostic purposes. + + if (allocated(sfc_state%frazil)) then + fraz = sfc_state%frazil(i,j) * I_dt_LHF + if (associated(fluxes%evap)) fluxes%evap(i,j) = fluxes%evap(i,j) - fraz + ! if (associated(fluxes%lprec)) fluxes%lprec(i,j) = fluxes%lprec(i,j) - fraz + sfc_state%frazil(i,j) = 0.0 + endif + + !Alon: Should these be set to zero too? + if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 + if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 + if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 + endif + enddo ; enddo + endif + +end subroutine iceberg_fluxes + +!> Initialize control structure for MOM_marine_ice +subroutine marine_ice_init(Time, G, param_file, diag, CS) + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(param_file_type), intent(in) :: param_file !< Runtime parameter handles + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_marine_ice" ! This module's name. + + if (associated(CS)) then + call MOM_error(WARNING, "marine_ice_init called with an associated control structure.") + return + else ; allocate(CS) ; endif + + ! Write all relevant parameters to the model log. + call log_version(mdl, version) + + call get_param(param_file, mdl, "KV_ICEBERG", CS%kv_iceberg, & + "The viscosity of the icebergs", & + units="m2 s-1", default=1.0e10, scale=G%US%Z_to_L**2*G%US%m_to_L**2*G%US%T_to_s) + call get_param(param_file, mdl, "DENSITY_ICEBERGS", CS%density_iceberg, & + "A typical density of icebergs.", units="kg m-3", default=917.0, scale=G%US%kg_m3_to_R) + call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & + "The latent heat of fusion.", units="J/kg", default=hlf, scale=G%US%J_kg_to_Q) + call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", CS%berg_area_threshold, & + "Fraction of grid cell which iceberg must occupy, so that fluxes "//& + "below berg are set to zero. Not applied for negative values.", & + units="nondim", default=-1.0) + +end subroutine marine_ice_init + +end module MOM_marine_ice diff --git a/ice_shelf/user_shelf_init.F90 b/ice_shelf/user_shelf_init.F90 new file mode 100644 index 0000000000..4d1f263ca8 --- /dev/null +++ b/ice_shelf/user_shelf_init.F90 @@ -0,0 +1,208 @@ +!> This module specifies the initial values and evolving properties of the +!! MOM6 ice shelf, using user-provided code. +module user_shelf_init + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_time_manager, only : time_type, set_time, time_type_to_real +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +#include + +public USER_initialize_shelf_mass, USER_update_shelf_mass +public USER_init_ice_thickness + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> The control structure for the user_ice_shelf module +type, public :: user_ice_shelf_CS ; private + real :: Rho_ocean !< The ocean's typical density [R ~> kg m-3]. + real :: max_draft !< The maximum ocean draft of the ice shelf [Z ~> m]. + real :: min_draft !< The minimum ocean draft of the ice shelf [Z ~> m]. + real :: flat_shelf_width !< The range over which the shelf is min_draft thick [km]. + real :: shelf_slope_scale !< The range over which the shelf slopes [km]. + real :: pos_shelf_edge_0 !< The x-position of the shelf edge at time 0 [km]. + real :: shelf_speed !< The ice shelf speed of translation [km day-1] + logical :: first_call = .true. !< If true, this module has not been called before. +end type user_ice_shelf_CS + +contains + +!> This subroutine sets up the initial mass and area covered by the ice shelf, based on user-provided code. +subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, US, CS, param_file, new_sim) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: mass_shelf !< The ice shelf mass per unit area averaged + !! over the full ocean cell [R Z ~> kg m-2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(user_ice_shelf_CS), pointer :: CS !< A pointer to the user ice shelf control structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + logical, intent(in) :: new_sim !< If true, this is a new run; otherwise it is + !! being started from a restart file. + +! This subroutine sets up the initial mass and area covered by the ice shelf. + character(len=40) :: mdl = "USER_initialize_shelf_mass" ! This subroutine's name. + + ! call MOM_error(FATAL, "USER_shelf_init.F90, USER_set_shelf_mass: " // & + ! "Unmodified user routine called - you must edit the routine to use it") + + if (.not.associated(CS)) allocate(CS) + + ! Read all relevant parameters and write them to the model log. + if (CS%first_call) call write_user_log(param_file) + CS%first_call = .false. + call get_param(param_file, mdl, "RHO_0", CS%Rho_ocean, & + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "SHELF_MAX_DRAFT", CS%max_draft, & + units="m", default=1.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "SHELF_MIN_DRAFT", CS%min_draft, & + units="m", default=1.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "FLAT_SHELF_WIDTH", CS%flat_shelf_width, & + units="axis_units", default=0.0) + call get_param(param_file, mdl, "SHELF_SLOPE_SCALE", CS%shelf_slope_scale, & + units="axis_units", default=0.0) + call get_param(param_file, mdl, "SHELF_EDGE_POS_0", CS%pos_shelf_edge_0, & + units="axis_units", default=0.0) + call get_param(param_file, mdl, "SHELF_SPEED", CS%shelf_speed, & + units="axis_units day-1", default=0.0) + + call USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, CS, set_time(0,0), new_sim) + +end subroutine USER_initialize_shelf_mass + +!> This subroutine updates the ice shelf thickness, as specified by user-provided code. +subroutine USER_init_ice_thickness(h_shelf, area_shelf_h, hmask, G, US, param_file) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf [nondim] + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + + ! This subroutine initializes the ice shelf thickness. Currently it does so + ! calling USER_initialize_shelf_mass, but this can be revised as needed. + real, dimension(SZI_(G),SZJ_(G)) :: mass_shelf ! The ice shelf mass per unit area averaged + ! over the full ocean cell [R Z ~> kg m-2]. + type(user_ice_shelf_CS), pointer :: CS => NULL() + + call USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, US, CS, param_file, .true.) + +end subroutine USER_init_ice_thickness + +!> This subroutine updates the ice shelf mass, as specified by user-provided code. +subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, CS, Time, new_sim) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: mass_shelf !< The ice shelf mass per unit area averaged + !! over the full ocean cell [R Z ~> kg m-2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness [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] + type(user_ice_shelf_CS), pointer :: CS !< A pointer to the user ice shelf control structure + type(time_type), intent(in) :: Time !< The current model time + logical, intent(in) :: new_sim !< If true, this the start of a new run. + + + real :: c1 ! The inverse of the range over which the shelf slopes [km-1] + real :: edge_pos ! The time-evolving position the ice shelf edge [km] + real :: slope_pos ! The time-evolving position of the start of the ice shelf slope [km] + integer :: i, j + + edge_pos = CS%pos_shelf_edge_0 + CS%shelf_speed*(time_type_to_real(Time) / 86400.0) + + slope_pos = edge_pos - CS%flat_shelf_width + c1 = 0.0 ; if (CS%shelf_slope_scale > 0.0) c1 = 1.0 / CS%shelf_slope_scale + + + do j=G%jsd,G%jed + + if (((j+G%jdg_offset) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+G%jdg_offset) >= G%domain%njhalo+1)) then + + do i=G%isc,G%iec + +! if (((i+G%idg_offset) <= G%domain%niglobal+G%domain%nihalo) .AND. & +! ((i+G%idg_offset) >= G%domain%nihalo+1)) then + + if ((j >= G%jsc) .and. (j <= G%jec)) then + if (new_sim) then ; if (G%geoLonCu(i-1,j) >= edge_pos) then + ! Everything past the edge is open ocean. + mass_shelf(i,j) = 0.0 + area_shelf_h(i,j) = 0.0 + hmask (i,j) = 0.0 + h_shelf (i,j) = 0.0 + else + if (G%geoLonCu(i,j) > edge_pos) then + area_shelf_h(i,j) = G%areaT(i,j) * (edge_pos - G%geoLonCu(i-1,j)) / & + (G%geoLonCu(i,j) - G%geoLonCu(i-1,j)) + hmask (i,j) = 2.0 + else + area_shelf_h(i,j) = G%areaT(i,j) + hmask (i,j) = 1.0 + endif + + if (G%geoLonT(i,j) > slope_pos) then + h_shelf (i,j) = CS%min_draft + mass_shelf(i,j) = CS%Rho_ocean * CS%min_draft + else + mass_shelf(i,j) = CS%Rho_ocean * (CS%min_draft + & + (CS%max_draft - CS%min_draft) * & + min(1.0, (c1*(slope_pos - G%geoLonT(i,j)))**2) ) + h_shelf(i,j) = (CS%min_draft + & + (CS%max_draft - CS%min_draft) * & + min(1.0, (c1*(slope_pos - G%geoLonT(i,j)))**2) ) + endif + endif ; endif + endif + + if ((i+G%idg_offset) == G%domain%nihalo+1) then + hmask(i-1,j) = 3.0 + endif + + enddo + endif + enddo + +end subroutine USER_update_shelf_mass + +!> This subroutine writes out the user ice shelf code version number to the model log. +subroutine write_user_log(param_file) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + + character(len=128) :: version = '$Id: user_shelf_init.F90,v 1.1.2.7 2012/06/19 22:15:52 Robert.Hallberg Exp $' + character(len=128) :: tagname = '$Name: MOM_ogrp $' + character(len=40) :: mdl = "user_shelf_init" ! This module's name. + + call log_version(param_file, mdl, version, tagname) + +end subroutine write_user_log + +end module user_shelf_init diff --git a/initialization/MOM_coord_initialization.F90 b/initialization/MOM_coord_initialization.F90 new file mode 100644 index 0000000000..bb7832525f --- /dev/null +++ b/initialization/MOM_coord_initialization.F90 @@ -0,0 +1,610 @@ +!> Initializes fixed aspects of the related to its vertical coordinate. +module MOM_coord_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : chksum +use MOM_EOS, only : calculate_density, EOS_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, read_param, log_param, param_file_type, log_version +use MOM_io, only : create_MOM_file, file_exists +use MOM_io, only : MOM_netCDF_file, MOM_field +use MOM_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc, SINGLE_FILE +use MOM_string_functions, only : slasher, uppercase +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type, setVerticalGridAxes +use user_initialization, only : user_set_coord +use BFB_initialization, only : BFB_set_coord + +implicit none ; private + +public MOM_initialize_coord, write_vertgrid_file + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +character(len=40) :: mdl = "MOM_coord_initialization" !< This module's name. + +contains + +!> MOM_initialize_coord sets up time-invariant quantities related to MOM6's +!! vertical coordinate. +subroutine MOM_initialize_coord(GV, US, PF, tv, max_depth) + type(verticalGrid_type), intent(inout) :: GV !< Ocean vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: PF !< A structure indicating the open file + !! to parse for model parameter values. + type(thermo_var_ptrs), intent(inout) :: tv !< The thermodynamic variable structure. + real, intent(in) :: max_depth !< The ocean's maximum depth [Z ~> m]. + ! Local + character(len=200) :: config + logical :: debug + ! This include declares and sets the variable "version". +# include "version_variable.h" + integer :: nz + + nz = GV%ke + + call callTree_enter("MOM_initialize_coord(), MOM_coord_initialization.F90") + call log_version(PF, mdl, version, "") + call get_param(PF, mdl, "DEBUG", debug, default=.false.) + +! Set-up the layer densities, GV%Rlay, and reduced gravities, GV%g_prime. + call get_param(PF, mdl, "COORD_CONFIG", config, & + "This specifies how layers are to be defined: \n"//& + " \t ALE or none - used to avoid defining layers in ALE mode \n"//& + " \t file - read coordinate information from the file \n"//& + " \t\t specified by (COORD_FILE).\n"//& + " \t BFB - Custom coords for buoyancy-forced basin case \n"//& + " \t\t based on SST_S, T_BOT and DRHO_DT.\n"//& + " \t linear - linear based on interfaces not layers \n"//& + " \t layer_ref - linear based on layer densities \n"//& + " \t ts_ref - use reference temperature and salinity \n"//& + " \t ts_range - use range of temperature and salinity \n"//& + " \t\t (T_REF and S_REF) to determine surface density \n"//& + " \t\t and GINT calculate internal densities. \n"//& + " \t gprime - use reference density (RHO_0) for surface \n"//& + " \t\t density and GINT calculate internal densities. \n"//& + " \t ts_profile - use temperature and salinity profiles \n"//& + " \t\t (read from COORD_FILE) to set layer densities. \n"//& + " \t USER - call a user modified routine.", & + default="none") + select case ( trim(config) ) + case ("gprime") + call set_coord_from_gprime(GV%Rlay, GV%g_prime, GV, US, PF) + case ("layer_ref") + call set_coord_from_layer_density(GV%Rlay, GV%g_prime, GV, US, PF) + case ("linear") + call set_coord_linear(GV%Rlay, GV%g_prime, GV, US, PF) + case ("ts_ref") + call set_coord_from_TS_ref(GV%Rlay, GV%g_prime, GV, US, PF, tv%eqn_of_state, tv%P_Ref) + case ("ts_profile") + call set_coord_from_TS_profile(GV%Rlay, GV%g_prime, GV, US, PF, tv%eqn_of_state, tv%P_Ref) + case ("ts_range") + call set_coord_from_TS_range(GV%Rlay, GV%g_prime, GV, US, PF, tv%eqn_of_state, tv%P_Ref) + case ("file") + call set_coord_from_file(GV%Rlay, GV%g_prime, GV, US, PF) + case ("USER") + call user_set_coord(GV%Rlay, GV%g_prime, GV, US, PF) + case ("BFB") + call BFB_set_coord(GV%Rlay, GV%g_prime, GV, US, PF) + case ("none", "ALE") + call set_coord_to_none(GV%Rlay, GV%g_prime, GV, US, PF) + case default ; call MOM_error(FATAL,"MOM_initialize_coord: "// & + "Unrecognized coordinate setup"//trim(config)) + end select + ! There are nz+1 values of g_prime because it is an interface field, but the value at the bottom + ! should not matter. This is here just to avoid having an uninitialized value in some output. + GV%g_prime(nz+1) = 10.0*GV%g_Earth + + if (debug) call chksum(US%R_to_kg_m3*GV%Rlay(:), "MOM_initialize_coord: Rlay ", 1, nz) + if (debug) call chksum(US%m_to_Z*US%L_to_m**2*US%s_to_T**2*GV%g_prime(:), "MOM_initialize_coord: g_prime ", 1, nz) + call setVerticalGridAxes( GV%Rlay, GV, scale=US%R_to_kg_m3 ) + + ! Copy the maximum depth across from the input argument + GV%max_depth = max_depth + + call callTree_leave('MOM_initialize_coord()') + +end subroutine MOM_initialize_coord + +! The set_coord routines deal with initializing aspects of the vertical grid. + +!> Sets the layer densities (Rlay) and the interface reduced gravities (g). +subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(GV%ke), intent(out) :: Rlay !< The layers' target coordinate values + !! (potential density) [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + ! Local variables + real :: g_int ! Reduced gravities across the internal interfaces [L2 Z-1 T-2 ~> m s-2]. + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + real :: Rlay_Ref ! The target density of the surface layer [R ~> kg m-3]. + character(len=40) :: mdl = "set_coord_from_gprime" ! This subroutine's name. + integer :: k, nz + nz = GV%ke + + call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") + + call get_param(param_file, mdl, "GFS" , g_fs, & + "The reduced gravity at the free surface.", units="m s-2", & + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "GINT", g_int, & + "The reduced gravity across internal interfaces.", & + units="m s-2", fail_if_missing=.true., scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) + + g_prime(1) = g_fs + do k=2,nz ; g_prime(k) = g_int ; enddo + Rlay(1) = Rlay_Ref + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + else + do k=2,nz + Rlay(k) = Rlay(k-1) * ((GV%g_Earth + 0.5*g_prime(k)) / (GV%g_Earth - 0.5*g_prime(k))) + enddo + endif + + call callTree_leave(trim(mdl)//'()') + +end subroutine set_coord_from_gprime + +!> Sets the layer densities (Rlay) and the interface reduced gravities (g). +subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(GV%ke), intent(out) :: Rlay !< The layers' target coordinate values + !! (potential density) [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + + ! Local variables + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + real :: Rlay_Ref! The surface layer's target density [R ~> kg m-3]. + real :: RLay_range ! The range of densities [R ~> kg m-3]. + character(len=40) :: mdl = "set_coord_from_layer_density" ! This subroutine's name. + integer :: k, nz + nz = GV%ke + + call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") + + call get_param(param_file, mdl, "GFS", g_fs, & + "The reduced gravity at the free surface.", units="m s-2", & + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "DENSITY_RANGE", Rlay_range, & + "The range of reference potential densities in the layers.", & + units="kg m-3", default=2.0, scale=US%kg_m3_to_R) + + Rlay(1) = Rlay_Ref + do k=2,nz + Rlay(k) = Rlay(k-1) + RLay_range/(real(nz-1)) + enddo +! These statements set the interface reduced gravities. ! + g_prime(1) = g_fs + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif + + call callTree_leave(trim(mdl)//'()') +end subroutine set_coord_from_layer_density + +!> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a profile of g'. +subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state, P_Ref) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(GV%ke), intent(out) :: Rlay !< The layers' target coordinate values + !! (potential density) [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + real, intent(in) :: P_Ref !< The coordinate-density reference pressure + !! [R L2 T-2 ~> Pa]. + + ! Local variables + real :: T_ref ! Reference temperature [C ~> degC] + real :: S_ref ! Reference salinity [S ~> ppt] + real :: g_int ! Reduced gravities across the internal interfaces [L2 Z-1 T-2 ~> m s-2]. + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + character(len=40) :: mdl = "set_coord_from_TS_ref" ! This subroutine's name. + integer :: k, nz + nz = GV%ke + + call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") + + call get_param(param_file, mdl, "T_REF", T_ref, & + "The initial temperature of the lightest layer.", & + units="degC", scale=US%degC_to_C, fail_if_missing=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + "The initial salinities.", units="ppt", default=35.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "GFS", g_fs, & + "The reduced gravity at the free surface.", units="m s-2", & + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "GINT", g_int, & + "The reduced gravity across internal interfaces.", & + units="m s-2", fail_if_missing=.true., scale=US%m_s_to_L_T**2*US%Z_to_m) + +! These statements set the interface reduced gravities. ! + g_prime(1) = g_fs + do k=2,nz ; g_prime(k) = g_int ; enddo + +! The uppermost layer's density is set here. Subsequent layers' ! +! densities are determined from this value and the g values. ! +! T0 = 28.228 ; S0 = 34.5848 ; Pref = P_Ref + call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state) + +! These statements set the layer densities. ! + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + else + do k=2,nz + Rlay(k) = Rlay(k-1) * ((GV%g_Earth + 0.5*g_prime(k)) / (GV%g_Earth - 0.5*g_prime(k))) + enddo + endif + + call callTree_leave(trim(mdl)//'()') +end subroutine set_coord_from_TS_ref + +!> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a T-S profile. +subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_state, P_Ref) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + real, intent(in) :: P_Ref !< The coordinate-density reference pressure + !! [R L2 T-2 ~> Pa]. + + ! Local variables + real, dimension(GV%ke) :: T0 ! A profile of temperatures [C ~> degC] + real, dimension(GV%ke) :: S0 ! A profile of salinities [S ~> ppt] + real, dimension(GV%ke) :: Pref ! A array of reference pressures [R L2 T-2 ~> Pa] + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + integer :: k, nz + character(len=40) :: mdl = "set_coord_from_TS_profile" ! This subroutine's name. + character(len=200) :: filename, coord_file, inputdir ! Strings for file/path + character(len=64) :: temp_var, salt_var ! Temperature and salinity names in files + + nz = GV%ke + + call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") + + call get_param(param_file, mdl, "GFS", g_fs, & + "The reduced gravity at the free surface.", units="m s-2", & + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "COORD_FILE", coord_file, & + "The file from which the coordinate temperatures and salinities are read.", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "TEMP_COORD_VAR", temp_var, & + "The coordinate reference profile variable name for potential temperature.", & + default="PTEMP") + call get_param(param_file, mdl, "SALT_COORD_VAR", salt_var, & + "The coordinate reference profile variable name for salinity.", & + default="SALT") + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + filename = trim(slasher(inputdir))//trim(coord_file) + call log_param(param_file, mdl, "INPUTDIR/COORD_FILE", filename) + + call MOM_read_data(filename, temp_var, T0(:), scale=US%degC_to_C) + call MOM_read_data(filename, salt_var, S0(:), scale=US%ppt_to_S) + + if (.not.file_exists(filename)) call MOM_error(FATAL, & + " set_coord_from_TS_profile: Unable to open " //trim(filename)) +! These statements set the interface reduced gravities. ! + g_prime(1) = g_fs + do k=1,nz ; Pref(k) = P_Ref ; enddo + call calculate_density(T0, S0, Pref, Rlay, eqn_of_state, (/1,nz/) ) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif + + call callTree_leave(trim(mdl)//'()') +end subroutine set_coord_from_TS_profile + +!> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a linear T-S profile. +subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_state, P_Ref) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + real, intent(in) :: P_Ref !< The coordinate-density reference pressure + !! [R L2 T-2 ~> Pa]. + + ! Local variables + real, dimension(GV%ke) :: T0 ! A profile of temperatures [C ~> degC] + real, dimension(GV%ke) :: S0 ! A profile of salinities [S ~> ppt] + real, dimension(GV%ke) :: Pref ! A array of reference pressures [R L2 T-2 ~> Pa] + real :: S_Ref ! Default salinity range parameters [S ~> ppt]. + real :: T_Ref ! Default temperature range parameters [C ~> degC]. + real :: S_Light, S_Dense ! Salinity range parameters [S ~> ppt]. + real :: T_Light, T_Dense ! Temperature range parameters [C ~> degC]. + real :: res_rat ! The ratio of density space resolution in the denser part + ! of the range to that in the lighter part of the range. + ! Setting this greater than 1 increases the resolution for + ! the denser water [nondim]. + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + real :: a1, frac_dense, k_frac ! Nondimensional temporary variables [nondim] + integer :: k, nz, k_light + character(len=40) :: mdl = "set_coord_from_TS_range" ! This subroutine's name. + + nz = GV%ke + + call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") + + call get_param(param_file, mdl, "T_REF", T_Ref, & + "The default initial temperatures.", & + units="degC", default=10.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "TS_RANGE_T_LIGHT", T_Light, & + "The initial temperature of the lightest layer when "//& + "COORD_CONFIG is set to ts_range.", & + units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C) + call get_param(param_file, mdl, "TS_RANGE_T_DENSE", T_Dense, & + "The initial temperature of the densest layer when "//& + "COORD_CONFIG is set to ts_range.", & + units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C) + + call get_param(param_file, mdl, "S_REF", S_Ref, & + "The default initial salinities.", & + units="ppt", default=35.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_Light, & + "The initial lightest salinities when COORD_CONFIG is set to ts_range.", & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S) + call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_Dense, & + "The initial densest salinities when COORD_CONFIG is set to ts_range.", & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S) + + call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, & + "The ratio of density space resolution in the densest "//& + "part of the range to that in the lightest part of the "//& + "range when COORD_CONFIG is set to ts_range. Values "//& + "greater than 1 increase the resolution of the denser water.",& + default=1.0, units="nondim") + + call get_param(param_file, mdl, "GFS", g_fs, & + "The reduced gravity at the free surface.", units="m s-2", & + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) + + if ((GV%nk_rho_varies > 0) .and. (nz < GV%nk_rho_varies+2)) & + call MOM_error(FATAL, "set_coord_from_TS_range requires that NZ >= NKML+NKBL+2.") + + k_light = GV%nk_rho_varies + 1 + + ! Set T0(k) to range from T_LIGHT to T_DENSE, and similarly for S0(k). + T0(k_light) = T_Light ; S0(k_light) = S_Light + a1 = 2.0 * res_rat / (1.0 + res_rat) + do k=k_light+1,nz + k_frac = real(k-k_light)/real(nz-k_light) + frac_dense = a1 * k_frac + (1.0 - a1) * k_frac**2 + T0(k) = frac_dense * (T_Dense - T_Light) + T_Light + S0(k) = frac_dense * (S_Dense - S_Light) + S_Light + enddo + + g_prime(1) = g_fs + do k=1,nz ; Pref(k) = P_Ref ; enddo + call calculate_density(T0, S0, Pref, Rlay, eqn_of_state, (/k_light,nz/) ) + ! Extrapolate target densities for the variable density mixed and buffer layers. + do k=k_light-1,1,-1 + Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) + enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif + + call callTree_leave(trim(mdl)//'()') +end subroutine set_coord_from_TS_range + +! Sets the layer densities (Rlay) and the interface reduced gravities (g) from data in file. +subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + + ! Local variables + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + integer :: k, nz + character(len=40) :: mdl = "set_coord_from_file" ! This subroutine's name. + character(len=40) :: coord_var + character(len=200) :: filename,coord_file,inputdir ! Strings for file/path + nz = GV%ke + + call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") + + call get_param(param_file, mdl, "GFS", g_fs, & + "The reduced gravity at the free surface.", units="m s-2", & + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "COORD_FILE", coord_file, & + "The file from which the coordinate densities are read.", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "COORD_VAR", coord_var, & + "The variable in COORD_FILE that is to be used for the "//& + "coordinate densities.", default="Layer") + filename = trim(inputdir)//trim(coord_file) + call log_param(param_file, mdl, "INPUTDIR/COORD_FILE", filename) + if (.not.file_exists(filename)) call MOM_error(FATAL, & + " set_coord_from_file: Unable to open "//trim(filename)) + + call MOM_read_data(filename, coord_var, Rlay, scale=US%kg_m3_to_R) + g_prime(1) = g_fs + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif + do k=1,nz ; if (g_prime(k) <= 0.0) then + call MOM_error(FATAL, "MOM_initialization set_coord_from_file: "//& + "Zero or negative g_primes read from variable "//"Layer"//" in file "//& + trim(filename)) + endif ; enddo + + call callTree_leave(trim(mdl)//'()') +end subroutine set_coord_from_file + +!> Sets the layer densities (Rlay) and the interface +!! reduced gravities (g) according to a linear profile starting at a +!! reference surface layer density and spanning a range of densities +!! to the bottom defined by the parameter RLAY_RANGE +!! (defaulting to 2.0 if not defined) +subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + + ! Local variables + character(len=40) :: mdl = "set_coord_linear" ! This subroutine + real :: Rlay_ref, Rlay_range ! A reference density and its range [R ~> kg m-3] + real :: g_fs ! The reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2] + integer :: k, nz + nz = GV%ke + + call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") + + call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for the surface interface.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "DENSITY_RANGE", Rlay_range, & + "The range of reference potential densities across all interfaces.", & + units="kg m-3", default=2.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "GFS", g_fs, & + "The reduced gravity at the free surface.", units="m s-2", & + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) + + ! This following sets the target layer densities such that the + ! surface interface has density Rlay_ref and the bottom + ! is Rlay_range larger + do k=1,nz + Rlay(k) = Rlay_Ref + RLay_range*((real(k)-0.5)/real(nz)) + enddo + ! These statements set the interface reduced gravities. + g_prime(1) = g_fs + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif + + call callTree_leave(trim(mdl)//'()') +end subroutine set_coord_linear + +!> Sets Rlay to Rho0 and g_prime to zero except for the free surface. +!! This is for use only in ALE mode where Rlay should not be used and g_prime(1) alone +!! might be used. +subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + ! Local variables + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + real :: Rlay_Ref ! The target density of the surface layer [R ~> kg m-3]. + character(len=40) :: mdl = "set_coord_to_none" ! This subroutine's name. + integer :: k, nz + nz = GV%ke + + call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") + + call get_param(param_file, mdl, "GFS" , g_fs, & + "The reduced gravity at the free surface.", units="m s-2", & + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) + + g_prime(1) = g_fs + do k=2,nz ; g_prime(k) = 0. ; enddo + Rlay(1) = Rlay_Ref + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + else + do k=2,nz + Rlay(k) = Rlay(k-1) * ((GV%g_Earth + 0.5*g_prime(k)) / (GV%g_Earth - 0.5*g_prime(k))) + enddo + endif + + call callTree_leave(trim(mdl)//'()') + +end subroutine set_coord_to_none + +!> Writes out a file containing any available data related +!! to the vertical grid used by the MOM ocean model. +subroutine write_vertgrid_file(GV, US, param_file, directory) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + character(len=*), intent(in) :: directory !< The directory into which to place the file. + ! Local variables + character(len=240) :: filepath + type(vardesc) :: vars(2) + type(MOM_field) :: fields(2) + type(MOM_netCDF_file) :: IO_handle ! The I/O handle of the fileset + + filepath = trim(directory) // trim("Vertical_coordinate.nc") + + vars(1) = var_desc("R","kilogram meter-3","Target Potential Density",'1','L','1') + vars(2) = var_desc("g","meter second-2","Reduced gravity",'1','i','1') + + call create_MOM_file(IO_handle, trim(filepath), vars, 2, fields, & + SINGLE_FILE, GV=GV) + + call MOM_write_field(IO_handle, fields(1), GV%Rlay, scale=US%R_to_kg_m3) + call MOM_write_field(IO_handle, fields(2), GV%g_prime, scale=US%L_T_to_m_s**2*US%m_to_Z) + + call IO_handle%close() + +end subroutine write_vertgrid_file + +end module MOM_coord_initialization diff --git a/initialization/MOM_fixed_initialization.F90 b/initialization/MOM_fixed_initialization.F90 new file mode 100644 index 0000000000..322abc6d5e --- /dev/null +++ b/initialization/MOM_fixed_initialization.F90 @@ -0,0 +1,261 @@ +!> Initializes fixed aspects of the model, such as horizontal grid metrics, +!! topography and Coriolis. +module MOM_fixed_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : hchksum, qchksum, uvchksum +use MOM_domains, only : pass_var +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, read_param, log_param, param_file_type +use MOM_file_parser, only : log_version +use MOM_io, only : slasher +use MOM_grid_initialize, only : initialize_masks, set_grid_metrics +use MOM_open_boundary, only : ocean_OBC_type +use MOM_open_boundary, only : open_boundary_config, open_boundary_query +use MOM_open_boundary, only : open_boundary_impose_normal_slope +use MOM_open_boundary, only : open_boundary_impose_land_mask +use MOM_shared_initialization, only : MOM_initialize_rotation, MOM_calculate_grad_Coriolis +use MOM_shared_initialization, only : initialize_topography_from_file, apply_topography_edits_from_file +use MOM_shared_initialization, only : initialize_topography_named, limit_topography, diagnoseMaximumDepth +use MOM_shared_initialization, only : set_rotation_planetary, set_rotation_beta_plane, initialize_grid_rotation_angle +use MOM_shared_initialization, only : reset_face_lengths_named, reset_face_lengths_file, reset_face_lengths_list +use MOM_shared_initialization, only : read_face_length_list, set_velocity_depth_max, set_velocity_depth_min +use MOM_shared_initialization, only : set_subgrid_topo_at_vel_from_file +use MOM_shared_initialization, only : compute_global_grid_integrals, write_ocean_geometry_file +use MOM_unit_scaling, only : unit_scale_type + +use user_initialization, only : user_initialize_topography +use DOME_initialization, only : DOME_initialize_topography +use ISOMIP_initialization, only : ISOMIP_initialize_topography +use basin_builder, only : basin_builder_topography +use benchmark_initialization, only : benchmark_initialize_topography +use Neverworld_initialization, only : Neverworld_initialize_topography +use DOME2d_initialization, only : DOME2d_initialize_topography +use Kelvin_initialization, only : Kelvin_initialize_topography +use sloshing_initialization, only : sloshing_initialize_topography +use seamount_initialization, only : seamount_initialize_topography +use dumbbell_initialization, only : dumbbell_initialize_topography +use shelfwave_initialization, only : shelfwave_initialize_topography +use Phillips_initialization, only : Phillips_initialize_topography +use dense_water_initialization, only : dense_water_initialize_topography + +implicit none ; private + +public MOM_initialize_fixed, MOM_initialize_rotation, MOM_initialize_topography + +contains + +! ----------------------------------------------------------------------------- +!> MOM_initialize_fixed sets up time-invariant quantities related to MOM6's +!! horizontal grid, bathymetry, and the Coriolis parameter. +subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) + type(dyn_horgrid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure. + type(param_file_type), intent(in) :: PF !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: write_geom !< If true, write grid geometry files. + character(len=*), intent(in) :: output_dir !< The directory into which to write files. + + ! Local + character(len=200) :: inputdir ! The directory where NetCDF input files are. + character(len=200) :: config + logical :: read_porous_file + character(len=40) :: mdl = "MOM_fixed_initialization" ! This module's name. + logical :: debug +! This include declares and sets the variable "version". +#include "version_variable.h" + + call callTree_enter("MOM_initialize_fixed(), MOM_fixed_initialization.F90") + call log_version(PF, mdl, version, "") + call get_param(PF, mdl, "DEBUG", debug, default=.false.) + + call get_param(PF, mdl, "INPUTDIR", inputdir, & + "The directory in which input files are found.", default=".") + inputdir = slasher(inputdir) + + ! Set up the parameters of the physical domain (i.e. the grid), G + call set_grid_metrics(G, PF, US) + + ! Set up the bottom depth, G%bathyT either analytically or from file + ! This also sets G%max_depth based on the input parameter MAXIMUM_DEPTH, + ! or, if absent, is diagnosed as G%max_depth = max( G%D(:,:) ) + call MOM_initialize_topography(G%bathyT, G%max_depth, G, PF, US) + + ! To initialize masks, the bathymetry in halo regions must be filled in + call pass_var(G%bathyT, G%Domain) + + ! Determine the position of any open boundaries + call open_boundary_config(G, US, PF, OBC) + + ! Make bathymetry consistent with open boundaries + call open_boundary_impose_normal_slope(OBC, G, G%bathyT) + + ! This call sets masks that prohibit flow over any point interpreted as land + call initialize_masks(G, PF, US) + + ! Make OBC mask consistent with land mask + call open_boundary_impose_land_mask(OBC, G, G%areaCu, G%areaCv, US) + + if (debug) then + call hchksum(G%bathyT, 'MOM_initialize_fixed: depth ', G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(G%mask2dT, 'MOM_initialize_fixed: mask2dT ', G%HI) + call uvchksum('MOM_initialize_fixed: mask2dC[uv]', G%mask2dCu, & + G%mask2dCv, G%HI) + call qchksum(G%mask2dBu, 'MOM_initialize_fixed: mask2dBu ', G%HI) + endif + + ! Modulate geometric scales according to geography. + call get_param(PF, mdl, "CHANNEL_CONFIG", config, & + "A parameter that determines which set of channels are \n"//& + "restricted to specific widths. Options are:\n"//& + " \t none - All channels have the grid width.\n"//& + " \t global_1deg - Sets 16 specific channels appropriate \n"//& + " \t\t for a 1-degree model, as used in CM2G.\n"//& + " \t list - Read the channel locations and widths from a \n"//& + " \t\t text file, like MOM_channel_list in the MOM_SIS \n"//& + " \t\t test case.\n"//& + " \t file - Read open face widths everywhere from a \n"//& + " \t\t NetCDF file on the model grid.", & + default="none") + select case ( trim(config) ) + case ("none") + case ("list") ; call reset_face_lengths_list(G, PF, US) + case ("file") ; call reset_face_lengths_file(G, PF, US) + case ("global_1deg") ; call reset_face_lengths_named(G, PF, trim(config), US) + case default ; call MOM_error(FATAL, "MOM_initialize_fixed: "// & + "Unrecognized channel configuration "//trim(config)) + end select + + ! This call sets the topography at velocity points. + if (G%bathymetry_at_vel) then + call get_param(PF, mdl, "VELOCITY_DEPTH_CONFIG", config, & + "A string that determines how the topography is set at "//& + "velocity points. This may be 'min' or 'max'.", & + default="max") + select case ( trim(config) ) + case ("max") ; call set_velocity_depth_max(G) + case ("min") ; call set_velocity_depth_min(G) + case default ; call MOM_error(FATAL, "MOM_initialize_fixed: "// & + "Unrecognized velocity depth configuration "//trim(config)) + end select + endif + + ! Read sub-grid scale topography parameters at velocity points used for porous barrier calculation + call get_param(PF, mdl, "SUBGRID_TOPO_AT_VEL", read_porous_file, & + "If true, use variables from TOPO_AT_VEL_FILE as parameters for porous barrier.", & + default=.False.) + if (read_porous_file) & + call set_subgrid_topo_at_vel_from_file(G, PF, US) + +! Calculate the value of the Coriolis parameter at the latitude ! +! of the q grid points [T-1 ~> s-1]. + call MOM_initialize_rotation(G%CoriolisBu, G, PF, US=US) +! Calculate the components of grad f (beta) + call MOM_calculate_grad_Coriolis(G%dF_dx, G%dF_dy, G, US=US) + if (debug) then + call qchksum(G%CoriolisBu, "MOM_initialize_fixed: f ", G%HI, scale=US%s_to_T) + call hchksum(G%dF_dx, "MOM_initialize_fixed: dF_dx ", G%HI, scale=US%m_to_L*US%s_to_T) + call hchksum(G%dF_dy, "MOM_initialize_fixed: dF_dy ", G%HI, scale=US%m_to_L*US%s_to_T) + endif + + call initialize_grid_rotation_angle(G, PF) + +! Compute global integrals of grid values for later use in scalar diagnostics ! + call compute_global_grid_integrals(G, US=US) + +! Write out all of the grid data used by this run. + if (write_geom) call write_ocean_geometry_file(G, PF, output_dir, US=US) + + call callTree_leave('MOM_initialize_fixed()') + +end subroutine MOM_initialize_fixed + +!> MOM_initialize_topography makes the appropriate call to set up the bathymetry in units of [Z ~> m]. +subroutine MOM_initialize_topography(D, max_depth, G, PF, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: PF !< Parameter file structure + real, intent(out) :: max_depth !< Maximum depth of model [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! This subroutine makes the appropriate call to set up the bottom depth. + ! This is a separate subroutine so that it can be made public and shared with + ! the ice-sheet code or other components. + + ! Local variables + character(len=40) :: mdl = "MOM_initialize_topography" ! This subroutine's name. + character(len=200) :: config + + call get_param(PF, mdl, "TOPO_CONFIG", config, & + "This specifies how bathymetry is specified: \n"//& + " \t file - read bathymetric information from the file \n"//& + " \t\t specified by (TOPO_FILE).\n"//& + " \t flat - flat bottom set to MAXIMUM_DEPTH. \n"//& + " \t bowl - an analytically specified bowl-shaped basin \n"//& + " \t\t ranging between MAXIMUM_DEPTH and MINIMUM_DEPTH. \n"//& + " \t spoon - a similar shape to 'bowl', but with an vertical \n"//& + " \t\t wall at the southern face. \n"//& + " \t halfpipe - a zonally uniform channel with a half-sine \n"//& + " \t\t profile in the meridional direction. \n"//& + " \t bbuilder - build topography from list of functions. \n"//& + " \t benchmark - use the benchmark test case topography. \n"//& + " \t Neverworld - use the Neverworld test case topography. \n"//& + " \t DOME - use a slope and channel configuration for the \n"//& + " \t\t DOME sill-overflow test case. \n"//& + " \t ISOMIP - use a slope and channel configuration for the \n"//& + " \t\t ISOMIP test case. \n"//& + " \t DOME2D - use a shelf and slope configuration for the \n"//& + " \t\t DOME2D gravity current/overflow test case. \n"//& + " \t Kelvin - flat but with rotated land mask.\n"//& + " \t seamount - Gaussian bump for spontaneous motion test case.\n"//& + " \t dumbbell - Sloshing channel with reservoirs on both ends.\n"//& + " \t shelfwave - exponential slope for shelfwave test case.\n"//& + " \t Phillips - ACC-like idealized topography used in the Phillips config.\n"//& + " \t dense - Denmark Strait-like dense water formation and overflow.\n"//& + " \t USER - call a user modified routine.", & + fail_if_missing=.true.) + call get_param(PF, mdl, "MAXIMUM_DEPTH", max_depth, units="m", default=-1.e9, scale=US%m_to_Z, do_not_log=.true.) + select case ( trim(config) ) + case ("file"); call initialize_topography_from_file(D, G, PF, US) + case ("flat"); call initialize_topography_named(D, G, PF, config, max_depth, US) + case ("spoon"); call initialize_topography_named(D, G, PF, config, max_depth, US) + case ("bowl"); call initialize_topography_named(D, G, PF, config, max_depth, US) + case ("halfpipe"); call initialize_topography_named(D, G, PF, config, max_depth, US) + case ("DOME"); call DOME_initialize_topography(D, G, PF, max_depth, US) + case ("ISOMIP"); call ISOMIP_initialize_topography(D, G, PF, max_depth, US) + case ("bbuilder"); call basin_builder_topography(D, G, PF, max_depth) + case ("benchmark"); call benchmark_initialize_topography(D, G, PF, max_depth, US) + case ("Neverworld","Neverland"); call Neverworld_initialize_topography(D, G, PF, max_depth) + case ("DOME2D"); call DOME2d_initialize_topography(D, G, PF, max_depth) + case ("Kelvin"); call Kelvin_initialize_topography(D, G, PF, max_depth, US) + case ("sloshing"); call sloshing_initialize_topography(D, G, PF, max_depth) + case ("seamount"); call seamount_initialize_topography(D, G, PF, max_depth) + case ("dumbbell"); call dumbbell_initialize_topography(D, G, PF, max_depth) + case ("shelfwave"); call shelfwave_initialize_topography(D, G, PF, max_depth, US) + case ("Phillips"); call Phillips_initialize_topography(D, G, PF, max_depth, US) + case ("dense"); call dense_water_initialize_topography(D, G, PF, max_depth) + case ("USER"); call user_initialize_topography(D, G, PF, max_depth, US) + case default ; call MOM_error(FATAL,"MOM_initialize_topography: "// & + "Unrecognized topography setup '"//trim(config)//"'") + end select + if (max_depth>0.) then + call log_param(PF, mdl, "MAXIMUM_DEPTH", max_depth, & + "The maximum depth of the ocean.", units="m", unscale=US%Z_to_m) + else + max_depth = diagnoseMaximumDepth(D,G) + call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth, & + "The (diagnosed) maximum depth of the ocean.", & + units="m", unscale=US%Z_to_m, like_default=.true.) + endif + if (trim(config) /= "DOME") then + call limit_topography(D, G, PF, max_depth, US) + endif + +end subroutine MOM_initialize_topography + +end module MOM_fixed_initialization diff --git a/initialization/MOM_grid_initialize.F90 b/initialization/MOM_grid_initialize.F90 new file mode 100644 index 0000000000..8bea8fe6e9 --- /dev/null +++ b/initialization/MOM_grid_initialize.F90 @@ -0,0 +1,1287 @@ +!> Initializes horizontal grid +module MOM_grid_initialize + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_checksums, only : hchksum, Bchksum, uvchksum, hchksum_pair, Bchksum_pair +use MOM_domains, only : pass_var, pass_vector, pe_here, root_PE, broadcast +use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All, Scalar_Pair +use MOM_domains, only : To_North, To_South, To_East, To_West +use MOM_domains, only : MOM_domain_type, clone_MOM_domain, deallocate_MOM_domain +use MOM_dyn_horgrid, only : dyn_horgrid_type, set_derived_dyn_horgrid +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_io, only : MOM_read_data, slasher, file_exists, stdout +use MOM_io, only : CORNER, NORTH_FACE, EAST_FACE +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +public set_grid_metrics, initialize_masks, Adcroft_reciprocal + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Global positioning system (aka container for information to describe the grid) +type, private :: GPS ; private + real :: len_lon !< The longitudinal or x-direction length of the domain [degrees_E] or [km] or [m]. + real :: len_lat !< The latitudinal or y-direction length of the domain [degrees_N] or [km] or [m]. + real :: west_lon !< The western longitude of the domain or the equivalent + !! starting value for the x-axis [degrees_E] or [km] or [m]. + real :: south_lat !< The southern latitude of the domain or the equivalent + !! starting value for the y-axis [degrees_N] or [km] or [m]. + real :: Rad_Earth_L !< The radius of the Earth in rescaled units [L ~> m] + real :: Lat_enhance_factor !< The amount by which the meridional resolution + !! is enhanced within LAT_EQ_ENHANCE of the equator [nondim] + real :: Lat_eq_enhance !< The latitude range to the north and south of the equator + !! over which the resolution is enhanced [degrees_N] + logical :: isotropic !< If true, an isotropic grid on a sphere (also known as a Mercator grid) + !! is used. With an isotropic grid, the meridional extent of the domain + !! (LENLAT), the zonal extent (LENLON), and the number of grid points in each + !! direction are _not_ independent. In MOM the meridional extent is determined + !! to fit the zonal extent and the number of grid points, while grid is + !! perfectly isotropic. + logical :: equator_reference !< If true, the grid is defined to have the equator at the + !! nearest q- or h- grid point to (-LOWLAT*NJGLOBAL/LENLAT). + integer :: niglobal !< The number of i-points in the global grid computational domain + integer :: njglobal !< The number of j-points in the global grid computational domain +end type GPS + +contains + +!> set_grid_metrics is used to set the primary values in the model's horizontal +!! grid. The bathymetry, land-sea mask and any restricted channel widths are +!! not known yet, so these are set later. +subroutine set_grid_metrics(G, param_file, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + ! This include declares and sets the variable "version". +# include "version_variable.h" + logical :: debug + character(len=256) :: config + + call callTree_enter("set_grid_metrics(), MOM_grid_initialize.F90") + call log_version(param_file, "MOM_grid_init", version, "") + call get_param(param_file, "MOM_grid_init", "GRID_CONFIG", config, & + "A character string that determines the method for "//& + "defining the horizontal grid. Current options are: \n"//& + " \t mosaic - read the grid from a mosaic (supergrid) \n"//& + " \t file set by GRID_FILE.\n"//& + " \t cartesian - use a (flat) Cartesian grid.\n"//& + " \t spherical - use a simple spherical grid.\n"//& + " \t mercator - use a Mercator spherical grid.", & + fail_if_missing=.true.) + call get_param(param_file, "MOM_grid_init", "DEBUG", debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + + ! These are defaults that may be changed in the next select block. + G%x_axis_units = "degrees_east" ; G%y_axis_units = "degrees_north" + G%x_ax_unit_short = "degrees_E" ; G%y_ax_unit_short = "degrees_N" + + G%Rad_Earth_L = -1.0*US%m_to_L ; G%len_lat = 0.0 ; G%len_lon = 0.0 + select case (trim(config)) + case ("mosaic"); call set_grid_metrics_from_mosaic(G, param_file, US) + case ("cartesian"); call set_grid_metrics_cartesian(G, param_file, US) + case ("spherical"); call set_grid_metrics_spherical(G, param_file, US) + case ("mercator"); call set_grid_metrics_mercator(G, param_file, US) + case ("file"); call MOM_error(FATAL, "MOM_grid_init: set_grid_metrics "//& + 'GRID_CONFIG "file" is no longer a supported option. Use a '//& + 'mosaic file ("mosaic") or one of the analytic forms instead.') + case default ; call MOM_error(FATAL, "MOM_grid_init: set_grid_metrics "//& + "Unrecognized grid configuration "//trim(config)) + end select + if (G%Rad_Earth_L <= 0.0) then + ! The grid metrics were set with an option that does not explicitly initialize Rad_Earth. + call get_param(param_file, "MOM_grid_init", "RAD_EARTH", G%Rad_Earth_L, & + "The radius of the Earth.", units="m", default=6.378e6, scale=US%m_to_L) + endif + G%Rad_Earth = US%L_to_m*G%Rad_Earth_L + + ! Calculate derived metrics (i.e. reciprocals and products) + call callTree_enter("set_derived_metrics(), MOM_grid_initialize.F90") + call set_derived_dyn_horgrid(G, US) + call callTree_leave("set_derived_metrics()") + + if (debug) call grid_metrics_chksum('MOM_grid_init/set_grid_metrics', G, US) + + call callTree_leave("set_grid_metrics()") +end subroutine set_grid_metrics + +! ------------------------------------------------------------------------------ + +!> grid_metrics_chksum performs a set of checksums on metrics on the grid for +!! debugging. +subroutine grid_metrics_chksum(parent, G, US) + character(len=*), intent(in) :: parent !< A string identifying the caller + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + integer :: halo + + halo = min(G%ied-G%iec, G%jed-G%jec, 1) + + call hchksum_pair(trim(parent)//': d[xy]T', G%dxT, G%dyT, G%HI, & + haloshift=halo, scale=US%L_to_m, scalar_pair=.true.) + + call uvchksum(trim(parent)//': dxC[uv]', G%dxCu, G%dyCv, G%HI, haloshift=halo, scale=US%L_to_m) + + call uvchksum(trim(parent)//': dxC[uv]', G%dyCu, G%dxCv, G%HI, haloshift=halo, scale=US%L_to_m) + + call Bchksum_pair(trim(parent)//': dxB[uv]', G%dxBu, G%dyBu, G%HI, haloshift=halo, scale=US%L_to_m) + + call hchksum_pair(trim(parent)//': Id[xy]T', G%IdxT, G%IdyT, G%HI, & + haloshift=halo, scale=US%m_to_L, scalar_pair=.true.) + + call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdxCu, G%IdyCv, G%HI, haloshift=halo, scale=US%m_to_L) + + call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdyCu, G%IdxCv, G%HI, haloshift=halo, scale=US%m_to_L) + + call Bchksum_pair(trim(parent)//': Id[xy]B[uv]', G%IdxBu, G%IdyBu, G%HI, haloshift=halo, scale=US%m_to_L) + + call hchksum(G%areaT, trim(parent)//': areaT',G%HI, haloshift=halo, scale=US%L_to_m**2) + call Bchksum(G%areaBu, trim(parent)//': areaBu',G%HI, haloshift=halo, scale=US%L_to_m**2) + + call hchksum(G%IareaT, trim(parent)//': IareaT',G%HI, haloshift=halo, scale=US%m_to_L**2) + call Bchksum(G%IareaBu, trim(parent)//': IareaBu',G%HI, haloshift=halo, scale=US%m_to_L**2) + + call hchksum(G%geoLonT,trim(parent)//': geoLonT',G%HI, haloshift=halo) + call hchksum(G%geoLatT,trim(parent)//': geoLatT',G%HI, haloshift=halo) + + call Bchksum(G%geoLonBu, trim(parent)//': geoLonBu',G%HI, haloshift=halo) + call Bchksum(G%geoLatBu, trim(parent)//': geoLatBu',G%HI, haloshift=halo) + + call uvchksum(trim(parent)//': geoLonC[uv]', G%geoLonCu, G%geoLonCv, G%HI, haloshift=halo) + + call uvchksum(trim(parent)//': geoLatC[uv]', G%geoLatCu, G%geoLatCv, G%HI, haloshift=halo) + +end subroutine grid_metrics_chksum + +! ------------------------------------------------------------------------------ + +!> Sets the grid metrics from a mosaic file. +subroutine set_grid_metrics_from_mosaic(G, param_file, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + ! These are symmetric arrays, corresponding to the data in the mosaic file + real, dimension(2*G%isd-2:2*G%ied+1,2*G%jsd-2:2*G%jed+1) :: tmpT ! Areas [L2 ~> m2] + real, dimension(2*G%isd-3:2*G%ied+1,2*G%jsd-2:2*G%jed+1) :: tmpU ! East face supergrid spacing [L ~> m] + real, dimension(2*G%isd-2:2*G%ied+1,2*G%jsd-3:2*G%jed+1) :: tmpV ! North face supergrid spacing [L ~> m] + real, dimension(2*G%isd-3:2*G%ied+1,2*G%jsd-3:2*G%jed+1) :: tmpZ ! Corner latitudes or longitudes [degN] or [degE] + real, dimension(:,:), allocatable :: tmpGlbl ! A global array of axis labels [degrees_N] or [km] or [m] + character(len=200) :: filename, grid_file, inputdir + character(len=64) :: mdl = "MOM_grid_init set_grid_metrics_from_mosaic" + type(MOM_domain_type), pointer :: SGdom => NULL() ! Supergrid domain + logical :: lon_bug ! If true use an older buggy answer in the tripolar longitude. + integer :: i, j, i2, j2, ni, nj + integer :: start(4), nread(4) + + call callTree_enter("set_grid_metrics_from_mosaic(), MOM_grid_initialize.F90") + + call get_param(param_file, mdl, "GRID_FILE", grid_file, & + "Name of the file from which to read horizontal grid data.", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "USE_TRIPOLAR_GEOLONB_BUG", lon_bug, & + "If true, use older code that incorrectly sets the longitude "//& + "in some points along the tripolar fold to be off by 360 degrees.", & + default=.false.) + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + filename = trim(adjustl(inputdir)) // trim(adjustl(grid_file)) + call log_param(param_file, mdl, "INPUTDIR/GRID_FILE", filename) + if (.not.file_exists(filename)) & + call MOM_error(FATAL," set_grid_metrics_from_mosaic: Unable to open "//& + trim(filename)) + + ! + + call clone_MOM_domain(G%domain, SGdom, symmetric=.true., domain_name="MOM_MOSAIC", & + refine=2, extra_halo=1) + + ! Read X from the supergrid + tmpZ(:,:) = 999. + call MOM_read_data(filename, 'x', tmpZ, SGdom, position=CORNER) + + if (lon_bug) then + call pass_var(tmpZ, SGdom, position=CORNER) + else + call pass_var(tmpZ, SGdom, position=CORNER, inner_halo=0) + endif + call extrapolate_metric(tmpZ, 2*(G%jsc-G%jsd)+2, missing=999.) + do j=G%jsd,G%jed ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*j + G%geoLonT(i,j) = tmpZ(i2-1,j2-1) + enddo ; enddo + do J=G%JsdB,G%JedB ; do I=G%IsdB,G%IedB ; i2 = 2*I ; j2 = 2*J + G%geoLonBu(I,J) = tmpZ(i2,j2) + enddo ; enddo + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB ; i2 = 2*i ; j2 = 2*j + G%geoLonCu(I,j) = tmpZ(i2,j2-1) + enddo ; enddo + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*J + G%geoLonCv(i,J) = tmpZ(i2-1,j2) + enddo ; enddo + ! For some reason, this messes up the solution... + ! call pass_var(G%geoLonBu, G%domain, position=CORNER) + + ! Read Y from the supergrid + tmpZ(:,:) = 999. + call MOM_read_data(filename, 'y', tmpZ, SGdom, position=CORNER) + + call pass_var(tmpZ, SGdom, position=CORNER) + call extrapolate_metric(tmpZ, 2*(G%jsc-G%jsd)+2, missing=999.) + do j=G%jsd,G%jed ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*j + G%geoLatT(i,j) = tmpZ(i2-1,j2-1) + enddo ; enddo + do J=G%JsdB,G%JedB ; do I=G%IsdB,G%IedB ; i2 = 2*I ; j2 = 2*J + G%geoLatBu(I,J) = tmpZ(i2,j2) + enddo ; enddo + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB ; i2 = 2*i ; j2 = 2*j + G%geoLatCu(I,j) = tmpZ(i2,j2-1) + enddo ; enddo + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*J + G%geoLatCv(i,J) = tmpZ(i2-1,j2) + enddo ; enddo + + ! Read DX,DY from the supergrid + tmpU(:,:) = 0. ; tmpV(:,:) = 0. + call MOM_read_data(filename, 'dx', tmpV, SGdom, position=NORTH_FACE, scale=US%m_to_L) + call MOM_read_data(filename, 'dy', tmpU, SGdom, position=EAST_FACE, scale=US%m_to_L) + call pass_vector(tmpU, tmpV, SGdom, To_All+Scalar_Pair, CGRID_NE) + call extrapolate_metric(tmpV, 2*(G%jsc-G%jsd)+2, missing=0.) + call extrapolate_metric(tmpU, 2*(G%jsc-G%jsd)+2, missing=0.) + + do j=G%jsd,G%jed ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*j + G%dxT(i,j) = tmpV(i2-1,j2-1) + tmpV(i2,j2-1) + G%dyT(i,j) = tmpU(i2-1,j2-1) + tmpU(i2-1,j2) + enddo ; enddo + + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB ; i2 = 2*i ; j2 = 2*j + G%dxCu(I,j) = tmpV(i2,j2-1) + tmpV(i2+1,j2-1) + G%dyCu(I,j) = tmpU(i2,j2-1) + tmpU(i2,j2) + enddo ; enddo + + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*j + G%dxCv(i,J) = tmpV(i2-1,j2) + tmpV(i2,j2) + G%dyCv(i,J) = tmpU(i2-1,j2) + tmpU(i2-1,j2+1) + enddo ; enddo + + do J=G%JsdB,G%JedB ; do I=G%IsdB,G%IedB ; i2 = 2*i ; j2 = 2*j + G%dxBu(I,J) = tmpV(i2,j2) + tmpV(i2+1,j2) + G%dyBu(I,J) = tmpU(i2,j2) + tmpU(i2,j2+1) + enddo ; enddo + + ! Read AREA from the supergrid + tmpT(:,:) = 0. + call MOM_read_data(filename, 'area', tmpT, SGdom, scale=US%m_to_L**2) + call pass_var(tmpT, SGdom) + call extrapolate_metric(tmpT, 2*(G%jsc-G%jsd)+2, missing=0.) + + do j=G%jsd,G%jed ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*j + G%areaT(i,j) = (tmpT(i2-1,j2-1) + tmpT(i2,j2)) + & + (tmpT(i2-1,j2) + tmpT(i2,j2-1)) + enddo ; enddo + do J=G%JsdB,G%JedB ; do I=G%IsdB,G%IedB ; i2 = 2*i ; j2 = 2*j + G%areaBu(I,J) = (tmpT(i2,j2) + tmpT(i2+1,j2+1)) + & + (tmpT(i2,j2+1) + tmpT(i2+1,j2)) + enddo ; enddo + + ni = SGdom%niglobal + nj = SGdom%njglobal + call deallocate_MOM_domain(SGdom) + + call pass_vector(G%dyCu, G%dxCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(G%dxCu, G%dyCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(G%dxBu, G%dyBu, G%Domain, To_All+Scalar_Pair, BGRID_NE) + call pass_var(G%areaT, G%Domain) + call pass_var(G%areaBu, G%Domain, position=CORNER) + + ! Construct axes for diagnostic output (only necessary because "ferret" uses + ! broken convention for interpretting netCDF files). + start(:) = 1 ; nread(:) = 1 + start(2) = 2 ; nread(1) = ni+1 ; nread(2) = 2 + allocate( tmpGlbl(ni+1,2) ) + if (is_root_PE()) & + call MOM_read_data(filename, "x", tmpGlbl, start, nread, & + no_domain=.TRUE., turns=G%HI%turns) + call broadcast(tmpGlbl, 2*(ni+1), root_PE()) + + ! I don't know why the second axis is 1 or 2 here. -RWH + do i=G%isg,G%ieg + G%gridLonT(i) = tmpGlbl(2*(i-G%isg)+2,2) + enddo + ! Note that the dynamic grid always uses symmetric memory for the global + ! arrays G%gridLatB and G%gridLonB. + do I=G%isg-1,G%ieg + G%gridLonB(I) = tmpGlbl(2*(I-G%isg)+3,1) + enddo + deallocate( tmpGlbl ) + + allocate( tmpGlbl(1, nj+1) ) + start(:) = 1 ; nread(:) = 1 + start(1) = int(ni/4)+1 ; nread(2) = nj+1 + if (is_root_PE()) & + call MOM_read_data(filename, "y", tmpGlbl, start, nread, & + no_domain=.TRUE., turns=G%HI%turns) + call broadcast(tmpGlbl, nj+1, root_PE()) + + do j=G%jsg,G%jeg + G%gridLatT(j) = tmpGlbl(1,2*(j-G%jsg)+2) + enddo + do J=G%jsg-1,G%jeg + G%gridLatB(J) = tmpGlbl(1,2*(j-G%jsg)+3) + enddo + deallocate( tmpGlbl ) + + call callTree_leave("set_grid_metrics_from_mosaic()") +end subroutine set_grid_metrics_from_mosaic + + +! ------------------------------------------------------------------------------ + +!> Calculate the values of the metric terms for a Cartesian grid that +!! might be used and save them in arrays. +!! +!! Within this subroutine, the x- and y- grid spacings and their +!! inverses and the cell areas centered on h, q, u, and v points are +!! calculated, as are the geographic locations of each of these 4 +!! sets of points. +subroutine set_grid_metrics_cartesian(G, param_file, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! Local variables + integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, I1off, J1off + integer :: niglobal, njglobal + real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) ! Axis labels [degrees_N] or [km] or [m] + real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) ! Axis labels [degrees_E] or [km] or [m] + real :: dx_everywhere, dy_everywhere ! Grid spacings [L ~> m]. + real :: I_dx, I_dy ! Inverse grid spacings [L-1 ~> m-1]. + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + character(len=80) :: units_temp + character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_cartesian" + + niglobal = G%Domain%niglobal ; njglobal = G%Domain%njglobal + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + I1off = G%idg_offset ; J1off = G%jdg_offset + + call callTree_enter("set_grid_metrics_cartesian(), MOM_grid_initialize.F90") + + PI = 4.0*atan(1.0) + + call get_param(param_file, mdl, "AXIS_UNITS", units_temp, & + "The units for the Cartesian axes. Valid entries are: \n"//& + " \t degrees - degrees of latitude and longitude \n"//& + " \t m or meter(s) - meters \n"//& + " \t k or km or kilometer(s) - kilometers", default="degrees") + if (trim(units_temp) == "k") units_temp = "km" + + call get_param(param_file, mdl, "SOUTHLAT", G%south_lat, & + "The southern latitude of the domain or the equivalent "//& + "starting value for the y-axis.", units=units_temp, & + fail_if_missing=.true.) + call get_param(param_file, mdl, "LENLAT", G%len_lat, & + "The latitudinal or y-direction length of the domain.", & + units=units_temp, fail_if_missing=.true.) + call get_param(param_file, mdl, "WESTLON", G%west_lon, & + "The western longitude of the domain or the equivalent "//& + "starting value for the x-axis.", units=units_temp, & + default=0.0) + call get_param(param_file, mdl, "LENLON", G%len_lon, & + "The longitudinal or x-direction length of the domain.", & + units=units_temp, fail_if_missing=.true.) + call get_param(param_file, mdl, "RAD_EARTH", G%Rad_Earth_L, & + "The radius of the Earth.", units="m", default=6.378e6, scale=US%m_to_L) + + if (units_temp(1:1) == 'k') then + G%x_axis_units = "kilometers" ; G%y_axis_units = "kilometers" + G%x_ax_unit_short = "km" ; G%y_ax_unit_short = "km" + elseif (units_temp(1:1) == 'm') then + G%x_axis_units = "meters" ; G%y_axis_units = "meters" + G%x_ax_unit_short = "m" ; G%y_ax_unit_short = "m" + endif + call log_param(param_file, mdl, "explicit AXIS_UNITS", G%x_axis_units) + + ! Note that the dynamic grid always uses symmetric memory for the global + ! arrays G%gridLatB and G%gridLonB. + do J=G%jsg-1,G%jeg + G%gridLatB(j) = G%south_lat + G%len_lat*REAL(J-(G%jsg-1))/REAL(njglobal) + enddo + do j=G%jsg,G%jeg + G%gridLatT(j) = G%south_lat + G%len_lat*(REAL(j-G%jsg)+0.5)/REAL(njglobal) + enddo + do I=G%isg-1,G%ieg + G%gridLonB(i) = G%west_lon + G%len_lon*REAL(I-(G%isg-1))/REAL(niglobal) + enddo + do i=G%isg,G%ieg + G%gridLonT(i) = G%west_lon + G%len_lon*(REAL(i-G%isg)+0.5)/REAL(niglobal) + enddo + + do J=JsdB,JedB + grid_latB(J) = G%south_lat + G%len_lat*REAL(J+J1off-(G%jsg-1))/REAL(njglobal) + enddo + do j=jsd,jed + grid_latT(J) = G%south_lat + G%len_lat*(REAL(j+J1off-G%jsg)+0.5)/REAL(njglobal) + enddo + do I=IsdB,IedB + grid_lonB(I) = G%west_lon + G%len_lon*REAL(i+I1off-(G%isg-1))/REAL(niglobal) + enddo + do i=isd,ied + grid_lonT(i) = G%west_lon + G%len_lon*(REAL(i+I1off-G%isg)+0.5)/REAL(niglobal) + enddo + + if (units_temp(1:1) == 'k') then ! Axes are measured in km. + dx_everywhere = 1000.0*US%m_to_L * G%len_lon / (REAL(niglobal)) + dy_everywhere = 1000.0*US%m_to_L * G%len_lat / (REAL(njglobal)) + elseif (units_temp(1:1) == 'm') then ! Axes are measured in m. + dx_everywhere = US%m_to_L*G%len_lon / (REAL(niglobal)) + dy_everywhere = US%m_to_L*G%len_lat / (REAL(njglobal)) + else ! Axes are measured in degrees of latitude and longitude. + dx_everywhere = G%Rad_Earth_L * G%len_lon * PI / (180.0 * niglobal) + dy_everywhere = G%Rad_Earth_L * G%len_lat * PI / (180.0 * njglobal) + endif + + I_dx = 1.0 / dx_everywhere ; I_dy = 1.0 / dy_everywhere + + do J=JsdB,JedB ; do I=IsdB,IedB + G%geoLonBu(I,J) = grid_lonB(I) ; G%geoLatBu(I,J) = grid_latB(J) + + G%dxBu(I,J) = dx_everywhere ; G%IdxBu(I,J) = I_dx + G%dyBu(I,J) = dy_everywhere ; G%IdyBu(I,J) = I_dy + G%areaBu(I,J) = dx_everywhere * dy_everywhere ; G%IareaBu(I,J) = I_dx * I_dy + enddo ; enddo + + do j=jsd,jed ; do i=isd,ied + G%geoLonT(i,j) = grid_lonT(i) ; G%geoLatT(i,j) = grid_LatT(j) + G%dxT(i,j) = dx_everywhere ; G%IdxT(i,j) = I_dx + G%dyT(i,j) = dy_everywhere ; G%IdyT(i,j) = I_dy + G%areaT(i,j) = dx_everywhere * dy_everywhere ; G%IareaT(i,j) = I_dx * I_dy + enddo ; enddo + + do j=jsd,jed ; do I=IsdB,IedB + G%geoLonCu(I,j) = grid_lonB(I) ; G%geoLatCu(I,j) = grid_LatT(j) + + G%dxCu(I,j) = dx_everywhere ; G%IdxCu(I,j) = I_dx + G%dyCu(I,j) = dy_everywhere ; G%IdyCu(I,j) = I_dy + enddo ; enddo + + do J=JsdB,JedB ; do i=isd,ied + G%geoLonCv(i,J) = grid_lonT(i) ; G%geoLatCv(i,J) = grid_latB(J) + + G%dxCv(i,J) = dx_everywhere ; G%IdxCv(i,J) = I_dx + G%dyCv(i,J) = dy_everywhere ; G%IdyCv(i,J) = I_dy + enddo ; enddo + + call callTree_leave("set_grid_metrics_cartesian()") +end subroutine set_grid_metrics_cartesian + +! ------------------------------------------------------------------------------ + +!> Calculate the values of the metric terms that might be used +!! and save them in arrays. +!! +!! Within this subroutine, the x- and y- grid spacings and their +!! inverses and the cell areas centered on h, q, u, and v points are +!! calculated, as are the geographic locations of each of these 4 +!! sets of points. +subroutine set_grid_metrics_spherical(G, param_file, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! Local variables + real :: PI ! PI = 3.1415926... as 4*atan(1) [nondim] + real :: PI_180 ! The conversion factor from degrees to radians [radians degree-1] + integer :: i, j, isd, ied, jsd, jed + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, IsdB, IedB, JsdB, JedB + integer :: i_offset, j_offset + real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) ! Axis labels [degrees_N] + real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) ! Axis labels [degrees_E] + real :: dLon ! The change in longitude between successive grid points [degrees_E] + real :: dLat ! The change in latitude between successive grid points [degrees_N] + real :: dL_di ! dLon rescaled from degrees to radians [radians] + real :: latitude ! The latitude of a grid point [degrees_N] + character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_spherical" + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + i_offset = G%idg_offset ; j_offset = G%jdg_offset + + call callTree_enter("set_grid_metrics_spherical(), MOM_grid_initialize.F90") + +! Calculate the values of the metric terms that might be used +! and save them in arrays. + PI = 4.0*atan(1.0) ; PI_180 = atan(1.0)/45. + + call get_param(param_file, mdl, "SOUTHLAT", G%south_lat, & + "The southern latitude of the domain.", units="degrees_N", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "LENLAT", G%len_lat, & + "The latitudinal length of the domain.", units="degrees_N", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "WESTLON", G%west_lon, & + "The western longitude of the domain.", units="degrees_E", & + default=0.0) + call get_param(param_file, mdl, "LENLON", G%len_lon, & + "The longitudinal length of the domain.", units="degrees_E", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "RAD_EARTH", G%Rad_Earth_L, & + "The radius of the Earth.", units="m", default=6.378e6, scale=US%m_to_L) + + dLon = G%len_lon/G%Domain%niglobal + dLat = G%len_lat/G%Domain%njglobal + + ! Note that the dynamic grid always uses symmetric memory for the global + ! arrays G%gridLatB and G%gridLonB. + do j=G%jsg-1,G%jeg + latitude = G%south_lat + dLat*(REAL(J-(G%jsg-1))) + G%gridLatB(J) = MIN(MAX(latitude,-90.),90.) + enddo + do j=G%jsg,G%jeg + latitude = G%south_lat + dLat*(REAL(j-G%jsg)+0.5) + G%gridLatT(j) = MIN(MAX(latitude,-90.),90.) + enddo + do i=G%isg-1,G%ieg + G%gridLonB(I) = G%west_lon + dLon*(REAL(I-(G%isg-1))) + enddo + do i=G%isg,G%ieg + G%gridLonT(i) = G%west_lon + dLon*(REAL(i-G%isg)+0.5) + enddo + + do J=JsdB,JedB + latitude = G%south_lat + dLat* REAL(J+J_offset-(G%jsg-1)) + grid_LatB(J) = MIN(MAX(latitude,-90.),90.) + enddo + do j=jsd,jed + latitude = G%south_lat + dLat*(REAL(j+J_offset-G%jsg)+0.5) + grid_LatT(j) = MIN(MAX(latitude,-90.),90.) + enddo + do I=IsdB,IedB + grid_LonB(I) = G%west_lon + dLon*REAL(I+I_offset-(G%isg-1)) + enddo + do i=isd,ied + grid_LonT(i) = G%west_lon + dLon*(REAL(i+I_offset-G%isg)+0.5) + enddo + + dL_di = (G%len_lon * 4.0*atan(1.0)) / (180.0 * G%Domain%niglobal) + do J=JsdB,JedB ; do I=IsdB,IedB + G%geoLonBu(I,J) = grid_lonB(I) + G%geoLatBu(I,J) = grid_latB(J) + + ! The following line is needed to reproduce the solution from + ! set_grid_metrics_mercator when used to generate a simple spherical grid. + G%dxBu(I,J) = G%Rad_Earth_L * COS( G%geoLatBu(I,J)*PI_180 ) * dL_di +! G%dxBu(I,J) = G%Rad_Earth_L * dLon*PI_180 * COS( G%geoLatBu(I,J)*PI_180 ) + G%dyBu(I,J) = G%Rad_Earth_L * dLat*PI_180 + G%areaBu(I,J) = G%dxBu(I,J) * G%dyBu(I,J) + enddo ; enddo + + do J=JsdB,JedB ; do i=isd,ied + G%geoLonCv(i,J) = grid_LonT(i) + G%geoLatCv(i,J) = grid_latB(J) + + ! The following line is needed to reproduce the solution from + ! set_grid_metrics_mercator when used to generate a simple spherical grid. + G%dxCv(i,J) = G%Rad_Earth_L * COS( G%geoLatCv(i,J)*PI_180 ) * dL_di +! G%dxCv(i,J) = G%Rad_Earth_L * (dLon*PI_180) * COS( G%geoLatCv(i,J)*PI_180 ) + G%dyCv(i,J) = G%Rad_Earth_L * dLat*PI_180 + enddo ; enddo + + do j=jsd,jed ; do I=IsdB,IedB + G%geoLonCu(I,j) = grid_lonB(I) + G%geoLatCu(I,j) = grid_LatT(j) + + ! The following line is needed to reproduce the solution from + ! set_grid_metrics_mercator when used to generate a simple spherical grid. + G%dxCu(I,j) = G%Rad_Earth_L * COS( G%geoLatCu(I,j)*PI_180 ) * dL_di +! G%dxCu(I,j) = G%Rad_Earth_L * dLon*PI_180 * COS( latitude ) + G%dyCu(I,j) = G%Rad_Earth_L * dLat*PI_180 + enddo ; enddo + + do j=jsd,jed ; do i=isd,ied + G%geoLonT(i,j) = grid_LonT(i) + G%geoLatT(i,j) = grid_LatT(j) + + ! The following line is needed to reproduce the solution from + ! set_grid_metrics_mercator when used to generate a simple spherical grid. + G%dxT(i,j) = G%Rad_Earth_L * COS( G%geoLatT(i,j)*PI_180 ) * dL_di +! G%dxT(i,j) = G%Rad_Earth_L * dLon*PI_180 * COS( latitude ) + G%dyT(i,j) = G%Rad_Earth_L * dLat*PI_180 + +! latitude = G%geoLatCv(i,J)*PI_180 ! In radians +! dL_di = G%geoLatCv(i,max(jsd,J-1))*PI_180 ! In radians +! G%areaT(i,j) = Rad_Earth_L**2*dLon*dLat*ABS(SIN(latitude)-SIN(dL_di)) + G%areaT(i,j) = G%dxT(i,j) * G%dyT(i,j) + enddo ; enddo + + call callTree_leave("set_grid_metrics_spherical()") +end subroutine set_grid_metrics_spherical + +!> Calculate the values of the metric terms that might be used +!! and save them in arrays. +!! +!! Within this subroutine, the x- and y- grid spacings and their +!! inverses and the cell areas centered on h, q, u, and v points are +!! calculated, as are the geographic locations of each of these 4 +!! sets of points. +subroutine set_grid_metrics_mercator(G, param_file, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! Local variables + integer :: i, j, isd, ied, jsd, jed + integer :: I_off, J_off + type(GPS) :: GP + character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_mercator" + real :: PI, PI_2 ! PI = 3.1415926... as 4*atan(1), PI_2 = (PI) /2.0 [nondim] + real :: y_q, y_h ! Latitudes of a point [radians] + real :: id ! The i-grid space positions whose longitude is being sought [gridpoints] + real :: jd ! The j-grid space positions whose latitude is being sought [gridpoints] + real :: x_q, x_h ! Longitudes of a point [radians] + real, dimension(G%isd:G%ied,G%jsd:G%jed) :: & + xh, yh ! Latitude and longitude of h points in radians [radians] + real, dimension(G%IsdB:G%IedB,G%jsd:G%jed) :: & + xu, yu ! Latitude and longitude of u points in radians [radians] + real, dimension(G%isd:G%ied,G%JsdB:G%JedB) :: & + xv, yv ! Latitude and longitude of v points in radians [radians] + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: & + xq, yq ! Latitude and longitude of q points in radians [radians] + real :: fnRef ! fnRef is the value of Int_dj_dy or + ! Int_dj_dy at a latitude or longitude that is + ! being set to be at grid index jRef or iRef [gridpoints] + real :: jRef, iRef ! The grid index at which fnRef is evaluated [gridpoints] + integer :: itt1, itt2 + logical, parameter :: simple_area = .true. + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, IsdB, IedB, JsdB, JedB + + ! All of the metric terms should be defined over the domain from + ! isd to ied. Outside of the physical domain, both the metrics + ! and their inverses may be set to zero. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + I_off = G%idg_offset ; J_off = G%jdg_offset + + GP%niglobal = G%Domain%niglobal + GP%njglobal = G%Domain%njglobal + + call callTree_enter("set_grid_metrics_mercator(), MOM_grid_initialize.F90") + + ! Calculate the values of the metric terms that might be used + ! and save them in arrays. + PI = 4.0*atan(1.0) ; PI_2 = 0.5*PI + + call get_param(param_file, mdl, "SOUTHLAT", GP%south_lat, & + "The southern latitude of the domain.", units="degrees_N", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "LENLAT", GP%len_lat, & + "The latitudinal length of the domain.", units="degrees_N", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "WESTLON", GP%west_lon, & + "The western longitude of the domain.", units="degrees_E", & + default=0.0) + call get_param(param_file, mdl, "LENLON", GP%len_lon, & + "The longitudinal length of the domain.", units="degrees_E", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "RAD_EARTH", GP%Rad_Earth_L, & + "The radius of the Earth.", units="m", default=6.378e6, scale=US%m_to_L) + G%south_lat = GP%south_lat ; G%len_lat = GP%len_lat + G%west_lon = GP%west_lon ; G%len_lon = GP%len_lon + G%Rad_Earth_L = GP%Rad_Earth_L + + call get_param(param_file, mdl, "ISOTROPIC", GP%isotropic, & + "If true, an isotropic grid on a sphere (also known as "//& + "a Mercator grid) is used. With an isotropic grid, the "//& + "meridional extent of the domain (LENLAT), the zonal "//& + "extent (LENLON), and the number of grid points in each "//& + "direction are _not_ independent. In MOM the meridional "//& + "extent is determined to fit the zonal extent and the "//& + "number of grid points, while grid is perfectly isotropic.", & + default=.false.) + call get_param(param_file, mdl, "EQUATOR_REFERENCE", GP%equator_reference, & + "If true, the grid is defined to have the equator at the "//& + "nearest q- or h- grid point to (-LOWLAT*NJGLOBAL/LENLAT).", & + default=.true.) + call get_param(param_file, mdl, "LAT_ENHANCE_FACTOR", GP%Lat_enhance_factor, & + "The amount by which the meridional resolution is "//& + "enhanced within LAT_EQ_ENHANCE of the equator.", & + units="nondim", default=1.0) + call get_param(param_file, mdl, "LAT_EQ_ENHANCE", GP%Lat_eq_enhance, & + "The latitude range to the north and south of the equator "//& + "over which the resolution is enhanced.", units="degrees_N", & + default=0.0) + + ! With an isotropic grid, the north-south extent of the domain, + ! the east-west extent, and the number of grid points in each + ! direction are _not_ independent. Here the north-south extent + ! will be determined to fit the east-west extent and the number of + ! grid points. The grid is perfectly isotropic. + if (GP%equator_reference) then + ! With the following expression, the equator will always be placed + ! on either h or q points, in a position consistent with the ratio + ! GP%south_lat to GP%len_lat. + jRef = (G%jsg-1) + 0.5*FLOOR(GP%njglobal*((-1.0*GP%south_lat*2.0)/GP%len_lat)+0.5) + fnRef = Int_dj_dy(0.0, GP) + else + ! The following line sets the reference latitude GP%south_lat at j=js-1 (or -2?) + jRef = (G%jsg-1) + fnRef = Int_dj_dy((GP%south_lat*PI/180.0), GP) + endif + + ! These calculations no longer depend on the the order in which they + ! are performed because they all use the same (poor) starting guess and + ! iterate to convergence. + ! Note that the dynamic grid always uses symmetric memory for the global + ! arrays G%gridLatB and G%gridLonB. + do J=G%jsg-1,G%jeg + jd = fnRef + (J - jRef) + y_q = find_root(Int_dj_dy, dy_dj, GP, jd, 0.0, -1.0*PI_2, PI_2, itt2) + G%gridLatB(J) = y_q*180.0/PI + ! if (is_root_pe()) & + ! write(stdout, '("J, y_q = ",I4,ES14.4," itts = ",I4)') j, y_q, itt2 + enddo + do j=G%jsg,G%jeg + jd = fnRef + (j - jRef) - 0.5 + y_h = find_root(Int_dj_dy, dy_dj, GP, jd, 0.0, -1.0*PI_2, PI_2, itt1) + G%gridLatT(j) = y_h*180.0/PI + ! if (is_root_pe()) & + ! write(stdout, '("j, y_h = ",I4,ES14.4," itts = ",I4)') j, y_h, itt1 + enddo + do J=JsdB+J_off,JedB+J_off + jd = fnRef + (J - jRef) + y_q = find_root(Int_dj_dy, dy_dj, GP, jd, 0.0, -1.0*PI_2, PI_2, itt2) + do I=IsdB,IedB ; yq(I,J-J_off) = y_q ; enddo + do i=isd,ied ; yv(i,J-J_off) = y_q ; enddo + enddo + do j=jsd+J_off,jed+J_off + jd = fnRef + (j - jRef) - 0.5 + y_h = find_root(Int_dj_dy, dy_dj, GP, jd, 0.0, -1.0*PI_2, PI_2, itt1) + if ((j >= jsd+J_off) .and. (j <= jed+J_off)) then + do i=isd,ied ; yh(i,j-J_off) = y_h ; enddo + do I=IsdB,IedB ; yu(I,j-J_off) = y_h ; enddo + endif + enddo + + ! Determine the longitudes of the various points. + + ! These two lines place the western edge of the domain at GP%west_lon. + iRef = (G%isg-1) + GP%niglobal + fnRef = Int_di_dx(((GP%west_lon+GP%len_lon)*PI/180.0), GP) + + ! These calculations no longer depend on the the order in which they + ! are performed because they all use the same (poor) starting guess and + ! iterate to convergence. + do I=G%isg-1,G%ieg + id = fnRef + (I - iRef) + x_q = find_root(Int_di_dx, dx_di, GP, id, 0.0, -4.0*PI, 4.0*PI, itt2) + G%gridLonB(I) = x_q*180.0/PI + enddo + do i=G%isg,G%ieg + id = fnRef + (i - iRef) - 0.5 + x_h = find_root(Int_di_dx, dx_di, GP, id, 0.0, -4.0*PI, 4.0*PI, itt1) + G%gridLonT(i) = x_h*180.0/PI + enddo + do I=IsdB+I_off,IedB+I_off + id = fnRef + (I - iRef) + x_q = find_root(Int_di_dx, dx_di, GP, id, 0.0, -4.0*PI, 4.0*PI, itt2) + do J=JsdB,JedB ; xq(I-I_off,J) = x_q ; enddo + do j=jsd,jed ; xu(I-I_off,j) = x_q ; enddo + enddo + do i=isd+I_off,ied+I_off + id = fnRef + (i - iRef) - 0.5 + x_h = find_root(Int_di_dx, dx_di, GP, id, 0.0, -4.0*PI, 4.0*PI, itt1) + do j=jsd,jed ; xh(i-I_off,j) = x_h ; enddo + do J=JsdB,JedB ; xv(i-I_off,J) = x_h ; enddo + enddo + + do J=JsdB,JedB ; do I=IsdB,IedB + G%geoLonBu(I,J) = xq(I,J)*180.0/PI + G%geoLatBu(I,J) = yq(I,J)*180.0/PI + G%dxBu(I,J) = ds_di(xq(I,J), yq(I,J), GP) + G%dyBu(I,J) = ds_dj(xq(I,J), yq(I,J), GP) + + G%areaBu(I,J) = G%dxBu(I,J) * G%dyBu(I,J) + G%IareaBu(I,J) = 1.0 / (G%areaBu(I,J)) + enddo ; enddo + + do j=jsd,jed ; do i=isd,ied + G%geoLonT(i,j) = xh(i,j)*180.0/PI + G%geoLatT(i,j) = yh(i,j)*180.0/PI + G%dxT(i,j) = ds_di(xh(i,j), yh(i,j), GP) + G%dyT(i,j) = ds_dj(xh(i,j), yh(i,j), GP) + + G%areaT(i,j) = G%dxT(i,j)*G%dyT(i,j) + G%IareaT(i,j) = 1.0 / (G%areaT(i,j)) + enddo ; enddo + + do j=jsd,jed ; do I=IsdB,IedB + G%geoLonCu(I,j) = xu(I,j)*180.0/PI + G%geoLatCu(I,j) = yu(I,j)*180.0/PI + G%dxCu(I,j) = ds_di(xu(I,j), yu(I,j), GP) + G%dyCu(I,j) = ds_dj(xu(I,j), yu(I,j), GP) + enddo ; enddo + + do J=JsdB,JedB ; do i=isd,ied + G%geoLonCv(i,J) = xv(i,J)*180.0/PI + G%geoLatCv(i,J) = yv(i,J)*180.0/PI + G%dxCv(i,J) = ds_di(xv(i,J), yv(i,J), GP) + G%dyCv(i,J) = ds_dj(xv(i,J), yv(i,J), GP) + enddo ; enddo + + if (.not.simple_area) then + do j=JsdB+1,jed ; do i=IsdB+1,ied + G%areaT(I,J) = GP%Rad_Earth_L**2 * & + (dL(xq(I-1,J-1),xq(I-1,J),yq(I-1,J-1),yq(I-1,J)) + & + (dL(xq(I-1,J),xq(I,J),yq(I-1,J),yq(I,J)) + & + (dL(xq(I,J),xq(I,J-1),yq(I,J),yq(I,J-1)) + & + dL(xq(I,J-1),xq(I-1,J-1),yq(I,J-1),yq(I-1,J-1))))) + enddo ;enddo + if ((IsdB == isd) .or. (JsdB == jsq)) then + ! Fill in row and column 1 to calculate the area in the southernmost + ! and westernmost land cells when we are not using symmetric memory. + ! The pass_var call updates these values if they are not land cells. + G%areaT(isd+1,jsd) = G%areaT(isd+1,jsd+1) + do j=jsd,jed ; G%areaT(isd,j) = G%areaT(isd+1,j) ; enddo + do i=isd,ied ; G%areaT(i,jsd) = G%areaT(i,jsd+1) ; enddo + ! Now replace the data in the halos, if value values exist. + call pass_var(G%areaT,G%Domain) + endif + do j=jsd,jed ; do i=isd,ied + G%IareaT(i,j) = 1.0 / (G%areaT(i,j)) + enddo ; enddo + endif + + call callTree_leave("set_grid_metrics_mercator()") +end subroutine set_grid_metrics_mercator + + +!> This function returns the grid spacing in the logical x direction in [L ~> m]. +function ds_di(x, y, GP) + real, intent(in) :: x !< The longitude in question [radians] + real, intent(in) :: y !< The latitude in question [radians] + type(GPS), intent(in) :: GP !< A structure of grid parameters + + real :: ds_di ! The returned grid spacing [L ~> m] + + ds_di = GP%Rad_Earth_L * cos(y) * dx_di(x,GP) + ! In general, this might be... + ! ds_di = GP%Rad_Earth_L * sqrt( cos(y)*cos(y) * dx_di(x,y,GP)*dx_di(x,y,GP) + & + ! dy_di(x,y,GP)*dy_di(x,y,GP)) +end function ds_di + +!> This function returns the grid spacing in the logical y direction in [L ~> m]. +function ds_dj(x, y, GP) + real, intent(in) :: x !< The longitude in question [radians] + real, intent(in) :: y !< The latitude in question [radians] + type(GPS), intent(in) :: GP !< A structure of grid parameters + + real :: ds_dj ! The returned grid spacing [L ~> m] + + ds_dj = GP%Rad_Earth_L * dy_dj(y,GP) + ! In general, this might be... + ! ds_dj = GP%Rad_Earth_L * sqrt( cos(y)*cos(y) * dx_dj(x,y,GP)*dx_dj(x,y,GP) + & + ! dy_dj(x,y,GP)*dy_dj(x,y,GP)) +end function ds_dj + +!> This function returns the contribution from the line integral along one of the four sides of a +!! cell face to the area of a cell, in [radians2], assuming that the sides follow a linear path in +!! latitude and longitude (i.e., on a Mercator grid). +function dL(x1, x2, y1, y2) + real, intent(in) :: x1 !< Segment starting longitude [radians] + real, intent(in) :: x2 !< Segment ending longitude [radians] + real, intent(in) :: y1 !< Segment starting latitude [radians] + real, intent(in) :: y2 !< Segment ending latitude [radians] + ! Local variables + real :: dL ! A contribution to the spanned area the surface of the sphere [radian2] + real :: r ! A contribution from the range of latitudes, including trigonometric factors [radians] + real :: dy ! The spanned range of latitudes [radians] + + dy = y2 - y1 + + if (ABS(dy) > 2.5e-8) then + r = ((1.0 - cos(dy))*cos(y1) + sin(dy)*sin(y1)) / dy + else + r = (0.5*dy*cos(y1) + sin(y1)) + endif + dL = r * (x2 - x1) + +end function dL + +!> This subroutine finds and returns the value of y at which the monotonically increasing +!! function fn takes the value fnval, also returning in ittmax the number of iterations of +!! Newton's method that were used to polish the root. +function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) + real :: find_root !< The value of y where fn(y) = fnval that will be returned [radians] + real, external :: fn !< The external function whose root is being sought [gridpoints] + real, external :: dy_df !< The inverse of the derivative of that function [radian gridpoint-1] + type(GPS), intent(in) :: GP !< A structure of grid parameters + real, intent(in) :: fnval !< The value of fn being sought [gridpoints] + real, intent(in) :: y1 !< A first guess for y [radians] + real, intent(in) :: ymin !< The minimum permitted value of y [radians] + real, intent(in) :: ymax !< The maximum permitted value of y [radians] + integer, intent(out) :: ittmax !< The number of iterations used to polish the root + ! Local variables + real :: y, y_next ! Successive guesses at the root position [radians] + real :: ybot, ytop ! Brackets bounding the root [radians] + real :: fnbot, fntop ! Values of fn at the bounding values of y [gridpoints] + real :: dy_dfn ! The inverse of the local derivative of fn with y [radian gridpoint-1] + real :: dy ! The jump to the next guess of y [radians] + real :: fny ! The difference between fn(y) and the target value [gridpoints] + integer :: itt + character(len=256) :: warnmesg + +! Bracket the root. Do not use the bounding values because the value at the +! function at the bounds could be infinite, as is the case for the Mercator +! grid recursion relation. (I.e., this is a search on an open interval.) + ybot = y1 + fnbot = fn(ybot,GP) - fnval ; itt = 0 + do while (fnbot > 0.0) + if ((ybot - 2.0*dy_df(ybot,GP)) < (0.5*(ybot+ymin))) then + ! Go twice as far as the secant method would normally go. + ybot = ybot - 2.0*dy_df(ybot,GP) + else ! But stay within the open interval! + ybot = 0.5*(ybot+ymin) ; itt = itt + 1 + endif + fnbot = fn(ybot,GP) - fnval + + if ((itt > 50) .and. (fnbot > 0.0)) then + write(warnmesg, '("PE ",I2," unable to find bottom bound for grid function. & + &x = ",ES10.4,", xmax = ",ES10.4,", fn = ",ES10.4,", dfn_dx = ",ES10.4,& + &", seeking fn = ",ES10.4," - fn = ",ES10.4,".")') & + pe_here(),ybot,ymin,fn(ybot,GP),dy_df(ybot,GP),fnval, fnbot + call MOM_error(FATAL,warnmesg) + endif + enddo + + ytop = y1 + fntop = fn(ytop,GP) - fnval ; itt = 0 + do while (fntop < 0.0) + if ((ytop + 2.0*dy_df(ytop,GP)) < (0.5*(ytop+ymax))) then + ! Go twice as far as the secant method would normally go. + ytop = ytop + 2.0*dy_df(ytop,GP) + else ! But stay within the open interval! + ytop = 0.5*(ytop+ymax) ; itt = itt + 1 + endif + fntop = fn(ytop,GP) - fnval + + if ((itt > 50) .and. (fntop < 0.0)) then + write(warnmesg, '("PE ",I2," unable to find top bound for grid function. & + &x = ",ES10.4,", xmax = ",ES10.4,", fn = ",ES10.4,", dfn_dx = ",ES10.4, & + &", seeking fn = ",ES10.4," - fn = ",ES10.4,".")') & + pe_here(),ytop,ymax,fn(ytop,GP),dy_df(ytop,GP),fnval,fntop + call MOM_error(FATAL,warnmesg) + endif + enddo + + ! Find the root using a bracketed variant of Newton's method, starting + ! with a false-positon method first guess. + if ((fntop < 0.0) .or. (fnbot > 0.0) .or. (ytop < ybot)) then + write(warnmesg, '("PE ",I2," find_root failed to bracket function. y = ",& + &2ES10.4,", fn = ",2ES10.4,".")') pe_here(),ybot,ytop,fnbot,fntop + call MOM_error(FATAL, warnmesg) + endif + + if (fntop == 0.0) then ; y = ytop ; fny = fntop + elseif (fnbot == 0.0) then ; y = ybot ; fny = fnbot + else + y = (ybot*fntop - ytop*fnbot) / (fntop - fnbot) + fny = fn(y,GP) - fnval + if (fny < 0.0) then ; fnbot = fny ; ybot = y + else ; fntop = fny ; ytop = y ; endif + endif + + do itt=1,50 + dy_dfn = dy_df(y,GP) + + dy = -1.0* fny * dy_dfn + y_next = y + dy + if ((y_next >= ytop) .or. (y_next <= ybot)) then + ! The Newton's method estimate has escaped bracketing, so use the + ! false-position method instead. The complicated test is to properly + ! handle the case where the iteration is down to roundoff level differences. + y_next = y + if (abs(fntop - fnbot) > EPSILON(y) * (abs(fntop) + abs(fnbot))) & + y_next = (ybot*fntop - ytop*fnbot) / (fntop - fnbot) + endif + + dy = y_next - y + if (ABS(dy) < (2.0*EPSILON(y)*(ABS(y) + ABS(y_next)) + 1.0e-20)) then + y = y_next ; exit + endif + y = y_next + + fny = fn(y,GP) - fnval + if (fny > 0.0) then ; ytop = y ; fntop = fny + elseif (fny < 0.0) then ; ybot = y ; fnbot = fny + else ; exit ; endif + + enddo + if (ABS(y) < 1e-12) y = 0.0 + + ittmax = itt + find_root = y +end function find_root + +!> This function calculates and returns the value of dx/di in [radian gridpoint-1], +!! where x is the longitude in Radians, and i is the integral east-west grid index. +function dx_di(x, GP) + real, intent(in) :: x !< The longitude in question [radians] + type(GPS), intent(in) :: GP !< A structure of grid parameters + real :: dx_di ! The derivative of zonal position with the grid index [radian gridpoint-1] + + dx_di = (GP%len_lon * 4.0*atan(1.0)) / (180.0 * GP%niglobal) + +end function dx_di + +!> This function calculates and returns the integral of the inverse +!! of dx/di to the point x, in radians [gridpoints] +function Int_di_dx(x, GP) + real, intent(in) :: x !< The longitude in question [radians] + type(GPS), intent(in) :: GP !< A structure of grid parameters + real :: Int_di_dx ! A position in the global i-index space [gridpoints] + + Int_di_dx = x * ((180.0 * GP%niglobal) / (GP%len_lon * 4.0*atan(1.0))) + +end function Int_di_dx + +!> This subroutine calculates and returns the value of dy/dj in [radian gridpoint-1], +!! where y is the latitude in Radians, and j is the integral north-south grid index. +function dy_dj(y, GP) + real, intent(in) :: y !< The latitude in question [radians] + type(GPS), intent(in) :: GP !< A structure of grid parameters + real :: dy_dj ! The derivative of meridional position with the grid index [radian gridpoint-1] + ! Local variables + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: C0 ! The constant that converts the nominal y-spacing in + ! gridpoints to the nominal spacing in Radians [radian gridpoint-1] + real :: y_eq_enhance ! The latitude in radians within which the resolution + ! is enhanced [radians] + PI = 4.0*atan(1.0) + if (GP%isotropic) then + C0 = (GP%len_lon * PI) / (180.0 * GP%niglobal) + y_eq_enhance = PI*abs(GP%lat_eq_enhance)/180.0 + if (ABS(y) < y_eq_enhance) then + dy_dj = C0 * (cos(y) / (1.0 + 0.5*cos(y) * (GP%lat_enhance_factor - 1.0) * & + (1.0+cos(PI*y/y_eq_enhance)) )) + else + dy_dj = C0 * cos(y) + endif + else + C0 = (GP%len_lat * PI) / (180.0 * GP%njglobal) + dy_dj = C0 + endif + +end function dy_dj + +!> This subroutine calculates and returns the integral of the inverse +!! of dy/dj to the point y in radians [gridpoints] +function Int_dj_dy(y, GP) + real, intent(in) :: y !< The latitude in question [radians] + type(GPS), intent(in) :: GP !< A structure of grid parameters + real :: Int_dj_dy ! The grid position of latitude y [gridpoints] + ! Local variables + real :: I_C0 ! The inverse of the constant that converts the + ! nominal spacing in gridpoints to the nominal + ! spacing in Radians [gridpoint radian-1] + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: y_eq_enhance ! The latitude in radians from from the equator within which the meridional + ! grid spacing is enhanced by a factor of GP%lat_enhance_factor [radians] + real :: r ! The y grid position in the global index space [gridpoints] + + PI = 4.0*atan(1.0) + if (GP%isotropic) then + I_C0 = (180.0 * GP%niglobal) / (GP%len_lon * PI) + y_eq_enhance = PI*ABS(GP%lat_eq_enhance)/180.0 + + if (y >= 0.0) then + r = I_C0 * log((1.0 + sin(y))/cos(y)) + else + r = -1.0 * I_C0 * log((1.0 - sin(y))/cos(y)) + endif + + if (y >= y_eq_enhance) then + r = r + I_C0*0.5*(GP%lat_enhance_factor - 1.0)*y_eq_enhance + elseif (y <= -y_eq_enhance) then + r = r - I_C0*0.5*(GP%lat_enhance_factor - 1.0)*y_eq_enhance + else + r = r + I_C0*0.5*(GP%lat_enhance_factor - 1.0) * & + (y + (y_eq_enhance/PI)*sin(PI*y/y_eq_enhance)) + endif + else + I_C0 = (180.0 * GP%njglobal) / (GP%len_lat * PI) + r = I_C0 * y + endif + + Int_dj_dy = r +end function Int_dj_dy + +!> Extrapolates missing metric data into all the halo regions. +subroutine extrapolate_metric(var, jh, missing) + real, dimension(:,:), intent(inout) :: var !< The array in which to fill in halos [abitrary] + integer, intent(in) :: jh !< The size of the halos to be filled + real, optional, intent(in) :: missing !< The missing data fill value, 0 by default [abitrary] + ! Local variables + real :: badval ! A bad data value [abitrary] + integer :: i, j + + badval = 0.0 ; if (present(missing)) badval = missing + + ! Fill in southern halo by extrapolating from the computational domain + do j=lbound(var,2)+jh,lbound(var,2),-1 ; do i=lbound(var,1),ubound(var,1) + if (var(i,j)==badval) var(i,j) = 2.0*var(i,j+1)-var(i,j+2) + enddo ; enddo + + ! Fill in northern halo by extrapolating from the computational domain + do j=ubound(var,2)-jh,ubound(var,2) ; do i=lbound(var,1),ubound(var,1) + if (var(i,j)==badval) var(i,j) = 2.0*var(i,j-1)-var(i,j-2) + enddo ; enddo + + ! Fill in western halo by extrapolating from the computational domain + do j=lbound(var,2),ubound(var,2) ; do i=lbound(var,1)+jh,lbound(var,1),-1 + if (var(i,j)==badval) var(i,j) = 2.0*var(i+1,j)-var(i+2,j) + enddo ; enddo + + ! Fill in eastern halo by extrapolating from the computational domain + do j=lbound(var,2),ubound(var,2) ; do i=ubound(var,1)-jh,ubound(var,1) + if (var(i,j)==badval) var(i,j) = 2.0*var(i-1,j)-var(i-2,j) + enddo ; enddo + +end subroutine extrapolate_metric + +!> This function implements Adcroft's rule for reciprocals, namely that +!! Adcroft_Inv(x) = 1/x for |x|>0 or 0 for x=0. +function Adcroft_reciprocal(val) result(I_val) + real, intent(in) :: val !< The value being inverted [abitrary] + real :: I_val !< The Adcroft reciprocal of val [abitrary-1] + + I_val = 0.0 + if (val /= 0.0) I_val = 1.0/val +end function Adcroft_reciprocal + +!> Initializes the grid masks and any metrics that come with masks already applied. +!! +!! Initialize_masks sets mask2dT, mask2dCu, mask2dCv, and mask2dBu to mask out +!! flow over any points which are shallower than Dmask and permit an +!! appropriate treatment of the boundary conditions. mask2dCu and mask2dCv +!! are 0.0 at any points adjacent to a land point. mask2dBu is 0.0 at +!! any land or boundary point. For points in the interior, mask2dCu, +!! mask2dCv, and mask2dBu are all 1.0. +subroutine initialize_masks(G, PF, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + type(param_file_type), intent(in) :: PF !< Parameter file structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! Local variables + real :: Dmask ! The depth for masking in the same units as G%bathyT [Z ~> m]. + real :: min_depth ! The minimum ocean depth in the same units as G%bathyT [Z ~> m]. + real :: mask_depth ! The depth shallower than which to mask a point as land [Z ~> m]. + character(len=40) :: mdl = "MOM_grid_init initialize_masks" + integer :: i, j + + call callTree_enter("initialize_masks(), MOM_grid_initialize.F90") + + call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & + "If MASKING_DEPTH is unspecified, then anything shallower than "//& + "MINIMUM_DEPTH is assumed to be land and all fluxes are masked out. "//& + "If MASKING_DEPTH is specified, then all depths shallower than "//& + "MINIMUM_DEPTH but deeper than MASKING_DEPTH are rounded to MINIMUM_DEPTH.", & + units="m", default=0.0, scale=US%m_to_Z) + call get_param(PF, mdl, "MASKING_DEPTH", mask_depth, & + "The depth below which to mask points as land points, for which all "//& + "fluxes are zeroed out. MASKING_DEPTH is ignored if it has the special "//& + "default value.", & + units="m", default=-9999.0, scale=US%m_to_Z) + + Dmask = mask_depth + if (mask_depth == -9999.0*US%m_to_Z) Dmask = min_depth + + G%mask2dCu(:,:) = 0.0 ; G%mask2dCv(:,:) = 0.0 ; G%mask2dBu(:,:) = 0.0 + + ! Construct the h-point or T-point mask + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if (G%bathyT(i,j) <= Dmask) then + G%mask2dT(i,j) = 0.0 + else + G%mask2dT(i,j) = 1.0 + endif + enddo ; enddo + + do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 + if ((G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i+1,j) <= Dmask)) then + G%mask2dCu(I,j) = 0.0 + else + G%mask2dCu(I,j) = 1.0 + endif + ! This mask may be revised later after the open boundary positions are specified. + G%OBCmaskCu(I,j) = G%mask2dCu(I,j) + enddo ; enddo + + do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied + if ((G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i,j+1) <= Dmask)) then + G%mask2dCv(i,J) = 0.0 + else + G%mask2dCv(i,J) = 1.0 + endif + ! This mask may be revised later after the open boundary positions are specified. + G%OBCmaskCv(i,J) = G%mask2dCv(i,J) + enddo ; enddo + + do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1 + if ((G%bathyT(i+1,j) <= Dmask) .or. (G%bathyT(i+1,j+1) <= Dmask) .or. & + (G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i,j+1) <= Dmask)) then + G%mask2dBu(I,J) = 0.0 + else + G%mask2dBu(I,J) = 1.0 + endif + enddo ; enddo + + call pass_var(G%mask2dBu, G%Domain, position=CORNER) + call pass_vector(G%mask2dCu, G%mask2dCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) + + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + ! This open face length may be revised later. + G%dy_Cu(I,j) = G%mask2dCu(I,j) * G%dyCu(I,j) + G%areaCu(I,j) = G%dxCu(I,j) * G%dy_Cu(I,j) + G%IareaCu(I,j) = G%mask2dCu(I,j) * Adcroft_reciprocal(G%areaCu(I,j)) + enddo ; enddo + + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + ! This open face length may be revised later. + G%dx_Cv(i,J) = G%mask2dCv(i,J) * G%dxCv(i,J) + G%areaCv(i,J) = G%dyCv(i,J) * G%dx_Cv(i,J) + G%IareaCv(i,J) = G%mask2dCv(i,J) * Adcroft_reciprocal(G%areaCv(i,J)) + enddo ; enddo + + call callTree_leave("initialize_masks()") +end subroutine initialize_masks + +!> \namespace mom_grid_initialize +!! +!! The metric terms have the form Dzp, IDzp, or DXDYp, where z can +!! be X or Y, and p can be q, u, v, or h. z describes the direction +!! of the metric, while p describes the location. IDzp is the +!! inverse of Dzp, while DXDYp is the product of DXp and DYp except +!! that areaT is calculated analytically from the latitudes and +!! longitudes of the surrounding q points. +!! +!! On a sphere, a variety of grids can be implemented by defining +!! analytic expressions for dx_di, dy_dj (where x and y are latitude +!! and longitude, and i and j are grid indices) and the expressions +!! for the integrals of their inverses in the four subroutines +!! dy_dj, Int_dj_dy, dx_di, and Int_di_dx. +!! +!! initialize_masks sets up land masks based on the depth field. +!! The one argument is the minimum ocean depth. Depths that are +!! less than this are interpreted as land points. + +end module MOM_grid_initialize diff --git a/initialization/MOM_shared_initialization.F90 b/initialization/MOM_shared_initialization.F90 new file mode 100644 index 0000000000..821232b80d --- /dev/null +++ b/initialization/MOM_shared_initialization.F90 @@ -0,0 +1,1460 @@ +!> Code that initializes fixed aspects of the model grid, such as horizontal +!! grid metrics, topography and Coriolis, and can be shared between components. +module MOM_shared_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : max_across_PEs, reproducing_sum +use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast +use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_param, param_file_type, log_version +use MOM_io, only : create_MOM_file, file_exists, field_size +use MOM_io, only : MOM_infra_file, MOM_field +use MOM_io, only : MOM_read_data, MOM_read_vector, read_variable, stdout +use MOM_io, only : open_file_to_read, close_file_to_read, SINGLE_FILE, MULTIPLE +use MOM_io, only : slasher, vardesc, MOM_write_field, var_desc +use MOM_string_functions, only : uppercase +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +public MOM_shared_init_init +public MOM_initialize_rotation, MOM_calculate_grad_Coriolis +public initialize_topography_from_file, apply_topography_edits_from_file +public initialize_topography_named, limit_topography, diagnoseMaximumDepth +public set_rotation_planetary, set_rotation_beta_plane, initialize_grid_rotation_angle +public reset_face_lengths_named, reset_face_lengths_file, reset_face_lengths_list +public read_face_length_list, set_velocity_depth_max, set_velocity_depth_min +public set_subgrid_topo_at_vel_from_file +public compute_global_grid_integrals, write_ocean_geometry_file + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +! ----------------------------------------------------------------------------- +!> MOM_shared_init_init just writes the code version. +subroutine MOM_shared_init_init(PF) + type(param_file_type), intent(in) :: PF !< A structure indicating the open file + !! to parse for model parameter values. + + character(len=40) :: mdl = "MOM_shared_initialization" ! This module's name. + +! This include declares and sets the variable "version". +#include "version_variable.h" + call log_version(PF, mdl, version, & + "Sharable code to initialize time-invariant fields, like bathymetry and Coriolis parameters.") + +end subroutine MOM_shared_init_init +! ----------------------------------------------------------------------------- + +!> MOM_initialize_rotation makes the appropriate call to set up the Coriolis parameter. +subroutine MOM_initialize_rotation(f, G, PF, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent(out) :: f !< The Coriolis parameter [T-1 ~> s-1] + type(param_file_type), intent(in) :: PF !< Parameter file structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + +! This subroutine makes the appropriate call to set up the Coriolis parameter. +! This is a separate subroutine so that it can be made public and shared with +! the ice-sheet code or other components. +! Set up the Coriolis parameter, f, either analytically or from file. + character(len=40) :: mdl = "MOM_initialize_rotation" ! This subroutine's name. + character(len=200) :: config + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + call get_param(PF, mdl, "ROTATION", config, & + "This specifies how the Coriolis parameter is specified: \n"//& + " \t 2omegasinlat - Use twice the planetary rotation rate \n"//& + " \t\t times the sine of latitude.\n"//& + " \t betaplane - Use a beta-plane or f-plane.\n"//& + " \t USER - call a user modified routine.", & + default="2omegasinlat") + select case (trim(config)) + case ("2omegasinlat"); call set_rotation_planetary(f, G, PF, US) + case ("beta"); call set_rotation_beta_plane(f, G, PF, US) + case ("betaplane"); call set_rotation_beta_plane(f, G, PF, US) + !case ("nonrotating") ! Note from AJA: Missing case? + case default ; call MOM_error(FATAL,"MOM_initialize: "// & + "Unrecognized rotation setup "//trim(config)) + end select + call callTree_leave(trim(mdl)//'()') +end subroutine MOM_initialize_rotation + +!> Calculates the components of grad f (Coriolis parameter) +subroutine MOM_calculate_grad_Coriolis(dF_dx, dF_dy, G, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: dF_dx !< x-component of grad f [T-1 L-1 ~> s-1 m-1] + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: dF_dy !< y-component of grad f [T-1 L-1 ~> s-1 m-1] + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + ! Local variables + character(len=40) :: mdl = "MOM_calculate_grad_Coriolis" ! This subroutine's name. + integer :: i,j + real :: f1, f2 ! Average of adjacent Coriolis parameters [T-1 ~> s-1] + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + if ((LBOUND(G%CoriolisBu,1) > G%isc-1) .or. & + (LBOUND(G%CoriolisBu,2) > G%jsc-1)) then + ! The gradient of the Coriolis parameter can not be calculated with this grid. + dF_dx(:,:) = 0.0 ; dF_dy(:,:) = 0.0 + return + endif + + do j=G%jsc, G%jec ; do i=G%isc, G%iec + f1 = 0.5*( G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) + f2 = 0.5*( G%CoriolisBu(I-1,J) + G%CoriolisBu(I-1,J-1) ) + dF_dx(i,j) = G%IdxT(i,j) * ( f1 - f2 ) + f1 = 0.5*( G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J) ) + f2 = 0.5*( G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J-1) ) + dF_dy(i,j) = G%IdyT(i,j) * ( f1 - f2 ) + enddo ; enddo + call pass_vector(dF_dx, dF_dy, G%Domain, stagger=AGRID) + call callTree_leave(trim(mdl)//'()') + +end subroutine MOM_calculate_grad_Coriolis + +!> Return the global maximum ocean bottom depth in the same units as the input depth. +function diagnoseMaximumDepth(D, G) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(in) :: D !< Ocean bottom depth in [m] or [Z ~> m] + real :: diagnoseMaximumDepth !< The global maximum ocean bottom depth in [m] or [Z ~> m] + ! Local variables + integer :: i,j + diagnoseMaximumDepth = D(G%isc,G%jsc) + do j=G%jsc, G%jec ; do i=G%isc, G%iec + diagnoseMaximumDepth = max(diagnoseMaximumDepth,D(i,j)) + enddo ; enddo + call max_across_PEs(diagnoseMaximumDepth) +end function diagnoseMaximumDepth + + +!> Read gridded depths from file +subroutine initialize_topography_from_file(D, G, param_file, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! Local variables + character(len=200) :: filename, topo_file, inputdir ! Strings for file/path + character(len=200) :: topo_varname ! Variable name in file + character(len=40) :: mdl = "initialize_topography_from_file" ! This subroutine's name. + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "TOPO_FILE", topo_file, & + "The file from which the bathymetry is read.", & + default="topog.nc") + call get_param(param_file, mdl, "TOPO_VARNAME", topo_varname, & + "The name of the bathymetry variable in TOPO_FILE.", & + default="depth") + + filename = trim(inputdir)//trim(topo_file) + call log_param(param_file, mdl, "INPUTDIR/TOPO_FILE", filename) + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_topography_from_file: Unable to open "//trim(filename)) + + D(:,:) = -9.0e30*US%m_to_Z ! Initializing to a very large negative depth (tall mountains) everywhere + ! before reading from a file should do nothing. However, in the instance of + ! masked-out PEs, halo regions are not updated when a processor does not + ! exist. We need to ensure the depth in masked-out PEs appears to be that + ! of land so this line does that in the halo regions. For non-masked PEs + ! the halo region is filled properly with a later pass_var(). + call MOM_read_data(filename, trim(topo_varname), D, G%Domain, scale=US%m_to_Z) + + call apply_topography_edits_from_file(D, G, param_file, US) + + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_topography_from_file + +!> Applies a list of topography overrides read from a netcdf file +subroutine apply_topography_edits_from_file(D, G, param_file, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(inout) :: D !< Ocean bottom depth [m] or [Z ~> m] if + !! US is present + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real, dimension(:), allocatable :: new_depth ! The new values of the depths [Z ~> m] + integer, dimension(:), allocatable :: ig, jg ! The global indicies of the points to modify + character(len=200) :: topo_edits_file, inputdir ! Strings for file/path + character(len=40) :: mdl = "apply_topography_edits_from_file" ! This subroutine's name. + integer :: i, j, n, ncid, n_edits, i_file, j_file, ndims, sizes(8) + logical :: topo_edits_change_mask + real :: min_depth ! The shallowest value of wet points [Z ~> m] + real :: mask_depth ! The depth defining the land-sea boundary [Z ~> m] + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "TOPO_EDITS_FILE", topo_edits_file, & + "The file from which to read a list of i,j,z topography overrides.", & + default="") + call get_param(param_file, mdl, "ALLOW_LANDMASK_CHANGES", topo_edits_change_mask, & + "If true, allow topography overrides to change land mask.", & + default=.false.) + call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & + "If MASKING_DEPTH is unspecified, then anything shallower than "//& + "MINIMUM_DEPTH is assumed to be land and all fluxes are masked out. "//& + "If MASKING_DEPTH is specified, then all depths shallower than "//& + "MINIMUM_DEPTH but deeper than MASKING_DEPTH are rounded to MINIMUM_DEPTH.", & + units="m", default=0.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "MASKING_DEPTH", mask_depth, & + "The depth below which to mask points as land points, for which all "//& + "fluxes are zeroed out. MASKING_DEPTH is ignored if it has the special "//& + "default value.", & + units="m", default=-9999.0, scale=US%m_to_Z) + if (mask_depth == -9999.*US%m_to_Z) mask_depth = min_depth + + if (len_trim(topo_edits_file)==0) return + + topo_edits_file = trim(inputdir)//trim(topo_edits_file) + if (is_root_PE()) then + if (.not.file_exists(topo_edits_file, G%Domain)) & + call MOM_error(FATAL, trim(mdl)//': Unable to find file '//trim(topo_edits_file)) + call open_file_to_read(topo_edits_file, ncid) + else + ncid = -1 + endif + + ! Read and check the values of ni and nj in the file for consistency with this configuration. + call read_variable(topo_edits_file, 'ni', i_file, ncid_in=ncid) + call read_variable(topo_edits_file, 'nj', j_file, ncid_in=ncid) + if (i_file /= G%ieg) call MOM_error(FATAL, trim(mdl)//': Incompatible i-dimension of grid in '//& + trim(topo_edits_file)) + if (j_file /= G%jeg) call MOM_error(FATAL, trim(mdl)//': Incompatible j-dimension of grid in '//& + trim(topo_edits_file)) + + ! Get nEdits + call field_size(topo_edits_file, 'zEdit', sizes, ndims=ndims, ncid_in=ncid) + if (ndims /= 1) call MOM_error(FATAL, "The variable zEdit has an "//& + "unexpected number of dimensions in "//trim(topo_edits_file) ) + n_edits = sizes(1) + allocate(ig(n_edits)) + allocate(jg(n_edits)) + allocate(new_depth(n_edits)) + + ! Read iEdit, jEdit and zEdit + call read_variable(topo_edits_file, 'iEdit', ig, ncid_in=ncid) + call read_variable(topo_edits_file, 'jEdit', jg, ncid_in=ncid) + call read_variable(topo_edits_file, 'zEdit', new_depth, ncid_in=ncid, scale=US%m_to_Z) + call close_file_to_read(ncid, topo_edits_file) + + do n = 1, n_edits + i = ig(n) - G%idg_offset + 1 ! +1 for python indexing + j = jg(n) - G%jdg_offset + 1 + if (i>=G%isc .and. i<=G%iec .and. j>=G%jsc .and. j<=G%jec) then + if (new_depth(n) /= mask_depth) then + write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & + 'Ocean topography edit: ', n, ig(n), jg(n), D(i,j)*US%Z_to_m, '->', abs(US%Z_to_m*new_depth(n)), i, j + D(i,j) = abs(new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) + else + if (topo_edits_change_mask) then + write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & + 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j)*US%Z_to_m,'->',abs(US%Z_to_m*new_depth(n)),i,j + D(i,j) = abs(new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) + else + call MOM_error(FATAL, ' apply_topography_edits_from_file: '//& + "A zero depth edit would change the land mask and is not allowed in"//trim(topo_edits_file)) + endif + endif + endif + enddo + + deallocate( ig, jg, new_depth ) + + call callTree_leave(trim(mdl)//'()') +end subroutine apply_topography_edits_from_file + +!> initialize the bathymetry based on one of several named idealized configurations +subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + character(len=*), intent(in) :: topog_config !< The name of an idealized + !! topographic configuration + real, intent(in) :: max_depth !< Maximum depth [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! This subroutine places the bottom depth in m into D(:,:), shaped according to the named config. + + ! Local variables + real :: min_depth ! The minimum depth [Z ~> m]. + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: D0 ! A constant to make the maximum basin depth MAXIMUM_DEPTH [Z ~> m] + real :: expdecay ! A decay scale of associated with the sloping boundaries [L ~> m] + real :: Dedge ! The depth at the basin edge [Z ~> m] + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + character(len=40) :: mdl = "initialize_topography_named" ! This subroutine's name. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + call MOM_mesg(" MOM_shared_initialization.F90, initialize_topography_named: "//& + "TOPO_CONFIG = "//trim(topog_config), 5) + + call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) + if (max_depth<=0.) call MOM_error(FATAL,"initialize_topography_named: "// & + "MAXIMUM_DEPTH has a non-sensical value! Was it set?") + + if (trim(topog_config) /= "flat") then + call get_param(param_file, mdl, "EDGE_DEPTH", Dedge, & + "The depth at the edge of one of the named topographies.", & + units="m", default=100.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "TOPOG_SLOPE_SCALE", expdecay, & + "The exponential decay scale used in defining some of "//& + "the named topographies.", units="m", default=400000.0, scale=US%m_to_L) + endif + + + PI = 4.0*atan(1.0) + + if (trim(topog_config) == "flat") then + do j=js,je ; do i=is,ie ; D(i,j) = max_depth ; enddo ; enddo + elseif (trim(topog_config) == "spoon") then + D0 = (max_depth - Dedge) / & + ((1.0 - exp(-0.5*G%len_lat*G%Rad_Earth_L*PI/(180.0 *expdecay))) * & + (1.0 - exp(-0.5*G%len_lat*G%Rad_Earth_L*PI/(180.0 *expdecay)))) + do j=js,je ; do i=is,ie + ! This sets a bowl shaped (sort of) bottom topography, with a ! + ! maximum depth of max_depth. ! + D(i,j) = Dedge + D0 * & + (sin(PI * (G%geoLonT(i,j) - (G%west_lon)) / G%len_lon) * & + (1.0 - exp((G%geoLatT(i,j) - (G%south_lat+G%len_lat))*G%Rad_Earth_L*PI / & + (180.0*expdecay)) )) + enddo ; enddo + elseif (trim(topog_config) == "bowl") then + D0 = (max_depth - Dedge) / & + ((1.0 - exp(-0.5*G%len_lat*G%Rad_Earth_L*PI/(180.0 *expdecay))) * & + (1.0 - exp(-0.5*G%len_lat*G%Rad_Earth_L*PI/(180.0 *expdecay)))) + + ! This sets a bowl shaped (sort of) bottom topography, with a + ! maximum depth of max_depth. + do j=js,je ; do i=is,ie + D(i,j) = Dedge + D0 * & + (sin(PI * (G%geoLonT(i,j) - G%west_lon) / G%len_lon) * & + ((1.0 - exp(-(G%geoLatT(i,j) - G%south_lat)*G%Rad_Earth_L*PI/ & + (180.0*expdecay))) * & + (1.0 - exp((G%geoLatT(i,j) - (G%south_lat+G%len_lat))* & + G%Rad_Earth_L*PI/(180.0*expdecay))))) + enddo ; enddo + elseif (trim(topog_config) == "halfpipe") then + D0 = max_depth - Dedge + do j=js,je ; do i=is,ie + D(i,j) = Dedge + D0 * ABS(sin(PI*(G%geoLatT(i,j) - G%south_lat)/G%len_lat)) + enddo ; enddo + else + call MOM_error(FATAL,"initialize_topography_named: "// & + "Unrecognized topography name "//trim(topog_config)) + endif + + ! This is here just for safety. Hopefully it doesn't do anything. + do j=js,je ; do i=is,ie + if (D(i,j) > max_depth) D(i,j) = max_depth + if (D(i,j) < min_depth) D(i,j) = 0.5*min_depth + enddo ; enddo + + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_topography_named +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> limit_topography ensures that min_depth < D(x,y) < max_depth +subroutine limit_topography(D, G, param_file, max_depth, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(inout) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum depth of model [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + integer :: i, j + character(len=40) :: mdl = "limit_topography" ! This subroutine's name. + real :: min_depth ! The shallowest value of wet points [Z ~> m] + real :: mask_depth ! The depth defining the land-sea boundary [Z ~> m] + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + + call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & + "If MASKING_DEPTH is unspecified, then anything shallower than "//& + "MINIMUM_DEPTH is assumed to be land and all fluxes are masked out. "//& + "If MASKING_DEPTH is specified, then all depths shallower than "//& + "MINIMUM_DEPTH but deeper than MASKING_DEPTH are rounded to MINIMUM_DEPTH.", & + units="m", default=0.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "MASKING_DEPTH", mask_depth, & + "The depth below which to mask points as land points, for which all "//& + "fluxes are zeroed out. MASKING_DEPTH is ignored if it has the special "//& + "default value.", & + units="m", default=-9999.0, scale=US%m_to_Z, do_not_log=.true.) + + ! Make sure that min_depth < D(x,y) < max_depth for ocean points + ! TBD: The following f.p. equivalence uses a special value. Originally, any negative value + ! indicated the branch. We should create a logical flag to indicate this branch. + if (mask_depth == -9999.*US%m_to_Z) then + if (min_depth<0.) then + call MOM_error(FATAL, trim(mdl)//": MINIMUM_DEPTH<0 does not work as expected "//& + "unless MASKING_DEPTH has been set appropriately. Set a meaningful "//& + "MASKING_DEPTH to enabled negative depths (land elevations) and to "//& + "enable flooding.") + endif + ! This is the old path way. The 0.5*min_depth is obscure and is retained to be + ! backward reproducible. If you are looking at the following line you should probably + ! set MASKING_DEPTH. This path way does not work for negative depths, i.e. flooding. + do j=G%jsd,G%jed ; do i=G%isd,G%ied + D(i,j) = min( max( D(i,j), 0.5*min_depth ), max_depth ) + enddo ; enddo + else + ! This is the preferred path way. + ! mask_depth has a meaningful value; anything shallower than mask_depth is land. + ! If min_depth min(min_depth,mask_depth)) then + D(i,j) = min( max( D(i,j), min_depth ), max_depth ) + else + ! This statement is required for cases with masked-out PEs over the land, + ! to remove the large initialized values (-9e30) from the halos. + D(i,j) = min(min_depth,mask_depth) + endif + enddo ; enddo + endif + + call callTree_leave(trim(mdl)//'()') +end subroutine limit_topography +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> This subroutine sets up the Coriolis parameter for a sphere +subroutine set_rotation_planetary(f, G, param_file, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(out) :: f !< Coriolis parameter (vertical component) [T-1 ~> s-1] + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + +! This subroutine sets up the Coriolis parameter for a sphere + character(len=30) :: mdl = "set_rotation_planetary" ! This subroutine's name. + integer :: I, J + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: omega ! The planetary rotation rate [T-1 ~> s-1] + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + + call get_param(param_file, "set_rotation_planetary", "OMEGA", omega, & + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) + PI = 4.0*atan(1.0) + + do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB + f(I,J) = ( 2.0 * omega ) * sin( ( PI * G%geoLatBu(I,J) ) / 180.) + enddo ; enddo + + call callTree_leave(trim(mdl)//'()') +end subroutine set_rotation_planetary +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> This subroutine sets up the Coriolis parameter for a beta-plane or f-plane +subroutine set_rotation_beta_plane(f, G, param_file, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(out) :: f !< Coriolis parameter (vertical component) [T-1 ~> s-1] + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + +! This subroutine sets up the Coriolis parameter for a beta-plane + integer :: I, J + real :: f_0 ! The reference value of the Coriolis parameter [T-1 ~> s-1] + real :: beta ! The meridional gradient of the Coriolis parameter [T-1 L-1 ~> s-1 m-1] + real :: beta_lat_ref ! The reference latitude for the beta plane [degrees_N] or [km] or [m] + real :: Rad_Earth_L ! The radius of the planet in rescaled units [L ~> m] + real :: y_scl ! A scaling factor from the units of latitude [L lat-1 ~> m lat-1] + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + character(len=40) :: mdl = "set_rotation_beta_plane" ! This subroutine's name. + character(len=200) :: axis_units + character(len=40) :: beta_lat_ref_units + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + + call get_param(param_file, mdl, "F_0", f_0, & + "The reference value of the Coriolis parameter with the "//& + "betaplane option.", units="s-1", default=0.0, scale=US%T_to_s) + call get_param(param_file, mdl, "BETA", beta, & + "The northward gradient of the Coriolis parameter with "//& + "the betaplane option.", units="m-1 s-1", default=0.0, scale=US%T_to_s*US%L_to_m) + call get_param(param_file, mdl, "AXIS_UNITS", axis_units, default="degrees") + + PI = 4.0*atan(1.0) + select case (axis_units(1:1)) + case ("d") + call get_param(param_file, mdl, "RAD_EARTH", Rad_Earth_L, & + "The radius of the Earth.", units="m", default=6.378e6, scale=US%m_to_L) + beta_lat_ref_units = "degrees" + y_scl = PI * Rad_Earth_L / 180. + case ("k") + beta_lat_ref_units = "kilometers" + y_scl = 1.0e3 * US%m_to_L + case ("m") + beta_lat_ref_units = "meters" + y_scl = 1.0 * US%m_to_L + case default ; call MOM_error(FATAL, & + " set_rotation_beta_plane: unknown AXIS_UNITS = "//trim(axis_units)) + end select + + call get_param(param_file, mdl, "BETA_LAT_REF", beta_lat_ref, & + "The reference latitude (origin) of the beta-plane", & + units=trim(beta_lat_ref_units), default=0.0) + + do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB + f(I,J) = f_0 + beta * ( (G%geoLatBu(I,J) - beta_lat_ref) * y_scl ) + enddo ; enddo + + call callTree_leave(trim(mdl)//'()') +end subroutine set_rotation_beta_plane + +!> initialize_grid_rotation_angle initializes the arrays with the sine and +!! cosine of the angle between logical north on the grid and true north. +subroutine initialize_grid_rotation_angle(G, PF) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid + type(param_file_type), intent(in) :: PF !< A structure indicating the open file + !! to parse for model parameter values. + + real :: angle ! The clockwise angle of the grid relative to true north [degrees] + real :: lon_scale ! The trigonometric scaling factor converting changes in longitude + ! to equivalent distances in latitudes [nondim] + real :: len_lon ! The periodic range of longitudes, usually 360 degrees [degrees_E]. + real :: pi_720deg ! One quarter the conversion factor from degrees to radians [radian degree-1] + real :: lonB(2,2) ! The longitude of a point, shifted to have about the same value [degrees_E]. + character(len=40) :: mdl = "initialize_grid_rotation_angle" ! This subroutine's name. + logical :: use_bugs + integer :: i, j, m, n + + call get_param(PF, mdl, "GRID_ROTATION_ANGLE_BUGS", use_bugs, & + "If true, use an older algorithm to calculate the sine and "//& + "cosines needed rotate between grid-oriented directions and "//& + "true north and east. Differences arise at the tripolar fold.", & + default=.false.) + + if (use_bugs) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon_scale = cos((G%geoLatBu(I-1,J-1) + G%geoLatBu(I,J-1 ) + & + G%geoLatBu(I-1,J) + G%geoLatBu(I,J)) * atan(1.0)/180) + angle = atan2((G%geoLonBu(I-1,J) + G%geoLonBu(I,J) - & + G%geoLonBu(I-1,J-1) - G%geoLonBu(I,J-1))*lon_scale, & + G%geoLatBu(I-1,J) + G%geoLatBu(I,J) - & + G%geoLatBu(I-1,J-1) - G%geoLatBu(I,J-1) ) + G%sin_rot(i,j) = sin(angle) ! angle is the clockwise angle from lat/lon to ocean + G%cos_rot(i,j) = cos(angle) ! grid (e.g. angle of ocean "north" from true north) + enddo ; enddo + + ! This is not right at a tripolar or cubed-sphere fold. + call pass_var(G%cos_rot, G%Domain) + call pass_var(G%sin_rot, G%Domain) + else + pi_720deg = atan(1.0) / 180.0 + len_lon = 360.0 ; if (G%len_lon > 0.0) len_lon = G%len_lon + do j=G%jsc,G%jec ; do i=G%isc,G%iec + do n=1,2 ; do m=1,2 + lonB(m,n) = modulo_around_point(G%geoLonBu(I+m-2,J+n-2), G%geoLonT(i,j), len_lon) + enddo ; enddo + lon_scale = cos(pi_720deg*((G%geoLatBu(I-1,J-1) + G%geoLatBu(I,J)) + & + (G%geoLatBu(I,J-1) + G%geoLatBu(I-1,J)) ) ) + angle = atan2(lon_scale*((lonB(1,2) - lonB(2,1)) + (lonB(2,2) - lonB(1,1))), & + (G%geoLatBu(I-1,J) - G%geoLatBu(I,J-1)) + & + (G%geoLatBu(I,J) - G%geoLatBu(I-1,J-1)) ) + G%sin_rot(i,j) = sin(angle) ! angle is the clockwise angle from lat/lon to ocean + G%cos_rot(i,j) = cos(angle) ! grid (e.g. angle of ocean "north" from true north) + enddo ; enddo + + call pass_vector(G%cos_rot, G%sin_rot, G%Domain, stagger=AGRID) + endif + +end subroutine initialize_grid_rotation_angle + +! ----------------------------------------------------------------------------- +!> Return the modulo value of x in an interval [xc-(Lx/2) xc+(Lx/2)] +!! If Lx<=0, then it returns x without applying modulo arithmetic. +function modulo_around_point(x, xc, Lx) result(x_mod) + real, intent(in) :: x !< Value to which to apply modulo arithmetic [A] + real, intent(in) :: xc !< Center of modulo range [A] + real, intent(in) :: Lx !< Modulo range width [A] + real :: x_mod !< x shifted by an integer multiple of Lx to be close to xc [A]. + + if (Lx > 0.0) then + x_mod = modulo(x - (xc - 0.5*Lx), Lx) + (xc - 0.5*Lx) + else + x_mod = x + endif +end function modulo_around_point + +! ----------------------------------------------------------------------------- +!> This subroutine sets the open face lengths at selected points to restrict +!! passages to their observed widths based on a named set of sizes. +subroutine reset_face_lengths_named(G, param_file, name, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + character(len=*), intent(in) :: name !< The name for the set of face lengths. Only "global_1deg" + !! is currently implemented. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + character(len=256) :: mesg ! Message for error messages. + real :: dx_2 ! Half the local zonal grid spacing [degrees_E] + real :: dy_2 ! Half the local meridional grid spacing [degrees_N] + real :: pi_180 ! Conversion factor from degrees to radians [nondim] + integer :: option + integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + pi_180 = (4.0*atan(1.0))/180.0 + + dx_2 = -1.0 ; dy_2 = -1.0 + option = -1 + + select case ( trim(name) ) + case ("global_1deg") ; option = 1 ; dx_2 = 0.5*1.0 + case default ; call MOM_error(FATAL, "reset_face_lengths_named: "//& + "Unrecognized channel configuration name "//trim(name)) + end select + + if (option==1) then ! 1-degree settings. + do j=jsd,jed ; do I=IsdB,IedB ! Change any u-face lengths within this loop. + dy_2 = dx_2 * G%dyCu(I,j)*G%IdxCu(I,j) * cos(pi_180 * G%geoLatCu(I,j)) + + if ((abs(G%geoLatCu(I,j)-35.5) < dy_2) .and. (G%geoLonCu(I,j) < -4.5) .and. & + (G%geoLonCu(I,j) > -6.5)) & + G%dy_Cu(I,j) = G%mask2dCu(I,j)*12000.0*US%m_to_L ! Gibraltar + + if ((abs(G%geoLatCu(I,j)-12.5) < dy_2) .and. (abs(G%geoLonCu(I,j)-43.0) < dx_2)) & + G%dy_Cu(I,j) = G%mask2dCu(I,j)*10000.0*US%m_to_L ! Red Sea + + if ((abs(G%geoLatCu(I,j)-40.5) < dy_2) .and. (abs(G%geoLonCu(I,j)-26.0) < dx_2)) & + G%dy_Cu(I,j) = G%mask2dCu(I,j)*5000.0*US%m_to_L ! Dardanelles + + if ((abs(G%geoLatCu(I,j)-41.5) < dy_2) .and. (abs(G%geoLonCu(I,j)+220.0) < dx_2)) & + G%dy_Cu(I,j) = G%mask2dCu(I,j)*35000.0*US%m_to_L ! Tsugaru strait at 140.0e + + if ((abs(G%geoLatCu(I,j)-45.5) < dy_2) .and. (abs(G%geoLonCu(I,j)+217.5) < 0.9)) & + G%dy_Cu(I,j) = G%mask2dCu(I,j)*15000.0*US%m_to_L ! Betw Hokkaido and Sakhalin at 217&218 = 142e + + ! Greater care needs to be taken in the tripolar region. + if ((abs(G%geoLatCu(I,j)-80.84) < 0.2) .and. (abs(G%geoLonCu(I,j)+64.9) < 0.8)) & + G%dy_Cu(I,j) = G%mask2dCu(I,j)*38000.0*US%m_to_L ! Smith Sound in Canadian Arch - tripolar region + + enddo ; enddo + + do J=JsdB,JedB ; do i=isd,ied ! Change any v-face lengths within this loop. + dy_2 = dx_2 * G%dyCv(i,J)*G%IdxCv(i,J) * cos(pi_180 * G%geoLatCv(i,J)) + if ((abs(G%geoLatCv(i,J)-41.0) < dy_2) .and. (abs(G%geoLonCv(i,J)-28.5) < dx_2)) & + G%dx_Cv(i,J) = G%mask2dCv(i,J)*2500.0*US%m_to_L ! Bosporus - should be 1000.0 m wide. + + if ((abs(G%geoLatCv(i,J)-13.0) < dy_2) .and. (abs(G%geoLonCv(i,J)-42.5) < dx_2)) & + G%dx_Cv(i,J) = G%mask2dCv(i,J)*10000.0*US%m_to_L ! Red Sea + + if ((abs(G%geoLatCv(i,J)+2.8) < 0.8) .and. (abs(G%geoLonCv(i,J)+241.5) < dx_2)) & + G%dx_Cv(i,J) = G%mask2dCv(i,J)*40000.0*US%m_to_L ! Makassar Straits at 241.5 W = 118.5 E + + if ((abs(G%geoLatCv(i,J)-0.56) < 0.5) .and. (abs(G%geoLonCv(i,J)+240.5) < dx_2)) & + G%dx_Cv(i,J) = G%mask2dCv(i,J)*80000.0*US%m_to_L ! entry to Makassar Straits at 240.5 W = 119.5 E + + if ((abs(G%geoLatCv(i,J)-0.19) < 0.5) .and. (abs(G%geoLonCv(i,J)+230.5) < dx_2)) & + G%dx_Cv(i,J) = G%mask2dCv(i,J)*25000.0*US%m_to_L ! Channel betw N Guinea and Halmahara 230.5 W = 129.5 E + + if ((abs(G%geoLatCv(i,J)-0.19) < 0.5) .and. (abs(G%geoLonCv(i,J)+229.5) < dx_2)) & + G%dx_Cv(i,J) = G%mask2dCv(i,J)*25000.0*US%m_to_L ! Channel betw N Guinea and Halmahara 229.5 W = 130.5 E + + if ((abs(G%geoLatCv(i,J)-0.0) < 0.25) .and. (abs(G%geoLonCv(i,J)+228.5) < dx_2)) & + G%dx_Cv(i,J) = G%mask2dCv(i,J)*25000.0*US%m_to_L ! Channel betw N Guinea and Halmahara 228.5 W = 131.5 E + + if ((abs(G%geoLatCv(i,J)+8.5) < 0.5) .and. (abs(G%geoLonCv(i,J)+244.5) < dx_2)) & + G%dx_Cv(i,J) = G%mask2dCv(i,J)*20000.0*US%m_to_L ! Lombok Straits at 244.5 W = 115.5 E + + if ((abs(G%geoLatCv(i,J)+8.5) < 0.5) .and. (abs(G%geoLonCv(i,J)+235.5) < dx_2)) & + G%dx_Cv(i,J) = G%mask2dCv(i,J)*20000.0*US%m_to_L ! Timor Straits at 235.5 W = 124.5 E + + if ((abs(G%geoLatCv(i,J)-52.5) < dy_2) .and. (abs(G%geoLonCv(i,J)+218.5) < dx_2)) & + G%dx_Cv(i,J) = G%mask2dCv(i,J)*2500.0*US%m_to_L ! Russia and Sakhalin Straits at 218.5 W = 141.5 E + + ! Greater care needs to be taken in the tripolar region. + if ((abs(G%geoLatCv(i,J)-76.8) < 0.06) .and. (abs(G%geoLonCv(i,J)+88.7) < dx_2)) & + G%dx_Cv(i,J) = G%mask2dCv(i,J)*8400.0*US%m_to_L ! Jones Sound in Canadian Arch - tripolar region + + enddo ; enddo + endif + + ! These checks apply regardless of the chosen option. + + do j=jsd,jed ; do I=IsdB,IedB + if (G%dy_Cu(I,j) > G%dyCu(I,j)) then + write(mesg,'("dy_Cu of ",ES11.4," exceeds unrestricted width of ",ES11.4,& + &" by ",ES11.4," at lon/lat of ", ES11.4, ES11.4)') & + US%L_to_m*G%dy_Cu(I,j), US%L_to_m*G%dyCu(I,j), US%L_to_m*(G%dy_Cu(I,j)-G%dyCu(I,j)), & + G%geoLonCu(I,j), G%geoLatCu(I,j) + call MOM_error(FATAL,"reset_face_lengths_named "//mesg) + endif + G%areaCu(I,j) = G%dxCu(I,j) * G%dy_Cu(I,j) + G%IareaCu(I,j) = 0.0 + if (G%areaCu(I,j) > 0.0) G%IareaCu(I,j) = G%mask2dCu(I,j) / (G%areaCu(I,j)) + enddo ; enddo + + do J=JsdB,JedB ; do i=isd,ied + if (G%dx_Cv(i,J) > G%dxCv(i,J)) then + write(mesg,'("dx_Cv of ",ES11.4," exceeds unrestricted width of ",ES11.4,& + &" by ",ES11.4, " at lon/lat of ", ES11.4, ES11.4)') & + US%L_to_m*G%dx_Cv(i,J), US%L_to_m*G%dxCv(i,J), US%L_to_m*(G%dx_Cv(i,J)-G%dxCv(i,J)), & + G%geoLonCv(i,J), G%geoLatCv(i,J) + + call MOM_error(FATAL,"reset_face_lengths_named "//mesg) + endif + G%areaCv(i,J) = G%dyCv(i,J) * G%dx_Cv(i,J) + G%IareaCv(i,J) = 0.0 + if (G%areaCv(i,J) > 0.0) G%IareaCv(i,J) = G%mask2dCv(i,J) / (G%areaCv(i,J)) + enddo ; enddo + +end subroutine reset_face_lengths_named +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> This subroutine sets the open face lengths at selected points to restrict +!! passages to their observed widths from a arrays read from a file. +subroutine reset_face_lengths_file(G, param_file, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + character(len=40) :: mdl = "reset_face_lengths_file" ! This subroutine's name. + character(len=256) :: mesg ! Message for error messages. + character(len=200) :: filename, chan_file, inputdir ! Strings for file/path + character(len=64) :: dxCv_open_var, dyCu_open_var ! Open face length names in files + integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + ! These checks apply regardless of the chosen option. + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + + call get_param(param_file, mdl, "CHANNEL_WIDTH_FILE", chan_file, & + "The file from which the list of narrowed channels is read.", & + default="ocean_geometry.nc") + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + filename = trim(inputdir)//trim(chan_file) + call log_param(param_file, mdl, "INPUTDIR/CHANNEL_WIDTH_FILE", filename) + + if (is_root_pe()) then ; if (.not.file_exists(filename)) & + call MOM_error(FATAL," reset_face_lengths_file: Unable to open "//& + trim(filename)) + endif + + call get_param(param_file, mdl, "OPEN_DY_CU_VAR", dyCu_open_var, & + "The u-face open face length variable in CHANNEL_WIDTH_FILE.", & + default="dyCuo") + call get_param(param_file, mdl, "OPEN_DX_CV_VAR", dxCv_open_var, & + "The v-face open face length variable in CHANNEL_WIDTH_FILE.", & + default="dxCvo") + + call MOM_read_vector(filename, dyCu_open_var, dxCv_open_var, G%dy_Cu, G%dx_Cv, G%Domain, scale=US%m_to_L) + call pass_vector(G%dy_Cu, G%dx_Cv, G%Domain, To_All+SCALAR_PAIR, CGRID_NE) + + do j=jsd,jed ; do I=IsdB,IedB + if (G%dy_Cu(I,j) > G%dyCu(I,j)) then + write(mesg,'("dy_Cu of ",ES11.4," exceeds unrestricted width of ",ES11.4,& + &" by ",ES11.4," at lon/lat of ", ES11.4, ES11.4)') & + US%L_to_m*G%dy_Cu(I,j), US%L_to_m*G%dyCu(I,j), US%L_to_m*(G%dy_Cu(I,j)-G%dyCu(I,j)), & + G%geoLonCu(I,j), G%geoLatCu(I,j) + call MOM_error(FATAL,"reset_face_lengths_file "//mesg) + endif + G%areaCu(I,j) = G%dxCu(I,j) * G%dy_Cu(I,j) + G%IareaCu(I,j) = 0.0 + if (G%areaCu(I,j) > 0.0) G%IareaCu(I,j) = G%mask2dCu(I,j) / (G%areaCu(I,j)) + enddo ; enddo + + do J=JsdB,JedB ; do i=isd,ied + if (G%dx_Cv(i,J) > G%dxCv(i,J)) then + write(mesg,'("dx_Cv of ",ES11.4," exceeds unrestricted width of ",ES11.4,& + &" by ",ES11.4, " at lon/lat of ", ES11.4, ES11.4)') & + US%L_to_m*G%dx_Cv(i,J), US%L_to_m*G%dxCv(i,J), US%L_to_m*(G%dx_Cv(i,J)-G%dxCv(i,J)), & + G%geoLonCv(i,J), G%geoLatCv(i,J) + + call MOM_error(FATAL,"reset_face_lengths_file "//mesg) + endif + G%areaCv(i,J) = G%dyCv(i,J) * G%dx_Cv(i,J) + G%IareaCv(i,J) = 0.0 + if (G%areaCv(i,J) > 0.0) G%IareaCv(i,J) = G%mask2dCv(i,J) / (G%areaCv(i,J)) + enddo ; enddo + + call callTree_leave(trim(mdl)//'()') +end subroutine reset_face_lengths_file +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> This subroutine sets the open face lengths at selected points to restrict +!! passages to their observed widths from a list read from a file. +subroutine reset_face_lengths_list(G, param_file, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + character(len=120), pointer, dimension(:) :: lines => NULL() + character(len=120) :: line + character(len=200) :: filename, chan_file, inputdir ! Strings for file/path + character(len=40) :: mdl = "reset_face_lengths_list" ! This subroutine's name. + real, allocatable, dimension(:,:) :: & + u_lat, u_lon, v_lat, v_lon ! The latitude and longitude ranges of faces [degrees_N] or [degrees_E] + real, allocatable, dimension(:) :: & + u_width, v_width ! The open width of faces [L ~> m] + integer, allocatable, dimension(:) :: & + u_line_no, v_line_no, & ! The line numbers in lines of u- and v-face lines + u_line_used, v_line_used ! The number of times each u- and v-line is used. + real, allocatable, dimension(:) :: & + Dmin_u, Dmax_u, Davg_u ! Porous barrier monomial fit params [Z ~> m] + real, allocatable, dimension(:) :: & + Dmin_v, Dmax_v, Davg_v ! Porous barrier monomial fit params [Z ~> m] + real :: lat, lon ! The latitude and longitude of a point [degrees_N] and [degrees_E]. + real :: len_lon ! The periodic range of longitudes, usually 360 degrees [degrees_E]. + real :: len_lat ! The range of latitudes, usually 180 degrees [degrees_N]. + real :: lon_p, lon_m ! The longitude of a point shifted by 360 degrees [degrees_E]. + logical :: check_360 ! If true, check for longitudes that are shifted by + ! +/- 360 degrees from the specified range of values. + logical :: found_u, found_v + logical :: unit_in_use + logical :: fatal_unused_lengths + integer :: unused + integer :: ios, iounit, isu, isv + integer :: num_lines, nl_read, ln, npt, u_pt, v_pt + integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer :: isu_por, isv_por + logical :: found_u_por, found_v_por + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + + call get_param(param_file, mdl, "CHANNEL_LIST_FILE", chan_file, & + "The file from which the list of narrowed channels is read.", & + default="MOM_channel_list") + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + filename = trim(inputdir)//trim(chan_file) + call log_param(param_file, mdl, "INPUTDIR/CHANNEL_LIST_FILE", filename) + call get_param(param_file, mdl, "CHANNEL_LIST_360_LON_CHECK", check_360, & + "If true, the channel configuration list works for any "//& + "longitudes in the range of -360 to 360.", default=.true.) + call get_param(param_file, mdl, "FATAL_UNUSED_CHANNEL_WIDTHS", fatal_unused_lengths, & + "If true, trigger a fatal error if there are any channel widths in "//& + "CHANNEL_LIST_FILE that do not cause any open face widths to change.", & + default=.false.) + + if (is_root_pe()) then + ! Open the input file. + if (.not.file_exists(filename)) call MOM_error(FATAL, & + " reset_face_lengths_list: Unable to open "//trim(filename)) + + ! Find an unused unit number. + do iounit=10,512 + INQUIRE(iounit,OPENED=unit_in_use) ; if (.not.unit_in_use) exit + enddo + if (iounit >= 512) call MOM_error(FATAL, & + "reset_face_lengths_list: No unused file unit could be found.") + + ! Open the parameter file. + open(iounit, file=trim(filename), access='SEQUENTIAL', & + form='FORMATTED', action='READ', position='REWIND', iostat=ios) + if (ios /= 0) call MOM_error(FATAL, & + "reset_face_lengths_list: Error opening "//trim(filename)) + + ! Count the number of u_width and v_width entries. + call read_face_length_list(iounit, filename, num_lines, lines) + endif + + len_lon = 360.0 ; if (G%len_lon > 0.0) len_lon = G%len_lon + len_lat = 180.0 ; if (G%len_lat > 0.0) len_lat = G%len_lat + ! Broadcast the number of lines and allocate the required space. + call broadcast(num_lines, root_PE()) + u_pt = 0 ; v_pt = 0 + if (num_lines > 0) then + allocate(lines(num_lines)) + + allocate(u_lat(2,num_lines), source=-1e34) + allocate(u_lon(2,num_lines), source=-1e34) + allocate(u_width(num_lines), source=-1e34) + allocate(u_line_used(num_lines), source=0) + allocate(u_line_no(num_lines), source=0) + + allocate(v_lat(2,num_lines), source=-1e34) + allocate(v_lon(2,num_lines), source=-1e34) + allocate(v_width(num_lines), source=-1e34) + allocate(v_line_used(num_lines), source=0) + allocate(v_line_no(num_lines), source=0) + + allocate(Dmin_u(num_lines), source=0.0) + allocate(Dmax_u(num_lines), source=0.0) + allocate(Davg_u(num_lines), source=0.0) + + allocate(Dmin_v(num_lines), source=0.0) + allocate(Dmax_v(num_lines), source=0.0) + allocate(Davg_v(num_lines), source=0.0) + + ! Actually read the lines. + if (is_root_pe()) then + call read_face_length_list(iounit, filename, nl_read, lines) + if (nl_read /= num_lines) & + call MOM_error(FATAL, 'reset_face_lengths_list : Found different '// & + 'number of valid lines on second reading of '//trim(filename)) + close(iounit) ; iounit = -1 + endif + + ! Broadcast the lines. + call broadcast(lines, 120, root_PE()) + + ! Populate the u_width, etc., data. + do ln=1,num_lines + line = lines(ln) + ! Detect keywords + found_u = .false.; found_v = .false. + found_u_por = .false.; found_v_por = .false. + isu = index(uppercase(line), "U_WIDTH" ); if (isu > 0) found_u = .true. + isv = index(uppercase(line), "V_WIDTH" ); if (isv > 0) found_v = .true. + isu_por = index(uppercase(line), "U_WIDTH_POR" ); if (isu_por > 0) found_u_por = .true. + isv_por = index(uppercase(line), "V_WIDTH_POR" ); if (isv_por > 0) found_v_por = .true. + + ! Store and check the relevant values. + if (found_u) then + u_pt = u_pt + 1 + if (found_u_por .eqv. .false.) then + read(line(isu+8:),*) u_lon(1:2,u_pt), u_lat(1:2,u_pt), u_width(u_pt) + elseif (found_u_por) then + read(line(isu_por+12:),*) u_lon(1:2,u_pt), u_lat(1:2,u_pt), u_width(u_pt), & + Dmin_u(u_pt), Dmax_u(u_pt), Davg_u(u_pt) + endif + u_width(u_pt) = US%m_to_L*u_width(u_pt) ! Rescale units equivalently to scale=US%m_to_L during read. + Dmin_u(u_pt) = US%m_to_Z*Dmin_u(u_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + Dmax_u(u_pt) = US%m_to_Z*Dmax_u(u_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + Davg_u(u_pt) = US%m_to_Z*Davg_u(u_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + u_line_no(u_pt) = ln + if (is_root_PE()) then + if (check_360) then + if ((abs(u_lon(1,u_pt)) > len_lon) .or. (abs(u_lon(2,u_pt)) > len_lon)) & + call MOM_error(WARNING, "reset_face_lengths_list : Out-of-bounds "//& + "u-longitude found when reading line "//trim(line)//" from file "//& + trim(filename)) + if ((abs(u_lat(1,u_pt)) > len_lat) .or. (abs(u_lat(2,u_pt)) > len_lat)) & + call MOM_error(WARNING, "reset_face_lengths_list : Out-of-bounds "//& + "u-latitude found when reading line "//trim(line)//" from file "//& + trim(filename)) + endif + if (u_lat(1,u_pt) > u_lat(2,u_pt)) & + call MOM_error(WARNING, "reset_face_lengths_list : Out-of-order "//& + "u-face latitudes found when reading line "//trim(line)//" from file "//& + trim(filename)) + if (u_lon(1,u_pt) > u_lon(2,u_pt)) & + call MOM_error(WARNING, "reset_face_lengths_list : Out-of-order "//& + "u-face longitudes found when reading line "//trim(line)//" from file "//& + trim(filename)) + if (u_width(u_pt) < 0.0) & + call MOM_error(WARNING, "reset_face_lengths_list : Negative "//& + "u-width found when reading line "//trim(line)//" from file "//& + trim(filename)) + if (Dmin_u(u_pt) > Dmax_u(u_pt)) & + call MOM_error(WARNING, "reset_face_lengths_list : Out-of-order "//& + "topographical min/max found when reading line "//trim(line)//" from file "//& + trim(filename)) + endif + elseif (found_v) then + v_pt = v_pt + 1 + if (found_v_por .eqv. .false.) then + read(line(isv+8:),*) v_lon(1:2,v_pt), v_lat(1:2,v_pt), v_width(v_pt) + elseif (found_v_por) then + read(line(isv+12:),*) v_lon(1:2,v_pt), v_lat(1:2,v_pt), v_width(v_pt), & + Dmin_v(v_pt), Dmax_v(v_pt), Davg_v(v_pt) + endif + v_width(v_pt) = US%m_to_L*v_width(v_pt) ! Rescale units equivalently to scale=US%m_to_L during read. + Dmin_v(v_pt) = US%m_to_Z*Dmin_v(v_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + Dmax_v(v_pt) = US%m_to_Z*Dmax_v(v_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + Davg_v(v_pt) = US%m_to_Z*Davg_v(v_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + v_line_no(v_pt) = ln + if (is_root_PE()) then + if (check_360) then + if ((abs(v_lon(1,v_pt)) > len_lon) .or. (abs(v_lon(2,v_pt)) > len_lon)) & + call MOM_error(WARNING, "reset_face_lengths_list : Out-of-bounds "//& + "v-longitude found when reading line "//trim(line)//" from file "//& + trim(filename)) + if ((abs(v_lat(1,v_pt)) > len_lat) .or. (abs(v_lat(2,v_pt)) > len_lat)) & + call MOM_error(WARNING, "reset_face_lengths_list : Out-of-bounds "//& + "v-latitude found when reading line "//trim(line)//" from file "//& + trim(filename)) + endif + if (v_lat(1,v_pt) > v_lat(2,v_pt)) & + call MOM_error(WARNING, "reset_face_lengths_list : Out-of-order "//& + "v-face latitudes found when reading line "//trim(line)//" from file "//& + trim(filename)) + if (v_lon(1,v_pt) > v_lon(2,v_pt)) & + call MOM_error(WARNING, "reset_face_lengths_list : Out-of-order "//& + "v-face longitudes found when reading line "//trim(line)//" from file "//& + trim(filename)) + if (v_width(v_pt) < 0.0) & + call MOM_error(WARNING, "reset_face_lengths_list : Negative "//& + "v-width found when reading line "//trim(line)//" from file "//& + trim(filename)) + if (Dmin_v(v_pt) > Dmax_v(v_pt)) & + call MOM_error(WARNING, "reset_face_lengths_list : Out-of-order "//& + "topographical min/max found when reading line "//trim(line)//" from file "//& + trim(filename)) + endif + endif + enddo + + endif + + do j=jsd,jed ; do I=IsdB,IedB + lat = G%geoLatCu(I,j) ; lon = G%geoLonCu(I,j) + if (check_360) then ; lon_p = lon+len_lon ; lon_m = lon-len_lon + else ; lon_p = lon ; lon_m = lon ; endif + + do npt=1,u_pt + if (((lat >= u_lat(1,npt)) .and. (lat <= u_lat(2,npt))) .and. & + (((lon >= u_lon(1,npt)) .and. (lon <= u_lon(2,npt))) .or. & + ((lon_p >= u_lon(1,npt)) .and. (lon_p <= u_lon(2,npt))) .or. & + ((lon_m >= u_lon(1,npt)) .and. (lon_m <= u_lon(2,npt)))) ) then + + G%dy_Cu(I,j) = G%mask2dCu(I,j) * min(G%dyCu(I,j), max(u_width(npt), 0.0)) + G%porous_DminU(I,j) = Dmin_u(npt) + G%porous_DmaxU(I,j) = Dmax_u(npt) + G%porous_DavgU(I,j) = Davg_u(npt) + + if (j>=G%jsc .and. j<=G%jec .and. I>=G%isc .and. I<=G%iec) then ! Limit messages/checking to compute domain + if ( G%mask2dCu(I,j) == 0.0 ) then + write(stdout,'(A,2F8.2,A,4F8.2,A)') "read_face_lengths_list : G%mask2dCu=0 at ",lat,lon," (",& + u_lat(1,npt), u_lat(2,npt), u_lon(1,npt), u_lon(2,npt),") so grid metric is unmodified." + else + u_line_used(npt) = u_line_used(npt) + 1 + write(stdout,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') & + "read_face_lengths_list : Modifying dy_Cu gridpoint at ",lat,lon," (",& + u_lat(1,npt), u_lat(2,npt), u_lon(1,npt), u_lon(2,npt),") to ",US%L_to_m*G%dy_Cu(I,j),"m" + write(stdout,'(A,3F8.2,A)') & + "read_face_lengths_list : Porous Topography parameters: Dmin, Dmax, Davg (",G%porous_DminU(I,j),& + G%porous_DmaxU(I,j), G%porous_DavgU(I,j),")m" + endif + endif + endif + enddo + + G%areaCu(I,j) = G%dxCu(I,j) * G%dy_Cu(I,j) + G%IareaCu(I,j) = 0.0 + if (G%areaCu(I,j) > 0.0) G%IareaCu(I,j) = G%mask2dCu(I,j) / (G%areaCu(I,j)) + enddo ; enddo + + do J=JsdB,JedB ; do i=isd,ied + lat = G%geoLatCv(i,J) ; lon = G%geoLonCv(i,J) + if (check_360) then ; lon_p = lon+len_lon ; lon_m = lon-len_lon + else ; lon_p = lon ; lon_m = lon ; endif + + do npt=1,v_pt + if (((lat >= v_lat(1,npt)) .and. (lat <= v_lat(2,npt))) .and. & + (((lon >= v_lon(1,npt)) .and. (lon <= v_lon(2,npt))) .or. & + ((lon_p >= v_lon(1,npt)) .and. (lon_p <= v_lon(2,npt))) .or. & + ((lon_m >= v_lon(1,npt)) .and. (lon_m <= v_lon(2,npt)))) ) then + G%dx_Cv(i,J) = G%mask2dCv(i,J) * min(G%dxCv(i,J), max(v_width(npt), 0.0)) + G%porous_DminV(i,J) = Dmin_v(npt) + G%porous_DmaxV(i,J) = Dmax_v(npt) + G%porous_DavgV(i,J) = Davg_v(npt) + + if (i>=G%isc .and. i<=G%iec .and. J>=G%jsc .and. J<=G%jec) then ! Limit messages/checking to compute domain + if ( G%mask2dCv(i,J) == 0.0 ) then + write(stdout,'(A,2F8.2,A,4F8.2,A)') "read_face_lengths_list : G%mask2dCv=0 at ",lat,lon," (",& + v_lat(1,npt), v_lat(2,npt), v_lon(1,npt), v_lon(2,npt),") so grid metric is unmodified." + else + v_line_used(npt) = v_line_used(npt) + 1 + write(stdout,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') & + "read_face_lengths_list : Modifying dx_Cv gridpoint at ",lat,lon," (",& + v_lat(1,npt), v_lat(2,npt), v_lon(1,npt), v_lon(2,npt),") to ",US%L_to_m*G%dx_Cv(I,j),"m" + write(stdout,'(A,3F8.2,A)') & + "read_face_lengths_list : Porous Topography parameters: Dmin, Dmax, Davg (",G%porous_DminV(i,J),& + G%porous_DmaxV(i,J), G%porous_DavgV(i,J),")m" + endif + endif + endif + enddo + + G%areaCv(i,J) = G%dyCv(i,J) * G%dx_Cv(i,J) + G%IareaCv(i,J) = 0.0 + if (G%areaCv(i,J) > 0.0) G%IareaCv(i,J) = G%mask2dCv(i,J) / (G%areaCv(i,J)) + enddo ; enddo + + ! Verify that all channel widths have been used + unused = 0 + if (u_pt > 0) call sum_across_PEs(u_line_used, u_pt) + if (v_pt > 0) call sum_across_PEs(v_line_used, v_pt) + if (is_root_PE()) then + unused = 0 + do npt=1,u_pt ; if (u_line_used(npt) == 0) then + call MOM_error(WARNING, "reset_face_lengths_list unused u-face line: "//& + trim(lines(u_line_no(npt))) ) + unused = unused + 1 + endif ; enddo + do npt=1,v_pt ; if (v_line_used(npt) == 0) then + call MOM_error(WARNING, "reset_face_lengths_list unused v-face line: "//& + trim(lines(v_line_no(npt))) ) + unused = unused + 1 + endif ; enddo + if (fatal_unused_lengths .and. (unused > 0)) call MOM_error(FATAL, & + "reset_face_lengths_list causing MOM6 abort due to unused face length lines.") + endif + + if (num_lines > 0) then + deallocate(lines) + deallocate(u_line_used, v_line_used, u_line_no, v_line_no) + deallocate(u_lat) ; deallocate(u_lon) ; deallocate(u_width) + deallocate(v_lat) ; deallocate(v_lon) ; deallocate(v_width) + deallocate(Dmin_u) ; deallocate(Dmax_u) ; deallocate(Davg_u) + deallocate(Dmin_v) ; deallocate(Dmax_v) ; deallocate(Davg_v) + endif + + call callTree_leave(trim(mdl)//'()') +end subroutine reset_face_lengths_list +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> This subroutine reads and counts the non-blank lines in the face length list file, after removing comments. +subroutine read_face_length_list(iounit, filename, num_lines, lines) + integer, intent(in) :: iounit !< An open I/O unit number for the file + character(len=*), intent(in) :: filename !< The name of the face-length file to read + integer, intent(out) :: num_lines !< The number of non-blank lines in the file + character(len=120), dimension(:), pointer :: lines !< The non-blank lines, after removing comments + + ! This subroutine reads and counts the non-blank lines in the face length + ! list file, after removing comments. + character(len=120) :: line, line_up + logical :: found_u, found_v + integer :: isu, isv, icom + integer :: last + + num_lines = 0 + + if (iounit <= 0) return + rewind(iounit) + do while(.true.) + read(iounit, '(a)', end=8, err=9) line + last = len_trim(line) + ! Eliminate either F90 or C comments from the line. + icom = index(line(:last), "!") ; if (icom > 0) last = icom-1 + icom = index(line(:last), "/*") ; if (icom > 0) last = icom-1 + if (last < 1) cycle + + ! Detect keywords + line_up = uppercase(line) + found_u = .false.; found_v = .false. + isu = index(line_up(:last), "U_WIDTH" ); if (isu > 0) found_u = .true. + isv = index(line_up(:last), "V_WIDTH" ); if (isv > 0) found_v = .true. + + if (found_u .and. found_v) call MOM_error(FATAL, & + "read_face_length_list : both U_WIDTH and V_WIDTH found when "//& + "reading the line "//trim(line(:last))//" in file "//trim(filename)) + if (found_u .or. found_v) then + num_lines = num_lines + 1 + if (associated(lines)) then + lines(num_lines) = line(1:last) + endif + endif + enddo ! while (.true.) + +8 continue + return + +9 call MOM_error(FATAL, "read_face_length_list : "//& + "Error while reading file "//trim(filename)) + +end subroutine read_face_length_list +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> Read from a file the maximum, minimum and average bathymetry at velocity points, +!! for the use of porous barrier. +!! Note that we assume the depth values in the sub-grid bathymetry file of the same +!! convention as in-cell bathymetry file, i.e. positive below the sea surface and +!! increasing downward; while in subroutine reset_face_lengths_list, it is implied +!! that read-in fields min_bathy, max_bathy and avg_bathy from the input file +!! CHANNEL_LIST_FILE all have negative values below the surface. Therefore, to ensure +!! backward compatibility, all signs of the variable are inverted here. +!! And porous_Dmax[UV] = shallowest point, porous_Dmin[UV] = deepest point +subroutine set_subgrid_topo_at_vel_from_file(G, param_file, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + character(len=200) :: filename, topo_file, inputdir ! Strings for file/path + character(len=200) :: varname_uhi, varname_ulo, varname_uav, & + varname_vhi, varname_vlo, varname_vav ! Variable names in file + character(len=40) :: mdl = "set_subgrid_topo_at_vel_from_file" ! This subroutine's name. + integer :: i, j + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "TOPO_AT_VEL_FILE", topo_file, & + "The file from which the bathymetry parameters at the velocity points are read. "//& + "While the names of the parameters reflect their physical locations, i.e. HIGH is above LOW, "//& + "their signs follow the model's convention, which is positive below the sea surface", & + default="topog_edge.nc") + call get_param(param_file, mdl, "TOPO_AT_VEL_VARNAME_U_HIGH", varname_uhi, & + "The variable name of the highest bathymetry at the u-cells in TOPO_AT_VEL_FILE.", & + default="depthu_hi") + call get_param(param_file, mdl, "TOPO_AT_VEL_VARNAME_U_LOW", varname_ulo, & + "The variable name of the lowest bathymetry at the u-cells in TOPO_AT_VEL_FILE.", & + default="depthu_lo") + call get_param(param_file, mdl, "TOPO_AT_VEL_VARNAME_U_AVE", varname_uav, & + "The variable name of the average bathymetry at the u-cells in TOPO_AT_VEL_FILE.", & + default="depthu_av") + call get_param(param_file, mdl, "TOPO_AT_VEL_VARNAME_V_HIGH", varname_vhi, & + "The variable name of the highest bathymetry at the v-cells in TOPO_AT_VEL_FILE.", & + default="depthv_hi") + call get_param(param_file, mdl, "TOPO_AT_VEL_VARNAME_V_LOW", varname_vlo, & + "The variable name of the lowest bathymetry at the v-cells in TOPO_AT_VEL_FILE.", & + default="depthv_lo") + call get_param(param_file, mdl, "TOPO_AT_VEL_VARNAME_V_AVE", varname_vav, & + "The variable name of the average bathymetry at the v-cells in TOPO_AT_VEL_FILE.", & + default="depthv_av") + + filename = trim(inputdir)//trim(topo_file) + call log_param(param_file, mdl, "INPUTDIR/TOPO_AT_VEL_FILE", filename) + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " set_subgrid_topo_at_vel_from_file: Unable to open "//trim(filename)) + + call MOM_read_vector(filename, trim(varname_uhi), trim(varname_vhi), & + G%porous_DmaxU, G%porous_DmaxV, G%Domain, stagger=CGRID_NE, scale=US%m_to_Z) + call MOM_read_vector(filename, trim(varname_ulo), trim(varname_vlo), & + G%porous_DminU, G%porous_DminV, G%Domain, stagger=CGRID_NE, scale=US%m_to_Z) + call MOM_read_vector(filename, trim(varname_uav), trim(varname_vav), & + G%porous_DavgU, G%porous_DavgV, G%Domain, stagger=CGRID_NE, scale=US%m_to_Z) + + ! The signs of the depth parameters need to be inverted to be backward compatible with input files + ! used by subroutine reset_face_lengths_list, which assumes depth is negative below the sea surface. + G%porous_DmaxU = -G%porous_DmaxU; G%porous_DminU = -G%porous_DminU; G%porous_DavgU = -G%porous_DavgU + G%porous_DmaxV = -G%porous_DmaxV; G%porous_DminV = -G%porous_DminV; G%porous_DavgV = -G%porous_DavgV + + call pass_vector(G%porous_DmaxU, G%porous_DmaxV, G%Domain, To_All+SCALAR_PAIR, CGRID_NE) + call pass_vector(G%porous_DminU, G%porous_DminV, G%Domain, To_All+SCALAR_PAIR, CGRID_NE) + call pass_vector(G%porous_DavgU, G%porous_DavgV, G%Domain, To_All+SCALAR_PAIR, CGRID_NE) + + call callTree_leave(trim(mdl)//'()') +end subroutine set_subgrid_topo_at_vel_from_file +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> Set the bathymetry at velocity points to be the maximum of the depths at the +!! neighoring tracer points. +subroutine set_velocity_depth_max(G) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid + ! This subroutine sets the 4 bottom depths at velocity points to be the + ! maximum of the adjacent depths. + integer :: i, j + + do I=G%isd,G%ied-1 ; do j=G%jsd,G%jed + G%Dblock_u(I,j) = G%mask2dCu(I,j) * max(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Dopen_u(I,j) = G%Dblock_u(I,j) + enddo ; enddo + do i=G%isd,G%ied ; do J=G%jsd,G%jed-1 + G%Dblock_v(I,J) = G%mask2dCv(i,J) * max(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Dopen_v(I,J) = G%Dblock_v(I,J) + enddo ; enddo +end subroutine set_velocity_depth_max +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> Set the bathymetry at velocity points to be the minimum of the depths at the +!! neighoring tracer points. +subroutine set_velocity_depth_min(G) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid + ! This subroutine sets the 4 bottom depths at velocity points to be the + ! minimum of the adjacent depths. + integer :: i, j + + do I=G%isd,G%ied-1 ; do j=G%jsd,G%jed + G%Dblock_u(I,j) = G%mask2dCu(I,j) * min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Dopen_u(I,j) = G%Dblock_u(I,j) + enddo ; enddo + do i=G%isd,G%ied ; do J=G%jsd,G%jed-1 + G%Dblock_v(I,J) = G%mask2dCv(i,J) * min(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Dopen_v(I,J) = G%Dblock_v(I,J) + enddo ; enddo +end subroutine set_velocity_depth_min +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> Pre-compute global integrals of grid quantities (like masked ocean area) for +!! later use in reporting diagnostics +subroutine compute_global_grid_integrals(G, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming ! Masked and unscaled cell areas [m2] + real :: area_scale ! A scaling factor for area into MKS units [m2 L-2 ~> 1] + integer :: i,j + + area_scale = US%L_to_m**2 + + tmpForSumming(:,:) = 0. + G%areaT_global = 0.0 ; G%IareaT_global = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + tmpForSumming(i,j) = area_scale*G%areaT(i,j) * G%mask2dT(i,j) + enddo ; enddo + G%areaT_global = reproducing_sum(tmpForSumming) + + if (G%areaT_global == 0.0) & + call MOM_error(FATAL, "compute_global_grid_integrals: "//& + "zero ocean area (check topography?)") + + G%IareaT_global = 1.0 / (G%areaT_global) +end subroutine compute_global_grid_integrals +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> Write out a file describing the topography, Coriolis parameter, grid locations +!! and various other fixed fields from the grid. +subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid + type(param_file_type), intent(in) :: param_file !< Parameter file structure + character(len=*), intent(in) :: directory !< The directory into which to place the geometry file. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + character(len=*), optional, intent(in) :: geom_file !< If present, the name of the geometry file + !! (otherwise the file is "ocean_geometry") + + ! Local variables. + character(len=240) :: filepath ! The full path to the file to write + character(len=40) :: mdl = "write_ocean_geometry_file" + type(vardesc), dimension(:), allocatable :: & + vars ! Types with metadata about the variables and their staggering + type(MOM_field), dimension(:), allocatable :: & + fields ! Opaque types used by MOM_io to store variable metadata information + type(MOM_infra_file) :: IO_handle ! The I/O handle of the fileset + integer :: nFlds ! The number of variables in this file + integer :: file_threading + logical :: multiple_files + + call callTree_enter('write_ocean_geometry_file()') + + nFlds = 19 ; if (G%bathymetry_at_vel) nFlds = 23 + + allocate(vars(nFlds)) + allocate(fields(nFlds)) + + ! var_desc populates a type defined in MOM_io.F90. The arguments, in order, are: + ! (1) the variable name for the NetCDF file + ! (2) the units of the variable when output + ! (3) the variable's long name + ! (4) a character indicating the horizontal grid, which may be '1' (column), + ! 'h', 'q', 'u', or 'v', for the corresponding C-grid variable + ! (5) a character indicating the vertical grid, which may be 'L' (layer), + ! 'i' (interface), or '1' (no vertical location) + ! (6) a character indicating the time levels of the field, which may be + ! 's' (snap-shot), 'p' (periodic), or '1' (no time variation) + vars(1) = var_desc("geolatb","degree","latitude at corner (Bu) points",'q','1','1') + vars(2) = var_desc("geolonb","degree","longitude at corner (Bu) points",'q','1','1') + vars(3) = var_desc("geolat","degree", "latitude at tracer (T) points", 'h','1','1') + vars(4) = var_desc("geolon","degree","longitude at tracer (T) points",'h','1','1') + vars(5) = var_desc("D","meter","Basin Depth",'h','1','1') + vars(6) = var_desc("f","s-1","Coriolis Parameter",'q','1','1') + vars(7) = var_desc("dxCv","m","Zonal grid spacing at v points",'v','1','1') + vars(8) = var_desc("dyCu","m","Meridional grid spacing at u points",'u','1','1') + vars(9) = var_desc("dxCu","m","Zonal grid spacing at u points",'u','1','1') + vars(10)= var_desc("dyCv","m","Meridional grid spacing at v points",'v','1','1') + vars(11)= var_desc("dxT","m","Zonal grid spacing at h points",'h','1','1') + vars(12)= var_desc("dyT","m","Meridional grid spacing at h points",'h','1','1') + vars(13)= var_desc("dxBu","m","Zonal grid spacing at q points",'q','1','1') + vars(14)= var_desc("dyBu","m","Meridional grid spacing at q points",'q','1','1') + vars(15)= var_desc("Ah","m2","Area of h cells",'h','1','1') + vars(16)= var_desc("Aq","m2","Area of q cells",'q','1','1') + + vars(17)= var_desc("dxCvo","m","Open zonal grid spacing at v points",'v','1','1') + vars(18)= var_desc("dyCuo","m","Open meridional grid spacing at u points",'u','1','1') + vars(19)= var_desc("wet", "nondim", "land or ocean?", 'h','1','1') + + if (G%bathymetry_at_vel) then + vars(20) = var_desc("Dblock_u","m","Blocked depth at u points",'u','1','1') + vars(21) = var_desc("Dopen_u","m","Open depth at u points",'u','1','1') + vars(22) = var_desc("Dblock_v","m","Blocked depth at v points",'v','1','1') + vars(23) = var_desc("Dopen_v","m","Open depth at v points",'v','1','1') + endif + + if (present(geom_file)) then + filepath = trim(directory) // trim(geom_file) + else + filepath = trim(directory) // "ocean_geometry" + endif + + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", multiple_files, & + "If true, the IO layout is used to group processors that write to the same "//& + "restart file or each processor writes its own (numbered) restart file. "//& + "If false, a single restart file is generated combining output from all PEs.", & + default=.false.) + file_threading = SINGLE_FILE + if (multiple_files) file_threading = MULTIPLE + + call create_MOM_file(IO_handle, trim(filepath), vars, nFlds, fields, & + file_threading, dG=G) + + call MOM_write_field(IO_handle, fields(1), G%Domain, G%geoLatBu) + call MOM_write_field(IO_handle, fields(2), G%Domain, G%geoLonBu) + call MOM_write_field(IO_handle, fields(3), G%Domain, G%geoLatT) + call MOM_write_field(IO_handle, fields(4), G%Domain, G%geoLonT) + + call MOM_write_field(IO_handle, fields(5), G%Domain, G%bathyT, scale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(6), G%Domain, G%CoriolisBu, scale=US%s_to_T) + + call MOM_write_field(IO_handle, fields(7), G%Domain, G%dxCv, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(8), G%Domain, G%dyCu, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(9), G%Domain, G%dxCu, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(10), G%Domain, G%dyCv, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(11), G%Domain, G%dxT, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(12), G%Domain, G%dyT, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(13), G%Domain, G%dxBu, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(14), G%Domain, G%dyBu, scale=US%L_to_m) + + call MOM_write_field(IO_handle, fields(15), G%Domain, G%areaT, scale=US%L_to_m**2) + call MOM_write_field(IO_handle, fields(16), G%Domain, G%areaBu, scale=US%L_to_m**2) + + call MOM_write_field(IO_handle, fields(17), G%Domain, G%dx_Cv, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(18), G%Domain, G%dy_Cu, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(19), G%Domain, G%mask2dT) + + if (G%bathymetry_at_vel) then + call MOM_write_field(IO_handle, fields(20), G%Domain, G%Dblock_u, scale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(21), G%Domain, G%Dopen_u, scale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(22), G%Domain, G%Dblock_v, scale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(23), G%Domain, G%Dopen_v, scale=US%Z_to_m) + endif + + call IO_handle%close() + + deallocate(vars, fields) + + call callTree_leave('write_ocean_geometry_file()') +end subroutine write_ocean_geometry_file + +end module MOM_shared_initialization diff --git a/initialization/MOM_state_initialization.F90 b/initialization/MOM_state_initialization.F90 new file mode 100644 index 0000000000..0bd155e8e4 --- /dev/null +++ b/initialization/MOM_state_initialization.F90 @@ -0,0 +1,3118 @@ +!> Initialization functions for state variables, u, v, h, T and S. +module MOM_state_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : hchksum, qchksum, uvchksum +use MOM_density_integrals, only : int_specific_vol_dp +use MOM_density_integrals, only : find_depth_of_pressure_in_cell +use MOM_coms, only : max_across_PEs, min_across_PEs, reproducing_sum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP +use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast +use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, read_param, log_param, param_file_type +use MOM_file_parser, only : log_version +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type, isPointInCell +use MOM_interface_heights, only : find_eta, dz_to_thickness, dz_to_thickness_simple +use MOM_interface_heights, only : calc_derived_thermo +use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher +use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data +use MOM_open_boundary, only : OBC_NONE +use MOM_open_boundary, only : open_boundary_query +use MOM_open_boundary, only : set_tracer_data, initialize_segment_data +use MOM_open_boundary, only : open_boundary_test_extern_h +use MOM_open_boundary, only : fill_temp_salt_segments +use MOM_open_boundary, only : update_OBC_segment_data +!use MOM_open_boundary, only : set_3D_OBC_data +use MOM_grid_initialize, only : initialize_masks, set_grid_metrics +use MOM_restart, only : restore_state, is_new_run, MOM_restart_CS +use MOM_restart, only : restart_registry_lock +use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density +use MOM_sponge, only : initialize_sponge, sponge_CS +use MOM_ALE_sponge, only : set_up_ALE_sponge_field, set_up_ALE_sponge_vel_field +use MOM_ALE_sponge, only : ALE_sponge_CS, initialize_ALE_sponge +use MOM_string_functions, only : uppercase, lowercase +use MOM_time_manager, only : time_type, operator(/=) +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : setVerticalGridAxes, verticalGrid_type +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type, EOS_domain +use MOM_EOS, only : convert_temp_salt_for_TEOS10 +use user_initialization, only : user_initialize_thickness, user_initialize_velocity +use user_initialization, only : user_init_temperature_salinity, user_set_OBC_data +use user_initialization, only : user_initialize_sponges +use DOME_initialization, only : DOME_initialize_thickness +use DOME_initialization, only : DOME_set_OBC_data +use DOME_initialization, only : DOME_initialize_sponges +use ISOMIP_initialization, only : ISOMIP_initialize_thickness +use ISOMIP_initialization, only : ISOMIP_initialize_sponges +use ISOMIP_initialization, only : ISOMIP_initialize_temperature_salinity +use RGC_initialization, only : RGC_initialize_sponges +use baroclinic_zone_initialization, only : baroclinic_zone_init_temperature_salinity +use benchmark_initialization, only : benchmark_initialize_thickness +use benchmark_initialization, only : benchmark_init_temperature_salinity +use Neverworld_initialization, only : Neverworld_initialize_thickness +use circle_obcs_initialization, only : circle_obcs_initialize_thickness +use lock_exchange_initialization, only : lock_exchange_initialize_thickness +use external_gwave_initialization, only : external_gwave_initialize_thickness +use DOME2d_initialization, only : DOME2d_initialize_thickness +use DOME2d_initialization, only : DOME2d_initialize_temperature_salinity +use DOME2d_initialization, only : DOME2d_initialize_sponges +use adjustment_initialization, only : adjustment_initialize_thickness +use adjustment_initialization, only : adjustment_initialize_temperature_salinity +use sloshing_initialization, only : sloshing_initialize_thickness +use sloshing_initialization, only : sloshing_initialize_temperature_salinity +use seamount_initialization, only : seamount_initialize_thickness +use seamount_initialization, only : seamount_initialize_temperature_salinity +use dumbbell_initialization, only : dumbbell_initialize_thickness +use dumbbell_initialization, only : dumbbell_initialize_temperature_salinity +use Phillips_initialization, only : Phillips_initialize_thickness +use Phillips_initialization, only : Phillips_initialize_velocity +use Phillips_initialization, only : Phillips_initialize_sponges +use Rossby_front_2d_initialization, only : Rossby_front_initialize_thickness +use Rossby_front_2d_initialization, only : Rossby_front_initialize_temperature_salinity +use Rossby_front_2d_initialization, only : Rossby_front_initialize_velocity +use SCM_CVMix_tests, only: SCM_CVMix_tests_TS_init +use dyed_channel_initialization, only : dyed_channel_set_OBC_tracer_data +use dyed_obcs_initialization, only : dyed_obcs_set_OBC_data +use supercritical_initialization, only : supercritical_set_OBC_data +use soliton_initialization, only : soliton_initialize_velocity +use soliton_initialization, only : soliton_initialize_thickness +use BFB_initialization, only : BFB_initialize_sponges_southonly +use dense_water_initialization, only : dense_water_initialize_TS +use dense_water_initialization, only : dense_water_initialize_sponges +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_regrid_accelerated, TS_PLM_edge_values +use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution +use MOM_regridding, only : regridding_main, regridding_preadjust_reqs, convective_adjustment +use MOM_regridding, only : set_dz_neglect +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer, homogenize_field +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 +use MOM_oda_incupd, only: calc_oda_increments, output_oda_incupd_inc + +implicit none ; private + +#include + +public MOM_initialize_state + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +character(len=40) :: mdl = "MOM_state_initialization" !< This module's name. + +contains + +!> Initialize temporally evolving fields, either as initial +!! conditions or by reading them from a restart (or saves) file. +subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & + restart_CS, ALE_CSp, tracer_Reg, sponge_CSp, & + ALE_sponge_CSp, oda_incupd_CSp, OBC, Time_in, frac_shelf_h, mass_shelf) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: u !< The zonal velocity that is being + !! initialized [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: v !< The meridional velocity that is being + !! initialized [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic + !! variables + type(time_type), intent(inout) :: Time !< Time at the start of the run segment. + type(param_file_type), intent(in) :: PF !< A structure indicating the open file to parse + !! for model parameter values. + type(directories), intent(in) :: dirs !< A structure containing several relevant + !! directory paths. + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + type(ALE_CS), pointer :: ALE_CSp !< The ALE control structure for remapping + type(tracer_registry_type), pointer :: tracer_Reg !< A pointer to the tracer registry + type(sponge_CS), pointer :: sponge_CSp !< The layerwise sponge control structure. + type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< The ALE sponge control structure. + type(ocean_OBC_type), pointer :: OBC !< The open boundary condition control structure. + type(oda_incupd_CS), pointer :: oda_incupd_CSp !< The oda_incupd control structure. + type(time_type), optional, intent(in) :: Time_in !< Time at the start of the run segment. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: frac_shelf_h !< The fraction of the grid cell covered + !! by a floating ice shelf [nondim]. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: mass_shelf !< The mass per unit area of the overlying + !! ice shelf [ R Z ~> kg m-2 ] + ! Local variables + real :: depth_tot(SZI_(G),SZJ_(G)) ! The nominal total depth of the ocean [Z ~> m] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! The layer thicknesses in geopotential (z) units [Z ~> m] + character(len=200) :: inputdir ! The directory where NetCDF input files are. + character(len=200) :: config, h_config + real :: H_rescale ! A rescaling factor for thicknesses from the representation in + ! a restart file to the internal representation in this run [various units ~> 1] + real :: dt ! The baroclinic dynamics timestep for this run [T ~> s]. + + logical :: from_Z_file, useALE + logical :: new_sim + logical :: use_temperature, use_sponge, use_OBC, use_oda_incupd + logical :: verify_restart_time + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: depress_sfc ! If true, remove the mass that would be displaced + ! by a large surface pressure by squeezing the column. + logical :: trim_ic_for_p_surf ! If true, remove the mass that would be displaced + ! by a large surface pressure, such as with an ice sheet. + logical :: regrid_accelerate + integer :: regrid_iterations + logical :: convert + logical :: just_read ! If true, only read the parameters because this + ! is a run from a restart file; this option + ! allows the use of Fatal unused parameters. + type(EOS_type), pointer :: eos => NULL() + logical :: debug ! If true, write debugging output. + logical :: debug_obc ! If true, do debugging calls related to OBCs. + logical :: debug_layers = .false. + logical :: use_ice_shelf + character(len=80) :: mesg + ! This include declares and sets the variable "version". +# include "version_variable.h" + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + 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 + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + call callTree_enter("MOM_initialize_state(), MOM_state_initialization.F90") + call log_version(PF, mdl, version, "") + call get_param(PF, mdl, "DEBUG", debug, default=.false.) + call get_param(PF, mdl, "DEBUG_OBC", debug_obc, default=.false.) + + new_sim = is_new_run(restart_CS) + just_read = .not.new_sim + + call get_param(PF, mdl, "INPUTDIR", inputdir, & + "The directory in which input files are found.", default=".") + inputdir = slasher(inputdir) + + use_temperature = associated(tv%T) + useALE = associated(ALE_CSp) + 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) + + !==================================================================== + ! Initialize temporally evolving fields, either as initial + ! conditions or by reading them from a restart (or saves) file. + !==================================================================== + + if (new_sim) then + call MOM_mesg("Run initialized internally.", 3) + + if (present(Time_in)) Time = Time_in + ! Otherwise leave Time at its input value. + + ! This initialization should not be needed. Certainly restricting it + ! to the computational domain helps detect possible uninitialized + ! data in halos which should be covered by the pass_var(h) later. + !do k=1,nz ; do j=js,je ; do i=is,ie + ! h(i,j,k) = 0. + !enddo + + ! Initialize the layer thicknesses. + dz(:,:,:) = 0.0 + endif + + ! Set the nominal depth of the ocean, which might be different from the bathymetric + ! geopotential height, for use by the various initialization routines. G%bathyT has + ! already been initialized in previous calls. + do j=jsd,jed ; do i=isd,ied + depth_tot(i,j) = G%bathyT(i,j) + G%Z_ref + enddo ; enddo + + call get_param(PF, mdl, "FATAL_INCONSISTENT_RESTART_TIME", verify_restart_time, & + "If true and a time_in value is provided to MOM_initialize_state, verify that "//& + "the time read from a restart file is the same as time_in, and issue a fatal "//& + "error if it is not. Otherwise, simply set the time to time_in if present.", & + default=.false.) + + ! The remaining initialization calls are done, regardless of whether the + ! fields are actually initialized here (if just_read=.false.) or whether it + ! is just to make sure that all valid parameters are read to enable the + ! detection of unused parameters. + call get_param(PF, mdl, "INIT_LAYERS_FROM_Z_FILE", from_Z_file, & + "If true, initialize the layer thicknesses, temperatures, and "//& + "salinities from a Z-space file on a latitude-longitude grid.", & + default=.false., do_not_log=just_read) + + convert = new_sim ! Thicknesses are initialized in height units in most cases. + if (from_Z_file) then + ! Initialize thickness and T/S from z-coordinate data in a file. + if (.NOT.use_temperature) call MOM_error(FATAL,"MOM_initialize_state : "//& + "use_temperature must be true if INIT_LAYERS_FROM_Z_FILE is true") + + call MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, & + just_read=just_read, frac_shelf_h=frac_shelf_h) + convert = .false. + else + ! Initialize thickness, h. + call get_param(PF, mdl, "THICKNESS_CONFIG", h_config, & + "A string that determines how the initial layer "//& + "thicknesses are specified for a new run: \n"//& + " \t file - read interface heights from the file specified \n"//& + " \t\t by (THICKNESS_FILE).\n"//& + " \t thickness_file - read thicknesses from the file specified \n"//& + " \t\t by (THICKNESS_FILE).\n"//& + " \t mass_file - read thicknesses in units of mass per unit area from the file \n"//& + " \t\t specified by (THICKNESS_FILE).\n"//& + " \t coord - determined by ALE coordinate.\n"//& + " \t uniform - uniform thickness layers evenly distributed \n"//& + " \t\t between the surface and MAXIMUM_DEPTH. \n"//& + " \t list - read a list of positive interface depths. \n"//& + " \t DOME - use a slope and channel configuration for the \n"//& + " \t\t DOME sill-overflow test case. \n"//& + " \t ISOMIP - use a configuration for the \n"//& + " \t\t ISOMIP test case. \n"//& + " \t benchmark - use the benchmark test case thicknesses. \n"//& + " \t Neverworld - use the Neverworld test case thicknesses. \n"//& + " \t search - search a density profile for the interface \n"//& + " \t\t densities. This is not yet implemented. \n"//& + " \t circle_obcs - the circle_obcs test case is used. \n"//& + " \t DOME2D - 2D version of DOME initialization. \n"//& + " \t adjustment2d - 2D lock exchange thickness ICs. \n"//& + " \t sloshing - sloshing gravity thickness ICs. \n"//& + " \t seamount - no motion test with seamount ICs. \n"//& + " \t dumbbell - sloshing channel ICs. \n"//& + " \t soliton - Equatorial Rossby soliton. \n"//& + " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& + " \t USER - call a user modified routine.", & + default="uniform", do_not_log=just_read) + select case (trim(h_config)) + case ("file") + call initialize_thickness_from_file(dz, depth_tot, G, GV, US, PF, file_has_thickness=.false., & + mass_file=.false., just_read=just_read) + case ("thickness_file") + call initialize_thickness_from_file(dz, depth_tot, G, GV, US, PF, file_has_thickness=.true., & + mass_file=.false., just_read=just_read) + case ("mass_file") + call initialize_thickness_from_file(h, depth_tot, G, GV, US, PF, file_has_thickness=.true., & + mass_file=.true., just_read=just_read) + convert = .false. + case ("coord") + if (new_sim .and. useALE) then + call ALE_initThicknessToCoord( ALE_CSp, G, GV, dz, height_units=.true. ) + elseif (new_sim) then + call MOM_error(FATAL, "MOM_initialize_state: USE_REGRIDDING must be True "//& + "for THICKNESS_CONFIG of 'coord'") + endif + case ("uniform"); call initialize_thickness_uniform(dz, depth_tot, G, GV, PF, & + just_read=just_read) + case ("list"); call initialize_thickness_list(dz, depth_tot, G, GV, US, PF, & + just_read=just_read) + case ("DOME"); call DOME_initialize_thickness(dz, depth_tot, G, GV, PF, & + just_read=just_read) + case ("ISOMIP"); call ISOMIP_initialize_thickness(dz, depth_tot, G, GV, US, PF, tv, & + just_read=just_read) + case ("benchmark"); call benchmark_initialize_thickness(dz, depth_tot, G, GV, US, PF, & + tv%eqn_of_state, tv%P_Ref, just_read=just_read) + case ("Neverworld","Neverland"); call Neverworld_initialize_thickness(dz, depth_tot, & + G, GV, US, PF, tv%P_Ref) + case ("search"); call initialize_thickness_search() + case ("circle_obcs"); call circle_obcs_initialize_thickness(dz, depth_tot, G, GV, US, PF, & + just_read=just_read) + case ("lock_exchange"); call lock_exchange_initialize_thickness(dz, G, GV, US, & + PF, just_read=just_read) + case ("external_gwave"); call external_gwave_initialize_thickness(dz, G, GV, US, & + PF, just_read=just_read) + case ("DOME2D"); call DOME2d_initialize_thickness(dz, depth_tot, G, GV, US, PF, & + just_read=just_read) + case ("adjustment2d"); call adjustment_initialize_thickness(dz, G, GV, US, & + PF, just_read=just_read) + case ("sloshing"); call sloshing_initialize_thickness(dz, depth_tot, G, GV, US, PF, & + just_read=just_read) + case ("seamount"); call seamount_initialize_thickness(dz, depth_tot, G, GV, US, PF, & + just_read=just_read) + case ("dumbbell"); call dumbbell_initialize_thickness(dz, depth_tot, G, GV, US, PF, & + just_read=just_read) + case ("soliton"); call soliton_initialize_thickness(dz, depth_tot, G, GV, US) + case ("phillips"); call Phillips_initialize_thickness(dz, depth_tot, G, GV, US, PF, & + just_read=just_read) + case ("rossby_front") + call Rossby_front_initialize_thickness(h, G, GV, US, PF, just_read=just_read) + convert = .false. ! Rossby_front initialization works directly in thickness units. + case ("USER"); call user_initialize_thickness(dz, G, GV, PF, & + just_read=just_read) + case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& + "Unrecognized layer thickness configuration "//trim(h_config)) + end select + + ! Initialize temperature and salinity (T and S). + if ( use_temperature ) then + call get_param(PF, mdl, "TS_CONFIG", config, & + "A string that determines how the initial temperatures "//& + "and salinities are specified for a new run: \n"//& + " \t file - read velocities from the file specified \n"//& + " \t\t by (TS_FILE). \n"//& + " \t fit - find the temperatures that are consistent with \n"//& + " \t\t the layer densities and salinity S_REF. \n"//& + " \t TS_profile - use temperature and salinity profiles \n"//& + " \t\t (read from TS_FILE) to set layer densities. \n"//& + " \t benchmark - use the benchmark test case T & S. \n"//& + " \t linear - linear in logical layer space. \n"//& + " \t DOME2D - 2D DOME initialization. \n"//& + " \t ISOMIP - ISOMIP initialization. \n"//& + " \t adjustment2d - 2d lock exchange T/S ICs. \n"//& + " \t sloshing - sloshing mode T/S ICs. \n"//& + " \t seamount - no motion test with seamount ICs. \n"//& + " \t dumbbell - sloshing channel ICs. \n"//& + " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& + " \t SCM_CVMix_tests - used in the SCM CVMix tests.\n"//& + " \t USER - call a user modified routine.", & + fail_if_missing=new_sim, do_not_log=just_read) +! " \t baroclinic_zone - an analytic baroclinic zone. \n"//& + + ! Check for incompatible THICKNESS_CONFIG and TS_CONFIG settings + if (new_sim .and. (.not.convert)) then ; select case (trim(config)) + case ("DOME2D", "ISOMIP", "adjustment2d", "baroclinic_zone", "sloshing", & + "seamount", "dumbbell", "SCM_CVMix_tests", "dense") + call MOM_error(FATAL, "TS_CONFIG = "//trim(config)//" does not work with thicknesses "//& + "that have already been converted to thickness units, as is the case with "//& + "THICKNESS_CONFIG = "//trim(h_config)//".") + end select ; endif + + select case (trim(config)) + case ("fit"); call initialize_temp_salt_fit(tv%T, tv%S, G, GV, US, PF, & + eos, tv%P_Ref, just_read=just_read) + case ("file"); call initialize_temp_salt_from_file(tv%T, tv%S, G, GV, US, & + PF, just_read=just_read) + case ("benchmark"); call benchmark_init_temperature_salinity(tv%T, tv%S, & + G, GV, US, PF, eos, tv%P_Ref, just_read=just_read) + case ("TS_profile") ; call initialize_temp_salt_from_profile(tv%T, tv%S, & + G, GV, US, PF, just_read=just_read) + case ("linear"); call initialize_temp_salt_linear(tv%T, tv%S, G, GV, US, PF, & + just_read=just_read) + case ("DOME2D"); call DOME2d_initialize_temperature_salinity (tv%T, tv%S, dz, & + G, GV, US, PF, just_read=just_read) + case ("ISOMIP"); call ISOMIP_initialize_temperature_salinity (tv%T, tv%S, dz, & + depth_tot, G, GV, US, PF, eos, just_read=just_read) + case ("adjustment2d"); call adjustment_initialize_temperature_salinity ( tv%T, & + tv%S, dz, depth_tot, G, GV, US, PF, just_read=just_read) + case ("baroclinic_zone"); call baroclinic_zone_init_temperature_salinity( tv%T, & + tv%S, dz, depth_tot, G, GV, US, PF, just_read=just_read) + case ("sloshing"); call sloshing_initialize_temperature_salinity(tv%T, & + tv%S, dz, G, GV, US, PF, just_read=just_read) + case ("seamount"); call seamount_initialize_temperature_salinity(tv%T, & + tv%S, dz, G, GV, US, PF, just_read=just_read) + case ("dumbbell"); call dumbbell_initialize_temperature_salinity(tv%T, & + tv%S, dz, G, GV, US, PF, just_read=just_read) + case ("rossby_front") + if (convert .and. .not.just_read) call dz_to_thickness(dz, tv, h, G, GV, US) + call Rossby_front_initialize_temperature_salinity ( tv%T, tv%S, h, & + G, GV, US, PF, just_read=just_read) + case ("SCM_CVMix_tests"); call SCM_CVMix_tests_TS_init(tv%T, tv%S, dz, & + G, GV, US, PF, just_read=just_read) + case ("dense"); call dense_water_initialize_TS(G, GV, US, PF, tv%T, tv%S, & + dz, just_read=just_read) + case ("USER"); call user_init_temperature_salinity(tv%T, tv%S, G, GV, PF, & + just_read=just_read) + case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& + "Unrecognized Temp & salt configuration "//trim(config)) + end select + endif + endif ! not from_Z_file. + if (use_temperature .and. use_OBC) & + call fill_temp_salt_segments(G, GV, US, OBC, tv) + + ! Convert thicknesses from geometric distances in depth units to thickness units or mass-per-unit-area. + if (new_sim .and. convert) call dz_to_thickness(dz, tv, h, G, GV, US) + + ! Handle the initial surface displacement under ice shelf + call get_param(PF, mdl, "DEPRESS_INITIAL_SURFACE", depress_sfc, & + "If true, depress the initial surface to avoid huge "//& + "tsunamis when a large surface pressure is applied.", & + default=.false., do_not_log=just_read) + call get_param(PF, mdl, "TRIM_IC_FOR_P_SURF", trim_ic_for_p_surf, & + "If true, cuts way the top of the column for initial conditions "//& + "at the depth where the hydrostatic pressure matches the imposed "//& + "surface pressure which is read from file.", default=.false., & + do_not_log=just_read) + if (depress_sfc .and. trim_ic_for_p_surf) call MOM_error(FATAL, "MOM_initialize_state: "//& + "DEPRESS_INITIAL_SURFACE and TRIM_IC_FOR_P_SURF are exclusive and cannot both be True") + + if (new_sim .and. debug .and. (depress_sfc .or. trim_ic_for_p_surf)) & + call hchksum(h, "Pre-depress: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) + + ! Remove the mass that would be displaced by an ice shelf or inverse barometer. + if (depress_sfc) then + call depress_surface(h, G, GV, US, PF, tv, just_read=just_read) + elseif (trim_ic_for_p_surf) then + call trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read=just_read) + elseif (new_sim .and. use_ice_shelf .and. present(mass_shelf)) then + call calc_sfc_displacement(PF, G, GV, US, mass_shelf, tv, h) + endif + + ! Perhaps we want to run the regridding coordinate generator for multiple + ! iterations here so the initial grid is consistent with the coordinate + if (useALE) then + call get_param(PF, mdl, "REGRID_ACCELERATE_INIT", regrid_accelerate, & + "If true, runs REGRID_ACCELERATE_ITERATIONS iterations of the regridding "//& + "algorithm to push the initial grid to be consistent with the initial "//& + "condition. Useful only for state-based and iterative coordinates.", & + default=.false., do_not_log=just_read) + if (regrid_accelerate) then + call get_param(PF, mdl, "REGRID_ACCELERATE_ITERATIONS", regrid_iterations, & + "The number of regridding iterations to perform to generate "//& + "an initial grid that is consistent with the initial conditions.", & + default=1, do_not_log=just_read) + + call get_param(PF, mdl, "DT", dt, "Timestep", & + units="s", scale=US%s_to_T, fail_if_missing=.true.) + + if (new_sim .and. debug) & + call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) + call ALE_regrid_accelerated(ALE_CSp, G, GV, US, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & + dt=dt, initial=.true.) + endif + endif + + ! The thicknesses in halo points might be needed to initialize the velocities. + if (new_sim) call pass_var(h, G%Domain) + + ! Initialize velocity components, u and v + call get_param(PF, mdl, "VELOCITY_CONFIG", config, & + "A string that determines how the initial velocities "//& + "are specified for a new run: \n"//& + " \t file - read velocities from the file specified \n"//& + " \t\t by (VELOCITY_FILE). \n"//& + " \t zero - the fluid is initially at rest. \n"//& + " \t uniform - the flow is uniform (determined by\n"//& + " \t\t parameters INITIAL_U_CONST and INITIAL_V_CONST).\n"//& + " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& + " \t soliton - Equatorial Rossby soliton.\n"//& + " \t USER - call a user modified routine.", default="zero", & + do_not_log=just_read) + select case (trim(config)) + case ("file"); call initialize_velocity_from_file(u, v, G, GV, US, PF, just_read) + case ("zero"); call initialize_velocity_zero(u, v, G, GV, PF, just_read) + case ("uniform"); call initialize_velocity_uniform(u, v, G, GV, US, PF, just_read) + case ("circular"); call initialize_velocity_circular(u, v, G, GV, US, PF, just_read) + case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, US, PF, just_read) + case ("rossby_front"); call Rossby_front_initialize_velocity(u, v, h, & + G, GV, US, PF, just_read) + case ("soliton"); call soliton_initialize_velocity(u, v, G, GV, US) + case ("USER"); call user_initialize_velocity(u, v, G, GV, US, PF, just_read) + case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& + "Unrecognized velocity configuration "//trim(config)) + end select + + if (new_sim) call pass_vector(u, v, G%Domain) + if (debug .and. new_sim) then + call uvchksum("MOM_initialize_state [uv]", u, v, G%HI, haloshift=1, scale=US%L_T_to_m_s) + endif + + ! This is the end of the block of code that might have initialized fields + ! internally at the start of a new run. + + ! Initialized assimilative incremental update (oda_incupd) structure and + ! register restart. + call get_param(PF, mdl, "ODA_INCUPD", use_oda_incupd, & + "If true, oda incremental updates will be applied "//& + "everywhere in the domain.", default=.false.) + if (use_oda_incupd) then + call restart_registry_lock(restart_CS, unlocked=.true.) + call initialize_oda_incupd_fixed(G, GV, US, oda_incupd_CSp, restart_CS) + call restart_registry_lock(restart_CS) + endif + + if (.not.new_sim) then ! This block restores the state from a restart file. + ! This line calls a subroutine that reads the initial conditions + ! from a previously generated file. + call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, G, restart_CS) + if (present(Time_in)) then + if (verify_restart_time .and. (Time /= Time_in)) call MOM_error(FATAL, & + "MOM6 attempted to restart from a file from a different time than given by Time_in.") + Time = Time_in + endif + endif + + if ( use_temperature ) then + call pass_var(tv%T, G%Domain, complete=.false.) + call pass_var(tv%S, G%Domain, complete=.false.) + endif + call pass_var(h, G%Domain) + + if (debug) then + call hchksum(h, "MOM_initialize_state: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) + if ( use_temperature ) call hchksum(tv%T, "MOM_initialize_state: T ", G%HI, haloshift=1, scale=US%C_to_degC) + if ( use_temperature ) call hchksum(tv%S, "MOM_initialize_state: S ", G%HI, haloshift=1, scale=US%S_to_ppt) + if ( use_temperature .and. debug_layers) then ; do k=1,nz + write(mesg,'("MOM_IS: T[",I2,"]")') k + call hchksum(tv%T(:,:,k), mesg, G%HI, haloshift=1, scale=US%C_to_degC) + write(mesg,'("MOM_IS: S[",I2,"]")') k + call hchksum(tv%S(:,:,k), mesg, G%HI, haloshift=1, scale=US%S_to_ppt) + enddo ; endif + endif + + call get_param(PF, mdl, "SPONGE", use_sponge, & + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified via SPONGE_CONFIG.", default=.false.) + if ( use_sponge ) then + call get_param(PF, mdl, "SPONGE_CONFIG", config, & + "A string that sets how the sponges are configured: \n"//& + " \t file - read sponge properties from the file \n"//& + " \t\t specified by (SPONGE_FILE).\n"//& + " \t ISOMIP - apply ale sponge in the ISOMIP case \n"//& + " \t RGC - apply sponge in the rotating_gravity_current case \n"//& + " \t DOME - use a slope and channel configuration for the \n"//& + " \t\t DOME sill-overflow test case. \n"//& + " \t BFB - Sponge at the southern boundary of the domain\n"//& + " \t\t for buoyancy-forced basin case.\n"//& + " \t USER - call a user modified routine.", default="file") + select case (trim(config)) + case ("DOME"); call DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, sponge_CSp) + case ("DOME2D"); call DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, PF, useALE, & + sponge_CSp, ALE_sponge_CSp) + case ("ISOMIP"); call ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, useALE, & + sponge_CSp, ALE_sponge_CSp) + case("RGC"); call RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, useALE, & + sponge_CSp, ALE_sponge_CSp) + case ("USER"); call user_initialize_sponges(G, GV, use_temperature, tv, PF, sponge_CSp, h) + case ("BFB"); call BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, depth_tot, PF, & + sponge_CSp, h) + case ("DUMBBELL"); call dumbbell_initialize_sponges(G, GV, US, tv, h, depth_tot, PF, useALE, & + sponge_CSp, ALE_sponge_CSp) + case ("phillips"); call Phillips_initialize_sponges(G, GV, US, tv, PF, sponge_CSp, h) + case ("dense"); call dense_water_initialize_sponges(G, GV, US, tv, depth_tot, PF, useALE, & + sponge_CSp, ALE_sponge_CSp) + case ("file"); call initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_tot, PF, & + sponge_CSp, ALE_sponge_CSp, Time) + case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& + "Unrecognized sponge configuration "//trim(config)) + end select + endif + + ! Reads OBC parameters not pertaining to the location of the boundaries + call open_boundary_init(G, GV, US, PF, OBC, restart_CS) + + ! This controls user code for setting open boundary data + if (associated(OBC)) then + call initialize_segment_data(G, GV, US, OBC, PF) +! call open_boundary_config(G, US, PF, OBC) + ! Call this once to fill boundary arrays from fixed values + if (OBC%some_need_no_IO_for_data) then + call calc_derived_thermo(tv, h, G, GV, US) + call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + endif + + call get_param(PF, mdl, "OBC_USER_CONFIG", config, & + "A string that sets how the user code is invoked to set open boundary data: \n"//& + " DOME - specified inflow on northern boundary\n"//& + " dyed_channel - supercritical with dye on the inflow boundary\n"//& + " dyed_obcs - circle_obcs with dyes on the open boundaries\n"//& + " Kelvin - barotropic Kelvin wave forcing on the western boundary\n"//& + " shelfwave - Flather with shelf wave forcing on western boundary\n"//& + " supercritical - now only needed here for the allocations\n"//& + " tidal_bay - Flather with tidal forcing on eastern boundary\n"//& + " USER - user specified", default="none") + if (trim(config) == "DOME") then + call DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tracer_Reg) + elseif (trim(config) == "dyed_channel") then + call dyed_channel_set_OBC_tracer_data(OBC, G, GV, PF, tracer_Reg) + OBC%update_OBC = .true. + elseif (trim(config) == "dyed_obcs") then + call dyed_obcs_set_OBC_data(OBC, G, GV, PF, tracer_Reg) + elseif (trim(config) == "Kelvin") then + OBC%update_OBC = .true. + elseif (trim(config) == "shelfwave") then + OBC%update_OBC = .true. + elseif (lowercase(trim(config)) == "supercritical") then + call supercritical_set_OBC_data(OBC, G, GV, US, PF) + elseif (trim(config) == "tidal_bay") then + OBC%update_OBC = .true. + elseif (trim(config) == "USER") then + call user_set_OBC_data(OBC, tv, G, GV, PF, tracer_Reg) + elseif (.not. trim(config) == "none") then + call MOM_error(FATAL, "The open boundary conditions specified by "//& + "OBC_USER_CONFIG = "//trim(config)//" have not been fully implemented.") + endif + if (open_boundary_query(OBC, apply_open_OBC=.true.)) then + call set_tracer_data(OBC, tv, h, G, GV, PF) + endif + endif +! if (open_boundary_query(OBC, apply_nudged_OBC=.true.)) then +! call set_3D_OBC_data(OBC, tv, h, G, PF, tracer_Reg) +! endif + ! Still need a way to specify the boundary values + if (debug.and.associated(OBC)) then + call hchksum(G%mask2dT, 'MOM_initialize_state: mask2dT ', G%HI) + call uvchksum('MOM_initialize_state: mask2dC[uv]', G%mask2dCu, & + G%mask2dCv, G%HI) + call qchksum(G%mask2dBu, 'MOM_initialize_state: mask2dBu ', G%HI) + endif + + if (debug_OBC) call open_boundary_test_extern_h(G, GV, OBC, h) + call callTree_leave('MOM_initialize_state()') + + ! Set-up of data Assimilation with incremental update + if (use_oda_incupd) then + call initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, & + PF, oda_incupd_CSp, restart_CS, Time) + endif +end subroutine MOM_initialize_state + +!> Reads the layer thicknesses or interface heights from a file. +subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, file_has_thickness, & + just_read, mass_file) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized, in height + !! or thickness units, depending on the value of + !! mass_file [Z ~> m] or [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: file_has_thickness !< If true, this file contains layer + !! thicknesses; otherwise it contains + !! interface heights. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + logical, intent(in) :: mass_file !< If true, this file contains layer thicknesses in + !! units of mass per unit area. + + ! Local variables + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Interface heights, in depth units [Z ~> m]. + real :: h_rescale ! A factor by which to rescale the initial thickness variable in the input + ! file to convert it to units of m [various] + real :: eta_rescale ! A factor by which to rescale the initial interface heights to convert + ! them to units of m or correct sign conventions to positive upward [various] + real :: h_tolerance ! A parameter that controls the tolerance when adjusting the + ! thickness to fit the bathymetry [Z ~> m]. + real :: tol_dz_bot ! A tolerance for detecting inconsistent bottom depths when + ! correct_thickness is false [Z ~> m] + integer :: inconsistent ! The total number of cells with in consistent topography and layer thicknesses. + logical :: correct_thickness + character(len=40) :: mdl = "initialize_thickness_from_file" ! This subroutine's name. + character(len=200) :: filename, thickness_file, inputdir, mesg ! Strings for file/path + character(len=80) :: eta_var ! The interface height variable name in the input file + character(len=80) :: h_var ! The thickness variable name in the input file + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) & + call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".", do_not_log=just_read) + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "THICKNESS_FILE", thickness_file, & + "The name of the thickness file.", & + fail_if_missing=.not.just_read, do_not_log=just_read) + + filename = trim(inputdir)//trim(thickness_file) + if (.not.just_read) call log_param(param_file, mdl, "INPUTDIR/THICKNESS_FILE", filename) + + if ((.not.just_read) .and. (.not.file_exists(filename, G%Domain))) call MOM_error(FATAL, & + " initialize_thickness_from_file: Unable to open "//trim(filename)) + + if (file_has_thickness) then + call get_param(param_file, mdl, "THICKNESS_IC_VAR", h_var, & + "The variable name for layer thickness initial conditions.", & + default="h", do_not_log=just_read) + call get_param(param_file, mdl, "THICKNESS_IC_RESCALE", h_rescale, & + 'A factor by which to rescale the initial thicknesses in the input file to '//& + 'convert them to units of kg/m2 (if THICKNESS_CONFIG="mass_file") or m.', & + default=1.0, units="various", do_not_log=just_read) + if (just_read) return ! All run-time parameters have been read, so return. + + if (mass_file) then + h_rescale = h_rescale*GV%kg_m2_to_H + else + h_rescale = h_rescale*US%m_to_Z + endif + call MOM_read_data(filename, h_var, h(:,:,:), G%Domain, scale=h_rescale) + else + call get_param(param_file, mdl, "ADJUST_THICKNESS", correct_thickness, & + "If true, all mass below the bottom removed if the "//& + "topography is shallower than the thickness input file "//& + "would indicate.", default=.false., do_not_log=just_read) + if (correct_thickness) then + call get_param(param_file, mdl, "THICKNESS_TOLERANCE", h_tolerance, & + "A parameter that controls the tolerance when adjusting the "//& + "thickness to fit the bathymetry. Used when ADJUST_THICKNESS=True.", & + units="m", default=0.1, scale=US%m_to_Z, do_not_log=just_read) + endif + call get_param(param_file, mdl, "DZ_BOTTOM_TOLERANCE", tol_dz_bot, & + "A tolerance for detecting inconsistent topography and input layer "//& + "thicknesses when ADJUST_THICKNESS is false.", & + units="m", default=1.0, scale=US%m_to_Z, & + do_not_log=(just_read.or.correct_thickness)) + call get_param(param_file, mdl, "INTERFACE_IC_VAR", eta_var, & + "The variable name for initial conditions for interface heights "//& + "relative to mean sea level, positive upward unless otherwise rescaled.", & + default="eta", do_not_log=just_read) + call get_param(param_file, mdl, "INTERFACE_IC_RESCALE", eta_rescale, & + "A factor by which to rescale the initial interface heights to convert "//& + "them to units of m or correct sign conventions to positive upward.", & + default=1.0, units="various", do_not_log=just_read) + if (just_read) return ! All run-time parameters have been read, so return. + + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z*eta_rescale) + + if (correct_thickness) then + call adjustEtaToFitBathymetry(G, GV, US, eta, h, h_tolerance, dZ_ref_eta=G%Z_ref) + else + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) then + eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z + else + h(i,j,k) = eta(i,j,K) - eta(i,j,K+1) + endif + enddo ; enddo ; enddo + + inconsistent = 0 + do j=js,je ; do i=is,ie + if (abs(eta(i,j,nz+1) + depth_tot(i,j)) > tol_dz_bot) & + inconsistent = inconsistent + 1 + enddo ; enddo + call sum_across_PEs(inconsistent) + + if ((inconsistent > 0) .and. (is_root_pe())) then + write(mesg,'("Thickness initial conditions are inconsistent ",'// & + '"with topography in ",I8," places.")') inconsistent + call MOM_error(WARNING, mesg) + endif + endif + + endif + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_thickness_from_file + +!> Adjust interface heights to fit the bathymetry and diagnose layer thickness. +!! +!! If the bottom most interface is below the topography then the bottom-most +!! layers are contracted to ANGSTROM thickness (which may be 0). +!! If the bottom most interface is above the topography then the entire column +!! is dilated (expanded) to fill the void. +subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, ht, dZ_ref_eta) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: eta !< Interface heights [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [Z ~> m] + real, intent(in) :: ht !< Tolerance to exceed adjustment + !! criteria [Z ~> m] + real, optional, intent(in) :: dZ_ref_eta !< The difference between the + !! reference heights for bathyT and + !! eta [Z ~> m], 0 by default. + ! Local variables + integer :: i, j, k, is, ie, js, je, nz, contractions, dilations + real :: dilate ! A factor by which the column is dilated [nondim] + real :: dZ_ref ! The difference in the reference heights for G%bathyT and eta [Z ~> m] + character(len=100) :: mesg + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + dZ_ref = 0.0 ; if (present(dZ_ref_eta)) dZ_ref = dZ_ref_eta + + contractions = 0 + do j=js,je ; do i=is,ie + if (-eta(i,j,nz+1) > (G%bathyT(i,j) + dZ_ref) + ht) then + eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) + contractions = contractions + 1 + endif + enddo ; enddo + call sum_across_PEs(contractions) + if ((contractions > 0) .and. (is_root_pe())) then + write(mesg,'("Thickness initial conditions were contracted ",'// & + '"to fit topography in ",I8," places.")') contractions + call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) + endif + + ! To preserve previous answers in non-Boussinesq cases, delay converting + ! thicknesses to units of H until the end of this routine. + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + ! Collapse layers to thinnest possible if the thickness less than + ! the thinnest possible (or negative). + if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) then + eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z + else + h(i,j,k) = (eta(i,j,K) - eta(i,j,K+1)) + endif + enddo ; enddo ; enddo + + dilations = 0 + do j=js,je ; do i=is,ie + ! The whole column is dilated to accommodate deeper topography than + ! the bathymetry would indicate. + ! This should be... if ((G%mask2dt(i,j)*(eta(i,j,1)-eta(i,j,nz+1)) > 0.0) .and. & + if (-eta(i,j,nz+1) < (G%bathyT(i,j) + dZ_ref) - ht) then + dilations = dilations + 1 + if (eta(i,j,1) <= eta(i,j,nz+1)) then + do k=1,nz ; h(i,j,k) = (eta(i,j,1) + (G%bathyT(i,j) + dZ_ref)) / real(nz) ; enddo + else + dilate = (eta(i,j,1) + (G%bathyT(i,j) + dZ_ref)) / (eta(i,j,1) - eta(i,j,nz+1)) + do k=1,nz ; h(i,j,k) = h(i,j,k) * dilate ; enddo + endif + do k=nz,2,-1 ; eta(i,j,K) = eta(i,j,K+1) + h(i,j,k) ; enddo + endif + enddo ; enddo + + + call sum_across_PEs(dilations) + if ((dilations > 0) .and. (is_root_pe())) then + write(mesg,'("Thickness initial conditions were dilated ",'// & + '"to fit topography in ",I8," places.")') dilations + call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) + endif + +end subroutine adjustEtaToFitBathymetry + +!> Initializes thickness to be uniform +subroutine initialize_thickness_uniform(h, depth_tot, G, GV, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + ! Local variables + character(len=40) :: mdl = "initialize_thickness_uniform" ! This subroutine's name. + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually + ! negative because it is positive upward. + real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface, + ! positive upward [Z ~> m]. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (just_read) return ! This subroutine has no run-time parameters. + + call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + + if (G%max_depth<=0.) call MOM_error(FATAL,"initialize_thickness_uniform: "// & + "MAXIMUM_DEPTH has a nonsensical value! Was it set?") + + do k=1,nz + e0(K) = -G%max_depth * real(k-1) / real(nz) + enddo + + do j=js,je ; do i=is,ie + ! This sets the initial thickness (in m) of the layers. The + ! thicknesses are set to insure that: 1. each layer is at least an + ! Angstrom thick, and 2. the interfaces are where they should be + ! based on the resting depths and interface height perturbations, + ! as long at this doesn't interfere with 1. + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(K) = e0(K) + if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then + eta1D(K) = eta1D(K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z + else + h(i,j,k) = eta1D(K) - eta1D(K+1) + endif + enddo + enddo ; enddo + + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_thickness_uniform + +!> Initialize thickness from a 1D list +subroutine initialize_thickness_list(h, depth_tot, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + ! Local variables + character(len=40) :: mdl = "initialize_thickness_list" ! This subroutine's name. + real :: e0(SZK_(GV)+1) ! The resting interface heights, in depth units [Z ~> m], + ! usually negative because it is positive upward. + real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface + ! positive upward, in depth units [Z ~> m]. + character(len=200) :: filename, eta_file, inputdir ! Strings for file/path + character(len=72) :: eta_var ! The interface height variable name in the input file + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call get_param(param_file, mdl, "INTERFACE_IC_FILE", eta_file, & + "The file from which horizontal mean initial conditions "//& + "for interface depths can be read.", fail_if_missing=.true.) + call get_param(param_file, mdl, "INTERFACE_IC_VAR", eta_var, & + "The variable name for horizontal mean initial conditions "//& + "for interface depths relative to mean sea level.", & + default="eta") + + if (just_read) return + + call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + filename = trim(slasher(inputdir))//trim(eta_file) + call log_param(param_file, mdl, "INPUTDIR/INTERFACE_IC_FILE", filename) + + e0(:) = 0.0 + call MOM_read_data(filename, eta_var, e0(:), scale=US%m_to_Z) + + if ((abs(e0(1)) - 0.0) > 0.001) then + ! This list probably starts with the interior interface, so shift it up. + do k=nz+1,2,-1 ; e0(K) = e0(K-1) ; enddo + e0(1) = 0.0 + endif + + if (e0(2) > e0(1)) then ! Switch to the convention for interface heights increasing upward. + do k=1,nz ; e0(K) = -e0(K) ; enddo + endif + + do j=js,je ; do i=is,ie + ! This sets the initial thickness (in m) of the layers. The + ! thicknesses are set to insure that: 1. each layer is at least an + ! Angstrom thick, and 2. the interfaces are where they should be + ! based on the resting depths and interface height perturbations, + ! as long at this doesn't interfere with 1. + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(K) = e0(K) + if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then + eta1D(K) = eta1D(K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z + else + h(i,j,k) = eta1D(K) - eta1D(K+1) + endif + enddo + enddo ; enddo + + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_thickness_list + +!> Search density space for location of layers (not implemented!) +subroutine initialize_thickness_search + call MOM_error(FATAL," MOM_state_initialization.F90, initialize_thickness_search: NOT IMPLEMENTED") +end subroutine initialize_thickness_search + +!> Depress the sea-surface based on an initial condition file +subroutine depress_surface(h, G, GV, US, param_file, tv, just_read, z_top_shelf) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: z_top_shelf !< Top interface position under ice shelf [Z ~> m] + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + eta_sfc ! The free surface height that the model should use [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + eta ! The free surface height that the model should use [Z ~> m]. + real :: dilate ! A ratio by which layers are dilated [nondim]. + real :: scale_factor ! A scaling factor for the eta_sfc values that are read in, + ! which can be used to change units, for example, often [Z m-1 ~> 1]. + character(len=40) :: mdl = "depress_surface" ! This subroutine's name. + character(len=200) :: inputdir, eta_srf_file ! Strings for file/path + character(len=200) :: filename, eta_srf_var ! Strings for file/path + integer :: i, j, k, is, ie, js, je, nz + logical :: use_z_shelf + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + use_z_shelf = present(z_top_shelf) + + + if (.not. use_z_shelf) then + ! Read the surface height (or pressure) from a file. + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "SURFACE_HEIGHT_IC_FILE", eta_srf_file, & + "The initial condition file for the surface height.", & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "SURFACE_HEIGHT_IC_VAR", eta_srf_var, & + "The initial condition variable for the surface height.", & + default="SSH", do_not_log=just_read) + filename = trim(inputdir)//trim(eta_srf_file) + if (.not.just_read) & + call log_param(param_file, mdl, "INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) + + call get_param(param_file, mdl, "SURFACE_HEIGHT_IC_SCALE", scale_factor, & + "A scaling factor to convert SURFACE_HEIGHT_IC_VAR into units of m", & + units="variable", default=1.0, scale=US%m_to_Z, do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + call MOM_read_data(filename, eta_srf_var, eta_sfc, G%Domain, scale=scale_factor) + else + do j=js,je ; do i=is,ie + eta_sfc(i,j) = z_top_shelf(i,j) + enddo; enddo + endif + + ! Convert thicknesses to interface heights. + call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref) + + do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then +! if (eta_sfc(i,j) < eta(i,j,nz+1)) then + ! Issue a warning? +! endif + if (eta_sfc(i,j) > eta(i,j,1)) then + ! Dilate the water column to agree, but only up to 10-fold. + if (eta_sfc(i,j) - eta(i,j,nz+1) > 10.0*(eta(i,j,1) - eta(i,j,nz+1))) then + dilate = 10.0 + call MOM_error(WARNING, "Free surface height dilation attempted "//& + "to exceed 10-fold.", all_print=.true.) + else + dilate = (eta_sfc(i,j) - eta(i,j,nz+1)) / (eta(i,j,1) - eta(i,j,nz+1)) + endif + do k=1,nz ; h(i,j,k) = h(i,j,k) * dilate ; enddo + elseif (eta(i,j,1) > eta_sfc(i,j)) then + ! Remove any mass that is above the target free surface. + do k=1,nz + if (eta(i,j,K) <= eta_sfc(i,j)) exit + if (eta(i,j,K+1) >= eta_sfc(i,j)) then + h(i,j,k) = GV%Angstrom_H + else + h(i,j,k) = max(GV%Angstrom_H, h(i,j,k) * & + (eta_sfc(i,j) - eta(i,j,K+1)) / (eta(i,j,K) - eta(i,j,K+1)) ) + endif + enddo + endif + endif ; enddo ; enddo + +end subroutine depress_surface + +!> Adjust the layer thicknesses by cutting away the top of each model column at the depth +!! where the hydrostatic pressure matches an imposed surface pressure read from file. +subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) + type(param_file_type), intent(in) :: PF !< Parameter file structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + ! Local variables + character(len=200) :: mdl = "trim_for_ice" + real, dimension(SZI_(G),SZJ_(G)) :: p_surf ! Imposed pressure on ocean at surface [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: S_t, S_b ! Top and bottom edge values for reconstructions + ! of salinity within each layer [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: T_t, T_b ! Top and bottom edge values for reconstructions + ! of temperature within each layer [C ~> degC] + character(len=200) :: inputdir, filename, p_surf_file, p_surf_var ! Strings for file/path + real :: scale_factor ! A file-dependent scaling factor for the input pressure [various]. + real :: min_thickness ! The minimum layer thickness [H ~> m or kg m-2]. + real :: z_tolerance ! The tolerance with which to find the depth matching a specified pressure [Z ~> m]. + integer :: i, j, k + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use + ! for remapping. Values below 20190101 recover the remapping + ! answers from 2018, while higher values use more robust + ! forms of the same remapping expressions. + logical :: use_remapping ! If true, remap the initial conditions. + type(remapping_CS), pointer :: remap_CS => NULL() + + call get_param(PF, mdl, "SURFACE_PRESSURE_FILE", p_surf_file, & + "The initial condition file for the surface pressure exerted by ice.", & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(PF, mdl, "SURFACE_PRESSURE_VAR", p_surf_var, & + "The initial condition variable for the surface pressure exerted by ice.", & + default="", do_not_log=just_read) + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".", do_not_log=.true.) + filename = trim(slasher(inputdir))//trim(p_surf_file) + if (.not.just_read) call log_param(PF, mdl, "!INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) + + call get_param(PF, mdl, "SURFACE_PRESSURE_SCALE", scale_factor, & + "A scaling factor to convert SURFACE_PRESSURE_VAR from "//& + "file SURFACE_PRESSURE_FILE into a surface pressure.", & + units="file dependent", default=1., do_not_log=just_read) + call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & + units='m', default=1.e-3, scale=GV%m_to_H, do_not_log=just_read) + call get_param(PF, mdl, "TRIM_IC_Z_TOLERANCE", z_tolerance, & + "The tolerance with which to find the depth matching the specified "//& + "surface pressure with TRIM_IC_FOR_P_SURF.", & + units="m", default=1.0e-5, scale=US%m_to_Z, do_not_log=just_read) + + call get_param(PF, mdl, "TRIMMING_USES_REMAPPING", use_remapping, & + 'When trimming the column, also remap T and S.', & + default=.false., do_not_log=just_read) + if (use_remapping) then + call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=just_read) + call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) + else + remap_answer_date = 20181231 + if (.not.GV%Boussinesq) remap_answer_date = 20230701 + endif + + if (just_read) return ! All run-time parameters have been read, so return. + + call MOM_read_data(filename, p_surf_var, p_surf, G%Domain, & + scale=scale_factor*US%Pa_to_RL2_T2) + + if (use_remapping) then + allocate(remap_CS) + call initialize_remapping(remap_CS, 'PLM', boundary_extrapolation=.true.) + endif + + ! Find edge values of T and S used in reconstructions + if ( associated(ALE_CSp) ) then ! This should only be associated if we are in ALE mode + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, .true.) + else +! call MOM_error(FATAL, "trim_for_ice: Does not work without ALE mode") + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + T_t(i,j,k) = tv%T(i,j,k) ; T_b(i,j,k) = tv%T(i,j,k) + S_t(i,j,k) = tv%S(i,j,k) ; S_b(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call cut_off_column_top(GV%ke, tv, GV, US, GV%g_Earth, G%bathyT(i,j)+G%Z_ref, & + min_thickness, tv%T(i,j,:), T_t(i,j,:), T_b(i,j,:), & + tv%S(i,j,:), S_t(i,j,:), S_b(i,j,:), p_surf(i,j), h(i,j,:), remap_CS, & + z_tol=z_tolerance, remap_answer_date=remap_answer_date) + enddo ; enddo + +end subroutine trim_for_ice + +!> Calculate the hydrostatic equilibrium position of the surface under an ice shelf +subroutine calc_sfc_displacement(PF, G, GV, US, mass_shelf, tv, h) + type(param_file_type), intent(in) :: PF !< Parameter file structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: mass_shelf !< Ice shelf mass [R Z ~> kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + + real :: z_top_shelf(SZI_(G),SZJ_(G)) ! The depth of the top interface under ice shelves [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + eta ! The free surface height that the model should use [Z ~> m]. + ! temporary arrays + real, dimension(SZK_(GV)) :: rho_col ! potential density in the column for use in ice [R ~> kg m-3] + real, dimension(SZK_(GV)) :: rho_h ! potential density multiplied by thickness [R Z ~> kg m-2] + real, dimension(SZK_(GV)) :: h_tmp ! temporary storage for thicknesses [H ~> m] + real, dimension(SZK_(GV)) :: p_ref ! pressure for density [R Z ~> kg m-2] + real, dimension(SZK_(GV)+1) :: ei_tmp, ei_orig ! temporary storage for interface positions [Z ~> m] + real :: z_top ! An estimate of the height of the ice-ocean interface [Z ~> m] + real :: mass_disp ! The net mass of sea water that has been displaced by the shelf [R Z ~> kg m-2] + real :: residual ! The difference between the displaced ocean mass and the ice shelf + ! mass [R Z ~> kg m-2] + real :: tol ! The initialization tolerance for ice shelf initialization [Z ~> m] + integer :: is, ie, js, je, k, nz, i, j, max_iter, iter + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call get_param(PF, mdl, "ICE_SHELF_INITIALIZATION_Z_TOLERANCE", tol, & + "A initialization tolerance for the calculation of the static "// & + "ice shelf displacement (m) using initial temperature and salinity profile.", & + default=0.001, units="m", scale=US%m_to_Z) + max_iter = 1e3 + call MOM_mesg("Started calculating initial interface position under ice shelf ") + ! Convert thicknesses to interface heights. + call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref) + do j=js,je ; do i=is,ie + iter = 1 + z_top_shelf(i,j) = 0.0 + p_ref(:) = tv%p_ref + if ((G%mask2dT(i,j) > 0.) .and. (mass_shelf(i,j) > 0.)) then + call calculate_density(tv%T(i,j,:), tv%S(i,j,:), P_Ref, rho_col, tv%eqn_of_state) + z_top = min(max(-1.0*mass_shelf(i,j)/rho_col(1), -G%bathyT(i,j)), 0.) + h_tmp(:) = 0.0 + ei_tmp(1:nz+1) = eta(i,j,1:nz+1) + ei_orig(1:nz+1) = eta(i,j,1:nz+1) + do k=1,nz+1 + if (ei_tmp(k) < z_top) ei_tmp(k) = z_top + enddo + mass_disp = 0.0 + do k=1,nz + h_tmp(k) = max(ei_tmp(k)-ei_tmp(k+1), GV%Angstrom_H) + rho_h(k) = h_tmp(k) * rho_col(k) + mass_disp = mass_disp + rho_h(k) + enddo + residual = mass_shelf(i,j) - mass_disp + do while ((abs(residual) > tol) .and. (z_top > -G%bathyT(i,j)) .and. (iter < max_iter)) + z_top = min(max(z_top-(residual*0.5e-3), -G%bathyT(i,j)), 0.0) + h_tmp(:) = 0.0 + ei_tmp(1:nz+1) = ei_orig(1:nz+1) + do k=1,nz+1 + if (ei_tmp(k) < z_top) ei_tmp(k) = z_top + enddo + mass_disp = 0.0 + do k=1,nz + h_tmp(k) = max(ei_tmp(k)-ei_tmp(k+1), GV%Angstrom_H) + rho_h(k) = h_tmp(k) * rho_col(k) + mass_disp = mass_disp + rho_h(k) + enddo + residual = mass_shelf(i,j) - mass_disp + iter = iter+1 + end do + if (iter >= max_iter) call MOM_mesg("Warning: calc_sfc_displacement too many iterations.") + z_top_shelf(i,j) = z_top + endif + enddo ; enddo + call MOM_mesg("Calling depress_surface ") + call depress_surface(h, G, GV, US, PF, tv, just_read=.false.,z_top_shelf=z_top_shelf) + call MOM_mesg("Finishing calling depress_surface ") +end subroutine calc_sfc_displacement + +!> Adjust the layer thicknesses by removing the top of the water column above the +!! depth where the hydrostatic pressure matches p_surf +subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, T_t, T_b, & + S, S_t, S_b, p_surf, h, remap_CS, z_tol, remap_answer_date) + integer, intent(in) :: nk !< Number of layers + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: G_earth !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: depth !< Depth of ocean column [Z ~> m]. + real, intent(in) :: min_thickness !< Smallest thickness allowed [H ~> m or kg m-2]. + real, dimension(nk), intent(inout) :: T !< Layer mean temperature [C ~> degC] + real, dimension(nk), intent(in) :: T_t !< Temperature at top of layer [C ~> degC] + real, dimension(nk), intent(in) :: T_b !< Temperature at bottom of layer [C ~> degC] + real, dimension(nk), intent(inout) :: S !< Layer mean salinity [S ~> ppt] + real, dimension(nk), intent(in) :: S_t !< Salinity at top of layer [S ~> ppt] + real, dimension(nk), intent(in) :: S_b !< Salinity at bottom of layer [S ~> ppt] + real, intent(in) :: p_surf !< Imposed pressure on ocean at surface [R L2 T-2 ~> Pa] + real, dimension(nk), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + type(remapping_CS), pointer :: remap_CS !< Remapping structure for remapping T and S, + !! if associated + real, intent(in) :: z_tol !< The tolerance with which to find the depth + !! matching the specified pressure [Z ~> m]. + integer, optional, intent(in) :: remap_answer_date !< The vintage of the order of arithmetic and + !! expressions to use for remapping. Values below 20190101 + !! recover the remapping answers from 2018, while higher + !! values use more robust forms of the same remapping expressions. + + ! Local variables + real, dimension(nk+1) :: e ! Top and bottom edge positions for reconstructions [Z ~> m] + real, dimension(nk) :: h0, h1 ! Initial and remapped layer thicknesses [H ~> m or kg m-2] + real, dimension(nk) :: S0, S1 ! Initial and remapped layer salinities [S ~> ppt] + real, dimension(nk) :: T0, T1 ! Initial and remapped layer temperatures [C ~> degC] + real :: P_t, P_b ! Top and bottom pressures [R L2 T-2 ~> Pa] + real :: z_out, e_top ! Interface height positions [Z ~> m] + real :: min_dz ! The minimum thickness in depth units [Z ~> m] + real :: dh_surf_rem ! The remaining thickness to remove in non-Bousinesq mode [H ~> kg m-2] + logical :: answers_2018 + integer :: k + + answers_2018 = .true. ; if (present(remap_answer_date)) answers_2018 = (remap_answer_date < 20190101) + + ! Keep a copy of the initial thicknesses in reverse order to use in remapping + do k=1,nk ; h0(k) = h(nk+1-k) ; enddo + + if (GV%Boussinesq) then + min_dz = GV%H_to_Z * min_thickness + ! Calculate original interface positions + e(nk+1) = -depth + do k=nk,1,-1 + e(K) = e(K+1) + GV%H_to_Z*h(k) + enddo + + P_t = 0. + e_top = e(1) + do k=1,nk + call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), & + P_t, p_surf, GV%Rho0, G_earth, tv%eqn_of_state, & + US, P_b, z_out, z_tol=z_tol) + if (z_out>=e(K)) then + ! Imposed pressure was less that pressure at top of cell + exit + elseif (z_out<=e(K+1)) then + ! Imposed pressure was greater than pressure at bottom of cell + e_top = e(K+1) + else + ! Imposed pressure was fell between pressures at top and bottom of cell + e_top = z_out + exit + endif + P_t = P_b + enddo + if (e_top e_top) then + ! Original e(K) is too high + e(K) = e_top + e_top = e_top - min_dz ! Next interface must be at least this deep + endif + ! This layer needs trimming + h(k) = max( min_thickness, GV%Z_to_H * (e(K) - e(K+1)) ) + if (e(K) < e_top) exit ! No need to go further + enddo + endif + else + ! In non-Bousinesq mode, we are already in mass units so the calculation is much easier. + if (p_surf > 0.0) then + dh_surf_rem = p_surf * GV%RZ_to_H / G_earth + do k=1,nk + if (h(k) <= min_thickness) then ! This layer has no mass to remove. + cycle + elseif ((h(k) - min_thickness) < dh_surf_rem) then ! This layer should be removed entirely. + dh_surf_rem = dh_surf_rem - (h(k) - min_thickness) + h(k) = min_thickness + else ! This is the last layer that should be removed. + h(k) = h(k) - dh_surf_rem + dh_surf_rem = 0.0 + exit + endif + enddo + endif + endif + + ! Now we need to remap but remapping assumes the surface is at the + ! same place in the two columns so we turn the column upside down. + if (associated(remap_CS)) then + do k=1,nk + S0(k) = S(nk+1-k) + T0(k) = T(nk+1-k) + h1(k) = h(nk+1-k) + enddo + if (answers_2018) then + call remapping_core_h(remap_CS, nk, h0, T0, nk, h1, T1, 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) + call remapping_core_h(remap_CS, nk, h0, S0, nk, h1, S1, 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) + else + call remapping_core_h(remap_CS, nk, h0, T0, nk, h1, T1, GV%H_subroundoff, GV%H_subroundoff) + call remapping_core_h(remap_CS, nk, h0, S0, nk, h1, S1, GV%H_subroundoff, GV%H_subroundoff) + endif + do k=1,nk + S(k) = S1(nk+1-k) + T(k) = T1(nk+1-k) + enddo + endif + +end subroutine cut_off_column_top + +!> Initialize horizontal velocity components from file +subroutine initialize_velocity_from_file(u, v, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: u !< The zonal velocity that is being initialized [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: v !< The meridional velocity that is being initialized [L T-1 ~> m s-1] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to + !! parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing u or v. + ! Local variables + character(len=40) :: mdl = "initialize_velocity_from_file" ! This subroutine's name. + character(len=200) :: filename, velocity_file, inputdir ! Strings for file/path + character(len=64) :: u_IC_var, v_IC_var ! Velocity component names in files + + if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + + call get_param(param_file, mdl, "VELOCITY_FILE", velocity_file, & + "The name of the velocity initial condition file.", & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + filename = trim(inputdir)//trim(velocity_file) + if (.not.just_read) call log_param(param_file, mdl, "INPUTDIR/VELOCITY_FILE", filename) + + call get_param(param_file, mdl, "U_IC_VAR", u_IC_var, & + "The initial condition variable for zonal velocity in VELOCITY_FILE.", & + default="u") + call get_param(param_file, mdl, "V_IC_VAR", v_IC_var, & + "The initial condition variable for meridional velocity in VELOCITY_FILE.", & + default="v") + + if (just_read) return ! All run-time parameters have been read, so return. + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_velocity_from_file: Unable to open "//trim(filename)) + + ! Read the velocities from a netcdf file. + call MOM_read_vector(filename, u_IC_var, v_IC_var, u(:,:,:), v(:,:,:), G%Domain, scale=US%m_s_to_L_T) + + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_velocity_from_file + +!> Initialize horizontal velocity components to zero. +subroutine initialize_velocity_zero(u, v, G, GV, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: u !< The zonal velocity that is being initialized [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: v !< The meridional velocity that is being initialized [L T-1 ~> m s-1] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to + !! parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + ! Local variables + character(len=200) :: mdl = "initialize_velocity_zero" ! This subroutine's name. + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + + if (just_read) return ! All run-time parameters have been read, so return. + + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + u(I,j,k) = 0.0 + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + v(i,J,k) = 0.0 + enddo ; enddo ; enddo + + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_velocity_zero + +!> Sets the initial velocity components to uniform +subroutine initialize_velocity_uniform(u, v, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: u !< The zonal velocity that is being initialized [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: v !< The meridional velocity that is being initialized [L T-1 ~> m s-1] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to + !! parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing u or v. + ! Local variables + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + real :: initial_u_const, initial_v_const ! Constant initial velocities [L T-1 ~> m s-1] + character(len=200) :: mdl = "initialize_velocity_uniform" ! This subroutine's name. + + 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 + + call get_param(param_file, mdl, "INITIAL_U_CONST", initial_u_const, & + "A initial uniform value for the zonal flow.", & + default=0.0, units="m s-1", scale=US%m_s_to_L_T, do_not_log=just_read) + call get_param(param_file, mdl, "INITIAL_V_CONST", initial_v_const, & + "A initial uniform value for the meridional flow.", & + default=0.0, units="m s-1", scale=US%m_s_to_L_T, do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + u(I,j,k) = initial_u_const + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + v(i,J,k) = initial_v_const + enddo ; enddo ; enddo + +end subroutine initialize_velocity_uniform + +!> Sets the initial velocity components to be circular with +!! no flow at edges of domain and center. +subroutine initialize_velocity_circular(u, v, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: u !< The zonal velocity that is being initialized [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: v !< The meridional velocity that is being initialized [L T-1 ~> m s-1] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to + !! parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing u or v. + ! Local variables + character(len=200) :: mdl = "initialize_velocity_circular" + real :: circular_max_u ! The amplitude of the zonal flow [L T-1 ~> m s-1] + real :: dpi ! A local variable storing pi = 3.14159265358979... [nondim] + real :: psi1, psi2 ! Values of the streamfunction at two points [L2 T-1 ~> m2 s-1] + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + 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 + + call get_param(param_file, mdl, "CIRCULAR_MAX_U", circular_max_u, & + "The amplitude of zonal flow from which to scale the "// & + "circular stream function [m s-1].", & + units="m s-1", default=0., scale=US%m_s_to_L_T, do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + dpi=acos(0.0)*2.0 ! pi + + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + psi1 = my_psi(I,j) + psi2 = my_psi(I,j-1) + u(I,j,k) = (psi1 - psi2) / G%dy_Cu(I,j) ! *(circular_max_u*G%len_lon/(2.0*dpi)) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + psi1 = my_psi(i,J) + psi2 = my_psi(i-1,J) + v(i,J,k) = (psi2 - psi1) / G%dx_Cv(i,J) ! *(circular_max_u*G%len_lon/(2.0*dpi)) + enddo ; enddo ; enddo + + contains + + !> Returns the value of a circular stream function at (ig,jg) in [L2 T-1 ~> m2 s-1] + real function my_psi(ig,jg) + integer :: ig !< Global i-index + integer :: jg !< Global j-index + ! Local variables + real :: x, y, r ! [nondim] + + x = 2.0*(G%geoLonBu(ig,jg)-G%west_lon) / G%len_lon - 1.0 ! -1 Initializes temperature and salinity from file +subroutine initialize_temp_salt_from_file(T, S, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature that is + !! being initialized [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is + !! being initialized [S ~> ppt] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + logical, intent(in) :: just_read !< If true, this call will only + !! read parameters without changing T or S. + ! Local variables + character(len=200) :: filename, salt_filename ! Full paths to input files + character(len=200) :: ts_file, salt_file, inputdir ! Strings for file/path + character(len=40) :: mdl = "initialize_temp_salt_from_file" + character(len=64) :: temp_var, salt_var ! Temperature and salinity names in files + + if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + + call get_param(param_file, mdl, "TS_FILE", ts_file, & + "The initial condition file for temperature.", & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + filename = trim(inputdir)//trim(ts_file) + if (.not.just_read) call log_param(param_file, mdl, "INPUTDIR/TS_FILE", filename) + call get_param(param_file, mdl, "TEMP_IC_VAR", temp_var, & + "The initial condition variable for potential temperature.", & + default="PTEMP", do_not_log=just_read) + call get_param(param_file, mdl, "SALT_IC_VAR", salt_var, & + "The initial condition variable for salinity.", & + default="SALT", do_not_log=just_read) + call get_param(param_file, mdl, "SALT_FILE", salt_file, & + "The initial condition file for salinity.", & + default=trim(ts_file), do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_temp_salt_from_file: Unable to open "//trim(filename)) + + ! Read the temperatures and salinities from netcdf files. + call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain, scale=US%degC_to_C) + + salt_filename = trim(inputdir)//trim(salt_file) + if (.not.file_exists(salt_filename, G%Domain)) call MOM_error(FATAL, & + " initialize_temp_salt_from_file: Unable to open "//trim(salt_filename)) + + call MOM_read_data(salt_filename, salt_var, S(:,:,:), G%Domain, scale=US%ppt_to_S) + + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_temp_salt_from_file + +!> Initializes temperature and salinity from a 1D profile +subroutine initialize_temp_salt_from_profile(T, S, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature that is + !! being initialized [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is + !! being initialized [S ~> ppt] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T or S. + ! Local variables + real, dimension(SZK_(GV)) :: T0 ! The profile of temperatures [C ~> degC] + real, dimension(SZK_(GV)) :: S0 ! The profile of salinities [S ~> ppt] + integer :: i, j, k + character(len=200) :: filename, ts_file, inputdir ! Strings for file/path + character(len=64) :: temp_var, salt_var ! Temperature and salinity names in files + character(len=40) :: mdl = "initialize_temp_salt_from_profile" + + if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + + call get_param(param_file, mdl, "TS_FILE", ts_file, & + "The file with the reference profiles for temperature and salinity.", & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "TEMP_IC_VAR", temp_var, & + "The initial condition variable for potential temperature.", & + default="PTEMP", do_not_log=just_read) + call get_param(param_file, mdl, "SALT_IC_VAR", salt_var, & + "The initial condition variable for salinity.", & + default="SALT", do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + filename = trim(inputdir)//trim(ts_file) + call log_param(param_file, mdl, "INPUTDIR/TS_FILE", filename) + if (.not.file_exists(filename)) call MOM_error(FATAL, & + " initialize_temp_salt_from_profile: Unable to open "//trim(filename)) + + ! Read the temperatures and salinities from a netcdf file. + call MOM_read_data(filename, temp_var, T0(:), scale=US%degC_to_C) + call MOM_read_data(filename, salt_var, S0(:), scale=US%ppt_to_S) + + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + T(i,j,k) = T0(k) ; S(i,j,k) = S0(k) + enddo ; enddo ; enddo + + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_temp_salt_from_profile + +!> Initializes temperature and salinity by fitting to density +subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P_Ref, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature that is + !! being initialized [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is being + !! initialized [S ~> ppt]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + real, intent(in) :: P_Ref !< The coordinate-density reference pressure + !! [R L2 T-2 ~> Pa]. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T or S. + ! Local variables + real :: T0(SZK_(GV)) ! Layer potential temperatures [C ~> degC] + real :: S0(SZK_(GV)) ! Layer salinities [S ~> ppt] + real :: T_Ref ! Reference Temperature [C ~> degC] + real :: S_Ref ! Reference Salinity [S ~> ppt] + real :: pres(SZK_(GV)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. + real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3]. + logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. + character(len=40) :: mdl = "initialize_temp_salt_fit" ! This subroutine's name. + integer :: i, j, k, itt, nz + nz = GV%ke + + if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + + call get_param(param_file, mdl, "T_REF", T_Ref, & + "A reference temperature used in initialization.", & + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_Ref, & + "A reference salinity used in initialization.", & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "FIT_SALINITY", fit_salin, & + "If true, accept the prescribed temperature and fit the "//& + "salinity; otherwise take salinity and fit temperature.", & + default=.false., do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + do k=1,nz + pres(k) = P_Ref ; S0(k) = S_Ref + T0(k) = T_Ref + enddo + + call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, (/1,1/) ) + + if (fit_salin) then + ! A first guess of the layers' temperatures. + do k=nz,1,-1 + S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS(1)) + enddo + ! Refine the guesses for each layer. + do itt=1,6 + call calculate_density(T0, S0, pres, rho_guess, eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state) + do k=1,nz + S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS(k)) + enddo + enddo + else + ! A first guess of the layers' temperatures. + do k=nz,1,-1 + T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT(1) + enddo + do itt=1,6 + call calculate_density(T0, S0, pres, rho_guess, eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state) + do k=1,nz + T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + enddo + enddo + endif + + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + T(i,j,k) = T0(k) ; S(i,j,k) = S0(k) + enddo ; enddo ; enddo + + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_temp_salt_fit + +!> Initializes T and S with linear profiles according to reference surface +!! layer salinity and temperature and a specified range. +!! +!! \remark Note that the linear distribution is set up with respect to the layer +!! number, not the physical position). +subroutine initialize_temp_salt_linear(T, S, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature that is + !! being initialized [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is + !! being initialized [S ~> ppt] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for + !! run-time parameters + logical, intent(in) :: just_read !< If present and true, + !! this call will only read parameters + !! without changing T or S. + + ! Local variables + real :: S_top, S_range ! Reference salinity in the surface layer and its vertical range [S ~> ppt] + real :: T_top, T_range ! Reference temperature in the surface layer and its vertical range [C ~> degC] + character(len=40) :: mdl = "initialize_temp_salt_linear" ! This subroutine's name. + integer :: k + + if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + call get_param(param_file, mdl, "T_TOP", T_top, & + "Initial temperature of the top surface.", & + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "T_RANGE", T_range, & + "Initial temperature difference (top-bottom).", & + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_TOP", S_top, & + "Initial salinity of the top surface.", & + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_RANGE", S_range, & + "Initial salinity difference (top-bottom).", & + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + ! Prescribe salinity and temperature, with the extrapolated top interface value prescribed. + do k=1,GV%ke + S(:,:,k) = S_top - S_range*((real(k)-0.5)/real(GV%ke)) + T(:,:,k) = T_top - T_range*((real(k)-0.5)/real(GV%ke)) + enddo + + ! Prescribe salinity and temperature, but with the top layer value matching the surface value. + ! S(:,:,1) = S_top ; T(:,:,1) = T_top + ! do k=2,GV%ke + ! S(:,:,k) = S_top - S_range * (real(k-1) / real(GV%ke-1)) + ! T(:,:,k) = T_top - T_range * (real(k-1) / real(GV%ke-1)) + ! enddo + + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_temp_salt_linear + +!> This subroutine sets the inverse restoration time (Idamp), and +!! the values towards which the interface heights and an arbitrary +!! number of tracers should be restored within each sponge. The +!! interface height is always subject to damping, and must always be +!! the first registered field. +subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_tot, param_file, & + Layer_CSp, ALE_CSp, Time) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: use_temperature !< If true, T & S are state variables. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic + !! variables. + real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity that is being + !! initialized [L T-1 ~> m s-1] + real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity that is being + !! initialized [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. + type(sponge_CS), pointer :: Layer_CSp !< A pointer that is set to point to the control + !! structure for this module (in layered mode). + type(ALE_sponge_CS), pointer :: ALE_CSp !< A pointer that is set to point to the control + !! structure for this module (in ALE mode). + type(time_type), intent(in) :: Time !< Time at the start of the run segment. Time_in + !! overrides any value set for Time. + ! Local variables + real, allocatable, dimension(:,:,:) :: eta ! The target interface heights [Z ~> m]. + real, allocatable, dimension(:,:,:) :: dz ! The target interface thicknesses in height units [Z ~> m] + real, allocatable, dimension(:,:,:) :: h ! The target interface thicknesses [H ~> m or kg m-2]. + + real, dimension (SZI_(G),SZJ_(G),SZK_(GV)) :: & + tmp, & ! A temporary array for temperatures [C ~> degC] or other tracers. + tmp2 ! A temporary array for salinities [S ~> ppt] + real, dimension (SZI_(G),SZJ_(G)) :: & + tmp_2d ! A temporary array for mixed layer densities [R ~> kg m-3] + real, allocatable, dimension(:,:,:) :: tmp_T ! A temporary array for reading sponge target temperatures + ! on the vertical grid of the input file [C ~> degC] + real, allocatable, dimension(:,:,:) :: tmp_S ! A temporary array for reading sponge target salinities + ! on the vertical grid of the input file [S ~> ppt] + real, allocatable, dimension(:,:,:) :: tmp_u ! Temporary array for reading sponge target zonal + ! velocities on the vertical grid of the input file [L T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: tmp_v ! Temporary array for reading sponge target meridional + ! velocities on the vertical grid of the input file [L T-1 ~> m s-1] + + real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] + real :: Idamp_u(SZIB_(G),SZJ_(G)) ! The sponge damping rate for velocity fields [T-1 ~> s-1] + real :: Idamp_v(SZI_(G),SZJB_(G)) ! The sponge damping rate for velocity fields [T-1 ~> s-1] + real :: pres(SZI_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa] + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, nz + integer :: isd, ied, jsd, jed + integer, dimension(4) :: siz + integer :: nz_data ! The size of the sponge source grid + logical :: sponge_uv ! Apply sponges in u and v, in addition to tracers. + character(len=40) :: potemp_var, salin_var, u_var, v_var, Idamp_var, Idamp_u_var, Idamp_v_var, eta_var + character(len=40) :: mdl = "initialize_sponges_file" + character(len=200) :: damping_file, uv_damping_file, state_file, state_uv_file ! Strings for filenames + character(len=200) :: filename, inputdir ! Strings for file/path and path. + type(verticalGrid_type) :: GV_loc ! A temporary vertical grid structure + + logical :: use_ALE ! True if ALE is being used, False if in layered mode + logical :: time_space_interp_sponge ! If true use sponge data that need to be interpolated in both + ! the horizontal dimension and in time prior to vertical remapping. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + pres(:) = 0.0 ; tmp(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 ; Idamp_u(:,:) = 0.0 ; Idamp_v(:,:) = 0.0 + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "SPONGE_DAMPING_FILE", damping_file, & + "The name of the file with the sponge damping rates.", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "SPONGE_STATE_FILE", state_file, & + "The name of the file with the state to damp toward.", & + default=damping_file) + call get_param(param_file, mdl, "SPONGE_PTEMP_VAR", potemp_var, & + "The name of the potential temperature variable in "//& + "SPONGE_STATE_FILE.", default="PTEMP") + call get_param(param_file, mdl, "SPONGE_SALT_VAR", salin_var, & + "The name of the salinity variable in "//& + "SPONGE_STATE_FILE.", default="SALT") + call get_param(param_file, mdl, "SPONGE_UV", sponge_uv, & + "Apply sponges in u and v, in addition to tracers.", & + default=.false.) + if (sponge_uv) then + call get_param(param_file, mdl, "SPONGE_UV_STATE_FILE", state_uv_file, & + "The name of the file with the state to damp UV toward.", & + default=damping_file) + call get_param(param_file, mdl, "SPONGE_U_VAR", u_var, & + "The name of the zonal velocity variable in "//& + "SPONGE_UV_STATE_FILE.", default="UVEL") + call get_param(param_file, mdl, "SPONGE_V_VAR", v_var, & + "The name of the vertical velocity variable in "//& + "SPONGE_UV_STATE_FILE.", default="VVEL") + endif + call get_param(param_file, mdl, "SPONGE_ETA_VAR", eta_var, & + "The name of the interface height variable in "//& + "SPONGE_STATE_FILE.", default="ETA") + call get_param(param_file, mdl, "SPONGE_IDAMP_VAR", Idamp_var, & + "The name of the inverse damping rate variable in "//& + "SPONGE_DAMPING_FILE.", default="Idamp") + if (sponge_uv) then + call get_param(param_file, mdl, "SPONGE_UV_DAMPING_FILE", uv_damping_file, & + "The name of the file with sponge damping rates for the velocity variables.", & + default=damping_file) + call get_param(param_file, mdl, "SPONGE_IDAMP_U_var", Idamp_u_var, & + "The name of the inverse damping rate variable in "//& + "SPONGE_UV_DAMPING_FILE for the velocities.", default=Idamp_var) + call get_param(param_file, mdl, "SPONGE_IDAMP_V_var", Idamp_v_var, & + "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, default=.false., do_not_log=.true.) + + call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & + "If True, perform on-the-fly regridding in lat-lon-time of sponge restoring data.", & + default=.false.) + + ! Read in sponge damping rate for tracers + filename = trim(inputdir)//trim(damping_file) + call log_param(param_file, mdl, "INPUTDIR/SPONGE_DAMPING_FILE", filename) + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) + + if (time_space_interp_sponge .and. .not. use_ALE) & + call MOM_error(FATAL, " initialize_sponges: Time-varying sponges are currently unavailable in layered mode ") + + call MOM_read_data(filename, Idamp_var, Idamp(:,:), G%Domain, scale=US%T_to_s) + + ! Read in sponge damping rate for velocities + if (sponge_uv) then + if (separate_idamp_for_uv()) then + filename = trim(inputdir)//trim(uv_damping_file) + call log_param(param_file, mdl, "INPUTDIR/SPONGE_UV_DAMPING_FILE", filename) + + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) + + 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 + endif + endif + + ! Now register all of the fields which are damped in the sponge. + ! By default, momentum is advected vertically within the sponge, but + ! momentum is typically not damped within the sponge. + + filename = trim(inputdir)//trim(state_file) + call log_param(param_file, mdl, "INPUTDIR/SPONGE_STATE_FILE", filename) + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) + + + if (.not. use_ALE) then + ! The first call to set_up_sponge_field is for the interface heights if in layered mode. + allocate(eta(isd:ied,jsd:jed,nz+1), source=0.0) + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) + + do j=js,je ; do i=is,ie + eta(i,j,nz+1) = -depth_tot(i,j) + enddo ; enddo + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) & + eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z + enddo ; enddo ; enddo + ! Set the sponge damping rates so that the model will know where to + ! apply the sponges, along with the interface heights. + call initialize_sponge(Idamp, eta, G, param_file, Layer_CSp, GV) + deallocate(eta) + + if ( GV%nkml>0) then + ! This call to set_up_sponge_ML_density registers the target values of the + ! mixed layer density, which is used in determining which layers can be + ! inflated without causing static instabilities. + do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) + + call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain, scale=US%degC_to_C) + call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain, scale=US%ppt_to_S) + + do j=js,je + call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), tv%eqn_of_state, EOSdom) + enddo + + call set_up_sponge_ML_density(tmp_2d, G, Layer_CSp) + endif + + ! Now register all of the tracer fields which are damped in the + ! sponge. By default, momentum is advected vertically within the + ! sponge, but momentum is typically not damped within the sponge. + + + ! The remaining calls to set_up_sponge_field can be in any order. + if ( use_temperature) then + call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain, scale=US%degC_to_C) + call set_up_sponge_field(tmp, tv%T, G, GV, nz, Layer_CSp) + call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain, scale=US%ppt_to_S) + call set_up_sponge_field(tmp2, tv%S, G, GV, nz, Layer_CSp) + endif + +! else + ! Initialize sponges without supplying sponge grid +! if (sponge_uv) then +! call initialize_ALE_sponge(Idamp, G, GV, US, param_file, ALE_CSp, Idamp_u, Idamp_v) +! else +! call initialize_ALE_sponge(Idamp, G, GV, US, param_file, ALE_CSp) +! endif + endif + + + if (use_ALE) then ! ALE mode + if (.not. time_space_interp_sponge) then + call field_size(filename,eta_var,siz,no_domain=.true.) + if (siz(1) /= G%ieg-G%isg+1 .or. siz(2) /= G%jeg-G%jsg+1) & + call MOM_error(FATAL,"initialize_sponge_file: Array size mismatch for sponge data.") + nz_data = siz(3)-1 + allocate(eta(isd:ied,jsd:jed,nz_data+1)) + allocate(dz(isd:ied,jsd:jed,nz_data)) + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) + do j=js,je ; do i=is,ie + eta(i,j,nz_data+1) = -depth_tot(i,j) + enddo ; enddo + do k=nz_data,1,-1 ; do j=js,je ; do i=is,ie + if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) & + eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z + enddo ; enddo ; enddo + do k=1,nz_data ; do j=js,je ; do i=is,ie + dz(i,j,k) = eta(i,j,k)-eta(i,j,k+1) + enddo; enddo ; enddo + deallocate(eta) + + allocate(h(isd:ied,jsd:jed,nz_data)) + if (use_temperature) then + allocate(tmp_T(isd:ied,jsd:jed,nz_data)) + allocate(tmp_S(isd:ied,jsd:jed,nz_data)) + call MOM_read_data(filename, potemp_var, tmp_T(:,:,:), G%Domain, scale=US%degC_to_C) + call MOM_read_data(filename, salin_var, tmp_S(:,:,:), G%Domain, scale=US%ppt_to_S) + endif + + GV_loc = GV ; GV_loc%ke = nz_data + if (use_temperature .and. associated(tv%eqn_of_state)) then + call dz_to_thickness(dz, tmp_T, tmp_S, tv%eqn_of_state, h, G, GV_loc, US) + else + call dz_to_thickness_simple(dz, h, G, GV_loc, US, layer_mode=.true.) + endif + + if (sponge_uv) then + call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, dz, nz_data, Idamp_u, Idamp_v, & + data_h_is_Z=.true.) + else + call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, dz, nz_data, & + data_h_is_Z=.true.) + endif + if (use_temperature) then + call set_up_ALE_sponge_field(tmp_T, G, GV, tv%T, ALE_CSp, 'temp', & + sp_long_name='temperature', sp_unit='degC s-1') + call set_up_ALE_sponge_field(tmp_S, G, GV, tv%S, ALE_CSp, 'salt', & + sp_long_name='salinity', sp_unit='g kg-1 s-1') + deallocate(tmp_S) + deallocate(tmp_T) + endif + deallocate(h) + deallocate(dz) + + if (sponge_uv) then + filename = trim(inputdir)//trim(state_uv_file) + call log_param(param_file, mdl, "INPUTDIR/SPONGE_STATE_UV_FILE", filename) + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) + allocate(tmp_u(G%IsdB:G%IedB,jsd:jed,nz_data)) + allocate(tmp_v(isd:ied,G%JsdB:G%JedB,nz_data)) + call MOM_read_vector(filename, u_var, v_var, tmp_u(:,:,:), tmp_v(:,:,:), G%Domain, scale=US%m_s_to_L_T) + call set_up_ALE_sponge_vel_field(tmp_u, tmp_v, G, GV, u, v, ALE_CSp) + deallocate(tmp_u,tmp_v) + endif + else + ! Initialize sponges without supplying sponge grid + if (sponge_uv) then + call initialize_ALE_sponge(Idamp, G, GV, US, param_file, ALE_CSp, Idamp_u, Idamp_v) + else + call initialize_ALE_sponge(Idamp, G, GV, US, param_file, ALE_CSp) + endif + ! The remaining calls to set_up_sponge_field can be in any order. + if ( use_temperature) then + call set_up_ALE_sponge_field(filename, potemp_var, Time, G, GV, US, tv%T, ALE_CSp, & + 'temp', sp_long_name='temperature', sp_unit='degC s-1', scale=US%degC_to_C) + call set_up_ALE_sponge_field(filename, salin_var, Time, G, GV, US, tv%S, ALE_CSp, & + 'salt', sp_long_name='salinity', sp_unit='g kg-1 s-1', scale=US%ppt_to_S) + endif + if (sponge_uv) then + filename = trim(inputdir)//trim(state_uv_file) + call log_param(param_file, mdl, "INPUTDIR/SPONGE_STATE_UV_FILE", filename) + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) + call set_up_ALE_sponge_vel_field(filename, u_var, filename, v_var, Time, G, GV, US, & + ALE_CSp, u, v, scale=US%m_s_to_L_T) + endif + endif + endif + + if (sponge_uv .and. .not. use_ALE) call MOM_error(FATAL,'initialize_sponges_file: '// & + 'UV damping to target values only available in ALE mode') + + + contains + + ! returns true if a separate idamp is provided for u and/or v + logical function separate_idamp_for_uv() + separate_idamp_for_uv = (lowercase(damping_file)/=lowercase(uv_damping_file) .or. & + lowercase(Idamp_var)/=lowercase(Idamp_u_var) .or. lowercase(Idamp_var)/=lowercase(Idamp_v_var)) + end function separate_idamp_for_uv + +end subroutine initialize_sponges_file + +subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, param_file, & + oda_incupd_CSp, restart_CS, Time) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: use_temperature !< If true, T & S are state variables. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic + !! variables. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] (in) + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity that is being + !! initialized [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity that is being + !! initialized [L T-1 ~> m s-1] + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. + type(oda_incupd_CS), pointer :: oda_incupd_CSp !< A pointer that is set to point to the control + !! structure for this module. + type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure + type(time_type), intent(in) :: Time !< Time at the start of the run segment. Time_in + !! overrides any value set for Time. + ! Local variables + real, allocatable, dimension(:,:,:) :: hoda ! The layer thickness increment and oda layer thickness [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: tmp_tr ! A temporary array for reading oda tracer increments + ! on the vertical grid of the input file, used for both + ! temperatures [C ~> degC] and salinities [S ~> ppt] + real, allocatable, dimension(:,:,:) :: tmp_u ! Temporary array for reading oda zonal velocity + ! increments on the vertical grid of the input file [L T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: tmp_v ! Temporary array for reading oda meridional velocity + ! increments on the vertical grid of the input file [L T-1 ~> m s-1] + + integer :: is, ie, js, je, nz + integer :: isd, ied, jsd, jed + + integer, dimension(4) :: siz + integer :: nz_data ! The size of the sponge source grid + logical :: oda_inc ! input files are increments (true) or full fields (false) + logical :: save_inc ! save increments if using full fields + logical :: uv_inc ! use u and v increments + logical :: reset_ncount ! reset ncount to zero if true + + character(len=40) :: tempinc_var, salinc_var, uinc_var, vinc_var, h_var + character(len=40) :: mdl = "initialize_oda_incupd_file" + character(len=200) :: inc_file, uv_inc_file ! Strings for filenames + character(len=200) :: filename, inputdir ! Strings for file/path and path. + +! logical :: use_ALE ! True if ALE is being used, False if in layered mode + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + call get_param(param_file, mdl, "ODA_INCUPD_FILE", inc_file, & + "The name of the file with the T,S,h increments.", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "ODA_INCUPD_INC", oda_inc, & + "INCUPD files are increments and not full fields.", & + default=.true.) + if (.not.oda_inc) then + call get_param(param_file, mdl, "ODA_INCUPD_SAVE", save_inc, & + "If true, save the increments when using full fields.", & + default=.false.) + endif + call get_param(param_file, mdl, "ODA_INCUPD_RESET_NCOUNT", reset_ncount, & + "If True, reinitialize number of updates already done, ncount.", & + default=.true.) + if (.not.oda_inc .and. .not.reset_ncount) & + call MOM_error(FATAL, " initialize_oda_incupd: restarting during update "// & + "necessitates increments input file") + + call get_param(param_file, mdl, "ODA_TEMPINC_VAR", tempinc_var, & + "The name of the potential temperature inc. variable in "//& + "ODA_INCUPD_FILE.", default="ptemp_inc") + call get_param(param_file, mdl, "ODA_SALTINC_VAR", salinc_var, & + "The name of the salinity inc. variable in "//& + "ODA_INCUPD_FILE.", default="sal_inc") + call get_param(param_file, mdl, "ODA_THK_VAR", h_var, & + "The name of the layer thickness variable in "//& + "ODA_INCUPD_FILE.", default="h") + call get_param(param_file, mdl, "ODA_INCUPD_UV", uv_inc, & + "use U,V increments.", & + default=.true.) + call get_param(param_file, mdl, "ODA_INCUPD_UV_FILE", uv_inc_file, & + "The name of the file with the U,V increments.", & + default=inc_file) + call get_param(param_file, mdl, "ODA_UINC_VAR", uinc_var, & + "The name of the zonal vel. inc. variable in "//& + "ODA_INCUPD_FILE.", default="u_inc") + call get_param(param_file, mdl, "ODA_VINC_VAR", vinc_var, & + "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, default=.false., do_not_log=.true.) + + ! Read in incremental update for tracers + filename = trim(inputdir)//trim(inc_file) + call log_param(param_file, mdl, "INPUTDIR/ODA_INCUPD_FILE", filename) + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " initialize_oda_incupd: Unable to open "//trim(filename)) + + call field_size(filename,h_var,siz,no_domain=.true.) + if (siz(1) /= G%ieg-G%isg+1 .or. siz(2) /= G%jeg-G%jsg+1) & + call MOM_error(FATAL,"initialize_oda_incupd_file: Array size mismatch for oda data.") + nz_data = siz(3) + ! get h increments + allocate(hoda(isd:ied,jsd:jed,nz_data)) + call MOM_read_data(filename, h_var , hoda(:,:,:), G%Domain, scale=US%m_to_Z) + call initialize_oda_incupd( G, GV, US, param_file, oda_incupd_CSp, hoda, nz_data, restart_CS) + deallocate(hoda) + + ! set-up T and S increments arrays + if (use_temperature) then + allocate(tmp_tr(isd:ied,jsd:jed,nz_data)) + ! temperature inc. in array Inc(1) + call MOM_read_data(filename, tempinc_var, tmp_tr(:,:,:), G%Domain, scale=US%degC_to_C) + call set_up_oda_incupd_field(tmp_tr, G, GV, oda_incupd_CSp) + ! salinity inc. in array Inc(2) + call MOM_read_data(filename, salinc_var, tmp_tr(:,:,:), G%Domain, scale=US%ppt_to_S) + call set_up_oda_incupd_field(tmp_tr, G, GV, oda_incupd_CSp) + deallocate(tmp_tr) + endif + + ! set-up U and V increments arrays + if (uv_inc) then + filename = trim(inputdir)//trim(uv_inc_file) + call log_param(param_file, mdl, "INPUTDIR/ODA_INCUPD_UV_FILE", filename) + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " initialize_oda_incupd_uv: Unable to open "//trim(filename)) + allocate(tmp_u(G%IsdB:G%IedB,jsd:jed,nz_data), source=0.0) + allocate(tmp_v(isd:ied,G%JsdB:G%JedB,nz_data), source=0.0) + call MOM_read_vector(filename, uinc_var, vinc_var, tmp_u, tmp_v, G%Domain,scale=US%m_s_to_L_T) + call set_up_oda_incupd_vel_field(tmp_u, tmp_v, G, GV, oda_incupd_CSp) + deallocate(tmp_u, tmp_v) + endif + + ! calculate increments if input are full fields + if (oda_inc) then ! input are increments + if (is_root_pe()) call MOM_mesg("incupd using increments fields ") + else ! inputs are full fields + if (is_root_pe()) call MOM_mesg("incupd using full fields ") + call calc_oda_increments(h, tv, u, v, G, GV, US, oda_incupd_CSp) + if (save_inc) then + call output_oda_incupd_inc(Time, G, GV, param_file, oda_incupd_CSp, US) + endif + endif ! not oda_inc + +end subroutine initialize_oda_incupd_file + + +!> This subroutine sets the 4 bottom depths at velocity points to be the +!! maximum of the adjacent depths. +subroutine set_velocity_depth_max(G) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + ! Local variables + integer :: i, j + + do I=G%isd,G%ied-1 ; do j=G%jsd,G%jed + G%Dblock_u(I,j) = G%mask2dCu(I,j) * max(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Dopen_u(I,j) = G%Dblock_u(I,j) + enddo ; enddo + do i=G%isd,G%ied ; do J=G%jsd,G%jed-1 + G%Dblock_v(I,J) = G%mask2dCv(i,J) * max(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Dopen_v(I,J) = G%Dblock_v(I,J) + enddo ; enddo +end subroutine set_velocity_depth_max + +!> Subroutine to pre-compute global integrals of grid quantities for +!! later use in reporting diagnostics +subroutine compute_global_grid_integrals(G, US) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! Local variables + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming ! Masked and unscaled areas for sums [m2] + real :: area_scale ! A conversion factor to prepare for reproducing sums [m2 L-2 ~> 1] + integer :: i,j + + area_scale = US%L_to_m**2 + tmpForSumming(:,:) = 0. + G%areaT_global = 0.0 ; G%IareaT_global = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + tmpForSumming(i,j) = area_scale*G%areaT(i,j) * G%mask2dT(i,j) + enddo ; enddo + G%areaT_global = reproducing_sum(tmpForSumming) + G%IareaT_global = 1. / (G%areaT_global) +end subroutine compute_global_grid_integrals + +!> This subroutine sets the 4 bottom depths at velocity points to be the +!! minimum of the adjacent depths. +subroutine set_velocity_depth_min(G) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + ! Local variables + integer :: i, j + + do I=G%isd,G%ied-1 ; do j=G%jsd,G%jed + G%Dblock_u(I,j) = G%mask2dCu(I,j) * min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Dopen_u(I,j) = G%Dblock_u(I,j) + enddo ; enddo + do i=G%isd,G%ied ; do J=G%jsd,G%jed-1 + G%Dblock_v(I,J) = G%mask2dCv(i,J) * min(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Dopen_v(I,J) = G%Dblock_v(I,J) + enddo ; enddo +end subroutine set_velocity_depth_min + +!> This subroutine determines the isopycnal or other coordinate interfaces and +!! layer potential temperatures and salinities directly from a z-space file on +!! a latitude-longitude grid. +subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just_read, frac_shelf_h) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< Layer thicknesses being initialized [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic + !! variables including temperature and salinity + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: PF !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T or S. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: frac_shelf_h !< The fraction of the grid cell covered + !! by a floating ice shelf [nondim]. + + ! Local variables + character(len=200) :: filename !< The name of an input file containing temperature + !! and salinity in z-space; by default it is also used for ice shelf area. + character(len=200) :: tfilename !< The name of an input file containing temperature in z-space. + character(len=200) :: sfilename !< The name of an input file containing salinity in z-space. + character(len=200) :: inputdir !! The directory where NetCDF input files are. + character(len=200) :: mesg + + type(EOS_type), pointer :: eos => NULL() + type(thermo_var_ptrs) :: tv_loc ! A temporary thermo_var container + type(verticalGrid_type) :: GV_loc ! A temporary vertical grid structure + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_initialize_layers_from_Z" ! This module's name. + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: is, ie, js, je, nz ! compute domain indices + integer :: isg, ieg, jsg, jeg ! global extent + integer :: isd, ied, jsd, jed ! data domain indices + + integer :: i, j, k, ks + integer :: nkml ! The number of layers in the mixed layer. + + integer :: inconsistent ! The total number of cells with in consistent topography and layer thicknesses. + integer :: kd ! The number of levels in the input data + integer :: nkd ! number of levels to use for regridding input arrays + real :: eps_Z ! A negligibly thin layer thickness [Z ~> m]. + real :: eps_rho ! A negligibly small density difference [R ~> kg m-3]. + real :: PI_180 ! for conversion from degrees to radians [radian degree-1] + real :: Hmix_default ! The default initial mixed layer depth [Z ~> m]. + real :: Hmix_depth ! The mixed layer depth in the initial condition [Z ~> m]. + real :: missing_value_temp ! The missing value in the input temperature field [C ~> degC] + real :: missing_value_salt ! The missing value in the input salinity field [S ~> ppt] + real :: tol_temp ! The tolerance for changes in temperature during the horizontal + ! interpolation from an input dataset [C ~> degC] + real :: tol_sal ! The tolerance for changes in salinity during the horizontal + ! interpolation from an input dataset [S ~> ppt] + logical :: correct_thickness ! If true, correct the column thicknesses to match the topography + real :: h_tolerance ! A parameter that controls the tolerance when adjusting the + ! thickness to fit the bathymetry [Z ~> m]. + real :: tol_dz_bot ! A tolerance for detecting inconsistent bottom depths when + ! correct_thickness is false [Z ~> m] + character(len=40) :: potemp_var, salin_var + + integer, parameter :: niter=10 ! number of iterations for t/s adjustment to layer density + logical :: adjust_temperature = .true. ! fit t/s to target densities + real :: temp_land_fill ! A temperature value to use for land points [C ~> degC] + real :: salt_land_fill ! A salinity value to use for land points [C ~> degC] + + ! data arrays + real, dimension(:), allocatable :: z_edges_in ! Input data interface heights or depths [Z ~> m] + real, dimension(:), allocatable :: z_in ! Input data cell heights or depths [Z ~> m] + real, dimension(:), allocatable :: Rb ! Interface densities [R ~> kg m-3] + real, dimension(:,:,:), allocatable, target :: temp_z ! Input temperatures [C ~> degC] + real, dimension(:,:,:), allocatable, target :: salt_z ! Input salinities [S ~> 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),SZK_(GV)) :: dz ! Layer thicknesses in height units [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 ! 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 ! Input temperatures on a model-sized grid [C ~> degC] + real, dimension(:,:,:), allocatable, target :: tmpS1dIn ! Input salinities on a model-sized grid [S ~> ppt] + real, dimension(:,:,:), allocatable :: tmp_mask_in ! The valid data mask on a model-sized grid [nondim] + real, dimension(:,:,:), allocatable :: dz1 ! Input grid thicknesses in depth units [Z ~> m] + real, dimension(:,:,:), allocatable :: h1 ! Thicknesses on the input grid [H ~> m or kg m-2]. + real, dimension(:,:,:), allocatable :: dz_interface ! Change in position of interface due to + ! regridding [H ~> m or kg m-2] + real :: dz_neglect ! A negligibly small vertical layer extent used in + ! remapping cell reconstructions [Z ~> m] + real :: dz_neglect_edge ! A negligibly small vertical layer extent used in + ! remapping edge value calculations [Z ~> m] + real :: zTopOfCell, zBottomOfCell ! Heights in Z units [Z ~> m]. + type(regridding_CS) :: regridCS ! Regridding parameters and work arrays + type(remapping_CS) :: remapCS ! Remapping parameters and work arrays + + logical :: homogenize, useALEremapping, remap_full_column, remap_general, remap_old_alg + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use + ! for remapping. Values below 20190101 recover the remapping + ! answers from 2018, while higher values use more robust + ! forms of the same remapping expressions. + integer :: hor_regrid_answer_date ! The vintage of the order of arithmetic and expressions to use + ! for horizontal regridding. Values below 20190101 recover the + ! answers from 2018, while higher values use expressions that have + ! been rearranged for rotational invariance. + 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 + ! extrapolating the densities at the bottom of unstable profiles + ! from data when finding the initial interface locations in + ! layered mode from a dataset of T and S. + character(len=64) :: remappingScheme + real :: tempAvg ! Spatially averaged temperatures on a layer [C ~> degC] + real :: saltAvg ! Spatially averaged salinities on a layer [S ~> ppt] + logical :: do_conv_adj, ignore + integer :: nPoints + integer :: id_clock_routine, id_clock_ALE + + id_clock_routine = cpu_clock_id('(Initialize from Z)', grain=CLOCK_ROUTINE) + id_clock_ALE = cpu_clock_id('(Initialize from Z) ALE', grain=CLOCK_LOOP) + + call cpu_clock_begin(id_clock_routine) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isg = G%isg ; ieg = G%ieg ; jsg = G%jsg ; jeg = G%jeg + + PI_180=atan(1.0)/45. + + if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + if (.not.just_read) call log_version(PF, mdl, version, "") + + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + eos => tv%eqn_of_state + + 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 "//& + "in the same file, TEMP_Z_INIT_FILE and SALT_Z_INIT_FILE "//& + "must be set.", default="temp_salt_z.nc", do_not_log=just_read) + call get_param(PF, mdl, "TEMP_Z_INIT_FILE", tfilename, & + "The name of the z-space input file used to initialize "//& + "temperatures, only.", default=trim(filename), do_not_log=just_read) + call get_param(PF, mdl, "SALT_Z_INIT_FILE", sfilename, & + "The name of the z-space input file used to initialize "//& + "temperatures, only.", default=trim(filename), do_not_log=just_read) + filename = trim(inputdir)//trim(filename) + tfilename = trim(inputdir)//trim(tfilename) + sfilename = trim(inputdir)//trim(sfilename) + call get_param(PF, mdl, "Z_INIT_FILE_PTEMP_VAR", potemp_var, & + "The name of the potential temperature variable in "//& + "TEMP_Z_INIT_FILE.", default="ptemp", do_not_log=just_read) + call get_param(PF, mdl, "Z_INIT_FILE_SALT_VAR", salin_var, & + "The name of the salinity variable in "//& + "SALT_Z_INIT_FILE.", default="salt", do_not_log=just_read) + call get_param(PF, mdl, "Z_INIT_HOMOGENIZE", homogenize, & + "If True, then horizontally homogenize the interpolated "//& + "initial conditions.", default=.false., do_not_log=just_read) + call get_param(PF, mdl, "Z_INIT_ALE_REMAPPING", useALEremapping, & + "If True, then remap straight to model coordinate from file.", & + default=.false., do_not_log=just_read) + call get_param(PF, mdl, "Z_INIT_REMAPPING_SCHEME", remappingScheme, & + "The remapping scheme to use if using Z_INIT_ALE_REMAPPING "//& + "is True.", default="PPM_IH4", do_not_log=just_read) + call get_param(PF, mdl, "Z_INIT_REMAP_GENERAL", remap_general, & + "If false, only initializes to z* coordinates. "//& + "If true, allows initialization directly to general coordinates.", & + default=.not.(GV%Boussinesq.or.GV%semi_Boussinesq) , do_not_log=just_read) + call get_param(PF, mdl, "Z_INIT_REMAP_FULL_COLUMN", remap_full_column, & + "If false, only reconstructs profiles for valid data points. "//& + "If true, inserts vanished layers below the valid data.", & + default=remap_general, do_not_log=just_read) + call get_param(PF, mdl, "Z_INIT_REMAP_OLD_ALG", remap_old_alg, & + "If false, uses the preferred remapping algorithm for initialization. "//& + "If true, use an older, less robust algorithm for remapping.", & + default=.false., do_not_log=just_read) + call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=just_read) + call get_param(PF, mdl, "TEMP_SALT_INIT_VERTICAL_REMAP_ONLY", pre_gridded, & + "If true, initial conditions are on the model horizontal grid. " //& + "Extrapolation over missing ocean values is done using an ICE-9 "//& + "procedure with vertical ALE remapping .", & + default=.false., do_not_log=just_read) + if (useALEremapping) then + call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) + endif + call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & + "The vintage of the order of arithmetic for horizontal regridding. "//& + "Dates before 20190101 give the same answers as the code did in late 2018, "//& + "while later versions add parentheses for rotational symmetry. "//& + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + if (.not.GV%Boussinesq) hor_regrid_answer_date = max(hor_regrid_answer_date, 20230701) + + if (.not.useALEremapping) then + call get_param(PF, mdl, "ADJUST_THICKNESS", correct_thickness, & + "If true, all mass below the bottom removed if the "//& + "topography is shallower than the thickness input file "//& + "would indicate.", default=.false., do_not_log=just_read) + call get_param(PF, mdl, "THICKNESS_TOLERANCE", h_tolerance, & + "A parameter that controls the tolerance when adjusting the "//& + "thickness to fit the bathymetry. Used when ADJUST_THICKNESS=True.", & + units="m", default=0.1, scale=US%m_to_Z, & + do_not_log=(just_read.or..not.correct_thickness)) + call get_param(PF, mdl, "DZ_BOTTOM_TOLERANCE", tol_dz_bot, & + "A tolerance for detecting inconsistent topography and input layer "//& + "thicknesses when ADJUST_THICKNESS is false.", & + units="m", default=1.0, scale=US%m_to_Z, & + do_not_log=(just_read.or.correct_thickness)) + + call get_param(PF, mdl, "FIT_TO_TARGET_DENSITY_IC", adjust_temperature, & + "If true, all the interior layers are adjusted to "//& + "their target densities using mostly temperature "//& + "This approach can be problematic, particularly in the "//& + "high latitudes.", default=.true., do_not_log=just_read) + call get_param(PF, mdl, "Z_INIT_SEPARATE_MIXED_LAYER", separate_mixed_layer, & + "If true, distribute the topmost Z_INIT_HMIX_DEPTH of water over NKML layers, "//& + "and do not correct the density of the topmost NKML+NKBL layers. Otherwise "//& + "all layers are initialized based on the depths of their target densities.", & + default=.false., do_not_log=just_read.or.(GV%nkml==0)) + if (GV%nkml == 0) separate_mixed_layer = .false. + call get_param(PF, mdl, "MINIMUM_DEPTH", Hmix_default, & + units="m", default=0.0, scale=US%m_to_Z) + call get_param(PF, mdl, "Z_INIT_HMIX_DEPTH", Hmix_depth, & + "The mixed layer depth in the initial conditions when Z_INIT_SEPARATE_MIXED_LAYER "//& + "is set to true.", units="m", default=US%Z_to_m*Hmix_default, scale=US%m_to_Z, & + do_not_log=(just_read .or. .not.separate_mixed_layer)) + ! Reusing MINIMUM_DEPTH for the default mixed layer depth may be a strange choice, but + ! it reproduces previous answers. + call get_param(PF, mdl, "DENSITY_INTERP_TOLERANCE", eps_rho, & + "A small density tolerance used when finding depths in a density profile.", & + units="kg m-3", default=1.0e-10, scale=US%kg_m3_to_R, & + do_not_log=useALEremapping.or.just_read) + call get_param(PF, mdl, "LAYER_Z_INIT_IC_EXTRAP_BUG", density_extrap_bug, & + "If true use an expression with a vertical indexing bug for extrapolating the "//& + "densities at the bottom of unstable profiles from data when finding the "//& + "initial interface locations in layered mode from a dataset of T and S.", & + default=.false., do_not_log=just_read) + endif + call get_param(PF, mdl, "LAND_FILL_TEMP", temp_land_fill, & + "A value to use to fill in ocean temperatures on land points.", & + units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "LAND_FILL_SALIN", salt_land_fill, & + "A value to use to fill in ocean salinities on land points.", & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(PF, mdl, "HORIZ_INTERP_TOL_TEMP", tol_temp, & + "The tolerance in temperature changes between iterations when interpolating "//& + "from an input dataset using horiz_interp_and_extrap_tracer. This routine "//& + "converges slowly, so an overly small tolerance can get expensive.", & + units="degC", default=1.0e-3, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "HORIZ_INTERP_TOL_SALIN", tol_sal, & + "The tolerance in salinity changes between iterations when interpolating "//& + "from an input dataset using horiz_interp_and_extrap_tracer. This routine "//& + "converges slowly, so an overly small tolerance can get expensive.", & + units="ppt", default=1.0e-3, scale=US%ppt_to_S, do_not_log=just_read) + + if (just_read) then + if ((.not.useALEremapping) .and. adjust_temperature) & + ! This call is just here to read and log the determine_temperature parameters + call determine_temperature(tv%T, tv%S, GV%Rlay(1:nz), eos, tv%P_Ref, 0, & + 0, G, GV, US, PF, just_read=.true.) + call cpu_clock_end(id_clock_routine) + return ! All run-time parameters have been read, so return. + endif + + eps_z = GV%Angstrom_Z + + ! Read input grid coordinates for temperature and salinity field + ! in z-coordinate dataset. The file is REQUIRED to contain the + ! following: + ! + ! dimension variables: + ! lon (degrees_E), lat (degrees_N), depth(meters) + ! variables: + ! ptemp(lon,lat,depth) : degC, potential temperature + ! salt (lon,lat,depth) : ppt, salinity + ! + ! The first record will be read if there are multiple time levels. + ! The observation grid MUST tile the model grid. If the model grid extends + ! to the North/South Pole past the limits of the input data, they are extrapolated using the average + ! value at the northernmost/southernmost latitude. + + call horiz_interp_and_extrap_tracer(tfilename, potemp_var, 1, & + G, temp_z, mask_z, z_in, z_edges_in, missing_value_temp, & + scale=US%degC_to_C, homogenize=homogenize, m_to_Z=US%m_to_Z, & + answer_date=hor_regrid_answer_date, ongrid=pre_gridded, tr_iter_tol=tol_temp) + + call horiz_interp_and_extrap_tracer(sfilename, salin_var, 1, & + G, salt_z, mask_z, z_in, z_edges_in, missing_value_salt, & + scale=US%ppt_to_S, homogenize=homogenize, m_to_Z=US%m_to_Z, & + answer_date=hor_regrid_answer_date, ongrid=pre_gridded, tr_iter_tol=tol_sal) + + kd = size(z_in,1) + + ! Convert the sign convention of Z_edges_in. + do k=1,size(Z_edges_in,1) ; Z_edges_in(k) = -Z_edges_in(k) ; enddo + + ! Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 or NEMO + call convert_temp_salt_for_TEOS10(temp_z, salt_z, G%HI, kd, mask_z, eos) + + do j=js,je ; do i=is,ie + Z_bottom(i,j) = -depth_tot(i,j) + enddo ; enddo + + ! Done with horizontal interpolation. + ! Now remap to model coordinates + if (useALEremapping) then + call cpu_clock_begin(id_clock_ALE) + nkd = max(GV%ke, kd) + + ! Build the source grid and copy data onto model-shaped arrays with vanished layers + allocate( tmp_mask_in(isd:ied,jsd:jed,nkd), source=0.0 ) + allocate( dz1(isd:ied,jsd:jed,nkd), source=0.0 ) + allocate( h1(isd:ied,jsd:jed,nkd), source=0.0 ) + allocate( tmpT1dIn(isd:ied,jsd:jed,nkd), source=0.0 ) + allocate( tmpS1dIn(isd:ied,jsd:jed,nkd), source=0.0 ) + do j = js, je ; do i = is, ie + if (G%mask2dT(i,j) > 0.) then + zTopOfCell = 0. ; zBottomOfCell = 0. + tmp_mask_in(i,j,1:kd) = mask_z(i,j,:) + do k = 1, nkd + if ((tmp_mask_in(i,j,k) > 0.) .and. (k <= kd)) then + zBottomOfCell = max( z_edges_in(k+1), Z_bottom(i,j)) + tmpT1dIn(i,j,k) = temp_z(i,j,k) + tmpS1dIn(i,j,k) = salt_z(i,j,k) + elseif (k>1) then + zBottomOfCell = Z_bottom(i,j) + tmpT1dIn(i,j,k) = tmpT1dIn(i,j,k-1) + tmpS1dIn(i,j,k) = tmpS1dIn(i,j,k-1) + else ! This next block should only ever be reached over land + tmpT1dIn(i,j,k) = temp_land_fill + tmpS1dIn(i,j,k) = salt_land_fill + endif + dz1(i,j,k) = (zTopOfCell - zBottomOfCell) + zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k + enddo + dz1(i,j,kd) = dz1(i,j,kd) + max(0., zTopOfCell - Z_bottom(i,j) ) + ! The max here is in case the data data is shallower than model + endif ! mask2dT + enddo ; enddo + deallocate( tmp_mask_in ) + + ! Convert input thicknesses to units of H. In non-Boussinesq mode this is done by inverting + ! integrals of specific volume in pressure, so it can be expensive. + tv_loc = tv + tv_loc%T => tmpT1dIn + tv_loc%S => tmpS1dIn + GV_loc = GV + GV_loc%ke = nkd + call dz_to_thickness(dz1, tv_loc, h1, G, GV_loc, US) + + ! Build the target grid (and set the model thickness to it) + + call ALE_initRegridding( GV, US, G%max_depth, PF, mdl, regridCS ) ! sets regridCS + call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false., answer_date=remap_answer_date ) + + ! Now remap from source grid to target grid, first setting reconstruction parameters + if (remap_general) then + call set_regrid_params( regridCS, min_thickness=0. ) + allocate( dz_interface(isd:ied,jsd:jed,nkd+1) ) ! Need for argument to regridding_main() but is not used + + 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, US, h1, tv_loc, h, dz_interface, & + frac_shelf_h=frac_shelf_h ) + + deallocate( dz_interface ) + + call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, & + old_remap=remap_old_alg, answer_date=remap_answer_date ) + call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpS1dIn, h, tv%S, all_cells=remap_full_column, & + old_remap=remap_old_alg, answer_date=remap_answer_date ) + else + ! This is the old way of initializing to z* coordinates only + allocate( hTarget(nz) ) + hTarget = getCoordinateResolution( regridCS ) + do j = js, je ; do i = is, ie + dz(i,j,:) = 0. + if (G%mask2dT(i,j) > 0.) then + ! Build the target grid combining hTarget and topography + zTopOfCell = 0. ; zBottomOfCell = 0. + do k = 1, nz + zBottomOfCell = max( zTopOfCell - hTarget(k), Z_bottom(i,j)) + dz(i,j,k) = zTopOfCell - zBottomOfCell + zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k + enddo + else + dz(i,j,:) = 0. + endif ! mask2dT + enddo ; enddo + deallocate( hTarget ) + + dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) + call ALE_remap_scalar(remapCS, G, GV, nkd, dz1, tmpT1dIn, dz, tv%T, all_cells=remap_full_column, & + old_remap=remap_old_alg, answer_date=remap_answer_date, & + H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) + call ALE_remap_scalar(remapCS, G, GV, nkd, dz1, tmpS1dIn, dz, tv%S, all_cells=remap_full_column, & + old_remap=remap_old_alg, answer_date=remap_answer_date, & + H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + ! This is a simple conversion of the target grid to thickness units that is not + ! appropriate in non-Boussinesq mode. + call dz_to_thickness_simple(dz, h, G, GV, US) + else + ! Convert dz into thicknesses in units of H using the equation of state as appropriate. + call dz_to_thickness(dz, tv, h, G, GV, US) + endif + endif + + deallocate( dz1 ) + deallocate( h1 ) + deallocate( tmpT1dIn ) + deallocate( tmpS1dIn ) + + call cpu_clock_end(id_clock_ALE) + + else ! remap to isopycnal layer space + + ! Next find interface positions using local arrays + ! nlevs contains the number of valid data points in each column + nlevs = int(sum(mask_z,dim=3)) + + ! Rb contains the layer interface densities + allocate(Rb(nz+1)) + do k=2,nz ; Rb(k) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo + Rb(1) = 0.0 + if (nz>1) then + Rb(nz+1) = 2.0*GV%Rlay(nz) - GV%Rlay(nz-1) + else + Rb(nz+1) = 2.0 * GV%Rlay(1) + endif + + nkml = 0 ; if (separate_mixed_layer) nkml = GV%nkml + + press(:) = tv%P_Ref + EOSdom(:) = EOS_domain(G%HI) + allocate(rho_z(isd:ied,jsd:jed,kd)) + do k=1,kd ; do j=js,je + call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), eos, EOSdom) + enddo ; enddo + + call find_interfaces(rho_z, z_in, kd, Rb, Z_bottom, zi, G, GV, US, nlevs, nkml, & + Hmix_depth, eps_z, eps_rho, density_extrap_bug) + + deallocate(rho_z) + + dz(:,:,:) = 0.0 + if (correct_thickness) then + call adjustEtaToFitBathymetry(G, GV, US, zi, dz, h_tolerance, dZ_ref_eta=G%Z_ref) + else + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + if (zi(i,j,K) < (zi(i,j,K+1) + GV%Angstrom_Z)) then + zi(i,j,K) = zi(i,j,K+1) + GV%Angstrom_Z + dz(i,j,k) = GV%Angstrom_Z + else + dz(i,j,k) = zi(i,j,K) - zi(i,j,K+1) + endif + enddo ; enddo ; enddo + inconsistent = 0 + do j=js,je ; do i=is,ie + if (abs(zi(i,j,nz+1) - Z_bottom(i,j)) > tol_dz_bot) & + inconsistent = inconsistent + 1 + enddo ; enddo + call sum_across_PEs(inconsistent) + + if ((inconsistent > 0) .and. (is_root_pe())) then + write(mesg, '("Thickness initial conditions are inconsistent ",'// & + '"with topography in ",I5," places.")') inconsistent + call MOM_error(WARNING, mesg) + endif + endif + + call tracer_z_init_array(temp_z, z_edges_in, kd, zi, temp_land_fill, G, nz, nlevs, eps_z, tv%T) + call tracer_z_init_array(salt_z, z_edges_in, kd, zi, salt_land_fill, G, nz, nlevs, eps_z, tv%S) + + if (homogenize) then + ! Horizontally homogenize data to produce perfectly "flat" initial conditions + do k=1,nz + call homogenize_field(tv%T(:,:,k), G%mask2dT, G, scale=US%degC_to_C, answer_date=hor_regrid_answer_date) + call homogenize_field(tv%S(:,:,k), G%mask2dT, G, scale=US%ppt_to_S, answer_date=hor_regrid_answer_date) + enddo + endif + + if (adjust_temperature) then + ! Finally adjust to target density + ks = 1 ; if (separate_mixed_layer) ks = GV%nk_rho_varies + 1 + call determine_temperature(tv%T, tv%S, GV%Rlay(1:nz), eos, tv%P_Ref, niter, & + ks, G, GV, US, PF, just_read) + endif + + ! Now convert dz into thicknesses in units of H. + call dz_to_thickness(dz, tv, h, G, GV, US) + + endif ! useALEremapping + + deallocate(z_in, z_edges_in, temp_z, salt_z, mask_z) + + call pass_var(h, G%Domain) + call pass_var(tv%T, G%Domain) + call pass_var(tv%S, G%Domain) + + call callTree_leave(trim(mdl)//'()') + call cpu_clock_end(id_clock_routine) + +end subroutine MOM_temp_salt_initialize_from_Z + + +!> Find interface positions corresponding to interpolated depths in a density profile +subroutine find_interfaces(rho, zin, nk_data, Rb, Z_bot, zi, G, GV, US, nlevs, nkml, hml, & + eps_z, eps_rho, density_extrap_bug) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: nk_data !< The number of levels in the input data + real, dimension(SZI_(G),SZJ_(G),nk_data), & + intent(in) :: rho !< Potential density in z-space [R ~> kg m-3] + real, dimension(nk_data), intent(in) :: zin !< Input data levels [Z ~> m]. + real, dimension(SZK_(GV)+1), intent(in) :: Rb !< target interface densities [R ~> kg m-3] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: Z_bot !< The (usually negative) height of the seafloor + !! relative to the surface [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(out) :: zi !< The returned interface heights [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: nlevs !< number of valid points in each column + integer, intent(in) :: nkml !< number of mixed layer pieces to distribute over + !! a depth of hml. + real, intent(in) :: hml !< mixed layer depth [Z ~> m]. + real, intent(in) :: eps_z !< A negligibly small layer thickness [Z ~> m]. + real, intent(in) :: eps_rho !< A negligibly small density difference [R ~> kg m-3]. + logical, intent(in) :: density_extrap_bug !< If true use an expression with an + !! indexing bug for projecting the densities at + !! the bottom of unstable profiles from data when + !! finding the initial interface locations in + !! layered mode from a dataset of T and S. + + ! Local variables + real, dimension(nk_data) :: rho_ ! A column of densities [R ~> kg m-3] + real, dimension(SZK_(GV)+1) :: zi_ ! A column interface heights (negative downward) [Z ~> m]. + real :: slope ! The rate of change of height with density [Z R-1 ~> m4 kg-1] + real :: drhodz ! A local vertical density gradient [R Z-1 ~> kg m-4] + real, parameter :: zoff = 0.999 ! A small fractional adjustment to the density differences [nondim] + logical :: unstable ! True if the column is statically unstable anywhere. + integer :: nlevs_data ! The number of data values in a column. + logical :: work_down ! This indicates whether this pass goes up or down the water column. + integer :: k_int, lo_int, hi_int, mid + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + zi(:,:,:) = 0.0 + + do j=js,je ; do i=is,ie + nlevs_data = nlevs(i,j) + do k=1,nlevs_data ; rho_(k) = rho(i,j,k) ; enddo + + unstable = .true. + work_down = .true. + do while (unstable) + ! Modify the input profile until it no longer has densities that decrease with depth. + unstable = .false. + if (work_down) then + do k=2,nlevs_data-1 ; if (rho_(k) - rho_(k-1) < 0.0) then + if (k == 2) then + rho_(k-1) = rho_(k) - eps_rho + else + drhodz = (rho_(k+1)-rho_(k-1)) / (zin(k+1)-zin(k-1)) + if (drhodz < 0.0) unstable = .true. + rho_(k) = rho_(k-1) + drhodz*zoff*(zin(k)-zin(k-1)) + endif + endif ; enddo + work_down = .false. + else + do k=nlevs_data-1,2,-1 ; if (rho_(k+1) - rho_(k) < 0.0) then + if (k == nlevs_data-1) then + if (density_extrap_bug) then + rho_(k+1) = rho_(k-1) + eps_rho + else + rho_(k+1) = rho_(k) + eps_rho + endif + else + drhodz = (rho_(k+1)-rho_(k-1)) / (zin(k+1)-zin(k-1)) + if (drhodz < 0.0) unstable = .true. + rho_(k) = rho_(k+1) - drhodz*(zin(k+1)-zin(k)) + endif + endif ; enddo + work_down = .true. + endif + enddo + + ! Find and store the interface depths. + zi_(1) = 0.0 + if (nlevs_data < 1) then + ! There is no data to use, so set the interfaces at the bottom. + do K=2,nz ; zi_(K) = Z_bot(i,j) ; enddo + elseif (nlevs_data == 1) then + ! There is data for only one input layer, so set the interfaces at the bottom or top, + ! depending on how their target densities compare with the one data point. + do K=2,nz + if (Rb(K) < rho_(1)) then ; zi_(K) = 0.0 + else ; zi_(K) = Z_bot(i,j) ; endif + enddo + else + do K=2,nz + ! Find the value of k_int in the list of rho_ where rho_(k_int) <= Rb(K) < rho_(k_int+1). + ! This might be made a little faster by exploiting the fact that Rb is + ! monotonically increasing and not resetting lo_int back to 1 inside the K loop. + lo_int = 1 ; hi_int = nlevs_data + do while (lo_int < hi_int) + mid = (lo_int+hi_int) / 2 + if (Rb(K) < rho_(mid)) then ; hi_int = mid + else ; lo_int = mid+1 ; endif + enddo + k_int = max(1, lo_int-1) + + ! Linearly interpolate to find the depth, zi_, where Rb would be found. + slope = (zin(k_int+1) - zin(k_int)) / max(rho_(k_int+1) - rho_(k_int), eps_rho) + zi_(K) = -1.0*(zin(k_int) + slope*(Rb(K)-rho_(k_int))) + zi_(K) = min(max(zi_(K), Z_bot(i,j)), -1.0*hml) + enddo + endif + zi_(nz+1) = Z_bot(i,j) + if (nkml > 0) then ; do K=2,nkml+1 + zi_(K) = max(hml*((1.0-real(K))/real(nkml)), Z_bot(i,j)) + enddo ; endif + do K=nz,max(nkml+2,2),-1 + if (zi_(K) < zi_(K+1) + eps_Z) zi_(K) = zi_(K+1) + eps_Z + if (zi_(K) > -1.0*hml) zi_(K) = max(-1.0*hml, Z_bot(i,j)) + enddo + + do K=1,nz+1 + zi(i,j,K) = zi_(K) + enddo + enddo ; enddo ! i- and j- loops + +end subroutine find_interfaces + +!> Run simple unit tests +subroutine MOM_state_init_tests(G, GV, US, tv) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + + ! Local variables + integer, parameter :: nk=5 + real, dimension(nk) :: T, T_t, T_b ! Temperatures [C ~> degC] + real, dimension(nk) :: S, S_t, S_b ! Salinities [S ~> ppt] + real, dimension(nk) :: rho ! Layer density [R ~> kg m-3] + real, dimension(nk) :: h ! Layer thicknesses [H ~> m or kg m-2] + real, dimension(nk) :: z ! Height of layer center [Z ~> m] + real, dimension(nk+1) :: e ! Interface heights [Z ~> m] + real :: T_ref ! A reference temperature [C ~> degC] + real :: S_ref ! A reference salinity [S ~> ppt] + real :: P_tot, P_t, P_b ! Pressures [R L2 T-2 ~> Pa] + real :: z_out ! Output height [Z ~> m] + real :: I_z_scale ! The inverse of the height scale for prescribed gradients [Z-1 ~> m-1] + real :: z_tol ! The tolerance with which to find the depth matching a specified pressure [Z ~> m]. + integer :: k + type(remapping_CS), pointer :: remap_CS => NULL() + + I_z_scale = 1.0 / (500.0*US%m_to_Z) + do k = 1, nk + h(k) = 100.0*GV%m_to_H + enddo + e(1) = 0. + do K = 1, nk + e(K+1) = e(K) - GV%H_to_Z * h(k) + enddo + P_tot = 0. + T_ref = 20.0*US%degC_to_C + S_ref = 35.0*US%ppt_to_S + z_tol = 1.0e-5*US%m_to_Z + do k = 1, nk + z(k) = 0.5 * ( e(K) + e(K+1) ) + T_t(k) = T_ref + (0. * I_z_scale) * e(k) + T(k) = T_ref + (0. * I_z_scale)*z(k) + T_b(k) = T_ref + (0. * I_z_scale)*e(k+1) + S_t(k) = S_ref - (0. * I_z_scale)*e(k) + S(k) = S_ref + (0. * I_z_scale)*z(k) + S_b(k) = S_ref - (0. * I_z_scale)*e(k+1) + call calculate_density(0.5*(T_t(k)+T_b(k)), 0.5*(S_t(k)+S_b(k)), -GV%Rho0*GV%g_Earth*z(k), & + rho(k), tv%eqn_of_state) + P_tot = P_tot + GV%g_Earth * rho(k) * GV%H_to_Z*h(k) + enddo + + P_t = 0. + do k = 1, nk + call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), P_t, 0.5*P_tot, & + GV%Rho0, GV%g_Earth, tv%eqn_of_state, US, P_b, z_out, z_tol=z_tol) + write(0,*) k, US%RL2_T2_to_Pa*P_t, US%RL2_T2_to_Pa*P_b, 0.5*US%RL2_T2_to_Pa*P_tot, & + US%Z_to_m*e(K), US%Z_to_m*e(K+1), US%Z_to_m*z_out + P_t = P_b + enddo + write(0,*) US%RL2_T2_to_Pa*P_b, US%RL2_T2_to_Pa*P_tot + + write(0,*) '' + write(0,*) ' ==================================================================== ' + write(0,*) '' + write(0,*) GV%H_to_m*h(:) + call cut_off_column_top(nk, tv, GV, US, GV%g_Earth, -e(nk+1), GV%Angstrom_H, & + T, T_t, T_b, S, S_t, S_b, 0.5*P_tot, h, remap_CS, z_tol=z_tol) + write(0,*) GV%H_to_m*h(:) + +end subroutine MOM_state_init_tests + +end module MOM_state_initialization diff --git a/initialization/MOM_tracer_initialization_from_Z.F90 b/initialization/MOM_tracer_initialization_from_Z.F90 new file mode 100644 index 0000000000..d28a925c03 --- /dev/null +++ b/initialization/MOM_tracer_initialization_from_Z.F90 @@ -0,0 +1,237 @@ +!> Initializes hydrography from z-coordinate climatology files +module MOM_tracer_initialization_from_Z + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : hchksum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP +use MOM_domains, only : pass_var +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, param_file_type, log_version +use MOM_grid, only : ocean_grid_type +use MOM_horizontal_regridding, only : myStats, horiz_interp_and_extrap_tracer +use MOM_interface_heights, only : dz_to_thickness_simple +use MOM_regridding, only : set_dz_neglect +use MOM_remapping, only : remapping_CS, initialize_remapping +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_ALE, only : ALE_remap_scalar + +implicit none ; private + +#include + +public :: MOM_initialize_tracer_from_Z + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +character(len=40) :: mdl = "MOM_tracer_initialization_from_Z" !< This module's name. + +contains + +!> Initializes a tracer from a z-space data file, including any lateral regridding that is needed. +subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_nam, & + src_var_unit_conversion, src_var_record, homogenize, & + useALEremapping, remappingScheme, src_var_gridspec, h_in_Z_units ) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses, in [H ~> m or kg m-2] or + !! [Z ~> m] depending on the value of h_in_Z_units. + real, dimension(:,:,:), pointer :: tr !< Pointer to array to be initialized [CU ~> conc] + type(param_file_type), intent(in) :: PF !< parameter file + character(len=*), intent(in) :: src_file !< source filename + character(len=*), intent(in) :: src_var_nam !< variable name in file + real, optional, intent(in) :: src_var_unit_conversion !< optional multiplicative unit conversion, + !! often used for rescaling into model units [CU conc-1 ~> 1] + integer, optional, intent(in) :: src_var_record !< record to read for multiple time-level files + logical, optional, intent(in) :: homogenize !< optionally homogenize to mean value + logical, optional, intent(in) :: useALEremapping !< to remap or not (optional) + character(len=*), optional, intent(in) :: remappingScheme !< remapping scheme to use. + character(len=*), optional, intent(in) :: src_var_gridspec !< Source variable name in a gridspec file. + !! This is not implemented yet. + logical, optional, intent(in) :: h_in_Z_units !< If present and true, the input grid + !! thicknesses are in the units of height + !! ([Z ~> m]) instead of the usual units of + !! thicknesses ([H ~> m or kg m-2]) + + ! Local variables + real :: land_fill = 0.0 ! A value to use to replace missing values [CU ~> conc] + real :: convert ! A conversion factor into the model's internal units [CU conc-1 ~> 1] + integer :: recnum + character(len=64) :: remapScheme + logical :: homog, useALE + logical :: h_is_in_Z_units + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_initialize_tracers_from_Z" ! This module's name. + + integer :: is, ie, js, je, nz ! compute domain indices + integer :: isd, ied, jsd, jed ! data domain indices + integer :: i, j, k, kd + real, allocatable, dimension(:,:,:), target :: tr_z ! Tracer array on the horizontal model grid + ! and input-file vertical levels [CU ~> conc] + real, allocatable, dimension(:,:,:), target :: mask_z ! Missing value mask on the horizontal model grid + ! and input-file vertical levels [nondim] + real, allocatable, dimension(:), target :: z_edges_in ! Cell edge depths for input data [Z ~> m] + real, allocatable, dimension(:), target :: z_in ! Cell center depths for input data [Z ~> m] + + ! Local variables for ALE remapping + real, dimension(:,:,:), allocatable :: dzSrc ! Source thicknesses in height units [Z ~> m] + real, dimension(:,:,:), allocatable :: hSrc ! Source thicknesses [H ~> m or kg m-2] + real, dimension(:), allocatable :: h1 ! A 1-d column of source thicknesses [Z ~> m]. + real :: zTopOfCell, zBottomOfCell, z_bathy ! Heights [Z ~> m]. + type(remapping_CS) :: remapCS ! Remapping parameters and work arrays + type(verticalGrid_type) :: GV_loc ! A temporary vertical grid structure + + real :: missing_value ! A value indicating that there is no valid input data at this point [CU ~> conc] + real :: dz_neglect ! A negligibly small vertical layer extent used in + ! remapping cell reconstructions [Z ~> m] + real :: dz_neglect_edge ! A negligibly small vertical layer extent used in + ! remapping edge value calculations [Z ~> m] + integer :: nPoints ! The number of valid input data points in a column + integer :: id_clock_routine, id_clock_ALE + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use + ! for remapping. Values below 20190101 recover the remapping + ! answers from 2018, while higher values use more robust + ! forms of the same remapping expressions. + integer :: hor_regrid_answer_date ! The vintage of the order of arithmetic and expressions to use + ! for horizontal regridding. Values below 20190101 recover the + ! answers from 2018, while higher values use expressions that have + ! been rearranged for rotational invariance. + + id_clock_routine = cpu_clock_id('(Initialize tracer from Z)', grain=CLOCK_ROUTINE) + id_clock_ALE = cpu_clock_id('(Initialize tracer from Z) ALE', grain=CLOCK_LOOP) + + call cpu_clock_begin(id_clock_routine) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + + call get_param(PF, mdl, "Z_INIT_HOMOGENIZE", homog, & + "If True, then horizontally homogenize the interpolated "//& + "initial conditions.", default=.false.) + call get_param(PF, mdl, "Z_INIT_ALE_REMAPPING", useALE, & + "If True, then remap straight to model coordinate from file.",& + default=.true.) + call get_param(PF, mdl, "Z_INIT_REMAPPING_SCHEME", remapScheme, & + "The remapping scheme to use if using Z_INIT_ALE_REMAPPING is True.", & + default="PLM") + call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + if (useALE) then + call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) + endif + call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & + "The vintage of the order of arithmetic for horizontal regridding. "//& + "Dates before 20190101 give the same answers as the code did in late 2018, "//& + "while later versions add parentheses for rotational symmetry. "//& + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) hor_regrid_answer_date = max(hor_regrid_answer_date, 20230701) + + if (PRESENT(homogenize)) homog=homogenize + if (PRESENT(useALEremapping)) useALE=useALEremapping + if (PRESENT(remappingScheme)) remapScheme=remappingScheme + recnum = 1 + if (PRESENT(src_var_record)) recnum = src_var_record + convert = 1.0 + if (PRESENT(src_var_unit_conversion)) convert = src_var_unit_conversion + + h_is_in_Z_units = .false. ; if (present(h_in_Z_units)) h_is_in_Z_units = h_in_Z_units + + call horiz_interp_and_extrap_tracer(src_file, src_var_nam, recnum, & + G, tr_z, mask_z, z_in, z_edges_in, missing_value, & + scale=convert, homogenize=homog, m_to_Z=US%m_to_Z, answer_date=hor_regrid_answer_date) + + kd = size(z_edges_in,1)-1 + call pass_var(tr_z,G%Domain) + call pass_var(mask_z,G%Domain) + +! Done with horizontal interpolation. +! Now remap to model coordinates + if (useALE) then + call cpu_clock_begin(id_clock_ALE) + ! First we reserve a work space for reconstructions of the source data + allocate( h1(kd) ) + allocate( dzSrc(isd:ied,jsd:jed,kd) ) + allocate( hSrc(isd:ied,jsd:jed,kd) ) + ! Set parameters for reconstructions + call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false., answer_date=remap_answer_date ) + ! Next we initialize the regridding package so that it knows about the target grid + + do j = js, je ; do i = is, ie + if (G%mask2dT(i,j)>0.) then + ! Build the source grid + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 + z_bathy = G%bathyT(i,j) + G%Z_ref + do k = 1, kd + if (mask_z(i,j,k) > 0.) then + zBottomOfCell = -min( z_edges_in(k+1), z_bathy ) + elseif (k>1) then + zBottomOfCell = -z_bathy + endif + h1(k) = zTopOfCell - zBottomOfCell + if (h1(k)>0.) nPoints = nPoints + 1 + zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k + enddo + h1(kd) = h1(kd) + ( zTopOfCell + z_bathy ) ! In case data is deeper than model + else + tr(i,j,:) = 0. + endif ! mask2dT + dzSrc(i,j,:) = h1(:) + enddo ; enddo + + if (h_is_in_Z_units) then + dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) + call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false., answer_date=remap_answer_date, & + H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) + else + ! Equation of state data is not available, so a simpler rescaling will have to suffice, + ! but it might be problematic in non-Boussinesq mode. + GV_loc = GV ; GV_loc%ke = kd + call dz_to_thickness_simple(dzSrc, hSrc, G, GV_loc, US) + + call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false., answer_date=remap_answer_date ) + endif + + deallocate( hSrc ) + deallocate( dzSrc ) + deallocate( h1 ) + + do k=1,nz + call myStats(tr(:,:,k), missing_value, G, k, 'Tracer from ALE()') + enddo + call cpu_clock_end(id_clock_ALE) + endif ! useALEremapping + +! Fill land values + do k=1,nz ; do j=js,je ; do i=is,ie + if (tr(i,j,k) == missing_value) then + tr(i,j,k) = land_fill + endif + enddo ; enddo ; enddo + + call callTree_leave(trim(mdl)//'()') + call cpu_clock_end(id_clock_routine) + +end subroutine MOM_initialize_tracer_from_Z + +end module MOM_tracer_initialization_from_Z diff --git a/ocean_data_assim/MOM_oda_driver.F90 b/ocean_data_assim/MOM_oda_driver.F90 new file mode 100644 index 0000000000..875051b6c7 --- /dev/null +++ b/ocean_data_assim/MOM_oda_driver.F90 @@ -0,0 +1,802 @@ +!> Interfaces for MOM6 ensembles and data assimilation. +module MOM_oda_driver_mod + +! This file is part of MOM6. see LICENSE.md for the license. + +! MOM infrastructure +use MOM_coms, only : PE_here, num_PEs +use MOM_coms, only : set_PElist, set_rootPE, Get_PElist, broadcast +use MOM_domains, only : domain2d, global_field, get_domain_extent +use MOM_domains, only : pass_var, redistribute_array, broadcast_domain +use MOM_diag_mediator, only : register_diag_field, diag_axis_init, post_data +use MOM_diag_mediator, only : enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_update_remap_grids +use MOM_ensemble_manager, only : get_ensemble_id, get_ensemble_size +use MOM_ensemble_manager, only : get_ensemble_pelist, get_ensemble_filter_pelist +use MOM_error_handler, only : stdout, stdlog, MOM_error +use MOM_io, only : SINGLE_FILE +use MOM_interp_infra, only : init_extern_field, get_external_field_info +use MOM_interp_infra, only : time_interp_extern +use MOM_interpolate, only : external_field +use MOM_remapping, only : remappingSchemesDoc +use MOM_time_manager, only : time_type, real_to_time, get_date +use MOM_time_manager, only : operator(+), operator(>=), operator(/=) +use MOM_time_manager, only : operator(==), operator(<) +use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end, cpu_clock_id +use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer +! ODA Modules +use ocean_da_types_mod, only : grid_type, ocean_profile_type, ocean_control_struct +use ocean_da_core_mod, only : ocean_da_core_init, get_profiles +!This preprocessing directive enables the SPEAR online ensemble data assimilation +!configuration. Existing community based APIs for data assimilation are currently +!called offline for forecast applications using information read from a MOM6 state file. +!The SPEAR configuration (https://doi.org/10.1029/2020MS002149) calculated increments +!efficiently online. A community-based set of APIs should be implemented in place +!of the CPP directive when this is available. +#ifdef ENABLE_ECDA +use eakf_oda_mod, only : ensemble_filter +#endif +use kdtree, only : kd_root !# A kd-tree object using JEDI APIs +! MOM Modules +use MOM_io, only : slasher, MOM_read_data +use MOM_diag_mediator, only : diag_ctrl, set_axes_info +use MOM_error_handler, only : FATAL, WARNING, MOM_error, MOM_mesg, is_root_pe +use MOM_get_input, only : get_MOM_input, directories +use MOM_grid, only : ocean_grid_type, MOM_grid_init +use MOM_grid_initialize, only : set_grid_metrics +use MOM_hor_index, only : hor_index_type, hor_index_init +use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid +use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid +use MOM_fixed_initialization, only : MOM_initialize_fixed, MOM_initialize_topography +use MOM_coord_initialization, only : MOM_initialize_coord +use MOM_file_parser, only : read_param, get_param, param_file_type +use MOM_string_functions, only : lowercase +use MOM_ALE, only : ALE_CS, ALE_initThicknessToCoord, ALE_init, ALE_updateVerticalGridType +use MOM_domains, only : MOM_domains_init, MOM_domain_type, clone_MOM_domain +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_regridding, only : regridding_CS, initialize_regridding +use MOM_regridding, only : regridding_main, set_regrid_params +use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit + +implicit none ; private + +public :: init_oda, oda_end, set_prior_tracer, get_posterior_tracer +public :: set_analysis_time, oda, apply_oda_tracer_increments + +!>@{ CPU time clock ID +integer :: id_clock_oda_init +integer :: id_clock_bias_adjustment +integer :: id_clock_apply_increments +!>@} + +#include + +!> A structure with a pointer to a domain2d, to allow for the creation of arrays of pointers. +type :: ptr_mpp_domain + type(domain2d), pointer :: mpp_domain => NULL() !< pointer to a domain2d +end type ptr_mpp_domain + +!> A structure containing integer handles for bias adjustment of tracers +type :: INC_CS + integer :: fldno = 0 !< The number of tracers + type(external_field) :: T !< The handle for the temperature file + type(external_field) :: S !< The handle for the salinity file +end type INC_CS + +!> Control structure that contains a transpose of the ocean state across ensemble members. +type, public :: ODA_CS ; private + type(ocean_control_struct), pointer :: Ocean_prior=> NULL() !< ensemble ocean prior states in DA space + type(ocean_control_struct), pointer :: Ocean_posterior=> NULL() !< ensemble ocean posterior states + !! or increments to prior in DA space + type(ocean_control_struct), pointer :: Ocean_increment=> NULL() !< A separate structure for + !! increment diagnostics + integer :: nk !< number of vertical layers used for DA + type(ocean_grid_type), pointer :: Grid => NULL() !< MOM6 grid type and decomposition for the DA + type(ocean_grid_type), pointer :: G => NULL() !< MOM6 grid type and decomposition for the model + type(MOM_domain_type), pointer, dimension(:) :: domains => NULL() !< Pointer to mpp_domain objects + !! for ensemble members + type(verticalGrid_type), pointer :: GV => NULL() !< vertical grid for DA + type(unit_scale_type), pointer :: & + US => NULL() !< structure containing various unit conversion factors for DA + + type(domain2d), pointer :: mpp_domain => NULL() !< Pointer to a mpp domain object for DA + type(grid_type), pointer :: oda_grid !< local tracer grid + real, pointer, dimension(:,:,:) :: h => NULL() ! m or kg m-2] for DA + real, pointer, dimension(:,:,:) :: T_tend => NULL() ! degC s-1] + real, pointer, dimension(:,:,:) :: S_tend => NULL() ! ppt s-1] + real, pointer, dimension(:,:,:) :: T_bc_tend => NULL() !< The layer temperature tendency due + !! to bias adjustment [C T-1 ~> degC s-1] + real, pointer, dimension(:,:,:) :: S_bc_tend => NULL() !< The layer salinity tendency due + !! to bias adjustment [S T-1 ~> ppt s-1] + integer :: ni !< global i-direction grid size + integer :: nj !< global j-direction grid size + logical :: reentrant_x !< grid is reentrant in the x direction + logical :: reentrant_y !< grid is reentrant in the y direction + logical :: tripolar_N !< grid is folded at its north edge + logical :: symmetric !< Values at C-grid locations are symmetric + logical :: use_basin_mask !< If true, use a basin file to delineate weakly coupled ocean basins + logical :: do_bias_adjustment !< If true, use spatio-temporally varying climatological tendency + !! adjustment for Temperature and Salinity + real :: bias_adjustment_multiplier !< A scaling for the bias adjustment + integer :: assim_method !< Method: NO_ASSIM,EAKF_ASSIM or OI_ASSIM + integer :: ensemble_size !< Size of the ensemble + integer :: ensemble_id = 0 !< id of the current ensemble member + integer, pointer, dimension(:,:) :: ensemble_pelist !< PE list for ensemble members + integer, pointer, dimension(:) :: filter_pelist !< PE list for ensemble members + real :: assim_interval !< analysis interval [ T ~> s] + ! Profiles local to the analysis domain + type(ocean_profile_type), pointer :: Profiles => NULL() !< pointer to linked list of all available profiles + type(ocean_profile_type), pointer :: CProfiles => NULL()!< pointer to linked list of current profiles + type(kd_root), pointer :: kdroot => NULL() !< A structure for storing nearest neighbors + type(ALE_CS), pointer :: ALE_CS=>NULL() !< ALE control structure for DA + logical :: use_ALE_algorithm !< true is using ALE remapping + type(regridding_CS) :: regridCS !< ALE control structure for regridding + type(remapping_CS) :: remapCS !< ALE control structure for remapping + type(time_type) :: Time !< Current Analysis time + type(diag_ctrl), pointer :: diag_cs=> NULL() !@{ DA parameters +integer, parameter :: NO_ASSIM = 0, OI_ASSIM=1, EAKF_ASSIM=2 +!>@} +character(len=40) :: mdl = "MOM_oda_driver" !< This module's name. + +contains + +!> initialize First_guess (prior) and Analysis grid +!! information for all ensemble members +subroutine init_oda(Time, G, GV, US, diag_CS, CS) + + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diag_ctrl), target, intent(inout) :: diag_CS !< A pointer to a diagnostic control structure + type(ODA_CS), pointer, intent(inout) :: CS !< The DA control structure + +! Local variables + type(thermo_var_ptrs) :: tv_dummy + type(dyn_horgrid_type), pointer :: dG=> NULL() + type(hor_index_type), pointer :: HI=> NULL() + type(directories) :: dirs + + type(grid_type), pointer :: T_grid !< global tracer grid + type(param_file_type) :: PF + integer :: n + integer :: isd, ied, jsd, jed + integer, dimension(4) :: fld_sz + character(len=32) :: assim_method + integer :: npes_pm, ens_info(6) + character(len=30) :: coord_mode + character(len=200) :: inputdir, basin_file + character(len=80) :: basin_var + character(len=80) :: remap_scheme + character(len=80) :: bias_correction_file, inc_file + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + + if (associated(CS)) call MOM_error(FATAL, 'Calling oda_init with associated control structure') + allocate(CS) + + id_clock_oda_init=cpu_clock_id('(ODA initialization)') + call cpu_clock_begin(id_clock_oda_init) + +! Use ens1 parameters , this could be changed at a later time +! if it were desirable to have alternate parameters, e.g. for the grid +! for the analysis + call get_MOM_input(PF,dirs,ensemble_num=0) + call unit_scaling_init(PF, CS%US) + + call get_param(PF, mdl, "ASSIM_METHOD", assim_method, & + "String which determines the data assimilation method "//& + "Valid methods are: \'EAKF\',\'OI\', and \'NO_ASSIM\'", default='NO_ASSIM') + call get_param(PF, mdl, "ASSIM_INTERVAL", CS%assim_interval, & + "data assimilation update interval in hours",default=-1.0,units="hours",scale=3600.*US%s_to_T) + if (CS%assim_interval < 0.) then + call get_param(PF, mdl, "ASSIM_FREQUENCY", CS%assim_interval, & + "data assimilation update in hours. This parameter name will \n"//& + "be deprecated in the future. ASSIM_INTERVAL should be used instead.",default=-1.0, & + units="hours",scale=3600.*US%s_to_T) + endif + + call get_param(PF, mdl, "USE_REGRIDDING", CS%use_ALE_algorithm , & + "If True, use the ALE algorithm (regridding/remapping).\n"//& + "If False, use the layered isopycnal algorithm.", default=.false. ) + call get_param(PF, mdl, "REENTRANT_X", CS%reentrant_x, & + "If true, the domain is zonally reentrant.", default=.true.) + call get_param(PF, mdl, "REENTRANT_Y", CS%reentrant_y, & + "If true, the domain is meridionally reentrant.", & + default=.false.) + call get_param(PF, mdl, "TRIPOLAR_N", CS%tripolar_N, & + "Use tripolar connectivity at the northern edge of the "//& + "domain. With TRIPOLAR_N, NIGLOBAL must be even.", & + default=.false.) + call get_param(PF, mdl, "APPLY_TRACER_TENDENCY_ADJUSTMENT", CS%do_bias_adjustment, & + "If true, add a spatio-temporally varying climatological adjustment "//& + "to temperature and salinity.", & + default=.false.) + if (CS%do_bias_adjustment) then + call get_param(PF, mdl, "TRACER_ADJUSTMENT_FACTOR", CS%bias_adjustment_multiplier, & + "A multiplicative scaling factor for the climatological tracer tendency adjustment ", & + units="nondim", default=1.0) + endif + call get_param(PF, mdl, "USE_BASIN_MASK", CS%use_basin_mask, & + "If true, add a basin mask to delineate weakly connected "//& + "ocean basins for the purpose of data assimilation.", & + default=.false.) + + call get_param(PF, mdl, "NIGLOBAL", CS%ni, & + "The total number of thickness grid points in the "//& + "x-direction in the physical domain.") + call get_param(PF, mdl, "NJGLOBAL", CS%nj, & + "The total number of thickness grid points in the "//& + "y-direction in the physical domain.") + call get_param(PF, mdl, "INPUTDIR", inputdir) + call get_param(PF, mdl, "ODA_REMAPPING_SCHEME", remap_scheme, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: "//& + trim(remappingSchemesDoc), default="PPM_H4") + call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(PF, mdl, "ODA_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions used by the ODA driver "//& + "Values below 20190101 recover the answers from the end of 2018, while higher "//& + "values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + inputdir = slasher(inputdir) + + select case(lowercase(trim(assim_method))) + case('eakf') + CS%assim_method = EAKF_ASSIM + case('oi') + CS%assim_method = OI_ASSIM + case('no_assim') + CS%assim_method = NO_ASSIM + case default + call MOM_error(FATAL, "Invalid assimilation method provided") + end select + + ens_info = get_ensemble_size() + CS%ensemble_size = ens_info(1) + npes_pm=ens_info(3) + CS%ensemble_id = get_ensemble_id() + !! Switch to global pelist + allocate(CS%ensemble_pelist(CS%ensemble_size,npes_pm)) + allocate(CS%filter_pelist(CS%ensemble_size*npes_pm)) + call get_ensemble_pelist(CS%ensemble_pelist, 'ocean') + call get_ensemble_filter_pelist(CS%filter_pelist, 'ocean') + + call set_PElist(CS%filter_pelist) + + allocate(CS%domains(CS%ensemble_size)) + CS%domains(CS%ensemble_id)%mpp_domain => G%Domain%mpp_domain ! this should go away + do n=1,CS%ensemble_size + if (.not. associated(CS%domains(n)%mpp_domain)) allocate(CS%domains(n)%mpp_domain) + call set_rootPE(CS%ensemble_pelist(n,1)) ! this line is not in Feiyu's version (needed?) + call broadcast_domain(CS%domains(n)%mpp_domain) + enddo + call set_rootPE(CS%filter_pelist(1)) ! this line is not in Feiyu's version (needed?) + CS%G => G + allocate(CS%Grid) + ! params NIHALO_ODA, NJHALO_ODA set the DA halo size + call MOM_domains_init(CS%Grid%Domain,PF,param_suffix='_ODA') + allocate(HI) + call hor_index_init(CS%Grid%Domain, HI, PF) + call verticalGridInit( PF, CS%GV, CS%US ) + allocate(dG) + call create_dyn_horgrid(dG, HI) + call clone_MOM_domain(CS%Grid%Domain, dG%Domain,symmetric=.false.) + call set_grid_metrics(dG, PF, CS%US) + call MOM_initialize_topography(dG%bathyT, dG%max_depth, dG, PF, CS%US) + call MOM_initialize_coord(CS%GV, CS%US, PF, tv_dummy, dG%max_depth) + call ALE_init(PF, CS%GV, CS%US, dG%max_depth, CS%ALE_CS) + call MOM_grid_init(CS%Grid, PF, global_indexing=.false.) + call ALE_updateVerticalGridType(CS%ALE_CS, CS%GV) + call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) + CS%mpp_domain => CS%Grid%Domain%mpp_domain + CS%Grid%ke = CS%GV%ke + CS%nk = CS%GV%ke + ! initialize storage for prior and posterior + allocate(CS%Ocean_prior) + call init_ocean_ensemble(CS%Ocean_prior,CS%Grid,CS%GV,CS%ensemble_size) + allocate(CS%Ocean_posterior) + call init_ocean_ensemble(CS%Ocean_posterior,CS%Grid,CS%GV,CS%ensemble_size) + allocate(CS%Ocean_increment) + call init_ocean_ensemble(CS%Ocean_increment,CS%Grid,CS%GV,CS%ensemble_size) + + + call get_param(PF, 'oda_driver', "REGRIDDING_COORDINATE_MODE", coord_mode, & + "Coordinate mode for vertical regridding.", & + default="ZSTAR", fail_if_missing=.false.) + call initialize_regridding(CS%regridCS, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','') + call initialize_remapping(CS%remapCS,remap_scheme) + call set_regrid_params(CS%regridCS, min_thickness=0.) + isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed + + ! breaking with the MOM6 convention and using global indices + !call get_domain_extent(G%Domain,is,ie,js,je,isd,ied,jsd,jed,& + ! isg,ieg,jsg,jeg,idg_offset,jdg_offset,symmetric) + !isd=isd+idg_offset; ied=ied+idg_offset ! using global indexing within the DA module + !jsd=jsd+jdg_offset; jed=jed+jdg_offset ! TODO: switch to local indexing? (mjh) + + if (.not. associated(CS%h)) then + allocate(CS%h(isd:ied,jsd:jed,CS%GV%ke), source=CS%GV%Angstrom_H) + ! assign thicknesses + call ALE_initThicknessToCoord(CS%ALE_CS, G, CS%GV, CS%h) + endif + + allocate(CS%T_tend(isd:ied,jsd:jed,CS%GV%ke), source=0.0) + allocate(CS%S_tend(isd:ied,jsd:jed,CS%GV%ke), source=0.0) +! call set_axes_info(CS%Grid, CS%GV, CS%US, PF, CS%diag_cs, set_vertical=.true.) ! missing in Feiyu's fork + allocate(CS%oda_grid) + CS%oda_grid%x => CS%Grid%geolonT + CS%oda_grid%y => CS%Grid%geolatT + + + if (CS%use_basin_mask) then + call get_param(PF, 'oda_driver', "BASIN_FILE", basin_file, & + "A file in which to find the basin masks.", default="basin.nc") + basin_file = trim(inputdir) // trim(basin_file) + call get_param(PF, 'oda_driver', "BASIN_VAR", basin_var, & + "The basin mask variable in BASIN_FILE.", default="basin") + allocate(CS%oda_grid%basin_mask(isd:ied,jsd:jed), source=0.0) + call MOM_read_data(basin_file, basin_var, CS%oda_grid%basin_mask, CS%Grid%domain, timelevel=1) + endif + + ! set up diag variables for analysis increments + CS%diag_CS => diag_CS + CS%id_inc_t = register_diag_field('ocean_model', 'temp_increment', diag_CS%axesTL, & + Time, 'ocean potential temperature increments', 'degC', conversion=US%C_to_degC) + CS%id_inc_s = register_diag_field('ocean_model', 'salt_increment', diag_CS%axesTL, & + Time, 'ocean salinity increments', 'psu', conversion=US%S_to_ppt) + + !! get global grid information from ocean model needed for ODA initialization + T_grid => NULL() + call set_up_global_tgrid(T_grid, CS, G) + + call ocean_da_core_init(CS%mpp_domain, T_grid, CS%Profiles, Time) + deallocate(T_grid) + CS%Time = Time + !! switch back to ensemble member pelist + call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) + + if (CS%do_bias_adjustment) then + call get_param(PF, mdl, "TEMP_SALT_ADJUSTMENT_FILE", bias_correction_file, & + "The name of the file containing temperature and salinity "//& + "tendency adjustments", default='temp_salt_adjustment.nc') + + inc_file = trim(inputdir) // trim(bias_correction_file) + CS%INC_CS%T = init_extern_field(inc_file, "temp_increment", & + correct_leap_year_inconsistency=.true.,verbose=.true.,domain=G%Domain%mpp_domain) + CS%INC_CS%S = init_extern_field(inc_file, "salt_increment", & + correct_leap_year_inconsistency=.true.,verbose=.true.,domain=G%Domain%mpp_domain) + call get_external_field_info(CS%INC_CS%T, size=fld_sz) + CS%INC_CS%fldno = 2 + if (CS%nk /= fld_sz(3)) call MOM_error(FATAL,'Increment levels /= ODA levels') + + allocate(CS%T_bc_tend(G%isd:G%ied,G%jsd:G%jed,CS%GV%ke), source=0.0) + allocate(CS%S_bc_tend(G%isd:G%ied,G%jsd:G%jed,CS%GV%ke), source=0.0) + endif + + call cpu_clock_end(id_clock_oda_init) + +! if (CS%write_obs) then +! temp_fid = open_profile_file("temp_"//trim(obs_file)) +! salt_fid = open_profile_file("salt_"//trim(obs_file)) +! end if + +end subroutine init_oda + +!> Copy ensemble member tracers to ensemble vector. +subroutine set_prior_tracer(Time, G, GV, h, tv, CS) + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + + type(ODA_CS), pointer :: CS !< ocean DA control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk) :: T ! Temperature on the analysis grid [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),CS%nk) :: S ! Salinity on the analysis grid [S ~> ppt] + integer :: i, j, m + integer :: isc, iec, jsc, jec + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] + + ! return if not time for analysis + if (Time < CS%Time) return + + if (.not. associated(CS%Grid)) call MOM_ERROR(FATAL,'ODA_CS ensemble horizontal grid not associated') + if (.not. associated(CS%GV)) call MOM_ERROR(FATAL,'ODA_CS ensemble vertical grid not associated') + + !! switch to global pelist + call set_PElist(CS%filter_pelist) + !call MOM_mesg('Setting prior') + + if (CS%answer_date >= 20190101) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + else + h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + endif + + ! computational domain for the analysis grid + isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec + ! array extents for the ensemble member + !call get_domain_extent(CS%domains(CS%ensemble_id),is,ie,js,je,isd,ied,jsd,jed,& + ! isg,ieg,jsg,jeg,idg_offset,jdg_offset,symmetric) + ! remap temperature and salinity from the ensemble member to the analysis grid + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%T(i,j,:), & + CS%nk, CS%h(i,j,:), T(i,j,:), h_neglect, h_neglect_edge) + call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%S(i,j,:), & + CS%nk, CS%h(i,j,:), S(i,j,:), h_neglect, h_neglect_edge) + enddo ; enddo + ! cast ensemble members to the analysis domain + do m=1,CS%ensemble_size + call redistribute_array(CS%domains(m)%mpp_domain, T,& + CS%mpp_domain, CS%Ocean_prior%T(:,:,:,m), complete=.true.) + call redistribute_array(CS%domains(m)%mpp_domain, S,& + CS%mpp_domain, CS%Ocean_prior%S(:,:,:,m), complete=.true.) + enddo + + do m=1,CS%ensemble_size + call pass_var(CS%Ocean_prior%T(:,:,:,m),CS%Grid%domain) + call pass_var(CS%Ocean_prior%S(:,:,:,m),CS%Grid%domain) + enddo + + !! switch back to ensemble member pelist + call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) + + return + +end subroutine set_prior_tracer + +!> Returns posterior adjustments or full state +!!Note that only those PEs associated with an ensemble member receive data +subroutine get_posterior_tracer(Time, CS, increment) + type(time_type), intent(in) :: Time !< the current model time + type(ODA_CS), pointer :: CS !< ocean DA control structure + logical, optional, intent(in) :: increment !< True if returning increment only + + type(ocean_control_struct), pointer :: Ocean_increment=>NULL() + integer :: m + logical :: get_inc + + + ! return if not analysis time (retain pointers for h and tv) + if (Time < CS%Time .or. CS%assim_method == NO_ASSIM) return + + + !! switch to global pelist + call set_PElist(CS%filter_pelist) + call MOM_mesg('Getting posterior') + + !! Calculate and redistribute increments to CS%tv right after assimilation + !! Retain CS%tv to calculate increments for IAU updates CS%tv_inc otherwise + get_inc = .true. + if (present(increment)) get_inc = increment + + if (get_inc) then + allocate(Ocean_increment) + Ocean_increment%T = CS%Ocean_posterior%T - CS%Ocean_prior%T + Ocean_increment%S = CS%Ocean_posterior%S - CS%Ocean_prior%S + endif + ! It may be necessary to check whether the increment and ocean state have the + ! same dimensionally rescaled units. + do m=1,CS%ensemble_size + if (get_inc) then + call redistribute_array(CS%mpp_domain, Ocean_increment%T(:,:,:,m),& + CS%domains(m)%mpp_domain, CS%T_tend, complete=.true.) + call redistribute_array(CS%mpp_domain, Ocean_increment%S(:,:,:,m),& + CS%domains(m)%mpp_domain, CS%S_tend, complete=.true.) + else + call redistribute_array(CS%mpp_domain, CS%Ocean_posterior%T(:,:,:,m),& + CS%domains(m)%mpp_domain, CS%T_tend, complete=.true.) + call redistribute_array(CS%mpp_domain, CS%Ocean_posterior%S(:,:,:,m),& + CS%domains(m)%mpp_domain, CS%S_tend, complete=.true.) + endif + enddo + + + !! switch back to ensemble member pelist + call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) + + call pass_var(CS%T_tend,CS%domains(CS%ensemble_id)) + call pass_var(CS%S_tend,CS%domains(CS%ensemble_id)) + + !convert to a tendency (degC or PSU per second) + CS%T_tend = CS%T_tend / (CS%assim_interval) + CS%S_tend = CS%S_tend / (CS%assim_interval) + + +end subroutine get_posterior_tracer + +!> Gather observations and call ODA routines +subroutine oda(Time, CS) + type(time_type), intent(in) :: Time !< the current model time + type(oda_CS), pointer :: CS !< A pointer the ocean DA control structure + + if ( Time >= CS%Time ) then + + !! switch to global pelist + call set_PElist(CS%filter_pelist) + call get_profiles(Time, CS%Profiles, CS%CProfiles) +#ifdef ENABLE_ECDA + call ensemble_filter(CS%Ocean_prior, CS%Ocean_posterior, CS%CProfiles, CS%kdroot, CS%mpp_domain, CS%oda_grid) +#endif + !! switch back to ensemble member pelist + call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) + call get_posterior_tracer(Time, CS, increment=.true.) + if (CS%do_bias_adjustment) call get_bias_correction_tracer(Time, CS%US, CS) + + endif + + return +end subroutine oda + +subroutine get_bias_correction_tracer(Time, US, CS) + type(time_type), intent(in) :: Time !< the current model time + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ODA_CS), pointer :: CS !< ocean DA control structure + + ! Local variables + real, allocatable, dimension(:,:,:) :: T_bias ! Estimated temperature tendency bias [C T-1 ~> degC s-1] + real, allocatable, dimension(:,:,:) :: S_bias ! Estimated salinity tendency bias [S T-1 ~> ppt s-1] + real, allocatable, dimension(:,:,:) :: valid_flag ! Valid value flag on the horizontal model grid + ! and input-file vertical levels [nondim] + real, allocatable, dimension(:), target :: z_in ! Cell center depths for input data [Z ~> m] + real, allocatable, dimension(:), target :: z_edges_in ! Cell edge depths for input data [Z ~> m] + real :: missing_value ! A value indicating that there is no valid input data at this point [CU ~> conc] + integer, dimension(3) :: fld_sz + integer :: i,j,k + + + call cpu_clock_begin(id_clock_bias_adjustment) + call horiz_interp_and_extrap_tracer(CS%INC_CS%T, Time, CS%G, T_bias, & + valid_flag, z_in, z_edges_in, missing_value, scale=US%degC_to_C*US%s_to_T, spongeOngrid=.true.) + call horiz_interp_and_extrap_tracer(CS%INC_CS%S, Time, CS%G, S_bias, & + valid_flag, z_in, z_edges_in, missing_value, scale=US%ppt_to_S*US%s_to_T, spongeOngrid=.true.) + + ! This should be replaced to use mask_z instead of the following lines + ! which are intended to zero land values using an arbitrary limit. + fld_sz=shape(T_bias) + do i=1,fld_sz(1) + do j=1,fld_sz(2) + do k=1,fld_sz(3) +! if (T_bias(i,j,k) > 1.0E-3*US%degC_to_C) T_bias(i,j,k) = 0.0 +! if (S_bias(i,j,k) > 1.0E-3*US%ppt_to_S) S_bias(i,j,k) = 0.0 + if (valid_flag(i,j,k)==0.) then + T_bias(i,j,k)=0.0 + S_bias(i,j,k)=0.0 + endif + enddo + enddo + enddo + + CS%T_bc_tend = T_bias * CS%bias_adjustment_multiplier + CS%S_bc_tend = S_bias * CS%bias_adjustment_multiplier + + call pass_var(CS%T_bc_tend, CS%domains(CS%ensemble_id)) + call pass_var(CS%S_bc_tend, CS%domains(CS%ensemble_id)) + + call cpu_clock_end(id_clock_bias_adjustment) + +end subroutine get_bias_correction_tracer + +!> Finalize DA module +subroutine oda_end(CS) + type(ODA_CS), intent(inout) :: CS !< the ocean DA control structure + +end subroutine oda_end + +!> Initialize DA module +subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) + type(ocean_control_struct), pointer :: CS !< Pointer to ODA control structure + type(ocean_grid_type), pointer :: Grid !< Pointer to ocean analysis grid + type(verticalGrid_type), pointer :: GV !< Pointer to DA vertical grid + integer, intent(in) :: ens_size !< ensemble size + + integer :: is, ie, js, je, nk + + nk=GV%ke + is=Grid%isd;ie=Grid%ied + js=Grid%jsd;je=Grid%jed + CS%ensemble_size=ens_size + allocate(CS%T(is:ie,js:je,nk,ens_size)) + allocate(CS%S(is:ie,js:je,nk,ens_size)) + allocate(CS%SSH(is:ie,js:je,ens_size)) +! allocate(CS%id_t(ens_size), source=-1) +! allocate(CS%id_s(ens_size), source=-1) +! allocate(CS%U(is:ie,js:je,nk,ens_size)) +! allocate(CS%V(is:ie,js:je,nk,ens_size)) +! allocate(CS%id_u(ens_size), source=-1) +! allocate(CS%id_v(ens_size), source=-1) +! allocate(CS%id_ssh(ens_size), source=-1) + + return +end subroutine init_ocean_ensemble + +!> Set the next analysis time +subroutine set_analysis_time(Time,CS) + type(time_type), intent(in) :: Time !< the current model time + type(ODA_CS), pointer, intent(inout) :: CS !< the DA control structure + + character(len=160) :: mesg ! The text of an error message + integer :: yr, mon, day, hr, min, sec + + if (Time >= CS%Time) then + ! increment the analysis time to the next step + CS%Time = CS%Time + real_to_time(CS%US%T_to_s*(CS%assim_interval)) + + call get_date(Time, yr, mon, day, hr, min, sec) + write(mesg,*) 'Model Time: ', yr, mon, day, hr, min, sec + call MOM_mesg("set_analysis_time: "//trim(mesg)) + call get_date(CS%time, yr, mon, day, hr, min, sec) + write(mesg,*) 'Assimilation Time: ', yr, mon, day, hr, min, sec + call MOM_mesg("set_analysis_time: "//trim(mesg)) + endif + if (CS%Time < Time) then + call MOM_error(FATAL, " set_analysis_time: " // & + "assimilation interval appears to be shorter than " // & + "the model timestep") + endif + return + +end subroutine set_analysis_time + + +!> Apply increments to tracers +subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) + real, intent(in) :: dt !< The tracer timestep [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< layer thickness [H ~> m or kg m-2] + type(ODA_CS), pointer :: CS !< the data assimilation structure + + !! local variables + integer :: i, j + integer :: isc, iec, jsc, jec + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_tend_inc !< an adjustment to the temperature + !! tendency [C T-1 -> degC s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: S_tend_inc !< an adjustment to the salinity + !! tendency [S T-1 -> ppt s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: T_tend !< The temperature tendency adjustment from + !! DA [C T-1 ~> degC s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: S_tend !< The salinity tendency adjustment from DA + !! [S T-1 ~> ppt s-1] + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] + + if (.not. associated(CS)) return + if (CS%assim_method == NO_ASSIM .and. (.not. CS%do_bias_adjustment)) return + + call cpu_clock_begin(id_clock_apply_increments) + + T_tend_inc(:,:,:) = 0.0; S_tend_inc(:,:,:) = 0.0; T_tend(:,:,:) = 0.0; S_tend(:,:,:) = 0.0 + if (CS%assim_method > 0 ) then + T_tend = T_tend + CS%T_tend + S_tend = S_tend + CS%S_tend + endif + if (CS%do_bias_adjustment ) then + T_tend = T_tend + CS%T_bc_tend + S_tend = S_tend + CS%S_bc_tend + endif + + if (CS%answer_date >= 20190101) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + else + h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + endif + + isc=G%isc; iec=G%iec; jsc=G%jsc; jec=G%jec + do j=jsc,jec; do i=isc,iec + call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), T_tend(i,j,:), & + G%ke, h(i,j,:), T_tend_inc(i,j,:), h_neglect, h_neglect_edge) + call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), S_tend(i,j,:), & + G%ke, h(i,j,:), S_tend_inc(i,j,:), h_neglect, h_neglect_edge) + enddo; enddo + + + call pass_var(T_tend_inc, G%Domain) + call pass_var(S_tend_inc, G%Domain) + + tv%T(isc:iec,jsc:jec,:) = tv%T(isc:iec,jsc:jec,:) + T_tend_inc(isc:iec,jsc:jec,:)*dt + tv%S(isc:iec,jsc:jec,:) = tv%S(isc:iec,jsc:jec,:) + S_tend_inc(isc:iec,jsc:jec,:)*dt + + call pass_var(tv%T, G%Domain) + call pass_var(tv%S, G%Domain) + + call enable_averaging(dt, Time_end, CS%diag_CS) + if (CS%id_inc_t > 0) call post_data(CS%id_inc_t, T_tend_inc, CS%diag_CS) + if (CS%id_inc_s > 0) call post_data(CS%id_inc_s, S_tend_inc, CS%diag_CS) + call disable_averaging(CS%diag_CS) + + call diag_update_remap_grids(CS%diag_CS) + call cpu_clock_end(id_clock_apply_increments) + + +end subroutine apply_oda_tracer_increments + + subroutine set_up_global_tgrid(T_grid, CS, G) + type(grid_type), pointer :: T_grid !< global tracer grid + type(ODA_CS), pointer, intent(in) :: CS !< A pointer to DA control structure. + type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model + + ! local variables + real, dimension(:,:), allocatable :: global2D, global2D_old + integer :: i, j, k + + ! get global grid information from ocean_model + T_grid=>NULL() + !if (associated(T_grid)) call MOM_error(FATAL,'MOM_oda_driver:set_up_global_tgrid called with associated T_grid') + + allocate(T_grid) + T_grid%ni = CS%ni + T_grid%nj = CS%nj + T_grid%nk = CS%nk + allocate(T_grid%x(CS%ni,CS%nj)) + allocate(T_grid%y(CS%ni,CS%nj)) + allocate(T_grid%bathyT(CS%ni,CS%nj)) + call global_field(CS%mpp_domain, CS%Grid%geolonT, T_grid%x) + call global_field(CS%mpp_domain, CS%Grid%geolatT, T_grid%y) + call global_field(CS%domains(CS%ensemble_id)%mpp_domain, G%bathyT, T_grid%bathyT) + if (CS%use_basin_mask) then + allocate(T_grid%basin_mask(CS%ni,CS%nj)) + call global_field(CS%mpp_domain, CS%oda_grid%basin_mask, T_grid%basin_mask) + endif + allocate(T_grid%mask(CS%ni,CS%nj,CS%nk), source=0.0) + allocate(T_grid%z(CS%ni,CS%nj,CS%nk), source=0.0) + allocate(global2D(CS%ni,CS%nj)) + allocate(global2D_old(CS%ni,CS%nj)) + + do k = 1, CS%nk + call global_field(G%Domain%mpp_domain, CS%h(:,:,k), global2D) + do i=1,CS%ni ; do j=1,CS%nj + if ( global2D(i,j) > 1 ) then + T_grid%mask(i,j,k) = 1.0 + endif + enddo; enddo + if (k == 1) then + T_grid%z(:,:,k) = global2D/2 + else + T_grid%z(:,:,k) = T_grid%z(:,:,k-1) + (global2D + global2D_old)/2 + endif + global2D_old = global2D + enddo + + deallocate(global2D) + deallocate(global2D_old) + end subroutine set_up_global_tgrid + +!> \namespace MOM_oda_driver_mod +!! +!! \section section_ODA The Ocean data assimilation (DA) and Ensemble Framework +!! +!! The DA framework implements ensemble capability in MOM6. Currently, this framework +!! is enabled using the cpp directive ENSEMBLE_OCEAN. The ensembles need to be generated +!! at the level of the calling routine for oda_init or above. The ensemble instances may +!! exist on overlapping or non-overlapping processors. The ensemble information is accessed +!! via the FMS ensemble manager. An independent PE layout is used to gather (prior) ensemble +!! member information where this information is stored in the ODA control structure. This +!! module was developed in collaboration with Feiyu Lu and Tony Rosati in the GFDL prediction +!! group for use in their coupled ensemble framework. These interfaces should be suitable for +!! interfacing MOM6 to other data assimilation packages as well. + +end module MOM_oda_driver_mod diff --git a/ocean_data_assim/MOM_oda_incupd.F90 b/ocean_data_assim/MOM_oda_incupd.F90 new file mode 100644 index 0000000000..be57bbe748 --- /dev/null +++ b/ocean_data_assim/MOM_oda_incupd.F90 @@ -0,0 +1,840 @@ +!> This module contains the routines used to apply incremental updates +!! from data assimilation. +! +!! Applying incremental updates requires the following: +!! 1. initialize_oda_incupd_fixed and initialize_oda_incupd +!! 2. set_up_oda_incupd_field (tracers) and set_up_oda_incupd_vel_field (vel) +!! 3. calc_oda_increments (if using full fields input) +!! 4. apply_oda_incupd +!! 5. output_oda_incupd_inc (output increment if using full fields input) +!! 6. init_oda_incupd_diags (to output increments in diagnostics) +!! 7. oda_incupd_end (not being used for now) + +module MOM_oda_incupd + + +! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only : rotate_array +use MOM_coms, only : sum_across_PEs +use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field +use MOM_diag_mediator, only : diag_ctrl +use MOM_domains, only : pass_var,pass_vector +use MOM_error_handler, only : MOM_error, FATAL, NOTE, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_get_input, only : directories, Get_MOM_input +use MOM_grid, only : ocean_grid_type +use MOM_io, only : vardesc, var_desc +use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping +use MOM_restart, only : register_restart_field, register_restart_pair, MOM_restart_CS +use MOM_restart, only : restart_init, save_restart, query_initialized +use MOM_spatial_means, only : global_i_mean +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units + +implicit none ; private + +#include + + +! Publicly available functions +public set_up_oda_incupd_field, set_up_oda_incupd_vel_field +public initialize_oda_incupd_fixed, initialize_oda_incupd, apply_oda_incupd, oda_incupd_end +public init_oda_incupd_diags,calc_oda_increments,output_oda_incupd_inc + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> A structure for creating arrays of pointers to 3D arrays with extra gridding information +type :: p3d + integer :: id !< id for FMS external time interpolator + integer :: nz_data !< The number of vertical levels in the input field. + real, dimension(:,:,:), pointer :: mask_in => NULL() !< pointer to the data mask. + real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data. + real, dimension(:,:,:), pointer :: h => NULL() !< pointer to the data grid. +end type p3d + +!> oda incupd control structure +type, public :: oda_incupd_CS ; private + integer :: nz !< The total number of layers. + integer :: nz_data !< The total number of arbritary layers (used by older code). + integer :: fldno = 0 !< The number of fields which have already been + !! registered by calls to set_up_oda_incupd_field + + type(p3d) :: Inc(MAX_FIELDS_) !< The increments to be applied to the field + type(p3d) :: Inc_u !< The increments to be applied to the u-velocities, with data in [L T-1 ~> m s-1] + type(p3d) :: Inc_v !< The increments to be applied to the v-velocities, with data in [L T-1 ~> m s-1] + type(p3d) :: Ref_h !< Vertical grid on which the increments are provided + + + integer :: nstep_incupd !< number of time step for full update + real :: ncount = 0.0 !< increment time step counter + type(remapping_cs) :: remap_cs !< Remapping parameters and work arrays + logical :: incupdDataOngrid !< True if the incupd data are on the model horizontal grid + logical :: uv_inc !< use u and v increments + + ! for diagnostics + type(diag_ctrl), pointer :: diag ! This subroutine defined the control structure of module and register +!the time counter to full update in restart +subroutine initialize_oda_incupd_fixed( G, GV, US, CS, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(oda_incupd_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module (in/out). + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + + if (associated(CS)) then + call MOM_error(WARNING, "initialize_oda_incupd_fixed called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ! initialize time counter + CS%ncount = 0.0 + ! register ncount in restart + call register_restart_field(CS%ncount, "oda_incupd_ncount", .false., restart_CS,& + "Number of inc. update already done", "N/A") +end subroutine initialize_oda_incupd_fixed + + +!> This subroutine defined the number of time step for full update, stores the layer pressure +!! increments and initialize remap structure. +subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: nz_data !< The total number of incr. input layers. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + type(oda_incupd_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module (in/out). + real, dimension(SZI_(G),SZJ_(G),nz_data), intent(in) :: data_h !< The ODA h + !! [H ~> m or kg m-2]. + type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control struct + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_oda" ! This module's name. + logical :: use_oda_incupd + logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries + logical :: reset_ncount + integer :: i, j, k + real :: nhours_incupd, dt, dt_therm + character(len=256) :: mesg + character(len=64) :: remapScheme + if (.not.associated(CS)) then + call MOM_error(WARNING, "initialize_oda_incupd called without an associated "// & + "control structure.") + return + endif + +! Set default, read and log parameters + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "ODA_INCUPD", use_oda_incupd, & + "If true, oda incremental updates will be applied "//& + "everywhere in the domain.", default=.false.) + + if (.not.use_oda_incupd) return + + call get_param(param_file, mdl, "ODA_INCUPD_NHOURS", nhours_incupd, & + "Number of hours for full update (0=direct insertion).", & + default=3.0,units="h", scale=US%s_to_T) + call get_param(param_file, mdl, "ODA_INCUPD_RESET_NCOUNT", reset_ncount, & + "If True, reinitialize number of updates already done, ncount.", & + default=.true.) + call get_param(param_file, mdl, "DT", dt, & + "The (baroclinic) dynamics time step. The time-step that "//& + "is actually used will be an integer fraction of the "//& + "forcing time-step (DT_FORCING in ocean-only mode or the "//& + "coupling timestep in coupled mode.)", units="s", scale=US%s_to_T, & + fail_if_missing=.true.) + call get_param(param_file, mdl, "DT_THERM", dt_therm, & + "The thermodynamic and tracer advection time step. "//& + "Ideally DT_THERM should be an integer multiple of DT "//& + "and less than the forcing or coupling time-step, unless "//& + "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& + "can be an integer multiple of the coupling timestep. By "//& + "default DT_THERM is set to DT.", & + units="s", scale=US%s_to_T, default=US%T_to_s*dt) + call get_param(param_file, mdl, "ODA_INCUPD_UV", CS%uv_inc, & + "use U,V increments.", & + default=.true.) + call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & + "This sets the reconstruction scheme used "//& + " for vertical remapping for all variables.", & + default="PLM", do_not_log=.true.) + + call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & + "When defined, a proper high-order reconstruction "//& + "scheme is used within boundary cells rather "//& + "than PCM. E.g., if PPM is used for remapping, a "//& + "PPM reconstruction will also be used within boundary cells.", & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "ODA_INCUPD_DATA_ONGRID", CS%incupdDataOngrid, & + "When defined, the incoming oda_incupd data are "//& + "assumed to be on the model horizontal grid " , & + default=.true.) + + CS%nz = GV%ke + + ! increments on horizontal grid + if (.not. CS%incupdDataOngrid) call MOM_error(FATAL,'initialize_oda_incupd: '// & + 'The oda_incupd code only applies ODA increments on the same horizontal grid. ') + + ! get number of timestep for full update + if (nhours_incupd == 0) then + CS%nstep_incupd = 1 !! direct insertion + else + 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:"//& + trim(mesg)) + + ! number of inc. update already done, CS%ncount, either from restart or set to 0.0 + if (query_initialized(CS%ncount, "oda_incupd_ncount", restart_CS) .and. & + .not.reset_ncount) then + CS%ncount = CS%ncount + else + CS%ncount = 0.0 + endif + write(mesg,'(f4.1)') CS%ncount + if (is_root_pe()) & + 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) + enddo; enddo ; enddo + !### Doing a halo update here on CS%Ref_h%p would avoid needing halo updates each timestep. + + ! Call the constructor for remapping control structure + !### Revisit this hard-coded answer_date. + call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & + answer_date=20190101) +end subroutine initialize_oda_incupd + + +!> This subroutine stores the increments at h points for the variable +!! whose address is given by f_ptr. +subroutine set_up_oda_incupd_field(sp_val, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(oda_incupd_CS), pointer :: CS !< oda_incupd control structure (in/out). + real, dimension(SZI_(G),SZJ_(G),CS%nz_data), & + intent(in) :: sp_val !< increment field, it can have an + !! arbitrary number of layers. + + integer :: i, j, k + character(len=256) :: mesg ! String for error messages + + if (.not.associated(CS)) return + + CS%fldno = CS%fldno + 1 + if (CS%fldno > MAX_FIELDS_) then + write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & + &the number of fields increments in the call to & + &initialize_oda_incupd." )') CS%fldno + call MOM_error(FATAL,"set_up_oda_incupd_field: "//mesg) + endif + + ! store the increment/full field tracer profiles + 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) + enddo ; enddo ; enddo + +end subroutine set_up_oda_incupd_field + + +!> This subroutine stores the increments at u and v points for the variable +!! whose address is given by u_ptr and v_ptr. +subroutine set_up_oda_incupd_vel_field(u_val, v_val, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< Grid structure (in). + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(oda_incupd_CS), pointer :: CS !< oda incupd structure (in/out). + + real, dimension(SZIB_(G),SZJ_(G),CS%nz_data), & + intent(in) :: u_val !< u increment, it has arbritary number of layers but + !! not to exceed the total number of model layers [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),CS%nz_data), & + intent(in) :: v_val !< v increment, it has arbritary number of layers but + !! not to exceed the number of model layers [L T-1 ~> m s-1] + integer :: i, j, k + + if (.not.associated(CS)) return + + + ! store the increment/full field u profile + allocate(CS%Inc_u%p(G%isdB:G%iedB,G%jsd:G%jed,CS%nz_data), source=0.0) + do j=G%jsc,G%jec ; do i=G%iscB,G%iecB + do k=1,CS%nz_data + CS%Inc_u%p(i,j,k) = u_val(i,j,k) + enddo + enddo ; enddo + + ! store the increment/full field v profile + allocate(CS%Inc_v%p(G%isd:G%ied,G%jsdB:G%jedB,CS%nz_data), source=0.0) + do j=G%jscB,G%jecB ; do i=G%isc,G%iec + do k=1,CS%nz_data + CS%Inc_v%p(i,j,k) = v_val(i,j,k) + enddo + enddo ; enddo + +end subroutine set_up_oda_incupd_vel_field + +! calculation of the increments if using full fields (ODA_INCUPD_INC=.false.) at initialization +subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] (in) + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + + real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity that is being + !! initialized [L T-1 ~> m s-1] + real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity that is being + !! initialized [L T-1 ~> m s-1] + type(oda_incupd_CS), pointer :: CS !< A pointer to the control structure for this module + !! that is set by a previous call to initialize_oda_incupd (in). + + + real, dimension(SZK_(GV)) :: tmp_val1 ! data values on the model grid, in rescaled units + ! like [S ~> ppt] for salinity. + real, allocatable, dimension(:) :: tmp_val2 ! data values remapped to increment grid, in rescaled units + ! like [S ~> ppt] for salinity. + real, allocatable, dimension(:,:,:) :: h_obs !< Layer-thicknesses of increments [H ~> m or kg m-2] + real, allocatable, dimension(:) :: tmp_h ! temporary array for corrected h_obs [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hu_obs ! A column of observation-grid thicknesses at u points [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hv_obs ! A column of observation-grid thicknesses at v points [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at u or v points [H ~> m or kg m-2] + + + integer :: i, j, k, is, ie, js, je, nz, nz_data + integer :: isB, ieB, jsB, jeB + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + real :: sum_h1, sum_h2 ! vertical sums of h's [H ~> m or kg m-2] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB + if (.not.associated(CS)) return + + + ! increments calculated on if CS%ncount = 0.0 + if (CS%ncount /= 0.0) call MOM_error(FATAL,'calc_oda_increments: '// & + 'CS%ncount should be 0.0 to get accurate increments.') + + + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + endif + + ! get h_obs + nz_data = CS%Inc(1)%nz_data + allocate(h_obs(G%isd:G%ied,G%jsd:G%jed,nz_data), source=0.0) + do k=1,nz_data ; do j=js,je ; do i=is,ie + h_obs(i,j,k) = CS%Ref_h%p(i,j,k) + enddo ; enddo ; enddo + call pass_var(h_obs,G%Domain) + + + ! allocate 1-d arrays + allocate(tmp_h(nz_data), source=0.0) + allocate(tmp_val2(nz_data), source=0.0) + allocate(hu_obs(nz_data), source=0.0) + allocate(hv_obs(nz_data), source=0.0) + + ! 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 + ! 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 + 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 ! uv_inc + + call pass_var(CS%Inc(1)%p, G%Domain) + call pass_var(CS%Inc(2)%p, G%Domain) + call pass_vector(CS%Inc_u%p,CS%Inc_v%p,G%Domain) + + ! deallocate arrays + deallocate(tmp_h,tmp_val2,hu_obs,hv_obs) + deallocate(h_obs) + +end subroutine calc_oda_increments + +!> This subroutine applies oda increments to layers thicknesses, temp, salt, U +!! and V everywhere . +subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] (in) + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables + + real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< The zonal velocity that is being + !! initialized [L T-1 ~> m s-1] + real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< The meridional velocity that is being + !! initialized [L T-1 ~> m s-1] + + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. + type(oda_incupd_CS), pointer :: CS !< A pointer to the control structure for this module + !! that is set by a previous call to initialize_oda_incupd (in). + + real, allocatable, dimension(:) :: tmp_val2 ! data values on the increment grid + real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid + real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at u or v points [H ~> m or kg m-2] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_t !< A temporary array for t increments [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_s !< A temporary array for s increments [S ~> ppt] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: tmp_u !< A temporary array for u increments [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: tmp_v !< A temporary array for v increments [L T-1 ~> m s-1] + + real, allocatable, dimension(:,:,:) :: h_obs !< h of increments + real, allocatable, dimension(:) :: tmp_h !< temporary array for corrected h_obs + real, allocatable, dimension(:) :: hu_obs ! A column of observation-grid thicknesses at u points [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hv_obs ! A column of observation-grid thicknesses at v points [H ~> m or kg m-2] + + integer :: i, j, k, is, ie, js, je, nz, nz_data + integer :: isB, ieB, jsB, jeB +! integer :: ncount ! time step counter + real :: inc_wt ! weight of the update for this time-step [nondim] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + real :: sum_h1, sum_h2 ! vertical sums of h's [H ~> m or kg m-2] + character(len=256) :: mesg + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB + if (.not.associated(CS)) return + + ! no assimilation after CS%step_incupd + if (CS%ncount >= CS%nstep_incupd) then + if (is_root_pe()) call MOM_error(NOTE,"ended updating fields with increments. ") + return + endif !ncount>CS%nstep_incupd + + ! update counter + CS%ncount = CS%ncount+1.0 + inc_wt = 1.0/CS%nstep_incupd + + ! print out increments + write(mesg,'(f10.0)') CS%ncount + if (is_root_pe()) call MOM_error(NOTE,"updating fields with increments ncount:"//trim(mesg)) + write(mesg,'(f10.8)') inc_wt + if (is_root_pe()) call MOM_error(NOTE,"updating fields with weight inc_wt:"//trim(mesg)) + + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + endif + + ! get h_obs + nz_data = CS%Inc(1)%nz_data + allocate(h_obs(G%isd:G%ied,G%jsd:G%jed,nz_data), source=0.0) + do k=1,nz_data ; do j=js,je ; do i=is,ie + h_obs(i,j,k) = CS%Ref_h%p(i,j,k) + enddo ; enddo ; enddo + call pass_var(h_obs,G%Domain) + + ! allocate 1-d array + allocate(tmp_h(nz_data), source=0.0) + allocate(tmp_val2(nz_data)) + allocate(hu_obs(nz_data), source=0.0) + allocate(hv_obs(nz_data), source=0.0) + + ! add increments to tracers + tmp_val1(:) = 0.0 + tmp_t(:,:,:) = 0.0 ; tmp_s(:,:,:) = 0.0 ! diagnostics + do j=js,je ; do i=is,ie + ! account for the different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1+h(i,j,k) + enddo + sum_h2 = 0.0 + 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 + 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 + endif + 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 + + endif ! uv_inc + + call pass_var(tv%T, G%Domain) + call pass_var(tv%S, G%Domain) + call pass_vector(u,v,G%Domain) + + ! Diagnostics of increments, mostly used for debugging. + if (CS%uv_inc) then + if (CS%id_u_oda_inc > 0) call post_data(CS%id_u_oda_inc, tmp_u, CS%diag) + if (CS%id_v_oda_inc > 0) call post_data(CS%id_v_oda_inc, tmp_v, CS%diag) + endif + !### The argument here seems wrong. + if (CS%id_h_oda_inc > 0) call post_data(CS%id_h_oda_inc, h , CS%diag) + if (CS%id_T_oda_inc > 0) call post_data(CS%id_T_oda_inc, tmp_t, CS%diag) + if (CS%id_S_oda_inc > 0) call post_data(CS%id_S_oda_inc, tmp_s, CS%diag) + + ! deallocate arrays + deallocate(tmp_h,tmp_val2,hu_obs,hv_obs) + deallocate(h_obs) + +end subroutine apply_oda_incupd + +!> Output increment if using full fields for the oda_incupd module. +subroutine output_oda_incupd_inc(Time, G, GV, param_file, CS, US) + type(time_type), target, intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for + !model parameter + !values. + type(oda_incupd_CS), pointer :: CS !< ODA incupd control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling + + type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() + + type(directories) :: dirs + type(vardesc) :: u_desc, v_desc + + character(len=40) :: mdl = "MOM_oda" ! This module's name. + character(len=200) :: inc_file ! name of the increment file + + if (.not.associated(CS)) return + ! get the output_directory + call Get_MOM_Input(dirs=dirs) + if (is_root_pe()) call MOM_error(NOTE,"output increments in output_directory") + + ! get a restart structure + call restart_init(param_file, restart_CSp_tmp) + + ! register the variables to write + call register_restart_field(CS%Inc(1)%p, "T_inc", .true., restart_CSp_tmp, & + "Pot. T. increment", "degC", conversion=US%C_to_degC) + call register_restart_field(CS%Inc(2)%p, "S_inc", .true., restart_CSp_tmp, & + "Salinity increment", "psu", conversion=US%S_to_ppt) + call register_restart_field(CS%Ref_h%p, "h_obs", .true., restart_CSp_tmp, & + "Observational h", units=get_thickness_units(GV), conversion=GV%H_to_MKS) + if (CS%uv_inc) then + u_desc = var_desc("u_inc", "m s-1", "U-vel increment", hor_grid='Cu') + v_desc = var_desc("v_inc", "m s-1", "V-vel increment", hor_grid='Cv') + call register_restart_pair(CS%Inc_u%p, CS%Inc_v%p, u_desc, v_desc, & + .false., restart_CSp_tmp, conversion=US%L_T_to_m_s) + endif + + ! get the name of the output file + call get_param(param_file, mdl, "ODA_INCUPD_OUTPUT_FILE", inc_file,& + "The name-root of the output file for the increment if using full fields.", & + default="MOM.inc") + + ! write the increments file + call save_restart(dirs%output_directory, Time, G, restart_CSp_tmp, & + filename=inc_file, GV=GV) !, write_ic=.true.) + +end subroutine output_oda_incupd_inc + + + +!> Initialize diagnostics for the oda_incupd module. +subroutine init_oda_incupd_diags(Time, G, GV, diag, CS, US) + type(time_type), target, intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic + !! output. + type(oda_incupd_CS), pointer :: CS !< ALE sponge control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling + + if (.not.associated(CS)) return + + CS%diag => diag + ! These diagnostics of the state variables increments are useful for debugging the ODA code. + CS%id_u_oda_inc = register_diag_field('ocean_model', 'u_oda_inc', diag%axesCuL, Time, & + 'Zonal velocity ODA inc.', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_v_oda_inc = register_diag_field('ocean_model', 'v_oda_inc', diag%axesCvL, Time, & + 'Meridional velocity ODA inc.', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_h_oda_inc = register_diag_field('ocean_model', 'h_oda_inc', diag%axesTL, Time, & + 'Layer Thickness ODA inc.', get_thickness_units(GV), conversion=GV%H_to_mks) + CS%id_T_oda_inc = register_diag_field('ocean_model', 'T_oda_inc', diag%axesTL, Time, & + 'Temperature ODA inc.', 'degC', conversion=US%C_to_degC) + CS%id_S_oda_inc = register_diag_field('ocean_model', 'S_oda_inc', diag%axesTL, Time, & + 'Salinity ODA inc.', 'PSU', conversion=US%S_to_ppt) + +end subroutine init_oda_incupd_diags + +!> This subroutine deallocates any memory associated with the oda_incupd module. +subroutine oda_incupd_end(CS) + type(oda_incupd_CS), pointer :: CS !< A pointer to the control structure that is + !! set by a previous call to initialize_oda_incupd. + + integer :: m + + if (.not.associated(CS)) return + + do m=1,CS%fldno + if (associated(CS%Inc(m)%p)) deallocate(CS%Inc(m)%p) + enddo + + deallocate(CS) + +end subroutine oda_incupd_end + +end module MOM_oda_incupd diff --git a/parameterizations/CVmix/INSTALL b/parameterizations/CVmix/INSTALL new file mode 100644 index 0000000000..0620e81537 --- /dev/null +++ b/parameterizations/CVmix/INSTALL @@ -0,0 +1,54 @@ +CVMix library installation guide +-------------------------------- + +This document describes how to build the CVMix library. Note that the steps +described in this document will not build any executables, it is only meant to +produce libcvmix.a and several .mod files that should be linked to or included +in an outside ocean model. To build one of the provided stand-alone drivers, +see $CVMIX/README. + +There are two different ways to build libcvmix.a and its associated .mod files. + +1) If you have downloaded the entire CVMix package, you can go to + $CVMIX/src/shared and run + + $ make + + You may be prompted for information about your compiler and netCDF location. + The netCDF location is only used in compiling the standalone drivers (and + only if you want to output in netCDF format), so you can leave that field + blank if you wish. + + This will result in files being created in three locations: + + $CVMIX/lib -- libcvmix.a will be placed in here. When you link a program + using the CVMix library, use -L$CVMIX/lib -lcvmix + + $CVMIX/include -- a handful of .mod files while be placed here. When you + build a program using the CVMix lbirary, use + -I$CVMIX/include + + $CVMIX/bld/obj -- a handful of .mod and .o files will be placed here. The .o + files have already been placed in libcvmix.a and the .mod + files have already been copied to the include/ directory, + so these files are not needed any more. + +2) If you have just downloaded the $CVMIX/src/shared directory as an external + to your model, you need to specify several necessary compilation options. + + FC -- your fortran compiler + FCFLAGS -- any compiler flags you wish to pass (default: nothing is passed) + OBJ_DIR -- where to put .o and .mod files when building (default: this dir) + LIB_DIR -- where to put libcvmix.a (default: this dir) + INC_DIR -- where to put the .mod files (default: this dir) + + For example, if you want to keep libcvmix.a in /projects/cvmix/lib and all + the .mod files in /projects/cvmix/include, and you use the intel compiler + with O2 optimization, you can run + + $ make FC=ifort FCFLAGS="-O2" LIB_DIR=/project/cvmix/lib \ + INC_DIR=/projects/cvmix/include + + Note that this will still write the .o and .mod files to the current + directory, so if you do not have write permissions you must also set + OBJ_DIR. diff --git a/parameterizations/CVmix/Makefile b/parameterizations/CVmix/Makefile new file mode 100644 index 0000000000..465be67382 --- /dev/null +++ b/parameterizations/CVmix/Makefile @@ -0,0 +1,89 @@ +.SUFFIXES: .F90 .o +extension = .F90 + +SRC_DIR = . +OBJ_DIR = . +LIB_DIR = . +INC_DIR = . +FC = NONE + +# Dependency Generation +MAKE_DEP = $(SRC_DIR)/makedep.py +DEP_FILE = $(OBJ_DIR)/shared_deps.d + +ifeq ($(FC),NONE) + NOFC = TRUE +endif + +MODULES = cvmix_kinds_and_types.F90 \ + cvmix_background.F90 \ + cvmix_convection.F90 \ + cvmix_ddiff.F90 \ + cvmix_kpp.F90 \ + cvmix_math.F90 \ + cvmix_put_get.F90 \ + cvmix_shear.F90 \ + cvmix_tidal.F90 \ + cvmix_utils.F90 + +# Some compilers produce ALL_UPPER_CASE.mod files +ifeq ($(UCASE),TRUE) + MODS_TMP = $(shell echo $(MODULES) | tr '[a-z]' '[A-Z]') +else + MODS_TMP = $(MODULES) +endif +ifneq ($(OBJ_DIR),$(INC_DIR)) + INCS = $(addprefix $(INC_DIR)/,${MODS_TMP:.F90=.mod}) +endif +MODS = $(addprefix $(OBJ_DIR)/,${MODS_TMP:.F90=.mod}) \ + $(INCS) +OBJS = $(addprefix $(OBJ_DIR)/,${MODULES:.F90=.o}) + +ifeq ($(USE_DEPS),TRUE) + include $(DEP_FILE) +endif + +### TARGETS ### + +all: lib + +# Create all object and module files +# Note that .mod files need to be copied to INC_DIR if OBJ_DIR != INC_DIR + +$(OBJ_DIR)/%.o: $(SRC_DIR)/%.F90 + $(FC) $(FCFLAGS) -c $< -o $@ + +$(INC_DIR)/%.mod: $(OBJ_DIR)/%.mod +ifneq ($(INC_DIR),$(OBJ_DIR)) + cp $< $@ +endif + +### Combine into library +$(LIB_DIR)/libcvmix.a: $(OBJS) + ar -ru $(LIB_DIR)/libcvmix.a $(OBJS) + +$(DEP_FILE): $(MAKE_DEP) $(SRC_DIR)/*.F90 + $(MAKE_DEP) $(DEP_FILE) $(OBJ_DIR) $(SRC_DIR) + @echo "Generated dependencies!" + +.PHONY: depends recurse check clean + +# Shorthand for making dependency file +depends: $(DEP_FILE) + +# Shorthand for making the library (and all .mod files) +lib: check depends + $(MAKE) -e -f $(SRC_DIR)/Makefile $(LIB_DIR)/libcvmix.a $(INCS) USE_DEPS=TRUE + +# Make sure a Fortran compiler was specified (the Makefile for the stand-alone +# driver passes FC along with FCFLAGS, SRC_DIR, OBJ_DIR, LIB_DIR, and INC_DIR) +check: + @$(if $(NOFC), echo "ERROR: you must specify FC (and it is recommended that \ + you specify FCFLAGS as"; echo "well)."; echo "NOTE: if you have checked \ + out the stand-alone CVMix driver set then you should"; echo "run \"make \ + lib\" from the src/ directory to use CVMix compile options."; exit 1) + +# Remove library, object files, module files, and dependency file +clean: + /bin/rm -f $(LIB_DIR)/libcvmix.a $(OBJS) $(MODS) $(DEP_FILE) + diff --git a/parameterizations/CVmix/cvmix_background.F90 b/parameterizations/CVmix/cvmix_background.F90 new file mode 100644 index 0000000000..4cae3bfe82 --- /dev/null +++ b/parameterizations/CVmix/cvmix_background.F90 @@ -0,0 +1,1162 @@ +module cvmix_background + +!BOP +!\newpage +! !MODULE: cvmix_background +! +! !AUTHOR: +! Michael N. Levy, NCAR (mlevy@ucar.edu) +! +! !DESCRIPTION: +! This module contains routines to initialize the derived types needed for +! time independent static background mixing coefficients. It specifies +! either a scalar, 1D, or 2D field for viscosity and diffusivity. It also +! calculates the background diffusivity using the Bryan-Lewis method. +! It then sets the viscosity and diffusivity to the specified value. +!\\ +!\\ +! References:\\ +! * K Bryan and LJ Lewis. +! A Water Mass Model of the World Ocean. +! Journal of Geophysical Research, 1979. +!\\ +!\\ + +! !USES: + + use cvmix_kinds_and_types, only : cvmix_PI, & + cvmix_r8, & + cvmix_strlen, & + cvmix_zero, & + cvmix_data_type, & + cvmix_global_params_type, & + CVMIX_OVERWRITE_OLD_VAL, & + CVMIX_SUM_OLD_AND_NEW_VALS, & + CVMIX_MAX_OLD_AND_NEW_VALS + use cvmix_put_get, only : cvmix_put + use cvmix_utils, only : cvmix_update_wrap + +!EOP + + implicit none + private + save + +!BOP + +! !PUBLIC MEMBER FUNCTIONS: + + public :: cvmix_init_bkgnd + public :: cvmix_coeffs_bkgnd + public :: cvmix_bkgnd_lvary_horizontal + public :: cvmix_bkgnd_static_Mdiff + public :: cvmix_bkgnd_static_Tdiff + public :: cvmix_put_bkgnd + public :: cvmix_get_bkgnd_real_2D + + interface cvmix_init_bkgnd + module procedure cvmix_init_bkgnd_scalar + module procedure cvmix_init_bkgnd_1D + module procedure cvmix_init_bkgnd_2D + module procedure cvmix_init_bkgnd_BryanLewis_wrap + module procedure cvmix_init_bkgnd_BryanLewis_low + end interface cvmix_init_bkgnd + + interface cvmix_coeffs_bkgnd + module procedure cvmix_coeffs_bkgnd_low + module procedure cvmix_coeffs_bkgnd_wrap + end interface cvmix_coeffs_bkgnd + + interface cvmix_put_bkgnd + module procedure cvmix_put_bkgnd_int + module procedure cvmix_put_bkgnd_real + module procedure cvmix_put_bkgnd_real_1D + module procedure cvmix_put_bkgnd_real_2D + end interface cvmix_put_bkgnd + +! !PUBLIC TYPES: + + ! cvmix_bkgnd_params_type contains the necessary parameters for background + ! mixing. Background mixing fields can vary from level to level as well as + ! over latitude and longitude. + type, public :: cvmix_bkgnd_params_type + private + ! 3D viscosity field (horizontal dimensions are collapsed into first + ! dimension, vertical is second dimension) + real(cvmix_r8), allocatable :: static_Mdiff(:,:) ! ncol, max_nlev+1 + ! units: m^2/s + ! 3D diffusivity field (horizontal dimensions are collapsed into first + ! dimension, vertical is second dimension) + real(cvmix_r8), allocatable :: static_Tdiff(:,:) ! ncol, max_nlev+1 + ! units: m^2/s + + ! Flag for what to do with old values of CVmix_vars%[MTS]diff + integer :: handle_old_vals + + ! Note: need to include some logic to avoid excessive memory use + ! when static_[MT]diff are constant or 1-D + logical :: lvary_vertical ! True => multiple levels + logical :: lvary_horizontal ! True => multiple columns + end type cvmix_bkgnd_params_type + +!EOP + + type(cvmix_bkgnd_params_type), target :: CVmix_bkgnd_params_saved + +contains + +!BOP + +! !IROUTINE: cvmix_init_bkgnd_scalar +! !INTERFACE: + + subroutine cvmix_init_bkgnd_scalar(bkgnd_Tdiff, bkgnd_Mdiff, old_vals, & + CVmix_bkgnd_params_user) + +! !DESCRIPTION: +! Initialization routine for static background mixing coefficients. For each +! column, this routine sets the static viscosity / diffusivity to the given +! scalar constants. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + real(cvmix_r8), intent(in) :: bkgnd_Tdiff + real(cvmix_r8), intent(in) :: bkgnd_Mdiff + character(len=*), optional, intent(in) :: old_vals + +! !OUTPUT PARAMETERS: + type(cvmix_bkgnd_params_type), optional, target, intent(inout) :: & + CVmix_bkgnd_params_user + +!EOP +!BOC + + type(cvmix_bkgnd_params_type), pointer :: CVmix_bkgnd_params_out + + CVmix_bkgnd_params_out => CVmix_bkgnd_params_saved + if (present(CVmix_bkgnd_params_user)) then + CVmix_bkgnd_params_out => CVmix_bkgnd_params_user + end if + + ! Clean up memory in bkgnd_params_type (will be re-allocated in put call) + if (allocated(CVmix_bkgnd_params_out%static_Mdiff)) & + deallocate(CVmix_bkgnd_params_out%static_Mdiff) + if (allocated(CVmix_bkgnd_params_out%static_Tdiff)) & + deallocate(CVmix_bkgnd_params_out%static_Tdiff) + + ! Set static_Mdiff and static_Tdiff in background_input_type + call cvmix_put_bkgnd('static_Mdiff', bkgnd_Mdiff, CVmix_bkgnd_params_user) + call cvmix_put_bkgnd('static_Tdiff', bkgnd_Tdiff, CVmix_bkgnd_params_user) + + if (present(old_vals)) then + select case (trim(old_vals)) + case ("overwrite") + call cvmix_put_bkgnd('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_bkgnd_params_user) + case ("sum") + call cvmix_put_bkgnd('handle_old_vals', CVMIX_SUM_OLD_AND_NEW_VALS, & + cvmix_bkgnd_params_user) + case ("max") + call cvmix_put_bkgnd('handle_old_vals', CVMIX_MAX_OLD_AND_NEW_VALS, & + cvmix_bkgnd_params_user) + case DEFAULT + print*, "ERROR: ", trim(old_vals), " is not a valid option for ", & + "handling old values of diff and visc." + stop 1 + end select + else + call cvmix_put_bkgnd('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_bkgnd_params_user) + end if + +!EOC + + end subroutine cvmix_init_bkgnd_scalar + +!BOP + +! !IROUTINE: cvmix_init_bkgnd_1D +! !INTERFACE: + + subroutine cvmix_init_bkgnd_1D(bkgnd_Tdiff, bkgnd_Mdiff, ncol, old_vals, & + CVmix_params_user, CVmix_bkgnd_params_user) + +! !DESCRIPTION: +! Initialization routine for static background mixing coefficients. For each +! column, this routine sets the static viscosity / diffusivity to the given +! 1D field. If field varies horizontally, need to include ncol! +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + real(cvmix_r8), dimension(:), intent(in) :: bkgnd_Tdiff + real(cvmix_r8), dimension(:), intent(in) :: bkgnd_Mdiff + integer, optional, intent(in) :: ncol + character(len=cvmix_strlen), optional, intent(in) :: old_vals + type(cvmix_global_params_type), optional, target, intent(in) :: & + CVmix_params_user + +! !OUTPUT PARAMETERS: + type(cvmix_bkgnd_params_type), optional, target, intent(inout) :: & + CVmix_bkgnd_params_user +!EOP +!BOC + + ! local vars + integer :: nlev + type(cvmix_global_params_type), pointer :: CVmix_params_in + type(cvmix_bkgnd_params_type), pointer :: CVmix_bkgnd_params_out + + nullify(CVmix_params_in) + if (present(CVmix_params_user)) then + CVmix_params_in => CVmix_params_user + nlev = CVmix_params_in%max_nlev + else + if (.not.present(ncol)) then + print*, "ERROR: You must specify either ncol or a global param type", & + "containing max_nlev!" + stop 1 + end if + endif + + CVmix_bkgnd_params_out => CVmix_bkgnd_params_saved + if (present(CVmix_bkgnd_params_user)) then + CVmix_bkgnd_params_out => CVmix_bkgnd_params_user + end if + + ! NOTE: need to verify that bkgnd_[MT]diff are ncol x 1 or 1 x nlev+1 + + ! Clean up memory in bkgnd_params_type (will be re-allocated in put call) + if (allocated(CVmix_bkgnd_params_out%static_Mdiff)) & + deallocate(CVmix_bkgnd_params_out%static_Mdiff) + if (allocated(CVmix_bkgnd_params_out%static_Tdiff)) & + deallocate(CVmix_bkgnd_params_out%static_Tdiff) + + ! Set static_[MT]diff in background_input_type + if (present(ncol)) then + call cvmix_put_bkgnd('static_Mdiff', bkgnd_Mdiff, & + CVmix_bkgnd_params_user, ncol=ncol) + call cvmix_put_bkgnd('static_Tdiff', bkgnd_Tdiff, & + CVmix_bkgnd_params_user, ncol=ncol) + else + call cvmix_put_bkgnd('static_Mdiff', bkgnd_Mdiff, & + CVmix_bkgnd_params_user, nlev=nlev) + call cvmix_put_bkgnd('static_Tdiff', bkgnd_Tdiff, & + CVmix_bkgnd_params_user, nlev=nlev) + end if + + if (present(old_vals)) then + select case (trim(old_vals)) + case ("overwrite") + call cvmix_put_bkgnd('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_bkgnd_params_user) + case ("sum") + call cvmix_put_bkgnd('handle_old_vals', CVMIX_SUM_OLD_AND_NEW_VALS, & + cvmix_bkgnd_params_user) + case ("max") + call cvmix_put_bkgnd('handle_old_vals', CVMIX_MAX_OLD_AND_NEW_VALS, & + cvmix_bkgnd_params_user) + case DEFAULT + print*, "ERROR: ", trim(old_vals), " is not a valid option for ", & + "handling old values of diff and visc." + stop 1 + end select + else + call cvmix_put_bkgnd('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_bkgnd_params_user) + end if + +!EOC + + end subroutine cvmix_init_bkgnd_1D + +!BOP + +! !IROUTINE: cvmix_init_bkgnd_2D +! !INTERFACE: + + subroutine cvmix_init_bkgnd_2D(bkgnd_Tdiff, bkgnd_Mdiff, ncol, & + CVmix_params_in, old_vals, & + CVmix_bkgnd_params_user) + +! !DESCRIPTION: +! Initialization routine for static background mixing coefficients. For each +! column, this routine sets the static viscosity / diffusivity to the given +! 2D field. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + real(cvmix_r8), dimension(:,:), intent(in) :: bkgnd_Tdiff + real(cvmix_r8), dimension(:,:), intent(in) :: bkgnd_Mdiff + integer, intent(in) :: ncol + character(len=cvmix_strlen), optional, intent(in) :: old_vals + type(cvmix_global_params_type), intent(in) :: CVmix_params_in + +! !OUTPUT PARAMETERS: + type(cvmix_bkgnd_params_type), target, optional, intent(inout) :: & + CVmix_bkgnd_params_user +!EOP +!BOC + + ! local vars + integer :: nlev + type(cvmix_bkgnd_params_type), pointer :: CVmix_bkgnd_params_out + + CVmix_bkgnd_params_out => CVmix_bkgnd_params_saved + if (present(CVmix_bkgnd_params_user)) then + CVmix_bkgnd_params_out => CVmix_bkgnd_params_user + end if + + ! NOTE: need to verify that bkgnd_[MT]diff are ncol x nlev+1 + + nlev = CVmix_params_in%max_nlev + + ! Clean up memory in bkgnd_params_type (will be re-allocated in put call) + if (allocated(CVmix_bkgnd_params_out%static_Mdiff)) & + deallocate(CVmix_bkgnd_params_out%static_Mdiff) + if (allocated(CVmix_bkgnd_params_out%static_Tdiff)) & + deallocate(CVmix_bkgnd_params_out%static_Tdiff) + + ! Set static_[MT]diff in background_input_type + call cvmix_put_bkgnd("static_Mdiff", bkgnd_Mdiff, ncol, nlev, & + CVmix_bkgnd_params_user) + call cvmix_put_bkgnd("static_Tdiff", bkgnd_Tdiff, ncol, nlev, & + CVmix_bkgnd_params_user) + + if (present(old_vals)) then + select case (trim(old_vals)) + case ("overwrite") + call cvmix_put_bkgnd('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_bkgnd_params_user) + case ("sum") + call cvmix_put_bkgnd('handle_old_vals', CVMIX_SUM_OLD_AND_NEW_VALS, & + cvmix_bkgnd_params_user) + case ("max") + call cvmix_put_bkgnd('handle_old_vals', CVMIX_MAX_OLD_AND_NEW_VALS, & + cvmix_bkgnd_params_user) + case DEFAULT + print*, "ERROR: ", trim(old_vals), " is not a valid option for ", & + "handling old values of diff and visc." + stop 1 + end select + else + call cvmix_put_bkgnd('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_bkgnd_params_user) + end if + +!EOC + + end subroutine cvmix_init_bkgnd_2D + +!BOP + +! !IROUTINE: cvmix_init_bkgnd_BryanLewis_wrap +! !INTERFACE: + + subroutine cvmix_init_bkgnd_BryanLewis_wrap(CVmix_vars, bl1, bl2, bl3, bl4, & + CVmix_params_in, old_vals, & + CVmix_bkgnd_params_user) + +! !DESCRIPTION: +! Calls cvmix_init_bkgnd_BryanLewis_low +! +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + ! Contains depth and nlev + type(cvmix_data_type), intent(in) :: CVmix_vars + ! Units are first column if CVmix_data%depth is m, second if cm + real(cvmix_r8), intent(in) :: bl1, &! m^2/s or cm^2/s + bl2, &! m^2/s or cm^2/s + bl3, &! 1/m or 1/cm + bl4 ! m or cm + character(len=cvmix_strlen), optional, intent(in) :: old_vals + type(cvmix_global_params_type), intent(in) :: CVmix_params_in + +! !OUTPUT PARAMETERS: + type(cvmix_bkgnd_params_type), target, optional, intent(inout) :: & + CVmix_bkgnd_params_user +!EOP +!BOC + + call cvmix_init_bkgnd(CVmix_params_in%max_nlev,-CVMix_vars%zw_iface, bl1, & + bl2, bl3, bl4, CVmix_params_in%prandtl, & + old_vals, CVmix_bkgnd_params_user) + +!EOC + + end subroutine cvmix_init_bkgnd_BryanLewis_wrap + +!BOP + +! !IROUTINE: cvmix_coeffs_bkgnd_low +! !INTERFACE: + + subroutine cvmix_init_bkgnd_BryanLewis_low(max_nlev, zw, bl1, bl2, bl3, bl4, & + prandtl, old_vals, CVmix_bkgnd_params_user) + +! !DESCRIPTION: +! Initialization routine for Bryan-Lewis diffusivity/viscosity calculation. +! For each column, this routine sets the static viscosity \& diffusivity +! based on the specified parameters. Note that the units of these parameters +! must be consistent with the units of viscosity and diffusivity -- either +! cgs or mks, but do not mix and match! +! \\ +! \\ +! The Bryan-Lewis parameterization is based on the following: +! \begin{eqnarray*} +! \kappa_{BL} &=& \textrm{bl1} + \frac{\textrm{bl2}}{\pi}\tan^{-1}\bigg( +! \textrm{bl3}(|z|-\textrm{bl4})\bigg)\\ +! \nu_{BL} &=& \textrm{Pr}\cdot\kappa_{BL} +! \end{eqnarray*} +! This method is based on the following paper: +! \begin{quote} +! \emph{A Water Mass Model of the World Ocean}\\ +! K. Bryan and L. J. Lewis\\ +! Journal of Geophysical Research, vol 84 (1979), pages 2503-2517. +! \end{quote} +! +! In that paper, they recommend the parameters +! \begin{itemize} +! \item[] bl1 $= 8 \cdot 10^{-5}$ m$^2/$s +! \item[] bl2 $= 1.05 \cdot 10^{-4}$ m$^2/$s +! \item[] bl3 $= 4.5 \cdot 10^{-3}$ m$^{-1}$ +! \item[] bl4 $= 2500$ m +! \end{itemize} +! However, more recent usage of their scheme may warrant different settings. +! +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + integer, intent(in) :: max_nlev + real(cvmix_r8), dimension(max_nlev+1), intent(in) :: zw + ! Units are first column if CVmix_data%depth is m, second if cm + real(cvmix_r8), intent(in) :: bl1, &! m^2/s or cm^2/s + bl2, &! m^2/s or cm^2/s + bl3, &! 1/m or 1/cm + bl4, &! m or cm + prandtl ! nondim + character(len=cvmix_strlen), optional, intent(in) :: old_vals + +! !OUTPUT PARAMETERS: + type(cvmix_bkgnd_params_type), target, optional, intent(inout) :: & + CVmix_bkgnd_params_user +!EOP +!BOC + + ! Pointers to parameter data type + type(cvmix_bkgnd_params_type), pointer :: CVmix_bkgnd_params_out + + ! Local copies to make code easier to read + real(cvmix_r8), dimension(max_nlev+1) :: Mdiff, Tdiff + + CVmix_bkgnd_params_out => CVmix_bkgnd_params_saved + if (present(CVmix_bkgnd_params_user)) then + CVmix_bkgnd_params_out => CVmix_bkgnd_params_user + end if + + ! Clean up memory in bkgnd_params_type (will be re-allocated in put call) + if (allocated(CVmix_bkgnd_params_out%static_Mdiff)) & + deallocate(CVmix_bkgnd_params_out%static_Mdiff) + if (allocated(CVmix_bkgnd_params_out%static_Tdiff)) & + deallocate(CVmix_bkgnd_params_out%static_Tdiff) + + ! Set static_[MT]diff in background_input_type + Tdiff = bl1 + (bl2/cvmix_PI)*atan(bl3*(zw-bl4)) + Mdiff = prandtl*Tdiff + + call cvmix_put_bkgnd("static_Mdiff", Mdiff, CVmix_bkgnd_params_user, & + nlev=max_nlev) + call cvmix_put_bkgnd("static_Tdiff", Tdiff, CVmix_bkgnd_params_user, & + nlev=max_nlev) + + if (present(old_vals)) then + select case (trim(old_vals)) + case ("overwrite") + call cvmix_put_bkgnd('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_bkgnd_params_user) + case ("sum") + call cvmix_put_bkgnd('handle_old_vals', CVMIX_SUM_OLD_AND_NEW_VALS, & + cvmix_bkgnd_params_user) + case ("max") + call cvmix_put_bkgnd('handle_old_vals', CVMIX_MAX_OLD_AND_NEW_VALS, & + cvmix_bkgnd_params_user) + case DEFAULT + print*, "ERROR: ", trim(old_vals), " is not a valid option for ", & + "handling old values of diff and visc." + stop 1 + end select + else + call cvmix_put_bkgnd('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_bkgnd_params_user) + end if + +!EOC + + end subroutine cvmix_init_bkgnd_BryanLewis_low + +!BOP + +! !IROUTINE: cvmix_coeffs_bkgnd_wrap +! !INTERFACE: + + subroutine cvmix_coeffs_bkgnd_wrap(CVmix_vars, colid, & + CVmix_bkgnd_params_user) + +! !DESCRIPTION: +! Computes vertical tracer and velocity mixing coefficients for static +! background mixing. This routine simply copies viscosity / diffusivity +! values from CVmix\_bkgnd\_params to CVmix\_vars. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + + ! Need to know column for pulling data from static_[MT]diff + integer, optional, intent(in) :: colid + type(cvmix_bkgnd_params_type), target, optional, intent(in) :: & + CVmix_bkgnd_params_user + +! !INPUT/OUTPUT PARAMETERS: + + type(cvmix_data_type), intent(inout) :: CVmix_vars + +!EOP +!BOC + + real(cvmix_r8), dimension(CVmix_vars%max_nlev+1) :: new_Mdiff, new_Tdiff + type(cvmix_bkgnd_params_type), pointer :: CVmix_bkgnd_params_in + integer :: nlev, max_nlev + + CVmix_bkgnd_params_in => CVmix_bkgnd_params_saved + if (present(CVmix_bkgnd_params_user)) then + CVmix_bkgnd_params_in => CVmix_bkgnd_params_user + end if + + nlev = CVmix_vars%nlev + max_nlev = CVmix_vars%max_nlev + + if (.not.associated(CVmix_vars%Mdiff_iface)) & + call cvmix_put(CVmix_vars, "Mdiff", cvmix_zero, max_nlev) + if (.not.associated(CVmix_vars%Tdiff_iface)) & + call cvmix_put(CVmix_vars, "Tdiff", cvmix_zero, max_nlev) + + call cvmix_coeffs_bkgnd(new_Mdiff, new_Tdiff, nlev, max_nlev, colid, & + CVmix_bkgnd_params_user) + call cvmix_update_wrap(CVmix_bkgnd_params_in%handle_old_vals, max_nlev, & + Mdiff_out = CVmix_vars%Mdiff_iface, & + new_Mdiff = new_Mdiff, & + Tdiff_out = CVmix_vars%Tdiff_iface, & + new_Tdiff = new_Tdiff) + +!EOC + + end subroutine cvmix_coeffs_bkgnd_wrap + +!BOP + +! !IROUTINE: cvmix_coeffs_bkgnd_low +! !INTERFACE: + + subroutine cvmix_coeffs_bkgnd_low(Mdiff_out, Tdiff_out, nlev, max_nlev, & + colid, CVmix_bkgnd_params_user) + +! !DESCRIPTION: +! Computes vertical tracer and velocity mixing coefficients for static +! background mixing. This routine simply copies viscosity / diffusivity +! values from CVmix\_bkgnd\_params to CVmix\_vars. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + + ! Need to know column for pulling data from static_[MT]diff + integer, intent(in) :: nlev, & + max_nlev + integer, optional, intent(in) :: colid + type(cvmix_bkgnd_params_type), target, optional, intent(in) :: & + CVmix_bkgnd_params_user + +! !OUTPUT PARAMETERS: + ! Using intent(inout) because memory should already be allocated + real(cvmix_r8), dimension(max_nlev+1), intent(inout) :: Mdiff_out, & + Tdiff_out + +!EOP +!BOC + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer :: kw + + do kw=1,nlev+1 + Mdiff_out(kw) = cvmix_bkgnd_static_Mdiff(CVmix_bkgnd_params_user, kw, & + colid) + Tdiff_out(kw) = cvmix_bkgnd_static_Tdiff(CVmix_bkgnd_params_user, kw, & + colid) + end do + +!EOC + + end subroutine cvmix_coeffs_bkgnd_low + +!BOP + +! !IROUTINE: cvmix_bkgnd_lvary_horizontal +! !INTERFACE: + + function cvmix_bkgnd_lvary_horizontal(CVmix_bkgnd_params_test) + +! !DESCRIPTION: +! Returns whether the background viscosity and diffusivity are +! varying with horizontal position. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_bkgnd_params_type), intent(in) :: CVmix_bkgnd_params_test + +! !OUTPUT PARAMETERS: + logical :: cvmix_bkgnd_lvary_horizontal +!EOP +!BOC + + cvmix_bkgnd_lvary_horizontal = CVmix_bkgnd_params_test%lvary_horizontal + +!EOC + + end function cvmix_bkgnd_lvary_horizontal + +!BOP + +! !IROUTINE: cvmix_bkgnd_static_Mdiff +! !INTERFACE: + + function cvmix_bkgnd_static_Mdiff(CVmix_bkgnd_params_user,kw,colid) + +! !DESCRIPTION: +! Obtain the background diffusivity value at a position in a water column. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_bkgnd_params_type), target, optional, intent(in) :: & + CVmix_bkgnd_params_user + integer, optional, intent(in) :: kw, colid + +! !OUTPUT PARAMETERS: + real(cvmix_r8) :: cvmix_bkgnd_static_Mdiff +!EOP +!BOC + + type(cvmix_bkgnd_params_type), pointer :: CVmix_bkgnd_params_in + integer :: cid, kid + + ! Error check + CVmix_bkgnd_params_in => CVmix_bkgnd_params_saved + if (present(CVmix_bkgnd_params_user)) then + CVmix_bkgnd_params_in => CVmix_bkgnd_params_user + end if + + if (CVmix_bkgnd_params_in%lvary_horizontal) then + if (present(colid)) then + cid = colid + else + print*, "ERROR: need to pass colid when static_Mdiff varies across", & + " columns." + stop 1 + end if + else + cid = 1 + end if + + if (CVmix_bkgnd_params_in%lvary_vertical) then + if (present(kw)) then + kid = kw + else + print*, "ERROR: need to pass kw (level id) when static_Mdiff varies", & + "across levels columns." + stop 1 + end if + else + kid = 1 + end if + + cvmix_bkgnd_static_Mdiff = CVmix_bkgnd_params_in%static_Mdiff(cid, kid) + +!EOC + + end function cvmix_bkgnd_static_Mdiff + +!BOP + +! !IROUTINE: cvmix_bkgnd_static_Tdiff +! !INTERFACE: + + function cvmix_bkgnd_static_Tdiff(CVmix_bkgnd_params_user,kw,colid) + +! !DESCRIPTION: +! Obtain the background diffusivity value at a position in a water column. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_bkgnd_params_type), target, optional, intent(in) :: & + CVmix_bkgnd_params_user + integer, optional, intent(in) :: kw, colid + +! !OUTPUT PARAMETERS: + real(cvmix_r8) :: cvmix_bkgnd_static_Tdiff +!EOP +!BOC + + type(cvmix_bkgnd_params_type), pointer :: CVmix_bkgnd_params_in + integer :: cid, kid + + ! Error che + CVmix_bkgnd_params_in => CVmix_bkgnd_params_saved + if (present(CVmix_bkgnd_params_user)) then + CVmix_bkgnd_params_in => CVmix_bkgnd_params_user + end if + + if (CVmix_bkgnd_params_in%lvary_horizontal) then + if (present(colid)) then + cid = colid + else + print*, "ERROR: need to pass colid when static_Tdiff varies across", & + " columns." + stop 1 + end if + else + cid = 1 + end if + + if (CVmix_bkgnd_params_in%lvary_vertical) then + if (present(kw)) then + kid = kw + else + print*, "ERROR: need to pass kw (level id) when static_Tdiff varies", & + "across levels columns." + stop 1 + end if + else + kid = 1 + end if + + cvmix_bkgnd_static_Tdiff = CVmix_bkgnd_params_in%static_Tdiff(cid, kid) + +!EOC + + end function cvmix_bkgnd_static_Tdiff + +!BOP + +! !IROUTINE: cvmix_put_bkgnd_int +! !INTERFACE: + + subroutine cvmix_put_bkgnd_int(varname, val, CVmix_bkgnd_params_user) + +! !DESCRIPTION: +! Write a real value into a cvmix\_bkgnd\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + integer, intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_bkgnd_params_type), target, optional, intent(inout) :: & + CVmix_bkgnd_params_user + +!EOP +!BOC + + type(cvmix_bkgnd_params_type), pointer :: CVmix_bkgnd_params_out + + CVmix_bkgnd_params_out => CVmix_bkgnd_params_saved + if (present(CVmix_bkgnd_params_user)) then + CVmix_bkgnd_params_out => CVmix_bkgnd_params_user + end if + + select case (trim(varname)) + case ('old_vals', 'handle_old_vals') + CVmix_bkgnd_params_out%handle_old_vals = val + case DEFAULT + call cvmix_put_bkgnd(varname, real(val,cvmix_r8), & + CVmix_bkgnd_params_user) + end select + +!EOC + + end subroutine cvmix_put_bkgnd_int + +!BOP + +! !IROUTINE: cvmix_put_bkgnd_real +! !INTERFACE: + + subroutine cvmix_put_bkgnd_real(varname, val, CVmix_bkgnd_params_user) + +! !DESCRIPTION: +! Write a real value into a cvmix\_bkgnd\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + real(cvmix_r8), intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_bkgnd_params_type), target, optional, intent(inout) :: & + CVmix_bkgnd_params_user + +!EOP +!BOC + + type(cvmix_bkgnd_params_type), pointer :: CVmix_bkgnd_params_out + + CVmix_bkgnd_params_out => CVmix_bkgnd_params_saved + if (present(CVmix_bkgnd_params_user)) then + CVmix_bkgnd_params_out => CVmix_bkgnd_params_user + end if + + select case (trim(varname)) + case ('static_Mdiff') + if (.not.allocated(CVmix_bkgnd_params_out%static_Mdiff)) then + allocate(CVmix_bkgnd_params_out%static_Mdiff(1,1)) + CVmix_bkgnd_params_out%lvary_horizontal=.false. + CVmix_bkgnd_params_out%lvary_vertical=.false. + else + print*, "WARNING: overwriting static_Mdiff!" + end if + CVmix_bkgnd_params_out%static_Mdiff(:,:) = val + + case ('static_Tdiff') + if (.not.allocated(CVmix_bkgnd_params_out%static_Tdiff)) then + allocate(CVmix_bkgnd_params_out%static_Tdiff(1,1)) + CVmix_bkgnd_params_out%lvary_horizontal=.false. + CVmix_bkgnd_params_out%lvary_vertical=.false. + else + print*, "WARNING: overwriting static_Tdiff!" + end if + CVmix_bkgnd_params_out%static_Tdiff(:,:) = val + + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end subroutine cvmix_put_bkgnd_real + +!BOP + +! !IROUTINE: cvmix_put_bkgnd_real_1D +! !INTERFACE: + + subroutine cvmix_put_bkgnd_real_1D(varname, val, CVmix_bkgnd_params_user, & + ncol, nlev) + +! !DESCRIPTION: +! Write an array of real values into a cvmix\_bkgnd\_params\_type variable. +! You must use \verb|opt='horiz'| to specify that the field varies in the +! horizontal direction, otherwise it is assumed to vary in the vertical. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + real(cvmix_r8), dimension(:), intent(in) :: val + integer, optional, intent(in) :: ncol, nlev + +! !OUTPUT PARAMETERS: + type(cvmix_bkgnd_params_type), target, optional, intent(inout) :: & + CVmix_bkgnd_params_user + +!EOP +!BOC + + ! Local vars + integer, dimension(2) :: dims + integer :: data_dims + logical :: lvary_horizontal + + type(cvmix_bkgnd_params_type), pointer :: CVmix_bkgnd_params_out + + ! Error checking to make sure dimension is specified + if ((.not.present(ncol)).and.(.not.present(nlev))) then + print*, "ERROR: when putting 1D data in cvmix_bkgnd_params_type ", & + "you must specify nlev or ncol!" + stop 1 + end if + + if ((present(ncol)).and.(present(nlev))) then + print*, "ERROR: when putting 1D data in cvmix_bkgnd_params_type ", & + "you can not specify both nlev or ncol!" + stop 1 + end if + + CVmix_bkgnd_params_out => CVmix_bkgnd_params_saved + if (present(CVmix_bkgnd_params_user)) then + CVmix_bkgnd_params_out => CVmix_bkgnd_params_user + end if + + data_dims = size(val) + if (present(ncol)) then + if (data_dims.gt.ncol) then + print*, "ERROR: data array is bigger than number of columns specified." + stop 1 + end if + lvary_horizontal=.true. + dims(1) = ncol + dims(2) = 1 + else + if (data_dims.gt.nlev+1) then + print*, "ERROR: data array is bigger than number of levels specified." + stop 1 + end if + lvary_horizontal=.false. + dims(1) = 1 + dims(2) = nlev+1 + end if + + select case (trim(varname)) + case ('static_Mdiff') + if (.not.allocated(CVmix_bkgnd_params_out%static_Mdiff)) then + allocate(CVmix_bkgnd_params_out%static_Mdiff(dims(1),dims(2))) + CVmix_bkgnd_params_out%lvary_horizontal = lvary_horizontal + CVmix_bkgnd_params_out%lvary_vertical = .not.lvary_horizontal + else + print*, "WARNING: overwriting static_Mdiff!" + end if + if (any(shape(CVmix_bkgnd_params_out%static_Mdiff).ne.dims)) then + print*, "ERROR: dimensions of static_Mdiff do not match what was ", & + "sent to cvmix_put" + stop 1 + end if + if (lvary_horizontal) then + CVmix_bkgnd_params_out%static_Mdiff(:,1) = cvmix_zero + CVmix_bkgnd_params_out%static_Mdiff(1:data_dims,1) = val + else + CVmix_bkgnd_params_out%static_Mdiff(1,:) = cvmix_zero + CVmix_bkgnd_params_out%static_Mdiff(1,1:data_dims) = val + end if + + case ('static_Tdiff') + if (.not.allocated(CVmix_bkgnd_params_out%static_Tdiff)) then + allocate(CVmix_bkgnd_params_out%static_Tdiff(dims(1),dims(2))) + CVmix_bkgnd_params_out%lvary_horizontal = lvary_horizontal + CVmix_bkgnd_params_out%lvary_vertical = .not.lvary_horizontal + else + print*, "WARNING: overwriting static_Tdiff!" + end if + if (any(shape(CVmix_bkgnd_params_out%static_Tdiff).ne.dims)) then + print*, "ERROR: dimensions of static_Tdiff do not match what was ", & + "sent to cvmix_put" + stop 1 + end if + if (lvary_horizontal) then + CVmix_bkgnd_params_out%static_Tdiff(:,1) = cvmix_zero + CVmix_bkgnd_params_out%static_Tdiff(1:data_dims,1) = val + else + CVmix_bkgnd_params_out%static_Tdiff(1,:) = cvmix_zero + CVmix_bkgnd_params_out%static_Tdiff(1,1:data_dims) = val + end if + + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end subroutine cvmix_put_bkgnd_real_1D + +!BOP + +! !IROUTINE: cvmix_put_bkgnd_real_2D +! !INTERFACE: + + subroutine cvmix_put_bkgnd_real_2D(varname, val, ncol, nlev, & + CVmix_bkgnd_params_user) + +! !DESCRIPTION: +! Write a 2D array of real values into a cvmix\_bkgnd\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + real(cvmix_r8), dimension(:,:), intent(in) :: val + integer, intent(in) :: ncol, nlev + +! !OUTPUT PARAMETERS: + type(cvmix_bkgnd_params_type), optional, target, intent(inout) :: & + CVmix_bkgnd_params_user + +!EOP +!BOC + + ! Local vars + integer, dimension(2) :: dims, data_dims + type(cvmix_bkgnd_params_type), pointer :: CVmix_bkgnd_params_out + + CVmix_bkgnd_params_out => CVmix_bkgnd_params_saved + if (present(CVmix_bkgnd_params_user)) then + CVmix_bkgnd_params_out => CVmix_bkgnd_params_user + end if + + dims = (/ncol, nlev+1/) + data_dims = shape(val) + + if (any(data_dims.gt.dims)) then + print*, "ERROR: data being put in cvmix_bkgnd_params_type is larger ", & + "than (ncol, nlev+1)" + stop 1 + end if + + select case (trim(varname)) + case ('static_Mdiff') + if (.not.allocated(CVmix_bkgnd_params_out%static_Mdiff)) then + allocate(CVmix_bkgnd_params_out%static_Mdiff(dims(1),dims(2))) + CVmix_bkgnd_params_out%lvary_horizontal=.true. + CVmix_bkgnd_params_out%lvary_vertical=.true. + else + print*, "WARNING: overwriting static_Mdiff!" + end if + if (any(shape(CVmix_bkgnd_params_out%static_Mdiff).ne.dims)) then + print*, "ERROR: dimensions of static_Mdiff do not match what was ", & + "sent to cvmix_put" + stop 1 + end if + CVmix_bkgnd_params_out%static_Mdiff = cvmix_zero + CVmix_bkgnd_params_out%static_Mdiff(1:data_dims(1),1:data_dims(2))= val + + case ('static_Tdiff') + if (.not.allocated(CVmix_bkgnd_params_out%static_Tdiff)) then + allocate(CVmix_bkgnd_params_out%static_Tdiff(dims(1),dims(2))) + CVmix_bkgnd_params_out%lvary_horizontal=.true. + CVmix_bkgnd_params_out%lvary_vertical=.true. + else + print*, "WARNING: overwriting static_Tdiff!" + end if + if (any(shape(CVmix_bkgnd_params_out%static_Tdiff).ne.dims)) then + print*, "ERROR: dimensions of static_Tdiff do not match what was ", & + "sent to cvmix_put" + stop 1 + end if + CVmix_bkgnd_params_out%static_Tdiff = cvmix_zero + CVmix_bkgnd_params_out%static_Tdiff(1:data_dims(1),1:data_dims(2))= val + + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end subroutine cvmix_put_bkgnd_real_2D + +!BOP + +! !IROUTINE: cvmix_get_bkgnd_real_2D +! !INTERFACE: + + function cvmix_get_bkgnd_real_2D(varname, CVmix_bkgnd_params_user) + +! !DESCRIPTION: +! Read the real values of a cvmix\_bkgnd\_params\_type 2D array variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + type(cvmix_bkgnd_params_type), target, optional, intent(in) :: & + CVmix_bkgnd_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8), allocatable, dimension(:,:) :: cvmix_get_bkgnd_real_2D + +!EOP +!BOC + + type(cvmix_bkgnd_params_type), pointer :: CVmix_bkgnd_params_get + integer :: dim1, dim2 + + CVmix_bkgnd_params_get => CVmix_bkgnd_params_saved + if (present(CVmix_bkgnd_params_user)) then + CVmix_bkgnd_params_get => CVmix_bkgnd_params_user + end if + dim1 = size(CVmix_bkgnd_params_get%static_Mdiff,1) + dim2 = size(CVmix_bkgnd_params_get%static_Mdiff,2) + allocate(cvmix_get_bkgnd_real_2D(dim1, dim2)) + + select case (trim(varname)) + case ('static_Mdiff') + cvmix_get_bkgnd_real_2D = CVmix_bkgnd_params_get%static_Mdiff(:,:) + case ('static_Tdiff') + cvmix_get_bkgnd_real_2D = CVmix_bkgnd_params_get%static_Tdiff(:,:) + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + end select + +!EOC + + end function cvmix_get_bkgnd_real_2D + + +end module cvmix_background + diff --git a/parameterizations/CVmix/cvmix_convection.F90 b/parameterizations/CVmix/cvmix_convection.F90 new file mode 100644 index 0000000000..698791689e --- /dev/null +++ b/parameterizations/CVmix/cvmix_convection.F90 @@ -0,0 +1,560 @@ +module cvmix_convection + +!BOP +!\newpage +! !MODULE: cvmix_convection +! +! !AUTHOR: +! Michael N. Levy, NCAR (mlevy@ucar.edu) +! +! !DESCRIPTION: +! This module contains routines to initialize the derived types needed for +! specifying mixing coefficients to parameterize vertical convective mixing, +! and to set the viscosity and diffusivity in gravitationally unstable +! portions of the water column. +!\\ +!\\ +! References:\\ +! * Brunt-Vaisala? +!\\ +!\\ + +! !USES: + use cvmix_kinds_and_types, only : cvmix_r8, & + cvmix_strlen, & + cvmix_zero, & + cvmix_one, & + cvmix_data_type, & + CVMIX_OVERWRITE_OLD_VAL, & + CVMIX_SUM_OLD_AND_NEW_VALS, & + CVMIX_MAX_OLD_AND_NEW_VALS + use cvmix_utils, only : cvmix_update_wrap + use cvmix_put_get, only : cvmix_put + +!EOP + + implicit none + private + save + +!BOP + +! !PUBLIC MEMBER FUNCTIONS: + + public :: cvmix_init_conv + public :: cvmix_coeffs_conv + public :: cvmix_put_conv + public :: cvmix_get_conv_real + + interface cvmix_coeffs_conv + module procedure cvmix_coeffs_conv_low + module procedure cvmix_coeffs_conv_wrap + end interface cvmix_coeffs_conv + + interface cvmix_put_conv + module procedure cvmix_put_conv_int + module procedure cvmix_put_conv_real + module procedure cvmix_put_conv_logical + end interface cvmix_put_conv + +! !PUBLIC TYPES: + + ! cvmix_conv_params_type contains the necessary parameters for convective + ! mixing. + type, public :: cvmix_conv_params_type + private + ! Convective diff + ! diffusivity coefficient used in convective regime + real(cvmix_r8) :: convect_diff ! units: m^2/s + + ! viscosity coefficient used in convective regime + real(cvmix_r8) :: convect_visc ! units: m^2/s + logical :: lBruntVaisala + + ! Threshold for squared buoyancy frequency needed to trigger + ! Brunt-Vaisala parameterization + real(cvmix_r8) :: BVsqr_convect ! units: s^-2 + + ! Only apply below the boundary layer? + logical :: lnoOBL + + ! Flag for what to do with old values of CVmix_vars%[MTS]diff + integer :: handle_old_vals + end type cvmix_conv_params_type + +!EOP + + type(cvmix_conv_params_type), target :: CVmix_conv_params_saved + +contains + +!BOP + +! !IROUTINE: cvmix_init_conv +! !INTERFACE: + + subroutine cvmix_init_conv(convect_diff, convect_visc, lBruntVaisala, & + BVsqr_convect, lnoOBL, old_vals, & + CVmix_conv_params_user) + +! !DESCRIPTION: +! Initialization routine for specifying convective mixing coefficients. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !OUTPUT PARAMETERS: + type (cvmix_conv_params_type), optional, intent(inout) :: & + CVmix_conv_params_user + +! !INPUT PARAMETERS: + real(cvmix_r8), intent(in) :: & + convect_diff, &! diffusivity to parameterize convection + convect_visc ! viscosity to parameterize convection + logical, intent(in), optional :: lBruntVaisala ! True => B-V mixing + real(cvmix_r8), intent(in), optional :: BVsqr_convect ! B-V parameter + logical, intent(in), optional :: lnoOBL ! False => apply in OBL too + character(len=cvmix_strlen), optional, intent(in) :: old_vals + +!EOP +!BOC + + ! Set convect_diff and convect_visc in conv_params_type + call cvmix_put_conv("convect_diff", convect_diff, CVmix_conv_params_user) + call cvmix_put_conv("convect_visc", convect_visc, CVmix_conv_params_user) + + if (present(lBruntVaisala)) then + call cvmix_put_conv("lBruntVaisala", lBruntVaisala, & + CVmix_conv_params_user) + else + call cvmix_put_conv("lBruntVaisala", .false., CVmix_conv_params_user) + end if + + if (present(BVsqr_convect)) then + call cvmix_put_conv("BVsqr_convect", BVsqr_convect, & + CVmix_conv_params_user) + else + call cvmix_put_conv("BVsqr_convect", cvmix_zero, CVmix_conv_params_user) + end if + + if (present(lnoOBL)) then + call cvmix_put_conv("lnoOBL", lnoOBL, CVmix_conv_params_user) + else + call cvmix_put_conv("lnoOBL", .true., CVmix_conv_params_user) + end if + + if (present(old_vals)) then + select case (trim(old_vals)) + case ("overwrite") + call cvmix_put_conv('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_conv_params_user) + case ("sum") + call cvmix_put_conv('handle_old_vals', CVMIX_SUM_OLD_AND_NEW_VALS, & + cvmix_conv_params_user) + case ("max") + call cvmix_put_conv('handle_old_vals', CVMIX_MAX_OLD_AND_NEW_VALS, & + cvmix_conv_params_user) + case DEFAULT + print*, "ERROR: ", trim(old_vals), " is not a valid option for ", & + "handling old values of diff and visc." + stop 1 + end select + else + call cvmix_put_conv('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_conv_params_user) + end if +!EOC + + end subroutine cvmix_init_conv + +!BOP + +! !IROUTINE: cvmix_coeffs_conv_wrap +! !INTERFACE: + + subroutine cvmix_coeffs_conv_wrap(CVmix_vars, CVmix_conv_params_user) + +! !DESCRIPTION: +! Computes vertical diffusion coefficients for convective mixing. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + + type (cvmix_conv_params_type), optional, target, intent(in) :: & + CVmix_conv_params_user + +! !INPUT/OUTPUT PARAMETERS: + type (cvmix_data_type), intent(inout) :: CVmix_vars + +!EOP +!BOC + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + real(cvmix_r8), dimension(CVmix_vars%max_nlev+1) :: new_Mdiff, new_Tdiff + type (cvmix_conv_params_type), pointer :: CVmix_conv_params_in + integer :: nlev, max_nlev + + if (present(CVmix_conv_params_user)) then + CVmix_conv_params_in => CVmix_conv_params_user + else + CVmix_conv_params_in => CVmix_conv_params_saved + end if + + nlev = CVmix_vars%nlev + max_nlev = CVmix_vars%max_nlev + + if (.not.associated(CVmix_vars%Mdiff_iface)) & + call cvmix_put(CVmix_vars, "Mdiff", cvmix_zero, max_nlev) + if (.not.associated(CVmix_vars%Tdiff_iface)) & + call cvmix_put(CVmix_vars, "Tdiff", cvmix_zero, max_nlev) + + call cvmix_coeffs_conv(new_Mdiff, new_Tdiff, & + CVmix_vars%SqrBuoyancyFreq_iface, & + CVmix_vars%WaterDensity_cntr, & + CVmix_vars%AdiabWaterDensity_cntr, & + nlev, max_nlev, nint(CVMix_vars%kOBL_depth)+1, & + CVmix_conv_params_user) + call cvmix_update_wrap(CVmix_conv_params_in%handle_old_vals, max_nlev, & + Mdiff_out = CVmix_vars%Mdiff_iface, & + new_Mdiff = new_Mdiff, & + Tdiff_out = CVmix_vars%Tdiff_iface, & + new_Tdiff = new_Tdiff) + +!EOC + + end subroutine cvmix_coeffs_conv_wrap + +!BOP + +! !IROUTINE: cvmix_coeffs_conv_low +! !INTERFACE: + + subroutine cvmix_coeffs_conv_low(Mdiff_out, Tdiff_out, Nsqr, dens, dens_lwr,& + nlev, max_nlev, OBL_ind, & + CVmix_conv_params_user) + +! !DESCRIPTION: +! Computes vertical diffusion coefficients for convective mixing. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + + integer, intent(in) :: nlev, max_nlev + integer, intent(in) :: OBL_ind + ! max_nlev+1 + real(cvmix_r8), dimension(max_nlev+1), intent(in) :: Nsqr + ! max_nlev + real(cvmix_r8), dimension(max_nlev), intent(in) :: dens, dens_lwr + type (cvmix_conv_params_type), optional, target, intent(in) :: & + CVmix_conv_params_user + +! !INPUT/OUTPUT PARAMETERS: + ! nlev+1 + real(cvmix_r8), dimension(max_nlev+1), intent(inout) :: Mdiff_out, & + Tdiff_out + +!EOP +!BOC + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + real(cvmix_r8) :: convect_mdiff, convect_tdiff, wgt + integer :: kw + logical :: lnoOBL + type (cvmix_conv_params_type), pointer :: CVmix_conv_params_in + + if (present(CVmix_conv_params_user)) then + CVmix_conv_params_in => CVmix_conv_params_user + else + CVmix_conv_params_in => CVmix_conv_params_saved + end if + lnoOBL = CVMix_conv_params_in%lnoOBL + convect_mdiff = CVMix_conv_params_in%convect_visc + convect_tdiff = CVMix_conv_params_in%convect_diff + +!----------------------------------------------------------------------- +! +! enhance the vertical mixing coefficients if gravitationally unstable +! +!----------------------------------------------------------------------- + if (CVmix_conv_params_in%lBruntVaisala) then + ! Brunt-Vaisala mixing based on buoyancy + ! Based on parameter BVsqr_convect + ! diffusivity = convect_diff * wgt + ! viscosity = convect_visc * wgt + + ! For BVsqr_convect < 0: + ! wgt = 0 for N^2 > 0 + ! wgt = 1 for N^2 < BVsqr_convect + ! wgt = [1 - (1-N^2/BVsqr_convect)^2]^3 otherwise + + ! If BVsqr_convect >= 0: + ! wgt = 0 for N^2 > 0 + ! wgt = 1 for N^2 <= 0 + + ! Compute wgt + if (CVmix_conv_params_in%BVsqr_convect.lt.0) then + do kw=1, nlev + wgt = cvmix_zero + if (Nsqr(kw).le.0) then + if (Nsqr(kw).gt.CVmix_conv_params_in%BVsqr_convect) then + wgt = cvmix_one - Nsqr(kw) / CVmix_conv_params_in%BVsqr_convect + wgt = (cvmix_one - wgt**2)**3 + else + wgt = cvmix_one + end if + end if + Mdiff_out(kw) = wgt*cvmix_get_conv_real('convect_visc', & + CVmix_conv_params_in) + Tdiff_out(kw) = wgt*cvmix_get_conv_real('convect_diff', & + CVmix_conv_params_in) + end do + else ! BVsqr_convect >= 0 => step function + do kw=1,nlev + if ((Nsqr(kw).le.0).and.((kw.ge.OBL_ind).or.(.not.lnoOBL))) then + Mdiff_out(kw) = cvmix_get_conv_real('convect_visc', & + CVmix_conv_params_in) + Tdiff_out(kw) = cvmix_get_conv_real('convect_diff', & + CVmix_conv_params_in) + else + Mdiff_out(kw) = cvmix_zero + Tdiff_out(kw) = cvmix_zero + end if + end do + end if + Mdiff_out(nlev+1) = cvmix_zero + Tdiff_out(nlev+1) = cvmix_zero + else + ! Default convection mixing based on density + do kw=1,nlev-1 + if (dens(kw).gt.dens_lwr(kw)) then + if (CVmix_conv_params_in%convect_visc.eq.cvmix_zero) then + ! convection only affects tracers + Mdiff_out(kw+1) = Mdiff_out(kw) + else + Mdiff_out(kw+1) = convect_mdiff + end if + Tdiff_out(kw+1) = convect_tdiff + end if + end do + end if + +!EOC + + end subroutine cvmix_coeffs_conv_low + +!BOP + +! !IROUTINE: cvmix_put_conv_int +! !INTERFACE: + + subroutine cvmix_put_conv_int(varname, val, CVmix_conv_params_user) + +! !DESCRIPTION: +! Write a real value into a cvmix\_conv\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + integer, intent(in) :: val + +! !OUTPUT PARAMETERS: + type (cvmix_conv_params_type), optional, target, intent(inout) :: & + CVmix_conv_params_user + +!EOP +!BOC + + type (cvmix_conv_params_type), pointer :: CVmix_conv_params_out + + if (present(CVmix_conv_params_user)) then + CVmix_conv_params_out => CVmix_conv_params_user + else + CVmix_conv_params_out => CVmix_conv_params_saved + end if + + select case (trim(varname)) + case ("old_vals", "handle_old_vals") + CVmix_conv_params_out%handle_old_vals = val + case DEFAULT + call cvmix_put_conv(varname, real(val, cvmix_r8), & + CVmix_conv_params_user) + end select + +!EOC + + end subroutine cvmix_put_conv_int + +!BOP + +! !IROUTINE: cvmix_put_conv_real +! !INTERFACE: + + subroutine cvmix_put_conv_real(varname, val, CVmix_conv_params_user) + +! !DESCRIPTION: +! Write a real value into a cvmix\_conv\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + real(cvmix_r8), intent(in) :: val + +! !OUTPUT PARAMETERS: + type (cvmix_conv_params_type), optional, target, intent(inout) :: & + CVmix_conv_params_user + +!EOP +!BOC + + type (cvmix_conv_params_type), pointer :: CVmix_conv_params_out + + if (present(CVmix_conv_params_user)) then + CVmix_conv_params_out => CVmix_conv_params_user + else + CVmix_conv_params_out => CVmix_conv_params_saved + end if + + select case (trim(varname)) + case ('convect_diff') + CVmix_conv_params_out%convect_diff = val + case ('convect_visc') + CVmix_conv_params_out%convect_visc = val + case ('BVsqr_convect') + CVmix_conv_params_out%BVsqr_convect = val + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end subroutine cvmix_put_conv_real + +!BOP + +! !IROUTINE: cvmix_put_conv_logical +! !INTERFACE: + + subroutine cvmix_put_conv_logical(varname, val, CVmix_conv_params_user) + +! !DESCRIPTION: +! Write a Boolean value into a cvmix\_conv\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + logical, intent(in) :: val + +! !OUTPUT PARAMETERS: + type (cvmix_conv_params_type), optional, target, intent(inout) :: & + CVmix_conv_params_user + +!EOP +!BOC + + type (cvmix_conv_params_type), pointer :: CVmix_conv_params_out + + if (present(CVmix_conv_params_user)) then + CVmix_conv_params_out => CVmix_conv_params_user + else + CVmix_conv_params_out => CVmix_conv_params_saved + end if + + select case (trim(varname)) + case ('lBruntVaisala') + CVmix_conv_params_out%lBruntVaisala = val + case ('lnoOBL') + CVmix_conv_params_out%lnoOBL = val + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + end select + +!EOC + + end subroutine cvmix_put_conv_logical + +!BOP + +! !IROUTINE: cvmix_get_conv_real +! !INTERFACE: + + function cvmix_get_conv_real(varname, CVmix_conv_params_user) + +! !DESCRIPTION: +! Read the real value of a cvmix\_conv\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + type(cvmix_conv_params_type), optional, target, intent(in) :: & + CVmix_conv_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8) :: cvmix_get_conv_real +!EOP +!BOC + + type(cvmix_conv_params_type), pointer :: CVmix_conv_params_get + + if (present(CVmix_conv_params_user)) then + CVmix_conv_params_get => CVmix_conv_params_user + else + CVmix_conv_params_get => CVmix_conv_params_saved + end if + + cvmix_get_conv_real = cvmix_zero + select case (trim(varname)) + case ('convect_diff') + cvmix_get_conv_real = CVmix_conv_params_get%convect_diff + case ('convect_visc') + cvmix_get_conv_real = CVmix_conv_params_get%convect_visc + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end function cvmix_get_conv_real + +end module cvmix_convection + diff --git a/parameterizations/CVmix/cvmix_ddiff.F90 b/parameterizations/CVmix/cvmix_ddiff.F90 new file mode 100644 index 0000000000..7dfd7bb87a --- /dev/null +++ b/parameterizations/CVmix/cvmix_ddiff.F90 @@ -0,0 +1,668 @@ +module cvmix_ddiff + +!BOP +!\newpage +! !MODULE: cvmix_ddiff +! +! !AUTHOR: +! Michael N. Levy, NCAR (mlevy@ucar.edu) +! +! !DESCRIPTION: +! This module contains routines to initialize the derived types needed for +! double diffusion mixing and to set the diffusivity coefficient +! accordingly. +!\\ +!\\ +! References:\\ +! * RW Schmitt. +! Double Diffusion in Oceanography. +! Annual Review of Fluid Mechanics, 1994.\\ +! * WG Large, JC McWilliams, and SC Doney. +! Oceanic Vertical Mixing: A Review and a Model with a Nonlocal Boundary Layer +! Parameterization. +! Review of Geophysics, 1994.\\ +! * G Danabasoglu, WG Large, JJ Tribbia, PR Gent, BP Briegleb, and JC +! McWilliams. +! Diurnal Coupling in the Tropical Oceans of CCSM3. +! Journal of Climate, 2006. +!\\ +!\\ + +! !USES: + + use cvmix_kinds_and_types, only : cvmix_r8, & + cvmix_strlen, & + cvmix_zero, & + cvmix_one, & + cvmix_data_type, & + CVMIX_OVERWRITE_OLD_VAL, & + CVMIX_SUM_OLD_AND_NEW_VALS, & + CVMIX_MAX_OLD_AND_NEW_VALS + use cvmix_put_get, only : cvmix_put + use cvmix_utils, only : cvmix_update_wrap + +!EOP + + implicit none + private + save + +!BOP + +! !PUBLIC MEMBER FUNCTIONS: + + public :: cvmix_init_ddiff + public :: cvmix_coeffs_ddiff + public :: cvmix_put_ddiff + public :: cvmix_get_ddiff_real + + interface cvmix_coeffs_ddiff + module procedure cvmix_coeffs_ddiff_low + module procedure cvmix_coeffs_ddiff_wrap + end interface cvmix_coeffs_ddiff + + interface cvmix_put_ddiff + module procedure cvmix_put_ddiff_str + module procedure cvmix_put_ddiff_real + module procedure cvmix_put_ddiff_int + end interface cvmix_put_ddiff + +! !PUBLIC TYPES: + + ! cvmix_ddiff_params_type contains the necessary parameters for double + ! diffusion mixing + type, public :: cvmix_ddiff_params_type + private + ! Max value of the stratification parameter (diffusivity = 0 for values + ! that exceed this constant). R_p^0 in LMD94. + real(cvmix_r8) :: strat_param_max ! units: unitless + + ! Type of diffusive convection to use + ! Options are Marmorino and Caldwell 1976 ("MC76"; default) + ! and Kelley 1988, 1990 ("K90") + character(len=cvmix_strlen) :: diff_conv_type + + ! leading coefficient in formula for salt-fingering regime for salinity + ! diffusion (nu_f in LMD94, kappa_0 in Gokhan's paper) + real(cvmix_r8) :: kappa_ddiff_s ! units: m^2/s + + ! interior exponent in salt-fingering regime formula (2 in LMD94, 1 in + ! Gokhan's paper) + real(cvmix_r8) :: ddiff_exp1 ! units: unitless + + ! exterior exponent in salt-fingering regime formula (p2 in LMD94, 3 in + ! Gokhan's paper) + real(cvmix_r8) :: ddiff_exp2 ! units: unitless + + ! Exterior coefficient in diffusive convection regime (0.909 in LMD94) + real(cvmix_r8) :: kappa_ddiff_param1 ! units: unitless + + ! Middle coefficient in diffusive convection regime (4.6 in LMD94) + real(cvmix_r8) :: kappa_ddiff_param2 ! units: unitless + + ! Interior coefficient in diffusive convection regime (-0.54 in LMD94) + real(cvmix_r8) :: kappa_ddiff_param3 ! units: unitless + + ! Molecular diffusivity (leading coefficient in diffusive convection + ! regime) + real(cvmix_r8) :: mol_diff ! units: m^2/s + + ! Flag for what to do with old values of CVmix_vars%[MTS]diff + integer :: handle_old_vals + + end type cvmix_ddiff_params_type + +!EOP + + type(cvmix_ddiff_params_type), target :: CVmix_ddiff_params_saved + + contains + +!BOP + +! !IROUTINE: cvmix_init_ddiff +! !INTERFACE: + + subroutine cvmix_init_ddiff(CVmix_ddiff_params_user, strat_param_max, & + kappa_ddiff_s, ddiff_exp1, ddiff_exp2, mol_diff, & + kappa_ddiff_param1, kappa_ddiff_param2, & + kappa_ddiff_param3, diff_conv_type, old_vals) + +! !DESCRIPTION: +! Initialization routine for double diffusion mixing. This mixing technique +! looks for two unstable cases in a column - salty water over fresher +! water and colder water over warmer water - and computes different +! diffusivity coefficients in each of these two locations. The parameter +! \begin{eqnarray*} +! R_\rho = \frac{\alpha (\partial \Theta / \partial z)} +! {\beta (\partial S / \partial z)} +! \end{eqnarray*} +! to determine as a stratification parameter. If $(\partial S / \partial z)$ +! is positive and $1 < R_\rho < R_\rho^0$ then salt water sits on top +! of fresh water and the diffusivity is given by +! \begin{eqnarray*} +! \kappa = \kappa^0 \left[ 1 - \left(\frac{R_\rho - 1}{R_\rho^0 - 1} \right)^{p_1}\right]^{p_2} +! \end{eqnarray*} +! By default, $R_\rho^0 = 2.55$, but that can be changed by setting +! \verb|strat_param_max| in the code. Similarly, by default $p_1 = 1$ +! (\verb|ddiff_exp1|), $p_2 = 3$ (\verb|ddiff_exp2|), and +! \begin{eqnarray*} +! \kappa^0 = \left\{ \begin{array}{r l} +! 7 \cdot 10^{-5}\ \textrm{m}^2\textrm{/s} & \textrm{for temperature} +! \ (0.7 \cdot \verb|kappa_ddiff_s|\ \textrm{in this routine})\\ +! 10^{-4}\ \textrm{m}^2\textrm{/s} & \textrm{for salinity and other tracers} +! \ (\verb|kappa_ddiff_s|\ \textrm{in this routine}). +! \end{array} \right. +! \end{eqnarray*} +! On the other hand, if $(\partial \Theta / \partial z)$ is negative and +! $0 < R_\rho < 1$ then cold water sits on warm warm water and the +! diffusivity for temperature is given by +! \begin{eqnarray*} +! \kappa = \nu_\textrm{molecular} \cdot 0.909\exp\left\{ 4.6\exp\left[ +! -0.54\left( \frac{1}{R_\rho} - 1 \right) \right] \right\} +! \end{eqnarray*} +! where $\nu_\textrm{molecular}$ Is the molecular viscosity of water. By default it +! is set to $1.5 \cdot 10^{-6}\ \textrm{m}^2\textrm{/s}$, but it can be changed +! through \verb|mol_diff| in the code. Similarly, 0.909, 4.6, and -0.54 are the +! default values of \verb|kappa_ddiff_param1|, \verb|kappa_ddiff_param2|, and +! \verb|kappa_ddiff_param3|, respectively.\\ +!\\ +! For salinity and other tracers, $\kappa$ above is multiplied by the factor +! \begin{eqnarray*} +! \textrm{factor} = \left\{ \begin{array}{c l} +! 0.15R_\rho & R_\rho < 0.5\\ +! 1.85R_\rho - 0.85 & 0.5 \le R_\rho < 1\\ +! \end{array} \right. +! \end{eqnarray*} +! $\kappa$ is stored in \verb|CVmix_vars%diff_iface(:,1)|, while the modified value +! for non-temperature tracers is stored in \verb|CVmix_vars%diff_iface(:,2)|. +! Note that CVMix assumes units are |'mks'|.\\ +!\\ +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + real(cvmix_r8), optional, intent(in) :: strat_param_max, & + kappa_ddiff_s, & + ddiff_exp1, & + ddiff_exp2, & + mol_diff, & + kappa_ddiff_param1, & + kappa_ddiff_param2, & + kappa_ddiff_param3 + character(len=*), optional, intent(in) :: diff_conv_type, old_vals + +! !OUTPUT PARAMETERS: + type(cvmix_ddiff_params_type), optional, target, intent(inout) :: & + CVmix_ddiff_params_user +!EOP +!BOC + + ! Unitless parameters + if (present(strat_param_max)) then + call cvmix_put_ddiff("strat_param_max", strat_param_max, & + CVmix_ddiff_params_user) + else + call cvmix_put_ddiff("strat_param_max", 2.55_cvmix_r8, & + CVmix_ddiff_params_user) + end if + + if (present(diff_conv_type)) then + call cvmix_put_ddiff("diff_conv_type", diff_conv_type, & + CVmix_ddiff_params_user) + else + call cvmix_put_ddiff("diff_conv_type", "MC76", CVmix_ddiff_params_user) + end if + + if (present(ddiff_exp1)) then + call cvmix_put_ddiff("ddiff_exp1", ddiff_exp1, CVmix_ddiff_params_user) + else + call cvmix_put_ddiff("ddiff_exp1", cvmix_one, CVmix_ddiff_params_user) + end if + + if (present(ddiff_exp2)) then + call cvmix_put_ddiff("ddiff_exp2", ddiff_exp2, CVmix_ddiff_params_user) + else + call cvmix_put_ddiff("ddiff_exp2", 3, CVmix_ddiff_params_user) + end if + + if (present(kappa_ddiff_param1)) then + call cvmix_put_ddiff("kappa_ddiff_param1", kappa_ddiff_param1, & + CVmix_ddiff_params_user) + else + call cvmix_put_ddiff("kappa_ddiff_param1", 0.909_cvmix_r8, & + CVmix_ddiff_params_user) + end if + + if (present(kappa_ddiff_param2)) then + call cvmix_put_ddiff("kappa_ddiff_param2", kappa_ddiff_param2, & + CVmix_ddiff_params_user) + else + call cvmix_put_ddiff("kappa_ddiff_param2", 4.6_cvmix_r8, & + CVmix_ddiff_params_user) + end if + + if (present(kappa_ddiff_param3)) then + call cvmix_put_ddiff("kappa_ddiff_param3", kappa_ddiff_param3, & + CVmix_ddiff_params_user) + else + call cvmix_put_ddiff("kappa_ddiff_param3", -0.54_cvmix_r8, & + CVmix_ddiff_params_user) + end if + + ! Parameters with physical units + if (present(kappa_ddiff_s)) then + call cvmix_put_ddiff("kappa_ddiff_s", kappa_ddiff_s, & + CVmix_ddiff_params_user) + else + call cvmix_put_ddiff("kappa_ddiff_s", 1e-4_cvmix_r8, & + CVmix_ddiff_params_user) + end if + + if (present(mol_diff)) then + call cvmix_put_ddiff("mol_diff", mol_diff, CVmix_ddiff_params_user) + else + call cvmix_put_ddiff("mol_diff", 1.5e-6_cvmix_r8, & + CVmix_ddiff_params_user) + end if + + if (present(old_vals)) then + select case (trim(old_vals)) + case ("overwrite") + call cvmix_put_ddiff('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_ddiff_params_user) + case ("sum") + call cvmix_put_ddiff('handle_old_vals', CVMIX_SUM_OLD_AND_NEW_VALS, & + cvmix_ddiff_params_user) + case ("max") + call cvmix_put_ddiff('handle_old_vals', CVMIX_MAX_OLD_AND_NEW_VALS, & + cvmix_ddiff_params_user) + case DEFAULT + print*, "ERROR: ", trim(old_vals), " is not a valid option for ", & + "handling old values of diff and visc." + stop 1 + end select + else + call cvmix_put_ddiff('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_ddiff_params_user) + end if + +!EOC + + end subroutine cvmix_init_ddiff + +!BOP + +! !IROUTINE: cvmix_coeffs_ddiff +! !INTERFACE: + + subroutine cvmix_coeffs_ddiff_wrap(CVmix_vars, CVmix_ddiff_params_user) + +! !DESCRIPTION: +! Computes vertical diffusion coefficients for the double diffusion mixing +! parameterization. +!\\ +!\\ +! +! !USES: +! only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_ddiff_params_type), optional, target, intent(in) :: & + CVmix_ddiff_params_user + +! !INPUT/OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars + +!EOP +!BOC + + real(cvmix_r8), dimension(CVmix_vars%max_nlev+1) :: new_Tdiff, new_Sdiff + integer :: nlev, max_nlev + type(cvmix_ddiff_params_type), pointer :: CVmix_ddiff_params_in + + if (present(CVmix_ddiff_params_user)) then + CVmix_ddiff_params_in => CVmix_ddiff_params_user + else + CVmix_ddiff_params_in => CVmix_ddiff_params_saved + end if + nlev = CVmix_vars%nlev + max_nlev = CVmix_vars%max_nlev + + if (.not.associated(CVmix_vars%Tdiff_iface)) & + call cvmix_put(CVmix_vars, "Tdiff", cvmix_zero, max_nlev) + if (.not.associated(CVmix_vars%Sdiff_iface)) & + call cvmix_put(CVmix_vars, "Sdiff", cvmix_zero, max_nlev) + + call cvmix_coeffs_ddiff(new_Tdiff, new_Sdiff, CVmix_vars%strat_param_num, & + CVmix_vars%strat_param_denom, nlev, max_nlev, & + CVmix_ddiff_params_user) + call cvmix_update_wrap(CVmix_ddiff_params_in%handle_old_vals, max_nlev, & + Tdiff_out = CVmix_vars%Tdiff_iface, & + new_Tdiff = new_Tdiff, & + Sdiff_out = CVmix_vars%Sdiff_iface, & + new_Sdiff = new_Sdiff) + +!EOC + + end subroutine cvmix_coeffs_ddiff_wrap + +!BOP + +! !IROUTINE: cvmix_coeffs_ddiff_low +! !INTERFACE: + + subroutine cvmix_coeffs_ddiff_low(Tdiff_out, Sdiff_out, strat_param_num, & + strat_param_denom, nlev, max_nlev, & + CVmix_ddiff_params_user) + +! !DESCRIPTION: +! Computes vertical diffusion coefficients for the double diffusion mixing +! parameterization. +!\\ +!\\ +! +! !USES: +! only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_ddiff_params_type), optional, target, intent(in) :: & + CVmix_ddiff_params_user + integer, intent(in) :: nlev, max_nlev + real(cvmix_r8), dimension(max_nlev), intent(in) :: strat_param_num, & + strat_param_denom + +! !INPUT/OUTPUT PARAMETERS: + real(cvmix_r8), dimension(max_nlev+1), intent(inout) :: Tdiff_out, & + Sdiff_out + +! !LOCAL VARIABLES: + integer :: k + real(cvmix_r8) :: ddiff, Rrho + +!EOP +!BOC + + type(cvmix_ddiff_params_type), pointer :: CVmix_ddiff_params_in + + if (present(CVmix_ddiff_params_user)) then + CVmix_ddiff_params_in => CVmix_ddiff_params_user + else + CVmix_ddiff_params_in => CVmix_ddiff_params_saved + end if + + ! Determine coefficients + Tdiff_out=cvmix_zero + Sdiff_out=cvmix_zero + do k = 1, nlev + if ((strat_param_num(k).ge.strat_param_denom(k)).and. & + (strat_param_denom(k).gt.cvmix_zero)) then + ! Rrho > 1 and dS/dz < 0 => Salt fingering + Rrho = strat_param_num(k) / strat_param_denom(k) + if (Rrho.lt.CVmix_ddiff_params_in%strat_param_max) then + ddiff = (cvmix_one - ((Rrho-cvmix_one)/ & + (CVmix_ddiff_params_in%strat_param_max-cvmix_one))** & + CVmix_ddiff_params_in%ddiff_exp1)**CVmix_ddiff_params_in%ddiff_exp2 + Sdiff_out(k) = CVmix_ddiff_params_in%kappa_ddiff_s*ddiff + end if + Tdiff_out(k) = Sdiff_out(k)*0.7_cvmix_r8 + end if + if ((strat_param_num(k).ge.strat_param_denom(k)).and. & + (strat_param_num(k).lt.cvmix_zero)) then + ! Rrho < 1 and dT/dz > 0 => Diffusive convection + Rrho = strat_param_num(k) / strat_param_denom(k) + select case (trim(CVmix_ddiff_params_in%diff_conv_type)) + case ("MC76") + ddiff = CVmix_ddiff_params_in%mol_diff * & + CVmix_ddiff_params_in%kappa_ddiff_param1 * & + exp(CVmix_ddiff_params_in%kappa_ddiff_param2*exp( & + CVmix_ddiff_params_in%kappa_ddiff_param3* & + (cvmix_one/Rrho-cvmix_one))) + case ("K88") + ddiff = CVmix_ddiff_params_in%mol_diff * 8.7_cvmix_r8 * & + (Rrho**1.1_cvmix_r8) + case DEFAULT + print*, "ERROR: ", trim(CVmix_ddiff_params_in%diff_conv_type), & + " is not a valid value for diff_conv_type" + stop 1 + end select + Tdiff_out(k) = ddiff + if (Rrho.lt.0.5_cvmix_r8) then + Sdiff_out(k) = 0.15_cvmix_r8*Rrho*ddiff + else + Sdiff_out(k) = (1.85_cvmix_r8*Rrho-0.85_cvmix_r8)*ddiff + end if + end if + end do + Tdiff_out(nlev+1) = cvmix_zero + Sdiff_out(nlev+1) = cvmix_zero + +!EOC + + end subroutine cvmix_coeffs_ddiff_low + +!BOP + +! !IROUTINE: cvmix_put_ddiff_str +! !INTERFACE: + + subroutine cvmix_put_ddiff_str(varname, val, CVmix_ddiff_params_user) + +! !DESCRIPTION: +! Write a string value into a cvmix\_ddiff\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname, val + +! !OUTPUT PARAMETERS: + type(cvmix_ddiff_params_type), optional, target, intent(inout) :: & + CVmix_ddiff_params_user +!EOP +!BOC + + type(cvmix_ddiff_params_type), pointer :: CVmix_ddiff_params_out + + if (present(CVmix_ddiff_params_user)) then + CVmix_ddiff_params_out => CVmix_ddiff_params_user + else + CVmix_ddiff_params_out => CVmix_ddiff_params_saved + end if + + select case (trim(varname)) + case ('diff_conv_type') + select case (trim(val)) + case ('MC76') + CVmix_ddiff_params_out%diff_conv_type = 'MC76' + case ('K88') + CVmix_ddiff_params_out%diff_conv_type = 'K88' + case DEFAULT + print*, "ERROR: ", trim(val), & + " is not a valid value for diff_conv_type" + stop 1 + end select + + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end subroutine cvmix_put_ddiff_str + +!BOP + +! !IROUTINE: cvmix_put_ddiff_real +! !INTERFACE: + + subroutine cvmix_put_ddiff_real(varname, val, CVmix_ddiff_params_user) + +! !DESCRIPTION: +! Write a real value into a cvmix\_ddiff\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + real(cvmix_r8), intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_ddiff_params_type), optional, target, intent(inout) :: & + CVmix_ddiff_params_user +!EOP +!BOC + + type(cvmix_ddiff_params_type), pointer :: CVmix_ddiff_params_out + + if (present(CVmix_ddiff_params_user)) then + CVmix_ddiff_params_out => CVmix_ddiff_params_user + else + CVmix_ddiff_params_out => CVmix_ddiff_params_saved + end if + + select case (trim(varname)) + case ('strat_param_max') + CVmix_ddiff_params_out%strat_param_max = val + case ('ddiff_exp1') + CVmix_ddiff_params_out%ddiff_exp1 = val + case ('ddiff_exp2') + CVmix_ddiff_params_out%ddiff_exp2 = val + case ('kappa_ddiff_param1') + CVmix_ddiff_params_out%kappa_ddiff_param1 = val + case ('kappa_ddiff_param2') + CVmix_ddiff_params_out%kappa_ddiff_param2 = val + case ('kappa_ddiff_param3') + CVmix_ddiff_params_out%kappa_ddiff_param3 = val + case ('kappa_ddiff_s') + CVmix_ddiff_params_out%kappa_ddiff_s = val + case ('mol_diff') + CVmix_ddiff_params_out%mol_diff = val + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end subroutine cvmix_put_ddiff_real + +!BOP + +! !IROUTINE: cvmix_put_ddiff_int +! !INTERFACE: + + subroutine cvmix_put_ddiff_int(varname, val, CVmix_ddiff_params_user) + +! !DESCRIPTION: +! Write an integer value into a cvmix\_ddiff\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + integer, intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_ddiff_params_type), optional, target, intent(inout) :: & + CVmix_ddiff_params_user + +!EOP +!BOC + + type(cvmix_ddiff_params_type), pointer :: CVmix_ddiff_params_out + + if (present(CVmix_ddiff_params_user)) then + CVmix_ddiff_params_out => CVmix_ddiff_params_user + else + CVmix_ddiff_params_out => CVmix_ddiff_params_saved + end if + + select case (trim(varname)) + case ('old_vals', 'handle_old_vals') + CVmix_ddiff_params_out%handle_old_vals = val + case DEFAULT + call cvmix_put_ddiff(varname, real(val,cvmix_r8), & + CVmix_ddiff_params_user) + end select + +!EOC + + end subroutine cvmix_put_ddiff_int + +!BOP + +! !IROUTINE: cvmix_get_ddiff_real +! !INTERFACE: + + function cvmix_get_ddiff_real(varname, CVmix_ddiff_params_user) + +! !DESCRIPTION: +! Return the real value of a cvmix\_ddiff\_params\_type variable. +! NOTE: This function is not efficient and is only for infrequent +! queries of ddiff parameters, such as at initialization. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + type(cvmix_ddiff_params_type), optional, target, intent(inout) :: & + CVmix_ddiff_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8) :: cvmix_get_ddiff_real +!EOP +!BOC + + type(cvmix_ddiff_params_type), pointer :: CVmix_ddiff_params_get + + if (present(CVmix_ddiff_params_user)) then + CVmix_ddiff_params_get => CVmix_ddiff_params_user + else + CVmix_ddiff_params_get => CVmix_ddiff_params_saved + end if + + cvmix_get_ddiff_real = cvmix_zero + select case (trim(varname)) + case ('strat_param_max') + cvmix_get_ddiff_real = CVmix_ddiff_params_get%strat_param_max + case ('ddiff_exp1') + cvmix_get_ddiff_real = CVmix_ddiff_params_get%ddiff_exp1 + case ('ddiff_exp2') + cvmix_get_ddiff_real = CVmix_ddiff_params_get%ddiff_exp2 + case ('kappa_ddiff_param1') + cvmix_get_ddiff_real = CVmix_ddiff_params_get%kappa_ddiff_param1 + case ('kappa_ddiff_param2') + cvmix_get_ddiff_real = CVmix_ddiff_params_get%kappa_ddiff_param2 + case ('kappa_ddiff_param3') + cvmix_get_ddiff_real = CVmix_ddiff_params_get%kappa_ddiff_param3 + case ('kappa_ddiff_s') + cvmix_get_ddiff_real = CVmix_ddiff_params_get%kappa_ddiff_s + case ('mol_diff') + cvmix_get_ddiff_real = CVmix_ddiff_params_get%mol_diff + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end function cvmix_get_ddiff_real + +end module cvmix_ddiff diff --git a/parameterizations/CVmix/cvmix_kinds_and_types.F90 b/parameterizations/CVmix/cvmix_kinds_and_types.F90 new file mode 100644 index 0000000000..a8682db745 --- /dev/null +++ b/parameterizations/CVmix/cvmix_kinds_and_types.F90 @@ -0,0 +1,217 @@ +!BOI + +! !TITLE: In-code documentation for CVMix +! !AUTHORS: Many contributors from GFDL, LANL, and NCAR +! !AFFILIATION: GFDL, LANL, and NCAR +! !DATE: \today + +!EOI + +module cvmix_kinds_and_types + +!BOP +! !MODULE: cvmix_kinds_and_types +! +! !AUTHOR: +! Michael Levy, NCAR (mlevy@ucar.edu) +! +! !DESCRIPTION: +! This module contains the declarations for all required vertical mixing +! data types. It also contains several global parameters used by the cvmix +! package, such as kind numbers and string lengths. +! \\ +! \\ + +! !USES: +! uses no other modules +!EOP + + implicit none + private + save + +!BOP + +! !DEFINED PARAMETERS: + + ! Kind Types: + ! The cvmix package uses double precision for floating point computations. + integer, parameter, public :: cvmix_r8 = selected_real_kind(15, 307), & + cvmix_log_kind = kind(.true.), & + cvmix_strlen = 256 + + ! Parameters to allow CVMix to store integers instead of strings + integer, parameter, public :: CVMIX_OVERWRITE_OLD_VAL = 1 + integer, parameter, public :: CVMIX_SUM_OLD_AND_NEW_VALS = 2 + integer, parameter, public :: CVMIX_MAX_OLD_AND_NEW_VALS = 3 + + ! Global parameters: + ! The constant 1 is used repeatedly in PP and double-diff mixing. + ! The value for pi is needed for Bryan-Lewis mixing. + real(cvmix_r8), parameter, public :: cvmix_zero = real(0,cvmix_r8), & + cvmix_one = real(1,cvmix_r8) + real(cvmix_r8), parameter, public :: cvmix_PI = & + 3.14159265358979323846_cvmix_r8 + +! !PUBLIC TYPES: + + ! cvmix_data_type contains variables for time-dependent and column-specific + ! mixing. Time-independent physical parameters should be stored in + ! cvmix_global_params_type and *-mixing specific parameters should be + ! stored in cvmix_*_params_type (found in the cvmix_* module). + type, public :: cvmix_data_type + integer :: nlev = -1 ! Number of active levels in column + integer :: max_nlev = -1 ! Number of levels in column + ! Setting defaults to -1 might be F95... + + ! Scalar quantities + ! ----------------- + ! distance from sea level to ocean bottom (positive => below sea level) + real(cvmix_r8) :: OceanDepth + ! units: m + ! distance from sea level to OBL bottom (positive => below sea level) + real(cvmix_r8) :: BoundaryLayerDepth + ! units: m + ! sea surface height (positive => above sea level) + real(cvmix_r8) :: SeaSurfaceHeight + ! units: m + ! turbulent friction velocity at surface + real(cvmix_r8) :: SurfaceFriction + ! units: m/s + ! buoyancy forcing at surface + real(cvmix_r8) :: SurfaceBuoyancyForcing + ! units: m^2 s^-3 + ! latitude of column + real(cvmix_r8) :: lat + ! units: degrees + ! longitude of column + real(cvmix_r8) :: lon + ! units: degrees + ! Coriolis parameter + real(cvmix_r8) :: Coriolis + ! units: s^-1 + ! Index of cell containing OBL (fraction > .5 => below cell center) + real(cvmix_r8) :: kOBL_depth + ! units: unitless + ! Langmuir mixing induced enhancement factor to turbulent velocity scale + real(cvmix_r8) :: LangmuirEnhancementFactor + ! units: unitless + ! Langmuir number + real(cvmix_r8) :: LangmuirNumber + ! units: unitless + ! A time-invariant coefficient needed for Simmons, et al. tidal mixing + real(cvmix_r8) :: SimmonsCoeff + + ! Values on interfaces (dimsize = nlev+1) + ! -------------------- + ! height of interfaces in column (positive up => most are negative) + real(cvmix_r8), dimension(:), pointer :: zw_iface => NULL() + ! units: m + + ! distance between neighboring cell centers (first value is top of ocean to + ! middle of first cell, last value is middle of last cell to ocean bottom + real(cvmix_r8), dimension(:), pointer :: dzw => NULL() + ! units: m + + ! diffusivity coefficients at interfaces + ! different coefficients for momentum (Mdiff), temperature (Tdiff), and + ! salinity / non-temp tracers (Sdiff) + real(cvmix_r8), dimension(:), pointer :: Mdiff_iface => NULL() + real(cvmix_r8), dimension(:), pointer :: Tdiff_iface => NULL() + real(cvmix_r8), dimension(:), pointer :: Sdiff_iface => NULL() + ! units: m^2/s + + ! shear Richardson number at column interfaces + real(cvmix_r8), dimension(:), pointer :: ShearRichardson_iface => NULL() + ! units: unitless + + ! For tidal mixing, we need the squared buoyancy frequency and vertical + ! deposition function + real(cvmix_r8), dimension(:), pointer :: SqrBuoyancyFreq_iface => NULL() + ! units: s^-2 + real(cvmix_r8), dimension(:), pointer :: VertDep_iface => NULL() + ! units: unitless + + ! A time-dependent coefficient needed for Schmittner 2014 + real(cvmix_r8), dimension(:), pointer :: SchmittnerCoeff => NULL() + + ! A time-invariant coefficient needed in Schmittner tidal mixing + real(cvmix_r8), dimension(:), pointer :: SchmittnerSouthernOcean => NULL() + + ! Another time-invariant coefficient needed in Schmittner tidal mixing + real(cvmix_r8), dimension(:,:), pointer :: exp_hab_zetar => NULL() + + + + ! For KPP, need to store non-local transport term + real(cvmix_r8), dimension(:), pointer :: kpp_Tnonlocal_iface => NULL() + real(cvmix_r8), dimension(:), pointer :: kpp_Snonlocal_iface => NULL() + ! units: unitless (see note below) + ! Note that kpp_transport_iface is the value of K_x*gamma_x/flux_x: in + ! other words, the user must multiply this value by either the freshwater + ! flux or the penetrative shortwave heat flux to come the values in Eqs. + ! (7.128) and (7.129) of the CVMix manual. + ! Currently only provide nonlocal term for temperature tracer and salinity + ! (non-temperature) tracers. Eventually may add support for momentum terms + ! (would be 2D for x- and y-, respectively) but current implementation + ! assumes momentum term is 0 everywhere. + + ! Values at tracer points (dimsize = nlev) + ! ----------------------- + ! height of cell centers in column (positive up => most are negative) + real(cvmix_r8), dimension(:), pointer :: zt_cntr => NULL() + ! units: m + + ! level thicknesses (positive semi-definite) + real(cvmix_r8), dimension(:), pointer :: dzt => NULL() + ! units: m + + ! Two density values are stored: the actual density of water at a given + ! level and the the density of water after adiabatic displacement to the + ! level below where the water actually is + real(cvmix_r8), dimension(:), pointer :: WaterDensity_cntr => NULL() + real(cvmix_r8), dimension(:), pointer :: AdiabWaterDensity_cntr => NULL() + ! units: kg m^-3 + + ! bulk Richardson number + real(cvmix_r8), dimension(:), pointer :: BulkRichardson_cntr => NULL() + ! units: unitless + + ! For double diffusion mixing, we need to calculate the stratification + ! parameter R_rho. Since the denominator of this ratio may be zero, we + ! store the numerator and denominator separately and make sure the + ! denominator is non-zero before performing the division. + real(cvmix_r8), dimension(:), pointer :: strat_param_num => NULL() + real(cvmix_r8), dimension(:), pointer :: strat_param_denom => NULL() + ! units: unitless + + ! For KPP we need velocity (in both x direction and y direction) + real(cvmix_r8), dimension(:), pointer :: Vx_cntr => NULL() + real(cvmix_r8), dimension(:), pointer :: Vy_cntr => NULL() + ! units: m/s + end type cvmix_data_type + + ! cvmix_global_params_type contains global parameters used by multiple + ! mixing methods. + type, public :: cvmix_global_params_type + ! maximum number of levels for any column + integer :: max_nlev + ! units: unitless + + real(cvmix_r8) :: Gravity = 9.80616_cvmix_r8 + + ! Prandtl number + real(cvmix_r8) :: prandtl + ! units: unitless + + ! Fresh water and salt water densities + real(cvmix_r8) :: FreshWaterDensity + real(cvmix_r8) :: SaltWaterDensity + ! units: kg m^-3 + + end type cvmix_global_params_type + +!EOP + +end module cvmix_kinds_and_types + diff --git a/parameterizations/CVmix/cvmix_kpp.F90 b/parameterizations/CVmix/cvmix_kpp.F90 new file mode 100644 index 0000000000..9c06b35f63 --- /dev/null +++ b/parameterizations/CVmix/cvmix_kpp.F90 @@ -0,0 +1,2787 @@ +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + + module cvmix_kpp + +!BOP +!\newpage +! !MODULE: cvmix_kpp +! +! !AUTHOR: +! Michael N. Levy, NCAR (mlevy@ucar.edu) +! +! !DESCRIPTION: +! This module contains routines to initialize the derived types needed for +! KPP mixing and to set the viscosity and diffusivity coefficients +! accordingly. +!\\ +!\\ +! References:\\ +! * WG Large, JC McWilliams, and SC Doney. +! Oceanic Vertical Mixing: A Review and a Model with a Nonlocal Boundary Layer +! Parameterization. +! Review of Geophysics, 1994. +!\\ +!\\ + +! !USES: + + use cvmix_kinds_and_types, only : cvmix_r8, & + cvmix_strlen, & + cvmix_zero, & + cvmix_one, & + cvmix_PI, & + cvmix_data_type, & + cvmix_global_params_type, & + CVMIX_OVERWRITE_OLD_VAL, & + CVMIX_SUM_OLD_AND_NEW_VALS, & + CVMIX_MAX_OLD_AND_NEW_VALS + use cvmix_math, only : CVMIX_MATH_INTERP_LINEAR, & + CVMIX_MATH_INTERP_QUAD, & + CVMIX_MATH_INTERP_CUBE_SPLINE, & + cvmix_math_poly_interp, & + cvmix_math_cubic_root_find, & + cvmix_math_evaluate_cubic + use cvmix_put_get, only : cvmix_put + use cvmix_utils, only : cvmix_update_wrap + +!EOP + + implicit none + private + save + +!BOP + +! !DEFINED PARAMETERS: + integer, parameter :: CVMIX_KPP_INTERP_LMD94 = -1 + integer, parameter :: CVMIX_KPP_MATCH_BOTH = 1 + integer, parameter :: CVMIX_KPP_MATCH_GRADIENT = 2 + integer, parameter :: CVMIX_KPP_SIMPLE_SHAPES = 3 + integer, parameter :: CVMIX_KPP_PARABOLIC_NONLOCAL = 4 + integer, parameter :: NO_LANGMUIR_MIXING = -1 + integer, parameter :: LANGMUIR_MIXING_LWF16 = 1 + integer, parameter :: LANGMUIR_MIXING_RWHGK16 = 2 + integer, parameter :: NO_LANGMUIR_ENTRAINMENT = -1 + integer, parameter :: LANGMUIR_ENTRAINMENT_LWF16 = 1 + integer, parameter :: LANGMUIR_ENTRAINMENT_LF17 = 2 + integer, parameter :: LANGMUIR_ENTRAINMENT_RWHGK16 = 3 + +! !PUBLIC MEMBER FUNCTIONS: + + public :: cvmix_init_kpp + ! Note: cvmix_kpp_compute_OBL_depth would be part of cvmix_coeffs_kpp but + ! CVMix can not smooth the boundary layer depth or correct the + ! buoyancy flux term + public :: cvmix_kpp_compute_OBL_depth + public :: cvmix_coeffs_kpp + public :: cvmix_put_kpp + public :: cvmix_get_kpp_real + public :: cvmix_kpp_compute_bulk_Richardson + public :: cvmix_kpp_compute_turbulent_scales + public :: cvmix_kpp_compute_unresolved_shear + ! These are public for testing, may end up private later + public :: cvmix_kpp_compute_shape_function_coeffs + public :: cvmix_kpp_compute_kOBL_depth + public :: cvmix_kpp_compute_enhanced_diff + public :: cvmix_kpp_compute_nu_at_OBL_depth_LMD94 + public :: cvmix_kpp_EFactor_model + public :: cvmix_kpp_ustokes_SL_model + + + interface cvmix_coeffs_kpp + module procedure cvmix_coeffs_kpp_low + module procedure cvmix_coeffs_kpp_wrap + end interface cvmix_coeffs_kpp + + interface cvmix_put_kpp + module procedure cvmix_put_kpp_int + module procedure cvmix_put_kpp_real + module procedure cvmix_put_kpp_logical + end interface cvmix_put_kpp + + interface cvmix_kpp_compute_OBL_depth + module procedure cvmix_kpp_compute_OBL_depth_low + module procedure cvmix_kpp_compute_OBL_depth_wrap + end interface cvmix_kpp_compute_OBL_depth + + interface cvmix_kpp_compute_turbulent_scales + module procedure cvmix_kpp_compute_turbulent_scales_0d + module procedure cvmix_kpp_compute_turbulent_scales_1d_sigma + module procedure cvmix_kpp_compute_turbulent_scales_1d_OBL + end interface cvmix_kpp_compute_turbulent_scales + +! !PUBLIC TYPES: + + ! cvmix_kpp_params_type contains the necessary parameters for KPP mixing + type, public :: cvmix_kpp_params_type + private + real(cvmix_r8) :: Ri_crit ! Critical Richardson number + ! (OBL_depth = where bulk Ri = Ri_crit) + + real(cvmix_r8) :: minOBLdepth ! Minimum allowable OBL depth + ! (Default is 0 m => no minimum) + real(cvmix_r8) :: maxOBLdepth ! Maximum allowable OBL depth + ! (Default is 0 m => no maximum) + real(cvmix_r8) :: minVtsqr ! Minimum allowable unresolved shear + ! (Default is 1e-10 m^2/s^2) + + real(cvmix_r8) :: vonkarman ! von Karman constant + + real(cvmix_r8) :: Cstar ! coefficient for nonlinear transport + real(cvmix_r8) :: nonlocal_coeff ! Cs from Eq (20) in LMD94 + ! Default value comes from paper, but + ! some users may set it = 1. + + ! For velocity scale function, _m => momentum and _s => scalar (tracer) + real(cvmix_r8) :: zeta_m ! parameter for computing vel scale func + real(cvmix_r8) :: zeta_s ! parameter for computing vel scale func + real(cvmix_r8) :: a_m ! parameter for computing vel scale func + real(cvmix_r8) :: c_m ! parameter for computing vel scale func + real(cvmix_r8) :: a_s ! parameter for computing vel scale func + real(cvmix_r8) :: c_s ! parameter for computing vel scale func + + real(cvmix_r8) :: surf_layer_ext ! nondimensional extent of surface layer + ! (expressed in sigma-coordinates) + + integer :: interp_type ! interpolation type used to interpolate + ! bulk Richardson number + integer :: interp_type2 ! interpolation type used to interpolate + ! diff and visc at OBL_depth + + ! Cv is a parameter used to compute the unresolved shear. By default, the + ! formula from Eq. (A3) of Danabasoglu et al. is used, but a single + ! scalar value can be set instead. + real(cvmix_r8) :: Cv + + ! MatchTechnique is set by a string of the same name as an argument in + ! cvmix_init_kpp. It determines how matching between the boundary layer + ! and ocean interior is handled at the interface. Note that this also + ! controls whether the shape function used to compute the coefficient in + ! front of the nonlocal term is the same as that used to compute the + ! gradient term. + ! Options (for cvmix_init_kpp) are + ! (i) SimpleShapes => Shape functions for both the gradient and nonlocal + ! terms vanish at interface + ! (ii) MatchGradient => Shape function for nonlocal term vanishes at + ! interface, but gradient term matches interior + ! values. + ! (iii) MatchBoth => Shape functions for both the gradient and nonlocal + ! term match interior values at interface + ! (iv) ParabolicNonLocal => Shape function for the nonlocal term is + ! (1-sigma)^2, gradient term is sigma*(1-sigma)^2 + integer :: MatchTechnique + + ! Flag for what to do with old values of CVmix_vars%[MTS]diff + integer :: handle_old_vals + + ! Logic flags to dictate if / how various terms are computed + logical :: lscalar_Cv ! True => use the scalar Cv value + logical :: lEkman ! True => compute Ekman depth limit + logical :: lMonOb ! True => compute Monin-Obukhov limit + logical :: lnoDGat1 ! True => G'(1) = 0 (shape function) + ! False => compute G'(1) as in LMD94 + logical :: lenhanced_diff ! True => enhance diffusivity at OBL + integer :: Langmuir_Mixing_Opt + ! Option of Langmuir enhanced mixing + ! - apply an enhancement factor to the + ! turbulent velocity scale + integer :: Langmuir_Entrainment_Opt + ! Option of Langmuir turbulence enhanced + ! entrainment - modify the unresolved shear + logical :: l_LMD_ws ! flag to use original Large et al. (1994) + ! equations for computing turbulent scales + ! rather than the updated methodology in + ! Danabasoglu et al. (2006). The latter + ! limits sigma to be < surf_layer_extent + ! when computing turbulent scales while + ! the former only imposes this restriction + ! in unstable regimes. + real(cvmix_r8) :: c_LT, c_ST, c_CT ! Empirical constants in the scaling of the + ! entrainment buoyancy flux + ! (20) in Li and Fox-Kemper, 2017, JPO + real(cvmix_r8) :: p_LT ! Power of Langmuir number in the above + ! scaling + !BGR + real(cvmix_r8) :: RWHGK_ENTR_COEF,& ! Coefficient and exponent from + RWHGK_ENTR_EXP ! RWHGK16 Langmuir parameterization + + end type cvmix_kpp_params_type + +!EOP + +type(cvmix_kpp_params_type), target :: CVmix_kpp_params_saved + +contains + +!BOP + +! !IROUTINE: cvmix_init_kpp +! !INTERFACE: + subroutine cvmix_init_kpp(ri_crit, minOBLdepth, maxOBLdepth, minVtsqr, & + vonkarman, Cstar, zeta_m, zeta_s, surf_layer_ext, & + Cv, interp_type, interp_type2, MatchTechnique, & + old_vals, lEkman, lMonOb, lnoDGat1, & + lenhanced_diff, lnonzero_surf_nonlocal, & + Langmuir_mixing_str, Langmuir_entrainment_str, & + l_LMD_ws, CVmix_kpp_params_user) + +! !DESCRIPTION: +! Initialization routine for KPP mixing. +!\\ +!\\ +! +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + real(cvmix_r8), optional, intent(in) :: ri_crit, & + minOBLdepth, & + maxOBLdepth, & + minVtsqr, & + vonkarman, & + Cstar, & + zeta_m, & + zeta_s, & + surf_layer_ext, & + Cv + character(len=*), optional, intent(in) :: interp_type, & + interp_type2, & + MatchTechnique, & + old_vals, & + Langmuir_mixing_str, & + Langmuir_entrainment_str + logical, optional, intent(in) :: lEkman, & + lMonOb, & + lnoDGat1, & + lenhanced_diff, & + lnonzero_surf_nonlocal, & + l_LMD_ws + +! !OUTPUT PARAMETERS: + type(cvmix_kpp_params_type), intent(inout), target, optional :: & + CVmix_kpp_params_user + +!EOP +!BOC + + real(cvmix_r8) :: zm, zs, a_m, a_s, c_m, c_s + real(cvmix_r8) :: Cstar_loc, vonkar_loc, surf_layer_ext_loc + real(cvmix_r8) :: nonlocal_coeff + + if (present(ri_crit)) then + if (ri_crit.lt.cvmix_zero) then + print*, "ERROR: ri_crit can not be negative." + stop 1 + end if + call cvmix_put_kpp('Ri_crit', ri_crit, CVmix_kpp_params_user) + else + call cvmix_put_kpp('Ri_crit', 0.3_cvmix_r8, CVmix_kpp_params_user) + end if + + if (present(minOBLdepth)) then + if (minOBLdepth.lt.cvmix_zero) then + print*, "ERROR: minOBLdepth can not be negative." + stop 1 + end if + call cvmix_put_kpp('minOBLdepth', minOBLdepth, CVmix_kpp_params_user) + else + call cvmix_put_kpp('minOBLdepth', 0, CVmix_kpp_params_user) + end if + + if (present(maxOBLdepth)) then + if (maxOBLdepth.lt.cvmix_zero) then + print*, "ERROR: maxOBLdepth can not be negative." + stop 1 + end if + call cvmix_put_kpp('maxOBLdepth', maxOBLdepth, CVmix_kpp_params_user) + else + call cvmix_put_kpp('maxOBLdepth', 0, CVmix_kpp_params_user) + end if + + if (present(minVtsqr)) then + if (minVtsqr.lt.cvmix_zero) then + print*, "ERROR: minVtsqr can not be negative." + stop 1 + end if + call cvmix_put_kpp('minVtsqr', minVtsqr, CVmix_kpp_params_user) + else + call cvmix_put_kpp('minVtsqr', 1e-10_cvmix_r8, CVmix_kpp_params_user) + end if + + if (present(vonkarman)) then + if (vonkarman.lt.cvmix_zero) then + print*, "ERROR: vonkarman can not be negative." + stop 1 + end if + vonkar_loc = vonkarman + else + vonkar_loc = 0.4_cvmix_r8 + end if + call cvmix_put_kpp('vonkarman', vonkar_loc, CVmix_kpp_params_user) + + if (present(Cstar)) then + Cstar_loc = Cstar + else + Cstar_loc = real(10,cvmix_r8) + end if + call cvmix_put_kpp('Cstar', Cstar_loc, CVmix_kpp_params_user) + + if (present(zeta_m)) then + if (zeta_m.ge.cvmix_zero) then + print*, "ERROR: zeta_m must be negative." + stop 1 + end if + zm = zeta_m + else + ! default value for zeta_m is -1/5 + zm = -0.2_cvmix_r8 + end if + call cvmix_put_kpp('zeta_m', zm, CVmix_kpp_params_user) + + if (present(zeta_s)) then + if (zeta_s.ge.cvmix_zero) then + print*, "ERROR: zeta_s must be negative." + stop 1 + end if + zs = zeta_s + else + ! Default value for zeta_s is -1 + zs = -cvmix_one + end if + call cvmix_put_kpp('zeta_s', zs, CVmix_kpp_params_user) + + ! a_m, a_s, c_m, and c_s are computed from zeta_m and zeta_s + ! a_m, c_m, and c_s are all non-negative. a_s may be negative depending + ! on the value of zeta_s + a_m = ((cvmix_one - real(16,cvmix_r8)*zm)**(-0.25_cvmix_r8))* & + (cvmix_one - real(4,cvmix_r8)*zm) + c_m = ((cvmix_one - real(16,cvmix_r8)*zm)**(-0.25_cvmix_r8))* & + real(12,cvmix_r8) + call cvmix_put_kpp('a_m', a_m, CVmix_kpp_params_user) + call cvmix_put_kpp('c_m', c_m, CVmix_kpp_params_user) + + a_s = sqrt(cvmix_one - real(16,cvmix_r8)*zs)* & + (cvmix_one + real(8,cvmix_r8)*zs) + c_s = real(24,cvmix_r8)*sqrt(cvmix_one - real(16,cvmix_r8)*zs) + call cvmix_put_kpp('a_s', a_s, CVmix_kpp_params_user) + call cvmix_put_kpp('c_s', c_s, CVmix_kpp_params_user) + + if (present(surf_layer_ext)) then + if ((surf_layer_ext.lt.cvmix_zero).or.(surf_layer_ext.gt.cvmix_one)) & + then + print*, "surf_layer_ext must be between 0 and 1, inclusive." + stop 1 + end if + surf_layer_ext_loc = surf_layer_ext + else + surf_layer_ext_loc = 0.1_cvmix_r8 + end if + call cvmix_put_kpp('surf_layer_ext', surf_layer_ext_loc, & + CVmix_kpp_params_user) + + if (present(Cv)) then + ! Use scalar Cv parameter + call cvmix_put_kpp('Cv', CV, CVmix_kpp_params_user) + call cvmix_put_kpp('lscalar_Cv', .true., CVmix_kpp_params_user) + else + ! Use Eq. (A3) from Danabasoglu et al. + call cvmix_put_kpp('lscalar_Cv', .false., CVmix_kpp_params_user) + end if + + if (present(interp_type)) then + select case (trim(interp_type)) + case ('line', 'linear') + call cvmix_put_kpp('interp_type', CVMIX_MATH_INTERP_LINEAR, & + CVmix_kpp_params_user) + case ('quad', 'quadratic') + call cvmix_put_kpp('interp_type', CVMIX_MATH_INTERP_QUAD, & + CVmix_kpp_params_user) + case ('cube', 'cubic', 'cubic_spline', 'cubic spline') + call cvmix_put_kpp('interp_type', CVMIX_MATH_INTERP_CUBE_SPLINE, & + CVmix_kpp_params_user) + case DEFAULT + print*, "ERROR: ", trim(interp_type), " is not a valid type of ", & + "interpolation!" + stop 1 + end select + else + call cvmix_put_kpp('interp_type', CVMIX_MATH_INTERP_QUAD, & + CVmix_kpp_params_user) + end if + + if (present(interp_type2)) then + select case (trim(interp_type2)) + case ('line', 'linear') + call cvmix_put_kpp('interp_type2', CVMIX_MATH_INTERP_LINEAR, & + CVmix_kpp_params_user) + case ('quad', 'quadratic') + call cvmix_put_kpp('interp_type2', CVMIX_MATH_INTERP_QUAD, & + CVmix_kpp_params_user) + case ('cube', 'cubic', 'cubic_spline', 'cubic spline') + call cvmix_put_kpp('interp_type2', CVMIX_MATH_INTERP_CUBE_SPLINE, & + CVmix_kpp_params_user) + case ('POP','LMD94') + call cvmix_put_kpp('interp_type2', CVMIX_KPP_INTERP_LMD94, & + CVmix_kpp_params_user) + case DEFAULT + print*, "ERROR: ", trim(interp_type2), " is not a valid type of ", & + "interpolation!" + stop 1 + end select + else + call cvmix_put_kpp('interp_type2', CVMIX_KPP_INTERP_LMD94, & + CVmix_kpp_params_user) + end if + + if (present(MatchTechnique)) then + select case (trim(MatchTechnique)) + case ('MatchBoth') + call cvmix_put_kpp('MatchTechnique', CVMIX_KPP_MATCH_BOTH, & + CVmix_kpp_params_user) + case ('MatchGradient') + call cvmix_put_kpp('MatchTechnique', CVMIX_KPP_MATCH_GRADIENT, & + CVmix_kpp_params_user) + case ('SimpleShapes') + call cvmix_put_kpp('MatchTechnique', CVMIX_KPP_SIMPLE_SHAPES, & + CVmix_kpp_params_user) + case ('ParabolicNonLocal') + call cvmix_put_kpp('MatchTechnique', CVMIX_KPP_PARABOLIC_NONLOCAL, & + CVmix_kpp_params_user) + case DEFAULT + print*, "ERROR: ", trim(MatchTechnique), " is not a valid choice ", & + "for MatchTechnique!" + stop 1 + end select + else + call cvmix_put_kpp('MatchTechnique', CVMIX_KPP_SIMPLE_SHAPES, & + CVmix_kpp_params_user) + end if + + if (present(old_vals)) then + select case (trim(old_vals)) + case ("overwrite") + call cvmix_put_kpp('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_kpp_params_user) + case ("sum") + call cvmix_put_kpp('handle_old_vals', CVMIX_SUM_OLD_AND_NEW_VALS, & + cvmix_kpp_params_user) + case ("max") + call cvmix_put_kpp('handle_old_vals', CVMIX_MAX_OLD_AND_NEW_VALS, & + cvmix_kpp_params_user) + case DEFAULT + print*, "ERROR: ", trim(old_vals), " is not a valid option for ", & + "handling old values of diff and visc." + stop 1 + end select + else + call cvmix_put_kpp('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_kpp_params_user) + end if + + if (present(lEkman)) then + call cvmix_put_kpp('lEkman', lEkman, CVmix_kpp_params_user) + else + call cvmix_put_kpp('lEkman', .false., CVmix_kpp_params_user) + end if + + if (present(lMonOb)) then + call cvmix_put_kpp('lMonOb', lMonOb, CVmix_kpp_params_user) + else + call cvmix_put_kpp('lMonOb', .false., CVmix_kpp_params_user) + end if + + if (present(lnoDGat1)) then + call cvmix_put_kpp('lnoDGat1', lnoDGat1, CVmix_kpp_params_user) + else + call cvmix_put_kpp('lnoDGat1', .true., CVmix_kpp_params_user) + end if + + if (present(lenhanced_diff)) then + call cvmix_put_kpp('lenhanced_diff', lenhanced_diff, & + CVmix_kpp_params_user) + else + call cvmix_put_kpp('lenhanced_diff', .true., CVmix_kpp_params_user) + end if + + if (present(Langmuir_mixing_str)) then + select case (trim(Langmuir_mixing_str)) + case ("LWF16") + call cvmix_put_kpp('Langmuir_Mixing_Opt', LANGMUIR_MIXING_LWF16 , & + CVmix_kpp_params_user) + case ("RWHGK16") + call cvmix_put_kpp('Langmuir_Mixing_Opt', & + LANGMUIR_MIXING_RWHGK16, CVmix_kpp_params_user) + case ("NONE") + call cvmix_put_kpp('Langmuir_Mixing_Opt', & + NO_LANGMUIR_MIXING, CVmix_kpp_params_user) + case DEFAULT + print*, "ERROR: ", trim(Langmuir_mixing_str), " is not a valid ", & + "option for Langmuir_mixing_str!" + stop 1 + end select + else + call cvmix_put_kpp('Langmuir_Mixing_Opt', & + NO_LANGMUIR_MIXING, CVmix_kpp_params_user) + end if + + if (present(Langmuir_entrainment_str)) then + select case (trim(Langmuir_entrainment_str)) + case ("LWF16") + call cvmix_put_kpp('Langmuir_Entrainment_Opt', & + LANGMUIR_ENTRAINMENT_LWF16, CVmix_kpp_params_user) + case ("LF17") + call cvmix_put_kpp('Langmuir_Entrainment_Opt', & + LANGMUIR_ENTRAINMENT_LF17, CVmix_kpp_params_user) + case ("RWHGK16") + call cvmix_put_kpp('Langmuir_Entrainment_Opt', & + LANGMUIR_ENTRAINMENT_RWHGK16, CVmix_kpp_params_user) + case ("NONE") + call cvmix_put_kpp('Langmuir_Entrainment_Opt', & + NO_LANGMUIR_ENTRAINMENT, CVmix_kpp_params_user) + case DEFAULT + print*, "ERROR: ", trim(Langmuir_entrainment_str), " is not a ", & + "valid option for Langmuir_entrainment_str!" + stop 1 + end select + else + call cvmix_put_kpp('Langmuir_Entrainment_Opt', & + NO_LANGMUIR_ENTRAINMENT, CVmix_kpp_params_user) + end if + + ! By default, assume that G(0) = 0 for nonlocal term + nonlocal_coeff = (Cstar_loc*vonkar_loc* & + (vonkar_loc*surf_layer_ext_loc*c_s)** & + (cvmix_one/real(3,cvmix_r8))) + if (present(lnonzero_surf_nonlocal)) then + if (lnonzero_surf_nonlocal) then + nonlocal_coeff = real(1,cvmix_r8) + end if + end if + call cvmix_put_kpp('nonlocal_coeff',nonlocal_coeff,CVmix_kpp_params_user) + + ! By default, use sigma construction from Danabasoglu et al. when computing + ! turbulent scales. Set l_LMD_ws = .true. to use Large et al. construction. + if (present(l_LMD_ws)) then + call cvmix_put_kpp('l_LMD_ws', l_LMD_ws, & + CVmix_kpp_params_user) + else + call cvmix_put_kpp('l_LMD_ws', .false., CVmix_kpp_params_user) + end if + + ! Initialize parameters for enhanced entrainment + call cvmix_put_kpp('c_ST', 0.17_cvmix_r8, CVmix_kpp_params_user) + call cvmix_put_kpp('c_CT', 0.15_cvmix_r8, CVmix_kpp_params_user) + call cvmix_put_kpp('c_LT', 0.083_cvmix_r8, CVmix_kpp_params_user) + call cvmix_put_kpp('p_LT', 2.0_cvmix_r8, CVmix_kpp_params_user) + call cvmix_put_kpp('RWHGK_ENTR_COEF', 2.3_cvmix_r8, CVmix_kpp_params_user) + call cvmix_put_kpp('RWHGK_ENTR_EXP', -0.5_cvmix_r8, CVmix_kpp_params_user) +!EOC + + end subroutine cvmix_init_kpp + +!BOP + +! !IROUTINE: cvmix_coeffs_kpp_wrap +! !INTERFACE: + + subroutine cvmix_coeffs_kpp_wrap(CVmix_vars, CVmix_kpp_params_user) + +! !DESCRIPTION: +! Computes vertical diffusion coefficients for the KPP boundary layer mixing +! parameterization. +!\\ +!\\ +! +! !USES: +! only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_kpp_params_type), intent(in), optional, target :: & + CVmix_kpp_params_user + +! !INPUT/OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars + +!EOP +!BOC + + real(cvmix_r8), dimension(CVmix_vars%max_nlev+1) :: new_Mdiff, new_Tdiff, & + new_Sdiff + integer :: nlev, max_nlev + type(cvmix_kpp_params_type), pointer :: CVmix_kpp_params_in + + CVmix_kpp_params_in => CVmix_kpp_params_saved + if (present(CVmix_kpp_params_user)) then + CVmix_kpp_params_in => CVmix_kpp_params_user + end if + + nlev = CVmix_vars%nlev + max_nlev = CVmix_vars%max_nlev + + if (.not.associated(CVmix_vars%Mdiff_iface)) & + call cvmix_put(CVmix_vars, "Mdiff", cvmix_zero, max_nlev) + if (.not.associated(CVmix_vars%Tdiff_iface)) & + call cvmix_put(CVmix_vars, "Tdiff", cvmix_zero, max_nlev) + if (.not.associated(CVmix_vars%Sdiff_iface)) & + call cvmix_put(CVmix_vars, "Sdiff", cvmix_zero, max_nlev) + + call cvmix_put(CVmix_vars, 'kpp_transport', cvmix_zero, max_nlev) + + call cvmix_coeffs_kpp(new_Mdiff, new_Tdiff, new_Sdiff, & + CVmix_vars%zw_iface, CVmix_vars%zt_cntr, & + CVmix_vars%Mdiff_iface, CVmix_vars%Tdiff_iface, & + CVMix_vars%Sdiff_iface, & + CVmix_vars%BoundaryLayerDepth, & + CVmix_vars%kOBL_depth, & + CVmix_vars%kpp_Tnonlocal_iface, & + CVmix_vars%kpp_Snonlocal_iface, & + CVmix_vars%SurfaceFriction, & + CVmix_vars%SurfaceBuoyancyForcing, & + nlev, max_nlev, & + CVmix_vars%LangmuirEnhancementFactor, & + CVmix_kpp_params_user) + call cvmix_update_wrap(CVmix_kpp_params_in%handle_old_vals, max_nlev, & + Mdiff_out = CVmix_vars%Mdiff_iface, & + new_Mdiff = new_Mdiff, & + Tdiff_out = CVmix_vars%Tdiff_iface, & + new_Tdiff = new_Tdiff, & + Sdiff_out = CVmix_vars%Sdiff_iface, & + new_Sdiff = new_Sdiff) + +!EOC + + end subroutine cvmix_coeffs_kpp_wrap + +!BOP + +! !IROUTINE: cvmix_coeffs_kpp_low +! !INTERFACE: + + subroutine cvmix_coeffs_kpp_low(Mdiff_out, Tdiff_out, Sdiff_out, zw, zt, & + old_Mdiff, old_Tdiff, old_Sdiff, OBL_depth, & + kOBL_depth, Tnonlocal, Snonlocal, surf_fric,& + surf_buoy, nlev, max_nlev, & + Langmuir_EFactor, CVmix_kpp_params_user) + +! !DESCRIPTION: +! Computes vertical diffusion coefficients for the KPP boundary layer mixing +! parameterization. +!\\ +!\\ +! +! !USES: +! only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_kpp_params_type), intent(in), optional, target :: & + CVmix_kpp_params_user + + integer, intent(in) :: nlev, max_nlev + real(cvmix_r8), dimension(max_nlev+1), intent(in) :: old_Mdiff, & + old_Tdiff, & + old_Sdiff, & + zw + real(cvmix_r8), dimension(max_nlev), intent(in) :: zt + real(cvmix_r8), intent(in) :: OBL_depth, & + surf_fric, & + surf_buoy, & + kOBL_depth + ! Langmuir enhancement factor + real(cvmix_r8), intent(in), optional :: Langmuir_EFactor + +! !INPUT/OUTPUT PARAMETERS: + real(cvmix_r8), dimension(max_nlev+1), intent(inout) :: Mdiff_out, & + Tdiff_out, & + Sdiff_out, & + Tnonlocal, & + Snonlocal + +!EOP +!BOC + + ! Local variables + type(cvmix_kpp_params_type), pointer :: CVmix_kpp_params_in + + ! OBL_[MTS]diff are the diffusivities in the whole OBL + real(cvmix_r8), dimension(nint(kOBL_depth)) :: OBL_Mdiff, OBL_Tdiff, & + OBL_Sdiff + + ! [MTS]diff_ktup are the enhanced diffusivity and viscosity values at the + ! deepest cell center above OBL_depth. Other _ktup vars are intermediary + ! variables needed to compute [MTS]diff_ktup + real(cvmix_r8) :: Mdiff_ktup, Tdiff_ktup, Sdiff_ktup + real(cvmix_r8) :: sigma_ktup, wm_ktup, ws_ktup + + real(cvmix_r8) :: delta + + real(cvmix_r8), dimension(nlev+1) :: sigma, w_m, w_s + + ! [MTS]shape are the coefficients of the shape function in the gradient + ! term; [TS]shape2 are the coefficients for the nonlocal term; + ! NMshape is the coefficient for the no-matching case, an option to shape + ! a Langmuir enhancement + real(cvmix_r8), dimension(4) :: Mshape, Tshape, Sshape, Tshape2, Sshape2,& + NMshape + + ! [MTS]shapeAt1 is value of shape function at sigma = 1 + ! d[MTS]shapeAt1 is value of derivative of shape function at sigma = 1 + ! (Used for matching the shape function at OBL depth) + real(cvmix_r8) :: MshapeAt1, TshapeAt1, SshapeAt1 + real(cvmix_r8) :: dMshapeAt1, dTshapeAt1, dSshapeAt1 + + ! [MTS]shapeAtS is value of shape function at sigma = S + real(cvmix_r8) :: MshapeAtS, TshapeAtS, SshapeAtS, GAtS + ! Storing the maximum value of shape function for no-matching case + ! that is used as an option for Langmuir mixing + real(cvmix_r8), parameter :: NMshapeMax = 4./27. + + ! [MTS]diff_OBL is value of diffusivity at OBL depth + ! d[MTS]diff_OBL is value of derivative of diffusivity at OBL depth + ! w[ms]_OBL is value of wm or ws at OBL depth + real(cvmix_r8) :: Mdiff_OBL, Tdiff_OBL, Sdiff_OBL + real(cvmix_r8) :: dMdiff_OBL, dTdiff_OBL, dSdiff_OBL + real(cvmix_r8) :: wm_OBL, ws_OBL, second_term + + ! coefficients used for interpolation if interp_type2 is not 'LMD94' + real(kind=cvmix_r8), dimension(4) :: coeffs + + ! Width of column kw_up and kw_up+1 + real(cvmix_r8), dimension(2) :: col_widths, col_centers + real(cvmix_r8), dimension(2) :: Mdiff_vals, Tdiff_vals, Sdiff_vals + + ! Parameters for RWHGK16 Langmuir parameterization + real(cvmix_r8) :: MixingCoefEnhancement + real(cvmix_r8) :: ShapeNoMatchAtS + + ! Constant from params + integer :: interp_type2, MatchTechnique + + integer :: kw + logical :: lstable + integer :: ktup, & ! kt index of cell center above OBL_depth + kwup ! kw index of iface above OBL_depth (= kt index of + ! cell containing OBL_depth) + + CVmix_kpp_params_in => CVmix_kpp_params_saved + if (present(CVmix_kpp_params_user)) then + CVmix_kpp_params_in => CVmix_kpp_params_user + end if + interp_type2 = CVmix_kpp_params_in%interp_type2 + MatchTechnique = CVmix_kpp_params_in%MatchTechnique + + ! Output values should be set to input values + Mdiff_out = old_Mdiff + Tdiff_out = old_Tdiff + Sdiff_out = old_Sdiff + + ! (1) Column-specific parameters + ! + ! Stability => positive surface buoyancy flux + lstable = (surf_buoy.gt.cvmix_zero) + + kwup = floor(kOBL_depth) + ktup = nint(kOBL_depth)-1 + + if (ktup.eq.nlev) then + ! OBL_depth between bottom cell center and ocean bottom, assume + ! zt(ktup+1) = ocn_bottom (which is zw(nlev+1) + delta = (OBL_depth+zt(ktup))/(zt(ktup)-zw(ktup+1)) + else + delta = (OBL_depth+zt(ktup))/(zt(ktup)-zt(ktup+1)) + end if + + ! (2) Compute coefficients of shape function + ! A no-match case is stored for use in Langmuir scheme + NMshape(1) = cvmix_zero + NMshape(2) = cvmix_one + NMshape(3) = -real(2,cvmix_r8) + NMshape(4) = cvmix_one + select case (MatchTechnique) + case (CVMIX_KPP_SIMPLE_SHAPES) + ! Simple shape function is sigma*(1-sigma)^2 + Mshape(1) = cvmix_zero + Mshape(2) = cvmix_one + Mshape(3) = -real(2,cvmix_r8) + Mshape(4) = cvmix_one + Tshape = Mshape + Sshape = Mshape + Tshape2 = Tshape + Sshape2 = Sshape + case (CVMIX_KPP_PARABOLIC_NONLOCAL) + ! Shape function is sigma*(1-sigma)^2 for gradient term + ! and (1-sigma)^2 for non-local term + Mshape(1) = cvmix_zero + Mshape(2) = cvmix_one + Mshape(3) = -real(2,cvmix_r8) + Mshape(4) = cvmix_one + Tshape = Mshape + Sshape = Mshape + Tshape2(1) = cvmix_one + Tshape2(2) = -real(2,cvmix_r8) + Tshape2(3) = cvmix_one + Tshape2(4) = cvmix_zero + Sshape2 = Tshape2 + case DEFAULT + ! (2a) Compute turbulent scales at OBL depth + call cvmix_kpp_compute_turbulent_scales(cvmix_one, OBL_depth, & + surf_buoy, surf_fric, & + wm_OBL, ws_OBL, & + CVmix_kpp_params_user) + if (CVMix_KPP_Params_in%Langmuir_Mixing_Opt & + .eq. LANGMUIR_MIXING_LWF16) then + ! enhance the turbulent velocity scale + wm_OBL = wm_OBL * Langmuir_EFactor + ws_OBL = ws_OBL * Langmuir_EFactor + end if + ! (2b) Compute diffusivities at OBL depth + if (interp_type2.ne.CVMIX_KPP_INTERP_LMD94) then + if (kwup.eq.1) then + call cvmix_math_poly_interp(coeffs, interp_type2, zw(kwup:kwup+1),& + old_Mdiff(kwup:kwup+1)) + Mdiff_OBL = cvmix_math_evaluate_cubic(coeffs, -OBL_depth, & + dMdiff_OBL) + + call cvmix_math_poly_interp(coeffs, interp_type2, zw(kwup:kwup+1),& + old_Tdiff(kwup:kwup+1)) + Tdiff_OBL = cvmix_math_evaluate_cubic(coeffs, -OBL_depth, & + dTdiff_OBL) + + call cvmix_math_poly_interp(coeffs, interp_type2, zw(kwup:kwup+1),& + old_Sdiff(kwup:kwup+1)) + Sdiff_OBL = cvmix_math_evaluate_cubic(coeffs, -OBL_depth, & + dSdiff_OBL) + else ! interp_type2 != 'LMD94' and kwup > 1 + call cvmix_math_poly_interp(coeffs, interp_type2, zw(kwup:kwup+1),& + old_Mdiff(kwup:kwup+1), zw(kwup-1), & + old_Mdiff(kwup-1)) + Mdiff_OBL = cvmix_math_evaluate_cubic(coeffs, -OBL_depth, & + dMdiff_OBL) + + call cvmix_math_poly_interp(coeffs, interp_type2, zw(kwup:kwup+1),& + old_Tdiff(kwup:kwup+1), zw(kwup-1), & + old_Tdiff(kwup-1)) + Tdiff_OBL = cvmix_math_evaluate_cubic(coeffs, -OBL_depth, & + dTdiff_OBL) + + call cvmix_math_poly_interp(coeffs, interp_type2, zw(kwup:kwup+1),& + old_Sdiff(kwup:kwup+1), zw(kwup-1), & + old_Sdiff(kwup-1)) + Sdiff_OBL = cvmix_math_evaluate_cubic(coeffs, -OBL_depth, & + dSdiff_OBL) + end if + else ! interp_type2 == 'LMD94' + col_centers(1) = zt(kwup) + col_widths(1) = zw(kwup) - zw(kwup+1) + Mdiff_vals(1) = old_Mdiff(kwup+1) + Tdiff_vals(1) = old_Tdiff(kwup+1) + Sdiff_vals(1) = old_Sdiff(kwup+1) + if (kwup.eq.nlev) then + col_centers(2) = zw(kwup+1) + col_widths(2) = 1.0_cvmix_r8 ! Value doesn't matter, will divide + ! into zero + Mdiff_vals(2) = old_Mdiff(kwup+1) + Tdiff_vals(2) = old_Tdiff(kwup+1) + Sdiff_vals(2) = old_Sdiff(kwup+1) + else + col_centers(2) = zt(kwup+1) + col_widths(2) = zw(kwup+1) - zw(kwup+2) + Mdiff_vals(2) = old_Mdiff(kwup+2) + Tdiff_vals(2) = old_Tdiff(kwup+2) + Sdiff_vals(2) = old_Sdiff(kwup+2) + end if + + if (kwup.eq.1) then + Mdiff_OBL = cvmix_kpp_compute_nu_at_OBL_depth_LMD94(col_centers, & + col_widths, & + Mdiff_vals, OBL_depth, & + dnu_dz=dMdiff_OBL) + Tdiff_OBL = cvmix_kpp_compute_nu_at_OBL_depth_LMD94(col_centers, & + col_widths, & + Tdiff_vals, OBL_depth, & + dnu_dz=dTdiff_OBL) + Sdiff_OBL = cvmix_kpp_compute_nu_at_OBL_depth_LMD94(col_centers, & + col_widths, & + Sdiff_vals, OBL_depth, & + dnu_dz=dSdiff_OBL) + else ! interp_type == 'LMD94' and kwup > 1 + Mdiff_OBL = cvmix_kpp_compute_nu_at_OBL_depth_LMD94(col_centers, & + col_widths, & + Mdiff_vals, OBL_depth, & + old_Mdiff(kwup), & + dnu_dz=dMdiff_OBL) + Tdiff_OBL = cvmix_kpp_compute_nu_at_OBL_depth_LMD94(col_centers, & + col_widths, & + Tdiff_vals, OBL_depth, & + old_Tdiff(kwup), & + dnu_dz=dTdiff_OBL) + Sdiff_OBL = cvmix_kpp_compute_nu_at_OBL_depth_LMD94(col_centers, & + col_widths, & + Sdiff_vals, OBL_depth, & + old_Sdiff(kwup), & + dnu_dz=dSdiff_OBL) + end if + end if ! interp_type != "LMD94" + + ! (2c) Compute G(1) [shape function when sigma = 1] and G'(1) for three + ! cases: + ! i) momentum diffusivity (viscosity) + ! ii) temperature diffusivity + ! iii) other tracers diffusivity + ! Notes: + ! * We are computing G(1) and G'(1) so we can represent G(sigma) as a + ! cubic polynomial and then compute Kx = OBL_depth*wx*G. If either + ! OBL_depth or wx are 0, it doesn't matter what G is because Kx + ! will be zero everywhere... in these cases, we set G(1)=G'(1)=0. + ! * If OBL_depth = 0, the above note applies to all three situations + ! listed as (i), (ii), and (iii). If ws = 0, it applies only to (i) + ! and (ii). If wm = 0, it applies only to (iii). + if (OBL_depth.eq.cvmix_zero) then + ! Values don't matter, K = 0 + MshapeAt1 = cvmix_zero + TshapeAt1 = cvmix_zero + SshapeAt1 = cvmix_zero + dMshapeAt1 = cvmix_zero + dTshapeAt1 = cvmix_zero + dSshapeAt1 = cvmix_zero + else ! OBL_depth != 0 + if (wm_OBL.ne.cvmix_zero) then + MshapeAt1 = Mdiff_OBL/(wm_OBL*OBL_depth) + else + MshapeAt1 = cvmix_zero ! value doesn't really matter, Km = 0 + end if + if (ws_OBL.ne.cvmix_zero) then + TshapeAt1 = Tdiff_OBL/(ws_OBL*OBL_depth) + SshapeAt1 = Sdiff_OBL/(ws_OBL*OBL_depth) + else + TshapeAt1 = cvmix_zero ! value doesn't really matter, Ks = 0 + SshapeAt1 = cvmix_zero ! value doesn't really matter, Ks = 0 + end if + if (CVmix_kpp_params_in%lnoDGat1) then + ! Force G'(1) = 0 + dMshapeAt1 = cvmix_zero + dTshapeAt1 = cvmix_zero + dSshapeAt1 = cvmix_zero + else + second_term = real(5,cvmix_r8)*surf_buoy/(surf_fric**4) + if (wm_OBL.ne.cvmix_zero) then + dMshapeAt1 = -dMdiff_OBL/wm_OBL + if (lstable) & + dMshapeAt1 = dMshapeAt1 + second_term*Mdiff_OBL + else + dMshapeAt1 = cvmix_zero ! value doesn't really matter, Km = 0 + end if + if (ws_OBL.ne.cvmix_zero) then + dTshapeAt1 = -dTdiff_OBL/ws_OBL + dSshapeAt1 = -dSdiff_OBL/ws_OBL + if (lstable) then + dTshapeAt1 = dTshapeAt1 + second_term*Tdiff_OBL + dSshapeAt1 = dSshapeAt1 + second_term*Sdiff_OBL + end if + else + dTshapeAt1 = cvmix_zero ! value doesn't really matter, Ks = 0 + dSshapeAt1 = cvmix_zero ! value doesn't really matter, Ks = 0 + end if + dMshapeAt1 = min(dMshapeAt1, cvmix_zero) ! non-positive value! + dTshapeAt1 = min(dTshapeAt1, cvmix_zero) ! non-positive value! + dSshapeAt1 = min(dSshapeAt1, cvmix_zero) ! non-positive value! + end if ! lnoDGat1 + end if ! OBL_depth == 0 + + ! (2d) Compute coefficients of shape function + call cvmix_kpp_compute_shape_function_coeffs(MshapeAt1, dMshapeAt1, & + Mshape) + call cvmix_kpp_compute_shape_function_coeffs(TshapeAt1, dTshapeAt1, & + Tshape) + call cvmix_kpp_compute_shape_function_coeffs(SshapeAt1, dSshapeAt1, & + Sshape) + if (MatchTechnique.eq.CVMIX_KPP_MATCH_GRADIENT) then + ! Only match for gradient term, use simple shape for nonlocal + Tshape2(1) = cvmix_zero + Tshape2(2) = cvmix_one + Tshape2(3) = -real(2,cvmix_r8) + Tshape2(4) = cvmix_one + Sshape2 = Tshape2 + else + ! Shape function is the same for gradient and nonlocal + Tshape2 = Tshape + Sshape2 = Sshape + end if + end select + + ! (3) Use shape function to compute diffusivities throughout OBL + Tnonlocal = cvmix_zero + Snonlocal = cvmix_zero + OBL_Mdiff = cvmix_zero + OBL_Tdiff = cvmix_zero + OBL_Sdiff = cvmix_zero + sigma = -zw(1:nlev+1)/OBL_depth + ! (3a) Compute turbulent scales throghout column + call cvmix_kpp_compute_turbulent_scales(sigma, OBL_depth, surf_buoy, & + surf_fric, w_m, w_s, & + CVmix_kpp_params_user) + do kw=2,kwup + ! (3b) Evaluate G(sigma) at each cell interface + MshapeAtS = cvmix_math_evaluate_cubic(Mshape, sigma(kw)) + TshapeAtS = cvmix_math_evaluate_cubic(Tshape, sigma(kw)) + SshapeAtS = cvmix_math_evaluate_cubic(Sshape, sigma(kw)) + ! The RWHGK16 Langmuir uses the shape function to shape the + ! enhancement to the mixing coefficient. + ShapeNoMatchAtS = cvmix_math_evaluate_cubic(NMshape, sigma(kw)) + ! (3c) Compute nonlocal term at each cell interface + if (.not.lstable) then + GAtS = cvmix_math_evaluate_cubic(Tshape2, sigma(kw)) + Tnonlocal(kw) = CVmix_kpp_params_in%nonlocal_coeff*GAtS + GAtS = cvmix_math_evaluate_cubic(Sshape2, sigma(kw)) + Snonlocal(kw) = CVmix_kpp_params_in%nonlocal_coeff*GAtS + end if + + select case (CVMix_KPP_Params_in%Langmuir_Mixing_Opt) + case (LANGMUIR_MIXING_LWF16) + MixingCoefEnhancement = Langmuir_EFactor + case (LANGMUIR_MIXING_RWHGK16) + MixingCoefEnhancement = cvmix_one + ShapeNoMatchAtS/NMshapeMax * & + (Langmuir_EFactor - cvmix_one) + case default + MixingCoefEnhancement = cvmix_one + end select + ! (3d) Diffusivity = OBL_depth * (turbulent scale) * G(sigma) + OBL_Mdiff(kw) = OBL_depth * w_m(kw) * MshapeAtS * MixingCoefEnhancement + OBL_Tdiff(kw) = OBL_depth * w_s(kw) * TshapeAtS * MixingCoefEnhancement + OBL_Sdiff(kw) = OBL_depth * w_s(kw) * SshapeAtS * MixingCoefEnhancement + end do + + ! (4) Compute the enhanced diffusivity + ! (4a) Compute shape function at last cell center in OBL + sigma_ktup = -zt(ktup)/OBL_depth + MshapeAtS = cvmix_math_evaluate_cubic(Mshape, sigma_ktup) + TshapeAtS = cvmix_math_evaluate_cubic(Tshape, sigma_ktup) + SshapeAtS = cvmix_math_evaluate_cubic(Sshape, sigma_ktup) + ! (4b) Compute turbulent scales at last cell center in OBL + call cvmix_kpp_compute_turbulent_scales(sigma_ktup, OBL_depth, surf_buoy, & + surf_fric, wm_ktup, ws_ktup, & + CVmix_kpp_params_user) + if (CVMix_KPP_Params_in%Langmuir_Mixing_Opt & + .eq. LANGMUIR_MIXING_LWF16) then + ! enhance the turbulent velocity scale + wm_ktup = wm_ktup * Langmuir_EFactor + ws_ktup = ws_ktup * Langmuir_EFactor + end if + ! (4c) Diffusivity = OBL_depth * (turbulent scale) * G(sigma) + Mdiff_ktup = OBL_depth * wm_ktup * MshapeAtS + Tdiff_ktup = OBL_depth * ws_ktup * TshapeAtS + Sdiff_ktup = OBL_depth * ws_ktup * SshapeAtS + + if (CVmix_kpp_params_in%lenhanced_diff) then + if ((ktup.eq.kwup).or.(ktup.eq.kwup-1)) then + call cvmix_kpp_compute_enhanced_diff(Mdiff_ktup, & + Tdiff_ktup, & + Sdiff_ktup, & + Mdiff_out(ktup+1), & + Tdiff_out(ktup+1), & + Sdiff_out(ktup+1), & + OBL_Mdiff(ktup+1), & + OBL_Tdiff(ktup+1), & + OBL_Sdiff(ktup+1), & + Tnonlocal(ktup+1), & + Snonlocal(ktup+1), & + delta, lkteqkw=(ktup.eq.kwup)) + else + print*, "ERROR: ktup should be either kwup or kwup-1!" + print*, "ktup = ", ktup, " and kwup = ", kwup + stop 1 + end if + end if + + ! (5) Combine interior and boundary coefficients + Mdiff_out(2:ktup+1) = OBL_Mdiff(2:ktup+1) + Tdiff_out(2:ktup+1) = OBL_Tdiff(2:ktup+1) + Sdiff_out(2:ktup+1) = OBL_Sdiff(2:ktup+1) + +!EOC + end subroutine cvmix_coeffs_kpp_low + +!BOP + +! !IROUTINE: cvmix_put_kpp_real +! !INTERFACE: + + subroutine cvmix_put_kpp_real(varname, val, CVmix_kpp_params_user) + +! !DESCRIPTION: +! Write a real value into a cvmix\_kpp\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + real(cvmix_r8), intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_kpp_params_type), intent(inout), target, optional :: & + CVmix_kpp_params_user + +!EOP +!BOC + + type(cvmix_kpp_params_type), pointer :: CVmix_kpp_params_out + + CVmix_kpp_params_out => CVmix_kpp_params_saved + if (present(CVmix_kpp_params_user)) then + CVmix_kpp_params_out => CVmix_kpp_params_user + end if + + select case (trim(varname)) + case ('Ri_crit') + CVmix_kpp_params_out%Ri_crit = val + case ('minOBLdepth') + CVmix_kpp_params_out%minOBLdepth = val + case ('maxOBLdepth') + CVmix_kpp_params_out%maxOBLdepth = val + case ('minVtsqr') + CVmix_kpp_params_out%minVtsqr = val + case ('vonkarman') + CVmix_kpp_params_out%vonkarman = val + case ('Cstar') + CVmix_kpp_params_out%Cstar = val + case ('zeta_m') + CVmix_kpp_params_out%zeta_m = val + case ('zeta_s') + CVmix_kpp_params_out%zeta_s = val + case ('a_m') + CVmix_kpp_params_out%a_m = val + case ('a_s') + CVmix_kpp_params_out%a_s = val + case ('c_m') + CVmix_kpp_params_out%c_m = val + case ('c_s') + CVmix_kpp_params_out%c_s = val + case ('surf_layer_ext') + CVmix_kpp_params_out%surf_layer_ext = val + case ('Cv') + CVmix_kpp_params_out%Cv = val + case ('nonlocal_coeff') + CVmix_kpp_params_out%nonlocal_coeff = val + case ('c_CT') + CVmix_kpp_params_out%c_CT = val + case ('c_ST') + CVmix_kpp_params_out%c_ST = val + case ('c_LT') + CVmix_kpp_params_out%c_LT = val + case ('p_LT') + CVmix_kpp_params_out%p_LT = val + case ('RWHGK_ENTR_COEF') + CVmix_kpp_params_out%rwhgk_entr_coef = val + case ('RWHGK_ENTR_EXP') + CVmix_kpp_params_out%rwhgk_entr_exp = val + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + end select + +!EOC + + end subroutine cvmix_put_kpp_real + +!BOP + +! !IROUTINE: cvmix_put_kpp_int +! !INTERFACE: + + subroutine cvmix_put_kpp_int(varname, val, CVmix_kpp_params_user) + +! !DESCRIPTION: +! Write an integer value into a cvmix\_kpp\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + integer, intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_kpp_params_type), intent(inout), target, optional :: & + CVmix_kpp_params_user + +!EOP +!BOC + + type(cvmix_kpp_params_type), pointer :: CVmix_kpp_params_out + + CVmix_kpp_params_out => CVmix_kpp_params_saved + if (present(CVmix_kpp_params_user)) then + CVmix_kpp_params_out => CVmix_kpp_params_user + end if + + select case (trim(varname)) + case ('interp_type') + CVmix_kpp_params_out%interp_type = val + case ('interp_type2') + CVmix_kpp_params_out%interp_type2 = val + case ('MatchTechnique') + CVmix_kpp_params_out%MatchTechnique = val + case ('old_vals', 'handle_old_vals') + CVmix_kpp_params_out%handle_old_vals = val + case ('Langmuir_Mixing_Opt') + CVmix_kpp_params_out%Langmuir_Mixing_opt = val + case ('Langmuir_Entrainment_Opt') + CVmix_kpp_params_out%Langmuir_Entrainment_opt = val + case DEFAULT + call cvmix_put_kpp(varname, real(val, cvmix_r8), CVmix_kpp_params_out) + end select + +!EOC + + end subroutine cvmix_put_kpp_int + +!BOP + +! !IROUTINE: cvmix_put_kpp_logical +! !INTERFACE: + + subroutine cvmix_put_kpp_logical(varname, val, CVmix_kpp_params_user) + +! !DESCRIPTION: +! Write a Boolean value into a cvmix\_kpp\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + logical, intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_kpp_params_type), intent(inout), target, optional :: & + CVmix_kpp_params_user + +!EOP +!BOC + + type(cvmix_kpp_params_type), pointer :: CVmix_kpp_params_out + + CVmix_kpp_params_out => CVmix_kpp_params_saved + if (present(CVmix_kpp_params_user)) then + CVmix_kpp_params_out => CVmix_kpp_params_user + end if + + select case (trim(varname)) + case ('lscalar_Cv') + CVmix_kpp_params_out%lscalar_Cv = val + case ('lEkman') + CVmix_kpp_params_out%lEkman = val + case ('lMonOb') + CVmix_kpp_params_out%lMonOb = val + case ('lnoDGat1') + CVmix_kpp_params_out%lnoDGat1 = val + case ('lenhanced_diff') + CVmix_kpp_params_out%lenhanced_diff = val + case ('l_LMD_ws') + CVmix_kpp_params_out%l_LMD_ws = val + case DEFAULT + print*, "ERROR: ", trim(varname), " is not a boolean variable!" + stop 1 + end select + +!EOC + + end subroutine cvmix_put_kpp_logical + +!BOP + +! !IROUTINE: cvmix_get_kpp_real +! !INTERFACE: + + function cvmix_get_kpp_real(varname, CVmix_kpp_params_user) + +! !DESCRIPTION: +! Return the real value of a cvmix\_kpp\_params\_type variable. +! NOTE: This function is not efficient and is only for infrequent +! queries of ddiff parameters, such as at initialization. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + type(cvmix_kpp_params_type), optional, target, intent(in) :: & + CVmix_kpp_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8) :: cvmix_get_kpp_real + +!EOP +!BOC + + type(cvmix_kpp_params_type), pointer :: CVmix_kpp_params_get + + CVmix_kpp_params_get => CVmix_kpp_params_saved + if (present(CVmix_kpp_params_user)) then + CVmix_kpp_params_get => CVmix_kpp_params_user + end if + + cvmix_get_kpp_real = cvmix_zero + select case (trim(varname)) + case ('Ri_crit') + cvmix_get_kpp_real = CVmix_kpp_params_get%Ri_crit + case ('vonkarman') + cvmix_get_kpp_real = CVmix_kpp_params_get%vonkarman + case ('Cstar') + cvmix_get_kpp_real = CVmix_kpp_params_get%Cstar + case ('zeta_m') + cvmix_get_kpp_real = CVmix_kpp_params_get%zeta_m + case ('zeta_s') + cvmix_get_kpp_real = CVmix_kpp_params_get%zeta_s + case ('a_m') + cvmix_get_kpp_real = CVmix_kpp_params_get%a_m + case ('a_s') + cvmix_get_kpp_real = CVmix_kpp_params_get%a_s + case ('c_m') + cvmix_get_kpp_real = CVmix_kpp_params_get%c_m + case ('c_s') + cvmix_get_kpp_real = CVmix_kpp_params_get%c_s + case ('surf_layer_ext') + cvmix_get_kpp_real = CVmix_kpp_params_get%surf_layer_ext + case ('Cv') + cvmix_get_kpp_real = CVmix_kpp_params_get%Cv + case ('c_CT') + cvmix_get_kpp_real = CVmix_kpp_params_get%c_CT + case ('c_ST') + cvmix_get_kpp_real = CVmix_kpp_params_get%c_ST + case ('c_LT') + cvmix_get_kpp_real = CVmix_kpp_params_get%c_LT + case ('p_LT') + cvmix_get_kpp_real = CVmix_kpp_params_get%p_LT + case ('RWHGK_ENTR_COEF') + cvmix_get_kpp_real = CVmix_kpp_params_get%RWHGK_ENTR_COEF + case ('RWHGK_ENTR_EXP') + cvmix_get_kpp_real = CVmix_kpp_params_get%RWHGK_ENTR_EXP + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + end select + +!EOC + + end function cvmix_get_kpp_real + +!BOP + +! !IROUTINE: cvmix_kpp_compute_OBL_depth_low +! !INTERFACE: + + subroutine cvmix_kpp_compute_OBL_depth_low(Ri_bulk, zw_iface, OBL_depth, & + kOBL_depth, zt_cntr, surf_fric, & + surf_buoy, Coriolis, & + CVmix_kpp_params_user) + +! !DESCRIPTION: +! Computes the depth of the ocean boundary layer (OBL) for a given column. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + real(cvmix_r8), dimension(:), intent(in) :: Ri_bulk + real(cvmix_r8), dimension(:), target, intent(in) :: zw_iface, & + zt_cntr + real(cvmix_r8), optional, intent(in) :: surf_fric, & + surf_buoy, & + Coriolis + type(cvmix_kpp_params_type), optional, target, intent(in) :: & + CVmix_kpp_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8), intent(out) :: OBL_depth, kOBL_depth + +!EOP +!BOC + + ! Local variables + real(kind=cvmix_r8), dimension(:), pointer :: depth + real(kind=cvmix_r8), dimension(4) :: coeffs + real(kind=cvmix_r8) :: Ekman, MoninObukhov, OBL_Limit + integer :: nlev, k + logical :: lstable + + type(cvmix_kpp_params_type), pointer :: CVmix_kpp_params_in + + CVmix_kpp_params_in => CVmix_kpp_params_saved + if (present(CVmix_kpp_params_user)) then + CVmix_kpp_params_in => CVmix_kpp_params_user + end if + + ! Error checks + ! (1) if using Ekman length, need to pass surf_fric and Coriolis + if ((.not.(present(surf_fric).and.present(Coriolis))).and. & + CVmix_kpp_params_in%lEkman) then + print*, "ERROR: must pass surf_fric and Coriolis if you want to ", & + "compute Ekman length" + stop 1 + end if + + ! (2) if using Monin-Obukhov length, need to pass surf_fric and surf_buoy + if ((.not.(present(surf_fric).and.present(surf_buoy))).and. & + CVmix_kpp_params_in%lMonOb) then + print*, "ERROR: must pass surf_fric and surf_buoy if you want to ", & + "compute Monin-Obukhov length" + stop 1 + end if + + ! (3) zt_cntr must be length nlev and zw_iface must be nlev+1 + nlev = size(zt_cntr) + if (size(zw_iface).ne.nlev+1) then + print*, "ERROR: zt_cntr must have exactly one less element than zw_iface!" + print*, "size(zt_cntr) = ", nlev, ", size(zw_iface) = ", size(zw_iface) + stop 1 + end if + + ! (4) Ri_bulk needs to be either the size of zw_iface or zt_cntr + if (size(Ri_bulk).eq.nlev) then + depth => zt_cntr + else if (size(Ri_bulk).eq.nlev+1) then + depth => zw_iface + else + print*, "ERROR: Ri_bulk must have size nlev or nlev+1!" + print*, "nlev = ", nlev, ", size(Ri_bulk) = ", size(Ri_bulk) + stop 1 + end if + + ! if lEkman = .true., OBL_depth must be between the surface and the Ekman + ! depth. Similarly, if lMonOb = .true., OBL_depth must be between the + ! surface and the Monin-Obukhov depth + OBL_limit = abs(zt_cntr(nlev)) + + ! Since depth gets more negative as you go deeper, that translates into + ! OBL_depth = max(abs(computed depth), abs(Ekman depth), abs(M-O depth)) + if (CVmix_kpp_params_in%lEkman) then + ! Column is stable if surf_buoy > 0 + lstable = (surf_buoy.gt.cvmix_zero) + + if (Coriolis.ne.cvmix_zero .and. lstable) then + Ekman = 0.7_cvmix_r8*surf_fric/abs(Coriolis) + else + ! Rather than divide by zero (or if column is unstable), set Ekman depth to ocean bottom + Ekman = abs(zt_cntr(nlev)) + end if + OBL_limit = min(OBL_limit, Ekman) + end if + + if (CVmix_kpp_params_in%lMonOb) then + ! Column is stable if surf_buoy > 0 + lstable = (surf_buoy.gt.cvmix_zero) + + if (lstable) then + MoninObukhov = surf_fric**3/(surf_buoy*CVmix_kpp_params_in%vonkarman) + else + MoninObukhov = abs(zt_cntr(nlev)) + end if + OBL_limit = min(OBL_limit, MoninObukhov) + end if + + ! Interpolation Step + ! (1) Find k such that Ri_bulk at level k+1 > Ri_crit + do k=0,size(Ri_bulk)-1 + if (Ri_bulk(k+1).gt.CVmix_kpp_params_in%ri_crit) & + exit + end do + + if (k.eq.size(Ri_bulk)) then + OBL_depth = abs(OBL_limit) + elseif (k.eq.0) then + OBL_depth = abs(zt_cntr(1)) + else + if (k.eq.1) then + call cvmix_math_poly_interp(coeffs, CVmix_kpp_params_in%interp_type, & + depth(k:k+1), Ri_bulk(k:k+1)) + else + call cvmix_math_poly_interp(coeffs, CVmix_kpp_params_in%interp_type, & + depth(k:k+1), Ri_bulk(k:k+1), depth(k-1), & + Ri_bulk(k-1)) + end if + coeffs(1) = coeffs(1)-CVmix_kpp_params_in%ri_crit + + OBL_depth = -cvmix_math_cubic_root_find(coeffs, 0.5_cvmix_r8 * & + (depth(k)+depth(k+1))) + + ! OBL_depth needs to be at or below the center of the top level + ! Note: OBL_depth can only be computed to be above this point if k=1, + ! depth => zw_iface instead of zt_cntr, and the interpolation + ! results in Ri_bulk = Ri_crit at a depth above the center of the + ! top level. + if (k.eq.1) then + OBL_depth = max(OBL_depth, -zt_cntr(1)) + end if + + ! OBL_depth needs to be at or above OBL_limit + ! Note: maybe there are times when we don't need to do the interpolation + ! because we know OBL_depth will equal OBL_limit? + OBL_depth = min(OBL_depth, OBL_limit) + end if + + OBL_depth = max(OBL_depth, CVmix_kpp_params_in%minOBLdepth) + if (CVmix_kpp_params_in%maxOBLdepth.gt.cvmix_zero) & + OBL_depth = min(OBL_depth, CVmix_kpp_params_in%maxOBLdepth) + kOBL_depth = cvmix_kpp_compute_kOBL_depth(zw_iface, zt_cntr, OBL_depth) + +!EOC + + end subroutine cvmix_kpp_compute_OBL_depth_low + +!BOP + +! !IROUTINE: cvmix_kpp_compute_kOBL_depth +! !INTERFACE: + + function cvmix_kpp_compute_kOBL_depth(zw_iface, zt_cntr, OBL_depth) + +! !DESCRIPTION: +! Computes the index of the level and interface above OBL\_depth. The index is +! stored as a real number, and the integer index can be solved for in the +! following way:\\ +! \verb|kt| = index of cell center above OBL\_depth = \verb|nint(kOBL_depth)-1| +! \verb|kw| = index of interface above OBL\_depth = \verb|floor(kOBL_depth)| +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + real(cvmix_r8), dimension(:), intent(in) :: zw_iface, zt_cntr + real(cvmix_r8), intent(in) :: OBL_depth + +! !OUTPUT PARAMETERS: + real(cvmix_r8) :: cvmix_kpp_compute_kOBL_depth + +!EOP +!BOC + + ! Local variables + integer :: kw, nlev + + nlev = size(zt_cntr) + if (size(zw_iface).ne.nlev+1) then + print*, "ERROR: there should be one more interface z coordinate than ", & + "cell center coordinate!" + stop 1 + end if + + ! Initial value = nlev + 0.75 => OBL_depth at center of bottom cell + cvmix_kpp_compute_kOBL_depth = real(nlev,cvmix_r8)+0.75_cvmix_r8 + do kw=1,nlev + if (OBL_depth.lt.abs(zw_iface(kw+1))) then + if (OBL_depth.lt.abs(zt_cntr(kw))) then + cvmix_kpp_compute_kOBL_depth = real(kw, cvmix_r8)+0.25_cvmix_r8 + else + cvmix_kpp_compute_kOBL_depth = real(kw, cvmix_r8)+0.75_cvmix_r8 + end if + exit + end if + end do + +!EOC + + end function cvmix_kpp_compute_kOBL_depth + +!BOP + +! !IROUTINE: cvmix_kpp_compute_enhanced_diff +! !INTERFACE: + + subroutine cvmix_kpp_compute_enhanced_diff(Mdiff_ktup, Tdiff_ktup, & + Sdiff_ktup, Mdiff, Tdiff, Sdiff, & + OBL_Mdiff, OBL_Tdiff, OBL_Sdiff, & + Tnonlocal, Snonlocal, & + delta, lkteqkw) + +! !DESCRIPTION: +! The enhanced mixing described in Appendix D of LMD94 changes the diffusivity +! values at the interface between the cell center above OBL\_depth and the one +! below it, based on a weighted average of how close to each center OBL\_depth +! is. Note that we need to know whether OBL\_depth is above this interface or +! below it - we do this by comparing the indexes of the cell center above +! OBL\_depth (ktup) and the cell interface above OBL\_depth(kwup). +!\\ +!\\ + +! !INPUT PARAMETERS: + + ! Diffusivity and viscosity at cell center above OBL_depth + real(cvmix_r8), intent(in) :: Mdiff_ktup, Tdiff_ktup, Sdiff_ktup + + ! Weight to use in averaging (distance between OBL_depth and cell center + ! above OBL_depth divided by distance between cell centers bracketing + ! OBL_depth). + real(cvmix_r8), intent(in) :: delta + + logical, intent(in) :: lkteqkw ! .true. => interface ktup+1 is outside OBL + ! (update diff and visc) + ! .false. => interface ktup+1 is inside OBL + ! (update OBL_diff and OBL_visc) + +! !OUTPUT PARAMETERS: + ! Will change either diff & visc or OBL_diff & OBL_visc, depending on value + ! of lkteqkw + real(cvmix_r8), intent(inout) :: Mdiff, Tdiff, Sdiff, & + OBL_Mdiff, OBL_Tdiff, OBL_Sdiff, & + Tnonlocal, Snonlocal + +!EOP +!BOC + + ! Local variables + + ! enh_diff and enh_visc are the enhanced diffusivity and viscosity values + ! at the interface nearest OBL_depth + real(cvmix_r8) :: enh_Mdiff, enh_Tdiff, enh_Sdiff + ! Need to store original OBL_Tdiff and OBL_Sdiff for updating nonlocal + real(cvmix_r8) :: old_Tdiff, old_Sdiff + + real(cvmix_r8) :: omd ! one minus delta + + omd = cvmix_one - delta + old_Tdiff = OBL_Tdiff + old_Sdiff = OBL_Sdiff + + if (lkteqkw) then + ! => ktup = kwup + ! Interface kw = ktup+1 is outside the OBL + + ! (a) compute enhanced diffs: get diffusivity values at kw = ktup+1 + ! from diff and visc rather than OBL_diff and OBL_visc + enh_Mdiff = (omd**2)*Mdiff_ktup + (delta**2)*Mdiff + enh_Tdiff = (omd**2)*Tdiff_ktup + (delta**2)*Tdiff + enh_Sdiff = (omd**2)*Sdiff_ktup + (delta**2)*Sdiff + + ! (b) modify diffusivity values at kw = ktup+1 (again in diff and visc) + Mdiff = omd*Mdiff + delta*enh_Mdiff + Tdiff = omd*Tdiff + delta*enh_Tdiff + Sdiff = omd*Sdiff + delta*enh_Sdiff + + ! (c) Update OBL_[MTS]diff + OBL_Mdiff = Mdiff + OBL_Tdiff = Tdiff + OBL_Sdiff = Sdiff + else + ! => ktup = kwup - 1 + ! Interface kw = ktup+1 is in the OBL + + ! (a) compute enhanced diffs: get diffusivity values at kw = ktup+1 + ! from OBL_diff and OBL_visc rather than diff and visc + enh_Mdiff = (omd**2)*Mdiff_ktup + (delta**2)*OBL_Mdiff + enh_Tdiff = (omd**2)*Tdiff_ktup + (delta**2)*OBL_Tdiff + enh_Sdiff = (omd**2)*Sdiff_ktup + (delta**2)*OBL_Sdiff + + ! (b) modify diffusivity values at kw = ktup+1 (again in OBL_diff and + ! OBL_visc) + OBL_Mdiff = omd*Mdiff + delta*enh_Mdiff + OBL_Tdiff = omd*Tdiff + delta*enh_Tdiff + OBL_Sdiff = omd*Sdiff + delta*enh_Sdiff + + ! (c) update nonlocal term + if (old_Tdiff.ne.cvmix_zero) then + Tnonlocal = Tnonlocal*OBL_Tdiff/old_Tdiff + else + Tnonlocal = cvmix_zero + end if + if (old_Sdiff.ne.cvmix_zero) then + Snonlocal = Snonlocal*OBL_Sdiff/old_Sdiff + else + Snonlocal = cvmix_zero + end if + end if + +! EOC + + end subroutine cvmix_kpp_compute_enhanced_diff + +!BOP + +! !IROUTINE: cvmix_kpp_compute_OBL_depth_wrap +! !INTERFACE: + + subroutine cvmix_kpp_compute_OBL_depth_wrap(CVmix_vars, CVmix_kpp_params_user) + +! !DESCRIPTION: +! Computes the depth of the ocean boundary layer (OBL) for a given column. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_kpp_params_type), optional, target, intent(in) :: & + CVmix_kpp_params_user + +! !OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars + +!EOP +!BOC + + ! Local variables + real(cvmix_r8) :: lcl_obl_depth, lcl_kobl_depth + + call cvmix_kpp_compute_OBL_depth(CVmix_vars%BulkRichardson_cntr, & + CVmix_vars%zw_iface, & + lcl_obl_depth, lcl_kobl_depth, & + CVmix_vars%zt_cntr, & + CVmix_vars%SurfaceFriction, & + CVmix_vars%SurfaceBuoyancyForcing, & + CVmix_vars%Coriolis, & + CVmix_kpp_params_user) + call cvmix_put(CVmix_vars, 'OBL_depth', lcl_obl_depth) + call cvmix_put(CVmix_vars, 'kOBL_depth', lcl_kobl_depth) + +!EOC + + end subroutine cvmix_kpp_compute_OBL_depth_wrap + +!BOP + +! !IROUTINE: cvmix_kpp_compute_bulk_Richardson +! !INTERFACE: + + function cvmix_kpp_compute_bulk_Richardson(zt_cntr, delta_buoy_cntr, & + delta_Vsqr_cntr, Vt_sqr_cntr, & + ws_cntr, N_iface, Nsqr_iface, & + EFactor, LaSL, bfsfc, ustar, & + CVmix_kpp_params_user) + +! !DESCRIPTION: +! Computes the bulk Richardson number at cell centers. If \verb|Vt_sqr_cntr| +! is not present, this routine will call \verb|compute_unresolved_shear|, +! a routine that requires \verb|ws_cntr| and either \verb|N_iface| or +! \verb|Nsqr_iface|. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + ! * zt_cntr is level-center height (d in LMD94, units: m) + ! * delta_buoy_cntr is the mean buoyancy estimate over surface layer minus + ! the level-center buoyancy ( (Br-B(d)) in LMD94, units: m/s^2) + ! * delta_Vsqr_cntr is the square of the magnitude of the mean velocity + ! estimate over surface layer minus the level-center velocity + ! ( |Vr-V(d)|^2 in LMD94, units: m^2/s^2) + real(cvmix_r8), dimension(:), intent(in) :: zt_cntr, delta_buoy_cntr, & + delta_Vsqr_cntr + ! * ws_cntr: w_s (turbulent scale factor) at center of cell (units: m/s) + ! * N_iface: buoyancy frequency at interfaces (units: 1/s) + ! * Nsqr_iface: squared buoyancy frequency at interfaces (units: 1/s^2) + ! * Vt_sqr_cntr: squared unresolved shear term (units m^2/s^2) + ! See note in description about what values should be passed in + real(cvmix_r8), dimension(size(zt_cntr)), intent(in), optional :: & + ws_cntr, Vt_sqr_cntr + real(cvmix_r8), dimension(size(zt_cntr)+1), intent(in), optional :: & + N_iface, Nsqr_iface + ! * EFactor: Langmuir enhancement factor for entrainment (units: none) + ! * LaSL: surface layer averaged Langmuir number (units: none) + ! * bfsfc: surface buoyancy flux (units: m^2/s^3) + ! * ustar: friction velocity (units: m/s) + real(cvmix_r8), intent(in), optional :: EFactor, LaSL, bfsfc, ustar + type(cvmix_kpp_params_type), intent(in), optional, target :: & + CVmix_kpp_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8), dimension(size(zt_cntr)) :: & + cvmix_kpp_compute_bulk_Richardson + +!EOP +!BOC + + ! Local variables + ! * unresolved_shear_cntr_sqr is the square of the unresolved level-center + ! velocity shear (Vt^2(d) in LMD94, units: m^2/s^2) + real(cvmix_r8), dimension(size(zt_cntr)) :: unresolved_shear_cntr_sqr + integer :: kt + real(cvmix_r8) :: scaling, num, denom + type(cvmix_kpp_params_type), pointer :: CVmix_kpp_params_in + + CVmix_kpp_params_in => CVmix_kpp_params_saved + if (present(CVmix_kpp_params_user)) then + CVmix_kpp_params_in => CVmix_kpp_params_user + end if + + ! Make sure all arguments are same size + if (any((/size(delta_buoy_cntr), size(delta_Vsqr_cntr)/).ne. & + size(zt_cntr))) then + print*, "ERROR: delta_buoy, delta_vel_sqr, and zt_cntr must all be the",& + "same size!" + stop 1 + end if + if (present(Vt_sqr_cntr)) then + if (size(Vt_sqr_cntr).eq.size(zt_cntr)) then + unresolved_shear_cntr_sqr = Vt_sqr_cntr + else + print*, "ERROR: Vt_sqr_cntr must be the same size as zt_cntr!" + stop 1 + end if + else + if (.not.present(ws_cntr)) then + print*, "ERROR: you must pass in either Vt_sqr_cntr or ws_cntr!" + stop 1 + end if + unresolved_shear_cntr_sqr = cvmix_kpp_compute_unresolved_shear( & + zt_cntr, ws_cntr, N_iface, Nsqr_iface, & + EFactor, LaSL, bfsfc, ustar, & + CVmix_kpp_params_user) + end if + + ! scaling because we want (d-dr) = (d-0.5*eps*d) = (1-0.5*eps)*d + scaling = cvmix_one - 0.5_cvmix_r8*CVmix_kpp_params_in%surf_layer_ext + do kt=1,size(zt_cntr) + ! Negative sign because we use positive-up for height + num = -scaling*zt_cntr(kt)*delta_buoy_cntr(kt) + denom = delta_Vsqr_cntr(kt) + unresolved_shear_cntr_sqr(kt) + if (denom.ne.cvmix_zero) then + cvmix_kpp_compute_bulk_Richardson(kt) = num/denom + else + ! Need a better fudge factor? + cvmix_kpp_compute_bulk_Richardson(kt) = num*1e10_cvmix_r8 + end if + end do + +!EOC + + end function cvmix_kpp_compute_bulk_Richardson + +!BOP + +! !IROUTINE: cvmix_kpp_compute_turbulent_scales_0d +! !INTERFACE: + + subroutine cvmix_kpp_compute_turbulent_scales_0d(sigma_coord, OBL_depth, & + surf_buoy_force, & + surf_fric_vel, & + w_m, w_s, & + CVmix_kpp_params_user) + +! !DESCRIPTION: +! Computes the turbulent velocity scales for momentum (\verb|w_m|) and scalars +! (\verb|w_s|) at a single $\sigma$ coordinate. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + real(cvmix_r8), intent(in) :: sigma_coord + real(cvmix_r8), intent(in) :: OBL_depth, surf_buoy_force, surf_fric_vel + type(cvmix_kpp_params_type), intent(in), optional, target :: & + CVmix_kpp_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8), optional, intent(inout) :: w_m + real(cvmix_r8), optional, intent(inout) :: w_s + +!EOP +!BOC + + ! Local variables + real(cvmix_r8), dimension(1) :: sigma, lcl_wm, lcl_ws + logical :: compute_wm, compute_ws + + compute_wm = present(w_m) + compute_ws = present(w_s) + sigma(1) = sigma_coord + if (compute_wm) & + lcl_wm(1) = w_m + if (compute_ws) & + lcl_ws(1) = w_s + if (compute_wm.and.compute_ws) then + call cvmix_kpp_compute_turbulent_scales(sigma, OBL_depth, & + surf_buoy_force, surf_fric_vel, & + w_m = lcl_wm, w_s = lcl_ws, & + CVmix_kpp_params_user=CVmix_kpp_params_user) + else + if (compute_wm) & + call cvmix_kpp_compute_turbulent_scales(sigma, OBL_depth, & + surf_buoy_force,surf_fric_vel,& + w_m = lcl_wm, & + CVmix_kpp_params_user=CVmix_kpp_params_user) + if (compute_ws) & + call cvmix_kpp_compute_turbulent_scales(sigma, OBL_depth, & + surf_buoy_force,surf_fric_vel,& + w_s = lcl_ws, & + CVmix_kpp_params_user=CVmix_kpp_params_user) + end if + + if (compute_wm) & + w_m = lcl_wm(1) + if (compute_ws) & + w_s = lcl_ws(1) + +!EOC + + end subroutine cvmix_kpp_compute_turbulent_scales_0d + +!BOP + +! !IROUTINE: cvmix_kpp_compute_turbulent_scales_1d +! !INTERFACE: + + subroutine cvmix_kpp_compute_turbulent_scales_1d_sigma(sigma_coord, & + OBL_depth, & + surf_buoy_force, & + surf_fric_vel, & + w_m, w_s, & + CVmix_kpp_params_user) + +! !DESCRIPTION: +! Computes the turbulent velocity scales for momentum (\verb|w_m|) and scalars +! (\verb|w_s|) given a 1d array of $\sigma$ coordinates. Note that the +! turbulent scales are a continuous function, so there is no restriction to +! only evaluating this routine at interfaces or cell centers. Also, if +! $\sigma >$ \verb|surf_layer_ext| (which is typically 0.1), \verb|w_m| and +! \verb|w_s| will be evaluated at the latter value. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + real(cvmix_r8), dimension(:), intent(in) :: sigma_coord + real(cvmix_r8), intent(in) :: OBL_depth, surf_buoy_force, surf_fric_vel + type(cvmix_kpp_params_type), intent(in), optional, target :: & + CVmix_kpp_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8), optional, dimension(size(sigma_coord)), intent(inout) :: & + w_m, w_s + +!EOP +!BOC + + ! Local variables + integer :: n_sigma, kw + logical :: compute_wm, compute_ws, l_LMD_ws + real(cvmix_r8), dimension(size(sigma_coord)) :: zeta, sigma_loc + real(cvmix_r8) :: vonkar, surf_layer_ext + type(cvmix_kpp_params_type), pointer :: CVmix_kpp_params_in + + n_sigma = size(sigma_coord) + + CVmix_kpp_params_in => CVmix_kpp_params_saved + if (present(CVmix_kpp_params_user)) then + CVmix_kpp_params_in => CVmix_kpp_params_user + end if + + compute_wm = present(w_m) + compute_ws = present(w_s) + + l_LMD_ws = CVmix_kpp_params_in%l_LMD_ws + vonkar = CVmix_kpp_params_in%vonkarman + surf_layer_ext = CVmix_kpp_params_in%surf_layer_ext + + if (surf_fric_vel.ne.cvmix_zero) then + if ((surf_buoy_force.ge.cvmix_zero) .and. l_LMD_ws) then + sigma_loc(:) = sigma_coord(:) + else + sigma_loc(:) = min(surf_layer_ext, sigma_coord(:)) + end if + ! compute scales at sigma if sigma < surf_layer_ext, otherwise compute + ! at surf_layer_ext + zeta(:) = sigma_loc(:) * OBL_depth * surf_buoy_force * vonkar / & + (surf_fric_vel**3) + + if (compute_wm) then + w_m(1) = compute_phi_inv(zeta(1), CVmix_kpp_params_in, lphi_m=.true.)*& + vonkar*surf_fric_vel + do kw=2,n_sigma + if (zeta(kw).eq.zeta(kw-1)) then + w_m(kw) = w_m(kw-1) + else + w_m(kw) = vonkar*surf_fric_vel*compute_phi_inv(zeta(kw), & + CVmix_kpp_params_in, lphi_m=.true.) + end if + end do + end if + if (compute_ws) then + w_s(1) = compute_phi_inv(zeta(1), CVmix_kpp_params_in, lphi_s=.true.)*& + vonkar*surf_fric_vel + do kw=2,n_sigma + if (zeta(kw).eq.zeta(kw-1)) then + w_s(kw) = w_s(kw-1) + else + w_s(kw) = vonkar*surf_fric_vel*compute_phi_inv(zeta(kw), & + CVmix_kpp_params_in, lphi_s=.true.) + end if + end do + end if + else ! surf_fric_vel = 0 + if (compute_wm) then + if (surf_buoy_force.ge.cvmix_zero) then + ! Stable regime with surf_fric_vel = 0 => w_m = 0 + w_m = cvmix_zero + else + ! Unstable forcing, Eqs. (13) and (B1c) reduce to following + do kw=1,n_sigma + ! Compute (u*/phi_m)^3 [this is where the zeros in numerator and + ! denominator cancel when u* = 0] + w_m(kw) = -CVmix_kpp_params_in%c_m * & + min(surf_layer_ext, sigma_coord(kw)) * OBL_depth * & + vonkar * surf_buoy_force + ! w_m = vonkar * u* / phi_m + ! = vonkar * ((u*/phi_m)^3)^1/3 + w_m(kw) = vonkar*(w_m(kw)**(cvmix_one/real(3,cvmix_r8))) + end do + end if ! surf_buoy_force >= 0 + end if ! compute_wm + + if (compute_ws) then + if (surf_buoy_force.ge.cvmix_zero) then + ! Stable regime with surf_fric_vel = 0 => w_s = 0 + w_s = cvmix_zero + else + ! Unstable forcing, Eqs. (13) and (B1e) reduce to following + do kw=1,n_sigma + ! Compute (u*/phi_s)^3 [this is where the zeros in numerator and + ! denominator cancel when u* = 0] + w_s(kw) = -CVmix_kpp_params_in%c_s * & + min(surf_layer_ext, sigma_coord(kw)) * OBL_depth * & + vonkar * surf_buoy_force + ! w_s = vonkar * u* / phi_s + ! = vonkar * ((u*/phi_s)^3)^1/3 + w_s(kw) = vonkar*(w_s(kw)**(cvmix_one/real(3,cvmix_r8))) + end do + end if ! surf_buoy_force >= 0 + end if ! compute_ws + end if ! surf_fric_vel != 0 + +!EOC + + end subroutine cvmix_kpp_compute_turbulent_scales_1d_sigma + + subroutine cvmix_kpp_compute_turbulent_scales_1d_OBL(sigma_coord, & + OBL_depth, & + surf_buoy_force, & + surf_fric_vel, & + w_m, w_s, & + CVmix_kpp_params_user) + +! !DESCRIPTION: +! Computes the turbulent velocity scales for momentum (\verb|w_m|) and scalars +! (\verb|w_s|) given a single $\sigma$ coordinate and an array of boundary +! layer depths. Note that the turbulent scales are a continuous function, so +! there is no restriction to only evaluating this routine at interfaces or +! cell centers. Also, if $\sigma >$ \verb|surf_layer_ext| (which is typically +! 0.1), \verb|w_m| and \verb|w_s| will be evaluated at the latter value. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + real(cvmix_r8), intent(in) :: sigma_coord + real(cvmix_r8), intent(in) :: surf_fric_vel + real(cvmix_r8), dimension(:), intent(in) :: surf_buoy_force, OBL_depth + type(cvmix_kpp_params_type), intent(in), optional, target :: & + CVmix_kpp_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8), optional, dimension(size(surf_buoy_force)), intent(inout) & + :: w_m, w_s + +!EOP +!BOC + + ! Local variables + integer :: n_sigma, kw + logical :: compute_wm, compute_ws, l_LMD_ws + real(cvmix_r8), dimension(size(surf_buoy_force)) :: zeta, sigma_loc + real(cvmix_r8) :: vonkar, surf_layer_ext + type(cvmix_kpp_params_type), pointer :: CVmix_kpp_params_in + + n_sigma = size(surf_buoy_force) + + CVmix_kpp_params_in => CVmix_kpp_params_saved + if (present(CVmix_kpp_params_user)) then + CVmix_kpp_params_in => CVmix_kpp_params_user + end if + + compute_wm = present(w_m) + compute_ws = present(w_s) + + l_LMD_ws = CVmix_kpp_params_in%l_LMD_ws + vonkar = CVmix_kpp_params_in%vonkarman + surf_layer_ext = CVmix_kpp_params_in%surf_layer_ext + + if (surf_fric_vel.ne.cvmix_zero) then + sigma_loc = min(surf_layer_ext, sigma_coord) + if (l_LMD_ws) then + where (surf_buoy_force.ge.cvmix_zero) + sigma_loc = sigma_coord + end where + end if + zeta(:) = sigma_loc(:) * OBL_depth(:) * surf_buoy_force(:) * vonkar / & + (surf_fric_vel**3) + + if (compute_wm) then + w_m(1) = compute_phi_inv(zeta(1), CVmix_kpp_params_in, lphi_m=.true.)*& + vonkar*surf_fric_vel + do kw=2,n_sigma + if (zeta(kw).eq.zeta(kw-1)) then + w_m(kw) = w_m(kw-1) + else + w_m(kw) = compute_phi_inv(zeta(kw), CVmix_kpp_params_in, lphi_m=.true.)*& + vonkar*surf_fric_vel + end if + end do + end if + + if (compute_ws) then + w_s(1) = compute_phi_inv(zeta(1), CVmix_kpp_params_in, lphi_s=.true.)*& + vonkar*surf_fric_vel + do kw=2,n_sigma + if (zeta(kw).eq.zeta(kw-1)) then + w_s(kw) = w_s(kw-1) + else + w_s(kw) = compute_phi_inv(zeta(kw), CVmix_kpp_params_in, lphi_s=.true.)*& + vonkar*surf_fric_vel + end if + end do + end if + + else ! surf_fric_vel = 0 + if (compute_wm) then + ! Unstable forcing, Eqs. (13) and (B1c) reduce to following + do kw=1,n_sigma + if(surf_buoy_force(kw) .ge. cvmix_zero) then + w_m(kw) = cvmix_zero + else + ! Compute (u*/phi_m)^3 [this is where the zeros in numerator and + ! denominator cancel when u* = 0] + w_m(kw) = -CVmix_kpp_params_in%c_m * & + min(surf_layer_ext, sigma_coord) * OBL_depth(kw) * & + vonkar * surf_buoy_force(kw) + ! w_m = vonkar * u* / phi_m + ! = vonkar * ((u*/phi_m)^3)^1/3 + w_m(kw) = vonkar*(w_m(kw)**(cvmix_one/real(3,cvmix_r8))) + endif + end do + end if ! compute_wm + + if (compute_ws) then + ! Unstable forcing, Eqs. (13) and (B1e) reduce to following + do kw=1,n_sigma + if (surf_buoy_force(kw) .ge. cvmix_zero) then + ! Stable regime with surf_fric_vel = 0 => w_s = 0 + w_s(kw) = cvmix_zero + else + ! Unstable forcing, Eqs. (13) and (B1e) reduce to following + ! Compute (u*/phi_s)^3 [this is where the zeros in numerator and + ! denominator cancel when u* = 0] + w_s(kw) = -CVmix_kpp_params_in%c_s * & + min(surf_layer_ext, sigma_coord) * OBL_depth(kw) * & + vonkar * surf_buoy_force(kw) + ! w_s = vonkar * u* / phi_s + ! = vonkar * ((u*/phi_s)^3)^1/3 + w_s(kw) = vonkar*(w_s(kw)**(cvmix_one/real(3,cvmix_r8))) + end if ! surf_buoy_force >= 0 + end do + end if ! compute_ws + end if ! surf_fric_vel != 0 + +!EOC + + end subroutine cvmix_kpp_compute_turbulent_scales_1d_OBL + +!BOP + +! !IROUTINE: cvmix_kpp_compute_unresolved_shear +! !INTERFACE: + + function cvmix_kpp_compute_unresolved_shear(zt_cntr, ws_cntr, N_iface, & + Nsqr_iface, EFactor, & + LaSL, bfsfc, ustar, & + CVmix_kpp_params_user) + +! !DESCRIPTION: +! Computes the square of the unresolved shear ($V_t^2$ in Eq. (23) of LMD94) +! at cell centers. Note that you must provide either the buoyancy frequency +! or its square at cell interfaces, this routine by default will use the +! lower cell interface value as the cell center, but you can instead take +! an average of the top and bottom interface values by setting +! lavg\_N\_or\_Nsqr = .true. in cvmix\_kpp\_init(). If you pass in Nsqr then +! negative values are assumed to be zero (default POP behavior). +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + ! zt_cntr: height at center of cell (units: m) + ! ws_cntr: w_s (turbulent scale factor) at center of cell (units: m/s) + real(cvmix_r8), dimension(:), intent(in) :: zt_cntr, ws_cntr + ! N_iface: buoyancy frequency at cell interfaces (units: 1/s) + ! Nsqr_iface: squared buoyancy frequency at cell interfaces (units: 1/s^2) + ! note that you must provide exactly one of these two inputs! + real(cvmix_r8), dimension(size(zt_cntr)+1), intent(in), optional :: & + N_iface, Nsqr_iface + ! EFactor: Langmuir enhancement factor (units: none) + ! LaSL: surface layer averaged Langmuir number (units: none) + ! bfsfc: surface buoyancy flux (units: m^2/s^3) + ! ustar: friction velocity (units: m/s) + real(cvmix_r8), intent(in), optional :: EFactor, LaSL, bfsfc, ustar + type(cvmix_kpp_params_type), intent(in), optional, target :: & + CVmix_kpp_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8), dimension(size(zt_cntr)) :: & + cvmix_kpp_compute_unresolved_shear + +!EOP +!BOC + + ! Local variables + integer :: kt, nlev + real(cvmix_r8) :: Cv, Vtc + ! N_cntr: buoyancy frequency at cell centers, derived from either N_iface + ! or Nsqr_iface (units: 1/s) + real(cvmix_r8), dimension(size(zt_cntr)) :: N_cntr + ! c_CT, c_ST, c_LT, p_LT: parameters of Langmuir-enhanced entrainment + ! in Li and Fox-Kemper, 2017, JPO + real(cvmix_r8) :: c_CT, c_ST, c_LT, p_LT + ! RWHGK_ENTR_COEF, RWHGK_ENTR_EXP: parameters of Langmuir-enhanced + ! entrainment in Reichl et al., 2016, JPO + real(cvmix_r8) :: RWHGK_ENTR_COEF, RWHGK_ENTR_EXP + ! Vt2_Enhancement: enhancement factor for unresolved shear + real(cvmix_r8) :: Vt2_Enhancement + type(cvmix_kpp_params_type), pointer :: CVmix_kpp_params_in + + nlev = size(zt_cntr) + if (size(ws_cntr).ne.nlev) then + print*, "ERROR: zt_cntr and ws_cntr must be same size" + stop 1 + end if + + if (present(N_iface).and.present(Nsqr_iface)) then + print*, "ERROR: you must provide N_iface OR Nsqr_iface, can not send", & + "both!" + stop 1 + end if + + CVmix_kpp_params_in => CVmix_kpp_params_saved + if (present(CVmix_kpp_params_user)) then + CVmix_kpp_params_in => CVmix_kpp_params_user + end if + + if (present(N_iface)) then + if (size(N_iface).ne.(nlev+1)) then + print*, "ERROR: N_iface must have one more element than zt_cntr" + stop 1 + end if + do kt=1,nlev + N_cntr(kt) = N_iface(kt+1) + end do + else + if (present(Nsqr_iface)) then + if (size(Nsqr_iface).ne.(nlev+1)) then + print*, "ERROR: Nsqr_iface must have one more element than zt_cntr" + stop 1 + end if + do kt=1,nlev + N_cntr(kt)=sqrt(max(Nsqr_iface(kt+1),cvmix_zero)) + end do + else + print*, "ERROR: you must provide N_iface OR Nsqr_iface" + stop 1 + end if + end if + + ! options for Langmuir enhanced entrainment + select case (CVmix_kpp_params_in%Langmuir_Entrainment_Opt) + + case (LANGMUIR_ENTRAINMENT_LWF16) + if (.not.(present(EFactor) )) then + print*, "ERROR: you must pass in EFactor if ",& + "Langmuir_entrainment_str .eq. 'LWF16'!" + stop 1 + end if + Vt2_Enhancement = EFactor + + ! From LMD 94, Vtc = sqrt(-beta_T/(c_s*eps))/kappa^2 + Vtc = sqrt(0.2_cvmix_r8/(cvmix_get_kpp_real('c_s', CVmix_kpp_params_in) * & + cvmix_get_kpp_real('surf_layer_ext', CVmix_kpp_params_in))) / & + (cvmix_get_kpp_real('vonkarman', CVmix_kpp_params_in)**2) + + do kt=1,nlev + if (CVmix_kpp_params_in%lscalar_Cv) then + Cv = cvmix_get_kpp_real('Cv', CVmix_kpp_params_in) + else + ! Cv computation comes from Danabasoglu et al., 2006 + if (N_cntr(kt).lt.0.002_cvmix_r8) then + Cv = 2.1_cvmix_r8-real(200,cvmix_r8)*N_cntr(kt) + else + Cv = 1.7_cvmix_r8 + end if + end if + + cvmix_kpp_compute_unresolved_shear(kt) = -Cv*Vtc*zt_cntr(kt)* & + N_cntr(kt)*ws_cntr(kt)/ & + CVmix_kpp_params_in%Ri_crit * Vt2_Enhancement + if (cvmix_kpp_compute_unresolved_shear(kt).lt. & + CVmix_kpp_params_in%minVtsqr) then + cvmix_kpp_compute_unresolved_shear(kt) = CVmix_kpp_params_in%minVtsqr + end if + end do + + case (LANGMUIR_ENTRAINMENT_LF17) + + if (.not.(present(LaSL) .and. present(bfsfc) .and. present(ustar))) then + print*, "ERROR: you must pass in LaSL, bfsfc and ustar if ",& + "Langmuir_entrainment_str == 'LF17'!" + stop 1 + end if + ! only apply Langmuir enhanced entrainment under unstable condition + if (bfsfc require non-negative dnu_dz + if (dnu_dz_above.lt.0.0_cvmix_r8) dnu_dz_above = 0.0_cvmix_r8 + if (dnu_dz_below.lt.0.0_cvmix_r8) dnu_dz_below = 0.0_cvmix_r8 + + ! (2) Compute dnu/dz at OBL_depth by weighted average of values + ! computed above (see LMD94, Eq. (D5) for details) + iface_depth = depths_cntr(1) - 0.5_cvmix_r8*layer_widths(1) + wgt = (-iface_depth-OBL_depth) / layer_widths(1) + dnu_dz_local = wgt*dnu_dz_above + (cvmix_one-wgt)*dnu_dz_below + + ! (3) Linear interpolant: slope = value computed in (2) and the line goes + ! through the point (iface_depth, diffs_iface(1)) + coeffs = cvmix_zero + coeffs(1) = diffs_iface(1) - dnu_dz_local*iface_depth + coeffs(2) = dnu_dz_local + if (present(dnu_dz)) then + dnu_dz = dnu_dz_local + end if + cvmix_kpp_compute_nu_at_OBL_depth_LMD94=cvmix_math_evaluate_cubic(coeffs, & + -OBL_depth) +! call cvmix_math_poly_interp(coeffs, interp_type2, layer_depth, layer_nu,& +! depth_2above, nu_2above) +! cvmix_kpp_compute_nu_at_OBL_depth = cvmix_math_evaluate_cubic(coeffs, & +! -OBL_depth,& +! dnu_dz) + + end function cvmix_kpp_compute_nu_at_OBL_depth_LMD94 + +!EOC + + function cvmix_kpp_EFactor_model(u10, ustar, hbl, CVmix_params_in) + +! This function returns the enhancement factor, given the 10-meter +! wind (m/s), friction velocity (m/s) and the boundary layer depth (m). +! +! Qing Li, 160606 + +! Input + real(cvmix_r8), intent(in) :: & + ! 10 meter wind (m/s) + u10, & + ! water-side surface friction velocity (m/s) + ustar, & + ! boundary layer depth (m) + hbl + type(cvmix_global_params_type), intent(in) :: CVmix_params_in + +! Local variables + real(cvmix_r8) :: us_sl, lasl_sqr_i + real(cvmix_r8) :: cvmix_kpp_EFactor_model + + if (u10 .gt. cvmix_zero .and. ustar .gt. cvmix_zero) then + ! surface layer averaged Stokes drift + us_sl = cvmix_kpp_ustokes_SL_model(u10, hbl, CVmix_params_in) + ! + ! LaSL^{-2} + lasl_sqr_i = us_sl/ustar + ! + ! enhancement factor (Li et al., 2016) + cvmix_kpp_EFactor_model = sqrt(cvmix_one & + +cvmix_one/1.5_cvmix_r8**2*lasl_sqr_i & + +cvmix_one/5.4_cvmix_r8**4*lasl_sqr_i**2) + else + ! otherwise set to one + cvmix_kpp_EFactor_model = cvmix_one + endif + + end function cvmix_kpp_EFactor_model + + function cvmix_kpp_ustokes_SL_model(u10, hbl, CVmix_params_in) + +! This function returns the surface layer averaged Stokes drift, given +! the 10-meter wind (m/s) and the boundary layer depth (m). +! +! Qing Li, 20180130 + +! Input + real(cvmix_r8), intent(in) :: & + ! 10 meter wind (m/s) + u10, & + ! boundary layer depth (m) + hbl + type(cvmix_global_params_type), intent(in) :: CVmix_params_in +! Local variables + ! parameters + real(cvmix_r8), parameter :: & + ! ratio of U19.5 to U10 (Holthuijsen, 2007) + u19p5_to_u10 = 1.075_cvmix_r8, & + ! ratio of mean frequency to peak frequency for + ! Pierson-Moskowitz spectrum (Webb, 2011) + fm_to_fp = 1.296_cvmix_r8, & + ! ratio of surface Stokes drift to U10 + us_to_u10 = 0.0162_cvmix_r8, & + ! loss ratio of Stokes transport + r_loss = 0.667_cvmix_r8 + + real(cvmix_r8) :: us, hm0, fm, fp, vstokes, kphil, kstar + real(cvmix_r8) :: z0, z0i, r1, r2, r3, r4, tmp + real(cvmix_r8) :: cvmix_kpp_ustokes_SL_model + + if (u10 .gt. cvmix_zero) then + ! surface Stokes drift + us = us_to_u10*u10 + ! + ! significant wave height from Pierson-Moskowitz + ! spectrum (Bouws, 1998) + hm0 = 0.0246_cvmix_r8*u10**2 + ! + ! peak frequency (PM, Bouws, 1998) + tmp = 2.0_cvmix_r8*cvmix_PI*u19p5_to_u10*u10 + fp = 0.877_cvmix_r8*CVmix_params_in%Gravity/tmp + ! + ! mean frequency + fm = fm_to_fp*fp + ! + ! total Stokes transport (a factor r_loss is applied to account + ! for the effect of directional spreading, multidirectional waves + ! and the use of PM peak frequency and PM significant wave height + ! on estimating the Stokes transport) + vstokes = 0.125_cvmix_r8*cvmix_PI*r_loss*fm*hm0**2 + ! + ! the general peak wavenumber for Phillips' spectrum + ! (Breivik et al., 2016) with correction of directional spreading + kphil = 0.176_cvmix_r8*us/vstokes + ! + ! surface layer averaged Stokes dirft with Stokes drift profile + ! estimated from Phillips' spectrum (Breivik et al., 2016) + ! the directional spreading effect from Webb and Fox-Kemper, 2015 + ! is also included + kstar = kphil*2.56_cvmix_r8 + ! surface layer + z0 = 0.2_cvmix_r8*abs(hbl) + z0i = cvmix_one/z0 + ! term 1 to 4 + r1 = (0.151_cvmix_r8/kphil*z0i-0.84_cvmix_r8) & + *(cvmix_one-exp(-2.0_cvmix_r8*kphil*z0)) + r2 = -(0.84_cvmix_r8+0.0591_cvmix_r8/kphil*z0i) & + *sqrt(2.0_cvmix_r8*cvmix_PI*kphil*z0) & + *erfc(sqrt(2.0_cvmix_r8*kphil*z0)) + r3 = (0.0632_cvmix_r8/kstar*z0i+0.125_cvmix_r8) & + *(cvmix_one-exp(-2.0_cvmix_r8*kstar*z0)) + r4 = (0.125_cvmix_r8+0.0946_cvmix_r8/kstar*z0i) & + *sqrt(2.0_cvmix_r8*cvmix_PI*kstar*z0) & + *erfc(sqrt(2.0_cvmix_r8*kstar*z0)) + cvmix_kpp_ustokes_SL_model = us*(0.715_cvmix_r8+r1+r2+r3+r4) + else + cvmix_kpp_ustokes_SL_model = cvmix_zero + endif + + end function cvmix_kpp_ustokes_SL_model + +end module cvmix_kpp diff --git a/parameterizations/CVmix/cvmix_math.F90 b/parameterizations/CVmix/cvmix_math.F90 new file mode 100644 index 0000000000..64d6a302b2 --- /dev/null +++ b/parameterizations/CVmix/cvmix_math.F90 @@ -0,0 +1,252 @@ +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + + module cvmix_math + +!BOP +!\newpage +! !MODULE: cvmix_math +! +! !AUTHOR: +! Michael N. Levy, NCAR (mlevy@ucar.edu) +! +! !DESCRIPTION: +! This module contains routines to compute polynomial interpolations (linear, +! quadratic, or cubic spline), evaluate third-order polynomials and their +! derivatives at specific values, and compute roots of these polynomials. +!\\ +!\\ +! +! !REVISION HISTORY: +! $Id$ +! $URL$ + +! !USES: + + use cvmix_kinds_and_types, only : cvmix_r8, & + cvmix_one + +!EOP + + implicit none + private + save + +!BOP + +! !DEFINED PARAMETERS: + integer, parameter, public :: CVMIX_MATH_INTERP_LINEAR = 1 + integer, parameter, public :: CVMIX_MATH_INTERP_QUAD = 2 + integer, parameter, public :: CVMIX_MATH_INTERP_CUBE_SPLINE = 3 + + real(cvmix_r8), parameter :: CVMIX_MATH_NEWTON_TOL = 1.0e-12_cvmix_r8 + integer, parameter :: CVMIX_MATH_MAX_NEWTON_ITERS = 100 + +! !PUBLIC MEMBER FUNCTIONS: + + public :: cvmix_math_poly_interp + public :: cvmix_math_cubic_root_find + public :: cvmix_math_evaluate_cubic + +!EOP + + contains + +!BOP + +! !IROUTINE: cvmix_math_poly_interp +! !INTERFACE: + + subroutine cvmix_math_poly_interp(coeffs, interp_type, x, y, x0, y0) + +! !DESCRIPTION: +! Given (x(1), y(1)), (x(2), y(2)), and possibly (x0, y0), compute coeffs = +! $(/a_0, a_1, a_2, a_3/)$ such that, for $f(x) = \sum a_nx^n$, the following +! hold: $f(x(1)) = y(1)$ and $f(x(2)) = y(2)$. For both quadratic and cubic +! interpolation, $f'(x(1)) = (y(1)-y0)/(x(1)-x0)$ as well, and for cubic splines +! $f'(x(2)) = (y(2) - y(1))/(x(2) - x(1))$. +! \\ +! \\ + +! !INPUT PARAMETERS: + integer, intent(in) :: interp_type + real(cvmix_r8), dimension(2), intent(in) :: x, y + real(cvmix_r8), optional, intent(in) :: x0, y0 +! !OUTPUT PARAMETERS: + real(cvmix_r8), dimension(4), intent(inout) :: coeffs + +!EOP +!BOC + + ! Local variables + real(cvmix_r8) :: det + integer :: k, k2 + real(kind=cvmix_r8), dimension(4,4) :: Minv + real(kind=cvmix_r8), dimension(4) :: rhs + + ! All interpolation assumes form of + ! y = dx^3 + cx^2 + bx + a + ! linear => c = d = 0 + ! quad => d = 0 + coeffs(1:4) = 0.0_cvmix_r8 + select case (interp_type) + case (CVMIX_MATH_INTERP_LINEAR) + ! Match y(1) and y(2) +! print*, "Linear interpolation" + coeffs(2) = (y(2)-y(1))/(x(2)-x(1)) + coeffs(1) = y(1)-coeffs(2)*x(1) + case (CVMIX_MATH_INTERP_QUAD) + ! Match y(1), y(2), and y'(1) [requires x(0)] +! print*, "Quadratic interpolation" + ! [ x2^2 x2 1 ][ c ] [ y2 ] + ! [ x1^2 x1 1 ][ b ] = [ y1 ] + ! [ 2x1 1 0 ][ a ] [ slope ] + ! ^^^ + ! M + det = -((x(2)-x(1))**2) + ! only using 3x3 block of Minv and first 3 elements of rhs + rhs(1) = y(2) + rhs(2) = y(1) + if (present(x0).and.present(y0)) then + rhs(3) = (y(1)-y0)/(x(1)-x0) + else + rhs(3) = 0.0_cvmix_r8 + end if + + Minv(1,1) = -cvmix_one/det + Minv(1,2) = cvmix_one/det + Minv(1,3) = -cvmix_one/(x(2)-x(1)) + Minv(2,1) = real(2, cvmix_r8)*x(1)/det + Minv(2,2) = -real(2, cvmix_r8)*x(1)/det + Minv(2,3) = (x(2)+x(1))/(x(2)-x(1)) + Minv(3,1) = -(x(1)**2)/det + Minv(3,2) = x(2)*(real(2, cvmix_r8)*x(1)-x(2))/det + Minv(3,3) = -x(2)*x(1)/(x(2)-x(1)) + + do k=1,3 + do k2=1,3 + ! Note: weird "4-k2" term is used because I switched from + ! y= 0x^3 + bx^2 + cx + d to + ! y = a + bx + cx^2 + 0x^3 + coeffs(k2) = coeffs(k2)+Minv(4-k2,k)*rhs(k) + end do + end do + case (CVMIX_MATH_INTERP_CUBE_SPLINE) + ! Match y(1), y(2), y'(1), and y'(2) +! print*, "Cubic spline interpolation" + ! [ x2^3 x2^2 x2 1 ][ d ] [ y2 ] + ! [ x1^3 x1^2 x1 1 ][ c ] = [ y1 ] + ! [ 3x1 2x1 1 0 ][ b ] [ slope1 ] + ! [ 3x2 2x2 1 0 ][ a ] [ slope2 ] + ! ^^^ + ! M + det = -((x(2)-x(1))**3) + rhs(1) = y(2) + rhs(2) = y(1) + if (present(x0).and.present(y0)) then + rhs(3) = (y(1)-y0)/(x(1)-x0) + else + rhs(3) = 0.0_cvmix_r8 + end if + rhs(4) = (y(2)-y(1))/(x(2)-x(1)) + + Minv(1,1) = real(2, cvmix_r8)/det + Minv(1,2) = -real(2, cvmix_r8)/det + Minv(1,3) = (x(1)-x(2))/det + Minv(1,4) = (x(1)-x(2))/det + Minv(2,1) = -real(3, cvmix_r8)*(x(2)+x(1))/det + Minv(2,2) = real(3, cvmix_r8)*(x(2)+x(1))/det + Minv(2,3) = (x(2)-x(1))*(real(2, cvmix_r8)*x(2)+x(1))/det + Minv(2,4) = (x(2)-x(1))*(real(2, cvmix_r8)*x(1)+x(2))/det + Minv(3,1) = real(6, cvmix_r8)*x(2)*x(1)/det + Minv(3,2) = -real(6, cvmix_r8)*x(2)*x(1)/det + Minv(3,3) = -x(2)*(x(2)-x(1))*(real(2, cvmix_r8)*x(1)+x(2))/det + Minv(3,4) = -x(1)*(x(2)-x(1))*(real(2, cvmix_r8)*x(2)+x(1))/det + Minv(4,1) = -(x(1)**2)*(real(3, cvmix_r8)*x(2)-x(1))/det + Minv(4,2) = -(x(2)**2)*(-real(3, cvmix_r8)*x(1)+x(2))/det + Minv(4,3) = x(1)*(x(2)**2)*(x(2)-x(1))/det + Minv(4,4) = x(2)*(x(1)**2)*(x(2)-x(1))/det + + do k=1,4 + do k2=1,4 + ! Note: weird "5-k2" term is used because I switched from + ! y = a + bx + cx^2 + dx^3 to + ! y= ax^3 + bx^2 + cx + d + coeffs(k2) = coeffs(k2)+Minv(5-k2,k)*rhs(k) + end do + end do + end select + +!EOC + + end subroutine cvmix_math_poly_interp + + function cvmix_math_cubic_root_find(coeffs, x0) + + real(cvmix_r8), dimension(4), intent(in) :: coeffs + real(cvmix_r8), intent(in) :: x0 + + real(cvmix_r8) :: cvmix_math_cubic_root_find + real(cvmix_r8) :: fun_val, root, slope + integer :: it_cnt + + root = x0 + fun_val = coeffs(4)*(root**3)+coeffs(3)*(root**2)+coeffs(2)*root+coeffs(1) + do it_cnt = 1, CVMIX_MATH_MAX_NEWTON_ITERS + if (abs(fun_val).lt.CVMIX_MATH_NEWTON_TOL) & + exit + slope = 3.0_cvmix_r8*coeffs(4)*(root**2)+2.0_cvmix_r8*coeffs(3)*root+coeffs(2) + root = root - fun_val/slope + fun_val = coeffs(4)*(root**3)+coeffs(3)*(root**2)+coeffs(2)*root+coeffs(1) + end do + cvmix_math_cubic_root_find = root + + end function cvmix_math_cubic_root_find + +!BOP + +! !IROUTINE: cvmix_math_evaluate_cubic +! !INTERFACE: + + function cvmix_math_evaluate_cubic(coeffs, x_in, fprime) + +! !DESCRIPTION: +! Computes $f(x) = a_0 + a_1x + a_2x^2 + a_3x^3$ at $x = $\verb|x_in|, where +! \verb|coeffs|$ = (/a_0, a_1, a_2, a_3/)$. If requested, can also return +! $f'(x)$ +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + real(cvmix_r8), dimension(4), intent(in) :: coeffs + real(cvmix_r8), intent(in) :: x_in + +! !OUTPUT PARAMETERS: + real(cvmix_r8) :: cvmix_math_evaluate_cubic + real(cvmix_r8), optional, intent(out) :: fprime + +!EOP +!BOC + + ! Local Variables + integer :: i + + ! Initialize both the cubic and its derivative to its constant term and + ! then add the powers of x_in via a do-loop. This both reduces the number + ! of arithmetic steps in the algorithm and avoids possible compiler issues + ! if x_in = 0 (because 0*0 is undefined in some compilers) + cvmix_math_evaluate_cubic = coeffs(1) + if (present(fprime)) & + fprime = coeffs(2) + do i=2,4 + cvmix_math_evaluate_cubic = cvmix_math_evaluate_cubic + & + coeffs(i)*(x_in**(i-1)) + if (present(fprime).and.(i.gt.2)) & + fprime = fprime + coeffs(i)*real(i-1,cvmix_r8)*(x_in**(i-2)) + end do + + end function cvmix_math_evaluate_cubic + +end module cvmix_math diff --git a/parameterizations/CVmix/cvmix_put_get.F90 b/parameterizations/CVmix/cvmix_put_get.F90 new file mode 100644 index 0000000000..44ba53664a --- /dev/null +++ b/parameterizations/CVmix/cvmix_put_get.F90 @@ -0,0 +1,595 @@ +module cvmix_put_get + +!BOP +!\newpage +! !MODULE: cvmix_put_get +! +! !AUTHOR: +! Michael N. Levy, NCAR (mlevy@ucar.edu) +! +! !DESCRIPTION: +! This module contains routines to pack data into the cvmix datatypes +! (allocating memory as necessary) and then unpack the data out. If we switch +! to pointers, the pack will just point at the right target and the unpack +! will be un-necessary. +!\\ +!\\ + +! !USES: + + use cvmix_kinds_and_types, only : cvmix_r8, & + cvmix_data_type, & + cvmix_global_params_type + use cvmix_utils, only : cvmix_att_name + +!EOP + + implicit none + private + save + +!BOP + +! !PUBLIC MEMBER FUNCTIONS: + public :: cvmix_put + + interface cvmix_put + module procedure cvmix_put_int + module procedure cvmix_put_real + module procedure cvmix_put_real_1D + module procedure cvmix_put_real_2D + module procedure cvmix_put_global_params_int + module procedure cvmix_put_global_params_real + end interface cvmix_put +!EOP + +contains + +!BOP + +! !IROUTINE: cvmix_put_int +! !INTERFACE: + + subroutine cvmix_put_int(CVmix_vars, varname, val, nlev_in) + +! !DESCRIPTION: +! Write an integer value into a cvmix\_data\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + integer, intent(in) :: val + integer, optional, intent(in) :: nlev_in + +! !OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars + +!EOP +!BOC + + ! Local variables + integer :: nlev + + if (present(nlev_in)) then + nlev = nlev_in + else + nlev = CVmix_vars%max_nlev + end if + + if ((trim(varname).ne.'nlev').and.(nlev.eq.-1)) then + print*, "ERROR: you must specify the number of levels before ", & + "you can pack data into a cvmix_data_type!" + print*, "You tried to set ", trim(varname) + stop 1 + end if + + select case (trim(cvmix_att_name(varname))) + case ('nlev') + CVmix_vars%nlev = val + if (CVmix_vars%max_nlev.eq.-1) then + CVmix_vars%max_nlev= val + end if + case ('max_nlev') + CVmix_vars%max_nlev = val + if (CVmix_vars%nlev.eq.-1) then + CVmix_vars%nlev= val + end if + case default + ! All other scalars are real(cvmix_r8) + call cvmix_put_real(CVmix_vars, varname, real(val,cvmix_r8), nlev_in) + end select +!EOC + + end subroutine cvmix_put_int + +!BOP + +! !IROUTINE: cvmix_put_real +! !INTERFACE: + + subroutine cvmix_put_real(CVmix_vars, varname, val, nlev_in) + +! !DESCRIPTION: +! Write a real value into a cvmix\_data\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + real(cvmix_r8), intent(in) :: val + integer, optional, intent(in) :: nlev_in + +! !OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars +!EOP +!BOC + + ! Local variables + integer :: nlev + + if (present(nlev_in)) then + nlev = nlev_in + else + nlev = CVmix_vars%max_nlev + end if + + if (nlev.eq.-1) then + print*, "ERROR: you must specify the number of levels before ", & + "you can pack data into a cvmix_data_type!" + print*, "You tried to set ", trim(varname) + stop 1 + end if + + select case (trim(cvmix_att_name(varname))) + case ('OceanDepth') + CVmix_vars%OceanDepth = val + case ('BoundaryLayerDepth') + CVmix_vars%BoundaryLayerDepth = val + case ('SeaSurfaceHeight') + CVmix_vars%SeaSurfaceHeight = val + case ('SurfaceFriction') + CVmix_vars%SurfaceFriction = val + case ("SurfaceBuoyancyForcing") + CVmix_vars%SurfaceBuoyancyForcing = val + case ("Latitude") + CVmix_vars%lat = val + case ("Longitude") + CVmix_vars%lon = val + case ("Coriolis") + CVmix_vars%Coriolis = val + case ("kOBL_depth") + CVmix_vars%kOBL_depth = val + case ("LangmuirEnhancementFactor") + CVmix_vars%LangmuirEnhancementFactor = val + case ("LangmuirNumber") + CVmix_vars%LangmuirNumber = val + case ('SimmonsCoeff') + CVmix_vars%SimmonsCoeff = val + + case ("dzw") +! print*, "WARNING: you are setting the cell midpoint to midpoint ", & +! "distance in all levels to a constant value" + if (.not.associated(CVmix_vars%dzw)) then + allocate(CVmix_vars%dzw(nlev+1)) + end if + CVmix_vars%dzw(:) = val + case ("Mdiff_iface") + if (.not.associated(CVmix_vars%Mdiff_iface)) then + allocate(CVmix_vars%Mdiff_iface(nlev+1)) + end if + CVmix_vars%Mdiff_iface(:) = val + case ("Tdiff_iface") + if (.not.associated(CVmix_vars%Tdiff_iface)) then + allocate(CVmix_vars%Tdiff_iface(nlev+1)) + end if + CVmix_vars%Tdiff_iface(:) = val + case ("Sdiff_iface") + if (.not.associated(CVmix_vars%Sdiff_iface)) then + allocate(CVmix_vars%Sdiff_iface(nlev+1)) + end if + CVmix_vars%Sdiff_iface(:) = val + case ("ShearRichardson_iface") +! print*, "WARNING: you are setting the Richardson number in all ", & +! "levels to a constant value" + if (.not.associated(CVmix_vars%ShearRichardson_iface)) then + allocate(CVmix_vars%ShearRichardson_iface(nlev+1)) + end if + CVmix_vars%ShearRichardson_iface(:) = val + case ("SqrBuoyancyFreq_iface") +! print*, "WARNING: you are setting the buoyancy in all levels to a ", & +! "constant value" + if (.not.associated(CVmix_vars%SqrBuoyancyFreq_iface)) then + allocate(CVmix_vars%SqrBuoyancyFreq_iface(nlev+1)) + end if + CVmix_vars%SqrBuoyancyFreq_iface(:) = val + case ("kpp_nonlocal_iface") + if (.not.associated(CVmix_vars%kpp_Tnonlocal_iface)) then + allocate(CVmix_vars%kpp_Tnonlocal_iface(nlev+1)) + end if + if (.not.associated(CVmix_vars%kpp_Snonlocal_iface)) then + allocate(CVmix_vars%kpp_Snonlocal_iface(nlev+1)) + end if + CVmix_vars%kpp_Tnonlocal_iface(:) = val + CVmix_vars%kpp_Snonlocal_iface(:) = val + case ("kpp_Tnonlocal_iface") + if (.not.associated(CVmix_vars%kpp_Tnonlocal_iface)) then + allocate(CVmix_vars%kpp_Tnonlocal_iface(nlev+1)) + end if + CVmix_vars%kpp_Tnonlocal_iface(:) = val + case ("kpp_Snonlocal_iface") + if (.not.associated(CVmix_vars%kpp_Snonlocal_iface)) then + allocate(CVmix_vars%kpp_Snonlocal_iface(nlev+1)) + end if + CVmix_vars%kpp_Snonlocal_iface(:) = val + + case ("dzt") +! print*, "WARNING: you are setting the cell thickness in all levels ", & +! "to a constant value" + if (.not.associated(CVmix_vars%dzt)) then + allocate(CVmix_vars%dzt(nlev)) + end if + CVmix_vars%dzt(:) = val + case ("WaterDensity_cntr") +! print*, "WARNING: you are setting the density in all levels to a ", & +! "constant value" + if (.not.associated(CVmix_vars%WaterDensity_cntr)) then + allocate(CVmix_vars%WaterDensity_cntr(nlev)) + end if + CVmix_vars%WaterDensity_cntr(:) = val + case ("AdiabWaterDensity_cntr") +! print*, "WARNING: you are setting the adiabatic density in all ", & +! "levels to a constant value" + if (.not.associated(CVmix_vars%AdiabWaterDensity_cntr)) then + allocate(CVmix_vars%AdiabWaterDensity_cntr(nlev)) + end if + CVmix_vars%AdiabWaterDensity_cntr(:) = val + case ("BulkRichardson_cntr") +! print*, "WARNING: you are setting the bulk Richardson number in all", & +! " levels to a constant value" + if (.not.associated(CVmix_vars%BulkRichardson_cntr)) then + allocate(CVmix_vars%BulkRichardson_cntr(nlev)) + end if + CVmix_vars%BulkRichardson_cntr(:) = val + case ('strat_param_num') +! print*, "WARNING: you are setting the numerator of the ", & +! "stratification parameter in all levels to a constant value" + if (.not.associated(CVmix_vars%strat_param_num)) then + allocate(CVmix_vars%strat_param_num(nlev)) + end if + CVmix_vars%strat_param_num(:) = val + case ('strat_param_denom') +! print*, "WARNING: you are setting the denominator of the ", & +! "stratification parameter in all levels to a constant value" + if (.not.associated(CVmix_vars%strat_param_denom)) then + allocate(CVmix_vars%strat_param_denom(nlev)) + end if + CVmix_vars%strat_param_denom(:) = val + case ("VertDep_iface") + if (.not.associated(CVmix_vars%VertDep_iface)) then + allocate(CVmix_vars%VertDep_iface(nlev+1)) + end if + CVmix_vars%VertDep_iface(:) = val + + case default + print*, "ERROR: ", trim(varname), " not a valid choice for cvmix_put_real!" + stop 1 + + end select +!EOC + + end subroutine cvmix_put_real + +!BOP + +! !IROUTINE: cvmix_put_real_1D +! !INTERFACE: + + subroutine cvmix_put_real_1D(CVmix_vars, varname, val, nlev_in) + +! !DESCRIPTION: +! Write an array of real values into a cvmix\_data\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + real(cvmix_r8), dimension(:), intent(in) :: val + integer, optional, intent(in) :: nlev_in + +! !OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars +!EOP +!BOC + + ! Local variables + integer :: nlev + + if (present(nlev_in)) then + nlev = nlev_in + else + nlev = CVmix_vars%max_nlev + end if + + if (nlev.eq.-1) then + print*, "ERROR: you must specify the number of levels before ", & + "you can pack data into a cvmix_data_type!" + print*, "You tried to set ", trim(varname) + stop 1 + end if + + select case (trim(cvmix_att_name(varname))) + case ("zw_iface") + if (.not.associated(CVmix_vars%zw_iface)) then + allocate(CVmix_vars%zw_iface(nlev+1)) + end if + CVmix_vars%zw_iface(:) = val + case ("dzw") + if (.not.associated(CVmix_vars%dzw)) then + allocate(CVmix_vars%dzw(nlev+1)) + end if + CVmix_vars%dzw(:) = val + case ("Mdiff_iface") + if (.not.associated(CVmix_vars%Mdiff_iface)) then + allocate(CVmix_vars%Mdiff_iface(nlev+1)) + end if + CVmix_vars%Mdiff_iface(:) = val + case ("Tdiff_iface") + if (.not.associated(CVmix_vars%Tdiff_iface)) then + allocate(CVmix_vars%Tdiff_iface(nlev+1)) + end if + CVmix_vars%Tdiff_iface(:) = val + case ("Sdiff_iface") + if (.not.associated(CVmix_vars%Sdiff_iface)) then + allocate(CVmix_vars%Sdiff_iface(nlev+1)) + end if + CVmix_vars%Sdiff_iface(:) = val + case ("ShearRichardson_iface") + if (.not.associated(CVmix_vars%ShearRichardson_iface)) then + allocate(CVmix_vars%ShearRichardson_iface(nlev+1)) + end if + CVmix_vars%ShearRichardson_iface(:) = val + case ("SqrBuoyancyFreq_iface") + if (.not.associated(CVmix_vars%SqrBuoyancyFreq_iface)) then + allocate(CVmix_vars%SqrBuoyancyFreq_iface(nlev+1)) + end if + CVmix_vars%SqrBuoyancyFreq_iface(:) = val + case ("kpp_nonlocal_iface") + if (.not.associated(CVmix_vars%kpp_Tnonlocal_iface)) then + allocate(CVmix_vars%kpp_Tnonlocal_iface(nlev+1)) + end if + if (.not.associated(CVmix_vars%kpp_Snonlocal_iface)) then + allocate(CVmix_vars%kpp_Snonlocal_iface(nlev+1)) + end if + CVmix_vars%kpp_Tnonlocal_iface(:) = val + CVmix_vars%kpp_Snonlocal_iface(:) = val + case ("kpp_Tnonlocal_iface") + if (.not.associated(CVmix_vars%kpp_Tnonlocal_iface)) then + allocate(CVmix_vars%kpp_Tnonlocal_iface(nlev+1)) + end if + CVmix_vars%kpp_Tnonlocal_iface(:) = val + case ("kpp_Snonlocal_iface") + if (.not.associated(CVmix_vars%kpp_Snonlocal_iface)) then + allocate(CVmix_vars%kpp_Snonlocal_iface(nlev+1)) + end if + CVmix_vars%kpp_Snonlocal_iface(:) = val + case ("VertDep_iface") + if (.not.associated(CVmix_vars%VertDep_iface)) then + allocate(CVmix_vars%VertDep_iface(nlev+1)) + end if + CVmix_vars%VertDep_iface(:) = val + case ("zt_cntr") + if (.not.associated(CVmix_vars%zt_cntr)) then + allocate(CVmix_vars%zt_cntr(nlev)) + end if + CVmix_vars%zt_cntr(:) = val + case ("dzt") + if (.not.associated(CVmix_vars%dzt)) then + allocate(CVmix_vars%dzt(nlev)) + end if + CVmix_vars%dzt(:) = val + case ("WaterDensity_cntr") + if (.not.associated(CVmix_vars%WaterDensity_cntr)) then + allocate(CVmix_vars%WaterDensity_cntr(nlev)) + end if + CVmix_vars%WaterDensity_cntr(:) = val + case ("AdiabWaterDensity_cntr") + if (.not.associated(CVmix_vars%AdiabWaterDensity_cntr)) then + allocate(CVmix_vars%AdiabWaterDensity_cntr(nlev)) + end if + CVmix_vars%AdiabWaterDensity_cntr(:) = val + case ("BulkRichardson_cntr") + if (.not.associated(CVmix_vars%BulkRichardson_cntr)) then + allocate(CVmix_vars%BulkRichardson_cntr(nlev)) + end if + CVmix_vars%BulkRichardson_cntr(:) = val + case ('strat_param_num') + if (.not.associated(CVmix_vars%strat_param_num)) then + allocate(CVmix_vars%strat_param_num(nlev)) + end if + CVmix_vars%strat_param_num(:) = val + case ('strat_param_denom') + if (.not.associated(CVmix_vars%strat_param_denom)) then + allocate(CVmix_vars%strat_param_denom(nlev)) + end if + CVmix_vars%strat_param_denom(:) = val + case ("Vx_cntr") + if (.not.associated(CVmix_vars%Vx_cntr)) then + allocate(CVmix_vars%Vx_cntr(nlev)) + end if + CVmix_vars%Vx_cntr(:) = val + case ("Vy_cntr") + if (.not.associated(CVmix_vars%Vy_cntr)) then + allocate(CVmix_vars%Vy_cntr(nlev)) + end if + CVmix_vars%Vy_cntr(:) = val + case ("SchmittnerSouthernOcean") + if (.not.associated(CVmix_vars%SchmittnerSouthernOcean)) then + allocate(CVmix_vars%SchmittnerSouthernOcean(CVmix_vars%max_nlev+1)) + end if + CVmix_vars%SchmittnerSouthernOcean(:) = val + case ("SchmittnerCoeff") + if (.not.associated(CVmix_vars%SchmittnerCoeff)) then + allocate(CVmix_vars%SchmittnerCoeff(CVmix_vars%max_nlev+1)) + end if + CVmix_vars%SchmittnerCoeff(:) = val + + case default + print*, "ERROR: ", trim(varname), " not a valid choice for cvmix_put_real_1D!" + stop 1 + + end select + +!EOC + + end subroutine cvmix_put_real_1D + +!BOP + +! !IROUTINE: cvmix_put_real_2D +! !INTERFACE: + + subroutine cvmix_put_real_2D(CVmix_vars, varname, val, nlev_in) + +! !DESCRIPTION: +! Write an array of real values into a cvmix\_data\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + real(cvmix_r8), dimension(:,:), intent(in) :: val + integer, optional, intent(in) :: nlev_in + +! !OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars +!EOP +!BOC + + ! Local variables + integer :: nlev + + if (present(nlev_in)) then + nlev = nlev_in + else + nlev = CVmix_vars%max_nlev + end if + + if (nlev.eq.-1) then + print*, "ERROR: you must specify the number of levels before ", & + "you can pack data into a cvmix_data_type!" + print*, "You tried to set ", trim(varname) + stop 1 + end if + + select case (trim(cvmix_att_name(varname))) + case ("exp_hab_zetar") + if (.not.associated(CVmix_vars%exp_hab_zetar)) then + allocate(CVmix_vars%exp_hab_zetar(CVmix_vars%nlev+1,CVmix_vars%nlev+1)) + end if + CVmix_vars%exp_hab_zetar = val + + + case default + print*, "ERROR: ", trim(varname), " not a valid choice for cvmix_put_real_2D!" + stop 1 + + end select + +!EOC + + end subroutine cvmix_put_real_2D + +!BOP + +! !IROUTINE: cvmix_put_global_params_int +! !INTERFACE: + + subroutine cvmix_put_global_params_int(CVmix_params, varname, val) + +! !DESCRIPTION: +! Write an integer value into a cvmix\_global\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + integer, intent(in) :: val + +! !OUTPUT PARAMETERS: + type (cvmix_global_params_type), intent(inout) :: CVmix_params +!EOP +!BOC + + select case (trim(varname)) + case ('max_nlev') + CVmix_params%max_nlev = val + + case default + print*, "ERROR: ", trim(varname), " not a valid choice for cvmix_put_global_params_int!" + stop 1 + + end select +!EOC + + end subroutine cvmix_put_global_params_int + +!BOP + +! !IROUTINE: cvmix_put_global_params_real +! !INTERFACE: + + subroutine cvmix_put_global_params_real(CVmix_params, varname, val) + +! !DESCRIPTION: +! Write a real value into a cvmix\_global\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + real(cvmix_r8), intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_global_params_type), intent(inout) :: CVmix_params +!EOP +!BOC + + select case (trim(varname)) + case ('prandtl','Prandtl') + CVmix_params%prandtl = val + case ('fw_rho','FreshWaterDensity') + CVmix_params%FreshWaterDensity = val + case ('sw_rho','SaltWaterDensity') + CVmix_params%SaltWaterDensity = val + case ('g','Gravity') + CVmix_params%Gravity = val + case default + print*, "ERROR: ", trim(varname), " not a valid choice for cvmix_put_global_params_real!" + stop 1 + + end select +!EOC + + end subroutine cvmix_put_global_params_real + +end module cvmix_put_get + diff --git a/parameterizations/CVmix/cvmix_shear.F90 b/parameterizations/CVmix/cvmix_shear.F90 new file mode 100644 index 0000000000..da897009e0 --- /dev/null +++ b/parameterizations/CVmix/cvmix_shear.F90 @@ -0,0 +1,692 @@ + module cvmix_shear + +!BOP +!\newpage +! !MODULE: cvmix_shear +! +! !AUTHOR: +! Michael N. Levy, NCAR (mlevy@ucar.edu) +! +! !DESCRIPTION: +! This module contains routines to initialize the derived types needed for +! shear mixing, and to set the viscosity and diffusivity coefficients. +!\\ +!\\ +! References:\\ +! * RC Pacanowski and SGH Philander. +! Parameterizations of Vertical Mixing in Numerical Models of Tropical Oceans. +! Journal of Physical Oceanography, 1981.\\ +! * WG Large, JC McWilliams, and SC Doney. +! Oceanic Vertical Mixing: A Review and a Model with a Nonlocal Boundary Layer +! Parameterization. +! Review of Geophysics, 1994. +!\\ +!\\ + +! !USES: + + use cvmix_kinds_and_types, only : cvmix_r8, & + cvmix_zero, & + cvmix_one, & + cvmix_strlen, & + cvmix_data_type, & + CVMIX_OVERWRITE_OLD_VAL, & + CVMIX_SUM_OLD_AND_NEW_VALS, & + CVMIX_MAX_OLD_AND_NEW_VALS + use cvmix_put_get, only : cvmix_put + use cvmix_utils, only : cvmix_update_wrap +!EOP + + implicit none + private + save + +!BOP + +! !PUBLIC MEMBER FUNCTIONS: + + public :: cvmix_init_shear + public :: cvmix_coeffs_shear + public :: cvmix_put_shear + public :: cvmix_get_shear_real + public :: cvmix_get_shear_str + + interface cvmix_coeffs_shear + module procedure cvmix_coeffs_shear_low + module procedure cvmix_coeffs_shear_wrap + end interface cvmix_coeffs_shear + + interface cvmix_put_shear + module procedure cvmix_put_shear_int + module procedure cvmix_put_shear_real + module procedure cvmix_put_shear_str + end interface cvmix_put_shear + +! !PUBLIC TYPES: + + ! cvmix_shear_params_type contains the necessary parameters for shear mixing + ! (currently Pacanowski-Philander or Large et al) + type, public :: cvmix_shear_params_type + private + ! Type of shear mixing to run (PP => Pacanowski-Philander, KPP => LMD94) + character(len=cvmix_strlen) :: mix_scheme + + ! Pacanowski - Philander parameters + ! See Eqs. (1) and (2) in 1981 paper + + ! numerator in viscosity term (O(5e-3) in PP81; default here is 0.01) + real(cvmix_r8) :: PP_nu_zero ! units: m^2/s + + ! coefficient of Richardson number in denominator of visc / diff terms + ! (5 in PP81) + real(cvmix_r8) :: PP_alpha ! units: unitless + + ! exponent of denominator in viscosity term (2 in PP81) + real(cvmix_r8) :: PP_exp ! units: unitless + + ! background coefficients for visc / diff terms + ! (1e-4 and 1e-5, respectively, in PP81; default here is 0 for both) + real(cvmix_r8) :: PP_nu_b ! units: m^2/s + real(cvmix_r8) :: PP_kappa_b ! units: m^2/s + + ! Large et al parameters + ! See Eq. (28b) in 1994 paper + + ! leading coefficient of shear mixing formula (5e-3 in LMD94) + real(cvmix_r8) :: KPP_nu_zero ! units: m^2/s + + ! critical Richardson number value (0.7 in LMD94) + real(cvmix_r8) :: KPP_Ri_zero ! units: unitless + + ! Exponent of unitless factor of diffusities (3 in LMD94) + real(cvmix_r8) :: KPP_exp ! units: unitless + + ! Flag for what to do with old values of CVmix_vars%[MTS]diff + integer :: handle_old_vals + end type cvmix_shear_params_type +!EOP + + type(cvmix_shear_params_type), target :: CVmix_shear_params_saved + +contains + +!BOP + +! !IROUTINE: cvmix_init_shear +! !INTERFACE: + + subroutine cvmix_init_shear(CVmix_shear_params_user, mix_scheme, & + PP_nu_zero, PP_alpha, PP_exp, PP_nu_b, & + PP_kappa_b, KPP_nu_zero, KPP_Ri_zero, KPP_exp, & + old_vals) + +! !DESCRIPTION: +! Initialization routine for shear (Richardson number-based) mixing. There are +! currently two supported schemes - set \verb|mix_scheme = 'PP'| to use the +! Pacanowski-Philander mixing scheme or set \verb|mix_scheme = 'KPP'| to use +! the interior mixing scheme laid out in Large et al. +!\\ +!\\ +! PP requires setting $\nu_0$ (\verb|PP_nu_zero| in this routine), $alpha$ +! (\verb|PP_alpha|), and $n$ (\verb|PP_exp|), and returns +! \begin{eqnarray*} +! \nu_{PP} & = & \frac{\nu_0}{(1+\alpha \textrm{Ri})^n} + \nu_b \\ +! \kappa_{PP} & = & \frac{\nu}{1+\alpha \textrm{Ri}} + \kappa_b +! \end{eqnarray*} +! Note that $\nu_b$ and $\kappa_b$ are 0 by default, with the assumption that +! background diffusivities are computed in the \verb|cvmix_background| module +! \\ +! \\ +! KPP requires setting $\nu^0$ (\verb|KPP_nu_zero|, $\textrm{Ri}_0 +! ($\verb|KPP_Ri_zero|), and $p_1$ (\verb|KPP_exp|), and returns +! $$ +! \nu_{KPP} = \left\{ +! \begin{array}{r l} +! \nu^0 & \textrm{Ri} < 0\\ +! \nu^0 \left[1 - \frac{\textrm{Ri}}{\textrm{Ri}_0}^2\right]^{p_1} +! & 0 < \textrm{Ri} +! < \textrm{Ri}_0 \\ +! 0 & \textrm{Ri}_0 < \textrm{Ri} +! \end{array} \right. +! $$ +! +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), optional, intent(in) :: mix_scheme, & + old_vals + real(cvmix_r8), optional, intent(in) :: PP_nu_zero, & + PP_alpha, & + PP_exp, & + PP_nu_b, & + PP_kappa_b, & + KPP_nu_zero, & + KPP_Ri_zero, & + KPP_exp + +! !OUTPUT PARAMETERS: + type(cvmix_shear_params_type), optional, target, intent(inout) :: & + CVmix_shear_params_user + +!EOP +!BOC + + type(cvmix_shear_params_type), pointer :: CVmix_shear_params_out + + if (present(CVmix_shear_params_user)) then + CVmix_shear_params_out => CVmix_shear_params_user + else + CVmix_shear_params_out => CVmix_shear_params_saved + end if + + if (present(mix_scheme)) then + call cvmix_put_shear("mix_scheme", trim(mix_scheme), & + CVmix_shear_params_user) + else + call cvmix_put_shear("mix_scheme", "KPP", CVmix_shear_params_user) + end if + + select case (trim(CVmix_shear_params_out%mix_scheme)) + case ('PP') + if (present(PP_nu_zero)) then + call cvmix_put_shear("PP_nu_zero", PP_nu_zero, & + CVmix_shear_params_user) + else + call cvmix_put_shear("PP_nu_zero", 0.01_cvmix_r8, & + CVmix_shear_params_user) + end if + + if (present(PP_alpha)) then + call cvmix_put_shear("PP_alpha", PP_alpha, CVmix_shear_params_user) + else + call cvmix_put_shear("PP_alpha", 5, CVmix_shear_params_user) + end if + + if (present(PP_exp)) then + call cvmix_put_shear("PP_exp", PP_exp, CVmix_shear_params_user) + else + call cvmix_put_shear("PP_exp", 2, CVmix_shear_params_user) + end if + + if (present(PP_nu_b)) then + call cvmix_put_shear("PP_nu_b", PP_nu_b, CVmix_shear_params_user) + else + call cvmix_put_shear("PP_nu_b", cvmix_zero, CVmix_shear_params_user) + end if + + if (present(PP_kappa_b)) then + call cvmix_put_shear("PP_kappa_b", PP_kappa_b, CVmix_shear_params_user) + else + call cvmix_put_shear("PP_kappa_b", cvmix_zero, CVmix_shear_params_user) + end if + + case ('KPP') + if (present(KPP_nu_zero)) then + call cvmix_put_shear("KPP_nu_zero", KPP_nu_zero, & + CVmix_shear_params_user) + else + call cvmix_put_shear("KPP_nu_zero", 50e-4_cvmix_r8, & + CVmix_shear_params_user) + end if + + if (present(KPP_Ri_zero)) then + call cvmix_put_shear("KPP_Ri_zero", KPP_Ri_zero, & + CVmix_shear_params_user) + else + call cvmix_put_shear("KPP_Ri_zero", 0.7_cvmix_r8, & + CVmix_shear_params_user) + end if + + if (present(KPP_exp)) then + call cvmix_put_shear("KPP_exp", KPP_exp, CVmix_shear_params_user) + else + call cvmix_put_shear("KPP_exp", 3, CVmix_shear_params_user) + end if + + case DEFAULT + print*, "ERROR: ", trim(CVmix_shear_params_out%mix_scheme), & + " is not a valid choice for shear mixing." + stop 1 + + end select + + if (present(old_vals)) then + select case (trim(old_vals)) + case ("overwrite") + call cvmix_put_shear('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_shear_params_user) + case ("sum") + call cvmix_put_shear('handle_old_vals', CVMIX_SUM_OLD_AND_NEW_VALS, & + cvmix_shear_params_user) + case ("max") + call cvmix_put_shear('handle_old_vals', CVMIX_MAX_OLD_AND_NEW_VALS, & + cvmix_shear_params_user) + case DEFAULT + print*, "ERROR: ", trim(old_vals), " is not a valid option for ", & + "handling old values of diff and visc." + stop 1 + end select + else + call cvmix_put_shear('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_shear_params_user) + end if + +!EOC + + end subroutine cvmix_init_shear + +!BOP + +! !IROUTINE: cvmix_coeffs_shear_wrap +! !INTERFACE: + + subroutine cvmix_coeffs_shear_wrap(CVmix_vars, CVmix_shear_params_user) + +! !DESCRIPTION: +! Computes vertical tracer and velocity mixing coefficients for +! shear-type mixing parameterizations. Note that Richardson number +! is needed at both T-points and U-points. +!\\ +!\\ +! +! !USES: +! only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_shear_params_type), target, optional, intent(in) :: & + CVmix_shear_params_user + +! !INPUT/OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars +!EOP +!BOC + + real(cvmix_r8), dimension(CVmix_vars%max_nlev+1) :: new_Mdiff, new_Tdiff + integer :: nlev, max_nlev + type(cvmix_shear_params_type), pointer :: CVmix_shear_params_in + + if (present(CVmix_shear_params_user)) then + CVmix_shear_params_in => CVmix_shear_params_user + else + CVmix_shear_params_in => CVmix_shear_params_saved + end if + nlev = CVmix_vars%nlev + max_nlev = CVmix_vars%max_nlev + + if (.not.associated(CVmix_vars%Mdiff_iface)) & + call cvmix_put(CVmix_vars, "Mdiff", cvmix_zero, max_nlev) + if (.not.associated(CVmix_vars%Tdiff_iface)) & + call cvmix_put(CVmix_vars, "Tdiff", cvmix_zero, max_nlev) + + call cvmix_coeffs_shear(new_Mdiff, new_Tdiff, & + CVmix_vars%ShearRichardson_iface, nlev, max_nlev, & + CVmix_shear_params_user) + call cvmix_update_wrap(CVmix_shear_params_in%handle_old_vals, max_nlev, & + Mdiff_out = CVmix_vars%Mdiff_iface, & + new_Mdiff = new_Mdiff, & + Tdiff_out = CVmix_vars%Tdiff_iface, & + new_Tdiff = new_Tdiff) + +!EOC + + end subroutine cvmix_coeffs_shear_wrap +!BOP + +! !IROUTINE: cvmix_coeffs_shear_low +! !INTERFACE: + + subroutine cvmix_coeffs_shear_low(Mdiff_out, Tdiff_out, RICH, nlev, & + max_nlev, CVmix_shear_params_user) + +! !DESCRIPTION: +! Computes vertical tracer and velocity mixing coefficients for +! shear-type mixing parameterizations. Note that Richardson number +! is needed at both T-points and U-points. +!\\ +!\\ +! +! !USES: +! only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_shear_params_type), target, optional, intent(in) :: & + CVmix_shear_params_user + integer, intent(in) :: nlev, max_nlev + real(cvmix_r8), dimension(max_nlev+1), intent(in) :: RICH + +! !INPUT/OUTPUT PARAMETERS: + real(cvmix_r8), dimension(max_nlev+1), intent(inout) :: Mdiff_out, & + Tdiff_out + +!EOP +!BOC + + integer :: kw ! vertical cell index + ! Parameters used in both PP81 and LMD94 + real(cvmix_r8) :: nu_zero, loc_exp + ! Parameters only used in PP81 + real(cvmix_r8) :: PP_alpha, PP_nu_b, PP_kappa_b, denom + ! Parameters only used in LMD94 + real(cvmix_r8) :: KPP_Ri_zero + type(cvmix_shear_params_type), pointer :: CVmix_shear_params + + if (present(CVmix_shear_params_user)) then + CVmix_shear_params => CVmix_shear_params_user + else + CVmix_shear_params => CVmix_shear_params_saved + end if + + select case (trim(CVmix_shear_params%mix_scheme)) + case ('PP') + ! Copy parameters to make the code more legible + nu_zero = CVmix_shear_params%PP_nu_zero + PP_alpha = CVmix_shear_params%PP_alpha + loc_exp = CVmix_shear_params%PP_exp + PP_nu_b = CVmix_shear_params%PP_nu_b + PP_kappa_b = CVmix_shear_params%PP_kappa_b + + ! Pacanowski-Philander + do kw=1,nlev+1 + if (RICH(kw).gt.cvmix_zero) then + denom = cvmix_one + PP_alpha * RICH(kw) + else + ! Treat non-negative Richardson number as Ri = 0 + denom = cvmix_one + end if + Mdiff_out(kw) = nu_zero / (denom**loc_exp) + PP_nu_b + Tdiff_out(kw) = Mdiff_out(kw) / denom + PP_kappa_b + end do + + case ('KPP') + ! Copy parameters to make the code more legible + nu_zero = CVmix_shear_params%KPP_nu_zero + KPP_Ri_zero = CVmix_shear_params%KPP_Ri_zero + loc_exp = CVmix_shear_params%KPP_exp + + ! Large, et al + do kw=1,nlev+1 + if (RICH(kw).lt.cvmix_zero) then + Tdiff_out(kw) = nu_zero + else if (RICH(kw).lt.KPP_Ri_zero) then + Tdiff_out(kw) = nu_zero * (cvmix_one - (RICH(kw)/KPP_Ri_zero) & + **2)**loc_exp + else ! Ri_g >= Ri_zero + Tdiff_out(kw) = cvmix_zero + end if + end do + ! to do: include global params for prandtl number! + Mdiff_out = Tdiff_out + + case DEFAULT + ! Note: this error should be caught in cvmix_init_shear + print*, "ERROR: invalid choice for type of shear mixing." + stop 1 + + end select + +!EOC + + end subroutine cvmix_coeffs_shear_low + +!BOP + +! !IROUTINE: cvmix_put_shear_int +! !INTERFACE: + + subroutine cvmix_put_shear_int(varname, val, CVmix_shear_params_user) + +! !DESCRIPTION: +! Write an integer value into a cvmix\_shear\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + integer, intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_shear_params_type), optional, target, intent(inout) :: & + CVmix_shear_params_user + +!EOP +!BOC + + type(cvmix_shear_params_type), pointer :: CVmix_shear_params_out + + if (present(CVmix_shear_params_user)) then + CVmix_shear_params_out => CVmix_shear_params_user + else + CVmix_shear_params_out => CVmix_shear_params_saved + end if + + select case(trim(varname)) + case ('old_vals', 'handle_old_vals') + CVmix_shear_params_out%handle_old_vals = val + case DEFAULT + call cvmix_put_shear(varname, real(val,cvmix_r8), & + CVmix_shear_params_user) + end select + +!EOC + + end subroutine cvmix_put_shear_int + +!BOP + +! !IROUTINE: cvmix_put_shear_real +! !INTERFACE: + + subroutine cvmix_put_shear_real(varname, val, CVmix_shear_params_user) + +! !DESCRIPTION: +! Write a real value into a cvmix\_shear\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + real(cvmix_r8), intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_shear_params_type), optional, target, intent(inout) :: & + CVmix_shear_params_user + +!EOP +!BOC + + type(cvmix_shear_params_type), pointer :: CVmix_shear_params_out + + if (present(CVmix_shear_params_user)) then + CVmix_shear_params_out => CVmix_shear_params_user + else + CVmix_shear_params_out => CVmix_shear_params_saved + end if + + select case (trim(varname)) + case ('PP_nu_zero') + CVmix_shear_params_out%PP_nu_zero = val + case ('PP_alpha') + CVmix_shear_params_out%PP_alpha = val + case ('PP_exp') + CVmix_shear_params_out%PP_exp = val + case ('PP_nu_b') + CVmix_shear_params_out%PP_nu_b = val + case ('PP_kappa_b') + CVmix_shear_params_out%PP_kappa_b = val + case ('KPP_nu_zero') + CVmix_shear_params_out%KPP_nu_zero = val + case ('KPP_Ri_zero') + CVmix_shear_params_out%KPP_Ri_zero = val + case ('KPP_exp') + CVmix_shear_params_out%KPP_exp = val + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end subroutine cvmix_put_shear_real + +!BOP + +! !IROUTINE: cvmix_put_shear_str +! !INTERFACE: + + subroutine cvmix_put_shear_str(varname, val, CVmix_shear_params_user) + +! !DESCRIPTION: +! Write a string into a cvmix\_shear\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_shear_params_type), optional, target, intent(inout) :: & + CVmix_shear_params_user + +!EOP +!BOC + + type(cvmix_shear_params_type), pointer :: CVmix_shear_params_out + + if (present(CVmix_shear_params_user)) then + CVmix_shear_params_out => CVmix_shear_params_user + else + CVmix_shear_params_out => CVmix_shear_params_saved + end if + + select case (trim(varname)) + case ('mix_scheme') + CVmix_shear_params_out%mix_scheme = val + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end subroutine cvmix_put_shear_str + +!BOP + +! !IROUTINE: cvmix_get_shear_real +! !INTERFACE: + + function cvmix_get_shear_real(varname, CVmix_shear_params_user) + +! !DESCRIPTION: +! Read the real value of a cvmix\_shear\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + type(cvmix_shear_params_type), optional, target, intent(in) :: & + CVmix_shear_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8) :: cvmix_get_shear_real + +!EOP +!BOC + + type(cvmix_shear_params_type), pointer :: CVmix_shear_params_in + + if (present(CVmix_shear_params_user)) then + CVmix_shear_params_in => CVmix_shear_params_user + else + CVmix_shear_params_in => CVmix_shear_params_saved + end if + + cvmix_get_shear_real = cvmix_zero + select case (trim(varname)) + case ('PP_nu_zero') + cvmix_get_shear_real =CVmix_shear_params_in%PP_nu_zero + case ('PP_alpha') + cvmix_get_shear_real =CVmix_shear_params_in%PP_alpha + case ('PP_exp') + cvmix_get_shear_real =CVmix_shear_params_in%PP_exp + case ('KPP_nu_zero') + cvmix_get_shear_real =CVmix_shear_params_in%KPP_nu_zero + case ('KPP_Ri_zero') + cvmix_get_shear_real =CVmix_shear_params_in%KPP_Ri_zero + case ('KPP_exp') + cvmix_get_shear_real =CVmix_shear_params_in%KPP_exp + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end function cvmix_get_shear_real + +!BOP + +! !IROUTINE: cvmix_get_shear_str +! !INTERFACE: + + function cvmix_get_shear_str(varname, CVmix_shear_params_user) + +! !DESCRIPTION: +! Read the string contents of a cvmix\_shear\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + type(cvmix_shear_params_type), optional, target, intent(in) :: & + CVmix_shear_params_user + +! !OUTPUT PARAMETERS: + character(len=cvmix_strlen) :: cvmix_get_shear_str + +!EOP +!BOC + + type(cvmix_shear_params_type), pointer :: CVmix_shear_params_in + + if (present(CVmix_shear_params_user)) then + CVmix_shear_params_in => CVmix_shear_params_user + else + CVmix_shear_params_in => CVmix_shear_params_saved + end if + + select case (trim(varname)) + case ('mix_scheme') + cvmix_get_shear_str = trim(CVmix_shear_params_in%mix_scheme) + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end function cvmix_get_shear_str + + +end module cvmix_shear diff --git a/parameterizations/CVmix/cvmix_tidal.F90 b/parameterizations/CVmix/cvmix_tidal.F90 new file mode 100644 index 0000000000..dc6dc80575 --- /dev/null +++ b/parameterizations/CVmix/cvmix_tidal.F90 @@ -0,0 +1,1362 @@ + module cvmix_tidal + +!BOP +!\newpage +! !MODULE: cvmix_tidal +! +! !AUTHOR: +! Michael N. Levy, NCAR (mlevy@ucar.edu) +! +! !DESCRIPTION: +! This module contains routines to initialize the derived types needed for +! tidal mixing (currently just the Simmons scheme) and to set the viscosity +! and diffusivity coefficients accordingly. +!\\ +!\\ +! References:\\ +! * HL Simmons, SR Jayne, LC St. Laurent, and AJ Weaver. +! Tidally Driven Mixing in a Numerical Model of the Ocean General Circulation. +! Ocean Modelling, 2004. +!\\ +!\\ + +! !USES: + + use cvmix_kinds_and_types, only : cvmix_r8, & + cvmix_log_kind, & + cvmix_zero, & + cvmix_one, & + cvmix_data_type, & + cvmix_strlen, & + cvmix_global_params_type, & + CVMIX_OVERWRITE_OLD_VAL, & + CVMIX_SUM_OLD_AND_NEW_VALS, & + CVMIX_MAX_OLD_AND_NEW_VALS + use cvmix_utils, only : cvmix_update_wrap + use cvmix_put_get, only : cvmix_put + +!EOP + + implicit none + private + save + +!BOP + +! !PUBLIC MEMBER FUNCTIONS: + + public :: cvmix_init_tidal + public :: cvmix_coeffs_tidal + public :: cvmix_coeffs_tidal_schmittner + public :: cvmix_compute_Simmons_invariant + public :: cvmix_compute_Schmittner_invariant + public :: cvmix_compute_SchmittnerCoeff + public :: cvmix_compute_socn_tidal_invariant + public :: cvmix_compute_vert_dep + public :: cvmix_compute_vert_dep_Schmittner + public :: cvmix_put_tidal + public :: cvmix_get_tidal_real + public :: cvmix_get_tidal_str + + interface cvmix_coeffs_tidal + module procedure cvmix_coeffs_tidal_low +! module procedure cvmix_coeffs_tidal_schmittner + module procedure cvmix_coeffs_tidal_wrap + end interface cvmix_coeffs_tidal + + interface cvmix_compute_Simmons_invariant + module procedure cvmix_compute_Simmons_invariant_low + module procedure cvmix_compute_Simmons_invariant_wrap + end interface cvmix_compute_Simmons_invariant + + interface cvmix_compute_Schmittner_invariant + module procedure cvmix_compute_Schmittner_invariant_low + module procedure cvmix_compute_Schmittner_invariant_wrap + end interface cvmix_compute_Schmittner_invariant + + interface cvmix_compute_SchmittnerCoeff + module procedure cvmix_compute_SchmittnerCoeff_low + module procedure cvmix_compute_SchmittnerCoeff_wrap + end interface cvmix_compute_SchmittnerCoeff + + interface cvmix_compute_socn_tidal_invariant + module procedure cvmix_compute_socn_tidal_invariant_low + module procedure cvmix_compute_socn_tidal_invariant_wrap + end interface cvmix_compute_socn_tidal_invariant + + interface cvmix_put_tidal + module procedure cvmix_put_tidal_int + module procedure cvmix_put_tidal_logical + module procedure cvmix_put_tidal_real + module procedure cvmix_put_tidal_str + end interface cvmix_put_tidal + +! !PUBLIC TYPES: + + ! cvmix_tidal_params_type contains the necessary parameters for tidal mixing + ! (currently just Simmons) + type, public :: cvmix_tidal_params_type + private + ! Tidal mixing scheme being used (currently only support Simmons et al) + character(len=cvmix_strlen) :: mix_scheme + + ! efficiency is the mixing efficiency (Gamma in Simmons) + real(cvmix_r8) :: efficiency ! units: unitless (fraction) + + ! local_mixing_frac is the tidal dissipation efficiency (q in Simmons) + real(cvmix_r8) :: local_mixing_frac ! units: unitless (fraction) + + ! vertical_decay_scale is zeta in the Simmons paper (used to compute the + ! vertical deposition function) + real(cvmix_r8) :: vertical_decay_scale ! units: m + + ! vertical_decay_scaleR is zetar in Schmittner method (used to compute the + ! vertical deposition function) + real(cvmix_r8) :: vertical_decay_scaleR ! units: m + + ! depth_cutoff is depth of the shallowest column where tidal mixing is + ! computed (like all depths, positive => below the surface) + real(cvmix_r8) :: depth_cutoff ! units: m + + ! max_coefficient is the largest acceptable value for diffusivity + real(cvmix_r8) :: max_coefficient ! units: m^2/s + + ! Flag for what to do with old values of CVmix_vars%[MTS]diff + integer :: handle_old_vals + + ! Flag for controlling application of Schmittner Southern-Ocean mods + logical(cvmix_log_kind) :: ltidal_Schmittner_socn + + ! Note: need to include some logic to avoid excessive memory use + end type cvmix_tidal_params_type +!EOP + + type(cvmix_tidal_params_type), target :: CVmix_tidal_params_saved + +contains + +!BOP + +! !IROUTINE: cvmix_init_tidal +! !INTERFACE: + + subroutine cvmix_init_tidal(CVmix_tidal_params_user, mix_scheme, efficiency,& + vertical_decay_scale, max_coefficient, & + local_mixing_frac, depth_cutoff, & + ltidal_Schmittner_socn, old_vals) + +! !DESCRIPTION: +! Initialization routine for tidal mixing. There is currently just one +! supported schemes - set \verb|mix_scheme = 'simmons'| to use the Simmons +! mixing scheme. +! - set \verb|mix_scheme = 'schmittner'| to use the Schmittner +! mixing scheme. +! +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), optional, intent(in) :: mix_scheme, old_vals + real(cvmix_r8), optional, intent(in) :: efficiency + real(cvmix_r8), optional, intent(in) :: vertical_decay_scale + real(cvmix_r8), optional, intent(in) :: max_coefficient + real(cvmix_r8), optional, intent(in) :: local_mixing_frac + real(cvmix_r8), optional, intent(in) :: depth_cutoff + logical(cvmix_log_kind), optional, intent(in) :: ltidal_Schmittner_socn + +! !OUTPUT PARAMETERS: + type(cvmix_tidal_params_type), optional, target, intent(inout) :: & + CVmix_tidal_params_user +!EOP +!BOC + + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params_out + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params_out => CVmix_tidal_params_user + else + CVmix_tidal_params_out => CVmix_tidal_params_saved + end if + + if (present(mix_scheme)) then + call cvmix_put_tidal("mix_scheme", trim(mix_scheme), & + CVmix_tidal_params_user) + else + call cvmix_put_tidal("mix_scheme", "Simmons", CVmix_tidal_params_user) + end if + + select case (trim(CVmix_tidal_params_out%mix_scheme)) + case ('simmons','Simmons') + ! Unitless parameters + if (present(efficiency)) then + call cvmix_put_tidal("efficiency", efficiency, & + CVmix_tidal_params_user) + else + call cvmix_put_tidal("efficiency", 0.2_cvmix_r8, & + CVmix_tidal_params_user) + end if + + if (present(local_mixing_frac)) then + call cvmix_put_tidal("local_mixing_frac", local_mixing_frac, & + CVmix_tidal_params_user) + else + call cvmix_put_tidal("local_mixing_frac", 3, CVmix_tidal_params_user) + end if + + ! Parameters with units + if (present(vertical_decay_scale)) then + call cvmix_put_tidal("vertical_decay_scale", vertical_decay_scale, & + CVmix_tidal_params_user) + else + call cvmix_put_tidal("vertical_decay_scale", 500, & + CVmix_tidal_params_user) + end if + + if (present(depth_cutoff)) then + call cvmix_put_tidal("depth_cutoff", depth_cutoff, & + CVmix_tidal_params_user) + else + ! Default: no cutoff depth => 0 m + call cvmix_put_tidal("depth_cutoff", 0, CVmix_tidal_params_user) + end if + + if (present(max_coefficient)) then + call cvmix_put_tidal("max_coefficient", max_coefficient, & + CVmix_tidal_params_user) + else + call cvmix_put_tidal("max_coefficient", 50e-4_cvmix_r8, & + CVmix_tidal_params_user) + end if + + if (present(ltidal_Schmittner_socn)) then + call cvmix_put_tidal("ltidal_Schmittner_socn", ltidal_Schmittner_socn, & + CVmix_tidal_params_user) + else + ! Default: do not apply Schmittner Southern Ocean mods + call cvmix_put_tidal("ltidal_Schmittner_socn", .false., CVmix_tidal_params_user) + end if + + case ('schmittner','Schmittner') + ! Unitless parameters + if (present(efficiency)) then + call cvmix_put_tidal("efficiency", efficiency, & + CVmix_tidal_params_user) + else + call cvmix_put_tidal("efficiency", 0.2_cvmix_r8, & + CVmix_tidal_params_user) + end if + + ! Parameters with units + if (present(vertical_decay_scale)) then + call cvmix_put_tidal("vertical_decay_scaleR", cvmix_one/vertical_decay_scale, & + CVmix_tidal_params_user) + else + call cvmix_put_tidal("vertical_decay_scaleR", cvmix_one/500.0_cvmix_r8, & + CVmix_tidal_params_user) + end if + + if (present(max_coefficient)) then + call cvmix_put_tidal("max_coefficient", max_coefficient, & + CVmix_tidal_params_user) + else + call cvmix_put_tidal("max_coefficient", 50e-4_cvmix_r8, & + CVmix_tidal_params_user) + end if + + if (present(ltidal_Schmittner_socn)) then + call cvmix_put_tidal("ltidal_Schmittner_socn", ltidal_Schmittner_socn, & + CVmix_tidal_params_user) + else + ! Default: do not apply Schmittner Southern Ocean mods + call cvmix_put_tidal("ltidal_Schmittner_socn", .false., CVmix_tidal_params_user) + end if + + case DEFAULT + print*, "ERROR: ", trim(mix_scheme), " is not a valid choice for ", & + "tidal mixing." + stop 1 + + end select + + if (present(old_vals)) then + select case (trim(old_vals)) + case ("overwrite") + call cvmix_put_tidal('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_tidal_params_user) + case ("sum") + call cvmix_put_tidal('handle_old_vals', CVMIX_SUM_OLD_AND_NEW_VALS, & + cvmix_tidal_params_user) + case ("max") + call cvmix_put_tidal('handle_old_vals', CVMIX_MAX_OLD_AND_NEW_VALS, & + cvmix_tidal_params_user) + case DEFAULT + print*, "ERROR: ", trim(old_vals), " is not a valid option for ", & + "handling old values of diff and visc." + stop 1 + end select + else + call cvmix_put_tidal('handle_old_vals', CVMIX_OVERWRITE_OLD_VAL, & + cvmix_tidal_params_user) + end if + +!EOC + + end subroutine cvmix_init_tidal + +!BOP + +! !IROUTINE: cvmix_coeffs_tidal_wrap +! !INTERFACE: + + subroutine cvmix_coeffs_tidal_wrap(CVmix_vars, & + CVmix_params, & + CVmix_tidal_params_user) + +! !DESCRIPTION: +! Computes vertical diffusion coefficients for tidal mixing +! parameterizations. +!\\ +!\\ +! +! !USES: +! only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_tidal_params_type), target, optional, intent(in) :: & + CVmix_tidal_params_user + type(cvmix_global_params_type), intent(in) :: CVmix_params + +! !INPUT/OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars + +!EOP +!BOC + + ! Local variables + real(cvmix_r8), dimension(CVmix_vars%max_nlev+1) :: new_Mdiff, new_Tdiff + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params_in + integer :: nlev, max_nlev + + CVmix_tidal_params_in => CVmix_tidal_params_saved + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params_in => CVmix_tidal_params_user + end if + nlev = CVmix_vars%nlev + max_nlev = CVmix_vars%max_nlev + + select case (trim(CVmix_tidal_params_in%mix_scheme)) + case ('simmons','Simmons') + call cvmix_coeffs_tidal_low & + (new_Mdiff, new_Tdiff, & + CVmix_vars%SqrBuoyancyFreq_iface, & + CVmix_vars%OceanDepth, & + CVmix_vars%SimmonsCoeff, & + CVmix_vars%VertDep_iface, nlev, max_nlev, & + CVMix_params, & + CVmix_vars%SchmittnerSouthernOcean, & + CVmix_tidal_params_user) + case ('schmittner','Schmittner') + call cvmix_coeffs_tidal_schmittner & + (new_Mdiff, new_Tdiff, & + CVmix_vars%SqrBuoyancyFreq_iface, & + CVmix_vars%OceanDepth, & + nlev, max_nlev, & + CVmix_vars%SchmittnerCoeff, & + CVmix_vars%SchmittnerSouthernOcean, & + CVmix_params, & + CVmix_tidal_params_user) + + end select + call cvmix_update_wrap(CVmix_tidal_params_in%handle_old_vals, max_nlev, & + Mdiff_out = CVmix_vars%Mdiff_iface, & + Tdiff_out = CVmix_vars%Tdiff_iface, & + new_Mdiff = new_Mdiff, & + new_Tdiff = new_Tdiff) + +!EOC + + end subroutine cvmix_coeffs_tidal_wrap + +!BOP + +! !IROUTINE: cvmix_coeffs_tidal_low +! !INTERFACE: + + subroutine cvmix_coeffs_tidal_low(Mdiff_out, Tdiff_out, Nsqr, OceanDepth, & + SimmonsCoeff, vert_dep, nlev, max_nlev, & + CVmix_params, & + SchmittnerSouthernOcean, & + CVmix_tidal_params_user) + +! !DESCRIPTION: +! Computes vertical diffusion coefficients for tidal mixing +! parameterizations. +!\\ +!\\ +! +! !USES: +! only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_tidal_params_type), target, optional, intent(in) :: & + CVmix_tidal_params_user + type(cvmix_global_params_type), intent(in) :: CVmix_params + integer, intent(in) :: nlev, max_nlev + real(cvmix_r8), dimension(max_nlev+1), intent(in) :: Nsqr, vert_dep + real(cvmix_r8), intent(in) :: OceanDepth + real(cvmix_r8), intent(in) :: SimmonsCoeff + real(cvmix_r8), dimension(max_nlev+1), intent(in), & + optional :: SchmittnerSouthernOcean + +! !INPUT/OUTPUT PARAMETERS: + real(cvmix_r8), dimension(max_nlev+1), intent(inout) :: Mdiff_out + real(cvmix_r8), dimension(max_nlev+1), intent(inout) :: Tdiff_out + +!EOP +!BOC + + ! Local variables + integer :: k + real(cvmix_r8), dimension(max_nlev+1) :: SchmittnerSouthernOceanLocal + + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params => CVmix_tidal_params_user + else + CVmix_tidal_params => CVmix_tidal_params_saved + end if + + if (present(SchmittnerSouthernOcean)) then + SchmittnerSouthernOceanLocal = SchmittnerSouthernOcean + else + SchmittnerSouthernOceanLocal = cvmix_zero + end if + + select case (trim(CVmix_tidal_params%mix_scheme)) + case ('simmons','Simmons') + Tdiff_out = cvmix_zero + if (OceanDepth.ge.CVmix_tidal_params%depth_cutoff) then + do k=1, nlev+1 + !*** compute tidal diffusion + if (Nsqr(k).gt.cvmix_zero) & + Tdiff_out(k) = SimmonsCoeff*vert_dep(k)/Nsqr(k) + + !*** apply Scmittner Southern Ocean modification + if (CVmix_tidal_params%ltidal_Schmittner_socn .and. k<=nlev)& + Tdiff_out(k) = max(Tdiff_out(k),SchmittnerSouthernOcean(k)) + + !*** apply tidal diffusion cap + if (Tdiff_out(k).gt.CVmix_tidal_params%max_coefficient) & + Tdiff_out(k) = CVmix_tidal_params%max_coefficient + + end do + end if + + case DEFAULT + ! Note: this error should be caught in cvmix_init_tidal + print*, "ERROR: invalid choice for type of tidal mixing." + stop 1 + + end select + Mdiff_out = CVmix_params%Prandtl*Tdiff_out + +!EOC + + end subroutine cvmix_coeffs_tidal_low + +!BOP + +! !IROUTINE: cvmix_coeffs_tidal_schmittner +! !INTERFACE: + + subroutine cvmix_coeffs_tidal_schmittner & + (Mdiff_out, Tdiff_out, Nsqr, & + OceanDepth, nlev, max_nlev, & + SchmittnerCoeff, & + SchmittnerSouthernOcean, & + CVmix_params, & + CVmix_tidal_params_user) + +! !DESCRIPTION: +! Computes vertical diffusion coefficients for tidal mixing +! parameterizations. +!\\ +!\\ +! +! !USES: +! only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_tidal_params_type), target, optional, intent(in) :: & + CVmix_tidal_params_user + integer, intent(in) :: nlev, max_nlev + type(cvmix_global_params_type), intent(in) :: CVmix_params + real(cvmix_r8), intent(in) :: OceanDepth + real(cvmix_r8), dimension(max_nlev+1), intent(in) :: Nsqr + real(cvmix_r8), dimension(max_nlev+1), intent(in) :: SchmittnerSouthernOcean + real(cvmix_r8), dimension(max_nlev+1), intent(in) :: SchmittnerCoeff + +! !INPUT/OUTPUT PARAMETERS: + real(cvmix_r8), dimension(max_nlev+1), intent(inout) :: Mdiff_out + real(cvmix_r8), dimension(max_nlev+1), intent(inout) :: Tdiff_out + +!EOP +!BOC + + ! Local variables + integer :: k + + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params => CVmix_tidal_params_user + else + CVmix_tidal_params => CVmix_tidal_params_saved + end if + + select case (trim(CVmix_tidal_params%mix_scheme)) + + case ('schmittner','Schmittner') + Tdiff_out = cvmix_zero + if (OceanDepth.ge.CVmix_tidal_params%depth_cutoff) then + do k=1, nlev+1 + !*** compute tidal diffusion + if (Nsqr(k).gt.cvmix_zero) & + Tdiff_out(k) = SchmittnerCoeff(k)/Nsqr(k) + + !*** apply Scmittner Southern Ocean modification + if (CVmix_tidal_params%ltidal_Schmittner_socn .and. k<=nlev)& + Tdiff_out(k) = max(Tdiff_out(k),SchmittnerSouthernOcean(k)) + + !*** apply tidal diffusion cap + if (Tdiff_out(k).gt.CVmix_tidal_params%max_coefficient) & + Tdiff_out(k) = CVmix_tidal_params%max_coefficient + + end do + + end if + + case DEFAULT + ! Note: this error should be caught in cvmix_init_tidal + print*, "ERROR: invalid choice for type of tidal mixing." + stop 1 + + end select + Mdiff_out = CVmix_params%Prandtl*Tdiff_out + +!EOC + + end subroutine cvmix_coeffs_tidal_schmittner + +!BOP + !IROUTINE: cvmix_compute_vert_dep + !INTERFACE: + + function cvmix_compute_vert_dep(zw, zt, nlev, CVmix_tidal_params) + +! !DESCRIPTION: +! Computes the vertical deposition function needed for Simmons et al tidal +! mixing. +!\\ +!\\ +! +! !USES: +! only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_tidal_params_type), intent(in) :: CVmix_tidal_params + integer, intent(in) :: nlev + real(cvmix_r8), dimension(nlev+1), intent(in) :: zw + real(cvmix_r8), dimension(nlev), intent(in) :: zt + +! !OUTPUT PARAMETERS: + real(cvmix_r8), dimension(nlev+1) :: cvmix_compute_vert_dep + +!EOP +!BOC + + ! Local variables + real(cvmix_r8) :: tot_area, num, thick + integer :: k + + ! Compute vertical deposition + tot_area = cvmix_zero + cvmix_compute_vert_dep(1) = cvmix_zero + cvmix_compute_vert_dep(nlev+1) = cvmix_zero + do k=2,nlev + num = -zw(k)/CVmix_tidal_params%vertical_decay_scale + ! Simmons vertical deposition + ! Note that it is getting normalized (divide through by tot_area) + ! So multiplicative constants that are independent of z are omitted + cvmix_compute_vert_dep(k) = exp(num) + + ! Compute integral of vert_dep via trapezoid rule + ! (looks like midpoint rule, but vert_dep = 0 at z=0 and z=-ocn_depth) + thick = zt(k-1) - zt(k) + tot_area = tot_area + cvmix_compute_vert_dep(k)*thick + end do + ! Normalize vert_dep (need integral = 1.0D0) + cvmix_compute_vert_dep = cvmix_compute_vert_dep/tot_area + +!EOC + + end function cvmix_compute_vert_dep + +!BOP + !IROUTINE: cvmix_compute_vert_dep_Schmittner + !INTERFACE: + + function cvmix_compute_vert_dep_Schmittner(zw, nlev, CVmix_tidal_params) + +! !DESCRIPTION: +! Computes the vertical deposition function needed for Schmittner 2014 tidal +! mixing. +!\\ +!\\ +! +! !USES: +! only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_tidal_params_type), intent(in) :: CVmix_tidal_params + integer, intent(in) :: nlev + real(cvmix_r8), dimension(nlev+1), intent(in) :: zw + +! !OUTPUT PARAMETERS: + real(cvmix_r8), dimension(nlev+1) :: cvmix_compute_vert_dep_Schmittner + +!EOP +!BOC + + ! Local variables + real(cvmix_r8) :: zetar + integer :: k + + zetar = CVmix_tidal_params%vertical_decay_scaleR + + ! Compute Schmittner-method vertical decay profile + cvmix_compute_vert_dep_Schmittner(1) = cvmix_zero + do k=2,nlev+1 + cvmix_compute_vert_dep_Schmittner(k) = zetar/(cvmix_one-exp(zetar*zw(k))) +! cvmix_compute_vert_dep_Schmittner(k) = zetar/(cvmix_one-exp(zetar*zw(k+1))) +! cvmix_compute_vert_dep_Schmittner(k) = zetar/(cvmix_one-exp(zetar*zw(k-1))) + end do + +!EOC + + end function cvmix_compute_vert_dep_Schmittner + +!BOP +! !IROUTINE: cvmix_compute_Simmons_invariant_wrap +! !INTERFACE: + + subroutine cvmix_compute_Simmons_invariant_wrap(CVmix_vars, CVmix_params, & + energy_flux, & + CVmix_tidal_params_user) + +! !DESCRIPTION: +! Compute the time-invariant portion of the tidal mixing coefficient using +! the Simmons, et al., scheme. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_global_params_type), intent(in) :: CVmix_params + real(cvmix_r8), intent(in) :: energy_flux + type(cvmix_tidal_params_type), target, optional, intent(in) :: & + CVmix_tidal_params_user + +! !INPUT/OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars + +!EOP + + ! local variables + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params => CVmix_tidal_params_user + else + CVmix_tidal_params => CVmix_tidal_params_saved + end if + + call cvmix_put(CVmix_vars, 'SimmonsCoeff', cvmix_zero) + call cvmix_put(CVmix_vars, 'VertDep', cvmix_zero) + call cvmix_compute_Simmons_invariant_low(CVmix_vars%nlev, & + energy_flux, & + CVmix_params%FreshWaterDensity, & + CVmix_vars%SimmonsCoeff, & + CVmix_vars%VertDep_iface, & + CVmix_vars%zw_iface, & + CVmix_vars%zt_cntr, & + CVMix_tidal_params_user) + +!EOC + + end subroutine cvmix_compute_Simmons_invariant_wrap + +!BOP + +! !IROUTINE: cvmix_compute_Simmons_invariant_low +! !INTERFACE: + + subroutine cvmix_compute_Simmons_invariant_low(nlev, energy_flux, rho, & + SimmonsCoeff, VertDep, zw, & + zt, CVmix_tidal_params_user) + +! !DESCRIPTION: +! Compute the time-invariant portion of the tidal mixing coefficient using +! the Simmons, et al., scheme. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + integer, intent(in) :: nlev + real(cvmix_r8), intent(in) :: energy_flux, rho + real(cvmix_r8), dimension(:), intent(in) :: zw, zt + type(cvmix_tidal_params_type), target, optional, intent(in) :: & + CVmix_tidal_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8), intent(out) :: SimmonsCoeff + real(cvmix_r8), dimension(nlev+1), intent(inout) :: VertDep + +!EOP + + ! local variables + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params => CVmix_tidal_params_user + else + CVmix_tidal_params => CVmix_tidal_params_saved + end if + + SimmonsCoeff = CVmix_tidal_params%local_mixing_frac * & + CVmix_tidal_params%efficiency * & + energy_flux/rho + VertDep = cvmix_compute_vert_dep(zw(1:nlev+1), zt(1:nlev), nlev, & + CVmix_tidal_params) +!BOC + +!EOC + + end subroutine cvmix_compute_Simmons_invariant_low + +!BOP +! !IROUTINE: cvmix_compute_Schmittner_invariant_wrap +! !INTERFACE: + + subroutine cvmix_compute_Schmittner_invariant_wrap(CVmix_vars, & + CVmix_params,& + CVmix_tidal_params_user) + +! !DESCRIPTION: +! Compute the time-invariant portion of the tidal mixing coefficient using +! the Schmittner 2014 scheme. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_global_params_type), intent(in) :: CVmix_params + type(cvmix_tidal_params_type), target, optional, intent(in) :: & + CVmix_tidal_params_user + +! !INPUT/OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars + +!EOP + + ! local variables + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params => CVmix_tidal_params_user + else + CVmix_tidal_params => CVmix_tidal_params_saved + end if + + call cvmix_put(CVmix_vars, 'VertDep', cvmix_zero) + + call cvmix_compute_Schmittner_invariant_low(CVmix_vars%nlev, & + CVmix_vars%VertDep_iface, & + CVmix_tidal_params%efficiency, & + CVmix_params%FreshWaterDensity, & + CVmix_vars%exp_hab_zetar, & + CVmix_vars%zw_iface, & + CVMix_tidal_params_user) + +!EOC + + end subroutine cvmix_compute_Schmittner_invariant_wrap + +!BOP +! !IROUTINE: cvmix_compute_Schmittner_invariant_low +! !INTERFACE: + + subroutine cvmix_compute_Schmittner_invariant_low(nlev, VertDep, efficiency, rho, & + exp_hab_zetar, zw, & + CVmix_tidal_params_user) + +! !DESCRIPTION: +! Compute the time-invariant portion of the tidal mixing coefficient using +! the Schmittner 2014 scheme. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + integer, intent(in) :: nlev + real(cvmix_r8), intent(in) :: efficiency + real(cvmix_r8), intent(in) :: rho + real(cvmix_r8), dimension(:), intent(in) :: zw + type(cvmix_tidal_params_type), target, optional, intent(in) :: & + CVmix_tidal_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8), dimension(1:nlev+1), intent(inout) :: VertDep + real(cvmix_r8), dimension(2:nlev+1,2:nlev+1), intent(inout) :: exp_hab_zetar + +!EOP + + ! local variables + real(cvmix_r8) :: hab ! height above bottom + real(cvmix_r8) :: term + real(cvmix_r8) :: zetar + integer :: k,k1 ! indices + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params => CVmix_tidal_params_user + else + CVmix_tidal_params => CVmix_tidal_params_saved + end if + + term = efficiency/rho + zetar = CVmix_tidal_params%vertical_decay_scaleR + + VertDep = cvmix_compute_vert_dep_Schmittner(zw(1:nlev+1), nlev,& + CVmix_tidal_params) + + do k=2,nlev + do k1=k+1,nlev+1 + hab= zw(k1)-zw(k) + exp_hab_zetar(k,k1)=term*exp(hab*zetar)*VertDep(k1) + enddo + enddo + +!BOC + +!EOC + + end subroutine cvmix_compute_Schmittner_invariant_low + +!BOP +! !IROUTINE: cvmix_compute_SchmittnerCoeff_wrap +! !INTERFACE: + + subroutine cvmix_compute_SchmittnerCoeff_wrap(CVmix_vars, nlev, energy_flux, & + CVmix_tidal_params_user) + +! !DESCRIPTION: +! Compute the full time-dependent tidal mixing coefficient using +! the Schmittner 2014 scheme. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + integer, intent(in) :: nlev + real(cvmix_r8), dimension(2:nlev+1), intent(in) :: energy_flux + type(cvmix_tidal_params_type), target, optional, intent(in) :: & + CVmix_tidal_params_user + +! !INPUT/OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars + +!EOP + + ! local variables + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params => CVmix_tidal_params_user + else + CVmix_tidal_params => CVmix_tidal_params_saved + end if + + call cvmix_compute_SchmittnerCoeff_low(CVmix_vars%nlev, & + energy_flux, & + CVmix_vars%SchmittnerCoeff, & + CVmix_vars%exp_hab_zetar, & + CVMix_tidal_params_user) + +!EOC + + end subroutine cvmix_compute_SchmittnerCoeff_wrap + +!BOP +! !IROUTINE: cvmix_compute_SchmittnerCoeff_low +! !INTERFACE: + + subroutine cvmix_compute_SchmittnerCoeff_low(nlev, energy_flux, & + SchmittnerCoeff, & + exp_hab_zetar, & + CVmix_tidal_params_user) + +! !DESCRIPTION: +! Compute the time-dependent portion of the tidal mixing coefficient using +! the Schmittner 2014 scheme. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + integer, intent(in) :: nlev + real(cvmix_r8), dimension(2:nlev+1,2:nlev+1), intent(in) :: exp_hab_zetar + real(cvmix_r8), dimension(2:nlev+1), intent(in) :: energy_flux + type(cvmix_tidal_params_type), target, optional, intent(in) :: & + CVmix_tidal_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8), dimension(:), intent(out) :: SchmittnerCoeff + +!EOP + + ! local variables + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params + integer :: k,k1 + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params => CVmix_tidal_params_user + else + CVmix_tidal_params => CVmix_tidal_params_saved + end if + + SchmittnerCoeff(:) = cvmix_zero + + do k=2,nlev + do k1=k+1,nlev+1 + !note... need to put energy_flux onto interface level + SchmittnerCoeff(k) = & + SchmittnerCoeff(k) + energy_flux(k1)*exp_hab_zetar(k,k1) + enddo + enddo + +!BOC + +!EOC + + end subroutine cvmix_compute_SchmittnerCoeff_low + +!BOP +! !IROUTINE: cvmix_compute_socn_tidal_invariant_wrap +! !INTERFACE: + + subroutine cvmix_compute_socn_tidal_invariant_wrap(CVmix_vars, & + CVmix_tidal_params_user) + +! !DESCRIPTION: +! Compute the time-invariant Schmittner Southern-Ocean tidal mixing terms +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + type(cvmix_tidal_params_type), target, optional, intent(in) :: & + CVmix_tidal_params_user + +! !INPUT/OUTPUT PARAMETERS: + type(cvmix_data_type), intent(inout) :: CVmix_vars + +!EOP + + ! local variables + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params => CVmix_tidal_params_user + else + CVmix_tidal_params => CVmix_tidal_params_saved + end if + + if (CVmix_tidal_params%ltidal_Schmittner_socn) & + call cvmix_compute_socn_tidal_invariant_low(CVmix_vars%nlev, & + CVmix_vars%lat, & + CVmix_vars%zw_iface, & + cvmix_vars%SchmittnerSouthernOcean,& + CVMix_tidal_params_user ) + +!EOC + + end subroutine cvmix_compute_socn_tidal_invariant_wrap + +!BOP + +! !IROUTINE: cvmix_compute_socn_tidal_invariant_low +! !INTERFACE: + + subroutine cvmix_compute_socn_tidal_invariant_low(nlev, & + lat, & + zw, & + SchmittnerSouthernOcean, & + CVmix_tidal_params_user ) + +! !DESCRIPTION: +! Compute the time-invariant Schmittner Southern-Ocean tidal mixing terms +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + integer, intent(in) :: nlev + real(cvmix_r8), intent(in) :: lat + real(cvmix_r8), dimension(:), intent(in) :: zw + type(cvmix_tidal_params_type), target, optional, intent(in) :: & + CVmix_tidal_params_user + + !OUTPUT PARAMETERS: + real(cvmix_r8),dimension(:),intent(inout) :: SchmittnerSouthernOcean + +!EOP + + ! local variables + integer :: k + real(cvmix_r8) :: SchmittnerTanhLat + real(cvmix_r8) :: SchmittnerTanhZw + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params + +!BOC + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params => CVmix_tidal_params_user + else + CVmix_tidal_params => CVmix_tidal_params_saved + end if + + SchmittnerTanhLat = 0.5_cvmix_r8*(cvmix_one-tanh((lat+40.0_cvmix_r8)/8.0_cvmix_r8)) + + do k=1, nlev+1 + SchmittnerTanhZw = tanh((-zw(k)-500._cvmix_r8)/100.0_cvmix_r8)*1.0e-4_cvmix_r8 + SchmittnerSouthernOcean(k) = SchmittnerTanhLat*SchmittnerTanhZw + end do + +!EOC + + end subroutine cvmix_compute_socn_tidal_invariant_low + +!BOP + +! !IROUTINE: cvmix_put_tidal_int +! !INTERFACE: + + subroutine cvmix_put_tidal_int(varname, val, CVmix_tidal_params_user) + +! !DESCRIPTION: +! Write an integer value into a cvmix\_tidal\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + integer, intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_tidal_params_type), optional, target, intent(inout) :: & + CVmix_tidal_params_user + +!EOP +!BOC + + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params_out + + CVmix_tidal_params_out => CVmix_tidal_params_saved + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params_out => CVmix_tidal_params_user + end if + + select case (trim(varname)) + case ('old_vals', 'handle_old_vals') + CVmix_tidal_params_out%handle_old_vals = val + case DEFAULT + call cvmix_put_tidal(varname, real(val,cvmix_r8), & + CVmix_tidal_params_user) + end select + +!EOC + + end subroutine cvmix_put_tidal_int + +! !IROUTINE: cvmix_put_tidal_logical +! !INTERFACE: + + subroutine cvmix_put_tidal_logical(varname, val, CVmix_tidal_params_user) + +! !DESCRIPTION: +! Write a logical value into a cvmix\_tidal\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + logical(cvmix_log_kind),intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_tidal_params_type), optional, target, intent(inout) :: & + CVmix_tidal_params_user + +!EOP +!BOC + + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params_out + + CVmix_tidal_params_out => CVmix_tidal_params_saved + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params_out => CVmix_tidal_params_user + end if + + select case (trim(varname)) + case ('ltidal_Schmittner_socn') + CVmix_tidal_params_out%ltidal_Schmittner_socn = val + case DEFAULT + print*, "ERROR: ", trim(varname), " is not a boolean variable!" + stop 1 + end select + +!EOC + + end subroutine cvmix_put_tidal_logical + +!BOP + +! !IROUTINE: cvmix_put_tidal_real +! !INTERFACE: + + subroutine cvmix_put_tidal_real(varname, val, CVmix_tidal_params_user) + +! !DESCRIPTION: +! Write a real value into a cvmix\_tidal\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + real(cvmix_r8), intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_tidal_params_type), optional, target, intent(inout) :: & + CVmix_tidal_params_user + +!EOP +!BOC + + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params_out + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params_out => CVmix_tidal_params_user + else + CVmix_tidal_params_out => CVmix_tidal_params_saved + end if + + select case (trim(varname)) + case ('efficiency') + CVmix_tidal_params_out%efficiency = val + case ('vertical_decay_scale') + CVmix_tidal_params_out%vertical_decay_scale = val + case ('vertical_decay_scaleR') + CVmix_tidal_params_out%vertical_decay_scaleR = val + case ('max_coefficient') + CVmix_tidal_params_out%max_coefficient = val + case ('local_mixing_frac') + CVmix_tidal_params_out%local_mixing_frac = val + case ('depth_cutoff') + CVmix_tidal_params_out%depth_cutoff = val + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end subroutine cvmix_put_tidal_real + +!BOP + +! !IROUTINE: cvmix_put_tidal_str +! !INTERFACE: + + subroutine cvmix_put_tidal_str(varname, val, CVmix_tidal_params_user) + +! !DESCRIPTION: +! Write a string into a cvmix\_tidal\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: val + +! !OUTPUT PARAMETERS: + type(cvmix_tidal_params_type), optional, target, intent(inout) :: & + CVmix_tidal_params_user + +!EOP +!BOC + + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params_out + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params_out => CVmix_tidal_params_user + else + CVmix_tidal_params_out => CVmix_tidal_params_saved + end if + + select case (trim(varname)) + case ('mix_scheme') + CVmix_tidal_params_out%mix_scheme = val + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end subroutine cvmix_put_tidal_str + +!BOP + +! !IROUTINE: cvmix_get_tidal_real +! !INTERFACE: + + function cvmix_get_tidal_real(varname, CVmix_tidal_params_user) + +! !DESCRIPTION: +! Returns the real value of a cvmix\_tidal\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + type(cvmix_tidal_params_type), optional, target, intent(in) :: & + CVmix_tidal_params_user + +! !OUTPUT PARAMETERS: + real(cvmix_r8) :: cvmix_get_tidal_real + +!EOP +!BOC + + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params_in + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params_in => CVmix_tidal_params_user + else + CVmix_tidal_params_in => CVmix_tidal_params_saved + end if + + cvmix_get_tidal_real = cvmix_zero + select case (trim(varname)) + case ('efficiency') + cvmix_get_tidal_real = CVmix_tidal_params_in%efficiency + case ('vertical_decay_scale') + cvmix_get_tidal_real = CVmix_tidal_params_in%vertical_decay_scale + case ('max_coefficient') + cvmix_get_tidal_real = CVmix_tidal_params_in%max_coefficient + case ('local_mixing_frac') + cvmix_get_tidal_real = CVmix_tidal_params_in%local_mixing_frac + case ('depth_cutoff') + cvmix_get_tidal_real = CVmix_tidal_params_in%depth_cutoff + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + end select + +!EOC + + end function cvmix_get_tidal_real + +!BOP + +! !IROUTINE: cvmix_get_tidal_str +! !INTERFACE: + + function cvmix_get_tidal_str(varname, CVmix_tidal_params_user) + +! !DESCRIPTION: +! Returns the string value of a cvmix\_tidal\_params\_type variable. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + type(cvmix_tidal_params_type), optional, target, intent(in) :: & + CVmix_tidal_params_user + +! !OUTPUT PARAMETERS: + character(len=cvmix_strlen) :: cvmix_get_tidal_str + +!EOP +!BOC + + type(cvmix_tidal_params_type), pointer :: CVmix_tidal_params_in + + if (present(CVmix_tidal_params_user)) then + CVmix_tidal_params_in => CVmix_tidal_params_user + else + CVmix_tidal_params_in => CVmix_tidal_params_saved + end if + + select case (trim(varname)) + case ('mix_scheme') + cvmix_get_tidal_str = trim(CVmix_tidal_params_in%mix_scheme) + case DEFAULT + print*, "ERROR: ", trim(varname), " not a valid choice!" + stop 1 + + end select + +!EOC + + end function cvmix_get_tidal_str + +end module cvmix_tidal diff --git a/parameterizations/CVmix/cvmix_utils.F90 b/parameterizations/CVmix/cvmix_utils.F90 new file mode 100644 index 0000000000..fb37f35340 --- /dev/null +++ b/parameterizations/CVmix/cvmix_utils.F90 @@ -0,0 +1,242 @@ +module cvmix_utils + +!BOP +!\newpage +! !MODULE: cvmix_utils +! +! !AUTHOR: +! Michael N. Levy, NCAR (mlevy@ucar.edu) +! +! !DESCRIPTION: +! This module contains routines that are called by multiple modules but don't +! specifically compute anything mixing related. +!\\ +!\\ + +! !USES: + + use cvmix_kinds_and_types, only : cvmix_r8, & + cvmix_strlen, & + CVMIX_SUM_OLD_AND_NEW_VALS, & + CVMIX_MAX_OLD_AND_NEW_VALS, & + CVMIX_OVERWRITE_OLD_VAL + +!EOP + + implicit none + private + save + +!BOP + +! !PUBLIC MEMBER FUNCTIONS: + public :: cvmix_update_wrap + public :: cvmix_att_name + +!EOP + +contains + +!BOP + +! !IROUTINE: cvmix_update_wrap +! !INTERFACE: + + subroutine cvmix_update_wrap(old_vals, nlev, Mdiff_out, new_Mdiff, & + Tdiff_out, new_Tdiff, Sdiff_out, new_Sdiff) + +! !DESCRIPTION: +! Update diffusivity values based on \verb|old_vals| (either overwrite, sum, or find +! the level-by-level max) +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + integer, intent(in) :: old_vals, nlev + real(cvmix_r8), dimension(nlev+1), optional, intent(in) :: new_Mdiff, & + new_Tdiff, & + new_Sdiff + +! !OUTPUT PARAMETERS: + real(cvmix_r8), dimension(nlev+1), optional, intent(inout) :: Mdiff_out, & + Tdiff_out, & + Sdiff_out + +!EOP +!BOC + + integer :: kw + + select case (old_vals) + case (CVMIX_SUM_OLD_AND_NEW_VALS) + if ((present(Mdiff_out)).and.(present(new_Mdiff))) & + Mdiff_out = Mdiff_out + new_Mdiff + if ((present(Tdiff_out)).and.(present(new_Tdiff))) & + Tdiff_out = Tdiff_out + new_Tdiff + if ((present(Sdiff_out)).and.(present(new_Sdiff))) & + Sdiff_out = Sdiff_out + new_Sdiff + case (CVMIX_MAX_OLD_AND_NEW_VALS) + do kw=1,nlev+1 + if ((present(Mdiff_out)).and.(present(new_Mdiff))) & + Mdiff_out(kw) = max(Mdiff_out(kw), new_Mdiff(kw)) + if ((present(Tdiff_out)).and.(present(new_Tdiff))) & + Tdiff_out(kw) = max(Tdiff_out(kw), new_Tdiff(kw)) + if ((present(Sdiff_out)).and.(present(new_Sdiff))) & + Sdiff_out(kw) = max(Sdiff_out(kw), new_Sdiff(kw)) + end do + case (CVMIX_OVERWRITE_OLD_VAL) + if ((present(Mdiff_out)).and.(present(new_Mdiff))) & + Mdiff_out = new_Mdiff + if ((present(Tdiff_out)).and.(present(new_Tdiff))) & + Tdiff_out = new_Tdiff + if ((present(Sdiff_out)).and.(present(new_Sdiff))) & + Sdiff_out = new_Sdiff + case DEFAULT + print*, "ERROR: do not know how to handle old values!" + stop 1 + end select + +!EOC + + end subroutine cvmix_update_wrap + +!BOP + +! !IROUTINE: cvmix_att_name +! !INTERFACE: + + function cvmix_att_name(varname) + +! !DESCRIPTION: +! Given a variable short name, returns the precise name of the desired +! attribute in the cvmix\_data\_type structure. +!\\ +!\\ + +! !USES: +! Only those used by entire module. + +! !INPUT PARAMETERS: + character(len=*), intent(in) :: varname + +! !OUTPUT PARAMETERS: + character(len=cvmix_strlen) :: cvmix_att_name + +!EOP +!BOC + + select case(trim(varname)) + ! Scalars + case ("nlev", "NumberLevels", "NumberOfLevels") + cvmix_att_name = "nlev" + case ("max_nlev", "MaxNumberLevels", "MaxNumberOfLevels") + cvmix_att_name = "max_nlev" + case ("depth", "ocn_depth", "OceanDepth", "DepthOfOcean") + cvmix_att_name = "OceanDepth" + case ('BoundaryLayerDepth','OBL_depth') + cvmix_att_name = "BoundaryLayerDepth" + case ("SSH", "surf_hgt", "SeaSurfaceHeight", "SurfaceHeight", "height") + cvmix_att_name = "SeaSurfaceHeight" + case ("surf_fric", "SurfaceFriction") + cvmix_att_name = "SurfaceFriction" + case ("surf_buoy", "SurfaceBuoyancy", "SurfaceBuoyancyForcing") + cvmix_att_name = "SurfaceBuoyancyForcing" + case ("lat", "latitude", "Latitude") + cvmix_att_name = "Latitude" + case ("lon", "longitude", "Longitude") + cvmix_att_name = "Longitude" + case ("coriolis", "Coriolis", "CoriolisFreq", "CoriolisFrequency") + cvmix_att_name = "Coriolis" + case ("kOBL_depth", "BoundaryLayerDepthIndex") + cvmix_att_name = "kOBL_depth" + case ("LangmuirEnhancementFactor", "EnhancementFactor", & + "langmuir_Efactor") + cvmix_att_name = "LangmuirEnhancementFactor" + case ("LangmuirNumber", "La") + cvmix_att_name = "LangmuirNumber" + case ("ltidal_Schmittner_socn") + cvmix_att_name = "UseSchmittnerSouthernOceanMods" + case ("ltidal_max") + cvmix_att_name = "ApplyTidalMixingCap" + + ! Variables on level interfaces + case ("zw", "zw_iface") + cvmix_att_name = "zw_iface" + case ("dzw", "dzw_iface") + cvmix_att_name = "dzw" + case ("Mdiff", "Udiff", "MomentumDiff", "MomentumDiffusivity") + cvmix_att_name = "Mdiff_iface" + case ("Tdiff", "TempDiff", "TemperatureDiff", "TemperatureDiffusivity") + cvmix_att_name = "Tdiff_iface" + case ("Sdiff", "SaltDiff", "SalinityDiff", "SalinityDiffusivity") + cvmix_att_name = "Sdiff_iface" + case ("Ri", "Ri_iface", "Richardson", "ShearRichardson", & + "RichardsonNumber", "ShearRichardsonNumber", & + "ShearRichardson_iface") + cvmix_att_name = "ShearRichardson_iface" + case ("buoy", "buoy_iface", "N", "Nsqr", "BuoyancyFreq", "SqrBuoyancy", & + "SqrBuoyancyFreq", "SqrBuoyancyFreq_iface") + cvmix_att_name = "SqrBuoyancyFreq_iface" + case ("kpp_transport", "kpp_nonlocal", "nonlocal_transport", & + "nonlocal", "kpp_nonlocal_iface") + ! Note: this isn't an attribute in the data type, but put / get + ! uses this as short hand for "both Tnonlocal and Snonlocal" + cvmix_att_name = "kpp_nonlocal_iface" + case ("Tnonlocal", "KPP_T_Nonlocal", "kpp_Tnonlocal", "kpp_Ttransport", & + "kpp_Tnonlocal_iface") + cvmix_att_name = "kpp_Tnonlocal_iface" + case ("Snonlocal", "KPP_S_Nonlocal", "kpp_Snonlocal", "kpp_Stransport", & + "kpp_Snonlocal_iface") + cvmix_att_name = "kpp_Snonlocal_iface" + + ! Variables on level centers + case ("z","zt","zt_cntr") + cvmix_att_name = "zt_cntr" + case ("dz", "dzt", "CellThickness") + cvmix_att_name = "dzt" + case ("rho", "dens", "WaterDensity", "WaterDensity_cntr") + cvmix_att_name = "WaterDensity_cntr" + case ("rho_lwr", "dens_lwr", "AdiabWaterDensity", & + "AdiabWaterDensity_cntr") + cvmix_att_name = "AdiabWaterDensity_cntr" + case ("Rib", "Ri_bulk", "BulkRichardson", "BulkRichardsonNumber", & + "BulkRichardson_cntr") + cvmix_att_name = "BulkRichardson_cntr" + case ("Rrho", "strat_param") + ! Note: this isn't an attribute in the data type, but the I/O routines + ! use it to denote strat_param_num / strat_param_denom + cvmix_att_name = "strat_param" + case ("Rrho_num", "strat_param_num") + cvmix_att_name = "strat_param_num" + case ("Rrho_denom", "strat_param_denom") + cvmix_att_name = "strat_param_denom" + case ("Buoyancy","buoyancy","buoyancy_cntr") + cvmix_att_name = "buoyancy_cntr" + case ("U", "Vx", "Vx_cntr") + cvmix_att_name = "Vx_cntr" + case ("V", "Vy", "Vy_cntr") + cvmix_att_name = "Vy_cntr" + case ("SimmonsCoeff", "TidalCoeff") + cvmix_att_name = "SimmonsCoeff" + case ("SchmittnerCoeff") + cvmix_att_name = "SchmittnerCoeff" + case ("SchmittnerSouthernOcean") + cvmix_att_name = "SchmittnerSouthernOcean" + case ("exp_hab_zetar") + cvmix_att_name = "exp_hab_zetar" + case ("VertDep", "VertDep_iface", "vert_dep") + cvmix_att_name = "VertDep_iface" + case DEFAULT + print*, "ERROR: ", trim(varname), " is not tied to an attribute of ", & + "the cvmix_data_type structure." + stop 1 + end select + +!EOC + + end function cvmix_att_name + +end module cvmix_utils diff --git a/parameterizations/CVmix/makedep.py b/parameterizations/CVmix/makedep.py new file mode 100755 index 0000000000..c4b5c29dcb --- /dev/null +++ b/parameterizations/CVmix/makedep.py @@ -0,0 +1,74 @@ +#!/usr/bin/env python + +# usage: makedep.py $(DEP_FILE) $(OBJ_DIR) $(SRC_DIR) [$(SRC_DIR2)] + +# Generate $DEP_FILE in $OBJ_DIR (arguments 1 and 2, respectively) +# Read in every file in $SRC_DIR and $SRC_DIR2 (arguments 3 and 4) +# Only depend on modules located in $SRC_DIR or $SRC_DIR2 + +import os +import sys +import re +import logging +logger = logging.getLogger(__name__) +logging.basicConfig(format='(makedep.py): %(message)s', level=logging.INFO) + +try: + dep_file = sys.argv[1] +except: + dep_file = "depends.d" + +try: + obj_dir = sys.argv[2] +except: + obj_dir = '.' + +try: + src_dir = sys.argv[3] +except: + src_dir = '.' + +try: + src_dir2 = sys.argv[4] +except: + src_dir2 = src_dir + +try: + inc_dir = sys.argv[5] + files_in_inc_dir = os.listdir(inc_dir) +except: + inc_dir = 'NONE' + +fout = open(dep_file, 'w') +files_in_src_dir = os.listdir(src_dir) +if src_dir != src_dir2: + files_in_src_dir.extend(os.listdir(src_dir2)) + +for src_file in files_in_src_dir: + file_name, file_ext = os.path.splitext(src_file) + if file_ext == '.F90': + try: + fin = open(src_dir+'/'+src_file,"r") + except: + fin = open(src_dir2+'/'+src_file,"r") + for line in fin: + if re.match('^ *[Uu][Ss][Ee]',line): + line_array = line.split() + # statements are usually "use module, only : subroutine" + # so we need to strip away the , to get the module name + file_used = line_array[1].split(',')[0] + if file_used+'.F90' in files_in_src_dir: + logger.info('%s.o depends on %s.o', file_name, file_used) + fout.write(obj_dir+'/'+file_name+'.o: '+obj_dir+'/'+file_used+'.o\n') + else: + if inc_dir != 'NONE': + if file_used+'.mod' in files_in_inc_dir: + logger.info('%s.o depends on %s.mod', file_name, file_used) + fout.write(obj_dir+'/'+file_name+'.o: '+inc_dir+'/'+file_used+'.mod\n') + else: + # Check for upper case + file_used = file_used.upper() + if file_used+'.mod' in files_in_inc_dir: + logger.info('%s.o depends on %s.mod', file_name, file_used) + fout.write(obj_dir+'/'+file_name+'.o: '+inc_dir+'/'+file_used+'.mod\n') + fin.close diff --git a/parameterizations/stochastic/MOM_stochastics.F90 b/parameterizations/stochastic/MOM_stochastics.F90 new file mode 100644 index 0000000000..04a29019fa --- /dev/null +++ b/parameterizations/stochastic/MOM_stochastics.F90 @@ -0,0 +1,147 @@ +!> Top-level module for the MOM6 ocean model in coupled mode. +module MOM_stochastics + +! This file is part of MOM6. See LICENSE.md for the license. + +! This is the top level module for the MOM6 ocean model. It contains routines +! for initialization, update, and writing restart of stochastic physics. This +! particular version wraps all of the calls for MOM6 in the calls that had +! been used for MOM4. +! +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type +use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type +use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain +use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain +use MOM_domains, only : root_PE, num_PEs +use MOM_coms, only : Get_PElist +use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn + +#include + +implicit none ; private + +public stochastics_init, update_stochastics + +!> This control structure holds parameters for the MOM_stochastics module +type, public:: stochastic_CS + logical :: do_sppt !< If true, stochastically perturb the diabatic + logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and genration terms + integer :: id_sppt_wts = -1 !< Diagnostic id for SPPT + integer :: id_epbl1_wts = -1 !< Diagnostic id for epbl generation perturbation + integer :: id_epbl2_wts = -1 !< Diagnostic id for epbl dissipation perturbation + ! stochastic patterns + real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT + !! tendencies with a number between 0 and 2 + real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation + real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation + type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output + type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) +end type stochastic_CS + +contains + +!! This subroutine initializes the stochastics physics control structure. +subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) + real, intent(in) :: dt !< time step [T ~> s] + type(ocean_grid_type), intent(in) :: grid !< horizontal grid information + type(verticalGrid_type), intent(in) :: GV !< vertical grid structure + type(stochastic_CS), pointer, intent(inout) :: CS !< stochastic control structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output + type(time_type), target :: Time !< model time + + ! Local variables + integer, allocatable :: pelist(:) ! list of pes for this instance of the ocean + integer :: mom_comm ! list of pes for this instance of the ocean + integer :: num_procs ! number of processors to pass to stochastic physics + integer :: iret ! return code from stochastic physics + integer :: pe_zero ! root pe + integer :: nx ! number of x-points including halo + integer :: ny ! number of x-points including halo + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "ocean_stochastics_init" ! This module's name. + + call callTree_enter("ocean_model_stochastic_init(), MOM_stochastics.F90") + if (associated(CS)) then + call MOM_error(WARNING, "MOM_stochastics_init called with an "// & + "associated control structure.") + return + else ; allocate(CS) ; endif + + CS%diag => diag + CS%Time => Time + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + ! get number of processors and PE list for stochastic physics initialization + call get_param(param_file, mdl, "DO_SPPT", CS%do_sppt, & + "If true, then stochastically perturb the thermodynamic "//& + "tendemcies of T,S, amd h. Amplitude and correlations are "//& + "controlled by the nam_stoch namelist in the UFS model only.", & + default=.false.) + call get_param(param_file, mdl, "PERT_EPBL", CS%pert_epbl, & + "If true, then stochastically perturb the kinetic energy "//& + "production and dissipation terms. Amplitude and correlations are "//& + "controlled by the nam_stoch namelist in the UFS model only.", & + default=.false.) + if (CS%do_sppt .OR. CS%pert_epbl) then + num_procs = num_PEs() + allocate(pelist(num_procs)) + call Get_PElist(pelist,commID = mom_comm) + pe_zero = root_PE() + nx = grid%ied - grid%isd + 1 + ny = grid%jed - grid%jsd + 1 + call init_stochastic_physics_ocn(dt,grid%geoLonT,grid%geoLatT,nx,ny,GV%ke, & + CS%pert_epbl,CS%do_sppt,pe_zero,mom_comm,iret) + if (iret/=0) then + call MOM_error(FATAL, "call to init_stochastic_physics_ocn failed") + endif + + if (CS%do_sppt) allocate(CS%sppt_wts(grid%isd:grid%ied,grid%jsd:grid%jed), source=0.0) + if (CS%pert_epbl) then + allocate(CS%epbl1_wts(grid%isd:grid%ied,grid%jsd:grid%jed), source=0.0) + allocate(CS%epbl2_wts(grid%isd:grid%ied,grid%jsd:grid%jed), source=0.0) + endif + endif + if (CS%do_sppt) then + CS%id_sppt_wts = register_diag_field('ocean_model', 'sppt_pattern', CS%diag%axesT1, Time, & + 'random pattern for sppt', 'None') + endif + if (CS%pert_epbl) then + CS%id_epbl1_wts = register_diag_field('ocean_model', 'epbl1_wts', CS%diag%axesT1, Time, & + 'random pattern for KE generation', 'None') + CS%id_epbl2_wts = register_diag_field('ocean_model', 'epbl2_wts', CS%diag%axesT1, Time, & + 'random pattern for KE dissipation', 'None') + endif + + if (CS%do_sppt .OR. CS%pert_epbl) & + call MOM_mesg(' === COMPLETED MOM STOCHASTIC INITIALIZATION =====') + + call callTree_leave("ocean_model_init(") + +end subroutine stochastics_init + +!> update_ocean_model uses the forcing in Ice_ocean_boundary to advance the +!! ocean model's state from the input value of Ocean_state (which must be for +!! time time_start_update) for a time interval of Ocean_coupling_time_step, +!! returning the publicly visible ocean surface properties in Ocean_sfc and +!! storing the new ocean properties in Ocean_state. +subroutine update_stochastics(CS) + type(stochastic_CS), intent(inout) :: CS !< diabatic control structure + call callTree_enter("update_stochastics(), MOM_stochastics.F90") + +! update stochastic physics patterns before running next time-step + call run_stochastic_physics_ocn(CS%sppt_wts,CS%epbl1_wts,CS%epbl2_wts) + + return +end subroutine update_stochastics + +end module MOM_stochastics + diff --git a/parameterizations/vertical/MOM_ALE_sponge.F90 b/parameterizations/vertical/MOM_ALE_sponge.F90 new file mode 100644 index 0000000000..0f4b50237e --- /dev/null +++ b/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -0,0 +1,1422 @@ +!> This module contains the routines used to apply sponge layers when using +!! the ALE mode. +!! +!! Applying sponges requires the following: +!! 1. initialize_ALE_sponge +!! 2. set_up_ALE_sponge_field (tracers) and set_up_ALE_sponge_vel_field (vel) +!! 3. apply_ALE_sponge +!! 4. init_ALE_sponge_diags (not being used for now) +!! 5. ALE_sponge_end (not being used for now) + +module MOM_ALE_sponge + + +! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only: rotate_array +use MOM_coms, only : sum_across_PEs +use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field +use MOM_diag_mediator, only : diag_ctrl +use MOM_domains, only : pass_var, To_ALL, Omit_Corners +use MOM_error_handler, only : MOM_error, FATAL, NOTE, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer +use MOM_interpolate, only : init_external_field, get_external_field_info, time_interp_external_init +use MOM_interpolate, only : external_field +use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping +use MOM_spatial_means, only : global_i_mean +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +!> Store the reference profile at h points for a variable +interface set_up_ALE_sponge_field + module procedure set_up_ALE_sponge_field_fixed + module procedure set_up_ALE_sponge_field_varying +end interface + +!> This subroutine stores the reference profile at u and v points for a vector +interface set_up_ALE_sponge_vel_field + module procedure set_up_ALE_sponge_vel_field_fixed + module procedure set_up_ALE_sponge_vel_field_varying +end interface + +!> Determine the number of points which are within sponges in this computational domain. +!! +!! Only points that have positive values of Iresttime and which mask2dT indicates are ocean +!! points are included in the sponges. It also stores the target interface heights. +interface initialize_ALE_sponge + module procedure initialize_ALE_sponge_fixed + module procedure initialize_ALE_sponge_varying +end interface + +! Publicly available functions +public set_up_ALE_sponge_field, set_up_ALE_sponge_vel_field +public get_ALE_sponge_thicknesses, get_ALE_sponge_nz_data +public initialize_ALE_sponge, apply_ALE_sponge, ALE_sponge_end, init_ALE_sponge_diags +public rotate_ALE_sponge, update_ALE_sponge_field + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> A structure for creating arrays of pointers to 3D arrays with extra gridding information +type :: p3d ; private + !integer :: id !< id for FMS external time interpolator + integer :: nz_data !< The number of vertical levels in the input field. + integer :: num_tlevs !< The number of time records contained in the file + real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data [various] + real, dimension(:,:,:), pointer :: dz => NULL() !< pointer to the data grid spacing [Z ~> m] +end type p3d + +!> A structure for creating arrays of pointers to 2D arrays with extra gridding information +type :: p2d ; private + type(external_field) :: field !< Time interpolator field handle + integer :: nz_data !< The number of vertical levels in the input field + integer :: num_tlevs !< The number of time records contained in the file + real :: scale = 1.0 !< A multiplicative factor by which to rescale input data [various] + real, dimension(:,:), pointer :: p => NULL() !< pointer to the data [various] + real, dimension(:,:), pointer :: dz => NULL() !< pointer to the data grid spacing [Z ~> m] + character(len=:), allocatable :: name !< The name of the input field + character(len=:), allocatable :: long_name !< The long name of the input field + character(len=:), allocatable :: unit !< The unit of the input field +end type p2d + +!> ALE sponge control structure +type, public :: ALE_sponge_CS ; private + integer :: nz !< The total number of layers. + integer :: nz_data !< The total number of arbitrary layers (used by older code). + integer :: num_col !< The number of sponge tracer points within the computational domain. + integer :: num_col_u !< The number of sponge u-points within the computational domain. + integer :: num_col_v !< The number of sponge v-points within the computational domain. + integer :: fldno = 0 !< The number of fields which have already been + !! registered by calls to set_up_sponge_field + logical :: sponge_uv !< Control whether u and v are included in sponge + integer, allocatable :: col_i(:) !< Array of the i-indices of each tracer column being damped + integer, allocatable :: col_j(:) !< Array of the j-indices of each tracer column being damped + integer, allocatable :: col_i_u(:) !< Array of the i-indices of each u-column being damped + integer, allocatable :: col_j_u(:) !< Array of the j-indices of each u-column being damped + integer, allocatable :: col_i_v(:) !< Array of the i-indices of each v-column being damped + integer, allocatable :: col_j_v(:) !< Array of the j-indices of each v-column being damped + + real, allocatable :: Iresttime_col(:) !< The inverse restoring time of each tracer column [T-1 ~> s-1] + real, allocatable :: Iresttime_col_u(:) !< The inverse restoring time of each u-column [T-1 ~> s-1] + real, allocatable :: Iresttime_col_v(:) !< The inverse restoring time of each v-column [T-1 ~> s-1] + + type(p3d) :: var(MAX_FIELDS_) !< Pointers to the fields that are being damped. + type(p2d) :: Ref_val(MAX_FIELDS_) !< The values to which the fields are damped. + type(p2d) :: Ref_val_u !< The values to which the u-velocities are damped. + type(p2d) :: Ref_val_v !< The values to which the v-velocities are damped. + type(p3d) :: var_u !< Pointer to the u velocities that are being damped. + type(p3d) :: var_v !< Pointer to the v velocities that are being damped. + type(p2d) :: Ref_dz !< Grid on which reference data is provided (older code). + type(p2d) :: Ref_dzu !< u-point grid on which reference data is provided (older code). + type(p2d) :: Ref_dzv !< v-point grid on which reference data is provided (older code). + + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. + + type(remapping_cs) :: remap_cs !< Remapping parameters and work arrays + integer :: remap_answer_date !< The vintage of the order of arithmetic and expressions to use + !! for remapping. Values below 20190101 recover the remapping + !! answers from 2018, while higher values use more robust + !! forms of the same remapping expressions. + integer :: hor_regrid_answer_date !< The vintage of the order of arithmetic and expressions to use + !! for horizontal regridding. Values below 20190101 recover the + !! answers from 2018, while higher values use expressions that have + !! been rearranged for rotational invariance. + + logical :: time_varying_sponges !< True if using newer sponge code + logical :: spongeDataOngrid !< True if the sponge data are on the model horizontal grid + real :: varying_input_dz_mask !< An input file thickness below which the target values with time-varying + !! sponges are replaced by the value above [Z ~> m]. + !! It is not clear why this needs to be greater than 0. + + !>@{ Diagnostic IDs + integer, dimension(MAX_FIELDS_) :: id_sp_tendency !< Diagnostic ids for tracer + !! tendencies due to sponges + integer :: id_sp_u_tendency !< Diagnostic id for zonal momentum tendency due to + !! Rayleigh damping + integer :: id_sp_v_tendency !< Diagnostic id for meridional momentum tendency due to + !! Rayleigh damping +end type ALE_sponge_CS + +contains + +!> This subroutine determines the number of points which are within sponges in this computational +!! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean +!! points are included in the sponges. It also stores the target interface heights. +subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, nz_data, & + Iresttime_u_in, Iresttime_v_in, data_h_is_Z) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + integer, intent(in) :: nz_data !< The total number of sponge input layers. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module (in/out). + real, dimension(SZI_(G),SZJ_(G),nz_data), intent(inout) :: data_h !< The thicknesses of the sponge + !! input layers, in [H ~> m or kg m-2] or [Z ~> m] + !! depending on data_h_is_Z. + real, dimension(SZIB_(G),SZJ_(G)), optional, intent(in) :: Iresttime_u_in !< The inverse of the restoring + !! time at U-points [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: Iresttime_v_in !< The inverse of the restoring + !! time at v-points [T-1 ~> s-1]. + logical, optional, intent(in) :: data_h_is_Z !< If present and true data_h is already in + !! depth units. Omitting this is the same as setting + !! it to false. + + ! Local variables + character(len=40) :: mdl = "MOM_sponge" ! This module's name. + real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [T-1 ~> s-1] + real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),nz_data) :: data_dz !< The vertical extent of the sponge + !! input layers [Z ~> m]. + real :: data_h_to_Z_scale ! A scaling factor to convert data_h into the right units, often [Z H-1 ~> 1 or m3 kg-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=64) :: remapScheme + logical :: use_sponge + logical :: data_h_to_Z + logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v + + if (associated(CS)) then + call MOM_error(WARNING, "initialize_ALE_sponge_fixed called with an associated "// & + "control structure.") + return + endif + +! Set default, read and log parameters + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "SPONGE", use_sponge, & + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified from MOM_initialization.F90.", default=.false.) + + if (.not.use_sponge) return + + allocate(CS) + + call get_param(param_file, mdl, "SPONGE_UV", CS%sponge_uv, & + "Apply sponges in u and v, in addition to tracers.", & + default=.false.) + + call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & + "This sets the reconstruction scheme used "//& + " for vertical remapping for all variables.", & + default="PLM", do_not_log=.true.) + + call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & + "When defined, a proper high-order reconstruction "//& + "scheme is used within boundary cells rather "//& + "than PCM. E.g., if PPM is used for remapping, a "//& + "PPM reconstruction will also be used within boundary cells.", & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) + + call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & + "The vintage of the order of arithmetic for horizontal regridding. "//& + "Dates before 20190101 give the same answers as the code did in late 2018, "//& + "while later versions add parentheses for rotational symmetry. "//& + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%hor_regrid_answer_date = max(CS%hor_regrid_answer_date, 20230701) + + CS%time_varying_sponges = .false. + CS%nz = GV%ke + + data_h_to_Z_scale = GV%H_to_Z ; if (present(data_h_is_Z)) data_h_to_Z_scale = 1.0 + + do k=1,nz_data ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + data_dz(i,j,k) = data_h_to_Z_scale * data_h(i,j,k) + enddo ; enddo ; enddo + ! 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.0)) & + CS%num_col = CS%num_col + 1 + enddo ; enddo + + if (CS%num_col > 0) then + allocate(CS%Iresttime_col(CS%num_col), source=0.0) + allocate(CS%col_i(CS%num_col), source=0) + allocate(CS%col_j(CS%num_col), source=0) + ! 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.0)) then + CS%col_i(col) = i ; CS%col_j(col) = j + CS%Iresttime_col(col) = Iresttime(i,j) + col = col + 1 + endif + enddo ; enddo + ! same for total number of arbitrary layers and correspondent data + CS%nz_data = nz_data + allocate(CS%Ref_dz%p(CS%nz_data,CS%num_col), source=0.0) + do col=1,CS%num_col ; do K=1,CS%nz_data + CS%Ref_dz%p(K,col) = data_dz(CS%col_i(col),CS%col_j(col),K) + enddo ; enddo + endif + + total_sponge_cols = CS%num_col + call sum_across_PEs(total_sponge_cols) + +! Call the constructor for remapping control structure + call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & + answer_date=CS%remap_answer_date) + + call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & + "The total number of columns where sponges are applied at h points.", like_default=.true.) + + if (CS%sponge_uv) then + allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed), source=0.0) + allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB), source=0.0) + + call pass_var(Iresttime, G%Domain, To_All+Omit_Corners, halo=1) + call pass_var(data_dz, G%Domain, To_All+Omit_Corners, halo=1) + + ! u points + CS%num_col_u = 0 ; + if (present(Iresttime_u_in)) then + 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 + enddo ; enddo + + if (CS%num_col_u > 0) then + + allocate(CS%Iresttime_col_u(CS%num_col_u), source=0.0) + allocate(CS%col_i_u(CS%num_col_u), source=0) + allocate(CS%col_j_u(CS%num_col_u), source=0) + + ! 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.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 + endif + enddo ; enddo + + ! same for total number of arbitrary layers and correspondent data + allocate(CS%Ref_dzu%p(CS%nz_data,CS%num_col_u), source=0.0) + do col=1,CS%num_col_u + I = CS%col_i_u(col) ; j = CS%col_j_u(col) + do k=1,CS%nz_data + CS%Ref_dzu%p(k,col) = 0.5 * (data_dz(i,j,k) + data_dz(i+1,j,k)) + enddo + enddo + endif + total_sponge_cols_u = CS%num_col_u + call sum_across_PEs(total_sponge_cols_u) + call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & + "The total number of columns where sponges are applied at u points.", like_default=.true.) + + ! v points + CS%num_col_v = 0 ; + if (present(Iresttime_v_in)) then + Iresttime_v(:,:) = Iresttime_v_in(:,:) + else + do J=G%jscB,G%jecB; do i=G%isc,G%iec + Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) + 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.0)) & + CS%num_col_v = CS%num_col_v + 1 + enddo ; enddo + + if (CS%num_col_v > 0) then + + allocate(CS%Iresttime_col_v(CS%num_col_v), source=0.0) + allocate(CS%col_i_v(CS%num_col_v), source=0) + allocate(CS%col_j_v(CS%num_col_v), source=0) + + ! 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.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 + endif + enddo ; enddo + + ! same for total number of arbitrary layers and correspondent data + allocate(CS%Ref_dzv%p(CS%nz_data,CS%num_col_v), source=0.0) + do col=1,CS%num_col_v + i = CS%col_i_v(col) ; J = CS%col_j_v(col) + do k=1,CS%nz_data + CS%Ref_dzv%p(k,col) = 0.5 * (data_dz(i,j,k) + data_dz(i,j+1,k)) + enddo + enddo + endif + total_sponge_cols_v = CS%num_col_v + call sum_across_PEs(total_sponge_cols_v) + call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & + "The total number of columns where sponges are applied at v points.", like_default=.true.) + endif + +end subroutine initialize_ALE_sponge_fixed + +!> Return the number of layers in the data with a fixed ALE sponge, or 0 if there are +!! no sponge columns on this PE. +function get_ALE_sponge_nz_data(CS) + type(ALE_sponge_CS), intent(in) :: CS !< ALE sponge control struct + integer :: get_ALE_sponge_nz_data !< The number of layers in the fixed sponge data. + + get_ALE_sponge_nz_data = CS%nz_data +end function get_ALE_sponge_nz_data + +!> Return the thicknesses used for the data with a fixed ALE sponge +subroutine get_ALE_sponge_thicknesses(G, GV, data_h, sponge_mask, CS, data_h_in_Z) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, allocatable, dimension(:,:,:), & + intent(inout) :: data_h !< The thicknesses of the sponge input layers expressed + !! as vertical extents [Z ~> m] or in thickness units + !! [H ~> m or kg m-2], depending on the value of data_h_in_Z. + logical, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: sponge_mask !< A logical mask that is true where + !! sponges are being applied. + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for the ALE_sponge module. + logical, optional, intent(in) :: data_h_in_Z !< If present and true data_h is returned in + !! depth units. Omitting this is the same as setting + !! it to false. + real :: Z_to_data_h_units ! A scaling factor to return data_h in the right units, often [H Z-1 ~> 1 or kg m-3] + integer :: c, i, j, k + + if (allocated(data_h)) call MOM_error(FATAL, & + "get_ALE_sponge_thicknesses called with an allocated data_h.") + + if (.not.associated(CS)) then + ! There are no sponge points on this PE. + allocate(data_h(G%isd:G%ied,G%jsd:G%jed,1), source=-1.0) + sponge_mask(:,:) = .false. + return + endif + + allocate(data_h(G%isd:G%ied,G%jsd:G%jed,CS%nz_data), source=-1.0) + sponge_mask(:,:) = .false. + + Z_to_data_h_units = GV%Z_to_H ; if (present(data_h_in_Z)) Z_to_data_h_units = 1.0 + + do c=1,CS%num_col + i = CS%col_i(c) ; j = CS%col_j(c) + sponge_mask(i,j) = .true. + do k=1,CS%nz_data + data_h(i,j,k) = Z_to_data_h_units*CS%Ref_dz%p(k,c) + enddo + enddo + +end subroutine get_ALE_sponge_thicknesses + +!> This subroutine determines the number of points which are to be restored in the computational +!! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean +!! points are included in the sponges. +subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, Iresttime_u_in, Iresttime_v_in) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse + !! for model parameter values. + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module (in/out). + real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: Iresttime_u_in !< The inverse of the restoring time + !! for u [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: Iresttime_v_in !< The inverse of the restoring time + !! for v [T-1 ~> s-1]. + + ! Local variables + character(len=40) :: mdl = "MOM_sponge" ! This module's name. + real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [T-1 ~> s-1] + real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [T-1 ~> s-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=64) :: remapScheme + logical :: use_sponge + logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: i, j, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v + + if (associated(CS)) then + call MOM_error(WARNING, "initialize_ALE_sponge_varying called with an associated "// & + "control structure.") + return + endif +! Set default, read and log parameters + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "SPONGE", use_sponge, & + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified from MOM_initialization.F90.", default=.false.) + if (.not.use_sponge) return + allocate(CS) + call get_param(param_file, mdl, "SPONGE_UV", CS%sponge_uv, & + "Apply sponges in u and v, in addition to tracers.", & + default=.false.) + call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & + "This sets the reconstruction scheme used "//& + " for vertical remapping for all variables.", & + default="PLM", do_not_log=.true.) + call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & + "When defined, a proper high-order reconstruction "//& + "scheme is used within boundary cells rather "//& + "than PCM. E.g., if PPM is used for remapping, a "//& + "PPM reconstruction will also be used within boundary cells.", & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "VARYING_SPONGE_MASK_THICKNESS", CS%varying_input_dz_mask, & + "An input file thickness below which the target values with "//& + "time-varying sponges are replaced by the value above.", & + units="m", default=0.001, scale=US%m_to_Z) + + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date) + call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & + "The vintage of the order of arithmetic for horizontal regridding. "//& + "Dates before 20190101 give the same answers as the code did in late 2018, "//& + "while later versions add parentheses for rotational symmetry. "//& + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date) + call get_param(param_file, mdl, "SPONGE_DATA_ONGRID", CS%spongeDataOngrid, & + "When defined, the incoming sponge data are "//& + "assumed to be on the model grid " , & + default=.false.) + + CS%time_varying_sponges = .true. + CS%nz = GV%ke + + ! 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.0)) & + CS%num_col = CS%num_col + 1 + enddo ; enddo + if (CS%num_col > 0) then + allocate(CS%Iresttime_col(CS%num_col), source=0.0) + allocate(CS%col_i(CS%num_col), source=0) + allocate(CS%col_j(CS%num_col), source=0) + ! 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.0)) then + CS%col_i(col) = i ; CS%col_j(col) = j + CS%Iresttime_col(col) = Iresttime(i,j) + col = col + 1 + endif + enddo ; enddo + endif + total_sponge_cols = CS%num_col + call sum_across_PEs(total_sponge_cols) + +! Call the constructor for remapping control structure + call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & + answer_date=CS%remap_answer_date) + call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & + "The total number of columns where sponges are applied at h points.", like_default=.true.) + if (CS%sponge_uv) then + allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed), source=0.0) + allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB), source=0.0) + + call pass_var(Iresttime, G%Domain, To_All+Omit_Corners, halo=1) + ! u points + if (present(Iresttime_u_in)) then + 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 + 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.0)) & + CS%num_col_u = CS%num_col_u + 1 + enddo ; enddo + if (CS%num_col_u > 0) then + allocate(CS%Iresttime_col_u(CS%num_col_u), source=0.0) + allocate(CS%col_i_u(CS%num_col_u), source=0) + allocate(CS%col_j_u(CS%num_col_u), source=0) + ! 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.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 + endif + enddo ; enddo + ! same for total number of arbitrary layers and correspondent data + endif + total_sponge_cols_u = CS%num_col_u + call sum_across_PEs(total_sponge_cols_u) + call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & + "The total number of columns where sponges are applied at u points.", like_default=.true.) + ! v points + if (present(Iresttime_v_in)) then + Iresttime_v(:,:) = Iresttime_v_in(:,:) + else + do J=G%jscB,G%jecB; do i=G%isc,G%iec + Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) + enddo ; enddo + 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.0)) & + CS%num_col_v = CS%num_col_v + 1 + enddo ; enddo + if (CS%num_col_v > 0) then + allocate(CS%Iresttime_col_v(CS%num_col_v), source=0.0) + allocate(CS%col_i_v(CS%num_col_v), source=0) + allocate(CS%col_j_v(CS%num_col_v), source=0) + ! 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.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 + endif + enddo ; enddo + endif + total_sponge_cols_v = CS%num_col_v + call sum_across_PEs(total_sponge_cols_v) + call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & + "The total number of columns where sponges are applied at v points.", like_default=.true.) + endif + +end subroutine initialize_ALE_sponge_varying + +!> Initialize diagnostics for the ALE_sponge module. +! GMM: this routine is not being used for now. +subroutine init_ALE_sponge_diags(Time, G, diag, CS, US) + type(time_type), target, intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic + !! output. + type(ALE_sponge_CS), intent(inout) :: CS !< ALE sponge control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! Local Variables + integer :: m + + CS%diag => diag + + do m=1,CS%fldno + CS%id_sp_tendency(m) = -1 + CS%id_sp_tendency(m) = register_diag_field('ocean_model', & + 'sp_tendency_' // CS%Ref_val(m)%name, diag%axesTL, Time, & + 'Time tendency due to restoring ' // CS%Ref_val(m)%long_name, & + CS%Ref_val(m)%unit, conversion=US%s_to_T) + enddo + + CS%id_sp_u_tendency = -1 + CS%id_sp_u_tendency = register_diag_field('ocean_model', 'sp_tendency_u', diag%axesCuL, Time, & + 'Zonal acceleration due to sponges', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_sp_v_tendency = -1 + CS%id_sp_v_tendency = register_diag_field('ocean_model', 'sp_tendency_v', diag%axesCvL, Time, & + 'Meridional acceleration due to sponges', 'm s-2', conversion=US%L_T2_to_m_s2) + +end subroutine init_ALE_sponge_diags + +!> This subroutine stores the reference profile at h points for the variable +!! whose address is given by f_ptr. +subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS, & + sp_name, sp_long_name, sp_unit, scale) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ALE_sponge_CS), pointer :: CS !< ALE sponge control structure (in/out). + real, dimension(SZI_(G),SZJ_(G),CS%nz_data), & + intent(in) :: sp_val !< Field to be used in the sponge, it can have an + !! arbitrary number of layers [various] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + target, intent(in) :: f_ptr !< Pointer to the field to be damped [various] + character(len=*), intent(in) :: sp_name !< The name of the tracer field + character(len=*), optional, & + intent(in) :: sp_long_name !< The long name of the tracer field + !! if not given, use the sp_name + character(len=*), optional, & + intent(in) :: sp_unit !< The unit of the tracer field + !! if not given, use the none + real, optional, intent(in) :: scale !< A factor by which to rescale the input data, including any + !! contributions due to dimensional rescaling [various ~> 1]. + !! The default is 1. + + real :: scale_fac ! A factor by which to scale sp_val before storing it [various ~> 1] + integer :: k, col + character(len=256) :: mesg ! String for error messages + character(len=256) :: long_name ! The long name of the tracer field + character(len=256) :: unit ! The unit of the tracer field + + if (.not.associated(CS)) return + + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + long_name = sp_name; if (present(sp_long_name)) long_name = sp_long_name + unit = 'none'; if (present(sp_unit)) unit = sp_unit + + CS%fldno = CS%fldno + 1 + if (CS%fldno > MAX_FIELDS_) then + write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & + &the number of fields to be damped in the call to & + &initialize_ALE_sponge." )') CS%fldno + call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) + endif + + ! stores the reference profile + CS%Ref_val(CS%fldno)%nz_data = CS%nz_data + CS%Ref_val(CS%fldno)%name = sp_name + CS%Ref_val(CS%fldno)%long_name = long_name + CS%Ref_val(CS%fldno)%unit = unit + allocate(CS%Ref_val(CS%fldno)%p(CS%nz_data,CS%num_col), source=0.0) + do col=1,CS%num_col + do k=1,CS%nz_data + CS%Ref_val(CS%fldno)%p(k,col) = scale_fac*sp_val(CS%col_i(col),CS%col_j(col),k) + enddo + enddo + + CS%var(CS%fldno)%p => f_ptr + +end subroutine set_up_ALE_sponge_field_fixed + +!> This subroutine stores the reference profile at h points for the variable +!! whose address is given by filename and fieldname. +subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, f_ptr, CS, & + sp_name, sp_long_name, sp_unit, scale) + character(len=*), intent(in) :: filename !< The name of the file with the + !! time varying field data + character(len=*), intent(in) :: fieldname !< The name of the field in the file + !! with the time varying field data + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< Grid structure (in). + 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)), & + target, intent(in) :: f_ptr !< Pointer to the field to be damped (in) [various]. + type(ALE_sponge_CS), pointer :: CS !< Sponge control structure (in/out). + character(len=*), intent(in) :: sp_name !< The name of the tracer field + character(len=*), optional, & + intent(in) :: sp_long_name !< The long name of the tracer field + !! if not given, use the sp_name + character(len=*), optional, & + intent(in) :: sp_unit !< The unit of the tracer field + !! if not given, use 'none' + real, optional, intent(in) :: scale !< A factor by which to rescale the input data, including any + !! contributions due to dimensional rescaling [various ~> 1]. + + ! Local variables + integer :: isd, ied, jsd, jed + integer, dimension(4) :: fld_sz + integer :: nz_data !< the number of vertical levels in this input field + character(len=256) :: mesg ! String for error messages + character(len=256) :: long_name ! The long name of the tracer field + character(len=256) :: unit ! The unit of the tracer field + long_name = sp_name; if (present(sp_long_name)) long_name = sp_long_name + unit = 'none'; if (present(sp_unit)) unit = sp_unit + + ! Local variables for ALE remapping + + if (.not.associated(CS)) return + ! initialize time interpolator module + call time_interp_external_init() + isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed + CS%fldno = CS%fldno + 1 + if (CS%fldno > MAX_FIELDS_) then + write(mesg, '("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease "//& + &"the number of fields to be damped in the call to initialize_ALE_sponge." )') CS%fldno + call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) + endif + ! get a unique time interp id for this field. If sponge data is on-grid, then setup + ! to only read on the computational domain + if (CS%spongeDataOngrid) then + CS%Ref_val(CS%fldno)%field = init_external_field(filename, fieldname, MOM_domain=G%Domain) + else + CS%Ref_val(CS%fldno)%field = init_external_field(filename, fieldname) + endif + CS%Ref_val(CS%fldno)%name = sp_name + CS%Ref_val(CS%fldno)%long_name = long_name + CS%Ref_val(CS%fldno)%unit = unit + fld_sz(1:4) = -1 + call get_external_field_info(CS%Ref_val(CS%fldno)%field, size=fld_sz) + nz_data = fld_sz(3) + CS%Ref_val(CS%fldno)%nz_data = nz_data !< individual sponge fields may reside on a different vertical grid + CS%Ref_val(CS%fldno)%num_tlevs = fld_sz(4) + CS%Ref_val(CS%fldno)%scale = 1.0 ; if (present(scale)) CS%Ref_val(CS%fldno)%scale = scale + ! initializes the target profile array for this field + ! for all columns which will be masked + allocate(CS%Ref_val(CS%fldno)%p(nz_data,CS%num_col), source=0.0) + allocate(CS%Ref_val(CS%fldno)%dz(nz_data,CS%num_col), source=0.0) + CS%var(CS%fldno)%p => f_ptr + +end subroutine set_up_ALE_sponge_field_varying + +!> This subroutine stores the reference profile at u and v points for the variable +!! whose address is given by u_ptr and v_ptr. +subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, GV, u_ptr, v_ptr, CS, scale) + type(ocean_grid_type), intent(in) :: G !< Grid structure (in). + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u_val !< u field to be used in the sponge [L T-1 ~> m s-1], + !! it is provided on its own vertical grid that may + !! have fewer layers than the model itself, but not more. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v_val !< v field to be used in the sponge [L T-1 ~> m s-1], + !! it is provided on its own vertical grid that may + !! have fewer layers than the model itself, but not more. + real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_ptr !< u-field to be damped [L T-1 ~> m s-1] + real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_ptr !< v-field to be damped [L T-1 ~> m s-1] + real, optional, intent(in) :: scale !< A factor by which to rescale the input data, including any + !! contributions due to dimensional rescaling [various ~> 1]. + !! The default is 1. + + real :: scale_fac ! A dimensional rescaling factor [various ~> 1] + integer :: k, col + + if (.not.associated(CS)) return + + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + ! stores the reference profile + allocate(CS%Ref_val_u%p(CS%nz_data,CS%num_col_u), source=0.0) + do col=1,CS%num_col_u + do k=1,CS%nz_data + CS%Ref_val_u%p(k,col) = scale_fac*u_val(CS%col_i_u(col),CS%col_j_u(col),k) + enddo + enddo + CS%var_u%p => u_ptr + allocate(CS%Ref_val_v%p(CS%nz_data,CS%num_col_v), source=0.0) + do col=1,CS%num_col_v + do k=1,CS%nz_data + CS%Ref_val_v%p(k,col) = scale_fac*v_val(CS%col_i_v(col),CS%col_j_v(col),k) + enddo + enddo + CS%var_v%p => v_ptr + +end subroutine set_up_ALE_sponge_vel_field_fixed + +!> This subroutine stores the reference profile at u and v points for the variable +!! whose address is given by u_ptr and v_ptr. +subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename_v, fieldname_v, & + Time, G, GV, US, CS, u_ptr, v_ptr, scale) + character(len=*), intent(in) :: filename_u !< File name for u field + character(len=*), intent(in) :: fieldname_u !< Name of u variable in file + character(len=*), intent(in) :: filename_v !< File name for v field + character(len=*), intent(in) :: fieldname_v !< Name of v variable in file + type(time_type), intent(in) :: Time !< Model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid (in) + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). + real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_ptr !< u-field to be damped [L T-1 ~> m s-1] + real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_ptr !< v-field to be damped [L T-1 ~> m s-1] + real, optional, intent(in) :: scale !< A factor by which to rescale the input data, including any + !! contributions due to dimensional rescaling, often in + !! [L s T-1 m-1 ~> 1]. For varying velocities the + !! default is the same as using US%m_s_to_L_T. + + ! Local variables + logical :: override + integer :: isd, ied, jsd, jed + integer :: isdB, iedB, jsdB, jedB + integer, dimension(4) :: fld_sz + if (.not.associated(CS)) return + + override =.true. + + isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed + isdB = G%isdB; iedB = G%iedB; jsdB = G%jsdB; jedB = G%jedB + ! get a unique id for this field which will allow us to return an array + ! containing time-interpolated values from an external file corresponding + ! to the current model date. + if (CS%spongeDataOngrid) then + CS%Ref_val_u%field = init_external_field(filename_u, fieldname_u, domain=G%Domain%mpp_domain) + else + CS%Ref_val_u%field = init_external_field(filename_u, fieldname_u) + endif + fld_sz(1:4) = -1 + call get_external_field_info(CS%Ref_val_u%field, size=fld_sz) + CS%Ref_val_u%nz_data = fld_sz(3) + CS%Ref_val_u%num_tlevs = fld_sz(4) + CS%Ref_val_u%scale = US%m_s_to_L_T ; if (present(scale)) CS%Ref_val_u%scale = scale + + if (CS%spongeDataOngrid) then + CS%Ref_val_v%field = init_external_field(filename_v, fieldname_v, domain=G%Domain%mpp_domain) + else + CS%Ref_val_v%field = init_external_field(filename_v, fieldname_v) + endif + fld_sz(1:4) = -1 + call get_external_field_info(CS%Ref_val_v%field, size=fld_sz) + CS%Ref_val_v%nz_data = fld_sz(3) + CS%Ref_val_v%num_tlevs = fld_sz(4) + CS%Ref_val_v%scale = US%m_s_to_L_T ; if (present(scale)) CS%Ref_val_v%scale = scale + + ! stores the reference profile + allocate(CS%Ref_val_u%p(fld_sz(3),CS%num_col_u), source=0.0) + allocate(CS%Ref_val_u%dz(fld_sz(3),CS%num_col_u), source=0.0) + CS%var_u%p => u_ptr + allocate(CS%Ref_val_v%p(fld_sz(3),CS%num_col_v), source=0.0) + allocate(CS%Ref_val_v%dz(fld_sz(3),CS%num_col_v), source=0.0) + CS%var_v%p => v_ptr + +end subroutine set_up_ALE_sponge_vel_field_varying + +!> This subroutine applies damping to the layers thicknesses, temp, salt and a variety of tracers +!! for every column where there is damping. +subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure (in). + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] (in) + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. + type(ALE_sponge_CS), pointer :: CS !< A pointer to the control structure for this module + !! that is set by a previous call to initialize_ALE_sponge (in). + type(time_type), intent(in) :: Time !< The current model date + + ! Local variables + real :: damp ! The timestep times the local damping coefficient [nondim]. + real :: I1pdamp ! I1pdamp is 1/(1 + damp). [nondim]. + real, allocatable, dimension(:) :: tmp_val2 ! data values on the original grid [various] + real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid [various] + real, dimension(SZK_(GV)) :: dz_col ! A column of thicknesses at h, u or v points [Z ~> m] + real, allocatable, dimension(:,:,:) :: sp_val ! A temporary array for fields [various] + real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts [nondim] + real, allocatable, dimension(:,:,:) :: mask_u ! A temporary array for field mask at u pts [nondim] + real, allocatable, dimension(:,:,:) :: mask_v ! A temporary array for field mask at v pts [nondim] + real, allocatable, dimension(:,:,:) :: tmp !< A temporary array for thermodynamic sponge tendency + !! diagnostics [various] then in [various T-1 ~> various s-1] + real, allocatable, dimension(:,:,:) :: tmp_u !< A temporary array for u sponge acceleration diagnostics + !! first in [L T-1 ~> m s-1] then in [L T-2 ~> m s-2] + real, allocatable, dimension(:,:,:) :: tmp_v !< A temporary array for v sponge acceleration diagnostics + !! first in [L T-1 ~> m s-1] then in [L T-2 ~> m s-2] + real, dimension(:), allocatable :: dz_src ! Source thicknesses [Z ~> m]. + real :: dz_model(SZI_(G),SZJ_(G),SZK_(GV)) ! Vertical distance across model layers [Z ~> m] + + ! Local variables for ALE remapping + real, dimension(:), allocatable :: tmpT1d ! A temporary variable for ALE remapping [various] + integer :: c, m, i, j, k, is, ie, js, je, nz, nz_data + real, allocatable, dimension(:), target :: z_in ! The depths (positive downward) in the input file [Z ~> m] + real, allocatable, dimension(:), target :: z_edges_in ! The depths (positive downward) of the + ! edges in the input file [Z ~> m] + real :: missing_value ! The missing value in the input data field [various] + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: dz_neglect, dz_neglect_edge ! Negligible layer extents [Z ~> m] + real :: zTopOfCell, zBottomOfCell ! Interface heights (positive upward) in the input dataset [Z ~> m]. + real :: sp_val_u ! Interpolation of sp_val to u-points, often a velocity in [L T-1 ~> m s-1] + real :: sp_val_v ! Interpolation of sp_val to v-points, often a velocity in [L T-1 ~> m s-1] + integer :: nPoints + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (.not.associated(CS)) return + + Idt = 1.0/dt + + if (CS%remap_answer_date >= 20190101) then + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + elseif (GV%Boussinesq) then + dz_neglect = US%m_to_Z*1.0e-30 ; dz_neglect_edge = US%m_to_Z*1.0e-10 + elseif (GV%semi_Boussinesq) then + dz_neglect = GV%kg_m2_to_H*GV%H_to_Z*1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z*1.0e-10 + else + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + endif + + if (CS%time_varying_sponges) then + do m=1,CS%fldno + nz_data = CS%Ref_val(m)%nz_data + call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%field, Time, G, sp_val, & + mask_z, z_in, z_edges_in, missing_value, & + scale=CS%Ref_val(m)%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & + answer_date=CS%hor_regrid_answer_date) + allocate( dz_src(nz_data) ) + allocate( tmpT1d(nz_data) ) + do c=1,CS%num_col + ! Set i and j to the structured indices of column c. + i = CS%col_i(c) ; j = CS%col_j(c) + CS%Ref_val(m)%p(1:nz_data,c) = sp_val(i,j,1:nz_data) + ! Build the source grid + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; dz_src(:) = 0.0 ; tmpT1d(:) = -99.9 + do k=1,nz_data + if (mask_z(CS%col_i(c),CS%col_j(c),k) == 1.0) then + zBottomOfCell = -min( z_edges_in(k+1) - G%Z_ref, G%bathyT(CS%col_i(c),CS%col_j(c)) ) + tmpT1d(k) = sp_val(CS%col_i(c),CS%col_j(c),k) + elseif (k>1) then + zBottomOfCell = -G%bathyT(CS%col_i(c),CS%col_j(c)) + tmpT1d(k) = tmpT1d(k-1) + else ! This next block should only ever be reached over land + tmpT1d(k) = -99.9 + endif + dz_src(k) = zTopOfCell - zBottomOfCell + if (dz_src(k) > 0.) nPoints = nPoints + 1 + zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k + enddo + ! In case data is deeper than model + dz_src(nz_data) = dz_src(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(c),CS%col_j(c)) ) + CS%Ref_val(m)%dz(1:nz_data,c) = dz_src(1:nz_data) + CS%Ref_val(m)%p(1:nz_data,c) = tmpT1d(1:nz_data) + do k=2,nz_data + if (CS%Ref_val(m)%dz(k,c) <= CS%varying_input_dz_mask) & + ! some confusion here about why the masks are not correct returning from horiz_interp + ! reverting to using a minimum thickness criteria + CS%Ref_val(m)%p(k,c) = CS%Ref_val(m)%p(k-1,c) + enddo + enddo + deallocate(sp_val, mask_z, dz_src, tmpT1d) + enddo + endif + + tmp_val1(:) = 0.0 ; dz_col(:) = 0.0 + do m=1,CS%fldno + nz_data = CS%Ref_val(m)%nz_data + allocate(tmp_val2(CS%Ref_val(m)%nz_data)) + if (CS%id_sp_tendency(m) > 0) then + allocate(tmp(G%isd:G%ied,G%jsd:G%jed,nz), source=0.0) + endif + do c=1,CS%num_col + ! Set i and j to the structured indices of column c. + i = CS%col_i(c) ; j = CS%col_j(c) + damp = dt * CS%Iresttime_col(c) + I1pdamp = 1.0 / (1.0 + damp) + tmp_val2(1:nz_data) = CS%Ref_val(m)%p(1:nz_data,c) + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do k=1,nz + dz_col(k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo + else + do k=1,nz + dz_col(k) = GV%H_to_Z * h(i,j,k) + enddo + endif + if (CS%time_varying_sponges) then + + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val(m)%dz(1:nz_data,c), tmp_val2, & + CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + else + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_dz%p(1:nz_data,c), tmp_val2, & + CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + endif + !Backward Euler method + if (CS%id_sp_tendency(m) > 0) tmp(i,j,1:nz) = CS%var(m)%p(i,j,1:nz) + CS%var(m)%p(i,j,1:nz) = I1pdamp * (CS%var(m)%p(i,j,1:nz) + tmp_val1(1:nz) * damp) + if (CS%id_sp_tendency(m) > 0) & + tmp(i,j,1:CS%nz) = Idt*(CS%var(m)%p(i,j,1:nz) - tmp(i,j,1:nz)) + enddo + + if (CS%id_sp_tendency(m) > 0) then + call post_data(CS%id_sp_tendency(m), tmp, CS%diag) + deallocate(tmp) + endif + deallocate(tmp_val2) + enddo + + if (CS%sponge_uv) then + + if (CS%time_varying_sponges) then + nz_data = CS%Ref_val_u%nz_data + ! Interpolate from the external horizontal grid and in time + call horiz_interp_and_extrap_tracer(CS%Ref_val_u%field, Time, G, sp_val, & + mask_z, z_in, z_edges_in, missing_value, & + scale=CS%Ref_val_u%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & + answer_date=CS%hor_regrid_answer_date) + + ! Initialize mask_z halos to zero before pass_var, in case of no update + mask_z(G%isc-1, G%jsc:G%jec, :) = 0. + mask_z(G%iec+1, G%jsc:G%jec, :) = 0. + call pass_var(sp_val, G%Domain, To_All+Omit_Corners, halo=1) + call pass_var(mask_z, G%Domain, To_All+Omit_Corners, halo=1) + + allocate(mask_u(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) + do j=G%jsc,G%jec; do I=G%iscB,G%iecB + mask_u(I,j,1:nz_data) = min(mask_z(i,j,1:nz_data),mask_z(i+1,j,1:nz_data)) + enddo ; enddo + + allocate( dz_src(nz_data) ) + do c=1,CS%num_col_u + ! Set i and j to the structured indices of column c. + i = CS%col_i_u(c) ; j = CS%col_j_u(c) + if (mask_u(i,j,1) == 1.0) then + do k=1,nz_data + sp_val_u = 0.5 * (sp_val(i,j,k) + sp_val(i+1,j,k)) + CS%Ref_val_u%p(k,c) = sp_val_u + enddo + else + CS%Ref_val_u%p(1:nz_data,c) = 0.0 + endif + ! Build the source grid + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; dz_src(:) = 0.0 + do k=1,nz_data + if (mask_u(i,j,k) == 1.0) then + zBottomOfCell = -min( z_edges_in(k+1) - G%Z_ref, G%bathyT(i,j) ) + elseif (k>1) then + zBottomOfCell = -G%bathyT(i,j) + else ! This next block should only ever be reached over land + endif + dz_src(k) = zTopOfCell - zBottomOfCell + if (dz_src(k) > 0.) nPoints = nPoints + 1 + zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k + enddo + ! In case data is deeper than model + dz_src(nz_data) = dz_src(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) + CS%Ref_val_u%dz(1:nz_data,c) = dz_src(1:nz_data) + enddo + deallocate(sp_val, mask_u, mask_z, dz_src) + nz_data = CS%Ref_val_v%nz_data + ! Interpolate from the external horizontal grid and in time + call horiz_interp_and_extrap_tracer(CS%Ref_val_v%field, Time, G, sp_val, & + mask_z, z_in, z_edges_in, missing_value, & + scale=CS%Ref_val_v%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& + answer_date=CS%hor_regrid_answer_date) + ! Initialize mask_z halos to zero before pass_var, in case of no update + mask_z(G%isc:G%iec, G%jsc-1, :) = 0. + mask_z(G%isc:G%iec, G%jec+1, :) = 0. + call pass_var(sp_val, G%Domain, To_All+Omit_Corners, halo=1) + call pass_var(mask_z, G%Domain, To_All+Omit_Corners, halo=1) + + allocate(mask_v(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) + do J=G%jscB,G%jecB; do i=G%isc,G%iec + mask_v(i,J,1:nz_data) = min(mask_z(i,j,1:nz_data),mask_z(i,j+1,1:nz_data)) + enddo ; enddo + + allocate( dz_src(nz_data) ) + do c=1,CS%num_col_v + ! Set i and j to the structured indices of column c. + i = CS%col_i_v(c) ; j = CS%col_j_v(c) + if (mask_v(i,j,1) == 1.0) then + do k=1,nz_data + sp_val_v = 0.5 * (sp_val(i,j,k) + sp_val(i,j+1,k)) + CS%Ref_val_v%p(k,c) = sp_val_v + enddo + else + CS%Ref_val_v%p(1:nz_data,c) = 0.0 + endif + ! Build the source grid + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; dz_src(:) = 0.0 + do k=1,nz_data + if (mask_v(i,j,k) == 1.0) then + zBottomOfCell = -min( z_edges_in(k+1) - G%Z_ref, G%bathyT(i,j) ) + elseif (k>1) then + zBottomOfCell = -G%bathyT(i,j) + else ! This next block should only ever be reached over land + endif + dz_src(k) = zTopOfCell - zBottomOfCell + if (dz_src(k) > 0.) nPoints = nPoints + 1 + zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k + enddo + ! In case data is deeper than model + dz_src(nz_data) = dz_src(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) + CS%Ref_val_v%dz(1:nz_data,c) = dz_src(1:nz_data) + enddo + deallocate(sp_val, mask_v, mask_z, dz_src) + endif + + ! Because we can not be certain whether there are velocity points at the processor + ! boundaries, and the thicknesses might not have been updated there, we need to + ! calculate the tracer point layer vertical extents and then do a halo update. + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do k=1,nz ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + dz_model(i,j,k) = GV%H_to_RZ * (h(i,j,k)*tv%SpV_avg(i,j,k)) + enddo ; enddo ; enddo + else + do k=1,nz ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + dz_model(i,j,k) = GV%H_to_Z * h(i,j,k) + enddo ; enddo ; enddo + endif + call pass_var(dz_model, G%Domain, To_All+Omit_Corners, halo=1) + + nz_data = CS%Ref_val_u%nz_data + allocate(tmp_val2(nz_data)) + if (CS%id_sp_u_tendency > 0) then + allocate(tmp_u(G%isdB:G%iedB,G%jsd:G%jed,nz), source=0.0) + endif + ! u points + do c=1,CS%num_col_u + I = CS%col_i_u(c) ; j = CS%col_j_u(c) + damp = dt * CS%Iresttime_col_u(c) + I1pdamp = 1.0 / (1.0 + damp) + tmp_val2(1:nz_data) = CS%Ref_val_u%p(1:nz_data,c) + do k=1,nz + dz_col(k) = 0.5 * (dz_model(i,j,k) + dz_model(i+1,j,k)) + enddo + if (CS%time_varying_sponges) then + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_u%dz(1:nz_data,c), tmp_val2, & + CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + else + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_dzu%p(1:nz_data,c), tmp_val2, & + CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + endif + if (CS%id_sp_u_tendency > 0) tmp_u(i,j,1:nz) = CS%var_u%p(i,j,1:nz) + !Backward Euler method + CS%var_u%p(i,j,1:nz) = I1pdamp * (CS%var_u%p(i,j,1:nz) + tmp_val1 * damp) + if (CS%id_sp_u_tendency > 0) tmp_u(i,j,1:nz) = Idt*(CS%var_u%p(i,j,1:nz) - tmp_u(i,j,1:nz)) + enddo + deallocate(tmp_val2) + if (CS%id_sp_u_tendency > 0) then + call post_data(CS%id_sp_u_tendency, tmp_u, CS%diag) + deallocate(tmp_u) + endif + ! v points + if (CS%id_sp_v_tendency > 0) then + allocate(tmp_v(G%isd:G%ied,G%jsdB:G%jedB,nz), source=0.0) + endif + nz_data = CS%Ref_val_v%nz_data + allocate(tmp_val2(nz_data)) + + do c=1,CS%num_col_v + i = CS%col_i_v(c) ; j = CS%col_j_v(c) + damp = dt * CS%Iresttime_col_v(c) + I1pdamp = 1.0 / (1.0 + damp) + if (CS%time_varying_sponges) nz_data = CS%Ref_val_v%nz_data + tmp_val2(1:nz_data) = CS%Ref_val_v%p(1:nz_data,c) + do k=1,nz + dz_col(k) = 0.5 * (dz_model(i,j,k) + dz_model(i,j+1,k)) + enddo + if (CS%time_varying_sponges) then + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_v%dz(1:nz_data,c), tmp_val2, & + CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + else + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_dzv%p(1:nz_data,c), tmp_val2, & + CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) + endif + if (CS%id_sp_v_tendency > 0) tmp_v(i,j,1:nz) = CS%var_v%p(i,j,1:nz) + !Backward Euler method + CS%var_v%p(i,j,1:nz) = I1pdamp * (CS%var_v%p(i,j,1:nz) + tmp_val1 * damp) + if (CS%id_sp_v_tendency > 0) tmp_v(i,j,1:nz) = Idt*(CS%var_v%p(i,j,1:nz) - tmp_v(i,j,1:nz)) + enddo + if (CS%id_sp_v_tendency > 0) then + call post_data(CS%id_sp_v_tendency, tmp_v, CS%diag) + deallocate(tmp_v) + endif + deallocate(tmp_val2) + endif + +end subroutine apply_ALE_sponge + +!> Rotate the ALE sponge fields from the input to the model index map. +subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, US, turns, param_file) + type(ALE_sponge_CS), intent(in) :: sponge_in !< The control structure for this module with the + !! original grid rotation + type(ocean_grid_type), intent(in) :: G_in !< The ocean's grid structure with the original rotation. + type(ALE_sponge_CS), pointer :: sponge !< A pointer to the control that will be set up with + !! the new grid rotation + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure with the new rotation. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: turns !< The number of 90-degree turns between grids + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + + ! First part: Index construction + ! 1. Reconstruct Iresttime(:,:) from sponge_in + ! 2. rotate Iresttime(:,:) + ! 3. Call initialize_ALE_sponge using new grid and rotated Iresttime(:,:) + ! All the index adjustment should follow from the Iresttime rotation + + real, dimension(:,:), allocatable :: Iresttime_in ! Restoring rate on the input sponges [T-1 ~> s-1] + real, dimension(:,:), allocatable :: Iresttime ! Restoring rate on the output sponges [T-1 ~> s-1] + real, dimension(:,:,:), allocatable :: data_dz_in ! Grid for the input sponges [Z ~> m] + real, dimension(:,:,:), allocatable :: data_dz ! Grid for the output sponges [Z ~> m] + real, dimension(:,:,:), allocatable :: sp_val_in ! Target data for the input sponges [various] + real, dimension(:,:,:), allocatable :: sp_val ! Target data for the output sponges [various] + real, dimension(:,:,:), pointer :: sp_ptr => NULL() ! Target data for the input sponges [various] + integer :: c, c_i, c_j + integer :: k, nz_data + integer :: n + logical :: fixed_sponge + + fixed_sponge = .not. sponge_in%time_varying_sponges + ! NOTE: nz_data is only conditionally set when fixed_sponge is true. + + allocate(Iresttime_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) + allocate(Iresttime(G%isd:G%ied, G%jsd:G%jed)) + + if (fixed_sponge) then + nz_data = sponge_in%nz_data + allocate(data_dz_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data), source=0.0) + allocate(data_dz(G%isd:G%ied, G%jsd:G%jed, nz_data)) + endif + + ! Re-populate the 2D Iresttime and data_dz arrays on the original grid + do c=1,sponge_in%num_col + c_i = sponge_in%col_i(c) + c_j = sponge_in%col_j(c) + Iresttime_in(c_i, c_j) = sponge_in%Iresttime_col(c) + if (fixed_sponge) then + do k = 1, nz_data + data_dz_in(c_i, c_j, k) = sponge_in%Ref_dz%p(k,c) + enddo + endif + enddo + + call rotate_array(Iresttime_in, turns, Iresttime) + if (fixed_sponge) then + call rotate_array(data_dz_in, turns, data_dz) + call initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, sponge, & + data_dz, nz_data, data_h_is_Z=.true.) + else + call initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, sponge) + endif + + deallocate(Iresttime_in) + deallocate(Iresttime) + if (fixed_sponge) then + deallocate(data_dz_in) + deallocate(data_dz) + endif + + ! Second part: Provide rotated fields for which relaxation is applied + + sponge%fldno = sponge_in%fldno + + if (fixed_sponge) then + allocate(sp_val_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data)) + allocate(sp_val(G%isd:G%ied, G%jsd:G%jed, nz_data)) + endif + + do n=1,sponge_in%fldno + ! Assume that tracers are pointers and are remapped in other functions(?) + sp_ptr => sponge_in%var(n)%p + if (fixed_sponge) then + sp_val_in(:,:,:) = 0.0 + do c = 1, sponge_in%num_col + c_i = sponge_in%col_i(c) + c_j = sponge_in%col_j(c) + do k = 1, nz_data + sp_val_in(c_i, c_j, k) = sponge_in%Ref_val(n)%p(k,c) + enddo + enddo + + call rotate_array(sp_val_in, turns, sp_val) + + ! NOTE: This points sp_val with the unrotated field. See note below. + call set_up_ALE_sponge_field(sp_val, G, GV, sp_ptr, sponge, & + sponge_in%Ref_val(n)%name, sp_long_name=sponge_in%Ref_val(n)%long_name, & + sp_unit=sponge_in%Ref_val(n)%unit) + + deallocate(sp_val_in) + else + ! We don't want to repeat FMS init in set_up_ALE_sponge_field_varying() + ! (time_interp_external_init, init_external_field, etc), so we manually + ! do a portion of this function below. + sponge%Ref_val(n)%field = sponge_in%Ref_val(n)%field + sponge%Ref_val(n)%num_tlevs = sponge_in%Ref_val(n)%num_tlevs + + nz_data = sponge_in%Ref_val(n)%nz_data + sponge%Ref_val(n)%nz_data = nz_data + + allocate(sponge%Ref_val(n)%p(nz_data, sponge_in%num_col), source=0.0) + allocate(sponge%Ref_val(n)%dz(nz_data, sponge_in%num_col), source=0.0) + + ! TODO: There is currently no way to associate a generic field pointer to + ! its rotated equivalent without introducing a new data structure which + ! explicitly tracks the pairing. + ! + ! As a temporary fix, we store the pointer to the unrotated field in + ! the rotated sponge, and use this reference to replace the pointer + ! to the rotated field update_ALE_sponge field. + ! + ! This makes a lot of unverifiable assumptions, and should not be + ! considered the final solution. + sponge%var(n)%p => sp_ptr + endif + enddo + + ! TODO: var_u and var_v sponge damping is not yet supported. + if (associated(sponge_in%var_u%p) .or. associated(sponge_in%var_v%p)) & + call MOM_error(FATAL, "Rotation of ALE sponge velocities is not yet " & + // "implemented.") + + ! Transfer any existing diag_CS reference pointer + sponge%diag => sponge_in%diag + + ! NOTE: initialize_ALE_sponge_* resolves remap_cs +end subroutine rotate_ALE_sponge + + +!> Scan the ALE sponge variables and replace a prescribed pointer to a new value. +! TODO: This function solely exists to replace field pointers in the sponge +! after rotation. This function is part of a temporary solution until +! something more robust is developed. +subroutine update_ALE_sponge_field(sponge, p_old, G, GV, p_new) + type(ALE_sponge_CS), intent(inout) :: sponge !< ALE sponge control struct + real, dimension(:,:,:), & + target, intent(in) :: p_old !< The previous array of target values [various] + type(ocean_grid_type), intent(in) :: G !< The updated ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + target, intent(in) :: p_new !< The new array of target values [various] + + integer :: n + + do n=1,sponge%fldno + if (associated(sponge%var(n)%p, p_old)) sponge%var(n)%p => p_new + enddo +end subroutine update_ALE_sponge_field + + +! GMM: I could not find where sponge_end is being called, but I am keeping +! ALE_sponge_end here so we can add that if needed. +!> This subroutine deallocates any memory associated with the ALE_sponge module. +subroutine ALE_sponge_end(CS) + type(ALE_sponge_CS), pointer :: CS !< A pointer to the control structure that is + !! set by a previous call to initialize_ALE_sponge. + + integer :: m + + if (.not.associated(CS)) return + + if (allocated(CS%col_i)) deallocate(CS%col_i) + if (allocated(CS%col_i_u)) deallocate(CS%col_i_u) + if (allocated(CS%col_i_v)) deallocate(CS%col_i_v) + if (allocated(CS%col_j)) deallocate(CS%col_j) + if (allocated(CS%col_j_u)) deallocate(CS%col_j_u) + if (allocated(CS%col_j_v)) deallocate(CS%col_j_v) + + if (allocated(CS%Iresttime_col)) deallocate(CS%Iresttime_col) + if (allocated(CS%Iresttime_col_u)) deallocate(CS%Iresttime_col_u) + if (allocated(CS%Iresttime_col_v)) deallocate(CS%Iresttime_col_v) + + do m=1,CS%fldno + if (associated(CS%Ref_val(m)%p)) deallocate(CS%Ref_val(m)%p) + enddo + + deallocate(CS) + +end subroutine ALE_sponge_end + +end module MOM_ALE_sponge diff --git a/parameterizations/vertical/MOM_CVMix_KPP.F90 b/parameterizations/vertical/MOM_CVMix_KPP.F90 new file mode 100644 index 0000000000..8e95edd563 --- /dev/null +++ b/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -0,0 +1,1556 @@ +!> Provides the K-Profile Parameterization (KPP) of Large et al., 1994, via CVMix. +module MOM_CVMix_KPP + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : max_across_PEs +use MOM_debugging, only : hchksum, is_NaN +use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_ptr, post_data +use MOM_diag_mediator, only : query_averaging_enabled, register_diag_field +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_PE +use MOM_EOS, only : EOS_type, calculate_density +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_grid, only : ocean_grid_type, isPointInCell +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number, get_wave_method +use MOM_domains, only : pass_var +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_tracer_types, only : tracer_type + +use CVMix_kpp, only : CVMix_init_kpp, CVMix_put_kpp, CVMix_get_kpp_real +use CVMix_kpp, only : CVMix_coeffs_kpp +use CVMix_kpp, only : CVMix_kpp_compute_OBL_depth +use CVMix_kpp, only : CVMix_kpp_compute_turbulent_scales +use CVMix_kpp, only : CVMix_kpp_compute_bulk_Richardson +use CVMix_kpp, only : CVMix_kpp_compute_unresolved_shear +use CVMix_kpp, only : CVMix_kpp_params_type +use CVMix_kpp, only : CVMix_kpp_compute_kOBL_depth + +implicit none ; private + +#include "MOM_memory.h" + +public :: KPP_init +public :: KPP_compute_BLD +public :: KPP_calculate +public :: KPP_end +public :: KPP_NonLocalTransport_temp +public :: KPP_NonLocalTransport_saln +public :: KPP_NonLocalTransport +public :: KPP_get_BLD + +! Enumerated constants +integer, private, parameter :: NLT_SHAPE_CVMix = 0 !< Use the CVMix profile +integer, private, parameter :: NLT_SHAPE_LINEAR = 1 !< Linear, \f$ G(\sigma) = 1-\sigma \f$ +integer, private, parameter :: NLT_SHAPE_PARABOLIC = 2 !< Parabolic, \f$ G(\sigma) = (1-\sigma)^2 \f$ +integer, private, parameter :: NLT_SHAPE_CUBIC = 3 !< Cubic, \f$ G(\sigma) = 1 + (2\sigma-3) \sigma^2\f$ +integer, private, parameter :: NLT_SHAPE_CUBIC_LMD = 4 !< Original shape, + !! \f$ G(\sigma) = \frac{27}{4} \sigma (1-\sigma)^2 \f$ + +integer, private, parameter :: SW_METHOD_ALL_SW = 0 !< Use all shortwave radiation +integer, private, parameter :: SW_METHOD_MXL_SW = 1 !< Use shortwave radiation absorbed in mixing layer +integer, private, parameter :: SW_METHOD_LV1_SW = 2 !< Use shortwave radiation absorbed in layer 1 +integer, private, parameter :: LT_K_CONSTANT = 1, & !< Constant enhance K through column + LT_K_SCALED = 2, & !< Enhance K scales with G(sigma) + LT_K_MODE_CONSTANT = 1, & !< Prescribed enhancement for K + LT_K_MODE_VR12 = 2, & !< Enhancement for K based on + !! Van Roekel et al., 2012 + LT_K_MODE_RW16 = 3, & !< Enhancement for K based on + !! Reichl et al., 2016 + LT_VT2_MODE_CONSTANT = 1, & !< Prescribed enhancement for Vt2 + LT_VT2_MODE_VR12 = 2, & !< Enhancement for Vt2 based on + !! Van Roekel et al., 2012 + LT_VT2_MODE_RW16 = 3, & !< Enhancement for Vt2 based on + !! Reichl et al., 2016 + LT_VT2_MODE_LF17 = 4 !< Enhancement for Vt2 based on + !! Li and Fox-Kemper, 2017 + +!> Control structure for containing KPP parameters/data +type, public :: KPP_CS ; private + + ! Parameters + real :: Ri_crit !< Critical bulk Richardson number (defines OBL depth) [nondim] + real :: vonKarman !< von Karman constant (dimensionless) [nondim] + real :: cs !< Parameter for computing velocity scale function (dimensionless) [nondim] + real :: cs2 !< Parameter for multiplying by non-local term [nondim] + ! This is active for NLT_SHAPE_CUBIC_LMD only + logical :: enhance_diffusion !< If True, add enhanced diffusivity at base of boundary layer. + character(len=32) :: interpType !< Type of interpolation to compute bulk Richardson number + character(len=32) :: interpType2 !< Type of interpolation to compute diff and visc at OBL_depth + logical :: computeEkman !< If True, compute Ekman depth limit for OBLdepth + logical :: computeMoninObukhov !< If True, compute Monin-Obukhov limit for OBLdepth + logical :: passiveMode !< If True, makes KPP passive meaning it does NOT alter the diffusivity + real :: deepOBLoffset !< If non-zero, is a distance from the bottom that the OBL can not + !! penetrate through [Z ~> m] + real :: minOBLdepth !< If non-zero, is a minimum depth for the OBL [Z ~> m] + real :: surf_layer_ext !< Fraction of OBL depth considered in the surface layer [nondim] + real :: minVtsqr !< Min for the squared unresolved velocity used in Rib CVMix + !! calculation [L2 T-2 ~> m2 s-2] + logical :: fixedOBLdepth !< If True, will fix the OBL depth at fixedOBLdepth_value + real :: fixedOBLdepth_value !< value for the fixed OBL depth when fixedOBLdepth==True [Z ~> m] + logical :: debug !< If True, calculate checksums and write debugging information + character(len=30) :: MatchTechnique !< Method used in CVMix for setting diffusivity and NLT profile functions + integer :: NLT_shape !< MOM6 over-ride of CVMix NLT shape function + logical :: applyNonLocalTrans !< If True, apply non-local transport to all tracers + integer :: n_smooth !< Number of times smoothing operator is applied on OBLdepth. + logical :: deepen_only !< If true, apply OBLdepth smoothing at a cell only if the OBLdepth gets deeper. + logical :: KPPzeroDiffusivity !< If True, will set diffusivity and viscosity from KPP to zero + !! for testing purposes. + logical :: KPPisAdditive !< If True, will add KPP diffusivity to initial diffusivity. + !! If False, will replace initial diffusivity wherever KPP diffusivity + !! is non-zero. + real :: min_thickness !< A minimum thickness used to avoid division by small numbers + !! in the vicinity of vanished layers [Z ~> m] + integer :: SW_METHOD !< Sets method for using shortwave radiation in surface buoyancy flux + logical :: LT_K_Enhancement !< Flags if enhancing mixing coefficients due to LT + integer :: LT_K_Shape !< Integer for constant or shape function enhancement + integer :: LT_K_Method !< Integer for mixing coefficients LT method + real :: KPP_K_ENH_FAC !< Factor to multiply by K if Method is CONSTANT [nondim] + logical :: LT_Vt2_Enhancement !< Flags if enhancing Vt2 due to LT + integer :: LT_VT2_METHOD !< Integer for Vt2 LT method + real :: KPP_VT2_ENH_FAC !< Factor to multiply by VT2 if Method is CONSTANT [nondim] + real :: MLD_guess_min !< The minimum estimate of the mixed layer depth used to + !! calculate the Langmuir number for Langmuir turbulence + !! enhancement with KPP [Z ~> m] + logical :: STOKES_MIXING !< Flag if model is mixing down Stokes gradient + !! This is relevant for which current to use in RiB + + !> CVMix parameters + type(CVMix_kpp_params_type), pointer :: KPP_params => NULL() + + type(diag_ctrl), pointer :: diag => NULL() !< Pointer to diagnostics control structure + !>@{ Diagnostic handles + integer :: id_OBLdepth = -1, id_BulkRi = -1 + integer :: id_N = -1, id_N2 = -1 + integer :: id_Ws = -1, id_Vt2 = -1 + integer :: id_BulkUz2 = -1, id_BulkDrho = -1 + integer :: id_uStar = -1, id_buoyFlux = -1 + integer :: id_sigma = -1, id_Kv_KPP = -1 + integer :: id_Kt_KPP = -1, id_Ks_KPP = -1 + integer :: id_Tsurf = -1, id_Ssurf = -1 + integer :: id_Usurf = -1, id_Vsurf = -1 + integer :: id_Kd_in = -1 + integer :: id_NLTt = -1 + integer :: id_NLTs = -1 + integer :: id_EnhK = -1, id_EnhVt2 = -1 + integer :: id_EnhW = -1 + integer :: id_La_SL = -1 + integer :: id_OBLdepth_original = -1 + !>@} + + ! Diagnostics arrays + real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of ocean boundary layer (OBL) [Z ~> m] + real, allocatable, dimension(:,:) :: OBLdepth_original !< Depth (positive) of OBL [Z ~> m] without smoothing + real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent [nondim] + real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL [Z ~> m] + real, allocatable, dimension(:,:) :: La_SL !< Langmuir number used in KPP [nondim] + real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density [R ~> kg m-3] + real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: BulkRi !< Bulk Richardson number for each layer [nondim] + real, allocatable, dimension(:,:,:) :: sigma !< Sigma coordinate (dimensionless) [nondim] + real, allocatable, dimension(:,:,:) :: Ws !< Turbulent velocity scale for scalars [Z T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: N !< Brunt-Vaisala frequency [T-1 ~> s-1] + real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [T-2 ~> s-2] + real, allocatable, dimension(:,:,:) :: Vt2 !< Unresolved squared turbulence velocity for + !! bulk Ri [Z2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: Kt_KPP !< Temp diffusivity from KPP [Z2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:,:) :: Ks_KPP !< Scalar diffusivity from KPP [Z2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:,:) :: Kv_KPP !< Viscosity due to KPP [Z2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:) :: Tsurf !< Temperature of surface layer [C ~> degC] + real, allocatable, dimension(:,:) :: Ssurf !< Salinity of surface layer [S ~> ppt] + real, allocatable, dimension(:,:) :: Usurf !< i-velocity of surface layer [L T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: Vsurf !< j-velocity of surface layer [L T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: EnhK !< Enhancement for mixing coefficient [nondim] + real, allocatable, dimension(:,:,:) :: EnhVt2 !< Enhancement for Vt2 [nondim] + +end type KPP_CS + +!>@{ CPU time clocks +integer :: id_clock_KPP_calc, id_clock_KPP_compute_BLD, id_clock_KPP_smoothing +!>@} + +#define __DO_SAFETY_CHECKS__ + +contains + +!> Initialize the CVMix KPP module and set up diagnostics +!! Returns True if KPP is to be used, False otherwise. +logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) + + ! Arguments + type(param_file_type), intent(in) :: paramFile !< File parser + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diag_ctrl), target, intent(in) :: diag !< Diagnostics + type(time_type), intent(in) :: Time !< Model time + type(KPP_CS), pointer :: CS !< Control structure + logical, optional, intent(out) :: passive !< Copy of %passiveMode + + ! Local variables +# include "version_variable.h" + character(len=40) :: mdl = 'MOM_CVMix_KPP' !< name of this module + character(len=20) :: string !< local temporary string + character(len=20) :: langmuir_mixing_opt = 'NONE' !< Langmuir mixing option to be passed to CVMix, e.g., LWF16 + character(len=20) :: langmuir_entrainment_opt = 'NONE' !< Langmuir entrainment option to be + !! passed to CVMix, e.g., LWF16 + logical :: CS_IS_ONE=.false. !< Logical for setting Cs based on Non-local + logical :: lnoDGat1=.false. !< True => G'(1) = 0 (shape function) + !! False => compute G'(1) as in LMD94 + if (associated(CS)) call MOM_error(FATAL, 'MOM_CVMix_KPP, KPP_init: '// & + 'Control structure has already been initialized') + + ! Read parameters + call get_param(paramFile, mdl, "USE_KPP", KPP_init, default=.false., do_not_log=.true.) + call log_version(paramFile, mdl, version, 'This is the MOM wrapper to CVMix:KPP\n' // & + 'See http://cvmix.github.io/', all_default=.not.KPP_init) + call get_param(paramFile, mdl, "USE_KPP", KPP_init, & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "// & + "to calculate diffusivities and non-local transport in the OBL.", & + default=.false.) + ! Forego remainder of initialization if not using this scheme + if (.not. KPP_init) return + allocate(CS) + + call openParameterBlock(paramFile,'KPP') + call get_param(paramFile, mdl, 'PASSIVE', CS%passiveMode, & + 'If True, puts KPP into a passive-diagnostic mode.', & + default=.False.) + !BGR: Note using PASSIVE for KPP creates warning for PASSIVE from Convection + ! should we create a separate flag? + if (present(passive)) passive=CS%passiveMode ! This is passed back to the caller so + ! the caller knows to not use KPP output + call get_param(paramFile, mdl, 'APPLY_NONLOCAL_TRANSPORT', CS%applyNonLocalTrans, & + 'If True, applies the non-local transport to all tracers. '// & + 'If False, calculates the non-local transport and tendencies but '//& + 'purely for diagnostic purposes.', & + default=.not. CS%passiveMode) + call get_param(paramFile, mdl, 'N_SMOOTH', CS%n_smooth, & + 'The number of times the 1-1-4-1-1 Laplacian filter is applied on OBL depth.', & + default=0) + if (CS%n_smooth > G%domain%nihalo) then + call MOM_error(FATAL,'KPP smoothing number (N_SMOOTH) cannot be greater than NIHALO.') + elseif (CS%n_smooth > G%domain%njhalo) then + call MOM_error(FATAL,'KPP smoothing number (N_SMOOTH) cannot be greater than NJHALO.') + endif + if (CS%n_smooth > 0) then + call get_param(paramFile, mdl, 'DEEPEN_ONLY_VIA_SMOOTHING', CS%deepen_only, & + 'If true, apply OBLdepth smoothing at a cell only if the OBLdepth '// & + 'gets deeper via smoothing.', & + default=.false.) + id_clock_KPP_smoothing = cpu_clock_id('(Ocean KPP BLD smoothing)', grain=CLOCK_ROUTINE) + endif + call get_param(paramFile, mdl, 'RI_CRIT', CS%Ri_crit, & + 'Critical bulk Richardson number used to define depth of the '// & + 'surface Ocean Boundary Layer (OBL).', & + units='nondim', default=0.3) + call get_param(paramFile, mdl, 'VON_KARMAN', CS%vonKarman, & + 'von Karman constant.', & + units='nondim', default=0.40) + call get_param(paramFile, mdl, 'ENHANCE_DIFFUSION', CS%enhance_diffusion, & + 'If True, adds enhanced diffusion at the based of the boundary layer.', & + default=.true.) + call get_param(paramFile, mdl, 'INTERP_TYPE', CS%interpType, & + 'Type of interpolation to determine the OBL depth.\n'// & + 'Allowed types are: linear, quadratic, cubic.', & + default='quadratic') + call get_param(paramFile, mdl, 'INTERP_TYPE2', CS%interpType2, & + 'Type of interpolation to compute diff and visc at OBL_depth.\n'// & + 'Allowed types are: linear, quadratic, cubic or LMD94.', & + default='LMD94') + call get_param(paramFile, mdl, 'COMPUTE_EKMAN', CS%computeEkman, & + 'If True, limit OBL depth to be no deeper than Ekman depth.', & + default=.False.) + call get_param(paramFile, mdl, 'COMPUTE_MONIN_OBUKHOV', CS%computeMoninObukhov, & + 'If True, limit the OBL depth to be no deeper than '// & + 'Monin-Obukhov depth.', & + default=.False.) + call get_param(paramFile, mdl, 'CS', CS%cs, & + 'Parameter for computing velocity scale function.', & + units='nondim', default=98.96) + call get_param(paramFile, mdl, 'CS2', CS%cs2, & + 'Parameter for computing non-local term.', & + units='nondim', default=6.32739901508) + call get_param(paramFile, mdl, 'DEEP_OBL_OFFSET', CS%deepOBLoffset, & + 'If non-zero, the distance above the bottom to which the OBL is clipped '// & + 'if it would otherwise reach the bottom. The smaller of this and 0.1D is used.', & + units='m', default=0., scale=US%m_to_Z) + call get_param(paramFile, mdl, 'FIXED_OBLDEPTH', CS%fixedOBLdepth, & + 'If True, fix the OBL depth to FIXED_OBLDEPTH_VALUE '// & + 'rather than using the OBL depth from CVMix. '// & + 'This option is just for testing purposes.', & + default=.False.) + call get_param(paramFile, mdl, 'FIXED_OBLDEPTH_VALUE', CS%fixedOBLdepth_value, & + 'Value for the fixed OBL depth when fixedOBLdepth==True. '// & + 'This parameter is for just for testing purposes. '// & + 'It will over-ride the OBLdepth computed from CVMix.', & + units='m', default=30.0, scale=US%m_to_Z) + call get_param(paramFile, mdl, 'SURF_LAYER_EXTENT', CS%surf_layer_ext, & + 'Fraction of OBL depth considered in the surface layer.', & + units='nondim', default=0.10) + call get_param(paramFile, mdl, 'MINIMUM_OBL_DEPTH', CS%minOBLdepth, & + 'If non-zero, a minimum depth to use for KPP OBL depth. Independent of '// & + 'this parameter, the OBL depth is always at least as deep as the first layer.', & + units='m', default=0., scale=US%m_to_Z) + call get_param(paramFile, mdl, 'MINIMUM_VT2', CS%minVtsqr, & + 'Min of the unresolved velocity Vt2 used in Rib CVMix calculation.\n'// & + 'Scaling: MINIMUM_VT2 = const1*d*N*ws, with d=1m, N=1e-5/s, ws=1e-6 m/s.', & + units='m2/s2', default=1e-10, scale=US%m_s_to_L_T**2) + + call get_param(paramFile, mdl, 'NLT_SHAPE', string, & + 'MOM6 method to set nonlocal transport profile. '// & + 'Over-rides the result from CVMix. Allowed values are: \n'// & + '\t CVMix - Uses the profiles from CVMix specified by MATCH_TECHNIQUE\n'//& + '\t LINEAR - A linear profile, 1-sigma\n'// & + '\t PARABOLIC - A parablic profile, (1-sigma)^2\n'// & + '\t CUBIC - A cubic profile, (1-sigma)^2(1+2*sigma)\n'// & + '\t CUBIC_LMD - The original KPP profile', & + default='CVMix') + select case ( trim(string) ) + case ("CVMix") ; CS%NLT_shape = NLT_SHAPE_CVMix + case ("LINEAR") ; CS%NLT_shape = NLT_SHAPE_LINEAR + case ("PARABOLIC") ; CS%NLT_shape = NLT_SHAPE_PARABOLIC + case ("CUBIC") ; CS%NLT_shape = NLT_SHAPE_CUBIC + case ("CUBIC_LMD") ; CS%NLT_shape = NLT_SHAPE_CUBIC_LMD + case default ; call MOM_error(FATAL,"KPP_init: "// & + "Unrecognized NLT_SHAPE option"//trim(string)) + end select + call get_param(paramFile, mdl, 'MATCH_TECHNIQUE', CS%MatchTechnique, & + 'CVMix method to set profile function for diffusivity and NLT, '// & + 'as well as matching across OBL base. Allowed values are: \n'// & + '\t SimpleShapes = sigma*(1-sigma)^2 for both diffusivity and NLT\n'// & + '\t MatchGradient = sigma*(1-sigma)^2 for NLT; diffusivity profile from matching\n'//& + '\t MatchBoth = match gradient for both diffusivity and NLT\n'// & + '\t ParabolicNonLocal = sigma*(1-sigma)^2 for diffusivity; (1-sigma)^2 for NLT', & + default='SimpleShapes') + if (CS%MatchTechnique == 'ParabolicNonLocal') then + ! This forces Cs2 (Cs in non-local computation) to equal 1 for parabolic non-local option. + ! May be used during CVMix initialization. + Cs_is_one=.true. + endif + if (CS%MatchTechnique == 'ParabolicNonLocal' .or. CS%MatchTechnique == 'SimpleShapes') then + ! if gradient won't be matched, lnoDGat1=.true. + lnoDGat1=.true. + endif + + ! safety check to avoid negative diff/visc + if (CS%MatchTechnique == 'MatchBoth' .and. (CS%interpType2 == 'cubic' .or. & + CS%interpType2 == 'quadratic')) then + call MOM_error(FATAL,"If MATCH_TECHNIQUE=MatchBoth, INTERP_TYPE2 must be set to \n"//& + "linear or LMD94 (recommended) to avoid negative viscosity and diffusivity.\n"//& + "Please select one of these valid options." ) + endif + + call get_param(paramFile, mdl, 'KPP_ZERO_DIFFUSIVITY', CS%KPPzeroDiffusivity, & + 'If True, zeroes the KPP diffusivity and viscosity; for testing purpose.',& + default=.False.) + call get_param(paramFile, mdl, 'KPP_IS_ADDITIVE', CS%KPPisAdditive, & + 'If true, adds KPP diffusivity to diffusivity from other schemes.\n'//& + 'If false, KPP is the only diffusivity wherever KPP is non-zero.', & + default=.True.) + call get_param(paramFile, mdl, 'KPP_SHORTWAVE_METHOD',string, & + 'Determines contribution of shortwave radiation to KPP surface '// & + 'buoyancy flux. Options include:\n'// & + ' ALL_SW: use total shortwave radiation\n'// & + ' MXL_SW: use shortwave radiation absorbed by mixing layer\n'// & + ' LV1_SW: use shortwave radiation absorbed by top model layer', & + default='MXL_SW') + select case ( trim(string) ) + case ("ALL_SW") ; CS%SW_METHOD = SW_METHOD_ALL_SW + case ("MXL_SW") ; CS%SW_METHOD = SW_METHOD_MXL_SW + case ("LV1_SW") ; CS%SW_METHOD = SW_METHOD_LV1_SW + case default ; call MOM_error(FATAL,"KPP_init: "// & + "Unrecognized KPP_SHORTWAVE_METHOD option"//trim(string)) + end select + call get_param(paramFile, mdl, 'CVMix_ZERO_H_WORK_AROUND', CS%min_thickness, & + 'A minimum thickness used to avoid division by small numbers in the vicinity '// & + 'of vanished layers. This is independent of MIN_THICKNESS used in other parts of MOM.', & + units='m', default=0., scale=US%m_to_Z) + +!/BGR: New options for including Langmuir effects +!/ 1. Options related to enhancing the mixing coefficient + call get_param(paramFile, mdl, "USE_KPP_LT_K", CS%LT_K_Enhancement, & + 'Flag for Langmuir turbulence enhancement of turbulent'//& + 'mixing coefficient.', Default=.false.) + call get_param(paramFile, mdl, "STOKES_MIXING", CS%Stokes_Mixing, & + 'Flag for Langmuir turbulence enhancement of turbulent'//& + 'mixing coefficient.', Default=.false.) + if (CS%LT_K_Enhancement) then + call get_param(paramFile, mdl, 'KPP_LT_K_SHAPE', string, & + 'Vertical dependence of LT enhancement of mixing. '// & + 'Valid options are: \n'// & + '\t CONSTANT = Constant value for full OBL\n'// & + '\t SCALED = Varies based on normalized shape function.', & + default='CONSTANT') + select case ( trim(string)) + case ("CONSTANT") ; CS%LT_K_SHAPE = LT_K_CONSTANT + case ("SCALED") ; CS%LT_K_SHAPE = LT_K_SCALED + case default ; call MOM_error(FATAL,"KPP_init: "//& + "Unrecognized KPP_LT_K_SHAPE option: "//trim(string)) + end select + call get_param(paramFile, mdl, "KPP_LT_K_METHOD", string , & + 'Method to enhance mixing coefficient in KPP. '// & + 'Valid options are: \n'// & + '\t CONSTANT = Constant value (KPP_K_ENH_FAC) \n'// & + '\t VR12 = Function of Langmuir number based on VR12\n'// & + '\t (Van Roekel et al. 2012)\n'// & + '\t (Li et al. 2016, OM) \n'// & + '\t RW16 = Function of Langmuir number based on RW16\n'// & + '\t (Reichl et al., 2016, JPO)', & + default='CONSTANT') + select case ( trim(string)) + case ("CONSTANT") + CS%LT_K_METHOD = LT_K_MODE_CONSTANT + langmuir_mixing_opt = 'LWF16' + case ("VR12") + CS%LT_K_METHOD = LT_K_MODE_VR12 + langmuir_mixing_opt = 'LWF16' + case ("RW16") + CS%LT_K_METHOD = LT_K_MODE_RW16 + langmuir_mixing_opt = 'RWHGK16' + case default + call MOM_error(FATAL,"KPP_init: "//& + "Unrecognized KPP_LT_K_METHOD option: "//trim(string)) + end select + if (CS%LT_K_METHOD==LT_K_MODE_CONSTANT) then + call get_param(paramFile, mdl, "KPP_K_ENH_FAC", CS%KPP_K_ENH_FAC, & + 'Constant value to enhance mixing coefficient in KPP.', & + units="nondim", default=1.0) + endif + endif +!/ 2. Options related to enhancing the unresolved Vt2/entrainment in Rib + call get_param(paramFile, mdl, "USE_KPP_LT_VT2", CS%LT_Vt2_Enhancement, & + 'Flag for Langmuir turbulence enhancement of Vt2'//& + 'in Bulk Richardson Number.', Default=.false.) + if (CS%LT_Vt2_Enhancement) then + call get_param(paramFile, mdl, "KPP_LT_VT2_METHOD",string , & + 'Method to enhance Vt2 in KPP. '// & + 'Valid options are: \n'// & + '\t CONSTANT = Constant value (KPP_VT2_ENH_FAC) \n'// & + '\t VR12 = Function of Langmuir number based on VR12\n'// & + '\t (Van Roekel et al., 2012) \n'// & + '\t (Li et al. 2016, OM) \n'// & + '\t RW16 = Function of Langmuir number based on RW16\n'// & + '\t (Reichl et al., 2016, JPO) \n'// & + '\t LF17 = Function of Langmuir number based on LF17\n'// & + '\t (Li and Fox-Kemper, 2017, JPO)', & + default='CONSTANT') + select case ( trim(string)) + case ("CONSTANT") + CS%LT_VT2_METHOD = LT_VT2_MODE_CONSTANT + langmuir_entrainment_opt = 'LWF16' + case ("VR12") + CS%LT_VT2_METHOD = LT_VT2_MODE_VR12 + langmuir_entrainment_opt = 'LWF16' + case ("RW16") + CS%LT_VT2_METHOD = LT_VT2_MODE_RW16 + langmuir_entrainment_opt = 'RWHGK16' + case ("LF17") + CS%LT_VT2_METHOD = LT_VT2_MODE_LF17 + langmuir_entrainment_opt = 'LF17' + case default + call MOM_error(FATAL,"KPP_init: "//& + "Unrecognized KPP_LT_VT2_METHOD option: "//trim(string)) + end select + if (CS%LT_VT2_METHOD==LT_VT2_MODE_CONSTANT) then + call get_param(paramFile, mdl, "KPP_VT2_ENH_FAC", CS%KPP_VT2_ENH_FAC, & + 'Constant value to enhance VT2 in KPP.', & + units="nondim", default=1.0) + endif + endif + + if (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) then + call get_param(paramFile, mdl, "KPP_LT_MLD_GUESS_MIN", CS%MLD_guess_min, & + "The minimum estimate of the mixed layer depth used to calculate "//& + "the Langmuir number for Langmuir turbulence enhancement with KPP.", & + units="m", default=1.0, scale=US%m_to_Z) + endif + + call closeParameterBlock(paramFile) + + call get_param(paramFile, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) + + call CVMix_init_kpp( Ri_crit=CS%Ri_crit, & + minOBLdepth=US%Z_to_m*CS%minOBLdepth, & + minVtsqr=US%L_T_to_m_s**2*CS%minVtsqr, & + vonKarman=CS%vonKarman, & + surf_layer_ext=CS%surf_layer_ext, & + interp_type=CS%interpType, & + interp_type2=CS%interpType2, & + lEkman=CS%computeEkman, & + lMonOb=CS%computeMoninObukhov, & + MatchTechnique=CS%MatchTechnique, & + lenhanced_diff=CS%enhance_diffusion,& + lnonzero_surf_nonlocal=Cs_is_one ,& + lnoDGat1=lnoDGat1 ,& + langmuir_mixing_str=langmuir_mixing_opt,& + langmuir_entrainment_str=langmuir_entrainment_opt,& + CVMix_kpp_params_user=CS%KPP_params ) + + ! Register diagnostics + CS%diag => diag + CS%id_OBLdepth = register_diag_field('ocean_model', 'KPP_OBLdepth', diag%axesT1, Time, & + 'Thickness of the surface Ocean Boundary Layer calculated by [CVMix] KPP', & + 'meter', conversion=US%Z_to_m, & + cmor_field_name='oml', cmor_long_name='ocean_mixed_layer_thickness_defined_by_mixing_scheme', & + cmor_units='m', cmor_standard_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') + ! CMOR names are placeholders; must be modified by time period + ! for CMOR compliance. Diag manager will be used for omlmax and + ! omldamax. + if (CS%n_smooth > 0) then + CS%id_OBLdepth_original = register_diag_field('ocean_model', 'KPP_OBLdepth_original', diag%axesT1, Time, & + 'Thickness of the surface Ocean Boundary Layer without smoothing calculated by [CVMix] KPP', & + 'meter', conversion=US%Z_to_m, & + cmor_field_name='oml', cmor_long_name='ocean_mixed_layer_thickness_defined_by_mixing_scheme', & + cmor_units='m', cmor_standard_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') + endif + CS%id_BulkDrho = register_diag_field('ocean_model', 'KPP_BulkDrho', diag%axesTL, Time, & + 'Bulk difference in density used in Bulk Richardson number, as used by [CVMix] KPP', & + 'kg/m3', conversion=US%R_to_kg_m3) + CS%id_BulkUz2 = register_diag_field('ocean_model', 'KPP_BulkUz2', diag%axesTL, Time, & + 'Square of bulk difference in resolved velocity used in Bulk Richardson number via [CVMix] KPP', & + 'm2/s2', conversion=US%L_T_to_m_s**2) + CS%id_BulkRi = register_diag_field('ocean_model', 'KPP_BulkRi', diag%axesTL, Time, & + 'Bulk Richardson number used to find the OBL depth used by [CVMix] KPP', 'nondim') + CS%id_Sigma = register_diag_field('ocean_model', 'KPP_sigma', diag%axesTi, Time, & + 'Sigma coordinate used by [CVMix] KPP', 'nondim') + CS%id_Ws = register_diag_field('ocean_model', 'KPP_Ws', diag%axesTL, Time, & + 'Turbulent vertical velocity scale for scalars used by [CVMix] KPP', & + 'm/s', conversion=US%Z_to_m*US%s_to_T) + CS%id_N = register_diag_field('ocean_model', 'KPP_N', diag%axesTi, Time, & + '(Adjusted) Brunt-Vaisala frequency used by [CVMix] KPP', '1/s', conversion=US%s_to_T) + CS%id_N2 = register_diag_field('ocean_model', 'KPP_N2', diag%axesTi, Time, & + 'Square of Brunt-Vaisala frequency used by [CVMix] KPP', '1/s2', conversion=US%s_to_T**2) + CS%id_Vt2 = register_diag_field('ocean_model', 'KPP_Vt2', diag%axesTL, Time, & + 'Unresolved shear turbulence used by [CVMix] KPP', 'm2/s2', conversion=US%Z_to_m**2*US%s_to_T**2) + CS%id_uStar = register_diag_field('ocean_model', 'KPP_uStar', diag%axesT1, Time, & + 'Friction velocity, u*, as used by [CVMix] KPP', 'm/s', conversion=US%Z_to_m*US%s_to_T) + CS%id_buoyFlux = register_diag_field('ocean_model', 'KPP_buoyFlux', diag%axesTi, Time, & + 'Surface (and penetrating) buoyancy flux, as used by [CVMix] KPP', & + 'm2/s3', conversion=US%L_to_m**2*US%s_to_T**3) + CS%id_Kt_KPP = register_diag_field('ocean_model', 'KPP_Kheat', diag%axesTi, Time, & + 'Heat diffusivity due to KPP, as calculated by [CVMix] KPP', & + 'm2/s', conversion=US%Z2_T_to_m2_s) + CS%id_Kd_in = register_diag_field('ocean_model', 'KPP_Kd_in', diag%axesTi, Time, & + 'Diffusivity passed to KPP', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Ks_KPP = register_diag_field('ocean_model', 'KPP_Ksalt', diag%axesTi, Time, & + 'Salt diffusivity due to KPP, as calculated by [CVMix] KPP', & + 'm2/s', conversion=US%Z2_T_to_m2_s) + CS%id_Kv_KPP = register_diag_field('ocean_model', 'KPP_Kv', diag%axesTi, Time, & + 'Vertical viscosity due to KPP, as calculated by [CVMix] KPP', & + 'm2/s', conversion=US%Z2_T_to_m2_s) + CS%id_NLTt = register_diag_field('ocean_model', 'KPP_NLtransport_heat', diag%axesTi, Time, & + 'Non-local transport (Cs*G(sigma)) for heat, as calculated by [CVMix] KPP', 'nondim') + CS%id_NLTs = register_diag_field('ocean_model', 'KPP_NLtransport_salt', diag%axesTi, Time, & + 'Non-local tranpsort (Cs*G(sigma)) for scalars, as calculated by [CVMix] KPP', 'nondim') + CS%id_Tsurf = register_diag_field('ocean_model', 'KPP_Tsurf', diag%axesT1, Time, & + 'Temperature of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & + 'C', conversion=US%C_to_degC) + CS%id_Ssurf = register_diag_field('ocean_model', 'KPP_Ssurf', diag%axesT1, Time, & + 'Salinity of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & + 'ppt', conversion=US%S_to_ppt) + CS%id_Usurf = register_diag_field('ocean_model', 'KPP_Usurf', diag%axesCu1, Time, & + 'i-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & + 'm/s', conversion=US%L_T_to_m_s) + CS%id_Vsurf = register_diag_field('ocean_model', 'KPP_Vsurf', diag%axesCv1, Time, & + 'j-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & + 'm/s', conversion=US%L_T_to_m_s) + CS%id_EnhK = register_diag_field('ocean_model', 'EnhK', diag%axesTI, Time, & + 'Langmuir number enhancement to K as used by [CVMix] KPP','nondim') + CS%id_EnhVt2 = register_diag_field('ocean_model', 'EnhVt2', diag%axesTL, Time, & + 'Langmuir number enhancement to Vt2 as used by [CVMix] KPP','nondim') + CS%id_La_SL = register_diag_field('ocean_model', 'KPP_La_SL', diag%axesT1, Time, & + 'Surface-layer Langmuir number computed in [CVMix] KPP','nondim') + + allocate( CS%N( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) + allocate( CS%OBLdepth( SZI_(G), SZJ_(G) ), source=0. ) + allocate( CS%kOBL( SZI_(G), SZJ_(G) ), source=0. ) + allocate( CS%La_SL( SZI_(G), SZJ_(G) ), source=0. ) + allocate( CS%Vt2( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) + if (CS%id_OBLdepth_original > 0) allocate( CS%OBLdepth_original( SZI_(G), SZJ_(G) ) ) + + allocate( CS%OBLdepthprev( SZI_(G), SZJ_(G) ), source=0.0 ) + if (CS%id_BulkDrho > 0) allocate( CS%dRho( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) + if (CS%id_BulkUz2 > 0) allocate( CS%Uz2( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) + if (CS%id_BulkRi > 0) allocate( CS%BulkRi( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) + if (CS%id_Sigma > 0) allocate( CS%sigma( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) + if (CS%id_Ws > 0) allocate( CS%Ws( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) + if (CS%id_N2 > 0) allocate( CS%N2( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) + if (CS%id_Kt_KPP > 0) allocate( CS%Kt_KPP( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) + if (CS%id_Ks_KPP > 0) allocate( CS%Ks_KPP( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) + if (CS%id_Kv_KPP > 0) allocate( CS%Kv_KPP( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) + if (CS%id_Tsurf > 0) allocate( CS%Tsurf( SZI_(G), SZJ_(G) ), source=0. ) + if (CS%id_Ssurf > 0) allocate( CS%Ssurf( SZI_(G), SZJ_(G) ), source=0. ) + if (CS%id_Usurf > 0) allocate( CS%Usurf( SZIB_(G), SZJ_(G) ), source=0. ) + if (CS%id_Vsurf > 0) allocate( CS%Vsurf( SZI_(G), SZJB_(G) ), source=0. ) + if (CS%id_EnhVt2 > 0) allocate( CS%EnhVt2( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) + if (CS%id_EnhK > 0) allocate( CS%EnhK( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) + + id_clock_KPP_calc = cpu_clock_id('Ocean KPP calculate)', grain=CLOCK_MODULE) + id_clock_KPP_compute_BLD = cpu_clock_id('(Ocean KPP comp BLD)', grain=CLOCK_ROUTINE) + +end function KPP_init + +!> KPP vertical diffusivity/viscosity and non-local tracer transport +subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & + nonLocalTransHeat, nonLocalTransScalar, Waves, lamult) + + ! Arguments + type(KPP_CS), pointer :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP + !! (out) Vertical diffusivity including KPP + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Ks !< (in) Vertical diffusivity of salt w/o KPP + !! (out) Vertical diffusivity including KPP + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP + !! (out) Vertical viscosity including KPP + !! [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local trans. [nondim] + type(wave_parameters_CS), pointer :: Waves !< Wave CS for Langmuir turbulence + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement multiplier [nondim] + + ! Local variables + integer :: i, j, k ! Loop indices + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] + real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [Z ~> m] (negative in ocean) + real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [Z ~> m] (negative in ocean) + real, dimension( GV%ke ) :: z_cell ! Cell center heights referenced to surface [m] (negative in ocean) + real, dimension( GV%ke+1 ) :: z_inter ! Cell interface heights referenced to surface [m] (negative in ocean) + real, dimension( GV%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces in MKS units [m2 s-1] + real, dimension( GV%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces in MKS units [m2 s-1] + real, dimension( GV%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces [nondim] + + real :: surfFricVel ! Surface friction velocity in MKS units [m s-1] + real :: surfBuoyFlux ! Surface buoyancy flux in MKS units [m2 s-3] + real :: sigma ! Fractional vertical position within the boundary layer [nondim] + real :: sigmaRatio ! A cubic function of sigma [nondim] + real :: buoy_scale ! A unit conversion factor for buoyancy fluxes [m2 T3 L-2 s-3 ~> 1] + real :: dh ! The local thickness used for calculating interface positions [Z ~> m] + real :: hcorr ! A cumulative correction arising from inflation of vanished layers [Z ~> m] + + ! For Langmuir Calculations + real :: LangEnhK ! Langmuir enhancement for mixing coefficient [nondim] + + if (CS%Stokes_Mixing .and. .not.associated(Waves)) call MOM_error(FATAL, & + "KPP_calculate: The Waves control structure must be associated if STOKES_MIXING is True.") + + if (CS%debug) then + call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0, scale=US%Z_to_m*US%s_to_T) + call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0, scale=US%L_to_m**2*US%s_to_T**3) + call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + + nonLocalTrans(:,:) = 0.0 + + if (CS%id_Kd_in > 0) call post_data(CS%id_Kd_in, Kt, CS%diag) + + call cpu_clock_begin(id_clock_KPP_calc) + buoy_scale = US%L_to_m**2*US%s_to_T**3 + + !$OMP parallel do default(none) firstprivate(nonLocalTrans) & + !$OMP private(surfFricVel, iFaceHeight, hcorr, dh, dz, cellHeight, & + !$OMP surfBuoyFlux, Kdiffusivity, Kviscosity, LangEnhK, sigma, & + !$OMP sigmaRatio, z_inter, z_cell) & + !$OMP shared(G, GV, CS, US, tv, uStar, h, buoy_scale, buoyFlux, Kt, & + !$OMP Ks, Kv, nonLocalTransHeat, nonLocalTransScalar, Waves, lamult) + ! loop over horizontal points on processor + do j = G%jsc, G%jec + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then + + ! things independent of position within the column + surfFricVel = US%Z_to_m*US%s_to_T * uStar(i,j) + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0. + do k=1,GV%ke + + ! cell center and cell bottom in meters (negative values in the ocean) + dh = dz(i,k) ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + + enddo ! k-loop finishes + + surfBuoyFlux = buoy_scale*buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit + ! h to Monin-Obukhov (default is false, ie. not used) + + ! Call CVMix/KPP to obtain OBL diffusivities, viscosities and non-local transports + + ! Unlike LMD94, we do not match to interior diffusivities. If using the original + ! LMD94 shape function, not matching is equivalent to matching to a zero diffusivity. + + !BGR/ Add option for use of surface buoyancy flux with total sw flux. + if (CS%SW_METHOD == SW_METHOD_ALL_SW) then + surfBuoyFlux = buoy_scale * buoyFlux(i,j,1) + elseif (CS%SW_METHOD == SW_METHOD_MXL_SW) then + ! We know the actual buoyancy flux into the OBL + surfBuoyFlux = buoy_scale * (buoyFlux(i,j,1) - buoyFlux(i,j,int(CS%kOBL(i,j))+1)) + elseif (CS%SW_METHOD == SW_METHOD_LV1_SW) then + surfBuoyFlux = buoy_scale * (buoyFlux(i,j,1) - buoyFlux(i,j,2)) + endif + + ! If option "MatchBoth" is selected in CVMix, MOM should be capable of matching. + if (.not. (CS%MatchTechnique == 'MatchBoth')) then + Kdiffusivity(:,:) = 0. ! Diffusivities for heat and salt [m2 s-1] + Kviscosity(:) = 0. ! Viscosity [m2 s-1] + else + Kdiffusivity(:,1) = GV%HZ_T_to_m2_s * Kt(i,j,:) + Kdiffusivity(:,2) = GV%HZ_T_to_m2_s * Ks(i,j,:) + Kviscosity(:) = GV%HZ_T_to_m2_s * Kv(i,j,:) + endif + + IF (CS%LT_K_ENHANCEMENT) then + if (CS%LT_K_METHOD==LT_K_MODE_CONSTANT) then + LangEnhK = CS%KPP_K_ENH_FAC + elseif (CS%LT_K_METHOD==LT_K_MODE_VR12) then + if (present(lamult)) then + LangEnhK = lamult(i,j) + else + LangEnhK = sqrt(1.+(1.5*CS%La_SL(i,j))**(-2) + & + (5.4*CS%La_SL(i,j))**(-4)) + endif + elseif (CS%LT_K_METHOD==LT_K_MODE_RW16) then + !This maximum value is proposed in Reichl et al., 2016 JPO formula + LangEnhK = min(2.25, 1. + 1./CS%La_SL(i,j)) + else + !This shouldn't be reached. + !call MOM_error(WARNING,"Unexpected behavior in MOM_CVMix_KPP, see error in LT_K_ENHANCEMENT") + LangEnhK = 1.0 + endif + + ! diffusivities don't need to be enhanced below anymore since LangEnhK is applied within CVMix. + ! todo: need to double check if the distinction between the two different options of LT_K_SHAPE may need to be + ! treated specially. + do k=1,GV%ke + if (CS%LT_K_SHAPE== LT_K_CONSTANT) then + if (CS%id_EnhK > 0) CS%EnhK(i,j,:) = LangEnhK + !Kdiffusivity(k,1) = Kdiffusivity(k,1) * LangEnhK + !Kdiffusivity(k,2) = Kdiffusivity(k,2) * LangEnhK + !Kviscosity(k) = Kviscosity(k) * LangEnhK + elseif (CS%LT_K_SHAPE == LT_K_SCALED) then + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + SigmaRatio = sigma * (1. - sigma)**2 / 0.148148037 + if (CS%id_EnhK > 0) CS%EnhK(i,j,k) = (1.0 + (LangEnhK - 1.)*sigmaRatio) + !Kdiffusivity(k,1) = Kdiffusivity(k,1) * ( 1. + & + ! ( LangEnhK - 1.)*sigmaRatio) + !Kdiffusivity(k,2) = Kdiffusivity(k,2) * ( 1. + & + ! ( LangEnhK - 1.)*sigmaRatio) + !Kviscosity(k) = Kviscosity(k) * ( 1. + & + ! ( LangEnhK - 1.)*sigmaRatio) + endif + enddo + endif + + ! Convert columns to MKS units for passing to CVMix + do k = 1, GV%ke + z_cell(k) = US%Z_to_m*cellHeight(k) + enddo + do K = 1, GV%ke+1 + z_inter(K) = US%Z_to_m*iFaceHeight(K) + enddo + + call CVMix_coeffs_kpp(Kviscosity(:), & ! (inout) Total viscosity [m2 s-1] + Kdiffusivity(:,1), & ! (inout) Total heat diffusivity [m2 s-1] + Kdiffusivity(:,2), & ! (inout) Total salt diffusivity [m2 s-1] + z_inter(:), & ! (in) Height of interfaces [m] + z_cell(:), & ! (in) Height of level centers [m] + Kviscosity(:), & ! (in) Original viscosity [m2 s-1] + Kdiffusivity(:,1), & ! (in) Original heat diffusivity [m2 s-1] + Kdiffusivity(:,2), & ! (in) Original salt diffusivity [m2 s-1] + US%Z_to_m*CS%OBLdepth(i,j), & ! (in) OBL depth [m] + CS%kOBL(i,j), & ! (in) level (+fraction) of OBL extent + nonLocalTrans(:,1),& ! (out) Non-local heat transport [nondim] + nonLocalTrans(:,2),& ! (out) Non-local salt transport [nondim] + surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] + GV%ke, & ! (in) Number of levels to compute coeffs for + GV%ke, & ! (in) Number of levels in array shape + Langmuir_EFactor=LangEnhK,& ! Langmuir enhancement multiplier + CVMix_kpp_params_user=CS%KPP_params ) + + ! safety check, Kviscosity and Kdiffusivity must be >= 0 + do k=1, GV%ke+1 + if (Kviscosity(k) < 0. .or. Kdiffusivity(k,1) < 0.) then + write(*,'(a,3i3)') 'interface, i, j, k = ',j, j, k + write(*,'(a,2f12.5)') 'lon,lat=', G%geoLonT(i,j), G%geoLatT(i,j) + write(*,'(a,es12.4)') 'depth, z_inter(k) =',z_inter(k) + write(*,'(a,es12.4)') 'Kviscosity(k) =',Kviscosity(k) + write(*,'(a,es12.4)') 'Kdiffusivity(k,1) =',Kdiffusivity(k,1) + write(*,'(a,es12.4)') 'Kdiffusivity(k,2) =',Kdiffusivity(k,2) + write(*,'(a,es12.4)') 'OBLdepth =',US%Z_to_m*CS%OBLdepth(i,j) + write(*,'(a,f8.4)') 'kOBL =',CS%kOBL(i,j) + write(*,'(a,es12.4)') 'u* =',surfFricVel + write(*,'(a,es12.4)') 'bottom, z_inter(GV%ke+1) =',z_inter(GV%ke+1) + write(*,'(a,es12.4)') 'CS%La_SL(i,j) =',CS%La_SL(i,j) + write(*,'(a,es12.4)') 'LangEnhK =',LangEnhK + if (present(lamult)) write(*,'(a,es12.4)') 'lamult(i,j) =',lamult(i,j) + write(*,*) 'Kviscosity(:) =',Kviscosity(:) + write(*,*) 'Kdiffusivity(:,1) =',Kdiffusivity(:,1) + + call MOM_error(FATAL,"KPP_calculate, after CVMix_coeffs_kpp: "// & + "Negative vertical viscosity or diffusivity has been detected. " // & + "This is likely related to the choice of MATCH_TECHNIQUE and INTERP_TYPE2." //& + "You might consider using the default options for these parameters." ) + endif + enddo + + ! Over-write CVMix NLT shape function with one of the following choices. + ! The CVMix code has yet to update for thse options, so we compute in MOM6. + ! Note that nonLocalTrans = Cs * G(sigma) (LMD94 notation), with + ! Cs = 6.32739901508. + ! Start do-loop at k=2, since k=1 is ocean surface (sigma=0) + ! and we do not wish to double-count the surface forcing. + ! Only compute nonlocal transport for 0 <= sigma <= 1. + ! MOM6 recommended shape is the parabolic; it gives deeper boundary layer + ! and no spurious extrema. + if (surfBuoyFlux < 0.0) then + if (CS%NLT_shape == NLT_SHAPE_CUBIC) then + do k = 2, GV%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = (1.0 - sigma)**2 * (1.0 + 2.0*sigma) !* + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + elseif (CS%NLT_shape == NLT_SHAPE_PARABOLIC) then + do k = 2, GV%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = (1.0 - sigma)**2 !*CS%CS2 + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + elseif (CS%NLT_shape == NLT_SHAPE_LINEAR) then + do k = 2, GV%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = (1.0 - sigma)!*CS%CS2 + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + elseif (CS%NLT_shape == NLT_SHAPE_CUBIC_LMD) then + ! Sanity check (should agree with CVMix result using simple matching) + do k = 2, GV%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = CS%CS2 * sigma*(1.0 -sigma)**2 + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + endif + endif + + ! we apply nonLocalTrans in subroutines + ! KPP_NonLocalTransport_temp and KPP_NonLocalTransport_saln + nonLocalTransHeat(i,j,:) = nonLocalTrans(:,1) ! temperature + nonLocalTransScalar(i,j,:) = nonLocalTrans(:,2) ! salinity + + ! set the KPP diffusivity and viscosity to zero for testing purposes + if (CS%KPPzeroDiffusivity) then + Kdiffusivity(:,1) = 0.0 + Kdiffusivity(:,2) = 0.0 + Kviscosity(:) = 0.0 + endif + + ! Copy 1d data into 3d diagnostic arrays + !/ grabbing obldepth_0d for next time step. + CS%OBLdepthprev(i,j) = CS%OBLdepth(i,j) + if (CS%id_sigma > 0) then + CS%sigma(i,j,:) = 0. + if (CS%OBLdepth(i,j)>0.) CS%sigma(i,j,:) = -iFaceHeight(:)/CS%OBLdepth(i,j) + endif + if (CS%id_Kt_KPP > 0) CS%Kt_KPP(i,j,:) = US%m2_s_to_Z2_T * Kdiffusivity(:,1) + if (CS%id_Ks_KPP > 0) CS%Ks_KPP(i,j,:) = US%m2_s_to_Z2_T * Kdiffusivity(:,2) + if (CS%id_Kv_KPP > 0) CS%Kv_KPP(i,j,:) = US%m2_s_to_Z2_T * Kviscosity(:) + + ! Update output of routine + if (.not. CS%passiveMode) then + if (CS%KPPisAdditive) then + do k=1, GV%ke+1 + Kt(i,j,k) = Kt(i,j,k) + GV%m2_s_to_HZ_T * Kdiffusivity(k,1) + Ks(i,j,k) = Ks(i,j,k) + GV%m2_s_to_HZ_T * Kdiffusivity(k,2) + Kv(i,j,k) = Kv(i,j,k) + GV%m2_s_to_HZ_T * Kviscosity(k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = Kv(i,j,k) + enddo + else ! KPP replaces prior diffusivity when former is non-zero + do k=1, GV%ke+1 + if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = GV%m2_s_to_HZ_T * Kdiffusivity(k,1) + if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = GV%m2_s_to_HZ_T * Kdiffusivity(k,2) + if (Kviscosity(k) /= 0.) Kv(i,j,k) = GV%m2_s_to_HZ_T * Kviscosity(k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = Kv(i,j,k) + enddo + endif + endif + + + ! end of the horizontal do-loops over the vertical columns + endif ; enddo ! i + enddo ! j + + call cpu_clock_end(id_clock_KPP_calc) + + if (CS%debug) then + call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + + ! send diagnostics to post_data + if (CS%id_OBLdepth > 0) call post_data(CS%id_OBLdepth, CS%OBLdepth, CS%diag) + if (CS%id_OBLdepth_original > 0) call post_data(CS%id_OBLdepth_original,CS%OBLdepth_original,CS%diag) + if (CS%id_sigma > 0) call post_data(CS%id_sigma, CS%sigma, CS%diag) + if (CS%id_Ws > 0) call post_data(CS%id_Ws, CS%Ws, CS%diag) + if (CS%id_uStar > 0) call post_data(CS%id_uStar, uStar, CS%diag) + if (CS%id_buoyFlux > 0) call post_data(CS%id_buoyFlux, buoyFlux, CS%diag) + if (CS%id_Kt_KPP > 0) call post_data(CS%id_Kt_KPP, CS%Kt_KPP, CS%diag) + if (CS%id_Ks_KPP > 0) call post_data(CS%id_Ks_KPP, CS%Ks_KPP, CS%diag) + if (CS%id_Kv_KPP > 0) call post_data(CS%id_Kv_KPP, CS%Kv_KPP, CS%diag) + if (CS%id_NLTt > 0) call post_data(CS%id_NLTt, nonLocalTransHeat, CS%diag) + if (CS%id_NLTs > 0) call post_data(CS%id_NLTs, nonLocalTransScalar,CS%diag) + + +end subroutine KPP_calculate + + +!> Compute OBL depth +subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFlux, Waves, lamult) + + ! Arguments + type(KPP_CS), pointer :: CS !< Control structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Temp !< potential/cons temp [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< Salinity [S ~> ppt] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Velocity i-component [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Velocity j-component [L T-1 ~> m s-1] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] + type(wave_parameters_CS), pointer :: Waves !< Wave CS for Langmuir turbulence + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement factor [nondim] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] + + ! Variables for passing to CVMix routines, often in MKS units + real, dimension( GV%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars in MKS units [m s-1] + real, dimension( GV%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] + real, dimension( GV%ke ) :: deltaBuoy ! Change in Buoyancy based on deltaRho [m s-2] + real, dimension( GV%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] + real, dimension( GV%ke ) :: surfBuoyFlux2 ! Surface buoyancy flux in MKS units [m2 s-3] + real, dimension( GV%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer [nondim] + real, dimension( GV%ke ) :: Vt2_1d ! Unresolved squared turbulence velocity for bulk Ri [m2 s-2] + real, dimension( GV%ke ) :: z_cell ! Cell center heights referenced to surface [m] (negative in ocean) + real, dimension( GV%ke ) :: OBL_depth ! Cell center depths referenced to surface [m] (positive in ocean) + real, dimension( GV%ke+1 ) :: z_inter ! Cell interface heights referenced to surface [m] (negative in ocean) + real, dimension( GV%ke+1 ) :: N_col ! A column of buoyancy frequencies at interfaces in MKS units [s-1] + real :: surfFricVel ! Surface friction velocity in MKS units [m s-1] + real :: surfBuoyFlux ! Surface buoyancy flux in MKS units [m2 s-3] + real :: Coriolis ! Coriolis parameter at tracer points in MKS units [s-1] + real :: KPP_OBL_depth ! Boundary layer depth calculated by CVMix_kpp_compute_OBL_depth in MKS units [m] + + ! Variables for EOS calculations + real, dimension( 3*GV%ke ) :: rho_1D ! A column of densities [R ~> kg m-3] + real, dimension( 3*GV%ke ) :: pres_1D ! A column of pressures [R L2 T-2 ~> Pa] + real, dimension( 3*GV%ke ) :: Temp_1D ! A column of temperatures [C ~> degC] + real, dimension( 3*GV%ke ) :: Salt_1D ! A column of salinities [S ~> ppt] + + real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [Z ~> m] (negative in ocean) + real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [Z ~> m] (negative in ocean) + real, dimension( GV%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces [T-2 ~> s-2] + real :: zBottomMinusOffset ! Height of bottom plus a little bit [Z ~> m] + real :: GoRho ! Gravitational acceleration in MKS units divided by density [m s-2 R-1 ~> m4 kg-1 s-2] + real :: GoRho_Z_L2 ! Gravitational acceleration, perhaps divided by density, times aspect ratio + ! rescaling [H T-2 R-1 ~> m4 kg-1 s-2 or m s-2] + real :: pRef ! The interface pressure [R L2 T-2 ~> Pa] + real :: Uk, Vk ! Layer velocities relative to their averages in the surface layer [L T-1 ~> m s-1] + real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth [Z ~> m] + real :: hTot ! Running sum of thickness used in the surface layer average [Z ~> m] + real :: buoy_scale ! A unit conversion factor for buoyancy fluxes [m2 T3 L-2 s-3 ~> 1] + real :: delH ! Thickness of a layer [Z ~> m] + real :: surfTemp ! Average of temperature over the surface layer [C ~> degC] + real :: surfHtemp ! Integral of temperature over the surface layer [Z C ~> m degC] + real :: surfSalt ! Average of salinity over the surface layer [S ~> ppt] + real :: surfHsalt ! Integral of salinity over the surface layer [Z S ~> m ppt] + real :: surfHu, surfHv ! Integral of u and v over the surface layer [Z L T-1 ~> m2 s-1] + real :: surfU, surfV ! Average of u and v over the surface layer [Z T-1 ~> m s-1] + real :: dh ! The local thickness used for calculating interface positions [Z ~> m] + real :: hcorr ! A cumulative correction arising from inflation of vanished layers [Z ~> m] + + ! For Langmuir Calculations + real :: LangEnhVt2 ! Langmuir enhancement for unresolved shear [nondim] + real, dimension(GV%ke) :: U_H, V_H ! Velocities at tracer points [L T-1 ~> m s-1] + real :: MLD_guess ! A guess at the mixed layer depth for calculating the Langmuir number [Z ~> m] + real :: LA ! The local Langmuir number [nondim] + real :: surfHuS, surfHvS ! Stokes drift velocities integrated over the boundary layer [Z L T-1 ~> m2 s-1] + real :: surfUs, surfVs ! Stokes drift velocities averaged over the boundary layer [Z T-1 ~> m s-1] + + integer :: i, j, k, km1, kk, ksfc, ktmp ! Loop indices + + if (CS%Stokes_Mixing .and. .not.associated(Waves)) call MOM_error(FATAL, & + "KPP_compute_BLD: The Waves control structure must be associated if STOKES_MIXING is True.") + + if (CS%debug) then + call hchksum(Salt, "KPP in: S", G%HI, haloshift=0, scale=US%S_to_ppt) + call hchksum(Temp, "KPP in: T", G%HI, haloshift=0, scale=US%C_to_degC) + call hchksum(u, "KPP in: u",G%HI,haloshift=0,scale=US%L_T_to_m_s) + call hchksum(v, "KPP in: v",G%HI,haloshift=0,scale=US%L_T_to_m_s) + endif + + call cpu_clock_begin(id_clock_KPP_compute_BLD) + + ! some constants + GoRho = US%Z_to_m*US%s_to_T**2 * (US%L_to_Z**2 * GV%g_Earth / GV%Rho0) + if (GV%Boussinesq) then + GoRho_Z_L2 = US%L_to_Z**2 * GV%Z_to_H * GV%g_Earth / GV%Rho0 + else + GoRho_Z_L2 = US%L_to_Z**2 * GV%g_Earth * GV%RZ_to_H + endif + buoy_scale = US%L_to_m**2*US%s_to_T**3 + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US) + + ! loop over horizontal points on processor + !$OMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & + !$OMP surfBuoyFlux, U_H, V_H, Coriolis, pRef, SLdepth_0d, vt2_1d, & + !$OMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & + !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & + !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, N_col, & + !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_guess, LA, rho_1D, & + !$OMP deltarho, deltaBuoy, N2_1d, ws_1d, LangEnhVT2,KPP_OBL_depth, z_cell, & + !$OMP z_inter, OBL_depth, BulkRi_1d, zBottomMinusOffset) & + !$OMP shared(G, GV, CS, US, uStar, h, dz, buoy_scale, buoyFlux, & + !$OMP Temp, Salt, waves, tv, GoRho, GoRho_Z_L2, u, v, lamult) + do j = G%jsc, G%jec + do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then + + do k=1,GV%ke + U_H(k) = 0.5 * (u(i,j,k)+u(i-1,j,k)) + V_H(k) = 0.5 * (v(i,j,k)+v(i,j-1,k)) + enddo + + ! things independent of position within the column + Coriolis = 0.25*US%s_to_T*( (G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) + & + (G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1)) ) + surfFricVel = US%Z_to_m*US%s_to_T * uStar(i,j) + + ! Bullk Richardson number computed for each cell in a column, + ! assuming OBLdepth = grid cell depth. After Rib(k) is + ! known for the column, then CVMix interpolates to find + ! the actual OBLdepth. This approach avoids need to iterate + ! on the OBLdepth calculation. It follows that used in MOM5 + ! and POP. + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + pRef = 0. ; if (associated(tv%p_surf)) pRef = tv%p_surf(i,j) + hcorr = 0. + do k=1,GV%ke + + ! cell center and cell bottom in meters (negative values in the ocean) + dh = dz(i,j,k) ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + + ! find ksfc for cell where "surface layer" sits + SLdepth_0d = CS%surf_layer_ext*max( max(-cellHeight(k),-iFaceHeight(2) ), CS%minOBLdepth ) + ksfc = k + do ktmp = 1,k + if (-1.0*iFaceHeight(ktmp+1) >= SLdepth_0d) then + ksfc = ktmp + exit + endif + enddo + + ! average temperature, salinity, u and v over surface layer + ! use C-grid average to get u and v on T-points. + surfHtemp = 0.0 + surfHsalt = 0.0 + surfHu = 0.0 + surfHv = 0.0 + surfHuS = 0.0 + surfHvS = 0.0 + hTot = 0.0 + do ktmp = 1,ksfc + + ! SLdepth_0d can be between cell interfaces + delH = min( max(0.0, SLdepth_0d - hTot), dz(i,j,ktmp) ) + + ! surface layer thickness + hTot = hTot + delH + + ! surface averaged fields + surfHtemp = surfHtemp + Temp(i,j,ktmp) * delH + surfHsalt = surfHsalt + Salt(i,j,ktmp) * delH + surfHu = surfHu + 0.5*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH + surfHv = surfHv + 0.5*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH + if (CS%Stokes_Mixing) then + surfHus = surfHus + 0.5*(Waves%US_x(i,j,ktmp)+Waves%US_x(i-1,j,ktmp)) * delH + surfHvs = surfHvs + 0.5*(Waves%US_y(i,j,ktmp)+Waves%US_y(i,j-1,ktmp)) * delH + endif + + enddo + surfTemp = surfHtemp / hTot + surfSalt = surfHsalt / hTot + surfU = surfHu / hTot + surfV = surfHv / hTot + surfUs = surfHus / hTot + surfVs = surfHvs / hTot + + ! vertical shear between present layer and surface layer averaged surfU and surfV. + ! C-grid average to get Uk and Vk on T-points. + Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU + Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV + + if (CS%Stokes_Mixing) then + ! If momentum is mixed down the Stokes drift gradient, then + ! the Stokes drift must be included in the bulk Richardson number + ! calculation. + Uk = Uk + (0.5*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) - surfUs ) + Vk = Vk + (0.5*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) - surfVs ) + endif + + deltaU2(k) = US%L_T_to_m_s**2 * (Uk**2 + Vk**2) + + ! pressure, temperature, and salinity for calling the equation of state + ! kk+1 = surface fields + ! kk+2 = k fields + ! kk+3 = km1 fields + km1 = max(1, k-1) + kk = 3*(k-1) + pres_1D(kk+1) = pRef + pres_1D(kk+2) = pRef + pres_1D(kk+3) = pRef + Temp_1D(kk+1) = surfTemp + Temp_1D(kk+2) = Temp(i,j,k) + Temp_1D(kk+3) = Temp(i,j,km1) + Salt_1D(kk+1) = surfSalt + Salt_1D(kk+2) = Salt(i,j,k) + Salt_1D(kk+3) = Salt(i,j,km1) + + ! pRef is pressure at interface between k and km1 [R L2 T-2 ~> Pa]. + ! iterate pRef for next pass through k-loop. + pRef = pRef + (GV%g_Earth * GV%H_to_RZ) * h(i,j,k) + + ! this difference accounts for penetrating SW + surfBuoyFlux2(k) = buoy_scale * (buoyFlux(i,j,1) - buoyFlux(i,j,k+1)) + + enddo ! k-loop finishes + + if ( (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) .and. .not. present(lamult)) then + MLD_guess = max( CS%MLD_guess_min, abs(CS%OBLdepthprev(i,j) ) ) + call get_Langmuir_Number(LA, G, GV, US, MLD_guess, uStar(i,j), i, j, & + dz=dz(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) + CS%La_SL(i,j) = LA + endif + + + ! compute in-situ density + call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, tv%eqn_of_state) + + ! N2 (can be negative) and N (non-negative) on interfaces. + ! deltaRho is non-local rho difference used for bulk Richardson number. + ! CS%N is local N (with floor) used for unresolved shear calculation. + do k = 1, GV%ke + km1 = max(1, k-1) + kk = 3*(k-1) + deltaRho(k) = rho_1D(kk+2) - rho_1D(kk+1) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + deltaBuoy(k) = GoRho*(rho_1D(kk+2) - rho_1D(kk+1)) + else + deltaBuoy(k) = (US%Z_to_m*US%s_to_T**2) * (US%L_to_Z**2 * GV%g_Earth) * & + ( (rho_1D(kk+2) - rho_1D(kk+1)) / (0.5 * (rho_1D(kk+2) + rho_1D(kk+1))) ) + endif + N2_1d(k) = (GoRho_Z_L2 * (rho_1D(kk+2) - rho_1D(kk+3)) ) / & + ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)) + CS%N(i,j,k) = sqrt( max( N2_1d(k), 0.) ) + enddo + N2_1d(GV%ke+1 ) = 0.0 + CS%N(i,j,GV%ke+1 ) = 0.0 + + ! Convert columns to MKS units for passing to CVMix + do k = 1, GV%ke + OBL_depth(k) = -US%Z_to_m * cellHeight(k) + z_cell(k) = US%Z_to_m*cellHeight(k) + enddo + do K = 1, GV%ke+1 + N_col(K) = US%s_to_T*CS%N(i,j,K) + z_inter(K) = US%Z_to_m*iFaceHeight(K) + enddo + + ! turbulent velocity scales w_s and w_m computed at the cell centers. + ! Note that if sigma > CS%surf_layer_ext, then CVMix_kpp_compute_turbulent_scales + ! computes w_s and w_m velocity scale at sigma=CS%surf_layer_ext. So we only pass + ! sigma=CS%surf_layer_ext for this calculation. + call CVMix_kpp_compute_turbulent_scales( & + CS%surf_layer_ext, & ! (in) Normalized surface layer depth; sigma = CS%surf_layer_ext + OBL_depth, & ! (in) OBL depth [m] + surfBuoyFlux2, & ! (in) Buoyancy flux at surface [m2 s-3] + surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] + CVMix_kpp_params_user=CS%KPP_params ) + + ! Determine the enhancement factor for unresolved shear + IF (CS%LT_VT2_ENHANCEMENT) then + IF (CS%LT_VT2_METHOD==LT_VT2_MODE_CONSTANT) then + LangEnhVT2 = CS%KPP_VT2_ENH_FAC + elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_VR12) then + !Introduced minimum value for La_SL, so maximum value for enhvt2 is removed. + if (present(lamult)) then + LangEnhVT2 = lamult(i,j) + else + LangEnhVT2 = sqrt(1.+(1.5*CS%La_SL(i,j))**(-2) + & + (5.4*CS%La_SL(i,j))**(-4)) + endif + else + ! for other methods (e.g., LT_VT2_MODE_RW16, LT_VT2_MODE_LF17), the enhancement factor is + ! computed internally within CVMix using LaSL, bfsfc, and ustar to be passed to CVMix. + LangEnhVT2 = 1.0 + endif + else + LangEnhVT2 = 1.0 + endif + + surfBuoyFlux = buoy_scale * buoyFlux(i,j,1) + + ! Calculate Bulk Richardson number from eq (21) of LMD94 + BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( & + zt_cntr=z_cell, & ! Depth of cell center [m] + delta_buoy_cntr=deltaBuoy, & ! Bulk buoyancy difference, Br-B(z) [m s-2] + delta_Vsqr_cntr=deltaU2, & ! Square of resolved velocity difference [m2 s-2] + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile [m s-1] + N_iface=N_col, & ! Buoyancy frequency [s-1] + EFactor=LangEnhVT2, & ! Langmuir enhancement factor [nondim] + LaSL=CS%La_SL(i,j), & ! surface layer averaged Langmuir number [nondim] + bfsfc=surfBuoyFlux, & ! surface buoyancy flux [m2 s-3] + uStar=surfFricVel, & ! surface friction velocity [m s-1] + CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters + + + call CVMix_kpp_compute_OBL_depth( & + BulkRi_1d, & ! (in) Bulk Richardson number + z_inter, & ! (in) Height of interfaces [m] + KPP_OBL_depth, & ! (out) OBL depth [m] + CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent + zt_cntr=z_cell, & ! (in) Height of cell centers [m] + surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] + Coriolis=Coriolis, & ! (in) Coriolis parameter [s-1] + CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters + CS%OBLdepth(i,j) = US%m_to_Z * KPP_OBL_depth + + ! A hack to avoid KPP reaching the bottom. It was needed during development + ! because KPP was unable to handle vanishingly small layers near the bottom. + if (CS%deepOBLoffset>0.) then + zBottomMinusOffset = iFaceHeight(GV%ke+1) + min(CS%deepOBLoffset, -0.1*iFaceHeight(GV%ke+1)) + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) + endif + + ! apply some constraints on OBLdepth + if (CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value + CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(GV%ke+1) ) ! no deeper than bottom + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + + ! compute unresolved squared velocity for diagnostics + if (CS%id_Vt2 > 0) then + Vt2_1d(:) = CVmix_kpp_compute_unresolved_shear( & + z_cell, & ! Depth of cell center [m] + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers [m s-1] + N_iface=N_col, & ! Buoyancy frequency at interface [s-1] + EFactor=LangEnhVT2, & ! Langmuir enhancement factor [nondim] + LaSL=CS%La_SL(i,j), & ! surface layer averaged Langmuir number [nondim] + bfsfc=surfBuoyFlux, & ! surface buoyancy flux [m2 s-3] + uStar=surfFricVel, & ! surface friction velocity [m s-1] + CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters + CS%Vt2(i,j,:) = US%m_to_Z*US%T_to_s * Vt2_1d(:) + endif + + ! recompute wscale for diagnostics, now that we in fact know boundary layer depth + !BGR consider if LTEnhancement is wanted for diagnostics + if (CS%id_Ws > 0) then + call CVMix_kpp_compute_turbulent_scales( & + -cellHeight(:)/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate [nondim] + US%Z_to_m*CS%OBLdepth(i,j), & ! (in) OBL depth [m] + surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] + surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] + CVMix_kpp_params_user=CS%KPP_params) ! KPP parameters + CS%Ws(i,j,:) = US%m_to_Z*US%T_to_s*Ws_1d(:) + endif + + ! Diagnostics + if (CS%id_N2 > 0) CS%N2(i,j,:) = N2_1d(:) + if (CS%id_BulkDrho > 0) CS%dRho(i,j,:) = deltaRho(:) + if (CS%id_BulkRi > 0) CS%BulkRi(i,j,:) = BulkRi_1d(:) + if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = US%m_s_to_L_T**2 * deltaU2(:) + if (CS%id_Tsurf > 0) CS%Tsurf(i,j) = surfTemp + if (CS%id_Ssurf > 0) CS%Ssurf(i,j) = surfSalt + if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU + if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfV + + endif ; enddo + enddo + + call cpu_clock_end(id_clock_KPP_compute_BLD) + + ! send diagnostics to post_data + if (CS%id_BulkRi > 0) call post_data(CS%id_BulkRi, CS%BulkRi, CS%diag) + if (CS%id_N > 0) call post_data(CS%id_N, CS%N, CS%diag) + if (CS%id_N2 > 0) call post_data(CS%id_N2, CS%N2, CS%diag) + if (CS%id_Tsurf > 0) call post_data(CS%id_Tsurf, CS%Tsurf, CS%diag) + if (CS%id_Ssurf > 0) call post_data(CS%id_Ssurf, CS%Ssurf, CS%diag) + if (CS%id_Usurf > 0) call post_data(CS%id_Usurf, CS%Usurf, CS%diag) + if (CS%id_Vsurf > 0) call post_data(CS%id_Vsurf, CS%Vsurf, CS%diag) + if (CS%id_BulkDrho > 0) call post_data(CS%id_BulkDrho, CS%dRho, CS%diag) + if (CS%id_BulkUz2 > 0) call post_data(CS%id_BulkUz2, CS%Uz2, CS%diag) + if (CS%id_EnhK > 0) call post_data(CS%id_EnhK, CS%EnhK, CS%diag) + if (CS%id_EnhVt2 > 0) call post_data(CS%id_EnhVt2, CS%EnhVt2, CS%diag) + if (CS%id_La_SL > 0) call post_data(CS%id_La_SL, CS%La_SL, CS%diag) + if (CS%id_Vt2 > 0) call post_data(CS%id_Vt2, CS%Vt2, CS%diag) + + ! BLD smoothing: + if (CS%n_smooth > 0) call KPP_smooth_BLD(CS, G, GV, US, dz) + +end subroutine KPP_compute_BLD + + +!> Apply a 1-1-4-1-1 Laplacian filter one time on BLD to reduce any horizontal two-grid-point noise +subroutine KPP_smooth_BLD(CS, G, GV, US, dz) + ! Arguments + type(KPP_CS), pointer :: CS !< Control structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: dz !< Layer thicknesses [Z ~> m] + + ! local + real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_prev ! OBLdepth before s.th smoothing iteration [Z ~> m] + real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [Z ~> m] + ! (negative in the ocean) + real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [Z ~> m] + ! (negative in the ocean) + real :: wc, ww, we, wn, ws ! averaging weights for smoothing [nondim] + real :: dh ! The local thickness used for calculating interface positions [Z ~> m] + real :: hcorr ! A cumulative correction arising from inflation of vanished layers [Z ~> m] + integer :: i, j, k, s + + call cpu_clock_begin(id_clock_KPP_smoothing) + + ! Update halos + call pass_var(CS%OBLdepth, G%Domain, halo=CS%n_smooth) + + if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = CS%OBLdepth + + do s=1,CS%n_smooth + + OBLdepth_prev = CS%OBLdepth + + ! apply smoothing on OBL depth + !$OMP parallel do default(none) shared(G, GV, US, CS, dz, OBLdepth_prev) & + !$OMP private(wc, ww, we, wn, ws, dh, hcorr, cellHeight, iFaceHeight) + do j = G%jsc, G%jec + do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0. + do k=1,GV%ke + + ! cell center and cell bottom in meters (negative values in the ocean) + dh = dz(i,j,k) ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + enddo + + ! compute weights + ww = 0.125 * G%mask2dT(i-1,j) + we = 0.125 * G%mask2dT(i+1,j) + ws = 0.125 * G%mask2dT(i,j-1) + wn = 0.125 * G%mask2dT(i,j+1) + wc = 1.0 - (ww+we+wn+ws) + + CS%OBLdepth(i,j) = wc * OBLdepth_prev(i,j) & + + ww * OBLdepth_prev(i-1,j) & + + we * OBLdepth_prev(i+1,j) & + + ws * OBLdepth_prev(i,j-1) & + + wn * OBLdepth_prev(i,j+1) + + ! Apply OBLdepth smoothing at a cell only if the OBLdepth gets deeper via smoothing. + if (CS%deepen_only) CS%OBLdepth(i,j) = max(CS%OBLdepth(i,j), OBLdepth_prev(i,j)) + + ! prevent OBL depths deeper than the bathymetric depth + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(GV%ke+1) ) ! no deeper than bottom + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + endif ; enddo + enddo + + enddo ! s-loop + + call cpu_clock_end(id_clock_KPP_smoothing) + +end subroutine KPP_smooth_BLD + + + +!> Copies KPP surface boundary layer depth into BLD, in units of [Z ~> m] unless other units are specified. +subroutine KPP_get_BLD(CS, BLD, G, US, m_to_BLD_units) + type(KPP_CS), pointer :: CS !< Control structure for + !! this module + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD !< Boundary layer depth [Z ~> m] or other units + real, optional, intent(in) :: m_to_BLD_units !< A conversion factor from meters + !! to the desired units for BLD [various] + ! Local variables + real :: scale ! A dimensional rescaling factor in [nondim] or other units. + integer :: i,j + + scale = 1.0 ; if (present(m_to_BLD_units)) scale = US%Z_to_m*m_to_BLD_units + + !$OMP parallel do default(none) shared(BLD, CS, G, scale) + do j = G%jsc, G%jec ; do i = G%isc, G%iec + BLD(i,j) = scale * CS%OBLdepth(i,j) + enddo ; enddo + +end subroutine KPP_get_BLD + +!> Apply KPP non-local transport of surface fluxes for a given tracer +subroutine KPP_NonLocalTransport(CS, G, GV, h, nonLocalTrans, surfFlux, & + dt, diag, tr_ptr, scalar, flux_scale) + type(KPP_CS), intent(in) :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of scalar + !! [conc H T-1 ~> conc m s-1 or conc kg m-2 s-1] + real, intent(in) :: dt !< Time-step [T ~> s] + type(diag_ctrl), target, intent(in) :: diag !< Diagnostics + type(tracer_type), pointer, intent(in) :: tr_ptr !< tracer_type has diagnostic ids on it + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: scalar !< Scalar (scalar units [conc]) + real, optional, intent(in) :: flux_scale !< Scale factor to get surfFlux + !! into proper units [various] + + integer :: i, j, k + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dtracer ! Rate of tracer change [conc T-1 ~> conc s-1] + real, dimension(SZI_(G),SZJ_(G)) :: surfFlux_loc ! An optionally rescaled surface flux of the scalar + ! in [conc H T-1 ~> conc m s-1 or conc kg m-2 s-1] or other units + + ! term used to scale + if (present(flux_scale)) then + do j = G%jsc, G%jec ; do i = G%isc, G%iec + surfFlux_loc(i,j) = surfFlux(i,j) * flux_scale + enddo ; enddo + else + surfFlux_loc(:,:) = surfFlux(:,:) + endif + + ! Post surface flux diagnostic + if (tr_ptr%id_net_surfflux > 0) call post_data(tr_ptr%id_net_surfflux, surfFlux_loc(:,:), diag) + + ! Only continue if we are applying the nonlocal tendency + ! or the nonlocal tendency diagnostic has been requested + if ((tr_ptr%id_NLT_tendency > 0) .or. (CS%applyNonLocalTrans)) then + + !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, h, G, GV, surfFlux_loc) + do k = 1, GV%ke ; do j = G%jsc, G%jec ; do i = G%isc, G%iec + dtracer(i,j,k) = ( nonLocalTrans(i,j,k) - nonLocalTrans(i,j,k+1) ) / & + ( h(i,j,k) + GV%H_subroundoff ) * surfFlux_loc(i,j) + enddo ; enddo ; enddo + + ! Update tracer due to non-local redistribution of surface flux + if (CS%applyNonLocalTrans) then + !$OMP parallel do default(none) shared(G, GV, dt, scalar, dtracer) + do k = 1, GV%ke ; do j = G%jsc, G%jec ; do i = G%isc, G%iec + scalar(i,j,k) = scalar(i,j,k) + dt * dtracer(i,j,k) + enddo ; enddo ; enddo + endif + if (tr_ptr%id_NLT_tendency > 0) call post_data(tr_ptr%id_NLT_tendency, dtracer, diag) + + endif + + + if (tr_ptr%id_NLT_budget > 0) then + !$OMP parallel do default(none) shared(G, GV, dtracer, nonLocalTrans, surfFlux_loc) + do k = 1, GV%ke ; do j = G%jsc, G%jec ; do i = G%isc, G%iec + ! Here dtracer has units of [Q R Z T-1 ~> W m-2]. + dtracer(i,j,k) = (nonLocalTrans(i,j,k) - nonLocalTrans(i,j,k+1)) * surfFlux_loc(i,j) + enddo ; enddo ; enddo + call post_data(tr_ptr%id_NLT_budget, dtracer(:,:,:), diag) + endif + +end subroutine KPP_NonLocalTransport + + +!> Apply KPP non-local transport of surface fluxes for temperature. +subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, dt, tr_ptr, scalar, C_p) + type(KPP_CS), intent(in) :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of temperature + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real, intent(in) :: dt !< Time-step [T ~> s] + type(tracer_type), pointer, intent(in) :: tr_ptr !< tracer_type has diagnostic ids on it + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: scalar !< temperature [C ~> degC] + real, intent(in) :: C_p !< Seawater specific heat capacity + !! [Q C-1 ~> J kg-1 degC-1] + + call KPP_NonLocalTransport(CS, G, GV, h, nonLocalTrans, surfFlux, dt, CS%diag, & + tr_ptr, scalar) + +end subroutine KPP_NonLocalTransport_temp + + +!> Apply KPP non-local transport of surface fluxes for salinity. +subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, tr_ptr, scalar) + type(KPP_CS), intent(in) :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of salt + !! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + real, intent(in) :: dt !< Time-step [T ~> s] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: scalar !< Salinity [S ~> ppt] + type(tracer_type), pointer, intent(in) :: tr_ptr !< tracer_type has diagnostic ids on it + + call KPP_NonLocalTransport(CS, G, GV, h, nonLocalTrans, surfFlux, dt, CS%diag, & + tr_ptr, scalar) + +end subroutine KPP_NonLocalTransport_saln + + +!> Clear pointers, deallocate memory +subroutine KPP_end(CS) + type(KPP_CS), pointer :: CS !< Control structure + + if (.not.associated(CS)) return + + deallocate(CS) + +end subroutine KPP_end + +end module MOM_CVMix_KPP diff --git a/parameterizations/vertical/MOM_CVMix_conv.F90 b/parameterizations/vertical/MOM_CVMix_conv.F90 new file mode 100644 index 0000000000..19744cb6c5 --- /dev/null +++ b/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -0,0 +1,310 @@ +!> Interface to CVMix convection scheme. +module MOM_CVMix_conv + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : hchksum +use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field +use MOM_diag_mediator, only : post_data +use MOM_EOS, only : calculate_density +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use CVMix_convection, only : CVMix_init_conv, CVMix_coeffs_conv +use CVMix_kpp, only : CVMix_kpp_compute_kOBL_depth + +implicit none ; private + +#include + +public CVMix_conv_init, calculate_CVMix_conv, CVMix_conv_is_used + +!> Control structure including parameters for CVMix convection. +type, public :: CVMix_conv_cs ; private + + ! Parameters + real :: kd_conv_const !< diffusivity constant used in convective regime [Z2 T-1 ~> m2 s-1] + real :: kv_conv_const !< viscosity constant used in convective regime [Z2 T-1 ~> m2 s-1] + real :: bv_sqr_conv !< Threshold for squared buoyancy frequency + !! needed to trigger Brunt-Vaisala parameterization [T-2 ~> s-2] + real :: min_thickness !< Minimum thickness allowed [Z ~> m] + logical :: debug !< If true, turn on debugging + + ! Diagnostic handles and pointers + type(diag_ctrl), pointer :: diag => NULL() !< Pointer to diagnostics control structure + !>@{ Diagnostics handles + integer :: id_N2 = -1, id_kd_conv = -1, id_kv_conv = -1 + !>@} + +end type CVMix_conv_cs + +character(len=40) :: mdl = "MOM_CVMix_conv" !< This module's name. + +contains + +!> Initialized the CVMix convection mixing routine. +logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) + + type(time_type), intent(in) :: Time !< The current time. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. + type(CVMix_conv_cs), intent(inout) :: CS !< CVMix convection control structure + + real :: prandtl_conv !< Turbulent Prandtl number used in convective instabilities [nondim] + logical :: useEPBL !< If True, use the ePBL boundary layer scheme. + + ! This include declares and sets the variable "version". +# include "version_variable.h" + + ! Read parameters + call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_init, default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, & + "Parameterization of enhanced mixing due to convection via CVMix", & + all_default=.not.CVMix_conv_init) + call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_init, & + "If true, turns on the enhanced mixing due to convection "//& + "via CVMix. This scheme increases diapycnal diffs./viscs. "//& + "at statically unstable interfaces. Relevant parameters are "//& + "contained in the CVMix_CONVECTION% parameter block.", & + default=.false.) + + if (.not. CVMix_conv_init) return + + call get_param(param_file, mdl, "ENERGETICS_SFC_PBL", useEPBL, default=.false., & + do_not_log=.true.) + + ! Warn user if EPBL is being used, since in this case mixing due to convection will + ! be aplied in the boundary layer + if (useEPBL) then + call MOM_error(WARNING, 'MOM_CVMix_conv_init: '// & + 'CVMix convection may not be properly applied when ENERGETICS_SFC_PBL = True'//& + 'as convective mixing might occur in the boundary layer.') + endif + + call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) + + call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, & + units="m", scale=US%m_to_Z, default=0.001, do_not_log=.True.) + + call openParameterBlock(param_file,'CVMix_CONVECTION') + + call get_param(param_file, mdl, "PRANDTL_CONV", prandtl_conv, & + "The turbulent Prandtl number applied to convective "//& + "instabilities (i.e., used to convert KD_CONV into KV_CONV)", & + units="nondim", default=1.0) + + call get_param(param_file, mdl, 'KD_CONV', CS%kd_conv_const, & + "Diffusivity used in convective regime. Corresponding viscosity "//& + "(KV_CONV) will be set to KD_CONV * PRANDTL_CONV.", & + units='m2/s', default=1.00, scale=US%m2_s_to_Z2_T) + + call get_param(param_file, mdl, 'BV_SQR_CONV', CS%bv_sqr_conv, & + "Threshold for squared buoyancy frequency needed to trigger "//& + "Brunt-Vaisala parameterization.", & + units='1/s^2', default=0.0, scale=US%T_to_s**2) + + call closeParameterBlock(param_file) + + ! set kv_conv_const based on kd_conv_const and prandtl_conv + CS%kv_conv_const = CS%kd_conv_const * prandtl_conv + + ! Register diagnostics + CS%diag => diag + CS%id_N2 = register_diag_field('ocean_model', 'N2_conv', diag%axesTi, Time, & + 'Square of Brunt-Vaisala frequency used by MOM_CVMix_conv module', '1/s2', conversion=US%s_to_T**2) + CS%id_kd_conv = register_diag_field('ocean_model', 'kd_conv', diag%axesTi, Time, & + 'Additional diffusivity added by MOM_CVMix_conv module', 'm2/s', conversion=US%Z2_T_to_m2_s) + CS%id_kv_conv = register_diag_field('ocean_model', 'kv_conv', diag%axesTi, Time, & + 'Additional viscosity added by MOM_CVMix_conv module', 'm2/s', conversion=US%Z2_T_to_m2_s) + + call CVMix_init_conv(convect_diff=US%Z2_T_to_m2_s*CS%kd_conv_const, & + convect_visc=US%Z2_T_to_m2_s*CS%kv_conv_const, & + lBruntVaisala=.true., & + BVsqr_convect=US%s_to_T**2*CS%bv_sqr_conv) + +end function CVMix_conv_init + +!> Subroutine for calculating enhanced diffusivity/viscosity +!! due to convection via CVMix +subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) + + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + type(CVMix_conv_cs), intent(in) :: CS !< CVMix convection control structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hbl !< Depth of ocean boundary layer [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(inout) :: Kd !< Diapycnal diffusivity at each interface + !! that will be incremented here + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(inout) :: Kv !< Viscosity at each interface that will be + !! incremented here [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: Kd_aux !< A second diapycnal diffusivity at each + !! interface that will also be incremented + !! here [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + ! local variables + real, dimension(SZK_(GV)) :: rho_lwr !< Adiabatic Water Density [kg m-3], this is a dummy + !! variable since here convection is always + !! computed based on Brunt Vaisala. + real, dimension(SZK_(GV)) :: rho_1d !< water density in a column [kg m-3], this is also + !! a dummy variable, same reason as above. + real, dimension(SZK_(GV)+1) :: N2 !< Squared buoyancy frequency [s-2] + real, dimension(SZK_(GV)+1) :: kv_col !< Viscosities at interfaces in the column [m2 s-1] + real, dimension(SZK_(GV)+1) :: kd_col !< Diffusivities at interfaces in the column [m2 s-1] + real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [Z ~> m] + real, dimension(SZK_(GV)) :: cellHeight !< Height of cell centers [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + kd_conv, & !< Diffusivity added by convection for diagnostics [Z2 T-1 ~> m2 s-1] + kv_conv, & !< Viscosity added by convection for diagnostics [Z2 T-1 ~> m2 s-1] + N2_3d !< Squared buoyancy frequency for diagnostics [T-2 ~> s-2] + integer :: kOBL !< level of ocean boundary layer extent + real :: g_o_rho0 ! Gravitational acceleration, perhaps divided by density, times unit conversion factors + ! [H s-2 R-1 ~> m4 s-2 kg-1 or m s-2] + real :: pref ! Interface pressures [R L2 T-2 ~> Pa] + real :: rhok, rhokm1 ! In situ densities of the layers above and below at the interface pressure [R ~> kg m-3] + real :: dh_int ! The distance between layer centers [H ~> m or kg m-2] + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] + integer :: i, j, k + + if (GV%Boussinesq) then + g_o_rho0 = (US%L_to_Z**2*US%s_to_T**2*GV%Z_to_H) * GV%g_Earth / GV%Rho0 + else + g_o_rho0 = (US%L_to_Z**2*US%s_to_T**2*GV%RZ_to_H) * GV%g_Earth + endif + + ! initialize dummy variables + rho_lwr(:) = 0.0 ; rho_1d(:) = 0.0 + + ! set N2 to zero at the top- and bottom-most interfaces + N2(1) = 0.0 ; N2(GV%ke+1) = 0.0 + + if (CS%id_N2 > 0) N2_3d(:,:,:) = 0.0 + if (CS%id_kv_conv > 0) Kv_conv(:,:,:) = 0.0 + if (CS%id_kd_conv > 0) Kd_conv(:,:,:) = 0.0 + + do j = G%jsc, G%jec + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + do i = G%isc, G%iec + + ! skip calling at land points + !if (G%mask2dT(i,j) == 0.) cycle + + pRef = 0. ; if (associated(tv%p_surf)) pRef = tv%p_surf(i,j) + ! Compute Brunt-Vaisala frequency (static stability) on interfaces + do K=2,GV%ke + + ! pRef is pressure at interface between k and km1 [R L2 T-2 ~> Pa]. + pRef = pRef + (GV%H_to_RZ*GV%g_Earth) * h(i,j,k) + call calculate_density(tv%t(i,j,k), tv%s(i,j,k), pRef, rhok, tv%eqn_of_state) + call calculate_density(tv%t(i,j,k-1), tv%s(i,j,k-1), pRef, rhokm1, tv%eqn_of_state) + + dh_int = 0.5*(h(i,j,k-1) + h(i,j,k)) + GV%H_subroundoff + N2(K) = g_o_rho0 * (rhok - rhokm1) / dh_int ! Can be negative + + enddo + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0.0 + ! compute heights at cell center and interfaces + do k=1,GV%ke + dh = dz(i,k) ! Nominal thickness to use for increment, in the units of heights + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + enddo + + ! gets index of the level and interface above hbl + kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl(i,j)) + + kv_col(:) = 0.0 ; kd_col(:) = 0.0 + call CVMix_coeffs_conv(Mdiff_out=kv_col(:), & + Tdiff_out=kd_col(:), & + Nsqr=N2(:), & + dens=rho_1d(:), & + dens_lwr=rho_lwr(:), & + nlev=GV%ke, & + max_nlev=GV%ke, & + OBL_ind=kOBL) + + ! Increment the diffusivity outside of the boundary layer. + do K=max(1,kOBL+1),GV%ke+1 + Kd(i,j,K) = Kd(i,j,K) + GV%m2_s_to_HZ_T * kd_col(K) + enddo + if (present(Kd_aux)) then + ! Increment the other diffusivity outside of the boundary layer. + do K=max(1,kOBL+1),GV%ke+1 + Kd_aux(i,j,K) = Kd_aux(i,j,K) + GV%m2_s_to_HZ_T * kd_col(K) + enddo + endif + + ! Increment the viscosity outside of the boundary layer. + do K=max(1,kOBL+1),GV%ke+1 + Kv(i,j,K) = Kv(i,j,K) + GV%m2_s_to_HZ_T * kv_col(K) + enddo + + ! Store 3-d arrays for diagnostics. + if (CS%id_kv_conv > 0) then + ! Do not apply mixing due to convection within the boundary layer + do K=max(1,kOBL+1),GV%ke+1 + Kv_conv(i,j,K) = US%m2_s_to_Z2_T * kv_col(K) + enddo + endif + if (CS%id_kd_conv > 0) then + ! Do not apply mixing due to convection within the boundary layer + do K=max(1,kOBL+1),GV%ke+1 + Kd_conv(i,j,K) = US%m2_s_to_Z2_T * kd_col(K) + enddo + endif + + if (CS%id_N2 > 0) then ; do k=2,GV%ke ; N2_3d(i,j,K) = US%T_to_s**2*N2(K) ; enddo ; endif + + enddo + enddo + + if (CS%debug) then + ! if (CS%id_N2 > 0) call hchksum(N2_3d, "MOM_CVMix_conv: N2",G%HI,haloshift=0) + ! if (CS%id_kd_conv > 0) & + ! call hchksum(Kd_conv, "MOM_CVMix_conv: Kd_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + ! if (CS%id_kv_conv > 0) & + ! call hchksum(Kv_conv, "MOM_CVMix_conv: Kv_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + + ! send diagnostics to post_data + if (CS%id_N2 > 0) call post_data(CS%id_N2, N2_3d, CS%diag) + if (CS%id_kd_conv > 0) call post_data(CS%id_kd_conv, Kd_conv, CS%diag) + if (CS%id_kv_conv > 0) call post_data(CS%id_kv_conv, Kv_conv, CS%diag) + +end subroutine calculate_CVMix_conv + +!> Reads the parameter "USE_CVMix_CONVECTION" and returns state. +!! This function allows other modules to know whether this parameterization will +!! be used without needing to duplicate the log entry. +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.) + +end function CVMix_conv_is_used + +end module MOM_CVMix_conv diff --git a/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/parameterizations/vertical/MOM_CVMix_ddiff.F90 new file mode 100644 index 0000000000..af17e0287f --- /dev/null +++ b/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -0,0 +1,290 @@ +!> Interface to CVMix double diffusion scheme. +module MOM_CVMix_ddiff + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field +use MOM_diag_mediator, only : post_data +use MOM_EOS, only : calculate_density_derivs +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_debugging, only : hchksum +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use cvmix_ddiff, only : cvmix_init_ddiff, CVMix_coeffs_ddiff +use cvmix_kpp, only : CVmix_kpp_compute_kOBL_depth +implicit none ; private + +#include + +public CVMix_ddiff_init, CVMix_ddiff_end, CVMix_ddiff_is_used, compute_ddiff_coeffs + +!> Control structure including parameters for CVMix double diffusion. +type, public :: CVMix_ddiff_cs ; private + + ! Parameters + real :: strat_param_max !< maximum value for the stratification parameter [nondim] + real :: kappa_ddiff_s !< leading coefficient in formula for salt-fingering regime + !! for salinity diffusion [Z2 T-1 ~> m2 s-1] + real :: ddiff_exp1 !< interior exponent in salt-fingering regime formula [nondim] + real :: ddiff_exp2 !< exterior exponent in salt-fingering regime formula [nondim] + real :: mol_diff !< molecular diffusivity [Z2 T-1 ~> m2 s-1] + real :: kappa_ddiff_param1 !< exterior coefficient in diffusive convection regime [nondim] + real :: kappa_ddiff_param2 !< middle coefficient in diffusive convection regime [nondim] + real :: kappa_ddiff_param3 !< interior coefficient in diffusive convection regime [nondim] + real :: min_thickness !< Minimum thickness allowed [H ~> m or kg-2] + character(len=4) :: diff_conv_type !< type of diffusive convection to use. Options are Marmorino & + !! Caldwell 1976 ("MC76"; default) and Kelley 1988, 1990 ("K90") + logical :: debug !< If true, turn on debugging + +end type CVMix_ddiff_cs + +character(len=40) :: mdl = "MOM_CVMix_ddiff" !< This module's name. + +contains + +!> Initialized the CVMix double diffusion module. +logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) + + type(time_type), intent(in) :: Time !< The current time. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. + type(CVMix_ddiff_cs), pointer :: CS !< This module's control structure. + + ! This include declares and sets the variable "version". +# include "version_variable.h" + + if (associated(CS)) then + call MOM_error(WARNING, "CVMix_ddiff_init called with an associated "// & + "control structure.") + return + endif + + ! Read parameters + call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_init, default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, & + "Parameterization of mixing due to double diffusion processes via CVMix", & + all_default=.not.CVMix_ddiff_init) + call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_init, & + "If true, turns on double diffusive processes via CVMix. "//& + "Note that double diffusive processes on viscosity are ignored "//& + "in CVMix, see http://cvmix.github.io/ for justification.", & + default=.false.) + + if (.not. CVMix_ddiff_init) return + allocate(CS) + + call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) + + call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, & + units="m", scale=GV%m_to_H, default=0.001, do_not_log=.True.) + + call openParameterBlock(param_file,'CVMIX_DDIFF') + + call get_param(param_file, mdl, "STRAT_PARAM_MAX", CS%strat_param_max, & + "The maximum value for the double dissusion stratification parameter", & + units="nondim", default=2.55) + + call get_param(param_file, mdl, "KAPPA_DDIFF_S", CS%kappa_ddiff_s, & + "Leading coefficient in formula for salt-fingering regime for salinity diffusion.", & + units="m2 s-1", default=1.0e-4, scale=US%m2_s_to_Z2_T) + + call get_param(param_file, mdl, "DDIFF_EXP1", CS%ddiff_exp1, & + "Interior exponent in salt-fingering regime formula.", & + units="nondim", default=1.0) + + call get_param(param_file, mdl, "DDIFF_EXP2", CS%ddiff_exp2, & + "Exterior exponent in salt-fingering regime formula.", & + units="nondim", default=3.0) + + call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM1", CS%kappa_ddiff_param1, & + "Exterior coefficient in diffusive convection regime.", & + units="nondim", default=0.909) + + call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM2", CS%kappa_ddiff_param2, & + "Middle coefficient in diffusive convection regime.", & + units="nondim", default=4.6) + + call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM3", CS%kappa_ddiff_param3, & + "Interior coefficient in diffusive convection regime.", & + units="nondim", default=-0.54) + + call get_param(param_file, mdl, "MOL_DIFF", CS%mol_diff, & + "Molecular diffusivity used in CVMix double diffusion.", & + units="m2 s-1", default=1.5e-6, scale=US%m2_s_to_Z2_T) + + call get_param(param_file, mdl, "DIFF_CONV_TYPE", CS%diff_conv_type, & + "type of diffusive convection to use. Options are Marmorino \n" //& + "and Caldwell 1976 (MC76) and Kelley 1988, 1990 (K90).", & + default="MC76") + + call closeParameterBlock(param_file) + + call cvmix_init_ddiff(strat_param_max=CS%strat_param_max, & + kappa_ddiff_s=US%Z2_T_to_m2_s*CS%kappa_ddiff_s, & + ddiff_exp1=CS%ddiff_exp1, & + ddiff_exp2=CS%ddiff_exp2, & + mol_diff=US%Z2_T_to_m2_s*CS%mol_diff, & + kappa_ddiff_param1=CS%kappa_ddiff_param1, & + kappa_ddiff_param2=CS%kappa_ddiff_param2, & + kappa_ddiff_param3=CS%kappa_ddiff_param3, & + diff_conv_type=CS%diff_conv_type) + +end function CVMix_ddiff_init + +!> Subroutine for computing vertical diffusion coefficients for the +!! double diffusion mixing parameterization. +subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) + + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: j !< Meridional grid index to work on. + ! Kd_T and Kd_S are intent inout because only one j-row is set here, but they are essentially outputs. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd_T !< Interface double diffusion diapycnal + !! diffusivity for temperature + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd_S !< Interface double diffusion diapycnal + !! diffusivity for salinity + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + type(CVMix_ddiff_cs), pointer :: CS !< The control structure returned + !! by a previous call to CVMix_ddiff_init. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: R_rho !< The density ratios at interfaces [nondim]. + + ! Local variables + real, dimension(SZK_(GV)) :: & + cellHeight, & !< Height of cell centers relative to the sea surface [H ~> m or kg m-2] + dRho_dT, & !< partial derivatives of density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & !< partial derivatives of density with salinity [R S-1 ~> kg m-3 ppt-1] + pres_int, & !< pressure at each interface [R L2 T-2 ~> Pa] + temp_int, & !< temp and at interfaces [C ~> degC] + salt_int, & !< salt at at interfaces [S ~> ppt] + alpha_dT, & !< alpha*dT across interfaces [kg m-3] + beta_dS, & !< beta*dS across interfaces [kg m-3] + dT, & !< temperature difference between adjacent layers [C ~> degC] + dS !< salinity difference between adjacent layers [S ~> ppt] + real, dimension(SZK_(GV)+1) :: & + Kd1_T, & !< Diapycanal diffusivity of temperature [m2 s-1]. + Kd1_S !< Diapycanal diffusivity of salinity [m2 s-1]. + + real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces relative to the sea surface [H ~> m or kg m-2] + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [H ~> m or kg m-2] + integer :: i, k + + ! initialize dummy variables + pres_int(:) = 0.0; temp_int(:) = 0.0; salt_int(:) = 0.0 + alpha_dT(:) = 0.0; beta_dS(:) = 0.0; dRho_dT(:) = 0.0 + dRho_dS(:) = 0.0; dT(:) = 0.0; dS(:) = 0.0 + + + ! GMM, I am leaving some code commented below. We need to pass BLD to + ! this subroutine to avoid adding diffusivity above that. This needs + ! to be done once we re-structure the order of the calls. + !if (.not. associated(hbl)) then + ! allocate(hbl(SZI_(G), SZJ_(G))); + ! hbl(:,:) = 0.0 + !endif + + do i = G%isc, G%iec + + ! skip calling at land points + if (G%mask2dT(i,j) == 0.) cycle + + pres_int(1) = 0. ; if (associated(tv%p_surf)) pres_int(1) = tv%p_surf(i,j) + ! we don't have SST and SSS, so let's use values at top-most layer + temp_int(1) = tv%T(i,j,1); salt_int(1) = tv%S(i,j,1) + do K=2,GV%ke + ! pressure at interface + pres_int(K) = pres_int(K-1) + (GV%g_Earth * GV%H_to_RZ) * h(i,j,k-1) + ! temp and salt at interface + ! for temp: (t1*h1 + t2*h2)/(h1+h2) + temp_int(K) = (tv%T(i,j,k-1)*h(i,j,k-1) + tv%T(i,j,k)*h(i,j,k)) / (h(i,j,k-1)+h(i,j,k)) + salt_int(K) = (tv%S(i,j,k-1)*h(i,j,k-1) + tv%S(i,j,k)*h(i,j,k)) / (h(i,j,k-1)+h(i,j,k)) + ! dT and dS + dT(K) = (tv%T(i,j,k-1)-tv%T(i,j,k)) + dS(K) = (tv%S(i,j,k-1)-tv%S(i,j,k)) + enddo ! k-loop finishes + + call calculate_density_derivs(temp_int, salt_int, pres_int, drho_dT, drho_dS, tv%eqn_of_state) + + ! The "-1.0" below is needed so that the following criteria is satisfied: + ! if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then "salt finger" + ! if ((alpha_dT < 0.) .and. (beta_dS < 0.) .and. (alpha_dT > beta_dS)) then "diffusive convection" + do k=1,GV%ke + alpha_dT(k) = -1.0*US%R_to_kg_m3*drho_dT(k) * dT(k) + beta_dS(k) = US%R_to_kg_m3*drho_dS(k) * dS(k) + enddo + + if (present(R_rho)) then + do k=1,GV%ke + ! Set R_rho using Adcroft's rule of reciprocals. + R_rho(i,j,k) = 0.0 ; if (abs(beta_dS(k)) > 0.0) R_rho(i,j,k) = alpha_dT(k) / beta_dS(k) + ! avoid NaN's again for safety, perhaps unnecessarily. + if (R_rho(i,j,k) /= R_rho(i,j,k)) R_rho(i,j,k) = 0.0 + enddo + endif + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0.0 + ! compute heights at cell center and interfaces + do k=1,GV%ke + dh = h(i,j,k) ! Nominal thickness to use for increment, in height units + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + enddo + + ! gets index of the level and interface above hbl + !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, GV%Z_to_H*hbl(i,j)) + + Kd1_T(:) = 0.0 ; Kd1_S(:) = 0.0 + call CVMix_coeffs_ddiff(Tdiff_out=Kd1_T(:), & + Sdiff_out=Kd1_S(:), & + strat_param_num=alpha_dT(:), & + strat_param_denom=beta_dS(:), & + nlev=GV%ke, & + max_nlev=GV%ke) + do K=1,GV%ke+1 + Kd_T(i,j,K) = GV%m2_s_to_HZ_T * Kd1_T(K) + Kd_S(i,j,K) = GV%m2_s_to_HZ_T * Kd1_S(K) + enddo + + ! Do not apply mixing due to convection within the boundary layer + !do k=1,kOBL + ! Kd_T(i,j,k) = 0.0 + ! Kd_S(i,j,k) = 0.0 + !enddo + + enddo ! i-loop + +end subroutine compute_ddiff_coeffs + +!> Reads the parameter "USE_CVMIX_DDIFF" and returns state. +!! This function allows other modules to know whether this parameterization will +!! be used without needing to duplicate the log entry. +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.) + +end function CVMix_ddiff_is_used + +!> Clear pointers and deallocate memory +! NOTE: Placeholder destructor +subroutine CVMix_ddiff_end(CS) + type(CVMix_ddiff_cs), pointer :: CS !< Control structure for this module that + !! will be deallocated in this subroutine +end subroutine CVMix_ddiff_end + +end module MOM_CVMix_ddiff diff --git a/parameterizations/vertical/MOM_CVMix_shear.F90 b/parameterizations/vertical/MOM_CVMix_shear.F90 new file mode 100644 index 0000000000..829318b606 --- /dev/null +++ b/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -0,0 +1,366 @@ +!> Interface to CVMix interior shear schemes +module MOM_CVMix_shear + +! This file is part of MOM6. See LICENSE.md for the license. + +!> \author Brandon Reichl + +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density +use CVMix_shear, only : CVMix_init_shear, CVMix_coeffs_shear +use MOM_kappa_shear, only : kappa_shear_is_used +implicit none ; private + +#include + +public calculate_CVMix_shear, CVMix_shear_init, CVMix_shear_is_used, CVMix_shear_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure including parameters for CVMix interior shear schemes. +type, public :: CVMix_shear_cs ; private + logical :: use_LMD94 !< Flags to use the LMD94 scheme + logical :: use_PP81 !< Flags to use Pacanowski and Philander (JPO 1981) + integer :: n_smooth_ri !< Number of times to smooth Ri using a 1-2-1 filter + real :: Ri_zero !< LMD94 critical Richardson number [nondim] + real :: Nu_zero !< LMD94 maximum interior diffusivity [Z2 T-1 ~> m2 s-1] + real :: KPP_exp !< Exponent of unitless factor of diffusivities + !! for KPP internal shear mixing scheme [nondim] + real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [T-2 ~> s-2] + real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency [T-2 ~> s-2] + real, allocatable, dimension(:,:,:) :: ri_grad !< Gradient Richardson number [nondim] + real, allocatable, dimension(:,:,:) :: ri_grad_orig !< Gradient Richardson number + !! after smoothing [nondim] + character(10) :: Mix_Scheme !< Mixing scheme name (string) + + type(diag_ctrl), pointer :: diag => NULL() !< Pointer to the diagnostics control structure + !>@{ Diagnostic handles + integer :: id_N2 = -1, id_S2 = -1, id_ri_grad = -1, id_kv = -1, id_kd = -1 + integer :: id_ri_grad_orig = -1 + !>@} + +end type CVMix_shear_cs + +character(len=40) :: mdl = "MOM_CVMix_shear" !< This module's name. + +contains + +!> Subroutine for calculating (internal) vertical diffusivities/viscosities +subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_H !< Initial zonal velocity on T points [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: v_H !< Initial meridional velocity on T + !! points [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: kd !< The vertical diffusivity at each interface + !! (not layer!) [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: kv !< The vertical viscosity at each interface + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] + type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous + !! call to CVMix_shear_init. + ! Local variables + integer :: i, j, k, kk, km1, s + real :: GoRho ! Gravitational acceleration divided by density [Z T-2 R-1 ~> m4 s-2 kg-1] + real :: pref ! Interface pressures [R L2 T-2 ~> Pa] + real :: DU, DV ! Velocity differences [L T-1 ~> m s-1] + real :: dz_int ! Grid spacing around an interface [Z ~> m] + real :: N2 ! Buoyancy frequency at an interface [T-2 ~> s-2] + real :: S2 ! Shear squared at an interface [T-2 ~> s-2] + real :: dummy ! A dummy variable [nondim] + real :: dRho ! Buoyancy differences [Z T-2 ~> m s-2] + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] + real, dimension(2*(GV%ke)) :: pres_1d ! A column of interface pressures [R L2 T-2 ~> Pa] + real, dimension(2*(GV%ke)) :: temp_1d ! A column of temperatures [C ~> degC] + real, dimension(2*(GV%ke)) :: salt_1d ! A column of salinities [S ~> ppt] + real, dimension(2*(GV%ke)) :: rho_1d ! A column of densities at interface pressures [R ~> kg m-3] + real, dimension(GV%ke+1) :: Ri_Grad !< Gradient Richardson number [nondim] + real, dimension(GV%ke+1) :: Ri_Grad_prev !< Gradient Richardson number before s.th smoothing iteration [nondim] + real, dimension(GV%ke+1) :: Kvisc !< Vertical viscosity at interfaces [m2 s-1] + real, dimension(GV%ke+1) :: Kdiff !< Diapycnal diffusivity at interfaces [m2 s-1] + real :: epsln !< Threshold to identify vanished layers [H ~> m or kg m-2] + + ! some constants + GoRho = US%L_to_Z**2 * GV%g_Earth / GV%Rho0 + epsln = 1.e-10 * GV%m_to_H + + do j = G%jsc, G%jec + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + do i = G%isc, G%iec + + ! skip calling for land points + if (G%mask2dT(i,j)==0.) cycle + + ! Richardson number computed for each cell in a column. + pRef = 0. ; if (associated(tv%p_surf)) pRef = tv%p_surf(i,j) + Ri_Grad(:)=1.e8 !Initialize w/ large Richardson value + do k=1,GV%ke + ! pressure, temp, and saln for EOS + ! kk+1 = k fields + ! kk+2 = km1 fields + km1 = max(1, k-1) + kk = 2*(k-1) + pres_1D(kk+1) = pRef + pres_1D(kk+2) = pRef + Temp_1D(kk+1) = tv%T(i,j,k) + Temp_1D(kk+2) = tv%T(i,j,km1) + Salt_1D(kk+1) = tv%S(i,j,k) + Salt_1D(kk+2) = tv%S(i,j,km1) + + ! pRef is pressure at interface between k and km1. + ! iterate pRef for next pass through k-loop. + pRef = pRef + (GV%g_Earth * GV%H_to_RZ) * h(i,j,k) + + enddo ! k-loop finishes + + ! compute in-situ density [R ~> kg m-3] + call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, tv%eqn_of_state) + + ! N2 (can be negative) on interface + do k = 1, GV%ke + km1 = max(1, k-1) + kk = 2*(k-1) + DU = u_h(i,j,k) - u_h(i,j,km1) + DV = v_h(i,j,k) - v_h(i,j,km1) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + dRho = GoRho * (rho_1D(kk+1) - rho_1D(kk+2)) + else + dRho = (US%L_to_Z**2 * GV%g_Earth) * (rho_1D(kk+1) - rho_1D(kk+2)) / (0.5*(rho_1D(kk+1) + rho_1D(kk+2))) + endif + dz_int = 0.5*(dz(i,km1) + dz(i,k)) + GV%dZ_subroundoff + N2 = DRHO / dz_int + S2 = US%L_to_Z**2*(DU*DU + DV*DV) / (dz_int*dz_int) + Ri_Grad(k) = max(0., N2) / max(S2, 1.e-10*US%T_to_s**2) + + ! fill 3d arrays, if user asks for diagnostics + if (CS%id_N2 > 0) CS%N2(i,j,k) = N2 + if (CS%id_S2 > 0) CS%S2(i,j,k) = S2 + + enddo + + Ri_grad(GV%ke+1) = Ri_grad(GV%ke) + + if (CS%n_smooth_ri > 0) then + + if (CS%id_ri_grad_orig > 0) CS%ri_grad_orig(i,j,:) = Ri_Grad(:) + + ! 1) fill Ri_grad in vanished layers with adjacent value + do k = 2, GV%ke + if (h(i,j,k) <= epsln) Ri_grad(k) = Ri_grad(k-1) + enddo + + Ri_grad(GV%ke+1) = Ri_grad(GV%ke) + + do s=1,CS%n_smooth_ri + + Ri_Grad_prev(:) = Ri_Grad(:) + + ! 2) vertically smooth Ri with 1-2-1 filter + dummy = 0.25 * Ri_grad_prev(2) + do k = 3, GV%ke + Ri_Grad(k) = dummy + 0.5 * Ri_Grad_prev(k) + 0.25 * Ri_grad_prev(k+1) + dummy = 0.25 * Ri_grad(k) + enddo + enddo + + Ri_grad(GV%ke+1) = Ri_grad(GV%ke) + + endif + + if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) + + do K=1,GV%ke+1 + Kvisc(K) = GV%HZ_T_to_m2_s * kv(i,j,K) + Kdiff(K) = GV%HZ_T_to_m2_s * kd(i,j,K) + enddo + + ! Call to CVMix wrapper for computing interior mixing coefficients. + call CVMix_coeffs_shear(Mdiff_out=Kvisc(:), & + Tdiff_out=Kdiff(:), & + RICH=Ri_Grad(:), & + nlev=GV%ke, & + max_nlev=GV%ke) + do K=1,GV%ke+1 + kv(i,j,K) = GV%m2_s_to_HZ_T * Kvisc(K) + kd(i,j,K) = GV%m2_s_to_HZ_T * Kdiff(K) + enddo + enddo + enddo + + ! write diagnostics + if (CS%id_kd > 0) call post_data(CS%id_kd, kd, CS%diag) + if (CS%id_kv > 0) call post_data(CS%id_kv, kv, CS%diag) + if (CS%id_N2 > 0) call post_data(CS%id_N2, CS%N2, CS%diag) + if (CS%id_S2 > 0) call post_data(CS%id_S2, CS%S2, CS%diag) + if (CS%id_ri_grad > 0) call post_data(CS%id_ri_grad, CS%ri_grad, CS%diag) + if (CS%id_ri_grad_orig > 0) call post_data(CS%id_ri_grad_orig ,CS%ri_grad_orig, CS%diag) + +end subroutine calculate_CVMix_shear + + +!> Initialized the CVMix internal shear mixing routine. +!! \todo Does this note require emphasis? +!! \note *This is where we test to make sure multiple internal shear +!! mixing routines (including JHL) are not enabled at the same time.* +!! (returns) CVMix_shear_init - True if module is to be used, False otherwise +logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< The current time. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. + type(CVMix_shear_cs), pointer :: CS !< This module's control structure. + ! Local variables + integer :: NumberTrue=0 + logical :: use_JHL + logical :: use_LMD94 + logical :: use_PP81 + +! This include declares and sets the variable "version". +#include "version_variable.h" + + if (associated(CS)) then + call MOM_error(WARNING, "CVMix_shear_init called with an associated "// & + "control structure.") + return + endif + +! Set default, read and log parameters + call get_param(param_file, mdl, "USE_LMD94", use_LMD94, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_PP81", use_PP81, default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, & + "Parameterization of shear-driven turbulence via CVMix (various options)", & + all_default=.not.(use_PP81.or.use_LMD94)) + call get_param(param_file, mdl, "USE_LMD94", use_LMD94, & + "If true, use the Large-McWilliams-Doney (JGR 1994) "//& + "shear mixing parameterization.", default=.false.) + if (use_LMD94) & + NumberTrue=NumberTrue + 1 + call get_param(param_file, mdl, "USE_PP81", use_PP81, & + "If true, use the Pacanowski and Philander (JPO 1981) "//& + "shear mixing parameterization.", default=.false.) + if (use_PP81) & + NumberTrue = NumberTrue + 1 + use_JHL=kappa_shear_is_used(param_file) + if (use_JHL) NumberTrue = NumberTrue + 1 + ! After testing for interior schemes, make sure only 0 or 1 are enabled. + ! Otherwise, warn user and kill job. + if ((NumberTrue) > 1) then + call MOM_error(FATAL, 'MOM_CVMix_shear_init: '// & + 'Multiple shear driven internal mixing schemes selected,'//& + ' please disable all but one scheme to proceed.') + endif + + CVMix_shear_init = use_PP81 .or. use_LMD94 + + ! Forego remainder of initialization if not using this scheme + if (.not. CVMix_shear_init) return + + allocate(CS) + CS%use_LMD94 = use_LMD94 + CS%use_PP81 = use_PP81 + if (use_LMD94) & + CS%Mix_Scheme = 'KPP' + if (use_PP81) & + CS%Mix_Scheme = 'PP' + + call get_param(param_file, mdl, "NU_ZERO", CS%Nu_Zero, & + "Leading coefficient in KPP shear mixing.", & + units="m2 s-1", default=5.e-3, scale=US%m2_s_to_Z2_T) + call get_param(param_file, mdl, "RI_ZERO", CS%Ri_Zero, & + "Critical Richardson for KPP shear mixing, "// & + "NOTE this the internal mixing and this is "// & + "not for setting the boundary layer depth.", & + units="nondim", default=0.8) + call get_param(param_file, mdl, "KPP_EXP", CS%KPP_exp, & + "Exponent of unitless factor of diffusivities, "// & + "for KPP internal shear mixing scheme.", & + units="nondim", default=3.0) + call get_param(param_file, mdl, "N_SMOOTH_RI", CS%n_smooth_ri, & + "If > 0, vertically smooth the Richardson "// & + "number by applying a 1-2-1 filter N_SMOOTH_RI times.", & + default=0) + call cvmix_init_shear(mix_scheme=CS%Mix_Scheme, & + KPP_nu_zero=US%Z2_T_to_m2_s*CS%Nu_Zero, & + KPP_Ri_zero=CS%Ri_zero, & + KPP_exp=CS%KPP_exp) + + ! Register diagnostics; allocation and initialization + CS%diag => diag + + CS%id_N2 = register_diag_field('ocean_model', 'N2_shear', diag%axesTi, Time, & + 'Square of Brunt-Vaisala frequency used by MOM_CVMix_shear module', '1/s2', conversion=US%s_to_T**2) + if (CS%id_N2 > 0) then + allocate( CS%N2( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) + endif + + CS%id_S2 = register_diag_field('ocean_model', 'S2_shear', diag%axesTi, Time, & + 'Square of vertical shear used by MOM_CVMix_shear module','1/s2', conversion=US%s_to_T**2) + if (CS%id_S2 > 0) then + allocate( CS%S2( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) + endif + + CS%id_ri_grad = register_diag_field('ocean_model', 'ri_grad_shear', diag%axesTi, Time, & + 'Gradient Richarson number used by MOM_CVMix_shear module','nondim') + if (CS%id_ri_grad > 0) then !Initialize w/ large Richardson value + allocate( CS%ri_grad( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) + endif + + if (CS%n_smooth_ri > 0) then + CS%id_ri_grad_orig = register_diag_field('ocean_model', 'ri_grad_shear_orig', & + diag%axesTi, Time, & + 'Original gradient Richarson number, before smoothing was applied. This is '//& + 'part of the MOM_CVMix_shear module and only available when N_SMOOTH_RI > 0','nondim') + endif + if (CS%id_ri_grad_orig > 0 .or. CS%n_smooth_ri > 0) then !Initialize w/ large Richardson value + allocate( CS%ri_grad_orig( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) + endif + + CS%id_kd = register_diag_field('ocean_model', 'kd_shear_CVMix', diag%axesTi, Time, & + 'Vertical diffusivity added by MOM_CVMix_shear module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_kv = register_diag_field('ocean_model', 'kv_shear_CVMix', diag%axesTi, Time, & + 'Vertical viscosity added by MOM_CVMix_shear module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + +end function CVMix_shear_init + +!> Reads the parameters "USE_LMD94" and "USE_PP81" and returns true if either is true. +!! This function allows other modules to know whether this parameterization will +!! be used without needing to duplicate the log entry. +logical function CVMix_shear_is_used(param_file) + type(param_file_type), intent(in) :: param_file !< Run-time parameter files handle. + ! Local variables + logical :: LMD94, PP81 + call get_param(param_file, mdl, "USE_LMD94", LMD94, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_PP81", PP81, & + default=.false., do_not_log=.true.) + CVMix_shear_is_used = (LMD94 .or. PP81) +end function CVMix_shear_is_used + +!> Clear pointers and deallocate memory +subroutine CVMix_shear_end(CS) + type(CVMix_shear_cs), intent(inout) :: CS !< Control structure for this module that + !! will be deallocated in this subroutine + if (CS%id_N2 > 0) deallocate(CS%N2) + if (CS%id_S2 > 0) deallocate(CS%S2) + if (CS%id_ri_grad > 0) deallocate(CS%ri_grad) +end subroutine CVMix_shear_end + +end module MOM_CVMix_shear diff --git a/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/parameterizations/vertical/MOM_bkgnd_mixing.F90 new file mode 100644 index 0000000000..ee04f3f195 --- /dev/null +++ b/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -0,0 +1,550 @@ +!> Interface to background mixing schemes, including the Bryan and Lewis (1979) +!! which is applied via CVMix. + +module MOM_bkgnd_mixing + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : hchksum +use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field +use MOM_diag_mediator, only : post_data +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type +use MOM_intrinsic_functions, only : invcosh +use CVMix_background, only : CVMix_init_bkgnd, CVMix_coeffs_bkgnd + +implicit none ; private + +#include + +public bkgnd_mixing_init +public bkgnd_mixing_end +public calculate_bkgnd_mixing + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure including parameters for this module. +type, public :: bkgnd_mixing_cs ; private + + ! Parameters + real :: Bryan_Lewis_c1 !< The vertical diffusivity values for Bryan-Lewis profile + !! at |z|=D [Z2 T-1 ~> m2 s-1] + real :: Bryan_Lewis_c2 !< The amplitude of variation in diffusivity for the + !! Bryan-Lewis diffusivity profile [Z2 T-1 ~> m2 s-1] + real :: Bryan_Lewis_c3 !< The inverse length scale for transition region in the + !! Bryan-Lewis diffusivity profile [Z-1 ~> m-1] + real :: Bryan_Lewis_c4 !< The depth where diffusivity is Bryan_Lewis_bl1 in the + !! Bryan-Lewis profile [Z ~> m] + real :: bckgrnd_vdc1 !< Background diffusivity (Ledwell) when + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: bckgrnd_vdc_eq !< Equatorial diffusivity (Gregg) when + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: bckgrnd_vdc_psim !< Max. PSI induced diffusivity (MacKinnon) when + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: bckgrnd_vdc_Banda !< Banda Sea diffusivity (Gordon) when + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_min !< minimum diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd !< interior diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. + real :: N0_2Omega !< ratio of the typical Buoyancy frequency to + !! twice the Earth's rotation period, used with the + !! Henyey scaling from the mixing [nondim] + real :: prandtl_bkgnd !< Turbulent Prandtl number used to convert + !! vertical background diffusivity into viscosity [nondim] + real :: Kd_tanh_lat_scale !< A nondimensional scaling for the range of + !! diffusivities with Kd_tanh_lat_fn [nondim]. Valid values + !! are in the range of -2 to 2; 0.4 reproduces CM2M. + real :: Kd_tot_ml !< The mixed layer diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + !! when no other physically based mixed layer turbulence + !! parameterization is being used. + real :: Hmix !< mixed layer thickness [H ~> m or kg m-2] when no physically based + !! ocean surface boundary layer parameterization is used. + logical :: Kd_tanh_lat_fn !< If true, use the tanh dependence of Kd_sfc on + !! latitude, like GFDL CM2.1/CM2M. There is no + !! physical justification for this form, and it can + !! not be used with Henyey_IGW_background. + logical :: Bryan_Lewis_diffusivity!< If true, background vertical diffusivity + !! uses Bryan-Lewis (1979) like tanh profile. + logical :: horiz_varying_background !< If true, apply vertically uniform, latitude-dependent + !! background diffusivity, as described in Danabasoglu et al., 2012 + logical :: Henyey_IGW_background !< If true, use a simplified variant of the + !! Henyey et al, JGR (1986) latitudinal scaling for the background diapycnal diffusivity, + !! which gives a marked decrease in the diffusivity near the equator. The simplification + !! here is to assume that the in-situ stratification is the same as the reference stratificaiton. + logical :: physical_OBL_scheme !< If true, a physically-based scheme is used to determine mixing in the + !! ocean's surface boundary layer, such as ePBL, KPP, or a refined bulk mixed layer scheme. + logical :: Kd_via_Kdml_bug !< If true and KDML /= KD and a number of other higher precedence + !! options are not used, the background diffusivity is set incorrectly using a + !! bug that was introduced in March, 2018. + logical :: debug !< If true, turn on debugging in this module + ! Diagnostic handles and pointers + type(diag_ctrl), pointer :: diag => NULL() !< A structure that regulates diagnostic output + + character(len=40) :: bkgnd_scheme_str = "none" !< Background scheme identifier + +end type bkgnd_mixing_cs + +character(len=40) :: mdl = "MOM_bkgnd_mixing" !< This module's name. + +contains + +!> Initialize the background mixing routine. +subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL_scheme) + + type(time_type), intent(in) :: Time !< The current time. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. + type(bkgnd_mixing_cs), pointer :: CS !< This module's control structure. + logical, intent(in) :: physical_OBL_scheme !< If true, a physically based + !! parameterization (like KPP or ePBL or a bulk mixed + !! layer) is used outside of set_diffusivity to + !! specify the mixing that occurs in the ocean's + !! surface boundary layer. + + ! Local variables + real :: Kv ! The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s] - read to set Prandtl + ! number unless it is provided as a parameter + real :: Kd_z ! The background diapycnal diffusivity in [Z2 T-1 ~> m2 s-1] for use + ! in setting the default for other diffusivities. + real :: prandtl_bkgnd_comp ! Kv/CS%Kd [nondim]. Gets compared with user-specified prandtl_bkgnd. + + ! This include declares and sets the variable "version". +# include "version_variable.h" + + if (associated(CS)) then + call MOM_error(WARNING, "bkgnd_mixing_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ! Read parameters + call log_version(param_file, mdl, version, & + "Adding static vertical background mixing coefficients") + + call get_param(param_file, mdl, "KD", Kd_z, & + "The background diapycnal diffusivity of density in the "//& + "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& + "may be used.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) + CS%Kd = (GV%m2_s_to_HZ_T*US%Z2_T_to_m2_s) * Kd_z + + call get_param(param_file, mdl, "KV", Kv, & + "The background kinematic viscosity in the interior. "//& + "The molecular value, ~1e-6 m2 s-1, may be used.", & + units="m2 s-1", scale=GV%m2_s_to_HZ_T, fail_if_missing=.true.) + + call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & + "The minimum diapycnal diffusivity.", & + units="m2 s-1", default=0.01*Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T) + + ! The following is needed to set one of the choices of vertical background mixing + + CS%physical_OBL_scheme = physical_OBL_scheme + if (CS%physical_OBL_scheme) then + ! Check that Kdml is not set when using bulk mixed layer + call get_param(param_file, mdl, "KDML", CS%Kd_tot_ml, & + units="m2 s-1", default=-1., scale=GV%m2_s_to_HZ_T, do_not_log=.true.) + if (CS%Kd_tot_ml>0.) call MOM_error(FATAL, & + "bkgnd_mixing_init: KDML is a depricated parameter that should not be used.") + call get_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml, & + units="m2 s-1", default=-1.0, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) + if (CS%Kd_tot_ml>0.) call MOM_error(FATAL, & + "bkgnd_mixing_init: KD_ML_TOT cannot be set when using a physically based ocean "//& + "boundary layer mixing parameterization.") + CS%Kd_tot_ml = CS%Kd ! This is not used with a bulk mixed layer, but also cannot be a NaN. + else + call get_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml, & + "The total diapcynal diffusivity in the surface mixed layer when there is "//& + "not a physically based parameterization of mixing in the mixed layer, such "//& + "as bulk mixed layer or KPP or ePBL.", & + units="m2 s-1", default=Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) + if (abs(CS%Kd_tot_ml - CS%Kd) <= 1.0e-15*abs(CS%Kd)) then + call get_param(param_file, mdl, "KDML", CS%Kd_tot_ml, & + "If BULKMIXEDLAYER is false, KDML is the elevated "//& + "diapycnal diffusivity in the topmost HMIX of fluid. "//& + "KDML is only used if BULKMIXEDLAYER is false.", & + units="m2 s-1", default=Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) + if (abs(CS%Kd_tot_ml - CS%Kd) > 1.0e-15*abs(CS%Kd)) & + call MOM_error(WARNING, "KDML is a depricated parameter. Use KD_ML_TOT instead.") + endif + call log_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml, & + "The total diapcynal diffusivity in the surface mixed layer when there is "//& + "not a physically based parameterization of mixing in the mixed layer, such "//& + "as bulk mixed layer or KPP or ePBL.", & + units="m2 s-1", default=Kd_z*US%Z2_T_to_m2_s, unscale=GV%HZ_T_to_m2_s) + + call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & + "The prescribed depth over which the near-surface "//& + "viscosity and diffusivity are elevated when the bulk "//& + "mixed layer is not used.", units="m", scale=GV%m_to_H, fail_if_missing=.true.) + endif + + call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) + +! call openParameterBlock(param_file,'MOM_BACKGROUND_MIXING') + + call get_param(param_file, mdl, "BRYAN_LEWIS_DIFFUSIVITY", CS%Bryan_Lewis_diffusivity, & + "If true, use a Bryan & Lewis (JGR 1979) like tanh "//& + "profile of background diapycnal diffusivity with depth. "//& + "This is done via CVMix.", default=.false.) + + if (CS%Bryan_Lewis_diffusivity) then + call check_bkgnd_scheme(CS, "BRYAN_LEWIS_DIFFUSIVITY") + + call get_param(param_file, mdl, "BRYAN_LEWIS_C1", CS%Bryan_Lewis_c1, & + "The vertical diffusivity values for Bryan-Lewis profile at |z|=D.", & + units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) + + call get_param(param_file, mdl, "BRYAN_LEWIS_C2", CS%Bryan_Lewis_c2, & + "The amplitude of variation in diffusivity for the Bryan-Lewis profile", & + units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) + + call get_param(param_file, mdl, "BRYAN_LEWIS_C3", CS%Bryan_Lewis_c3, & + "The inverse length scale for transition region in the Bryan-Lewis profile", & + units="m-1", scale=US%Z_to_m, fail_if_missing=.true.) + + call get_param(param_file, mdl, "BRYAN_LEWIS_C4", CS%Bryan_Lewis_c4, & + "The depth where diffusivity is BRYAN_LEWIS_C1 in the Bryan-Lewis profile",& + units="m", scale=US%m_to_Z, fail_if_missing=.true.) + + endif ! CS%Bryan_Lewis_diffusivity + + call get_param(param_file, mdl, "HORIZ_VARYING_BACKGROUND", CS%horiz_varying_background, & + "If true, apply vertically uniform, latitude-dependent background "//& + "diffusivity, as described in Danabasoglu et al., 2012", & + default=.false.) + + if (CS%horiz_varying_background) then + call check_bkgnd_scheme(CS, "HORIZ_VARYING_BACKGROUND") + + call get_param(param_file, mdl, "BCKGRND_VDC1", CS%bckgrnd_vdc1, & + "Background diffusivity (Ledwell) when HORIZ_VARYING_BACKGROUND=True", & + units="m2 s-1",default = 0.16e-04, scale=GV%m2_s_to_HZ_T) + + call get_param(param_file, mdl, "BCKGRND_VDC_EQ", CS%bckgrnd_vdc_eq, & + "Equatorial diffusivity (Gregg) when HORIZ_VARYING_BACKGROUND=True", & + units="m2 s-1",default = 0.01e-04, scale=GV%m2_s_to_HZ_T) + + call get_param(param_file, mdl, "BCKGRND_VDC_PSIM", CS%bckgrnd_vdc_psim, & + "Max. PSI induced diffusivity (MacKinnon) when HORIZ_VARYING_BACKGROUND=True", & + units="m2 s-1",default = 0.13e-4, scale=GV%m2_s_to_HZ_T) + + call get_param(param_file, mdl, "BCKGRND_VDC_BAN", CS%bckgrnd_vdc_Banda, & + "Banda Sea diffusivity (Gordon) when HORIZ_VARYING_BACKGROUND=True", & + units="m2 s-1",default = 1.0e-4, scale=GV%m2_s_to_HZ_T) + endif + + call get_param(param_file, mdl, "PRANDTL_BKGND", CS%prandtl_bkgnd, & + "Turbulent Prandtl number used to convert vertical "//& + "background diffusivities into viscosities.", & + units="nondim", default=1.0) + + if (CS%Bryan_Lewis_diffusivity .or. CS%horiz_varying_background) then + prandtl_bkgnd_comp = CS%prandtl_bkgnd + if (CS%Kd /= 0.0) prandtl_bkgnd_comp = Kv / CS%Kd + + if ( abs(CS%prandtl_bkgnd - prandtl_bkgnd_comp)>1.e-14) then + call MOM_error(FATAL, "bkgnd_mixing_init: The provided KD, KV and PRANDTL_BKGND values "//& + "are incompatible. The following must hold: KD*PRANDTL_BKGND==KV") + endif + endif + + call get_param(param_file, mdl, "HENYEY_IGW_BACKGROUND", CS%Henyey_IGW_background, & + "If true, use a latitude-dependent scaling for the near "//& + "surface background diffusivity, as described in "//& + "Harrison & Hallberg, JPO 2008.", default=.false.) + if (CS%Henyey_IGW_background) call check_bkgnd_scheme(CS, "HENYEY_IGW_BACKGROUND") + + if (CS%Kd>0.0 .and. (trim(CS%bkgnd_scheme_str)=="BRYAN_LEWIS_DIFFUSIVITY" .or.& + trim(CS%bkgnd_scheme_str)=="HORIZ_VARYING_BACKGROUND" )) then + call MOM_error(WARNING, "bkgnd_mixing_init: a nonzero constant background "//& + "diffusivity (KD) is specified along with "//trim(CS%bkgnd_scheme_str)) + endif + + if (CS%Henyey_IGW_background) then + call get_param(param_file, mdl, "HENYEY_N0_2OMEGA", CS%N0_2Omega, & + "The ratio of the typical Buoyancy frequency to twice "//& + "the Earth's rotation period, used with the Henyey "//& + "scaling from the mixing.", units="nondim", default=20.0) + call get_param(param_file, mdl, "OMEGA", CS%omega, & + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) + endif + + call get_param(param_file, mdl, "KD_TANH_LAT_FN", CS%Kd_tanh_lat_fn, & + "If true, use a tanh dependence of Kd_sfc on latitude, "//& + "like CM2.1/CM2M. There is no physical justification "//& + "for this form, and it can not be used with "//& + "HENYEY_IGW_BACKGROUND.", default=.false.) + + if (CS%Kd_tanh_lat_fn) & + call get_param(param_file, mdl, "KD_TANH_LAT_SCALE", CS%Kd_tanh_lat_scale, & + "A nondimensional scaling for the range ofdiffusivities "//& + "with KD_TANH_LAT_FN. Valid values are in the range of "//& + "-2 to 2; 0.4 reproduces CM2M.", units="nondim", default=0.0) + + if (CS%Henyey_IGW_background .and. CS%Kd_tanh_lat_fn) call MOM_error(FATAL, & + "MOM_bkgnd_mixing: KD_TANH_LAT_FN can not be used with HENYEY_IGW_BACKGROUND.") + + CS%Kd_via_Kdml_bug = .false. + if ((CS%Kd /= CS%Kd_tot_ml) .and. .not.(CS%Kd_tanh_lat_fn .or. CS%physical_OBL_scheme .or. & + CS%Henyey_IGW_background .or. & + CS%horiz_varying_background .or. CS%Bryan_Lewis_diffusivity)) then + call get_param(param_file, mdl, "KD_BACKGROUND_VIA_KDML_BUG", CS%Kd_via_Kdml_bug, & + "If true and KDML /= KD and several other conditions apply, the background "//& + "diffusivity is set incorrectly using a bug that was introduced in March, 2018.", & + default=.false.) ! This parameter should be obsoleted. + endif + +! call closeParameterBlock(param_file) + +end subroutine bkgnd_mixing_init + +!> Calculates the vertical background diffusivities/viscosities +subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, GV, US, CS) + + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< squared buoyancy frequency associated + !! with layers [T-2 ~> s-2] + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: Kd_lay !< The background diapycnal diffusivity of each + !! layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_int !< The background diapycnal diffusivity of each + !! interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kv_bkgnd !< The background vertical viscosity at + !! each interface [H Z T-1 ~> m2 s-1 or Pa s] + integer, intent(in) :: j !< Meridional grid index + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(bkgnd_mixing_cs), pointer :: CS !< The control structure returned by + !! a previous call to bkgnd_mixing_init. + + ! local variables + real, dimension(SZK_(GV)+1) :: depth_int !< Distance from surface of the interfaces [m] + real, dimension(SZK_(GV)+1) :: Kd_col !< Diffusivities at the interfaces [m2 s-1] + real, dimension(SZK_(GV)+1) :: Kv_col !< Viscosities at the interfaces [m2 s-1] + real, dimension(SZI_(G)) :: Kd_sfc !< Surface value of the diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G)) :: depth !< Distance from surface of an interface [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)) :: dz !< Height change across layers [Z ~> m] + real :: depth_c !< depth of the center of a layer [H ~> m or kg m-2] + real :: I_Hmix !< inverse of fixed mixed layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: I_2Omega !< 1/(2 Omega) [T ~> s] + real :: N_2Omega ! The ratio of the stratification to the Earth's rotation rate [nondim] + real :: N02_N2 ! The ratio a reference stratification to the actual stratification [nondim] + real :: I_x30 !< 2/acos(2) = 1/(sin(30 deg) * acosh(1/sin(30 deg))) [nondim] + real :: deg_to_rad !< factor converting degrees to radians [radians degree-1], pi/180. + real :: abs_sinlat !< absolute value of sine of latitude [nondim] + real :: min_sinlat ! The minimum value of the sine of latitude [nondim] + real :: bckgrnd_vdc_psin !< PSI diffusivity in northern hemisphere [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: bckgrnd_vdc_psis !< PSI diffusivity in southern hemisphere [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + integer :: i, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + ! set some parameters + deg_to_rad = atan(1.0)/45.0 ! = PI/180 + min_sinlat = 1.e-10 + + ! Start with a constant value that may be replaced below. + Kd_lay(:,:) = CS%Kd + Kv_bkgnd(:,:) = 0.0 + + ! Set up the background diffusivity. + if (CS%Bryan_Lewis_diffusivity) then + + call thickness_to_dz(h, tv, dz, j, G, GV) + + do i=is,ie + depth_int(1) = 0.0 + do k=2,nz+1 + depth_int(k) = depth_int(k-1) + US%Z_to_m*dz(i,k-1) + enddo + + call CVMix_init_bkgnd(max_nlev=nz, & + zw = depth_int(:), & !< interface depths relative to the surface in m, must be positive. + bl1 = US%Z2_T_to_m2_s*CS%Bryan_Lewis_c1, & + bl2 = US%Z2_T_to_m2_s*CS%Bryan_Lewis_c2, & + bl3 = US%m_to_Z*CS%Bryan_Lewis_c3, & + bl4 = US%Z_to_m*CS%Bryan_Lewis_c4, & + prandtl = CS%prandtl_bkgnd) + + Kd_col(:) = 0.0 ; Kv_col(:) = 0.0 ! Is this line necessary? + call CVMix_coeffs_bkgnd(Mdiff_out=Kv_col, Tdiff_out=Kd_col, nlev=nz, max_nlev=nz) + + ! Update Kd and Kv. + do K=1,nz+1 + Kv_bkgnd(i,K) = GV%m2_s_to_HZ_T * Kv_col(K) + Kd_int(i,K) = GV%m2_s_to_HZ_T*Kd_col(K) + enddo + do k=1,nz + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * GV%m2_s_to_HZ_T * (Kd_col(K) + Kd_col(K+1)) + enddo + enddo ! i loop + + elseif (CS%horiz_varying_background) then + !### Note that there are lots of hard-coded parameters (mostly latitudes and longitudes) here. + do i=is,ie + bckgrnd_vdc_psis = CS%bckgrnd_vdc_psim * exp(-(0.4*(G%geoLatT(i,j)+28.9))**2) + bckgrnd_vdc_psin = CS%bckgrnd_vdc_psim * exp(-(0.4*(G%geoLatT(i,j)-28.9))**2) + Kd_int(i,1) = (CS%bckgrnd_vdc_eq + bckgrnd_vdc_psin) + bckgrnd_vdc_psis + + if (G%geoLatT(i,j) < -10.0) then + Kd_int(i,1) = Kd_int(i,1) + CS%bckgrnd_vdc1 + elseif (G%geoLatT(i,j) <= 10.0) then + Kd_int(i,1) = Kd_int(i,1) + CS%bckgrnd_vdc1 * (G%geoLatT(i,j)/10.0)**2 + else + Kd_int(i,1) = Kd_int(i,1) + CS%bckgrnd_vdc1 + endif + + ! North Banda Sea + if ( (G%geoLatT(i,j) < -1.0) .and. (G%geoLatT(i,j) > -4.0) .and. & + ( mod(G%geoLonT(i,j)+360.0,360.0) > 103.0) .and. & + ( mod(G%geoLonT(i,j)+360.0,360.0) < 134.0) ) then + Kd_int(i,1) = CS%bckgrnd_vdc_Banda + endif + + ! Middle Banda Sea + if ( (G%geoLatT(i,j) <= -4.0) .and. (G%geoLatT(i,j) > -7.0) .and. & + ( mod(G%geoLonT(i,j)+360.0,360.0) > 106.0) .and. & + ( mod(G%geoLonT(i,j)+360.0,360.0) < 140.0) ) then + Kd_int(i,1) = CS%bckgrnd_vdc_Banda + endif + + ! South Banda Sea + if ( (G%geoLatT(i,j) <= -7.0) .and. (G%geoLatT(i,j) > -8.3) .and. & + ( mod(G%geoLonT(i,j)+360.0,360.0) > 111.0) .and. & + ( mod(G%geoLonT(i,j)+360.0,360.0) < 142.0) ) then + Kd_int(i,1) = CS%bckgrnd_vdc_Banda + endif + + enddo + ! Update interior values of Kd and Kv (uniform profile; no interpolation needed) + do K=1,nz+1 ; do i=is,ie + Kd_int(i,K) = Kd_int(i,1) + Kv_bkgnd(i,K) = Kd_int(i,1) * CS%prandtl_bkgnd + enddo ; enddo + do k=1,nz ; do i=is,ie + Kd_lay(i,k) = Kd_int(i,1) + enddo ; enddo + + else + ! Set a potentially spatially varying surface value of diffusivity. + if (CS%Henyey_IGW_background) then + I_x30 = 2.0 / invcosh(CS%N0_2Omega*2.0) ! This is evaluated at 30 deg. + do i=is,ie + abs_sinlat = abs(sin(G%geoLatT(i,j)*deg_to_rad)) + Kd_sfc(i) = max(CS%Kd_min, CS%Kd * & + ((abs_sinlat * invcosh(CS%N0_2Omega / max(min_sinlat, abs_sinlat))) * I_x30) ) + enddo + elseif (CS%Kd_tanh_lat_fn) then + do i=is,ie + ! The transition latitude and latitude range are hard-scaled here, since + ! this is not really intended for wide-spread use, but rather for + ! comparison with CM2M / CM2.1 settings. + Kd_sfc(i) = max(CS%Kd_min, CS%Kd * (1.0 + & + CS%Kd_tanh_lat_scale * 0.5*tanh((abs(G%geoLatT(i,j)) - 35.0)/5.0) )) + enddo + else ! Use a spatially constant surface value. + do i=is,ie + Kd_sfc(i) = CS%Kd + enddo + endif + + ! Now set background diffusivities based on these surface values, possibly with vertical structure. + if ((.not.CS%physical_OBL_scheme) .and. (CS%Kd /= CS%Kd_tot_ml)) then + ! This is a crude way to put in a diffusive boundary layer without an explicit boundary + ! layer turbulence scheme. It should not be used for any realistic ocean models. + I_Hmix = 1.0 / (CS%Hmix + GV%H_subroundoff) + do i=is,ie ; depth(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + depth_c = depth(i) + 0.5*h(i,j,k) + if (CS%Kd_via_Kdml_bug) then + ! These two lines should update Kd_lay, not Kd_int. They were correctly working on the + ! same variables until MOM6 commit 7a818716 (PR#750), which was added on March 26, 2018. + if (depth_c <= CS%Hmix) then ; Kd_int(i,K) = CS%Kd_tot_ml + elseif (depth_c >= 2.0*CS%Hmix) then ; Kd_int(i,K) = Kd_sfc(i) + else + Kd_lay(i,k) = ((Kd_sfc(i) - CS%Kd_tot_ml) * I_Hmix) * depth_c + (2.0*CS%Kd_tot_ml - Kd_sfc(i)) + endif + else + if (depth_c <= CS%Hmix) then ; Kd_lay(i,k) = CS%Kd_tot_ml + elseif (depth_c >= 2.0*CS%Hmix) then ; Kd_lay(i,k) = Kd_sfc(i) + else + Kd_lay(i,k) = ((Kd_sfc(i) - CS%Kd_tot_ml) * I_Hmix) * depth_c + (2.0*CS%Kd_tot_ml - Kd_sfc(i)) + endif + endif + + depth(i) = depth(i) + h(i,j,k) + enddo ; enddo + + else ! There is no vertical structure to the background diffusivity. + do k=1,nz ; do i=is,ie + Kd_lay(i,k) = Kd_sfc(i) + enddo ; enddo + endif + + ! Update Kd_int and Kv_bkgnd, based on Kd_lay. These might be just used for diagnostic purposes. + do i=is,ie + Kd_int(i,1) = 0.0; Kv_bkgnd(i,1) = 0.0 + Kd_int(i,nz+1) = 0.0; Kv_bkgnd(i,nz+1) = 0.0 + enddo + do K=2,nz ; do i=is,ie + Kd_int(i,K) = 0.5*(Kd_lay(i,k-1) + Kd_lay(i,k)) + Kv_bkgnd(i,K) = Kd_int(i,K) * CS%prandtl_bkgnd + enddo ; enddo + endif + +end subroutine calculate_bkgnd_mixing + +!> Reads the parameter "USE_CVMix_BACKGROUND" and returns state. +!! This function allows other modules to know whether this parameterization will +!! be used without needing to duplicate the log entry. +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.) + +end function CVMix_bkgnd_is_used + +!> Sets CS%bkgnd_scheme_str to check whether multiple background diffusivity schemes are activated. +!! The string is also for error/log messages. +subroutine check_bkgnd_scheme(CS, str) + type(bkgnd_mixing_cs), pointer :: CS !< Control structure + character(len=*), intent(in) :: str !< Background scheme identifier deducted from MOM_input + !! parameters + + if (trim(CS%bkgnd_scheme_str)=="none") then + CS%bkgnd_scheme_str = str + else + call MOM_error(FATAL, "bkgnd_mixing_init: Cannot activate both "//trim(str)//" and "//& + trim(CS%bkgnd_scheme_str)//".") + endif + +end subroutine + +!> Clear pointers and deallocate memory +subroutine bkgnd_mixing_end(CS) + type(bkgnd_mixing_cs), pointer :: CS !< Control structure for this module that + !! will be deallocated in this subroutine + + if (.not. associated(CS)) return + deallocate(CS) + +end subroutine bkgnd_mixing_end + + +end module MOM_bkgnd_mixing diff --git a/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/parameterizations/vertical/MOM_bulk_mixed_layer.F90 new file mode 100644 index 0000000000..f2b38c4a29 --- /dev/null +++ b/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -0,0 +1,4265 @@ +!> Build mixed layer parameterization +module MOM_bulk_mixed_layer + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc +use MOM_diag_mediator, only : time_type, diag_ctrl, diag_update_remap_grids +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : average_specific_vol, calculate_density_derivs +use MOM_EOS, only : calculate_spec_vol, calculate_specific_vol_derivs +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : extractFluxes1d, forcing, find_ustar +use MOM_grid, only : ocean_grid_type +use MOM_opacity, only : absorbRemainingSW, optics_type, extract_optics_slice +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public bulkmixedlayer, bulkmixedlayer_init + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> The control structure with parameters for the MOM_bulk_mixed_layer module +type, public :: bulkmixedlayer_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + integer :: nkml !< The number of layers in the mixed layer. + integer :: nkbl !< The number of buffer layers. + integer :: nsw !< The number of bands of penetrating shortwave radiation. + real :: mstar !< The ratio of the friction velocity cubed to the + !! TKE input to the mixed layer [nondim]. + real :: nstar !< The fraction of the TKE input to the mixed layer + !! available to drive entrainment [nondim]. + real :: nstar2 !< The fraction of potential energy released by + !! convective adjustment that drives entrainment [nondim]. + logical :: absorb_all_SW !< If true, all shortwave radiation is absorbed by the + !! ocean, instead of passing through to the bottom mud. + real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE + !! decay scale [nondim]. + real :: bulk_Ri_ML !< The efficiency with which mean kinetic energy + !! released by mechanically forced entrainment of + !! the mixed layer is converted to TKE [nondim]. + real :: bulk_Ri_convective !< The efficiency with which convectively + !! released mean kinetic energy becomes TKE [nondim]. + real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] + real :: Hmix_min !< The minimum mixed layer thickness [H ~> m or kg m-2]. + real :: mech_TKE_floor !< A tiny floor on the amount of turbulent kinetic energy that is + !! used when the mixed layer does not yet contain HMIX_MIN fluid + !! [H L2 T-2 ~> m3 s-2 or J m-2]. The default is so small that its actual + !! value is irrelevant, but it is detectably greater than 0. + real :: H_limit_fluxes !< When the total ocean depth is less than this + !! value [H ~> m or kg m-2], scale away all surface forcing to + !! avoid boiling the ocean. + real :: ustar_min !< A minimum value of ustar to avoid numerical problems [Z T-1 ~> m s-1]. + !! If the value is small enough, this should not affect the solution. + real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. + real :: dT_dS_wt !< When forced to extrapolate T & S to match the + !! layer densities, this factor [C S-1 ~> degC ppt-1] is + !! combined with the derivatives of density with T & S + !! to determines what direction is orthogonal to + !! density contours. It should be a typical value of + !! (dR/dS) / (dR/dT) in oceanic profiles. + !! 6 degC ppt-1 might be reasonable. + real :: Hbuffer_min !< The minimum buffer layer thickness when the mixed layer + !! is very large [H ~> m or kg m-2]. + real :: Hbuffer_rel_min !< The minimum buffer layer thickness relative to the combined + !! mixed and buffer layer thicknesses when they are thin [nondim] + real :: BL_detrain_time !< A timescale that characterizes buffer layer detrainment + !! events [T ~> s]. + real :: BL_extrap_lim !< A limit on the density range over which + !! extrapolation can occur when detraining from the + !! buffer layers, relative to the density range + !! within the mixed and buffer layers, when the + !! detrainment is going into the lightest interior + !! layer [nondim]. + real :: BL_split_rho_tol !< The fractional tolerance for matching layer target densities + !! when splitting layers to deal with massive interior layers + !! that are lighter than one of the mixed or buffer layers [nondim]. + logical :: ML_resort !< If true, resort the layers by density, rather than + !! doing convective adjustment. + integer :: ML_presort_nz_conv_adj !< If ML_resort is true, do convective + !! adjustment on this many layers (starting from the + !! top) before sorting the remaining layers. + real :: omega_frac !< When setting the decay scale for turbulence, use this fraction + !! of the absolute rotation rate blended with the local value of f, + !! as sqrt((1-of)*f^2 + of*4*omega^2) [nondim]. + logical :: correct_absorption !< If true, the depth at which penetrating + !! shortwave radiation is absorbed is corrected by + !! moving some of the heating upward in the water + !! column. The default is false. + logical :: nonBous_energetics !< If true, use non-Boussinesq expressions for the energetic + !! calculations used in the bulk mixed layer calculations. + logical :: Resolve_Ekman !< If true, the nkml layers in the mixed layer are + !! chosen to optimally represent the impact of the + !! Ekman transport on the mixed layer TKE budget. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + logical :: TKE_diagnostics = .false. !< If true, calculate extensive diagnostics of the TKE budget + logical :: do_rivermix = .false. !< Provide additional TKE to mix river runoff + !! at the river mouths to rivermix_depth + real :: rivermix_depth = 0.0 !< The depth of mixing if do_rivermix is true [H ~> m or kg m-2]. + logical :: limit_det !< If true, limit the extent of buffer layer + !! detrainment to be consistent with neighbors. + real :: lim_det_dH_sfc !< The fractional limit in the change between grid + !! points of the surface region (mixed & buffer + !! layer) thickness [nondim]. 0.5 by default. + real :: lim_det_dH_bathy !< The fraction of the total depth by which the + !! thickness of the surface region (mixed & buffer layers) is allowed + !! to change between grid points [nondim]. 0.2 by default. + logical :: use_river_heat_content !< If true, use the fluxes%runoff_Hflx field + !! to set the heat carried by runoff, instead of + !! using SST for temperature of liq_runoff + logical :: use_calving_heat_content !< Use SST for temperature of froz_runoff + logical :: convect_mom_bug !< If true, use code with a bug that causes a loss of momentum + !! conservation during mixedlayer convection. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the + !! timing of diagnostic output. + real :: Allowed_T_chg !< The amount by which temperature is allowed + !! to exceed previous values during detrainment [C ~> degC] + real :: Allowed_S_chg !< The amount by which salinity is allowed + !! to exceed previous values during detrainment [S ~> ppt] + + ! These are terms in the mixed layer TKE budget, all in [H L2 T-3 ~> m3 s-3 or W m-2] except as noted. + real, allocatable, dimension(:,:) :: & + ML_depth, & !< The mixed layer depth [H ~> m or kg m-2]. + diag_TKE_wind, & !< The wind source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_RiBulk, & !< The resolved KE source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_conv, & !< The convective source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_pen_SW, & !< The TKE sink required to mix penetrating shortwave heating [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_mech_decay, & !< The decay of mechanical TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_conv_decay, & !< The decay of convective TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_conv_s2, & !< The convective source of TKE due to to mixing in sigma2 [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_PE_detrain, & !< The spurious source of potential energy due to mixed layer + !! detrainment [R Z L2 T-3 ~> W m-2]. + diag_PE_detrain2 !< The spurious source of potential energy due to mixed layer only + !! detrainment [R Z L2 T-3 ~> W m-2]. + type(group_pass_type) :: pass_h_sum_hmbl_prev !< For group halo pass + + !>@{ Diagnostic IDs + integer :: id_ML_depth = -1, id_TKE_wind = -1, id_TKE_mixing = -1 + integer :: id_TKE_RiBulk = -1, id_TKE_conv = -1, id_TKE_pen_SW = -1 + integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1, id_TKE_conv_s2 = -1 + integer :: id_PE_detrain = -1, id_PE_detrain2 = -1, id_h_mismatch = -1 + integer :: id_Hsfc_used = -1, id_Hsfc_max = -1, id_Hsfc_min = -1 + !>@} +end type bulkmixedlayer_CS + +!>@{ CPU clock IDs +integer :: id_clock_pass=0 +!>@} + +contains + +!> This subroutine partially steps the bulk mixed layer model. +!! See \ref BML for more details. +subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, CS, & + optics, Hml, aggregate_FW_forcing, dt_diag, last_call) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_3d !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u_3d !< Zonal velocities interpolated to h points + !! [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: v_3d !< Zonal velocities interpolated to h points + !! [L T-1 ~> m s-1]. + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent + !! fields have NULL pointers. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL pointers. + real, intent(in) :: dt !< Time increment [T ~> s]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ea !< The amount of fluid moved downward into a + !! layer; this should be increased due to + !! mixed layer detrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: eb !< The amount of fluid moved upward into a + !! layer; this should be increased due to + !! mixed layer entrainment [H ~> m or kg m-2]. + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure + type(optics_type), pointer :: optics !< The structure that can be queried for the + !! inverse of the vertical absorption decay + !! scale for penetrating shortwave radiation. + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and + !! outgoing surface freshwater fluxes are + !! combined before being applied, instead of + !! being applied separately. + real, optional, intent(in) :: dt_diag !< The diagnostic time step, + !! which may be less than dt if there are + !! two calls to mixedlayer [T ~> s]. + logical, optional, intent(in) :: last_call !< if true, this is the last call + !! to mixedlayer in the current time step, so + !! diagnostics will be written. The default is + !! .true. + + ! Local variables + real, dimension(SZI_(G),SZK_(GV)) :: & + eaml, & ! The amount of fluid moved downward into a layer due to mixed + ! layer detrainment [H ~> m or kg m-2]. (I.e. entrainment from above.) + ebml ! The amount of fluid moved upward into a layer due to mixed + ! layer detrainment [H ~> m or kg m-2]. (I.e. entrainment from below.) + + ! If there is resorting, the vertical coordinate for these variables is the + ! new, sorted index space. Here layer 0 is an initially massless layer that + ! will be used to hold the new mixed layer properties. + real, dimension(SZI_(G),SZK0_(GV)) :: & + h, & ! The layer thickness [H ~> m or kg m-2]. + T, & ! The layer temperatures [C ~> degC]. + S, & ! The layer salinities [S ~> ppt]. + R0, & ! The potential density referenced to the surface [R ~> kg m-3]. + SpV0, & ! The specific volume referenced to the surface [R-1 ~> m3 kg-1]. + Rcv ! The coordinate variable potential density [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)) :: & + u, & ! The zonal velocity [L T-1 ~> m s-1]. + v, & ! The meridional velocity [L T-1 ~> m s-1]. + h_orig, & ! The original thickness [H ~> m or kg m-2]. + d_eb, & ! The downward increase across a layer in the entrainment from + ! below [H ~> m or kg m-2]. The sign convention is that positive values of + ! d_eb correspond to a gain in mass by a layer by upward motion. + d_ea, & ! The upward increase across a layer in the entrainment from + ! above [H ~> m or kg m-2]. The sign convention is that positive values of + ! d_ea mean a net gain in mass by a layer from downward motion. + eps ! The (small) thickness that must remain in a layer [H ~> m or kg m-2]. + integer, dimension(SZI_(G),SZK_(GV)) :: & + ksort ! The sorted k-index that each original layer goes to. + real, dimension(SZI_(G),SZJ_(G)) :: & + h_miss ! The summed absolute mismatch [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + U_star_2d, &! The wind friction velocity, calculated using the Boussinesq reference density or + ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] + U_star_H_2d ! The wind friction velocity in thickness-based units, calculated + ! using the Boussinesq reference density or the time-evolving + ! surface density in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] + real, dimension(SZI_(G)) :: & + TKE, & ! The turbulent kinetic energy available for mixing over a + ! time step [H L2 T-2 ~> m3 s-2 or J m-2]. + Conv_En, & ! The turbulent kinetic energy source due to mixing down to + ! the depth of free convection [H L2 T-2 ~> m3 s-2 or J m-2]. + htot, & ! The total depth of the layers being considered for + ! entrainment [H ~> m or kg m-2]. + R0_tot, & ! The integrated potential density referenced to the surface + ! of the layers which are fully entrained [H R ~> kg m-2 or kg2 m-5]. + SpV0_tot, & ! The integrated specific volume referenced to the surface + ! of the layers which are fully entrained [H R-1 ~> m4 kg-1 or m]. + Rcv_tot, & ! The integrated coordinate value potential density of the + ! layers that are fully entrained [H R ~> kg m-2 or kg2 m-5]. + Ttot, & ! The integrated temperature of layers which are fully + ! entrained [C H ~> degC m or degC kg m-2]. + Stot, & ! The integrated salt of layers which are fully entrained + ! [H S ~> m ppt or ppt kg m-2]. + uhtot, & ! The depth integrated zonal velocity in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] + vhtot, & ! The depth integrated meridional velocity in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] + + netMassInOut, & ! The net mass flux (if non-Boussinesq) or volume flux (if + ! Boussinesq - i.e. the fresh water flux (P+R-E)) into the + ! ocean over a time step [H ~> m or kg m-2]. + NetMassOut, & ! The mass flux (if non-Boussinesq) or volume flux (if Boussinesq) + ! over a time step from evaporating fresh water [H ~> m or kg m-2] + Net_heat, & ! The net heating at the surface over a time step [C H ~> degC m or degC kg m-2] + ! Any penetrating shortwave radiation is not included in Net_heat. + Net_salt, & ! The surface salt flux into the ocean over a time step [S H ~> ppt m or ppt kg m-2] + Idecay_len_TKE, & ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. + p_ref, & ! Reference pressure for the potential density governing mixed + ! layer dynamics, almost always 0 (or 1e5) [R L2 T-2 ~> Pa]. + p_ref_cv, & ! Reference pressure for the potential density which defines + ! the coordinate variable, set to P_Ref [R L2 T-2 ~> Pa]. + dR0_dT, & ! Partial derivative of the mixed layer potential density with + ! temperature [R C-1 ~> kg m-3 degC-1]. + dSpV0_dT, & ! Partial derivative of the mixed layer specific volume with + ! temperature [R-1 C-1 ~> m3 kg-1 degC-1]. + dRcv_dT, & ! Partial derivative of the coordinate variable potential + ! density in the mixed layer with temperature [R C-1 ~> kg m-3 degC-1]. + dR0_dS, & ! Partial derivative of the mixed layer potential density with + ! salinity [R S-1 ~> kg m-3 ppt-1]. + dSpV0_dS, & ! Partial derivative of the mixed layer specific volume with + ! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + dRcv_dS, & ! Partial derivative of the coordinate variable potential + ! density in the mixed layer with salinity [R S-1 ~> kg m-3 ppt-1]. + p_sfc, & ! The sea surface pressure [R L2 T-2 ~> Pa] + dp_ml, & ! The pressure change across the mixed layer [R L2 T-2 ~> Pa] + SpV_ml, & ! The specific volume averaged across the mixed layer [R-1 ~> m3 kg-1] + TKE_river ! The source of turbulent kinetic energy available for mixing + ! at rivermouths [H L2 T-3 ~> m3 s-3 or W m-2]. + + real, dimension(max(CS%nsw,1),SZI_(G)) :: & + Pen_SW_bnd ! The penetrating fraction of the shortwave heating integrated + ! over a time step in each band [C H ~> degC m or degC kg m-2]. + real, dimension(max(CS%nsw,1),SZI_(G),SZK_(GV)) :: & + opacity_band ! The opacity in each band [H-1 ~> m-1 or m2 kg-1]. The indices are band, i, k. + + real :: cMKE(2,SZI_(G)) ! Coefficients of HpE and HpE^2 used in calculating the + ! denominator of MKE_rate; the two elements have differing + ! units of [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. + real :: Irho0 ! 1.0 / rho_0 [R-1 ~> m3 kg-1] + real :: Inkml, Inkmlm1! 1.0 / REAL(nkml) and 1.0 / REAL(nkml-1) [nondim] + real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. + real :: Idt_diag ! The inverse of the timestep used for diagnostics [T-1 ~> s-1]. + real :: RmixConst ! A combination of constants used in the river mixing energy + ! calculation [H L2 Z-1 T-2 R-2 ~> m8 s-2 kg-2 or m5 s-2 kg-1] or + ! [H L2 Z-1 T-2 ~> m2 s-2 or kg m-1 s-2] + real, dimension(SZI_(G)) :: & + dKE_FC, & ! The change in mean kinetic energy due to free convection + ! [H L2 T-2 ~> m3 s-2 or J m-2]. + h_CA ! The depth to which convective adjustment has gone [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)) :: & + dKE_CA, & ! The change in mean kinetic energy due to convective + ! adjustment [H L2 T-2 ~> m3 s-2 or J m-2]. + cTKE ! The turbulent kinetic energy source due to convective + ! adjustment [H L2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + Hsfc_max, & ! The thickness of the surface region (mixed and buffer layers) + ! after entrainment but before any buffer layer detrainment [H ~> m or kg m-2]. + Hsfc_used, & ! The thickness of the surface region after buffer layer + ! detrainment [H ~> m or kg m-2]. + Hsfc_min, & ! The minimum thickness of the surface region based on the + ! new mixed layer depth and the previous thickness of the + ! neighboring water columns [H ~> m or kg m-2]. + h_sum, & ! The total thickness of the water column [H ~> m or kg m-2]. + hmbl_prev ! The previous thickness of the mixed and buffer layers [H ~> m or kg m-2]. + real, dimension(SZI_(G)) :: & + Hsfc, & ! The thickness of the surface region (mixed and buffer + ! layers before detrainment in to the interior [H ~> m or kg m-2]. + max_BL_det ! If non-negative, the maximum amount of entrainment from + ! the buffer layers that will be allowed this time step [H ~> m or kg m-2]. + real :: dHsfc, dHD ! Local copies of nondimensional parameters [nondim] + real :: H_nbr ! A minimum thickness based on neighboring thicknesses [H ~> m or kg m-2]. + + real :: absf_x_H ! The absolute value of f times the mixed layer thickness [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: kU_star ! Ustar times the Von Karman constant [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: dt__diag ! A rescaled copy of dt_diag (if present) or dt [T ~> s]. + logical :: write_diags ! If true, write out diagnostics with this step. + logical :: reset_diags ! If true, zero out the accumulated diagnostics. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, nz, nkmb + integer :: nsw ! The number of bands of penetrating shortwave radiation. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_bulk_mixed_layer: "//& + "Module must be initialized before it is used.") + if (GV%nkml < 1) return + + if (.not. associated(tv%eqn_of_state)) call MOM_error(FATAL, & + "MOM_mixed_layer: Temperature, salinity and an equation of state "//& + "must now be used.") + if (.not. (associated(fluxes%ustar) .or. associated(fluxes%tau_mag))) call MOM_error(FATAL, & + "MOM_mixed_layer: No surface TKE fluxes (ustar or tau_mag) defined in mixedlayer!") + + nkmb = CS%nkml+CS%nkbl + Inkml = 1.0 / REAL(CS%nkml) + if (CS%nkml > 1) Inkmlm1 = 1.0 / REAL(CS%nkml-1) + + Irho0 = 1.0 / GV%Rho0 + dt__diag = dt ; if (present(dt_diag)) dt__diag = dt_diag + Idt_diag = 1.0 / dt__diag + write_diags = .true. ; if (present(last_call)) write_diags = last_call + + p_ref(:) = 0.0 ; p_ref_cv(:) = tv%P_Ref + + nsw = CS%nsw + + if (CS%limit_det .or. (CS%id_Hsfc_min > 0)) then + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + h_sum(i,j) = 0.0 ; hmbl_prev(i,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do j=js-1,je+1 + do k=1,nkmb ; do i=is-1,ie+1 + h_sum(i,j) = h_sum(i,j) + h_3d(i,j,k) + hmbl_prev(i,j) = hmbl_prev(i,j) + h_3d(i,j,k) + enddo ; enddo + do k=nkmb+1,nz ; do i=is-1,ie+1 + h_sum(i,j) = h_sum(i,j) + h_3d(i,j,k) + enddo ; enddo + enddo + + call cpu_clock_begin(id_clock_pass) + call create_group_pass(CS%pass_h_sum_hmbl_prev, h_sum,G%Domain) + call create_group_pass(CS%pass_h_sum_hmbl_prev, hmbl_prev,G%Domain) + call do_group_pass(CS%pass_h_sum_hmbl_prev, G%Domain) + call cpu_clock_end(id_clock_pass) + endif + + ! Determine whether to zero out diagnostics before accumulation. + reset_diags = .true. + if (present(dt_diag) .and. write_diags .and. (dt__diag > dt)) & + reset_diags = .false. ! This is the second call to mixedlayer. + + if (reset_diags) then + if (CS%TKE_diagnostics) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + CS%diag_TKE_wind(i,j) = 0.0 ; CS%diag_TKE_RiBulk(i,j) = 0.0 + CS%diag_TKE_conv(i,j) = 0.0 ; CS%diag_TKE_pen_SW(i,j) = 0.0 + CS%diag_TKE_mixing(i,j) = 0.0 ; CS%diag_TKE_mech_decay(i,j) = 0.0 + CS%diag_TKE_conv_decay(i,j) = 0.0 ; CS%diag_TKE_conv_s2(i,j) = 0.0 + enddo ; enddo + endif + if (allocated(CS%diag_PE_detrain)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + CS%diag_PE_detrain(i,j) = 0.0 + enddo ; enddo + endif + if (allocated(CS%diag_PE_detrain2)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + CS%diag_PE_detrain2(i,j) = 0.0 + enddo ; enddo + endif + endif + + if (CS%ML_resort) then + do i=is,ie ; h_CA(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie ; dKE_CA(i,k) = 0.0 ; cTKE(i,k) = 0.0 ; enddo ; enddo + endif + max_BL_det(:) = -1 + EOSdom(:) = EOS_domain(G%HI) + + ! Extract the friction velocity from the forcing type. + call find_ustar(fluxes, tv, U_star_2d, G, GV, US) + if (CS%Resolve_Ekman .and. (CS%nkml>1)) & + call find_ustar(fluxes, tv, U_star_H_2d, G, GV, US, H_T_units=.true.) + + !$OMP parallel default(shared) firstprivate(dKE_CA,cTKE,h_CA,max_BL_det,p_ref,p_ref_cv) & + !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,SpV0,Rcv,ksort, & + !$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,dSpV0_dT,dSpV0_dS,htot,Ttot,Stot,TKE,Conv_en, & + !$OMP RmixConst,TKE_river,Pen_SW_bnd,netMassInOut,NetMassOut, & + !$OMP Net_heat,Net_salt,uhtot,vhtot,R0_tot,Rcv_tot,SpV0_tot,dKE_FC, & + !$OMP Idecay_len_TKE,cMKE,Hsfc,dHsfc,dHD,H_nbr,kU_Star, & + !$OMP absf_x_H,ebml,eaml) + !$OMP do + do j=js,je + ! Copy the thicknesses and other fields to 2-d arrays. + do k=1,nz ; do i=is,ie + h(i,k) = h_3d(i,j,k) ; u(i,k) = u_3d(i,j,k) ; v(i,k) = v_3d(i,j,k) + h_orig(i,k) = h_3d(i,j,k) + eps(i,k) = 0.0 ; if (k > nkmb) eps(i,k) = GV%Angstrom_H + T(i,k) = tv%T(i,j,k) ; S(i,k) = tv%S(i,j,k) + enddo ; enddo + if (nsw>0) then + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + call extract_optics_slice(optics, j, G, GV, opacity=opacity_band, opacity_scale=GV%H_to_Z) + else + call extract_optics_slice(optics, j, G, GV, opacity=opacity_band, opacity_scale=GV%H_to_RZ, & + SpV_avg=tv%SpV_avg) + endif + endif + + do k=1,nz ; do i=is,ie + d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 + enddo ; enddo + + ! Calculate an estimate of the mid-mixed layer pressure [R L2 T-2 ~> Pa] + if (associated(tv%p_surf)) then + do i=is,ie ; p_ref(i) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; p_ref(i) = 0.0 ; enddo + endif + do k=1,CS%nkml ; do i=is,ie + p_ref(i) = p_ref(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,k) + enddo ; enddo + if (CS%nonBous_energetics) then + call calculate_specific_vol_derivs(T(:,1), S(:,1), p_ref, dSpV0_dT, dSpV0_dS, tv%eqn_of_state, EOSdom) + do k=1,nz + call calculate_spec_vol(T(:,k), S(:,k), p_ref, SpV0(:,k), tv%eqn_of_state, EOSdom) + enddo + else + call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, tv%eqn_of_state, EOSdom) + do k=1,nz + call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), tv%eqn_of_state, EOSdom) + enddo + endif + call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, tv%eqn_of_state, EOSdom) + do k=1,nz + call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, EOSdom) + enddo + + if (CS%ML_resort) then + if (CS%ML_presort_nz_conv_adj > 0) & + call convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, & + US, CS, CS%ML_presort_nz_conv_adj) + + call sort_ML(h, R0, SpV0, eps, G, GV, CS, ksort) + else + do k=1,nz ; do i=is,ie ; ksort(i,k) = k ; enddo ; enddo + + ! Undergo instantaneous entrainment into the buffer layers and mixed layers + ! to remove hydrostatic instabilities. Any water that is lighter than + ! currently in the mixed or buffer layer is entrained. + call convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, US, CS) + do i=is,ie ; h_CA(i) = h(i,1) ; enddo + + endif + + if (associated(fluxes%lrunoff) .and. CS%do_rivermix) then + + ! Here we add an additional source of TKE to the mixed layer where river + ! is present to simulate unresolved estuaries. The TKE input is diagnosed + ! as follows: + ! TKE_river[H L2 T-3 ~> m3 s-3] = 0.5*rivermix_depth * g * Irho0**2 * drho_ds * + ! River*(Samb - Sriver) = CS%mstar*U_star^3 + ! where River is in units of [R Z T-1 ~> kg m-2 s-1]. + ! Samb = Ambient salinity at the mouth of the estuary + ! rivermix_depth = The prescribed depth over which to mix river inflow + ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. + ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) + if (CS%nonBous_energetics) then + RmixConst = -0.5*CS%rivermix_depth * GV%g_Earth + do i=is,ie + TKE_river(i) = max(0.0, RmixConst * dSpV0_dS(i) * & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) + enddo + else + RmixConst = 0.5*CS%rivermix_depth * GV%g_Earth * Irho0**2 + do i=is,ie + TKE_river(i) = max(0.0, RmixConst*dR0_dS(i)* & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) + enddo + endif + else + do i=is,ie ; TKE_river(i) = 0.0 ; enddo + endif + + ! The surface forcing is contained in the fluxes type. + ! We aggregate the thermodynamic forcing for a time step into the following: + ! netMassInOut = water [H ~> m or kg m-2] added/removed via surface fluxes + ! netMassOut = water [H ~> m or kg m-2] removed via evaporating surface fluxes + ! net_heat = heat via surface fluxes [C H ~> degC m or degC kg m-2] + ! net_salt = salt via surface fluxes [S H ~> ppt m or gSalt m-2] + ! Pen_SW_bnd = components to penetrative shortwave radiation + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & + CS%H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & + h(:,1:), T(:,1:), netMassInOut, netMassOut, Net_heat, Net_salt, Pen_SW_bnd, & + tv, aggregate_FW_forcing) + + ! This subroutine causes the mixed layer to entrain to depth of free convection. + call mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, R0_tot, SpV0_tot, Rcv_tot, & + u, v, T, S, R0, SpV0, Rcv, eps, dR0_dT, dSpV0_dT, dRcv_dT, dR0_dS, dSpV0_dS, dRcv_dS, & + netMassInOut, netMassOut, Net_heat, Net_salt, & + nsw, Pen_SW_bnd, opacity_band, Conv_En, dKE_FC, & + j, ksort, G, GV, US, CS, tv, fluxes, dt, aggregate_FW_forcing) + + ! Now the mixed layer undergoes mechanically forced entrainment. + ! The mixed layer may entrain down to the Monin-Obukhov depth if the + ! surface is becoming lighter, and is effectively detraining. + + ! First the TKE at the depth of free convection that is available + ! to drive mixing is calculated. + call find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_FC, dKE_CA, & + TKE, TKE_river, Idecay_len_TKE, cMKE, tv, dt, Idt_diag, & + j, ksort, G, GV, US, CS) + + ! Here the mechanically driven entrainment occurs. + call mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & + R0_tot, SpV0_tot, Rcv_tot, u, v, T, S, R0, SpV0, Rcv, eps, & + dR0_dT, dSpV0_dT, dRcv_dT, cMKE, Idt_diag, nsw, Pen_SW_bnd, & + opacity_band, TKE, Idecay_len_TKE, j, ksort, G, GV, US, CS) + + call absorbRemainingSW(G, GV, US, h(:,1:), opacity_band, nsw, optics, j, dt, & + CS%H_limit_fluxes, CS%correct_absorption, CS%absorb_all_SW, & + T(:,1:), Pen_SW_bnd, eps, ksort, htot, Ttot) + + if (CS%TKE_diagnostics) then ; do i=is,ie + CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) - Idt_diag * TKE(i) + enddo ; endif + + ! Calculate the homogeneous mixed layer properties and store them in layer 0. + do i=is,ie ; if (htot(i) > 0.0) then + Ih = 1.0 / htot(i) + if (CS%nonBous_energetics) then + SpV0(i,0) = SpV0_tot(i) * Ih + else + R0(i,0) = R0_tot(i) * Ih + endif + Rcv(i,0) = Rcv_tot(i) * Ih + T(i,0) = Ttot(i) * Ih ; S(i,0) = Stot(i) * Ih + h(i,0) = htot(i) + else ! This may not ever be needed? + T(i,0) = T(i,1) ; S(i,0) = S(i,1) ; Rcv(i,0) = Rcv(i,1) + if (CS%nonBous_energetics) then + SpV0(i,0) = SpV0(i,1) + else + R0(i,0) = R0(i,1) + endif + h(i,0) = htot(i) + endif ; enddo + if (write_diags .and. allocated(CS%ML_depth)) then ; do i=is,ie + CS%ML_depth(i,j) = h(i,0) ! Store the diagnostic. + enddo ; endif + + if (associated(Hml)) then + ! Return the mixed layerd depth in [Z ~> m]. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is,ie + Hml(i,j) = G%mask2dT(i,j) * GV%H_to_Z*h(i,0) + enddo + else + do i=is,ie ; dp_ml(i) = GV%g_Earth * GV%H_to_RZ * h(i,0) ; enddo + if (associated(tv%p_surf)) then + do i=is,ie ; p_sfc(i) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; p_sfc(i) = 0.0 ; enddo + endif + call average_specific_vol(T(:,0), S(:,0), p_sfc, dp_ml, SpV_ml, tv%eqn_of_state) + do i=is,ie + Hml(i,j) = G%mask2dT(i,j) * GV%H_to_RZ * SpV_ml(i) * h(i,0) + enddo + endif + endif + +! At this point, return water to the original layers, but constrained to +! still be sorted. After this point, all the water that is in massive +! interior layers will be denser than water remaining in the mixed- and +! buffer-layers. To achieve this, some of these variable density layers +! might be split between two isopycnal layers that are denser than new +! mixed layer or any remaining water from the old mixed- or buffer-layers. +! Alternately, if there are fewer than nkbl of the old buffer or mixed layers +! with any mass, relatively light interior layers might be transferred to +! these unused layers (but not currently in the code). + + if (CS%ML_resort) then + call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), SpV0(:,0:), Rcv(:,0:), GV%Rlay(:), eps, & + d_ea, d_eb, ksort, G, GV, CS, dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS) + endif + + if (CS%limit_det .or. (CS%id_Hsfc_max > 0) .or. (CS%id_Hsfc_min > 0)) then + do i=is,ie ; Hsfc(i) = h(i,0) ; enddo + do k=1,nkmb ; do i=is,ie ; Hsfc(i) = Hsfc(i) + h(i,k) ; enddo ; enddo + + if (CS%limit_det .or. (CS%id_Hsfc_min > 0)) then + dHsfc = CS%lim_det_dH_sfc ; dHD = CS%lim_det_dH_bathy + do i=is,ie + H_nbr = min(dHsfc*max(hmbl_prev(i-1,j), hmbl_prev(i+1,j), & + hmbl_prev(i,j-1), hmbl_prev(i,j+1)), & + max(hmbl_prev(i-1,j) - dHD*min(h_sum(i,j),h_sum(i-1,j)), & + hmbl_prev(i+1,j) - dHD*min(h_sum(i,j),h_sum(i+1,j)), & + hmbl_prev(i,j-1) - dHD*min(h_sum(i,j),h_sum(i,j-1)), & + hmbl_prev(i,j+1) - dHD*min(h_sum(i,j),h_sum(i,j+1))) ) + + Hsfc_min(i,j) = max(h(i,0), min(Hsfc(i), H_nbr)) + + if (CS%limit_det) max_BL_det(i) = max(0.0, Hsfc(i)-H_nbr) + enddo + endif + + if (CS%id_Hsfc_max > 0) then ; do i=is,ie + Hsfc_max(i,j) = Hsfc(i) + enddo ; endif + endif + + ! Move water left in the former mixed layer into the buffer layer and + ! from the buffer layer into the interior. These steps might best be + ! treated in conjunction. + if (CS%nkbl == 1) then + call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), SpV0(:,0:), Rcv(:,0:), & + GV%Rlay(:), dt, dt__diag, d_ea, d_eb, j, G, GV, US, CS, & + dRcv_dT, dRcv_dS, max_BL_det) + elseif (CS%nkbl == 2) then + call mixedlayer_detrain_2(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), SpV0(:,0:), Rcv(:,0:), & + GV%Rlay(:), dt, dt__diag, d_ea, j, G, GV, US, CS, & + dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS, max_BL_det) + else ! CS%nkbl not = 1 or 2 + ! This code only works with 1 or 2 buffer layers. + call MOM_error(FATAL, "MOM_mixed_layer: CS%nkbl must be 1 or 2 for now.") + endif + + if (CS%id_Hsfc_used > 0) then + do i=is,ie ; Hsfc_used(i,j) = h(i,0) ; enddo + do k=CS%nkml+1,nkmb ; do i=is,ie + Hsfc_used(i,j) = Hsfc_used(i,j) + h(i,k) + enddo ; enddo + endif + +! Now set the properties of the layers in the mixed layer in the original +! 3-d variables. + if (CS%Resolve_Ekman .and. (CS%nkml>1)) then + ! The thickness of the topmost piece of the mixed layer is given by + ! h_1 = H / (3 + sqrt(|f|*H^2/2*nu_max)), which asymptotes to the Ekman + ! layer depth and 1/3 of the mixed layer depth. This curve has been + ! determined to maximize the impact of the Ekman transport in the mixed + ! layer TKE budget with nkml=2. With nkml=3, this should also be used, + ! as the third piece will then optimally describe mixed layer + ! restratification. For nkml>=4 the whole strategy should be revisited. + do i=is,ie + ! Perhaps in the following, u* could be replaced with u*+w*? + kU_star = CS%vonKar * U_star_H_2d(i,j) + if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then + if (fluxes%frac_shelf_h(i,j) > 0.0) then + if (allocated(tv%SpV_avg)) then + kU_star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & + fluxes%frac_shelf_h(i,j) * ((CS%vonKar*fluxes%ustar_shelf(i,j)) / & + (GV%H_to_RZ * tv%SpV_avg(i,j,1))) + else + kU_star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & + fluxes%frac_shelf_h(i,j) * (CS%vonKar*GV%Z_to_H*fluxes%ustar_shelf(i,j)) + endif + endif + endif + absf_x_H = 0.25 * h(i,0) * & + ((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & + (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) + ! If the mixed layer vertical viscosity specification is changed in + ! MOM_vert_friction.F90, this line will have to be modified accordingly. + h_3d(i,j,1) = h(i,0) / (3.0 + sqrt(absf_x_H*(absf_x_H + 2.0*kU_star) / kU_star**2)) + do k=2,CS%nkml + ! The other layers are evenly distributed through the mixed layer. + h_3d(i,j,k) = (h(i,0)-h_3d(i,j,1)) * Inkmlm1 + d_ea(i,k) = d_ea(i,k) + h_3d(i,j,k) + d_ea(i,1) = d_ea(i,1) - h_3d(i,j,k) + enddo + enddo + else + do i=is,ie + h_3d(i,j,1) = h(i,0) * Inkml + enddo + do k=2,CS%nkml ; do i=is,ie + h_3d(i,j,k) = h(i,0) * Inkml + d_ea(i,k) = d_ea(i,k) + h_3d(i,j,k) + d_ea(i,1) = d_ea(i,1) - h_3d(i,j,k) + enddo ; enddo + endif + do i=is,ie ; h(i,0) = 0.0 ; enddo + do k=1,CS%nkml ; do i=is,ie + tv%T(i,j,k) = T(i,0) ; tv%S(i,j,k) = S(i,0) + enddo ; enddo + + ! These sum needs to be done in the original layer space. + + ! The treatment of layer 1 is atypical because evaporation shows up as + ! negative ea(i,1), and because all precipitation goes straight into layer 1. + ! The code is ordered so that any roundoff errors in ea are lost the surface. +! do i=is,ie ; eaml(i,1) = 0.0 ; enddo +! do k=2,nz ; do i=is,ie ; eaml(i,k) = eaml(i,k-1) - d_ea(i,k-1) ; enddo ; enddo +! do i=is,ie ; eaml(i,1) = netMassInOut(i) ; enddo + + + do i=is,ie +! eaml(i,nz) is derived from h(i,nz) - h_orig(i,nz) = eaml(i,nz) - ebml(i,nz-1) + ebml(i,nz) = 0.0 + eaml(i,nz) = (h(i,nz) - h_orig(i,nz)) - d_eb(i,nz) + enddo + do k=nz-1,1,-1 ; do i=is,ie + ebml(i,k) = ebml(i,k+1) - d_eb(i,k+1) + eaml(i,k) = eaml(i,k+1) + d_ea(i,k) + enddo ; enddo + do i=is,ie ; eaml(i,1) = netMassInOut(i) ; enddo + + ! Copy the interior thicknesses and other fields back to the 3-d arrays. + do k=CS%nkml+1,nz ; do i=is,ie + h_3d(i,j,k) = h(i,k); tv%T(i,j,k) = T(i,k) ; tv%S(i,j,k) = S(i,k) + enddo ; enddo + + do k=1,nz ; do i=is,ie + ea(i,j,k) = ea(i,j,k) + eaml(i,k) + eb(i,j,k) = eb(i,j,k) + ebml(i,k) + enddo ; enddo + + if (CS%id_h_mismatch > 0) then + do i=is,ie + h_miss(i,j) = abs(h_3d(i,j,1) - (h_orig(i,1) + & + (eaml(i,1) + (ebml(i,1) - eaml(i,1+1))))) + enddo + do k=2,nz-1 ; do i=is,ie + h_miss(i,j) = h_miss(i,j) + abs(h_3d(i,j,k) - (h_orig(i,k) + & + ((eaml(i,k) - ebml(i,k-1)) + (ebml(i,k) - eaml(i,k+1))))) + enddo ; enddo + do i=is,ie + h_miss(i,j) = h_miss(i,j) + abs(h_3d(i,j,nz) - (h_orig(i,nz) + & + ((eaml(i,nz) - ebml(i,nz-1)) + ebml(i,nz)))) + enddo + endif + + enddo ! j loop + !$OMP end parallel + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + ! This needs to happen after the H update and before the next post_data. + call diag_update_remap_grids(CS%diag) + + + if (write_diags) then + if (CS%id_ML_depth > 0) & + call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) + if (CS%id_TKE_wind > 0) & + call post_data(CS%id_TKE_wind, CS%diag_TKE_wind, CS%diag) + if (CS%id_TKE_RiBulk > 0) & + call post_data(CS%id_TKE_RiBulk, CS%diag_TKE_RiBulk, CS%diag) + if (CS%id_TKE_conv > 0) & + call post_data(CS%id_TKE_conv, CS%diag_TKE_conv, CS%diag) + if (CS%id_TKE_pen_SW > 0) & + call post_data(CS%id_TKE_pen_SW, CS%diag_TKE_pen_SW, CS%diag) + if (CS%id_TKE_mixing > 0) & + call post_data(CS%id_TKE_mixing, CS%diag_TKE_mixing, CS%diag) + if (CS%id_TKE_mech_decay > 0) & + call post_data(CS%id_TKE_mech_decay, CS%diag_TKE_mech_decay, CS%diag) + if (CS%id_TKE_conv_decay > 0) & + call post_data(CS%id_TKE_conv_decay, CS%diag_TKE_conv_decay, CS%diag) + if (CS%id_TKE_conv_s2 > 0) & + call post_data(CS%id_TKE_conv_s2, CS%diag_TKE_conv_s2, CS%diag) + if (CS%id_PE_detrain > 0) & + call post_data(CS%id_PE_detrain, CS%diag_PE_detrain, CS%diag) + if (CS%id_PE_detrain2 > 0) & + call post_data(CS%id_PE_detrain2, CS%diag_PE_detrain2, CS%diag) + if (CS%id_h_mismatch > 0) & + call post_data(CS%id_h_mismatch, h_miss, CS%diag) + if (CS%id_Hsfc_used > 0) & + call post_data(CS%id_Hsfc_used, Hsfc_used, CS%diag) + if (CS%id_Hsfc_max > 0) & + call post_data(CS%id_Hsfc_max, Hsfc_max, CS%diag) + if (CS%id_Hsfc_min > 0) & + call post_data(CS%id_Hsfc_min, Hsfc_min, CS%diag) + endif + +end subroutine bulkmixedlayer + +!> This subroutine does instantaneous convective entrainment into the buffer +!! layers and mixed layers to remove hydrostatic instabilities. Any water that +!! is lighter than currently in the mixed- or buffer- layer is entrained. +subroutine convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, & + dKE_CA, cTKE, j, G, GV, US, CS, nz_conv) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. + !! The units of h are referred to as H below. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: u !< Zonal velocities interpolated to h + !! points [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: v !< Zonal velocities interpolated to h + !! points [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to + !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential + !! density [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Layer temperatures [C ~> degC]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Layer salinities [S ~> ppt]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: eps !< The negligibly small amount of water + !! that will be left in each layer [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_eb !< The downward increase across a layer + !! in the entrainment from below [H ~> m or kg m-2]. + !! Positive values go with mass gain by + !! a layer. + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: dKE_CA !< The vertically integrated change in + !! kinetic energy due to convective + !! adjustment [H L2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: cTKE !< The buoyant turbulent kinetic energy + !! source due to convective adjustment + !! [H L2 T-2 ~> m3 s-2 or J m-2]. + integer, intent(in) :: j !< The j-index to work on. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure + integer, optional, intent(in) :: nz_conv !< If present, the number of layers + !! over which to do convective adjustment + !! (perhaps CS%nkml). + + ! Local variables + real, dimension(SZI_(G)) :: & + R0_tot, & ! The integrated potential density referenced to the surface + ! of the layers which are fully entrained [H R ~> kg m-2 or kg2 m-5]. + SpV0_tot, & ! The integrated specific volume referenced to the surface + ! of the layers which are fully entrained [H R-1 ~> m4 kg-1 or m]. + Rcv_tot, & ! The integrated coordinate value potential density of the + ! layers that are fully entrained [H R ~> kg m-2 or kg2 m-5]. + Ttot, & ! The integrated temperature of layers which are fully + ! entrained [C H ~> degC m or degC kg m-2]. + Stot, & ! The integrated salt of layers which are fully entrained + ! [H S ~> m ppt or ppt kg m-2]. + uhtot, & ! The depth integrated zonal velocities in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] + vhtot, & ! The depth integrated meridional velocities in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] + KE_orig, & ! The total mean kinetic energy per unit area in the mixed layer before + ! convection, [H L2 T-2 ~> m3 s-2 or kg s-2]. + h_orig_k1 ! The depth of layer k1 before convective adjustment [H ~> m or kg m-2]. + real :: h_ent ! The thickness from a layer that is entrained [H ~> m or kg m-2]. + real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. + real :: g_H_2Rho0 ! Half the gravitational acceleration times + ! the conversion from H to Z divided by the mean density, + ! in [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + logical :: unstable + integer :: is, ie, nz, i, k, k1, nzc, nkmb + + is = G%isc ; ie = G%iec ; nz = GV%ke + g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * GV%Rho0) + nzc = nz ; if (present(nz_conv)) nzc = nz_conv + nkmb = CS%nkml+CS%nkbl + +! Undergo instantaneous entrainment into the buffer layers and mixed layers +! to remove hydrostatic instabilities. Any water that is lighter than currently +! in the layer is entrained. + do k1=min(nzc-1,nkmb),1,-1 + do i=is,ie + h_orig_k1(i) = h(i,k1) + KE_orig(i) = 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2) + uhtot(i) = h(i,k1)*u(i,k1) ; vhtot(i) = h(i,k1)*v(i,k1) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0(i,k1) * h(i,k1) + else + R0_tot(i) = R0(i,k1) * h(i,k1) + endif + cTKE(i,k1) = 0.0 ; dKE_CA(i,k1) = 0.0 + + Rcv_tot(i) = Rcv(i,k1) * h(i,k1) + Ttot(i) = T(i,k1) * h(i,k1) ; Stot(i) = S(i,k1) * h(i,k1) + enddo + do k=k1+1,nzc + do i=is,ie + if (CS%nonBous_energetics) then + unstable = (SpV0_tot(i) < h(i,k1)*SpV0(i,k)) + else + unstable = (R0_tot(i) > h(i,k1)*R0(i,k)) + endif + if ((h(i,k) > eps(i,k)) .and. unstable) then + h_ent = h(i,k)-eps(i,k) + if (CS%nonBous_energetics) then + ! This and the other energy calculations assume that specific volume is + ! conserved during mixing, which ignores certain thermobaric contributions. + cTKE(i,k1) = cTKE(i,k1) + 0.5 * h_ent * (GV%g_Earth * GV%H_to_RZ) * & + (h(i,k1)*SpV0(i,k) - SpV0_tot(i)) * CS%nstar2 + SpV0_tot(i) = SpV0_tot(i) + h_ent * SpV0(i,k) + else + cTKE(i,k1) = cTKE(i,k1) + h_ent * g_H_2Rho0 * & + (R0_tot(i) - h(i,k1)*R0(i,k)) * CS%nstar2 + R0_tot(i) = R0_tot(i) + h_ent * R0(i,k) + endif + if (k < nkmb) then + cTKE(i,k1) = cTKE(i,k1) + cTKE(i,k) + dKE_CA(i,k1) = dKE_CA(i,k1) + dKE_CA(i,k) + endif + KE_orig(i) = KE_orig(i) + 0.5*h_ent* & + (u(i,k)*u(i,k) + v(i,k)*v(i,k)) + uhtot(i) = uhtot(i) + h_ent*u(i,k) + vhtot(i) = vhtot(i) + h_ent*v(i,k) + + Rcv_tot(i) = Rcv_tot(i) + h_ent * Rcv(i,k) + Ttot(i) = Ttot(i) + h_ent * T(i,k) + Stot(i) = Stot(i) + h_ent * S(i,k) + h(i,k1) = h(i,k1) + h_ent ; h(i,k) = eps(i,k) + + d_eb(i,k) = d_eb(i,k) - h_ent + d_eb(i,k1) = d_eb(i,k1) + h_ent + endif + enddo + enddo +! Determine the temperature, salinity, and velocities of the mixed or buffer +! layer in question, if it has entrained. + do i=is,ie ; if (h(i,k1) > h_orig_k1(i)) then + Ih = 1.0 / h(i,k1) + if (CS%nonBous_energetics) then + SpV0(i,k1) = SpV0_tot(i) * Ih + else + R0(i,k1) = R0_tot(i) * Ih + endif + u(i,k1) = uhtot(i) * Ih ; v(i,k1) = vhtot(i) * Ih + dKE_CA(i,k1) = dKE_CA(i,k1) + CS%bulk_Ri_convective * & + (KE_orig(i) - 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2)) + Rcv(i,k1) = Rcv_tot(i) * Ih + T(i,k1) = Ttot(i) * Ih ; S(i,k1) = Stot(i) * Ih + endif ; enddo + enddo +! If lower mixed or buffer layers are massless, give them the properties of the +! layer above. + do k=2,min(nzc,nkmb) ; do i=is,ie ; if (h(i,k) == 0.0) then + if (CS%nonBous_energetics) then + SpV0(i,k) = SpV0(i,k-1) + else + R0(i,k) = R0(i,k-1) + endif + Rcv(i,k) = Rcv(i,k-1) ; T(i,k) = T(i,k-1) ; S(i,k) = S(i,k-1) + endif ; enddo ; enddo + +end subroutine convective_adjustment + +!> This subroutine causes the mixed layer to entrain to the depth of free +!! convection. The depth of free convection is the shallowest depth at which the +!! fluid is denser than the average of the fluid above. +subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & + R0_tot, SpV0_tot, Rcv_tot, u, v, T, S, R0, SpV0, Rcv, eps, & + dR0_dT, dSpV0_dT, dRcv_dT, dR0_dS, dSpV0_dS, dRcv_dS, & + netMassInOut, netMassOut, Net_heat, Net_salt, & + nsw, Pen_SW_bnd, opacity_band, Conv_En, & + dKE_FC, j, ksort, G, GV, US, CS, tv, fluxes, dt, & + aggregate_FW_forcing) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. + !! The units of h are referred to as H below. + real, dimension(SZI_(G),SZK_(GV)), & + intent(inout) :: d_eb !< The downward increase across a layer in the + !! layer in the entrainment from below [H ~> m or kg m-2]. + !! Positive values go with mass gain by a layer. + real, dimension(SZI_(G)), intent(out) :: htot !< The accumulated mixed layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(out) :: Ttot !< The depth integrated mixed layer temperature + !! [C H ~> degC m or degC kg m-2]. + real, dimension(SZI_(G)), intent(out) :: Stot !< The depth integrated mixed layer salinity + !! [S H ~> ppt m or ppt kg m-2]. + real, dimension(SZI_(G)), intent(out) :: uhtot !< The depth integrated mixed layer zonal + !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G)), intent(out) :: vhtot !< The integrated mixed layer meridional + !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G)), intent(out) :: R0_tot !< The integrated mixed layer potential density referenced + !! to 0 pressure [H R ~> kg m-2 or kg2 m-5]. + real, dimension(SZI_(G)), intent(out) :: SpV0_tot !< The integrated mixed layer specific volume referenced + !! to 0 pressure [H R-1 ~> m4 kg-1 or m]. + real, dimension(SZI_(G)), intent(out) :: Rcv_tot !< The integrated mixed layer coordinate + !! variable potential density [H R ~> kg m-2 or kg2 m-5]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocities interpolated to h points [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: v !< Zonal velocities interpolated to h points [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: T !< Layer temperatures [C ~> degC]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: S !< Layer salinities [S ~> ppt]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: R0 !< Potential density referenced to + !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: Rcv !< The coordinate defining potential + !! density [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: eps !< The negligibly small amount of water + !! that will be left in each layer [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of R0 with respect to + !! temperature [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of SpV0 with respect to + !! temperature [R-1 C-1 ~> m3 kg-1 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of Rcv with respect to + !! temperature [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of R0 with respect to + !! salinity [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dS !< The partial derivative of SpV0 with respect to + !! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of Rcv with respect to + !! salinity [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: netMassInOut !< The net mass flux (if non-Boussinesq) + !! or volume flux (if Boussinesq) into the ocean + !! within a time step [H ~> m or kg m-2]. (I.e. P+R-E.) + real, dimension(SZI_(G)), intent(in) :: netMassOut !< The mass or volume flux out of the ocean + !! within a time step [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: Net_heat !< The net heating at the surface over a time + !! step [C H ~> degC m or degC kg m-2]. Any penetrating + !! shortwave radiation is not included in Net_heat. + real, dimension(SZI_(G)), intent(in) :: Net_salt !< The net surface salt flux into the ocean + !! over a time step [S H ~> ppt m or ppt kg m-2]. + integer, intent(in) :: nsw !< The number of bands of penetrating + !! shortwave radiation. + real, dimension(max(nsw,1),SZI_(G)), intent(inout) :: Pen_SW_bnd !< The penetrating shortwave + !! heating at the sea surface in each penetrating + !! band [C H ~> degC m or degC kg m-2]. + real, dimension(max(nsw,1),SZI_(G),SZK_(GV)), intent(in) :: opacity_band !< The opacity in each band of + !! penetrating shortwave radiation [H-1 ~> m-1 or m2 kg-1]. + real, dimension(SZI_(G)), intent(out) :: Conv_En !< The buoyant turbulent kinetic energy source + !! due to free convection [H L2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G)), intent(out) :: dKE_FC !< The vertically integrated change in kinetic + !! energy due to free convection [H L2 T-2 ~> m3 s-2 or J m-2]. + integer, intent(in) :: j !< The j-index to work on. + integer, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: ksort !< The density-sorted k-indices. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent + !! fields have NULL pointers. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL pointers. + real, intent(in) :: dt !< Time increment [T ~> s]. + logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and + !! outgoing surface freshwater fluxes are + !! combined before being applied, instead of + !! being applied separately. + +! This subroutine causes the mixed layer to entrain to the depth of free +! convection. The depth of free convection is the shallowest depth at which the +! fluid is denser than the average of the fluid above. + + ! Local variables + real, dimension(SZI_(G)) :: & + massOutRem, & ! Evaporation that remains to be supplied [H ~> m or kg m-2]. + netMassIn ! mass entering through ocean surface [H ~> m or kg m-2] + real :: SW_trans ! The fraction of shortwave radiation + ! that is not absorbed in a layer [nondim]. + real :: Pen_absorbed ! The amount of penetrative shortwave radiation + ! that is absorbed in a layer [C H ~> degC m or degC kg m-2]. + real :: h_avail ! The thickness in a layer available for + ! entrainment [H ~> m or kg m-2]. + real :: h_ent ! The thickness from a layer that is entrained [H ~> m or kg m-2]. + real :: T_precip ! The temperature of the precipitation [C ~> degC]. + real :: C1_3, C1_6 ! 1/3 and 1/6 [nondim] + real :: En_fn, Frac, x1 ! Nondimensional temporary variables [nondim]. + real :: dr, dr0 ! Temporary variables [R H ~> kg m-2 or kg2 m-5] or [R-1 H ~> m4 kg-1 or m]. + real :: dr_ent, dr_comp ! Temporary variables [R H ~> kg m-2 or kg2 m-5]. + real :: dr_dh ! The partial derivative of dr_ent with h_ent [R ~> kg m-3]. + real :: h_min, h_max ! The minimum and maximum estimates for h_ent [H ~> m or kg m-2] + real :: h_prev ! The previous estimate for h_ent [H ~> m or kg m-2] + real :: h_evap ! The thickness that is evaporated [H ~> m or kg m-2]. + real :: dh_Newt ! The Newton's method estimate of the change in + ! h_ent between iterations [H ~> m or kg m-2]. + real :: g_H_2Rho0 ! Half the gravitational acceleration times + ! the conversion from H to Z divided by the mean density, + ! [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. + real :: opacity ! The opacity converted to inverse thickness units [H-1 ~> m-1 or m2 kg-1] + real :: sum_Pen_En ! The potential energy change due to penetrating + ! shortwave radiation, integrated over a layer + ! [H R ~> kg m-2 or kg2 m-5]. + real :: Idt ! 1.0/dt [T-1 ~> s-1] + integer :: is, ie, nz, i, k, ks, itt, n + real, dimension(max(nsw,1)) :: & + C2, & ! Temporary variable [R H-1 ~> kg m-4 or m-1]. + r_SW_top ! Temporary variables [H R ~> kg m-2 or kg2 m-5]. + + Angstrom = GV%Angstrom_H + C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 + g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * GV%Rho0) + Idt = 1.0 / dt + is = G%isc ; ie = G%iec ; nz = GV%ke + + do i=is,ie ; if (ksort(i,1) > 0) then + k = ksort(i,1) + + if (aggregate_FW_forcing) then + massOutRem(i) = 0.0 + if (netMassInOut(i) < 0.0) massOutRem(i) = -netMassInOut(i) + netMassIn(i) = netMassInOut(i) + massOutRem(i) + else + massOutRem(i) = -netMassOut(i) + netMassIn(i) = netMassInOut(i) - netMassOut(i) + endif + + ! htot is an Angstrom (taken from layer 1) plus any net precipitation. + h_ent = max(min(Angstrom,h(i,k)-eps(i,k)),0.0) + htot(i) = h_ent + netMassIn(i) + h(i,k) = h(i,k) - h_ent + d_eb(i,k) = d_eb(i,k) - h_ent + + Pen_absorbed = 0.0 + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + SW_trans = exp(-htot(i)*opacity_band(n,i,k)) + Pen_absorbed = Pen_absorbed + Pen_SW_bnd(n,i) * (1.0-SW_trans) + Pen_SW_bnd(n,i) = Pen_SW_bnd(n,i) * SW_trans + endif ; enddo + + ! Precipitation is assumed to have the same temperature and velocity + ! as layer 1. Because layer 1 might not be the topmost layer, this + ! involves multiple terms. + T_precip = T(i,1) + Ttot(i) = (Net_heat(i) + (netMassIn(i) * T_precip + h_ent * T(i,k))) + & + Pen_absorbed + ! Net_heat contains both heat fluxes and the heat content of mass fluxes. + !! Ttot(i) = netMassIn(i) * T_precip + h_ent * T(i,k) + !! Ttot(i) = Net_heat(i) + Ttot(i) + !! Ttot(i) = Ttot(i) + Pen_absorbed + ! smg: + ! Ttot(i) = (Net_heat(i) + (h_ent * T(i,k))) + Pen_absorbed + Stot(i) = h_ent*S(i,k) + Net_salt(i) + uhtot(i) = u(i,1)*netMassIn(i) + u(i,k)*h_ent + vhtot(i) = v(i,1)*netMassIn(i) + v(i,k)*h_ent + if (CS%nonBous_energetics) then + SpV0_tot(i) = (h_ent*SpV0(i,k) + netMassIn(i)*SpV0(i,1)) + & +! dSpV0_dT(i)*netMassIn(i)*(T_precip - T(i,1)) + & + (dSpV0_dT(i)*(Net_heat(i) + Pen_absorbed) - & + dSpV0_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) + else + R0_tot(i) = (h_ent*R0(i,k) + netMassIn(i)*R0(i,1)) + & +! dR0_dT(i)*netMassIn(i)*(T_precip - T(i,1)) + & + (dR0_dT(i)*(Net_heat(i) + Pen_absorbed) - & + dR0_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) + endif + Rcv_tot(i) = (h_ent*Rcv(i,k) + netMassIn(i)*Rcv(i,1)) + & +! dRcv_dT(i)*netMassIn(i)*(T_precip - T(i,1)) + & + (dRcv_dT(i)*(Net_heat(i) + Pen_absorbed) - & + dRcv_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) + Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 + if (associated(fluxes%heat_content_massin)) & + fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & + T_precip * netMassIn(i) * GV%H_to_RZ * tv%C_p * Idt + if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & + T_precip * netMassIn(i) * GV%H_to_RZ + else ! This is a massless column, but zero out the summed variables anyway for safety. + htot(i) = 0.0 ; Ttot(i) = 0.0 ; Stot(i) = 0.0 ; Rcv_tot = 0.0 + R0_tot(i) = 0.0 ; SpV0_tot(i) = 0.0 + uhtot(i) = 0.0 ; vhtot(i) = 0.0 ; Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 + endif ; enddo + + ! Now do netMassOut case in this block. + ! At this point htot contains an Angstrom of fluid from layer 0 plus netMassIn. + do ks=1,nz + do i=is,ie ; if (ksort(i,ks) > 0) then + k = ksort(i,ks) + + if ((htot(i) < Angstrom) .and. (h(i,k) > eps(i,k))) then + ! If less than an Angstrom was available from the layers above plus + ! any precipitation, add more fluid from this layer. + h_ent = min(Angstrom-htot(i), h(i,k)-eps(i,k)) + htot(i) = htot(i) + h_ent + h(i,k) = h(i,k) - h_ent + d_eb(i,k) = d_eb(i,k) - h_ent + + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0_tot(i) + h_ent*SpV0(i,k) + else + R0_tot(i) = R0_tot(i) + h_ent*R0(i,k) + endif + uhtot(i) = uhtot(i) + h_ent*u(i,k) + vhtot(i) = vhtot(i) + h_ent*v(i,k) + + Rcv_tot(i) = Rcv_tot(i) + h_ent*Rcv(i,k) + Ttot(i) = Ttot(i) + h_ent*T(i,k) + Stot(i) = Stot(i) + h_ent*S(i,k) + endif + + ! Water is removed from the topmost layers with any mass. + ! We may lose layers if they are thin enough. + ! The salt that is left behind goes into Stot. + if ((massOutRem(i) > 0.0) .and. (h(i,k) > eps(i,k))) then + if (massOutRem(i) > (h(i,k) - eps(i,k))) then + h_evap = h(i,k) - eps(i,k) + h(i,k) = eps(i,k) + massOutRem(i) = massOutRem(i) - h_evap + else + h_evap = massOutRem(i) + h(i,k) = h(i,k) - h_evap + massOutRem(i) = 0.0 + endif + + Stot(i) = Stot(i) + h_evap*S(i,k) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0_tot(i) + dSpV0_dS(i)*h_evap*S(i,k) + else + R0_tot(i) = R0_tot(i) + dR0_dS(i)*h_evap*S(i,k) + endif + Rcv_tot(i) = Rcv_tot(i) + dRcv_dS(i)*h_evap*S(i,k) + d_eb(i,k) = d_eb(i,k) - h_evap + + ! smg: when resolve the A=B code, we will set + ! heat_content_massout = heat_content_massout - T(i,k)*h_evap*GV%H_to_RZ*tv%C_p*Idt + ! by uncommenting the lines here. + ! we will also then completely remove TempXpme from the model. + if (associated(fluxes%heat_content_massout)) & + fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) - & + T(i,k)*h_evap*GV%H_to_RZ * tv%C_p * Idt + if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) - & + T(i,k)*h_evap*GV%H_to_RZ + + endif + + ! The following section calculates how much fluid will be entrained. + h_avail = h(i,k) - eps(i,k) + if (h_avail > 0.0) then + h_ent = 0.0 + + if (CS%nonBous_energetics) then + dr = htot(i)*SpV0(i,k) - SpV0_tot(i) + + dr0 = dr + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + dr0 = dr0 + (dSpV0_dT(i)*Pen_SW_bnd(n,i)) * & + opacity_band(n,i,k)*htot(i) + endif ; enddo + else + dr = R0_tot(i) - htot(i)*R0(i,k) + + dr0 = dr + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + dr0 = dr0 - (dR0_dT(i)*Pen_SW_bnd(n,i)) * & + opacity_band(n,i,k)*htot(i) + endif ; enddo + endif + + ! Some entrainment will occur from this layer. + if (dr0 > 0.0) then + dr_comp = dr + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + ! Compare the density at the bottom of a layer with the + ! density averaged over the mixed layer and that layer. + opacity = opacity_band(n,i,k) + SW_trans = exp(-h_avail*opacity) + if (CS%nonBous_energetics) then + dr_comp = dr_comp - (dSpV0_dT(i)*Pen_SW_bnd(n,i)) * & + ((1.0 - SW_trans) - opacity*(htot(i)+h_avail)*SW_trans) + else + dr_comp = dr_comp + (dR0_dT(i)*Pen_SW_bnd(n,i)) * & + ((1.0 - SW_trans) - opacity*(htot(i)+h_avail)*SW_trans) + endif + endif ; enddo + if (dr_comp >= 0.0) then + ! The entire layer is entrained. + h_ent = h_avail + else + ! The layer is partially entrained. Iterate to determine how much + ! entrainment occurs. Solve for the h_ent at which dr_ent = 0. + + ! Instead of assuming that the curve is linear between the two end + ! points, assume that the change is concentrated near small values + ! of entrainment. On average, this saves about 1 iteration. + Frac = dr0 / (dr0 - dr_comp) + h_ent = h_avail * Frac*Frac + h_min = 0.0 ; h_max = h_avail + + do n=1,nsw + if (CS%nonBous_energetics) then + r_SW_top(n) = -dSpV0_dT(i) * Pen_SW_bnd(n,i) + else + r_SW_top(n) = dR0_dT(i) * Pen_SW_bnd(n,i) + endif + C2(n) = r_SW_top(n) * opacity_band(n,i,k)**2 + enddo + do itt=1,10 + dr_ent = dr ; dr_dh = 0.0 + do n=1,nsw + opacity = opacity_band(n,i,k) + SW_trans = exp(-h_ent*opacity) + dr_ent = dr_ent + r_SW_top(n) * ((1.0 - SW_trans) - & + opacity*(htot(i)+h_ent)*SW_trans) + dr_dh = dr_dh + C2(n) * (htot(i)+h_ent) * SW_trans + enddo + + if (dr_ent > 0.0) then + h_min = h_ent + else + h_max = h_ent + endif + + dh_Newt = -dr_ent / dr_dh + h_prev = h_ent ; h_ent = h_prev+dh_Newt + if (h_ent > h_max) then + h_ent = 0.5*(h_prev+h_max) + elseif (h_ent < h_min) then + h_ent = 0.5*(h_prev+h_min) + endif + + if (ABS(dh_Newt) < 0.2*Angstrom) exit + enddo + + endif + + ! Now that the amount of entrainment (h_ent) has been determined, + ! calculate changes in various terms. + sum_Pen_En = 0.0 ; Pen_absorbed = 0.0 + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + opacity = opacity_band(n,i,k) + SW_trans = exp(-h_ent*opacity) + + x1 = h_ent*opacity + if (x1 < 2.0e-5) then + En_fn = (opacity*htot(i)*(1.0 - 0.5*(x1 - C1_3*x1)) + & + x1*x1*C1_6) + else + En_fn = ((opacity*htot(i) + 2.0) * & + ((1.0-SW_trans) / x1) - 1.0 + SW_trans) + endif + if (CS%nonBous_energetics) then + sum_Pen_En = sum_Pen_En + (dSpV0_dT(i)*Pen_SW_bnd(n,i)) * En_fn + else + sum_Pen_En = sum_Pen_En - (dR0_dT(i)*Pen_SW_bnd(n,i)) * En_fn + endif + + Pen_absorbed = Pen_absorbed + Pen_SW_bnd(n,i) * (1.0 - SW_trans) + Pen_SW_bnd(n,i) = Pen_SW_bnd(n,i) * SW_trans + endif ; enddo + + if (CS%nonBous_energetics) then + ! This and the other energy calculations assume that specific volume is + ! conserved during mixing, which ignores certain thermobaric contributions. + Conv_En(i) = Conv_En(i) + 0.5 * (GV%g_Earth * GV%H_to_RZ) * h_ent * & + ( (SpV0(i,k)*htot(i) - SpV0_tot(i)) + sum_Pen_En ) + SpV0_tot(i) = SpV0_tot(i) + (h_ent * SpV0(i,k) + Pen_absorbed*dSpV0_dT(i)) + else + Conv_En(i) = Conv_En(i) + g_H_2Rho0 * h_ent * & + ( (R0_tot(i) - R0(i,k)*htot(i)) + sum_Pen_En ) + R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) + endif + + Stot(i) = Stot(i) + h_ent * S(i,k) + Ttot(i) = Ttot(i) + (h_ent * T(i,k) + Pen_absorbed) + Rcv_tot(i) = Rcv_tot(i) + (h_ent * Rcv(i,k) + Pen_absorbed*dRcv_dT(i)) + endif ! dr0 > 0.0 + + + if ((h_ent > 0.0) .and. (htot(i) > 0.0)) & + dKE_FC(i) = dKE_FC(i) + CS%bulk_Ri_convective * 0.5 * & + ((h_ent) / (htot(i)*(h_ent+htot(i)))) * & + ((uhtot(i)-u(i,k)*htot(i))**2 + (vhtot(i)-v(i,k)*htot(i))**2) + + if (h_ent > 0.0) then + htot(i) = htot(i) + h_ent + h(i,k) = h(i,k) - h_ent + d_eb(i,k) = d_eb(i,k) - h_ent + if (CS%convect_mom_bug) then + uhtot(i) = u(i,k)*h_ent ; vhtot(i) = v(i,k)*h_ent + else + uhtot(i) = uhtot(i) + h_ent*u(i,k) ; vhtot(i) = vhtot(i) + h_ent*v(i,k) + endif + endif + + endif ! h_avail>0 + endif ; enddo ! i loop + enddo ! k loop + +end subroutine mixedlayer_convection + +!> This subroutine determines the TKE available at the depth of free +!! convection to drive mechanical entrainment. +subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_FC, dKE_CA, & + TKE, TKE_river, Idecay_len_TKE, cMKE, tv, dt, Idt_diag, & + j, ksort, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G)), intent(in) :: htot !< The accumulated mixed layer thickness + !! [H ~> m or kg m-2] + real, dimension(SZI_(G)), intent(in) :: h_CA !< The mixed layer depth after convective + !! adjustment [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL pointers. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: U_star_2d !< The wind friction velocity, calculated + !! using the Boussinesq reference density or + !! the time-evolving surface density in + !! non-Boussinesq mode [Z T-1 ~> m s-1] + real, dimension(SZI_(G)), intent(inout) :: Conv_En !< The buoyant turbulent kinetic energy source + !! due to free convection [H L2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G)), intent(in) :: dKE_FC !< The vertically integrated change in + !! kinetic energy due to free convection + !! [H L2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: cTKE !< The buoyant turbulent kinetic energy + !! source due to convective adjustment + !! [H L2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dKE_CA !< The vertically integrated change in + !! kinetic energy due to convective + !! adjustment [H L2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G)), intent(out) :: TKE !< The turbulent kinetic energy available for + !! mixing over a time step [H L2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G)), intent(out) :: Idecay_len_TKE !< The inverse of the vertical decay + !! scale for TKE [H-1 ~> m-1 or m2 kg-1]. + real, dimension(SZI_(G)), intent(in) :: TKE_river !< The source of turbulent kinetic energy + !! available for driving mixing at river mouths + !! [H L2 T-3 ~> m3 s-3 or W m-2]. + real, dimension(2,SZI_(G)), intent(out) :: cMKE !< Coefficients of HpE and HpE^2 in + !! calculating the denominator of MKE_rate, + !! [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. + real, intent(in) :: dt !< The time step [T ~> s]. + real, intent(in) :: Idt_diag !< The inverse of the accumulated diagnostic + !! time interval [T-1 ~> s-1]. + integer, intent(in) :: j !< The j-index to work on. + integer, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: ksort !< The density-sorted k-indices. + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure + +! This subroutine determines the TKE available at the depth of free +! convection to drive mechanical entrainment. + + ! Local variables + real :: dKE_conv ! The change in mean kinetic energy due to all convection [H L2 T-2 ~> m3 s-2 or J m-2]. + real :: nstar_FC ! The effective efficiency with which the energy released by + ! free convection is converted to TKE, often ~0.2 [nondim]. + real :: nstar_CA ! The effective efficiency with which the energy released by + ! convective adjustment is converted to TKE, often ~0.2 [nondim]. + real :: TKE_CA ! The potential energy released by convective adjustment if + ! that release is positive [H L2 T-2 ~> m3 s-2 or J m-2]. + real :: MKE_rate_CA ! MKE_rate for convective adjustment [nondim], 0 to 1. + real :: MKE_rate_FC ! MKE_rate for free convection [nondim], 0 to 1. + real :: totEn_Z ! The total potential energy released by convection, [H Z2 T-2 ~> m3 s-2 or J m-2]. + real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. + real :: exp_kh ! The nondimensional decay of TKE across a layer [nondim]. + real :: absf ! The absolute value of f averaged to thickness points [T-1 ~> s-1]. + real :: U_star ! The friction velocity [Z T-1 ~> m s-1]. + real :: absf_Ustar ! The absolute value of f divided by U_star converted to thickness units [H-1 ~> m-1 or m2 kg-1] + real :: wind_TKE_src ! The surface wind source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + real :: diag_wt ! The ratio of the current timestep to the diagnostic + ! timestep (which may include 2 calls) [nondim]. + real :: H_to_Z ! The thickness to depth conversion factor, which in non-Boussinesq mode is + ! based on the layer-averaged specific volume [Z H-1 ~> nondim or m3 kg-1] + integer :: is, ie, nz, i + + is = G%isc ; ie = G%iec ; nz = GV%ke + diag_wt = dt * Idt_diag + + if (CS%omega_frac >= 1.0) absf = 2.0*CS%omega + do i=is,ie + U_star = U_star_2d(i,j) + + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + H_to_Z = GV%H_to_Z + else + H_to_Z = GV%H_to_RZ * tv%SpV_avg(i,j,1) + endif + + if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then + if (fluxes%frac_shelf_h(i,j) > 0.0) & + U_star = (1.0 - fluxes%frac_shelf_h(i,j)) * U_star + & + fluxes%frac_shelf_h(i,j) * fluxes%ustar_shelf(i,j) + endif + + if (U_star < CS%ustar_min) U_star = CS%ustar_min + + if (CS%omega_frac < 1.0) then + absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & + (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) + if (CS%omega_frac > 0.0) & + absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) + endif + absf_Ustar = H_to_Z * absf / U_star + Idecay_len_TKE(i) = absf_Ustar * CS%TKE_decay + +! The first number in the denominator could be anywhere up to 16. The +! value of 3 was chosen to minimize the time-step dependence of the amount +! of shear-driven mixing in 10 days of a 1-degree global model, emphasizing +! the equatorial areas. Although it is not cast as a parameter, it should +! be considered an empirical parameter, and it might depend strongly on the +! number of sublayers in the mixed layer and their locations. +! This equation assumes that small & large scales contribute to mixed layer +! deepening at similar rates, even though small scales are dissipated more +! rapidly (implying they are less efficient). +! Ih = H_to_Z / (16.0*CS%vonKar*U_star*dt) + Ih = H_to_Z / (3.0*CS%vonKar*U_star*dt) + cMKE(1,i) = 4.0 * Ih ; cMKE(2,i) = absf_Ustar * Ih + + if (Idecay_len_TKE(i) > 0.0) then + exp_kh = exp(-htot(i)*Idecay_len_TKE(i)) + else + exp_kh = 1.0 + endif + +! Here nstar is a function of the natural Rossby number 0.2/(1+0.2/Ro), based +! on a curve fit from the data of Wang (GRL, 2003). +! Note: Ro = 1.0/sqrt(0.5 * dt * (absf*htot(i))**3 / totEn) + if (Conv_En(i) < 0.0) Conv_En(i) = 0.0 + if (cTKE(i,1) > 0.0) then ; TKE_CA = cTKE(i,1) ; else ; TKE_CA = 0.0 ; endif + if ((htot(i) >= h_CA(i)) .or. (TKE_CA == 0.0)) then + totEn_Z = US%L_to_Z**2 * (Conv_En(i) + TKE_CA) + + if (totEn_Z > 0.0) then + nstar_FC = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & + sqrt(0.5 * dt * (H_to_Z**2*(absf*htot(i))**3) * totEn_Z)) + else + nstar_FC = CS%nstar + endif + nstar_CA = nstar_FC + else + ! This reconstructs the Buoyancy flux within the topmost htot of water. + if (Conv_En(i) > 0.0) then + totEn_Z = US%L_to_Z**2 * (Conv_En(i) + TKE_CA * (htot(i) / h_CA(i)) ) + nstar_FC = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & + sqrt(0.5 * dt * (H_to_Z**2*(absf*htot(i))**3) * totEn_Z)) + else + nstar_FC = CS%nstar + endif + + totEn_Z = US%L_to_Z**2 * (Conv_En(i) + TKE_CA) + if (TKE_CA > 0.0) then + nstar_CA = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & + sqrt(0.5 * dt * (H_to_Z**2*(absf*h_CA(i))**3) * totEn_Z)) + else + nstar_CA = CS%nstar + endif + endif + + if (dKE_FC(i) + dKE_CA(i,1) > 0.0) then + if (htot(i) >= h_CA(i)) then + MKE_rate_FC = 1.0 / (1.0 + htot(i)*(cMKE(1,i) + cMKE(2,i)*htot(i)) ) + MKE_rate_CA = MKE_rate_FC + else + MKE_rate_FC = 1.0 / (1.0 + htot(i)*(cMKE(1,i) + cMKE(2,i)*htot(i)) ) + MKE_rate_CA = 1.0 / (1.0 + h_CA(i)*(cMKE(1,i) + cMKE(2,i)*h_CA(i)) ) + endif + else + ! This branch just saves unnecessary calculations. + MKE_rate_FC = 1.0 ; MKE_rate_CA = 1.0 + endif + + dKE_conv = dKE_CA(i,1) * MKE_rate_CA + dKE_FC(i) * MKE_rate_FC +! At this point, it is assumed that cTKE is positive and stored in TKE_CA! +! Note: Removed factor of 2 in u*^3 terms. + if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.(associated(fluxes%tau_mag))) then + TKE(i) = (dt*CS%mstar)*((GV%Z_to_H*US%Z_to_L**2*(U_star*U_Star*U_Star))*exp_kh) + & + (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) + else + ! Note that GV%Z_to_H*US%Z_to_L**2*U_star**3 = GV%RZ_to_H * US%Z_to_L*fluxes%tau_mag(i,j) * U_star + TKE(i) = (dt*CS%mstar) * ((GV%RZ_to_H*US%Z_to_L * fluxes%tau_mag(i,j) * U_star)*exp_kh) + & + (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) + endif + + if (CS%do_rivermix) then ! Add additional TKE at river mouths + TKE(i) = TKE(i) + TKE_river(i)*dt*exp_kh + endif + + if (CS%TKE_diagnostics) then + if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.(associated(fluxes%tau_mag))) then + wind_TKE_src = CS%mstar*(GV%Z_to_H*US%Z_to_L**2*U_star*U_Star*U_Star) * diag_wt + else + wind_TKE_src = CS%mstar*(GV%RZ_to_H * US%Z_to_L*fluxes%tau_mag(i,j) * U_star) * diag_wt + endif + CS%diag_TKE_wind(i,j) = CS%diag_TKE_wind(i,j) + & + ( wind_TKE_src + TKE_river(i) * diag_wt ) + CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + dKE_conv*Idt_diag + CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + & + (exp_kh-1.0)*(wind_TKE_src + dKE_conv*Idt_diag) + CS%diag_TKE_conv(i,j) = CS%diag_TKE_conv(i,j) + & + Idt_diag * (nstar_FC*Conv_En(i) + nstar_CA*TKE_CA) + CS%diag_TKE_conv_decay(i,j) = CS%diag_TKE_conv_decay(i,j) + & + Idt_diag * ((CS%nstar-nstar_FC)*Conv_En(i) + (CS%nstar-nstar_CA)*TKE_CA) + CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) + & + Idt_diag * (cTKE(i,1)-TKE_CA) + endif + enddo + +end subroutine find_starting_TKE + +!> This subroutine calculates mechanically driven entrainment. +subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & + R0_tot, SpV0_tot, Rcv_tot, u, v, T, S, R0, SpV0, Rcv, eps, & + dR0_dT, dSpV0_dT, dRcv_dT, cMKE, Idt_diag, nsw, & + Pen_SW_bnd, opacity_band, TKE, & + Idecay_len_TKE, j, ksort, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZK0_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(inout) :: d_eb !< The downward increase across a layer in the + !! layer in the entrainment from below [H ~> m or kg m-2]. + !! Positive values go with mass gain by a layer. + real, dimension(SZI_(G)), intent(inout) :: htot !< The accumulated mixed layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(inout) :: Ttot !< The depth integrated mixed layer temperature + !! [C H ~> degC m or degC kg m-2]. + real, dimension(SZI_(G)), intent(inout) :: Stot !< The depth integrated mixed layer salinity + !! [S H ~> ppt m or ppt kg m-2]. + real, dimension(SZI_(G)), intent(inout) :: uhtot !< The depth integrated mixed layer zonal + !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G)), intent(inout) :: vhtot !< The integrated mixed layer meridional + !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G)), intent(inout) :: R0_tot !< The integrated mixed layer potential density + !! referenced to 0 pressure [H R ~> kg m-2 or kg2 m-5]. + real, dimension(SZI_(G)), intent(inout) :: SpV0_tot !< The integrated mixed layer specific volume referenced + !! to 0 pressure [H R-1 ~> m4 kg-1 or m]. + real, dimension(SZI_(G)), intent(inout) :: Rcv_tot !< The integrated mixed layer coordinate variable + !! potential density [H R ~> kg m-2 or kg2 m-5]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocities interpolated to h points [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: v !< Zonal velocities interpolated to h points [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: T !< Layer temperatures [C ~> degC]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: S !< Layer salinities [S ~> ppt]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: R0 !< Potential density referenced to + !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: Rcv !< The coordinate defining potential + !! density [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: eps !< The negligibly small amount of water + !! that will be left in each layer [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of R0 with respect to + !! temperature [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of SpV0 with respect to + !! temperature [R-1 C-1 ~> m3 kg-1 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of Rcv with respect to + !! temperature [R C-1 ~> kg m-3 degC-1]. + real, dimension(2,SZI_(G)), intent(in) :: cMKE !< Coefficients of HpE and HpE^2 used in calculating the + !! denominator of MKE_rate; the two elements have differing + !! units of [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. + real, intent(in) :: Idt_diag !< The inverse of the accumulated diagnostic + !! time interval [T-1 ~> s-1]. + integer, intent(in) :: nsw !< The number of bands of penetrating + !! shortwave radiation. + real, dimension(max(nsw,1),SZI_(G)), intent(inout) :: Pen_SW_bnd !< The penetrating shortwave + !! heating at the sea surface in each penetrating + !! band [C H ~> degC m or degC kg m-2]. + real, dimension(max(nsw,1),SZI_(G),SZK_(GV)), intent(in) :: opacity_band !< The opacity in each band of + !! penetrating shortwave radiation [H-1 ~> m-1 or m2 kg-1]. + real, dimension(SZI_(G)), intent(inout) :: TKE !< The turbulent kinetic energy + !! available for mixing over a time + !! step [H L2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G)), intent(inout) :: Idecay_len_TKE !< The vertical TKE decay rate [H-1 ~> m-1 or m2 kg-1]. + integer, intent(in) :: j !< The j-index to work on. + integer, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: ksort !< The density-sorted k-indices. + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure + +! This subroutine calculates mechanically driven entrainment. + + ! Local variables + real :: SW_trans ! The fraction of shortwave radiation that is not + ! absorbed in a layer [nondim]. + real :: Pen_absorbed ! The amount of penetrative shortwave radiation + ! that is absorbed in a layer [C H ~> degC m or degC kg m-2]. + real :: h_avail ! The thickness in a layer available for entrainment [H ~> m or kg m-2]. + real :: h_ent ! The thickness from a layer that is entrained [H ~> m or kg m-2]. + real :: h_min, h_max ! Limits on the solution for h_ent [H ~> m or kg m-2]. + real :: dh_Newt ! The Newton's method estimate of the change in + ! h_ent between iterations [H ~> m or kg m-2]. + real :: MKE_rate ! The fraction of the energy in resolved shears + ! within the mixed layer that will be eliminated + ! within a timestep [nondim], 0 to 1. + real :: HpE ! The current thickness plus entrainment [H ~> m or kg m-2]. + real :: g_H_2Rho0 ! Half the gravitational acceleration times the + ! conversion from H to m divided by the mean density, + ! in [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + real :: TKE_full_ent ! The TKE remaining if a layer is fully entrained + ! [H L2 T-2 ~> m3 s-2 or J m-2]. + real :: dRL ! Work required to mix water from the next layer + ! across the mixed layer [L2 T-2 ~> m2 s-2]. + real :: Pen_En_Contrib ! Penetrating SW contributions to the changes in + ! TKE, divided by layer thickness in m [L2 T-2 ~> m2 s-2]. + real :: Cpen1 ! A temporary variable [L2 T-2 ~> m2 s-2]. + real :: dMKE ! A temporary variable related to the release of mean + ! kinetic energy [H2 L2 T-2 ~> m4 s-2 or kg2 m-2 s-2] + real :: TKE_ent ! The TKE that remains if h_ent were entrained [H L2 T-2 ~> m3 s-2 or J m-2] + real :: TKE_ent1 ! The TKE that would remain, without considering the + ! release of mean kinetic energy [H L2 T-2 ~> m3 s-2 or J m-2] + real :: dTKE_dh ! The partial derivative of TKE with h_ent [L2 T-2 ~> m2 s-2] + real :: Pen_dTKE_dh_Contrib ! The penetrating shortwave contribution to + ! dTKE_dh [L2 T-2 ~> m2 s-2]. + real :: EF4_val ! The result of EF4() (see later) [H-1 ~> m-1 or m2 kg-1]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dEF4_dh ! The partial derivative of EF4 with h [H-2 ~> m-2 or m4 kg-2]. + real :: Pen_En1 ! A nondimensional temporary variable [nondim]. + real :: kh, exp_kh, f1_kh ! Nondimensional temporary variables related to the + ! fractional decay of TKE across a layer [nondim]. + real :: x1, e_x1 ! Nondimensional temporary variables related to the relative decay + ! of TKE and SW radiation across a layer [nondim] + real :: f1_x1, f2_x1, f3_x1 ! Exponential-related functions of x1 [nondim]. + real :: E_HxHpE ! Entrainment divided by the product of the new and old + ! thicknesses [H-1 ~> m-1 or m2 kg-1]. + real :: Hmix_min ! The minimum mixed layer depth [H ~> m or kg m-2]. + real :: opacity ! The opacity of a layer in a band of shortwave radiation [H-1 ~> m-1 or m2 kg-1] + real :: C1_3, C1_6, C1_24 ! 1/3, 1/6, and 1/24. [nondim] + integer :: is, ie, nz, i, k, ks, itt, n + + C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 ; C1_24 = 1.0/24.0 + g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * GV%Rho0) + Hmix_min = CS%Hmix_min + h_neglect = GV%H_subroundoff + is = G%isc ; ie = G%iec ; nz = GV%ke + + do ks=1,nz + + do i=is,ie ; if (ksort(i,ks) > 0) then + k = ksort(i,ks) + + h_avail = h(i,k) - eps(i,k) + if ((h_avail > 0.) .and. ((TKE(i) > 0.) .or. (htot(i) < Hmix_min))) then + if (CS%nonBous_energetics) then + dRL = 0.5 * (GV%g_Earth * GV%H_to_RZ) * (SpV0_tot(i) - SpV0(i,k)*htot(i)) + else + dRL = g_H_2Rho0 * (R0(i,k)*htot(i) - R0_tot(i) ) + endif + dMKE = CS%bulk_Ri_ML * 0.5 * & + ((uhtot(i)-u(i,k)*htot(i))**2 + (vhtot(i)-v(i,k)*htot(i))**2) + +! Find the TKE that would remain if the entire layer were entrained. + kh = Idecay_len_TKE(i)*h_avail ; exp_kh = exp(-kh) + if (kh >= 2.0e-5) then ; f1_kh = (1.0-exp_kh) / kh + else ; f1_kh = (1.0 - kh*(0.5 - C1_6*kh)) ; endif + + Pen_En_Contrib = 0.0 + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + opacity = opacity_band(n,i,k) +! Two different forms are used here to make sure that only negative +! values are taken into exponentials to avoid excessively large +! numbers. They are, of course, mathematically identical. + if (Idecay_len_TKE(i) > opacity) then + x1 = (Idecay_len_TKE(i) - opacity) * h_avail + if (x1 >= 2.0e-5) then + e_x1 = exp(-x1) ; f1_x1 = ((1.0-e_x1)/(x1)) + f3_x1 = ((e_x1-(1.0-x1))/(x1*x1)) + else + f1_x1 = (1.0 - x1*(0.5 - C1_6*x1)) + f3_x1 = (0.5 - x1*(C1_6 - C1_24*x1)) + endif + + Pen_En1 = exp(-opacity*h_avail) * & + ((1.0+opacity*htot(i))*f1_x1 + opacity*h_avail*f3_x1) + else + x1 = (opacity - Idecay_len_TKE(i)) * h_avail + if (x1 >= 2.0e-5) then + e_x1 = exp(-x1) ; f1_x1 = ((1.0-e_x1)/(x1)) + f2_x1 = ((1.0-(1.0+x1)*e_x1)/(x1*x1)) + else + f1_x1 = (1.0 - x1*(0.5 - C1_6*x1)) + f2_x1 = (0.5 - x1*(C1_3 - 0.125*x1)) + endif + + Pen_En1 = exp_kh * ((1.0+opacity*htot(i))*f1_x1 + & + opacity*h_avail*f2_x1) + endif + if (CS%nonBous_energetics) then + Pen_En_Contrib = Pen_En_Contrib - & + (0.5 * (GV%g_Earth * GV%H_to_RZ) * dSpV0_dT(i)*Pen_SW_bnd(n,i)) * (Pen_En1 - f1_kh) + else + Pen_En_Contrib = Pen_En_Contrib + & + (g_H_2Rho0*dR0_dT(i)*Pen_SW_bnd(n,i)) * (Pen_En1 - f1_kh) + endif + endif ; enddo + + HpE = htot(i)+h_avail + MKE_rate = 1.0/(1.0 + (cMKE(1,i)*HpE + cMKE(2,i)*HpE**2)) + EF4_val = EF4(htot(i)+h_neglect,h_avail,Idecay_len_TKE(i)) + TKE_full_ent = (exp_kh*TKE(i) - h_avail*(dRL*f1_kh + Pen_En_Contrib)) + & + MKE_rate*dMKE*EF4_val + if ((TKE_full_ent >= 0.0) .or. (h_avail+htot(i) <= Hmix_min)) then + ! The layer will be fully entrained. + h_ent = h_avail + + if (CS%TKE_diagnostics) then + E_HxHpE = h_ent / ((htot(i)+h_neglect)*(htot(i)+h_ent+h_neglect)) + CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + & + Idt_diag * ((exp_kh-1.0)* TKE(i) + h_ent*dRL*(1.0-f1_kh) + & + MKE_rate*dMKE*(EF4_val-E_HxHpE)) + CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - Idt_diag*h_ent*dRL + CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - & + Idt_diag*h_ent*Pen_En_Contrib + CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + & + Idt_diag*MKE_rate*dMKE*E_HxHpE + endif + + TKE(i) = TKE_full_ent + + if (TKE(i) <= 0.0) TKE(i) = CS%mech_TKE_floor + else +! The layer is only partially entrained. The amount that will be +! entrained is determined iteratively. No further layers will be +! entrained. + h_min = 0.0 ; h_max = h_avail + if (TKE(i) <= 0.0) then + h_ent = 0.0 + else + h_ent = h_avail * TKE(i) / (TKE(i) - TKE_full_ent) + + do itt=1,15 + ! Evaluate the TKE that would remain if h_ent were entrained. + + kh = Idecay_len_TKE(i)*h_ent ; exp_kh = exp(-kh) + if (kh >= 2.0e-5) then + f1_kh = (1.0-exp_kh) / kh + else + f1_kh = (1.0 - kh*(0.5 - C1_6*kh)) + endif + + + Pen_En_Contrib = 0.0 ; Pen_dTKE_dh_Contrib = 0.0 + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + ! Two different forms are used here to make sure that only negative + ! values are taken into exponentials to avoid excessively large + ! numbers. They are, of course, mathematically identical. + opacity = opacity_band(n,i,k) + SW_trans = exp(-h_ent*opacity) + if (Idecay_len_TKE(i) > opacity) then + x1 = (Idecay_len_TKE(i) - opacity) * h_ent + if (x1 >= 2.0e-5) then + e_x1 = exp(-x1) ; f1_x1 = ((1.0-e_x1)/(x1)) + f3_x1 = ((e_x1-(1.0-x1))/(x1*x1)) + else + f1_x1 = (1.0 - x1*(0.5 - C1_6*x1)) + f3_x1 = (0.5 - x1*(C1_6 - C1_24*x1)) + endif + Pen_En1 = SW_trans * ((1.0+opacity*htot(i))*f1_x1 + & + opacity*h_ent*f3_x1) + else + x1 = (opacity - Idecay_len_TKE(i)) * h_ent + if (x1 >= 2.0e-5) then + e_x1 = exp(-x1) ; f1_x1 = ((1.0-e_x1)/(x1)) + f2_x1 = ((1.0-(1.0+x1)*e_x1)/(x1*x1)) + else + f1_x1 = (1.0 - x1*(0.5 - C1_6*x1)) + f2_x1 = (0.5 - x1*(C1_3 - 0.125*x1)) + endif + + Pen_En1 = exp_kh * ((1.0+opacity*htot(i))*f1_x1 + & + opacity*h_ent*f2_x1) + endif + if (CS%nonBous_energetics) then + Cpen1 = -0.5 * (GV%g_Earth * GV%H_to_RZ) * dSpV0_dT(i) * Pen_SW_bnd(n,i) + else + Cpen1 = g_H_2Rho0 * dR0_dT(i) * Pen_SW_bnd(n,i) + endif + Pen_En_Contrib = Pen_En_Contrib + Cpen1*(Pen_En1 - f1_kh) + Pen_dTKE_dh_Contrib = Pen_dTKE_dh_Contrib + & + Cpen1*((1.0-SW_trans) - opacity*(htot(i) + h_ent)*SW_trans) + endif ; enddo ! (Pen_SW_bnd(n,i) > 0.0) + + TKE_ent1 = exp_kh* TKE(i) - h_ent*(dRL*f1_kh + Pen_En_Contrib) + EF4_val = EF4(htot(i)+h_neglect,h_ent,Idecay_len_TKE(i),dEF4_dh) + HpE = htot(i)+h_ent + MKE_rate = 1.0/(1.0 + (cMKE(1,i)*HpE + cMKE(2,i)*HpE**2)) + TKE_ent = TKE_ent1 + dMKE*EF4_val*MKE_rate + ! TKE_ent is the TKE that would remain if h_ent were entrained. + + dTKE_dh = ((-Idecay_len_TKE(i)*TKE_ent1 - dRL) + & + Pen_dTKE_dh_Contrib) + dMKE * MKE_rate* & + (dEF4_dh - EF4_val*MKE_rate*(cMKE(1,i)+2.0*cMKE(2,i)*HpE)) + ! dh_Newt = -TKE_ent / dTKE_dh + ! Bisect if the Newton's method prediction is outside of the bounded range. + if (TKE_ent > 0.0) then + if ((h_max-h_ent)*(-dTKE_dh) > TKE_ent) then + dh_Newt = -TKE_ent / dTKE_dh + else + dh_Newt = 0.5*(h_max-h_ent) + endif + h_min = h_ent + else + if ((h_min-h_ent)*(-dTKE_dh) < TKE_ent) then + dh_Newt = -TKE_ent / dTKE_dh + else + dh_Newt = 0.5*(h_min-h_ent) + endif + h_max = h_ent + endif + h_ent = h_ent + dh_Newt + + if (ABS(dh_Newt) < 0.2*GV%Angstrom_H) exit + enddo + endif + + if (h_ent < Hmix_min-htot(i)) h_ent = Hmix_min - htot(i) + + if (CS%TKE_diagnostics) then + HpE = htot(i)+h_ent + MKE_rate = 1.0/(1.0 + cMKE(1,i)*HpE + cMKE(2,i)*HpE**2) + EF4_val = EF4(htot(i)+h_neglect,h_ent,Idecay_len_TKE(i)) + + E_HxHpE = h_ent / ((htot(i)+h_neglect)*(HpE+h_neglect)) + CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + & + Idt_diag * ((exp_kh-1.0)* TKE(i) + h_ent*dRL*(1.0-f1_kh) + & + dMKE*MKE_rate*(EF4_val-E_HxHpE)) + CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - Idt_diag*h_ent*dRL + CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - Idt_diag*h_ent*Pen_En_Contrib + CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + Idt_diag*dMKE*MKE_rate*E_HxHpE + endif + + TKE(i) = 0.0 + endif ! TKE_full_ent > 0.0 + + Pen_absorbed = 0.0 + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + SW_trans = exp(-h_ent*opacity_band(n,i,k)) + Pen_absorbed = Pen_absorbed + Pen_SW_bnd(n,i) * (1.0 - SW_trans) + Pen_SW_bnd(n,i) = Pen_SW_bnd(n,i) * SW_trans + endif ; enddo + + htot(i) = htot(i) + h_ent + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0_tot(i) + (h_ent * SpV0(i,k) + Pen_absorbed*dSpV0_dT(i)) + else + R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) + endif + h(i,k) = h(i,k) - h_ent + d_eb(i,k) = d_eb(i,k) - h_ent + + Stot(i) = Stot(i) + h_ent * S(i,k) + Ttot(i) = Ttot(i) + (h_ent * T(i,k) + Pen_absorbed) + Rcv_tot(i) = Rcv_tot(i) + (h_ent*Rcv(i,k) + Pen_absorbed*dRcv_dT(i)) + + uhtot(i) = uhtot(i) + u(i,k)*h_ent + vhtot(i) = vhtot(i) + v(i,k)*h_ent + endif ! h_avail > 0.0 .AND TKE(i) > 0.0 + + endif ; enddo ! i loop + enddo ! k loop + +end subroutine mechanical_entrainment + +!> This subroutine generates an array of indices that are sorted by layer +!! density. +subroutine sort_ML(h, R0, SpV0, eps, G, GV, CS, ksort) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZK0_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK0_(GV)), intent(in) :: R0 !< The potential density used to sort + !! the layers [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(in) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: eps !< The (small) thickness that must + !! remain in each layer [H ~> m or kg m-2]. + type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure + integer, dimension(SZI_(G),SZK_(GV)), intent(out) :: ksort !< The k-index to use in the sort. + + ! Local variables + real :: R0sort(SZI_(G),SZK_(GV)) ! The sorted potential density [R ~> kg m-3] + real :: SpV0sort(SZI_(G),SZK_(GV)) ! The sorted specific volume [R-1 ~> m3 kg-1] + integer :: nsort(SZI_(G)) ! The number of layers left to sort + logical :: done_sorting(SZI_(G)) + integer :: i, k, ks, is, ie, nz, nkmb + + is = G%isc ; ie = G%iec ; nz = GV%ke + nkmb = CS%nkml+CS%nkbl + + ! Come up with a sorted index list of layers with increasing R0. + ! Assume that the layers below nkmb are already stably stratified. + ! Only layers that are thicker than eps are in the list. Extra elements + ! have an index of -1. + + ! This is coded using straight insertion, on the assumption that the + ! layers are usually in the right order (or massless) anyway. + + do k=1,nz ; do i=is,ie ; ksort(i,k) = -1 ; enddo ; enddo + + do i=is,ie ; nsort(i) = 0 ; done_sorting(i) = .false. ; enddo + + if (CS%nonBous_energetics) then + do k=1,nz ; do i=is,ie ; if (h(i,k) > eps(i,k)) then + if (done_sorting(i)) then ; ks = nsort(i) ; else + do ks=nsort(i),1,-1 + if (SpV0(i,k) <= SpV0sort(i,ks)) exit + SpV0sort(i,ks+1) = SpV0sort(i,ks) ; ksort(i,ks+1) = ksort(i,ks) + enddo + if ((k > nkmb) .and. (ks == nsort(i))) done_sorting(i) = .true. + endif + + ksort(i,ks+1) = k + SpV0sort(i,ks+1) = SpV0(i,k) + nsort(i) = nsort(i) + 1 + endif ; enddo ; enddo + else + do k=1,nz ; do i=is,ie ; if (h(i,k) > eps(i,k)) then + if (done_sorting(i)) then ; ks = nsort(i) ; else + do ks=nsort(i),1,-1 + if (R0(i,k) >= R0sort(i,ks)) exit + R0sort(i,ks+1) = R0sort(i,ks) ; ksort(i,ks+1) = ksort(i,ks) + enddo + if ((k > nkmb) .and. (ks == nsort(i))) done_sorting(i) = .true. + endif + + ksort(i,ks+1) = k + R0sort(i,ks+1) = R0(i,k) + nsort(i) = nsort(i) + 1 + endif ; enddo ; enddo + endif + +end subroutine sort_ML + +!> This subroutine actually moves properties between layers to achieve a +!! resorted state, with all of the resorted water either moved into the correct +!! interior layers or in the top nkmb layers. +subroutine resort_ML(h, T, S, R0, SpV0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS, & + dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid + !! structure. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. + !! Layer 0 is the new mixed layer. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Layer temperatures [C ~> degC]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Layer salinities [S ~> ppt]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to + !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining + !! potential density [R ~> kg m-3]. + real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each + !! layer [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: eps !< The (small) thickness that must + !! remain in each layer [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_ea !< The upward increase across a + !! layer in the entrainment from + !! above [H ~> m or kg m-2]. + !! Positive d_ea goes with layer + !! thickness increases. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_eb !< The downward increase across a + !! layer in the entrainment from + !! below [H ~> m or kg m-2]. Positive values go + !! with mass gain by a layer. + integer, dimension(SZI_(G),SZK_(GV)), intent(in) :: ksort !< The density-sorted k-indices. + type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure + real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of + !! potential density referenced + !! to the surface with potential + !! temperature [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of + !! potential density referenced + !! to the surface with salinity, + !! [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of SpV0 with respect + !! to temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)), intent(in) :: dSpV0_dS !< The partial derivative of SpV0 with respect + !! to salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of + !! coordinate defining potential + !! density with potential + !! temperature [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of + !! coordinate defining potential + !! density with salinity, + !! [R S-1 ~> kg m-3 ppt-1]. + +! If there are no massive light layers above the deepest of the mixed- and +! buffer layers, do nothing (except perhaps to reshuffle these layers). +! If there are nkbl or fewer layers above the deepest mixed- or buffer- +! layers, move them (in sorted order) into the buffer layers, even if they +! were previously interior layers. +! If there are interior layers that are intermediate in density (both in-situ +! and the coordinate density (sigma-2)) between the newly forming mixed layer +! and a residual buffer- or mixed layer, and the number of massive layers above +! the deepest massive buffer or mixed layer is greater than nkbl, then split +! those buffer layers into pieces that match the target density of the two +! nearest interior layers. +! Otherwise, if there are more than nkbl+1 remaining massive layers + + ! Local variables + real :: h_move ! The thickness of water being moved between layers [H ~> m or kg m-2] + real :: h_tgt_old ! The previous thickness of the recipient layer [H ~> m or kg m-2] + real :: I_hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: dT_dS_wt2 ! The square of the relative weighting of temperature and salinity changes + ! when extrapolating to match a target density [C2 S-2 ~> degC2 ppt-2] + real :: dT_dR ! The ratio of temperature changes to density changes when + ! extrapolating [C R-1 ~> degC m3 kg-1] + real :: dS_dR ! The ratio of salinity changes to density changes when + ! extrapolating [S R-1 ~> ppt m3 kg-1] + real :: I_denom ! A work variable with units of [S2 R-2 ~> ppt2 m6 kg-2]. + real :: Rcv_int ! The target coordinate density of an interior layer [R ~> kg m-3] + real :: T_up, T_dn ! Temperatures projected to match the target densities of two layers [C ~> degC] + real :: S_up, S_dn ! Salinities projected to match the target densities of two layers [S ~> ppt] + real :: R0_up, R0_dn ! Potential densities projected to match the target coordinate + ! densities of two layers [R ~> kg m-3] + real :: SpV0_up, SpV0_dn ! Specific volumes projected to be consistent with the target coordinate + ! densities of two layers [R-1 ~> m3 kg-1] + real :: I_hup, I_hdn ! Inverse of the new thicknesses of the two layers [H-1 ~> m-1 or m2 kg-1] + real :: h_to_up, h_to_dn ! Thickness transferred to two layers [H ~> m or kg m-2] + real :: wt_dn ! Fraction of the thickness transferred to the deeper layer [nondim] + real :: dR1, dR2 ! Density difference with the target densities of two layers [R ~> kg m-3] + real :: dPE, min_dPE ! Values proportional to the potential energy change due to the merging of a + ! pair of layers [R H2 ~> kg m-1 or kg3 m-7] or [R-1 H2 ~> m5 kg-1 or kg m-1] + real :: hmin, min_hmin ! The thickness of the thinnest layer [H ~> m or kg m-2] + real :: h_tmp(SZK_(GV)) ! A copy of the original layer thicknesses [H ~> m or kg m-2] + real :: R0_tmp(SZK_(GV)) ! A copy of the original layer potential densities [R ~> kg m-3] + real :: SpV0_tmp(SZK_(GV)) ! A copy of the original layer specific volumes [R ~> kg m-3] + real :: T_tmp(SZK_(GV)) ! A copy of the original layer temperatures [C ~> degC] + real :: S_tmp(SZK_(GV)) ! A copy of the original layer salinities [S ~> ppt] + real :: Rcv_tmp(SZK_(GV)) ! A copy of the original layer coordinate densities [R ~> kg m-3] + integer :: ks_min + logical :: sorted, leave_in_layer + integer :: ks_deep(SZI_(G)), k_count(SZI_(G)), ks2_reverse(SZI_(G), SZK_(GV)) + integer :: ks2(SZK_(GV)) + integer :: i, k, ks, is, ie, nz, k1, k2, k_tgt, k_src, k_int_top + integer :: nks, nkmb, num_interior, top_interior_ks + + is = G%isc ; ie = G%iec ; nz = GV%ke + nkmb = CS%nkml+CS%nkbl + + dT_dS_wt2 = CS%dT_dS_wt**2 + +! Find out how many massive layers are above the deepest buffer or mixed layer. + do i=is,ie ; ks_deep(i) = -1 ; k_count(i) = 0 ; enddo + do ks=nz,1,-1 ; do i=is,ie ; if (ksort(i,ks) > 0) then + k = ksort(i,ks) + + if (h(i,k) > eps(i,k)) then + if (ks_deep(i) == -1) then + if (k <= nkmb) then + ks_deep(i) = ks ; k_count(i) = k_count(i) + 1 + ks2_reverse(i,k_count(i)) = k + endif + else + k_count(i) = k_count(i) + 1 + ks2_reverse(i,k_count(i)) = k + endif + endif + endif ; enddo ; enddo + + do i=is,ie ; if (k_count(i) > 1) then + ! This column might need to be reshuffled. + nks = k_count(i) + + ! Put ks2 in the right order and check whether reshuffling is needed. + sorted = .true. + ks2(nks) = ks2_reverse(i,1) + do ks=nks-1,1,-1 + ks2(ks) = ks2_reverse(i,1+nks-ks) + if (ks2(ks) > ks2(ks+1)) sorted = .false. + enddo + + ! Go to the next column of no reshuffling is needed. + if (sorted) cycle + + ! Find out how many interior layers are being reshuffled. If none, + ! then this is a simple swapping procedure. + num_interior = 0 ; top_interior_ks = 0 + do ks=nks,1,-1 ; if (ks2(ks) > nkmb) then + num_interior = num_interior+1 ; top_interior_ks = ks + endif ; enddo + + if (num_interior >= 1) then + ! Find the lightest interior layer with a target coordinate density + ! greater than the newly forming mixed layer. + do k=nkmb+1,nz ; if (Rcv(i,0) < RcvTgt(k)) exit ; enddo + k_int_top = k ; Rcv_int = RcvTgt(k) + + I_denom = 1.0 / (dRcv_dS(i)**2 + dT_dS_wt2*dRcv_dT(i)**2) + dT_dR = dT_dS_wt2*dRcv_dT(i) * I_denom + dS_dR = dRcv_dS(i) * I_denom + + + ! Examine whether layers can be split out of existence. Stop when there + ! is a layer that cannot be handled this way, or when the topmost formerly + ! interior layer has been dealt with. + do ks = nks,top_interior_ks,-1 + k = ks2(ks) + leave_in_layer = .false. + if ((k > nkmb) .and. (Rcv(i,k) <= RcvTgt(k))) then + if (RcvTgt(k)-Rcv(i,k) < CS%BL_split_rho_tol*(RcvTgt(k) - RcvTgt(k-1))) & + leave_in_layer = .true. + elseif (k > nkmb) then + if (Rcv(i,k)-RcvTgt(k) < CS%BL_split_rho_tol*(RcvTgt(k+1) - RcvTgt(k))) & + leave_in_layer = .true. + endif + + if (leave_in_layer) then + ! Just drop this layer from the sorted list. + nks = nks-1 + elseif (Rcv(i,k) < Rcv_int) then + ! There is no interior layer with a target density that is intermediate + ! between this layer and the mixed layer. + exit + else + ! Try splitting the layer between two interior isopycnal layers. + ! Find the target densities that bracket this layer. + do k2=k_int_top+1,nz ; if (Rcv(i,k) < RcvTgt(k2)) exit ; enddo + if (k2>nz) exit + + ! This layer is bracketed in density between layers k2-1 and k2. + + dR1 = (RcvTgt(k2-1) - Rcv(i,k)) ; dR2 = (RcvTgt(k2) - Rcv(i,k)) + T_up = T(i,k) + dT_dR * dR1 + S_up = S(i,k) + dS_dR * dR1 + T_dn = T(i,k) + dT_dR * dR2 + S_dn = S(i,k) + dS_dR * dR2 + + if (CS%nonBous_energetics) then + SpV0_up = SpV0(i,k) + (dT_dR*dSpV0_dT(i) + dS_dR*dSpV0_dS(i)) * dR1 + SpV0_dn = SpV0(i,k) + (dT_dR*dSpV0_dT(i) + dS_dR*dSpV0_dS(i)) * dR2 + + ! Make sure the new properties are acceptable, and avoid creating obviously unstable profiles. + if ((SpV0_up < SpV0(i,0)) .or. (SpV0_dn < SpV0(i,0))) exit + else + R0_up = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR1 + R0_dn = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR2 + + ! Make sure the new properties are acceptable, and avoid creating obviously unstable profiles. + if ((R0_up > R0(i,0)) .or. (R0_dn > R0(i,0))) exit + endif + + wt_dn = (Rcv(i,k) - RcvTgt(k2-1)) / (RcvTgt(k2) - RcvTgt(k2-1)) + h_to_up = (h(i,k)-eps(i,k)) * (1.0 - wt_dn) + h_to_dn = (h(i,k)-eps(i,k)) * wt_dn + + I_hup = 1.0 / (h(i,k2-1) + h_to_up) + I_hdn = 1.0 / (h(i,k2) + h_to_dn) + if (CS%nonBous_energetics) then + SpV0(i,k2-1) = (SpV0(i,k2)*h(i,k2-1) + SpV0_up*h_to_up) * I_hup + SpV0(i,k2) = (SpV0(i,k2)*h(i,k2) + SpV0_dn*h_to_dn) * I_hdn + else + R0(i,k2-1) = (R0(i,k2)*h(i,k2-1) + R0_up*h_to_up) * I_hup + R0(i,k2) = (R0(i,k2)*h(i,k2) + R0_dn*h_to_dn) * I_hdn + endif + + T(i,k2-1) = (T(i,k2)*h(i,k2-1) + T_up*h_to_up) * I_hup + T(i,k2) = (T(i,k2)*h(i,k2) + T_dn*h_to_dn) * I_hdn + S(i,k2-1) = (S(i,k2)*h(i,k2-1) + S_up*h_to_up) * I_hup + S(i,k2) = (S(i,k2)*h(i,k2) + S_dn*h_to_dn) * I_hdn + Rcv(i,k2-1) = (Rcv(i,k2)*h(i,k2-1) + RcvTgt(k2-1)*h_to_up) * I_hup + Rcv(i,k2) = (Rcv(i,k2)*h(i,k2) + RcvTgt(k2)*h_to_dn) * I_hdn + + h(i,k) = eps(i,k) + h(i,k2) = h(i,k2) + h_to_dn + h(i,k2-1) = h(i,k2-1) + h_to_up + + if (k > k2-1) then + d_eb(i,k) = d_eb(i,k) - h_to_up + d_eb(i,k2-1) = d_eb(i,k2-1) + h_to_up + elseif (k < k2-1) then + d_ea(i,k) = d_ea(i,k) - h_to_up + d_ea(i,k2-1) = d_ea(i,k2-1) + h_to_up + endif + if (k > k2) then + d_eb(i,k) = d_eb(i,k) - h_to_dn + d_eb(i,k2) = d_eb(i,k2) + h_to_dn + elseif (k < k2) then + d_ea(i,k) = d_ea(i,k) - h_to_dn + d_ea(i,k2) = d_ea(i,k2) + h_to_dn + endif + nks = nks-1 + endif + enddo + endif + + do while (nks > nkmb) + ! Having already tried to move surface layers into the interior, there + ! are still too many layers, and layers must be merged until nks=nkmb. + ! Examine every merger of a layer with its neighbors, and merge the ones + ! that increase the potential energy the least. If there are layers + ! with (apparently?) negative potential energy change, choose the one + ! with the smallest total thickness. Repeat until nkmb layers remain. + ! Choose the smaller value for the remaining index for convenience. + + ks_min = -1 ; min_dPE = 1.0 ; min_hmin = 0.0 + do ks=1,nks-1 + k1 = ks2(ks) ; k2 = ks2(ks+1) + if (CS%nonBous_energetics) then + dPE = max(0.0, (SpV0(i,k1) - SpV0(i,k2)) * (h(i,k1) * h(i,k2))) + else + dPE = max(0.0, (R0(i,k2) - R0(i,k1)) * h(i,k1) * h(i,k2)) + endif + hmin = min(h(i,k1)-eps(i,k1), h(i,k2)-eps(i,k2)) + if ((ks_min < 0) .or. (dPE < min_dPE) .or. & + ((dPE <= 0.0) .and. (hmin < min_hmin))) then + ks_min = ks ; min_dPE = dPE ; min_hmin = hmin + endif + enddo + + ! Now merge the two layers that do the least damage. + k1 = ks2(ks_min) ; k2 = ks2(ks_min+1) + if (k1 < k2) then ; k_tgt = k1 ; k_src = k2 + else ; k_tgt = k2 ; k_src = k1 ; ks2(ks_min) = k2 ; endif + + h_tgt_old = h(i,k_tgt) + h_move = h(i,k_src)-eps(i,k_src) + h(i,k_src) = eps(i,k_src) + h(i,k_tgt) = h(i,k_tgt) + h_move + I_hnew = 1.0 / (h(i,k_tgt)) + if (CS%nonBous_energetics) then + SpV0(i,k_tgt) = (SpV0(i,k_tgt)*h_tgt_old + SpV0(i,k_src)*h_move) * I_hnew + else + R0(i,k_tgt) = (R0(i,k_tgt)*h_tgt_old + R0(i,k_src)*h_move) * I_hnew + endif + + T(i,k_tgt) = (T(i,k_tgt)*h_tgt_old + T(i,k_src)*h_move) * I_hnew + S(i,k_tgt) = (S(i,k_tgt)*h_tgt_old + S(i,k_src)*h_move) * I_hnew + Rcv(i,k_tgt) = (Rcv(i,k_tgt)*h_tgt_old + Rcv(i,k_src)*h_move) * I_hnew + + d_eb(i,k_src) = d_eb(i,k_src) - h_move + d_eb(i,k_tgt) = d_eb(i,k_tgt) + h_move + + ! Remove the newly missing layer from the sorted list. + do ks=ks_min+1,nks ; ks2(ks) = ks2(ks+1) ; enddo + nks = nks-1 + enddo + + ! Check again whether the layers are sorted, and go on to the next column + ! if they are. + sorted = .true. + do ks=1,nks-1 ; if (ks2(ks) > ks2(ks+1)) sorted = .false. ; enddo + if (sorted) cycle + + if (nks > 1) then + ! At this point, actually swap the properties of the layers, and place + ! the remaining layers in order starting with nkmb. + + ! Save all the properties of the nkmb layers that might be replaced. + do k=1,nkmb + h_tmp(k) = h(i,k) + if (CS%nonBous_energetics) then + SpV0_tmp(k) = SpV0(i,k) + else + R0_tmp(k) = R0(i,k) + endif + T_tmp(k) = T(i,k) ; S_tmp(k) = S(i,k) ; Rcv_tmp(k) = Rcv(i,k) + + h(i,k) = 0.0 + enddo + + do ks=nks,1,-1 + k_tgt = nkmb - nks + ks ; k_src = ks2(ks) + if (k_tgt == k_src) then + h(i,k_tgt) = h_tmp(k_tgt) ! This layer doesn't move, so put the water back. + cycle + endif + + ! Note below that eps=0 for k<=nkmb. + if (k_src > nkmb) then + h_move = h(i,k_src)-eps(i,k_src) + h(i,k_src) = eps(i,k_src) + h(i,k_tgt) = h_move + if (CS%nonBous_energetics) then + SpV0(i,k_tgt) = SpV0(i,k_src) + else + R0(i,k_tgt) = R0(i,k_src) + endif + + T(i,k_tgt) = T(i,k_src) ; S(i,k_tgt) = S(i,k_src) + Rcv(i,k_tgt) = Rcv(i,k_src) + + d_eb(i,k_src) = d_eb(i,k_src) - h_move + d_eb(i,k_tgt) = d_eb(i,k_tgt) + h_move + else + h(i,k_tgt) = h_tmp(k_src) + if (CS%nonBous_energetics) then + SpV0(i,k_tgt) = SpV0_tmp(k_src) + else + R0(i,k_tgt) = R0_tmp(k_src) + endif + + T(i,k_tgt) = T_tmp(k_src) ; S(i,k_tgt) = S_tmp(k_src) + Rcv(i,k_tgt) = Rcv_tmp(k_src) + + if (k_src > k_tgt) then + d_eb(i,k_src) = d_eb(i,k_src) - h_tmp(k_src) + d_eb(i,k_tgt) = d_eb(i,k_tgt) + h_tmp(k_src) + else + d_ea(i,k_src) = d_ea(i,k_src) - h_tmp(k_src) + d_ea(i,k_tgt) = d_ea(i,k_tgt) + h_tmp(k_src) + endif + endif + enddo + endif + + endif ; enddo + +end subroutine resort_ML + +!> This subroutine moves any water left in the former mixed layers into the +!! two buffer layers and may also move buffer layer water into the interior +!! isopycnal layers. +subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, G, GV, US, CS, & + dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS, max_BL_det) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. + !! Layer 0 is the new mixed layer. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Potential temperature [C ~> degC]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [S ~> ppt]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to + !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential + !! density [R ~> kg m-3]. + real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each + !! layer [R ~> kg m-3]. + real, intent(in) :: dt !< Time increment [T ~> s]. + real, intent(in) :: dt_diag !< The diagnostic time step [T ~> s]. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_ea !< The upward increase across a layer in + !! the entrainment from above + !! [H ~> m or kg m-2]. Positive d_ea + !! goes with layer thickness increases. + integer, intent(in) :: j !< The meridional row to work on. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure + real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of + !! potential density referenced to the + !! surface with potential temperature, + !! [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of + !! potential density referenced to the + !! surface with salinity + !! [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of specific + !! volume with respect to temeprature + !! [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)), intent(in) :: dSpV0_dS !< The partial derivative of specific + !! volume with respect to salinity + !! [R-1 S-1 ~> m3 kg-1 ppt-1] + real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of + !! coordinate defining potential density + !! with potential temperature, + !! [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of + !! coordinate defining potential density + !! with salinity [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: max_BL_det !< If non-negative, the maximum + !! detrainment permitted from the buffer + !! layers [H ~> m or kg m-2]. + +! This subroutine moves any water left in the former mixed layers into the +! two buffer layers and may also move buffer layer water into the interior +! isopycnal layers. + + ! Local variables + real :: h_to_bl ! The total thickness detrained to the buffer + ! layers [H ~> m or kg m-2]. + real :: R0_to_bl ! The depth integrated amount of R0 that is detrained to the + ! buffer layer [H R ~> kg m-2 or kg2 m-5] + real :: SpV0_to_bl ! The depth integrated amount of SpV0 that is detrained to the + ! buffer layer [H R-1 ~> m4 kg-1 or m] + real :: Rcv_to_bl ! The depth integrated amount of Rcv that is detrained to the + ! buffer layer [H R ~> kg m-2 or kg2 m-5] + real :: T_to_bl ! The depth integrated amount of T that is detrained to the + ! buffer layer [C H ~> degC m or degC kg m-2] + real :: S_to_bl ! The depth integrated amount of S that is detrained to the + ! buffer layer [S H ~> ppt m or ppt kg m-2] + real :: h_min_bl ! The minimum buffer layer thickness [H ~> m or kg m-2]. + + real :: h1, h2 ! Scalar variables holding the values of + ! h(i,CS%nkml+1) and h(i,CS%nkml+2) [H ~> m or kg m-2]. + real :: h1_avail ! The thickness of the upper buffer layer + ! available to move into the lower buffer + ! layer [H ~> m or kg m-2]. + real :: stays ! stays is the thickness of the upper buffer + ! layer that remains there [H ~> m or kg m-2]. + real :: stays_min, stays_max ! The minimum and maximum permitted values of + ! stays [H ~> m or kg m-2]. + + logical :: intermediate ! True if the water in layer kb1 is intermediate in density + ! between the water in kb2 and the water being detrained. + logical :: mergeable_bl ! If true, it is an option to combine the two + ! buffer layers and create water that matches + ! the target density of an interior layer. + logical :: better_to_merge ! True if it is energetically favorable to merge layers + real :: stays_merge ! If the two buffer layers can be combined + ! stays_merge is the thickness of the upper + ! layer that remains [H ~> m or kg m-2]. + real :: stays_min_merge ! The minimum allowed value of stays_merge [H ~> m or kg m-2]. + + real :: dR0_2dz, dRcv_2dz ! Half the vertical gradients of R0 and Rcv [R H-1 ~> kg m-4 or m-1] + real :: dSpV0_2dz ! Half the vertical gradients of SpV0 and Rcv [R-1 H-1 ~> m2 kg-1 or m5 kg-2] +! real :: dT_2dz ! Half the vertical gradient of T [C H-1 ~> degC m-1 or degC m2 kg-1] +! real :: dS_2dz ! Half the vertical gradient of S [S H-1 ~> ppt m-1 or ppt m2 kg-1] + real :: scale_slope ! A nondimensional number < 1 used to scale down + ! the slope within the upper buffer layer when + ! water MUST be detrained to the lower layer [nondim]. + + real :: dPE_extrap_rhoG ! The potential energy change due to dispersive + ! advection or mixing layers, divided by + ! rho_0*g [H2 ~> m2 or kg2 m-4]. + real :: dPE_extrapolate ! The potential energy change due to dispersive advection or + ! mixing layers [R Z L2 T-2 ~> J m-2]. + real :: dPE_det, dPE_merge ! The energy required to mix the detrained water + ! into the buffer layer or the merge the two + ! buffer layers [R H2 L2 Z-1 T-2 ~> J m-2 or J kg2 m-8]. + real :: dPE_det_nB, dPE_merge_nB ! The energy required to mix the detrained water + ! into the buffer layer or the merge the two + ! buffer layers [R Z L2 T-2 ~> J m-2]. + + real :: h_from_ml ! The amount of additional water that must be + ! drawn from the mixed layer [H ~> m or kg m-2]. + real :: h_det_h2 ! The amount of detrained water and mixed layer + ! water that will go directly into the lower + ! buffer layer [H ~> m or kg m-2]. + + real :: h_det_to_h2, h_ml_to_h2 ! The fluxes of detrained and mixed layer water to + ! the lower buffer layer [H ~> m or kg m-2]. + real :: h_det_to_h1, h_ml_to_h1 ! The fluxes of detrained and mixed layer water to + ! the upper buffer layer [H ~> m or kg m-2]. + real :: h1_to_h2, h1_to_k0 ! The fluxes of upper buffer layer water to the lower buffer layer + ! and to an interior layer that is just denser than the lower + ! buffer layer [H ~> m or kg m-2]. + real :: h2_to_k1, h2_to_k1_rem ! Fluxes of lower buffer layer water to the interior layer that + ! is just denser than the lower buffer layer [H ~> m or kg m-2]. + + real :: R0_det ! Detrained value of potential density referenced to the surface [R ~> kg m-3] + real :: SpV0_det ! Detrained value of specific volume referenced to the surface [R-1 ~> m3 kg-1] + real :: T_det, S_det ! Detrained values of temperature [C ~> degC] and salinity [S ~> ppt] + real :: Rcv_stays, R0_stays ! Values of Rcv and R0 that stay in a layer [R ~> kg m-3] + real :: SpV0_stays ! Values of SpV0 that stay in a layer [R-1 ~> m3 kg-1] + real :: T_stays, S_stays ! Values of T and S that stay in a layer, [C ~> degC] and S [S ~> ppt] + real :: dSpice_det, dSpice_stays! The spiciness difference between an original + ! buffer layer and the water that moves into + ! an interior layer or that stays in that + ! layer [R ~> kg m-3]. + real :: dSpice_lim, dSpice_lim2 ! Limits to the spiciness difference between + ! the lower buffer layer and the water that + ! moves into an interior layer [R ~> kg m-3]. + real :: dSpice_2dz ! The vertical gradient of spiciness used for + ! advection [R H-1 ~> kg m-4 or m-1]. + real :: dSpiceSpV_stays ! The specific volume based spiciness difference between an original + ! buffer layer and the water that stays in that layer [R-1 ~> m3 kg-1] + real :: dSpiceSpV_lim ! A limit on the specific volume based spiciness difference + ! between the lower buffer layer and the water that + ! moves into an interior layer [R-1 ~> m3 kg-1] + real :: dPE_ratio ! Multiplier of dPE_det at which merging is + ! permitted - here (detrainment_per_day/dt)*30 + ! days? [nondim] + real :: num_events ! The number of detrainment events over which + ! to prefer merging the buffer layers [nondim]. + real :: dPE_time_ratio ! Larger of 1 and the detrainment timescale over dt [nondim]. + real :: dT_dS_gauge, dS_dT_gauge ! The relative scales of temperature and + ! salinity changes in defining spiciness, in + ! [C S-1 ~> degC ppt-1] and [S C-1 ~> ppt degC-1]. + real :: I_denom ! A work variable with units of [S2 R-2 ~> ppt2 m6 kg-2] or [R2 S2 ~> ppt2 kg2 m-6]. + + real :: g_2 ! 1/2 g_Earth [L2 Z-1 T-2 ~> m s-2]. + real :: Rho0xG ! Rho0 times G_Earth [R L2 Z-1 T-2 ~> kg m-2 s-2]. + real :: I2Rho0 ! 1 / (2 Rho0) [R-1 ~> m3 kg-1]. + real :: Idt_diag ! The inverse of the timestep used for diagnostics [T-1 ~> s-1]. + real :: Idt_H2 ! The square of the conversion from thickness to Z + ! divided by the time step [Z2 H-2 T-1 ~> s-1 or m6 kg-2 s-1]. + logical :: stable_Rcv ! If true, the buffer layers are stable with + ! respect to the coordinate potential density. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + + real :: s1en ! A work variable [R Z L2 T-3 ~> W m-2] + real :: s1, s2, bh0 ! Work variables [H ~> m or kg m-2]. + real :: s3sq ! A work variable [H2 ~> m2 or kg2 m-4]. + real :: I_ya, b1 ! Nondimensional work variables [nondim] + real :: Ih, Ihdet, Ih1f, Ih2f ! Assorted inverse thickness work variables [H-1 ~> m-1 or m2 kg-1] + real :: Ihk0, Ihk1, Ih12 ! Assorted inverse thickness work variables [H-1 ~> m-1 or m2 kg-1] + real :: dR1, dR2, dR2b, dRk1 ! Assorted density difference work variables [R ~> kg m-3] + real :: dR0, dR21, dRcv ! Assorted density difference work variables [R ~> kg m-3] + real :: dSpV0, dSpVk1 ! Assorted specific volume difference work variables [R-1 ~> m3 kg-1] + real :: dRcv_stays, dRcv_det, dRcv_lim ! Assorted densities [R ~> kg m-3] + real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. + + real :: h2_to_k1_lim ! A limit on the thickness that can be detrained to layer k1 [H ~> m or kg m-2] + real :: T_new, T_max, T_min ! Temperature of the detrained water and limits on it [C ~> degC] + real :: S_new, S_max, S_min ! Salinity of the detrained water and limits on it [S ~> ppt] + logical :: stable + integer :: i, k, k0, k1, is, ie, nz, kb1, kb2, nkmb + + is = G%isc ; ie = G%iec ; nz = GV%ke + kb1 = CS%nkml+1; kb2 = CS%nkml+2 + nkmb = CS%nkml+CS%nkbl + h_neglect = GV%H_subroundoff + g_2 = 0.5 * GV%g_Earth + Rho0xG = GV%Rho0 * GV%g_Earth + Idt_diag = 1.0 / dt_diag + Idt_H2 = GV%H_to_Z**2 / dt_diag + I2Rho0 = 0.5 / GV%Rho0 + Angstrom = GV%Angstrom_H + + ! This is hard coding of arbitrary and dimensional numbers. + dT_dS_gauge = CS%dT_dS_wt ; dS_dT_gauge = 1.0 / dT_dS_gauge + num_events = 10.0 + + if (CS%nkbl /= 2) call MOM_error(FATAL, "MOM_mixed_layer"// & + "CS%nkbl must be 2 in mixedlayer_detrain_2.") + + if (dt < CS%BL_detrain_time) then ; dPE_time_ratio = CS%BL_detrain_time / (dt) + else ; dPE_time_ratio = 1.0 ; endif + + do i=is,ie + + ! Determine all of the properties being detrained from the mixed layer. + + ! As coded this has the k and i loop orders switched, but k is CS%nkml is + ! often just 1 or 2, so this seems like it should not be a problem, especially + ! since it means that a number of variables can now be scalars, not arrays. + h_to_bl = 0.0 ; R0_to_bl = 0.0 ; SpV0_to_bl = 0.0 + Rcv_to_bl = 0.0 ; T_to_bl = 0.0 ; S_to_bl = 0.0 + + do k=1,CS%nkml ; if (h(i,k) > 0.0) then + h_to_bl = h_to_bl + h(i,k) + if (CS%nonBous_energetics) then + SpV0_to_bl = SpV0_to_bl + SpV0(i,k)*h(i,k) + else + R0_to_bl = R0_to_bl + R0(i,k)*h(i,k) + endif + + Rcv_to_bl = Rcv_to_bl + Rcv(i,k)*h(i,k) + T_to_bl = T_to_bl + T(i,k)*h(i,k) + S_to_bl = S_to_bl + S(i,k)*h(i,k) + + d_ea(i,k) = d_ea(i,k) - h(i,k) + h(i,k) = 0.0 + endif ; enddo + + if (CS%nonBous_energetics) then + if (h_to_bl > 0.0) then ; SpV0_det = SpV0_to_bl / h_to_bl + else ; SpV0_det = SpV0(i,0) ; endif + else + if (h_to_bl > 0.0) then ; R0_det = R0_to_bl / h_to_bl + else ; R0_det = R0(i,0) ; endif + endif + + ! This code does both downward detrainment from both the mixed layer and the + ! buffer layers. + ! Several considerations apply in detraining water into the interior: + ! (1) Water only moves into the interior from the deeper buffer layer, + ! so the deeper buffer layer must have some mass. + ! (2) The upper buffer layer must have some mass so the extrapolation of + ! density is meaningful (i.e. there is not detrainment from the buffer + ! layers when there is strong mixed layer entrainment). + ! (3) The lower buffer layer density extrapolated to its base with a + ! linear fit between the two layers must exceed the density of the + ! next denser interior layer. + ! (4) The average extrapolated coordinate density that is moved into the + ! isopycnal interior matches the target value for that layer. + ! (5) The potential energy change is calculated and might be used later + ! to allow the upper buffer layer to mix more into the lower buffer + ! layer. + + ! Determine whether more must be detrained from the mixed layer to keep a + ! minimal amount of mass in the buffer layers. In this case the 5% of the + ! mixed layer thickness is hard-coded, but probably shouldn't be! + h_min_bl = MIN(CS%Hbuffer_min, CS%Hbuffer_rel_min*h(i,0)) + + stable_Rcv = .true. + if (CS%nonBous_energetics) then + if (((SpV0(i,kb1)-SpV0(i,kb2)) * (Rcv(i,kb2)-Rcv(i,kb1)) <= 0.0)) stable_Rcv = .false. + else + if (((R0(i,kb2)-R0(i,kb1)) * (Rcv(i,kb2)-Rcv(i,kb1)) <= 0.0)) stable_Rcv = .false. + endif + + h1 = h(i,kb1) ; h2 = h(i,kb2) + + h2_to_k1_rem = (h1 + h2) + h_to_bl + if ((max_BL_det(i) >= 0.0) .and. (h2_to_k1_rem > max_BL_det(i))) & + h2_to_k1_rem = max_BL_det(i) + + + if ((h2 == 0.0) .and. (h1 > 0.0)) then + ! The lower buffer layer has been eliminated either by convective + ! adjustment or entrainment from the interior, and its current properties + ! are not meaningful, but may later be used to determine the properties of + ! waters moving into the lower buffer layer. So the properties of the + ! lower buffer layer are set to be between those of the upper buffer layer + ! and the next denser interior layer, measured by R0 or SpV0. This probably does + ! not happen very often, so I am not too worried about the inefficiency of + ! the following loop. + do k1=kb2+1,nz ; if (h(i,k1) > 2.0*Angstrom) exit ; enddo + + Rcv(i,kb2) = Rcv(i,kb1) ; T(i,kb2) = T(i,kb1) ; S(i,kb2) = S(i,kb1) + + if (CS%nonBous_energetics) then + SpV0(i,kb2) = SpV0(i,kb1) + if (k1 <= nz) then ; if (SpV0(i,k1) <= SpV0(i,kb1)) then + SpV0(i,kb2) = 0.5*(SpV0(i,kb1)+SpV0(i,k1)) + + Rcv(i,kb2) = 0.5*(Rcv(i,kb1)+Rcv(i,k1)) + T(i,kb2) = 0.5*(T(i,kb1)+T(i,k1)) + S(i,kb2) = 0.5*(S(i,kb1)+S(i,k1)) + endif ; endif + else + R0(i,kb2) = R0(i,kb1) + + if (k1 <= nz) then ; if (R0(i,k1) >= R0(i,kb1)) then + R0(i,kb2) = 0.5*(R0(i,kb1)+R0(i,k1)) + + Rcv(i,kb2) = 0.5*(Rcv(i,kb1)+Rcv(i,k1)) + T(i,kb2) = 0.5*(T(i,kb1)+T(i,k1)) + S(i,kb2) = 0.5*(S(i,kb1)+S(i,k1)) + endif ; endif + endif + endif ! (h2 = 0 && h1 > 0) + + dPE_extrap_rhoG = 0.0 ; dPE_extrapolate = 0.0 ; dPE_merge = 0.0 ; dPE_merge_nB = 0.0 + mergeable_bl = .false. + if ((h1 > 0.0) .and. (h2 > 0.0) .and. (h_to_bl > 0.0) .and. & + (stable_Rcv)) then + ! Check whether it is permissible for the buffer layers to detrain + ! into the interior isopycnal layers. + + ! Determine the layer that has the lightest target density that is + ! denser than the lowermost buffer layer. + do k1=kb2+1,nz ; if (RcvTgt(k1) >= Rcv(i,kb2)) exit ; enddo ; k0 = k1-1 + dR1 = RcvTgt(k0)-Rcv(i,kb1) ; dR2 = Rcv(i,kb2)-RcvTgt(k0) + + ! Use an energy-balanced combination of downwind advection into the next + ! denser interior layer and upwind advection from the upper buffer layer + ! into the lower one, each with an energy change that equals that required + ! to mix the detrained water with the upper buffer layer. + h1_avail = h1 - MAX(0.0,h_min_bl-h_to_bl) + if (CS%nonBous_energetics) then + intermediate = (SpV0(i,kb1) > SpV0(i,kb2)) .and. (h_to_bl*SpV0(i,kb1) < SpV0_to_bl) + else + intermediate = (R0(i,kb1) < R0(i,kb2)) .and. (h_to_bl*R0(i,kb1) > R0_to_bl) + endif + + if ((k1<=nz) .and. (h2 > h_min_bl) .and. (h1_avail > 0.0) .and. intermediate) then + if (CS%nonBous_energetics) then + dSpVk1 = (RcvTgt(k1) - Rcv(i,kb2)) * (SpV0(i,kb2) - SpV0(i,kb1)) / & + (Rcv(i,kb2) - Rcv(i,kb1)) + b1 = (RcvTgt(k1) - Rcv(i,kb2)) / (Rcv(i,kb2) - Rcv(i,kb1)) + else + dRk1 = (RcvTgt(k1) - Rcv(i,kb2)) * (R0(i,kb2) - R0(i,kb1)) / & + (Rcv(i,kb2) - Rcv(i,kb1)) + b1 = dRk1 / (R0(i,kb2) - R0(i,kb1)) + ! b1 = RcvTgt(k1) - Rcv(i,kb2)) / (Rcv(i,kb2) - Rcv(i,kb1)) + endif + + ! Apply several limits to the detrainment. + ! Entrain less than the mass in h2, and keep the base of the buffer + ! layers from becoming shallower than any neighbors. + h2_to_k1 = min(h2 - h_min_bl, h2_to_k1_rem) + ! Balance downwind advection of density into the layer below the + ! buffer layers with upwind advection from the layer above. + if (h2_to_k1*(h1_avail + b1*(h1_avail + h2)) > h2*h1_avail) & + h2_to_k1 = (h2*h1_avail) / (h1_avail + b1*(h1_avail + h2)) + + if (CS%nonBous_energetics) then + if (h2_to_k1*(dSpVk1 * h2) < (h_to_bl*SpV0(i,kb1) - SpV0_to_bl) * h1) & + h2_to_k1 = (h_to_bl*SpV0(i,kb1) - SpV0_to_bl) * h1 / (dSpVk1 * h2) + else + if (h2_to_k1*(dRk1 * h2) > (h_to_bl*R0(i,kb1) - R0_to_bl) * h1) & + h2_to_k1 = (h_to_bl*R0(i,kb1) - R0_to_bl) * h1 / (dRk1 * h2) + endif + + if ((k1==kb2+1) .and. (CS%BL_extrap_lim > 0.)) then + ! Simply do not detrain very light water into the lightest isopycnal + ! coordinate layers if the density jump is too large. + dRcv_lim = Rcv(i,kb2)-Rcv(i,0) + do k=1,kb2 ; dRcv_lim = max(dRcv_lim, Rcv(i,kb2)-Rcv(i,k)) ; enddo + dRcv_lim = CS%BL_extrap_lim*dRcv_lim + if ((RcvTgt(k1) - Rcv(i,kb2)) >= dRcv_lim) then + h2_to_k1 = 0.0 + elseif ((RcvTgt(k1) - Rcv(i,kb2)) > 0.5*dRcv_lim) then + h2_to_k1 = h2_to_k1 * (2.0 - 2.0*((RcvTgt(k1) - Rcv(i,kb2)) / dRcv_lim)) + endif + endif + + dRcv = (RcvTgt(k1) - Rcv(i,kb2)) + + ! Use 2nd order upwind advection of spiciness, limited by the values + ! in deeper thick layers to determine the detrained temperature and + ! salinity. + dSpice_det = (dS_dT_gauge*dRcv_dS(i)*(T(i,kb2)-T(i,kb1)) - & + dT_dS_gauge*dRcv_dT(i)*(S(i,kb2)-S(i,kb1))) * & + (h2 - h2_to_k1) / (h1 + h2) + dSpice_lim = 0.0 + if (h(i,k1) > 10.0*Angstrom) then + dSpice_lim = dS_dT_gauge*dRcv_dS(i)*(T(i,k1)-T(i,kb2)) - & + dT_dS_gauge*dRcv_dT(i)*(S(i,k1)-S(i,kb2)) + if (dSpice_det*dSpice_lim <= 0.0) dSpice_lim = 0.0 + endif + if (k1 10.0*Angstrom) then + dSpice_lim2 = dS_dT_gauge*dRcv_dS(i)*(T(i,k1+1)-T(i,kb2)) - & + dT_dS_gauge*dRcv_dT(i)*(S(i,k1+1)-S(i,kb2)) + if ((dSpice_det*dSpice_lim2 > 0.0) .and. & + (abs(dSpice_lim2) > abs(dSpice_lim))) dSpice_lim = dSpice_lim2 + endif ; endif + if (abs(dSpice_det) > abs(dSpice_lim)) dSpice_det = dSpice_lim + + I_denom = 1.0 / (dRcv_dS(i)**2 + (dT_dS_gauge*dRcv_dT(i))**2) + T_det = T(i,kb2) + dT_dS_gauge * I_denom * & + (dT_dS_gauge * dRcv_dT(i) * dRcv + dRcv_dS(i) * dSpice_det) + S_det = S(i,kb2) + I_denom * & + (dRcv_dS(i) * dRcv - dT_dS_gauge * dRcv_dT(i) * dSpice_det) + + ! The detrained values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_det = SpV0(i,kb2) + (T_det-T(i,kb2)) * dSpV0_dT(i) + & + (S_det-S(i,kb2)) * dSpV0_dS(i) + else + R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & + (S_det-S(i,kb2)) * dR0_dS(i) + endif + + if (CS%BL_extrap_lim >= 0.) then + ! Only do this detrainment if the new layer's temperature and salinity + ! are not too far outside of the range of previous values. + if (h(i,k1) > 10.0*Angstrom) then + T_min = min(T(i,kb1), T(i,kb2), T(i,k1)) - CS%Allowed_T_chg + T_max = max(T(i,kb1), T(i,kb2), T(i,k1)) + CS%Allowed_T_chg + S_min = min(S(i,kb1), S(i,kb2), S(i,k1)) - CS%Allowed_S_chg + S_max = max(S(i,kb1), S(i,kb2), S(i,k1)) + CS%Allowed_S_chg + else + T_min = min(T(i,kb1), T(i,kb2)) - CS%Allowed_T_chg + T_max = max(T(i,kb1), T(i,kb2)) + CS%Allowed_T_chg + S_min = min(S(i,kb1), S(i,kb2)) - CS%Allowed_S_chg + S_max = max(S(i,kb1), S(i,kb2)) + CS%Allowed_S_chg + endif + Ihk1 = 1.0 / (h(i,k1) + h2_to_k1) + T_new = (h(i,k1)*T(i,k1) + h2_to_k1*T_det) * Ihk1 + S_new = (h(i,k1)*S(i,k1) + h2_to_k1*S_det) * Ihk1 + ! A less restrictive limit might be used here. + if ((T_new < T_min) .or. (T_new > T_max) .or. & + (S_new < S_min) .or. (S_new > S_max)) & + h2_to_k1 = 0.0 + endif + + h1_to_h2 = b1*h2*h2_to_k1 / (h2 - (1.0+b1)*h2_to_k1) + + Ihk1 = 1.0 / (h(i,k1) + h_neglect + h2_to_k1) + Ih2f = 1.0 / ((h(i,kb2) - h2_to_k1) + h1_to_h2) + + Rcv(i,kb2) = ((h(i,kb2)*Rcv(i,kb2) - h2_to_k1*RcvTgt(k1)) + & + h1_to_h2*Rcv(i,kb1))*Ih2f + Rcv(i,k1) = ((h(i,k1)+h_neglect)*Rcv(i,k1) + h2_to_k1*RcvTgt(k1)) * Ihk1 + + T(i,kb2) = ((h(i,kb2)*T(i,kb2) - h2_to_k1*T_det) + & + h1_to_h2*T(i,kb1)) * Ih2f + T(i,k1) = ((h(i,k1)+h_neglect)*T(i,k1) + h2_to_k1*T_det) * Ihk1 + + S(i,kb2) = ((h(i,kb2)*S(i,kb2) - h2_to_k1*S_det) + & + h1_to_h2*S(i,kb1)) * Ih2f + S(i,k1) = ((h(i,k1)+h_neglect)*S(i,k1) + h2_to_k1*S_det) * Ihk1 + + ! Changes in R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0(i,kb2) = ((h(i,kb2)*SpV0(i,kb2) - h2_to_k1*SpV0_det) + h1_to_h2*SpV0(i,kb1)) * Ih2f + SpV0(i,k1) = ((h(i,k1)+h_neglect)*SpV0(i,k1) + h2_to_k1*SpV0_det) * Ihk1 + else + R0(i,kb2) = ((h(i,kb2)*R0(i,kb2) - h2_to_k1*R0_det) + h1_to_h2*R0(i,kb1)) * Ih2f + R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + endif + + h(i,kb1) = h(i,kb1) - h1_to_h2 ; h1 = h(i,kb1) + h(i,kb2) = (h(i,kb2) - h2_to_k1) + h1_to_h2 ; h2 = h(i,kb2) + h(i,k1) = h(i,k1) + h2_to_k1 + + d_ea(i,kb1) = d_ea(i,kb1) - h1_to_h2 + d_ea(i,kb2) = (d_ea(i,kb2) - h2_to_k1) + h1_to_h2 + d_ea(i,k1) = d_ea(i,k1) + h2_to_k1 + h2_to_k1_rem = max(h2_to_k1_rem - h2_to_k1, 0.0) + + ! The lower buffer layer has become lighter - it may be necessary to + ! adjust k1 lighter. + if ((k1>kb2+1) .and. (RcvTgt(k1-1) >= Rcv(i,kb2))) then + do k1=k1,kb2+1,-1 ; if (RcvTgt(k1-1) < Rcv(i,kb2)) exit ; enddo + endif + endif + + k0 = k1-1 + dR1 = RcvTgt(k0)-Rcv(i,kb1) ; dR2 = Rcv(i,kb2)-RcvTgt(k0) + + if (CS%nonBous_energetics) then + stable = (SpV0(i,kb2) < SpV0(i,kb1)) + else + stable = (R0(i,kb2) > R0(i,kb1)) + endif + + if ((k0>kb2) .and. (dR1 > 0.0) .and. (h1 > h_min_bl) .and. (h2*dR2 < h1*dR1) .and. stable) then + ! An interior isopycnal layer (k0) is intermediate in density between + ! the two buffer layers, and there can be detrainment. The entire + ! lower buffer layer is combined with a portion of the upper buffer + ! layer to match the target density of layer k0. + stays_merge = 2.0*(h1+h2)*(h1*dR1 - h2*dR2) / & + ((dR1+dR2)*h1 + dR1*(h1+h2) + & + sqrt((dR2*h1-dR1*h2)**2 + 4*(h1+h2)*h2*(dR1+dR2)*dR2)) + + if (CS%nonBous_energetics) then + stays_min_merge = MAX(h_min_bl, 2.0*h_min_bl - h_to_bl, & + h1 - (h1+h2)*(SpV0(i,kb1) - SpV0_det) / (SpV0(i,kb2) - SpV0(i,kb1))) + if ((stays_merge > stays_min_merge) .and. (stays_merge + h2_to_k1_rem >= h1 + h2)) then + mergeable_bl = .true. + dPE_merge_nB = g_2*GV%H_to_RZ**2*(SpV0(i,kb1)-SpV0(i,kb2)) * ((h1-stays_merge)*(h2-stays_merge)) + endif + else + stays_min_merge = MAX(h_min_bl, 2.0*h_min_bl - h_to_bl, & + h1 - (h1+h2)*(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1))) + if ((stays_merge > stays_min_merge) .and. (stays_merge + h2_to_k1_rem >= h1 + h2)) then + mergeable_bl = .true. + dPE_merge = g_2*(R0(i,kb2)-R0(i,kb1)) * (h1-stays_merge)*(h2-stays_merge) + endif + endif + endif + + if ((k1<=nz).and.(.not.mergeable_bl)) then + ! Check whether linear extrapolation of density (i.e. 2nd order upwind + ! advection) will allow some of the lower buffer layer to detrain into + ! the next denser interior layer (k1). + dR2b = RcvTgt(k1)-Rcv(i,kb2) ; dR21 = Rcv(i,kb2) - Rcv(i,kb1) + if (dR2b*(h1+h2) < h2*dR21) then + ! Some of layer kb2 is denser than k1. + h2_to_k1 = min(h2 - (h1+h2) * dR2b / dR21, h2_to_k1_rem) + + if (h2 > h2_to_k1) then + dRcv = (RcvTgt(k1) - Rcv(i,kb2)) + + ! Use 2nd order upwind advection of spiciness, limited by the values + ! in deeper thick layers to determine the detrained temperature and + ! salinity. + dSpice_det = (dS_dT_gauge*dRcv_dS(i)*(T(i,kb2)-T(i,kb1)) - & + dT_dS_gauge*dRcv_dT(i)*(S(i,kb2)-S(i,kb1))) * & + (h2 - h2_to_k1) / (h1 + h2) + dSpice_lim = 0.0 + if (h(i,k1) > 10.0*Angstrom) then + dSpice_lim = dS_dT_gauge*dRcv_dS(i)*(T(i,k1)-T(i,kb2)) - & + dT_dS_gauge*dRcv_dT(i)*(S(i,k1)-S(i,kb2)) + if (dSpice_det*dSpice_lim <= 0.0) dSpice_lim = 0.0 + endif + if (k1 10.0*Angstrom) then + dSpice_lim2 = dS_dT_gauge*dRcv_dS(i)*(T(i,k1+1)-T(i,kb2)) - & + dT_dS_gauge*dRcv_dT(i)*(S(i,k1+1)-S(i,kb2)) + if ((dSpice_det*dSpice_lim2 > 0.0) .and. & + (abs(dSpice_lim2) > abs(dSpice_lim))) dSpice_lim = dSpice_lim2 + endif ; endif + if (abs(dSpice_det) > abs(dSpice_lim)) dSpice_det = dSpice_lim + + I_denom = 1.0 / (dRcv_dS(i)**2 + (dT_dS_gauge*dRcv_dT(i))**2) + T_det = T(i,kb2) + dT_dS_gauge * I_denom * & + (dT_dS_gauge * dRcv_dT(i) * dRcv + dRcv_dS(i) * dSpice_det) + S_det = S(i,kb2) + I_denom * & + (dRcv_dS(i) * dRcv - dT_dS_gauge * dRcv_dT(i) * dSpice_det) + ! The detrained values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_det = SpV0(i,kb2) + (T_det-T(i,kb2)) * dSpV0_dT(i) + & + (S_det-S(i,kb2)) * dSpV0_dS(i) + else + R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & + (S_det-S(i,kb2)) * dR0_dS(i) + endif + + ! Now that the properties of the detrained water are known, + ! potentially limit the amount of water that is detrained to + ! avoid creating unphysical properties in the remaining water. + Ih2f = 1.0 / (h2 - h2_to_k1) + + T_min = min(T(i,kb2), T(i,kb1)) - CS%Allowed_T_chg + T_max = max(T(i,kb2), T(i,kb1)) + CS%Allowed_T_chg + T_new = (h2*T(i,kb2) - h2_to_k1*T_det)*Ih2f + if (T_new < T_min) then + h2_to_k1_lim = h2 * (T(i,kb2) - T_min) / (T_det - T_min) +! write(mesg,'("Low temperature limits det to ", & +! & 1pe12.5, " from ", 1pe12.5, " at ", 1pg11.4,"E, ",1pg11.4,"N. T=", & +! & 5(1pe12.5))') & +! h2_to_k1_lim, h2_to_k1, G%geoLonT(i,j), G%geoLatT(i,j), & +! T_new, T(i,kb2), T(i,kb1), T_det, T_new-T_min +! call MOM_error(WARNING, mesg) + h2_to_k1 = h2_to_k1_lim + Ih2f = 1.0 / (h2 - h2_to_k1) + elseif (T_new > T_max) then + h2_to_k1_lim = h2 * (T(i,kb2) - T_max) / (T_det - T_max) +! write(mesg,'("High temperature limits det to ", & +! & 1pe12.5, " from ", 1pe12.5, " at ", 1pg11.4,"E, ",1pg11.4,"N. T=", & +! & 5(1pe12.5))') & +! h2_to_k1_lim, h2_to_k1, G%geoLonT(i,j), G%geoLatT(i,j), & +! T_new, T(i,kb2), T(i,kb1), T_det, T_new-T_max +! call MOM_error(WARNING, mesg) + h2_to_k1 = h2_to_k1_lim + Ih2f = 1.0 / (h2 - h2_to_k1) + endif + S_min = max(min(S(i,kb2), S(i,kb1)) - CS%Allowed_S_chg, 0.0) + S_max = max(S(i,kb2), S(i,kb1)) + CS%Allowed_S_chg + S_new = (h2*S(i,kb2) - h2_to_k1*S_det)*Ih2f + if (S_new < S_min) then + h2_to_k1_lim = h2 * (S(i,kb2) - S_min) / (S_det - S_min) +! write(mesg,'("Low salinity limits det to ", & +! & 1pe12.5, " from ", 1pe12.5, " at ", 1pg11.4,"E, ",1pg11.4,"N. S=", & +! & 5(1pe12.5))') & +! h2_to_k1_lim, h2_to_k1, G%geoLonT(i,j), G%geoLatT(i,j), & +! S_new, S(i,kb2), S(i,kb1), S_det, S_new-S_min +! call MOM_error(WARNING, mesg) + h2_to_k1 = h2_to_k1_lim + Ih2f = 1.0 / (h2 - h2_to_k1) + elseif (S_new > S_max) then + h2_to_k1_lim = h2 * (S(i,kb2) - S_max) / (S_det - S_max) +! write(mesg,'("High salinity limits det to ", & +! & 1pe12.5, " from ", 1pe12.5, " at ", 1pg11.4,"E, ",1pg11.4,"N. S=", & +! & 5(1pe12.5))') & +! h2_to_k1_lim, h2_to_k1, G%geoLonT(i,j), G%geoLatT(i,j), & +! S_new, S(i,kb2), S(i,kb1), S_det, S_new-S_max +! call MOM_error(WARNING, mesg) + h2_to_k1 = h2_to_k1_lim + Ih2f = 1.0 / (h2 - h2_to_k1) + endif + + Ihk1 = 1.0 / (h(i,k1) + h_neglect + h2_to_k1) + Rcv(i,k1) = ((h(i,k1)+h_neglect)*Rcv(i,k1) + h2_to_k1*RcvTgt(k1)) * Ihk1 + Rcv(i,kb2) = Rcv(i,kb2) - h2_to_k1*dRcv*Ih2f + + T(i,kb2) = (h2*T(i,kb2) - h2_to_k1*T_det)*Ih2f + T(i,k1) = ((h(i,k1)+h_neglect)*T(i,k1) + h2_to_k1*T_det) * Ihk1 + + S(i,kb2) = (h2*S(i,kb2) - h2_to_k1*S_det) * Ih2f + S(i,k1) = ((h(i,k1)+h_neglect)*S(i,k1) + h2_to_k1*S_det) * Ihk1 + + ! Changes in R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0(i,kb2) = (h2*SpV0(i,kb2) - h2_to_k1*SpV0_det) * Ih2f + SpV0(i,k1) = ((h(i,k1)+h_neglect)*SpV0(i,k1) + h2_to_k1*SpV0_det) * Ihk1 + else + R0(i,kb2) = (h2*R0(i,kb2) - h2_to_k1*R0_det) * Ih2f + R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + endif + else + ! h2==h2_to_k1 can happen if dR2b = 0 exactly, but this is very + ! unlikely. In this case the entirety of layer kb2 is detrained. + h2_to_k1 = h2 ! These 2 lines are probably unnecessary. + Ihk1 = 1.0 / (h(i,k1) + h2) + + Rcv(i,k1) = (h(i,k1)*Rcv(i,k1) + h2*Rcv(i,kb2)) * Ihk1 + T(i,k1) = (h(i,k1)*T(i,k1) + h2*T(i,kb2)) * Ihk1 + S(i,k1) = (h(i,k1)*S(i,k1) + h2*S(i,kb2)) * Ihk1 + if (CS%nonBous_energetics) then + SpV0(i,k1) = (h(i,k1)*SpV0(i,k1) + h2*SpV0(i,kb2)) * Ihk1 + else + R0(i,k1) = (h(i,k1)*R0(i,k1) + h2*R0(i,kb2)) * Ihk1 + endif + endif + + h(i,k1) = h(i,k1) + h2_to_k1 + h(i,kb2) = h(i,kb2) - h2_to_k1 ; h2 = h(i,kb2) + ! dPE_extrap_rhoG should be positive here. + if (CS%nonBous_energetics) then + dPE_extrap_rhoG = 0.5*(SpV0(i,kb2)-SpV0_det) * (h2_to_k1*h2) / SpV0(i,k1) + dPE_extrapolate = 0.5*GV%g_Earth*GV%H_to_RZ**2*(SpV0(i,kb2)-SpV0_det) * (h2_to_k1*h2) + else + dPE_extrap_rhoG = I2Rho0*(R0_det-R0(i,kb2))*h2_to_k1*h2 + endif + + d_ea(i,kb2) = d_ea(i,kb2) - h2_to_k1 + d_ea(i,k1) = d_ea(i,k1) + h2_to_k1 + h2_to_k1_rem = max(h2_to_k1_rem - h2_to_k1, 0.0) + endif + endif ! Detrainment by extrapolation. + + endif ! Detrainment to the interior at all. + + ! Does some of the detrained water go into the lower buffer layer? + h_det_h2 = MAX(h_min_bl-(h1+h2), 0.0) + if (h_det_h2 > 0.0) then + ! Detrained water will go into both upper and lower buffer layers. + ! h(kb2) will be h_min_bl, but h(kb1) may be larger if there was already + ! ample detrainment; all water in layer kb1 moves into layer kb2. + + ! Determine the fluxes between the various layers. + h_det_to_h2 = MIN(h_to_bl, h_det_h2) + h_ml_to_h2 = h_det_h2 - h_det_to_h2 + h_det_to_h1 = h_to_bl - h_det_to_h2 + h_ml_to_h1 = MAX(h_min_bl-h_det_to_h1,0.0) + + Ih = 1.0/h_min_bl + Ihdet = 0.0 ; if (h_to_bl > 0.0) Ihdet = 1.0 / h_to_bl + Ih1f = 1.0 / (h_det_to_h1 + h_ml_to_h1) + + if (CS%nonBous_energetics) then + SpV0(i,kb2) = ((h2*SpV0(i,kb2) + h1*SpV0(i,kb1)) + & + (h_det_to_h2*SpV0_to_bl*Ihdet + h_ml_to_h2*SpV0(i,0))) * Ih + SpV0(i,kb1) = (h_det_to_h1*SpV0_to_bl*Ihdet + h_ml_to_h1*SpV0(i,0)) * Ih1f + else + R0(i,kb2) = ((h2*R0(i,kb2) + h1*R0(i,kb1)) + & + (h_det_to_h2*R0_to_bl*Ihdet + h_ml_to_h2*R0(i,0))) * Ih + R0(i,kb1) = (h_det_to_h1*R0_to_bl*Ihdet + h_ml_to_h1*R0(i,0)) * Ih1f + endif + + Rcv(i,kb2) = ((h2*Rcv(i,kb2) + h1*Rcv(i,kb1)) + & + (h_det_to_h2*Rcv_to_bl*Ihdet + h_ml_to_h2*Rcv(i,0))) * Ih + Rcv(i,kb1) = (h_det_to_h1*Rcv_to_bl*Ihdet + h_ml_to_h1*Rcv(i,0)) * Ih1f + + T(i,kb2) = ((h2*T(i,kb2) + h1*T(i,kb1)) + & + (h_det_to_h2*T_to_bl*Ihdet + h_ml_to_h2*T(i,0))) * Ih + T(i,kb1) = (h_det_to_h1*T_to_bl*Ihdet + h_ml_to_h1*T(i,0)) * Ih1f + + S(i,kb2) = ((h2*S(i,kb2) + h1*S(i,kb1)) + & + (h_det_to_h2*S_to_bl*Ihdet + h_ml_to_h2*S(i,0))) * Ih + S(i,kb1) = (h_det_to_h1*S_to_bl*Ihdet + h_ml_to_h1*S(i,0)) * Ih1f + + ! Recall that h1 = h(i,kb1) & h2 = h(i,kb2). + d_ea(i,1) = d_ea(i,1) - (h_ml_to_h1 + h_ml_to_h2) + d_ea(i,kb1) = d_ea(i,kb1) + ((h_det_to_h1 + h_ml_to_h1) - h1) + d_ea(i,kb2) = d_ea(i,kb2) + (h_min_bl - h2) + + h(i,kb1) = h_det_to_h1 + h_ml_to_h1 ; h(i,kb2) = h_min_bl + h(i,0) = h(i,0) - (h_ml_to_h1 + h_ml_to_h2) + + + if (allocated(CS%diag_PE_detrain) .or. allocated(CS%diag_PE_detrain2)) then + if (CS%nonBous_energetics) then + SpV0_det = SpV0_to_bl*Ihdet + s1en = Idt_diag * ( -GV%H_to_RZ**2 * g_2 * ((SpV0(i,kb2)-SpV0(i,kb1))*h1*h2 + & + h_det_to_h2*( (SpV0(i,kb1)-SpV0_det)*h1 + (SpV0(i,kb2)-SpV0_det)*h2 ) + & + h_ml_to_h2*( (SpV0(i,kb2)-SpV0(i,0))*h2 + (SpV0(i,kb1)-SpV0(i,0))*h1 + & + (SpV0_det-SpV0(i,0))*h_det_to_h2 ) + & + h_det_to_h1*h_ml_to_h1*(SpV0_det-SpV0(i,0))) - dPE_extrapolate ) + + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + s1en + Idt_diag*dPE_extrapolate + else + R0_det = R0_to_bl*Ihdet + s1en = g_2 * Idt_H2 * ( ((R0(i,kb2)-R0(i,kb1))*h1*h2 + & + h_det_to_h2*( (R0(i,kb1)-R0_det)*h1 + (R0(i,kb2)-R0_det)*h2 ) + & + h_ml_to_h2*( (R0(i,kb2)-R0(i,0))*h2 + (R0(i,kb1)-R0(i,0))*h1 + & + (R0_det-R0(i,0))*h_det_to_h2 ) + & + h_det_to_h1*h_ml_to_h1*(R0_det-R0(i,0))) - 2.0*GV%Rho0*dPE_extrap_rhoG ) + + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + s1en + Idt_H2*Rho0xG*dPE_extrap_rhoG + endif + + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + s1en + endif + + elseif ((h_to_bl > 0.0) .or. (h1 < h_min_bl) .or. (h2 < h_min_bl)) then + ! Determine how much of the upper buffer layer will be moved into + ! the lower buffer layer and the properties with which it is moving. + ! This implementation assumes a 2nd-order upwind advection of density + ! from the uppermost buffer layer into the next one down. + h_from_ml = h_min_bl + MAX(h_min_bl-h2,0.0) - h1 - h_to_bl + if (h_from_ml > 0.0) then + ! Some water needs to be moved from the mixed layer so that the upper + ! (and perhaps lower) buffer layers exceed their minimum thicknesses. + if (CS%nonBous_energetics) then + ! The choice of which specific volume to use in the denominator could be revisited. + ! dPE_extrap_rhoG = dPE_extrap_rhoG + 0.5*h_from_ml*(SpV0_to_bl - SpV0(i,0)*h_to_bl) / SpV0(i,0) + dPE_extrap_rhoG = dPE_extrap_rhoG + 0.5*h_from_ml*(SpV0_to_bl - SpV0(i,0)*h_to_bl) * & + ( (h_to_bl + h_from_ml) / (SpV0_to_bl + h_from_ml*SpV0(i,0)) ) + dPE_extrapolate = dPE_extrapolate + 0.5*GV%g_Earth*GV%H_to_RZ**2 * & + h_from_ml*(SpV0_to_bl - SpV0(i,0)*h_to_bl) + SpV0_to_bl = SpV0_to_bl + h_from_ml*SpV0(i,0) + else + dPE_extrap_rhoG = dPE_extrap_rhoG - I2Rho0*h_from_ml*(R0_to_bl - R0(i,0)*h_to_bl) + R0_to_bl = R0_to_bl + h_from_ml*R0(i,0) + endif + Rcv_to_bl = Rcv_to_bl + h_from_ml*Rcv(i,0) + T_to_bl = T_to_bl + h_from_ml*T(i,0) + S_to_bl = S_to_bl + h_from_ml*S(i,0) + + h_to_bl = h_to_bl + h_from_ml + h(i,0) = h(i,0) - h_from_ml + d_ea(i,1) = d_ea(i,1) - h_from_ml + endif + + ! The absolute value should be unnecessary and 1e9 is just a large number. + b1 = 1.0e9 + if (CS%nonBous_energetics) then + if (SpV0(i,kb1) - SpV0(i,kb2) > 1.0e-9*abs(SpV0_det - SpV0(i,kb1))) & + b1 = abs(SpV0_det - SpV0(i,kb1)) / (SpV0(i,kb1) - SpV0(i,kb2)) + else + if (R0(i,kb2) - R0(i,kb1) > 1.0e-9*abs(R0(i,kb1) - R0_det)) & + b1 = abs(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1)) + endif + stays_min = MAX((1.0-b1)*h1 - b1*h2, 0.0, h_min_bl - h_to_bl) + stays_max = h1 - MAX(h_min_bl-h2,0.0) + + scale_slope = 1.0 + if (stays_max <= stays_min) then + stays = stays_max + mergeable_bl = .false. + if (stays_max < h1) scale_slope = (h1 - stays_min) / (h1 - stays_max) + else + ! There are numerous temporary variables used here that should not be + ! used outside of this "else" branch: s1, s2, s3sq, I_ya, bh0 + bh0 = b1*h_to_bl + I_ya = (h1 + h2) / ((h1 + h2) + h_to_bl) + ! s1 is the amount staying that minimizes the PE increase. + s1 = 0.5*(h1 + (h2 - bh0) * I_ya) ; s2 = h1 - s1 + + if (s2 < 0.0) then + ! The energy released by detrainment from the lower buffer layer can be + ! used to mix water from the upper buffer layer into the lower one. + s3sq = I_ya*MAX(bh0*h1-dPE_extrap_rhoG, 0.0) + else + s3sq = I_ya*(bh0*h1-MIN(dPE_extrap_rhoG,0.0)) + endif + + if (s3sq == 0.0) then + ! There is a simple, exact solution to the quadratic equation, namely: + stays = h1 ! This will revert to stays_max later. + elseif (s2*s2 <= s3sq) then + ! There is no solution with 0 PE change - use the minimum energy input. + stays = s1 + else + ! The following choose the solutions that are continuous with all water + ! staying in the upper buffer layer when there is no detrainment, + ! namely the + root when s2>0 and the - root otherwise. They also + ! carefully avoid differencing large numbers, using s2 = (h1-s). + if (bh0 <= 0.0) then ; stays = h1 + elseif (s2 > 0.0) then + ! stays = s + sqrt(s2*s2 - s3sq) ! Note that s2 = h1-s + if (s1 >= stays_max) then ; stays = stays_max + elseif (s1 >= 0.0) then ; stays = s1 + sqrt(s2*s2 - s3sq) + else ; stays = (h1*(s2-s1) - s3sq) / (-s1 + sqrt(s2*s2 - s3sq)) + endif + else + ! stays = s - sqrt(s2*s2 - s3sq) ! Note that s2 = h1-s & stays_min >= 0 + if (s1 <= stays_min) then ; stays = stays_min + else ; stays = (h1*(s1-s2) + s3sq) / (s1 + sqrt(s2*s2 - s3sq)) + endif + endif + endif + + ! Limit the amount that stays so that the motion of water is from the + ! upper buffer layer into the lower, but no more than is in the upper + ! layer, and the water left in the upper layer is no lighter than the + ! detrained water. + if (stays >= stays_max) then ; stays = stays_max + elseif (stays < stays_min) then ; stays = stays_min + endif + endif + + if (CS%nonBous_energetics) then + dPE_det_nB = -g_2*GV%H_to_RZ**2*((SpV0(i,kb1)*h_to_bl - SpV0_to_bl)*stays + & + (SpV0(i,kb2)-SpV0(i,kb1)) * (h1-stays) * & + (h2 - scale_slope*stays*((h1+h2)+h_to_bl)/(h1+h2)) ) - & + dPE_extrapolate + else + dPE_det = g_2*((R0(i,kb1)*h_to_bl - R0_to_bl)*stays + & + (R0(i,kb2)-R0(i,kb1)) * (h1-stays) * & + (h2 - scale_slope*stays*((h1+h2)+h_to_bl)/(h1+h2)) ) - & + Rho0xG*dPE_extrap_rhoG + endif + + if (dPE_time_ratio*h_to_bl > h_to_bl+h(i,0)) then + dPE_ratio = (h_to_bl+h(i,0)) / h_to_bl + else + dPE_ratio = dPE_time_ratio + endif + + if (CS%nonBous_energetics) then + better_to_merge = (num_events*dPE_ratio*dPE_det_nB > dPE_merge_nB) + else + better_to_merge = (num_events*dPE_ratio*dPE_det > dPE_merge) + endif + + if (mergeable_bl .and. better_to_merge) then + ! It is energetically preferable to merge the two buffer layers, detrain + ! them into interior layer (k0), move the remaining upper buffer layer + ! water into the lower buffer layer, and detrain undiluted into the + ! upper buffer layer. + h1_to_k0 = (h1-stays_merge) + stays = MAX(h_min_bl-h_to_bl,0.0) + h1_to_h2 = stays_merge - stays + + Ihk0 = 1.0 / ((h1_to_k0 + h2) + h(i,k0)) + Ih1f = 1.0 / (h_to_bl + stays); Ih2f = 1.0 / h1_to_h2 + Ih12 = 1.0 / (h1 + h2) + + dRcv_2dz = (Rcv(i,kb1) - Rcv(i,kb2)) * Ih12 + dRcv_stays = dRcv_2dz*(h1_to_k0 + h1_to_h2) + dRcv_det = - dRcv_2dz*(stays + h1_to_h2) + Rcv(i,k0) = ((h1_to_k0*(Rcv(i,kb1) + dRcv_det) + & + h2*Rcv(i,kb2)) + h(i,k0)*Rcv(i,k0)) * Ihk0 + Rcv(i,kb2) = Rcv(i,kb1) + dRcv_2dz*(h1_to_k0-stays) + Rcv(i,kb1) = (Rcv_to_bl + stays*(Rcv(i,kb1) + dRcv_stays)) * Ih1f + + ! Use 2nd order upwind advection of spiciness, limited by the value in + ! the water from the mixed layer to determine the temperature and + ! salinity of the water that stays in the buffer layers. + I_denom = 1.0 / (dRcv_dS(i)**2 + (dT_dS_gauge*dRcv_dT(i))**2) + dSpice_2dz = (dS_dT_gauge*dRcv_dS(i)*(T(i,kb1)-T(i,kb2)) - & + dT_dS_gauge*dRcv_dT(i)*(S(i,kb1)-S(i,kb2))) * Ih12 + if (CS%nonBous_energetics) then + ! Use the specific volume differences to limit the coordinate density change. + dSpice_lim = -Rcv(i,kb1) * (dS_dT_gauge*dSpV0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dSpV0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / (SpV0(i,kb1) * h_to_bl) + else + dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + endif + if (dSpice_lim * dSpice_2dz <= 0.0) dSpice_2dz = 0.0 + + if (stays > 0.0) then + ! Limit the spiciness of the water that stays in the upper buffer layer. + if (abs(dSpice_lim) < abs(dSpice_2dz*(h1_to_k0 + h1_to_h2))) & + dSpice_2dz = dSpice_lim/(h1_to_k0 + h1_to_h2) + + dSpice_stays = dSpice_2dz*(h1_to_k0 + h1_to_h2) + T_stays = T(i,kb1) + dT_dS_gauge * I_denom * & + (dT_dS_gauge * dRcv_dT(i) * dRcv_stays + dRcv_dS(i) * dSpice_stays) + S_stays = S(i,kb1) + I_denom * & + (dRcv_dS(i) * dRcv_stays - dT_dS_gauge * dRcv_dT(i) * dSpice_stays) + ! The values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_stays = SpV0(i,kb1) + (T_stays-T(i,kb1)) * dSpV0_dT(i) + & + (S_stays-S(i,kb1)) * dSpV0_dS(i) + else + R0_stays = R0(i,kb1) + (T_stays-T(i,kb1)) * dR0_dT(i) + & + (S_stays-S(i,kb1)) * dR0_dS(i) + endif + else + ! Limit the spiciness of the water that moves into the lower buffer layer. + if (abs(dSpice_lim) < abs(dSpice_2dz*h1_to_k0)) & + dSpice_2dz = dSpice_lim/h1_to_k0 + ! These will be multiplied by 0 later. + T_stays = 0.0 ; S_stays = 0.0 ; R0_stays = 0.0 ; SpV0_stays = 0.0 + endif + + dSpice_det = - dSpice_2dz*(stays + h1_to_h2) + T_det = T(i,kb1) + dT_dS_gauge * I_denom * & + (dT_dS_gauge * dRcv_dT(i) * dRcv_det + dRcv_dS(i) * dSpice_det) + S_det = S(i,kb1) + I_denom * & + (dRcv_dS(i) * dRcv_det - dT_dS_gauge * dRcv_dT(i) * dSpice_det) + ! The values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_det = SpV0(i,kb1) + (T_det-T(i,kb1)) * dSpV0_dT(i) + & + (S_det-S(i,kb1)) * dSpV0_dS(i) + else + R0_det = R0(i,kb1) + (T_det-T(i,kb1)) * dR0_dT(i) + & + (S_det-S(i,kb1)) * dR0_dS(i) + endif + + T(i,k0) = ((h1_to_k0*T_det + h2*T(i,kb2)) + h(i,k0)*T(i,k0)) * Ihk0 + T(i,kb2) = (h1*T(i,kb1) - stays*T_stays - h1_to_k0*T_det) * Ih2f + T(i,kb1) = (T_to_bl + stays*T_stays) * Ih1f + + S(i,k0) = ((h1_to_k0*S_det + h2*S(i,kb2)) + h(i,k0)*S(i,k0)) * Ihk0 + S(i,kb2) = (h1*S(i,kb1) - stays*S_stays - h1_to_k0*S_det) * Ih2f + S(i,kb1) = (S_to_bl + stays*S_stays) * Ih1f + + if (CS%nonBous_energetics) then + SpV0(i,k0) = ((h1_to_k0*SpV0_det + h2*SpV0(i,kb2)) + h(i,k0)*SpV0(i,k0)) * Ihk0 + SpV0(i,kb2) = (h1*SpV0(i,kb1) - stays*SpV0_stays - h1_to_k0*SpV0_det) * Ih2f + SpV0(i,kb1) = (SpV0_to_bl + stays*SpV0_stays) * Ih1f + else + R0(i,k0) = ((h1_to_k0*R0_det + h2*R0(i,kb2)) + h(i,k0)*R0(i,k0)) * Ihk0 + R0(i,kb2) = (h1*R0(i,kb1) - stays*R0_stays - h1_to_k0*R0_det) * Ih2f + R0(i,kb1) = (R0_to_bl + stays*R0_stays) * Ih1f + endif + +! ! The following is 2nd-order upwind advection without limiters. +! dT_2dz = (T(i,kb1) - T(i,kb2)) * Ih12 +! T(i,k0) = (h1_to_k0*(T(i,kb1) - dT_2dz*(stays+h1_to_h2)) + & +! h2*T(i,kb2) + h(i,k0)*T(i,k0)) * Ihk0 +! T(i,kb2) = T(i,kb1) + dT_2dz*(h1_to_k0-stays) +! T(i,kb1) = (T_to_bl + stays*(T(i,kb1) + dT_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! dS_2dz = (S(i,kb1) - S(i,kb2)) * Ih12 +! S(i,k0) = (h1_to_k0*(S(i,kb1) - dS_2dz*(stays+h1_to_h2)) + & +! h2*S(i,kb2) + h(i,k0)*S(i,k0)) * Ihk0 +! S(i,kb2) = S(i,kb1) + dS_2dz*(h1_to_k0-stays) +! S(i,kb1) = (S_to_bl + stays*(S(i,kb1) + dS_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! if (CS%nonBous_energetics) then +! dSpV0_2dz = (SpV0(i,kb1) - SpV0(i,kb2)) * Ih12 +! SpV0(i,k0) = (h1_to_k0*(SpV0(i,kb1) - dSpV0_2dz*(stays+h1_to_h2)) + & +! h2*SpV0(i,kb2) + h(i,k0)*SpV0(i,k0)) * Ihk0 +! SpV0(i,kb2) = SpV0(i,kb1) + dSpV0_2dz*(h1_to_k0-stays) +! SpV0(i,kb1) = (SpV0_to_bl + stays*(SpV0(i,kb1) + dSpV0_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! else +! dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih12 +! R0(i,k0) = (h1_to_k0*(R0(i,kb1) - dR0_2dz*(stays+h1_to_h2)) + & +! h2*R0(i,kb2) + h(i,k0)*R0(i,k0)) * Ihk0 +! R0(i,kb2) = R0(i,kb1) + dR0_2dz*(h1_to_k0-stays) +! R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + dR0_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! endif + + d_ea(i,kb1) = (d_ea(i,kb1) + h_to_bl) + (stays - h1) + d_ea(i,kb2) = d_ea(i,kb2) + (h1_to_h2 - h2) + d_ea(i,k0) = d_ea(i,k0) + (h1_to_k0 + h2) + + h(i,kb1) = stays + h_to_bl + h(i,kb2) = h1_to_h2 + h(i,k0) = h(i,k0) + (h1_to_k0 + h2) + if (CS%nonBous_energetics) then + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_diag*dPE_merge_nB + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_diag*(dPE_det_nB + dPE_extrapolate) + else + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_merge + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap_rhoG) + endif + else ! Not mergeable_bl. + ! There is no further detrainment from the buffer layers, and the + ! upper buffer layer water is distributed optimally between the + ! upper and lower buffer layer. + h1_to_h2 = h1 - stays + Ih1f = 1.0 / (h_to_bl + stays) ; Ih2f = 1.0 / (h2 + h1_to_h2) + Ih = 1.0 / (h1 + h2) + if (CS%nonBous_energetics) then + dSpV0_2dz = (SpV0(i,kb1) - SpV0(i,kb2)) * Ih + SpV0(i,kb2) = (h2*SpV0(i,kb2) + h1_to_h2*(SpV0(i,kb1) - scale_slope*dSpV0_2dz*stays)) * Ih2f + SpV0(i,kb1) = (SpV0_to_bl + stays*(SpV0(i,kb1) + scale_slope*dSpV0_2dz*h1_to_h2)) * Ih1f + else + dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih + R0(i,kb2) = (h2*R0(i,kb2) + h1_to_h2*(R0(i,kb1) - scale_slope*dR0_2dz*stays)) * Ih2f + R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + scale_slope*dR0_2dz*h1_to_h2)) * Ih1f + endif + + ! Use 2nd order upwind advection of spiciness, limited by the value in the + ! detrained water to determine the detrained temperature and salinity. + if (CS%nonBous_energetics) then + dSpV0 = scale_slope*dSpV0_2dz*h1_to_h2 + dSpiceSpV_stays = (dS_dT_gauge*dSpV0_dS(i)*(T(i,kb1)-T(i,kb2)) - & + dT_dS_gauge*dSpV0_dT(i)*(S(i,kb1)-S(i,kb2))) * & + scale_slope*h1_to_h2 * Ih + if (h_to_bl > 0.0) then + dSpiceSpV_lim = (dS_dT_gauge*dSpV0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dSpV0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + else + dSpiceSpV_lim = dS_dT_gauge*dSpV0_dS(i)*(T(i,0)-T(i,kb1)) - & + dT_dS_gauge*dSpV0_dT(i)*(S(i,0)-S(i,kb1)) + endif + if (dSpiceSpV_stays*dSpiceSpV_lim <= 0.0) then + dSpiceSpV_stays = 0.0 + elseif (abs(dSpiceSpV_stays) > abs(dSpiceSpV_lim)) then + dSpiceSpV_stays = dSpiceSpV_lim + endif + I_denom = 1.0 / (dSpV0_dS(i)**2 + (dT_dS_gauge*dSpV0_dT(i))**2) + T_stays = T(i,kb1) + dT_dS_gauge * I_denom * & + (dT_dS_gauge * dSpV0_dT(i) * dSpV0 + dSpV0_dS(i) * dSpiceSpV_stays) + S_stays = S(i,kb1) + I_denom * & + (dSpV0_dS(i) * dSpV0 - dT_dS_gauge * dSpV0_dT(i) * dSpiceSpV_stays) + else + dR0 = scale_slope*dR0_2dz*h1_to_h2 + dSpice_stays = (dS_dT_gauge*dR0_dS(i)*(T(i,kb1)-T(i,kb2)) - & + dT_dS_gauge*dR0_dT(i)*(S(i,kb1)-S(i,kb2))) * & + scale_slope*h1_to_h2 * Ih + if (h_to_bl > 0.0) then + dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + else + dSpice_lim = dS_dT_gauge*dR0_dS(i)*(T(i,0)-T(i,kb1)) - & + dT_dS_gauge*dR0_dT(i)*(S(i,0)-S(i,kb1)) + endif + if (dSpice_stays*dSpice_lim <= 0.0) then + dSpice_stays = 0.0 + elseif (abs(dSpice_stays) > abs(dSpice_lim)) then + dSpice_stays = dSpice_lim + endif + I_denom = 1.0 / (dR0_dS(i)**2 + (dT_dS_gauge*dR0_dT(i))**2) + T_stays = T(i,kb1) + dT_dS_gauge * I_denom * & + (dT_dS_gauge * dR0_dT(i) * dR0 + dR0_dS(i) * dSpice_stays) + S_stays = S(i,kb1) + I_denom * & + (dR0_dS(i) * dR0 - dT_dS_gauge * dR0_dT(i) * dSpice_stays) + endif + + ! The detrained values of Rcv are based on changes in T and S. + Rcv_stays = Rcv(i,kb1) + (T_stays-T(i,kb1)) * dRcv_dT(i) + & + (S_stays-S(i,kb1)) * dRcv_dS(i) + + T(i,kb2) = (h2*T(i,kb2) + h1*T(i,kb1) - T_stays*stays) * Ih2f + T(i,kb1) = (T_to_bl + stays*T_stays) * Ih1f + S(i,kb2) = (h2*S(i,kb2) + h1*S(i,kb1) - S_stays*stays) * Ih2f + S(i,kb1) = (S_to_bl + stays*S_stays) * Ih1f + Rcv(i,kb2) = (h2*Rcv(i,kb2) + h1*Rcv(i,kb1) - Rcv_stays*stays) * Ih2f + Rcv(i,kb1) = (Rcv_to_bl + stays*Rcv_stays) * Ih1f + +! ! The following is 2nd-order upwind advection without limiters. +! dRcv_2dz = (Rcv(i,kb1) - Rcv(i,kb2)) * Ih +! dRcv = scale_slope*dRcv_2dz*h1_to_h2 +! Rcv(i,kb2) = (h2*Rcv(i,kb2) + h1_to_h2*(Rcv(i,kb1) - & +! scale_slope*dRcv_2dz*stays)) * Ih2f +! Rcv(i,kb1) = (Rcv_to_bl + stays*(Rcv(i,kb1) + dRcv)) * Ih1f +! dT_2dz = (T(i,kb1) - T(i,kb2)) * Ih +! T(i,kb2) = (h2*T(i,kb2) + h1_to_h2*(T(i,kb1) - & +! scale_slope*dT_2dz*stays)) * Ih2f +! T(i,kb1) = (T_to_bl + stays*(T(i,kb1) + & +! scale_slope*dT_2dz*h1_to_h2)) * Ih1f +! dS_2dz = (S(i,kb1) - S(i,kb2)) * Ih +! S(i,kb2) = (h2*S(i,kb2) + h1_to_h2*(S(i,kb1) - & +! scale_slope*dS_2dz*stays)) * Ih2f +! S(i,kb1) = (S_to_bl + stays*(S(i,kb1) + & +! scale_slope*dS_2dz*h1_to_h2)) * Ih1f + + d_ea(i,kb1) = d_ea(i,kb1) + ((stays - h1) + h_to_bl) + d_ea(i,kb2) = d_ea(i,kb2) + h1_to_h2 + + h(i,kb1) = stays + h_to_bl + h(i,kb2) = h(i,kb2) + h1_to_h2 + + if (CS%nonBous_energetics) then + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_diag*dPE_det_nB + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_diag*(dPE_det_nB + dPE_extrapolate) + else + ! Recasting dPE_det into the same units as dPE_det_nB changes these diagnostics slightly + ! in some cases for reasons that are not understood. + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_det + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap_rhoG) + endif + endif + endif ! End of detrainment... + + enddo ! i loop + +end subroutine mixedlayer_detrain_2 + +!> This subroutine moves any water left in the former mixed layers into the +!! single buffer layers and may also move buffer layer water into the interior +!! isopycnal layers. +subroutine mixedlayer_detrain_1(h, T, S, R0, SpV0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_eb, & + j, G, GV, US, CS, dRcv_dT, dRcv_dS, max_BL_det) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. + !! Layer 0 is the new mixed layer. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Potential temperature [C ~> degC]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [S ~> ppt]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to + !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg] + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential + !! density [R ~> kg m-3]. + real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each + !! layer [R ~> kg m-3]. + real, intent(in) :: dt !< Time increment [T ~> s]. + real, intent(in) :: dt_diag !< The accumulated time interval for + !! diagnostics [T ~> s]. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_ea !< The upward increase across a layer in + !! the entrainment from above + !! [H ~> m or kg m-2]. Positive d_ea + !! goes with layer thickness increases. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_eb !< The downward increase across a layer + !! in the entrainment from below [H ~> m or kg m-2]. + !! Positive values go with mass gain by + !! a layer. + integer, intent(in) :: j !< The meridional row to work on. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure + real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of + !! coordinate defining potential density + !! with potential temperature + !! [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of + !! coordinate defining potential density + !! with salinity [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: max_BL_det !< If non-negative, the maximum + !! detrainment permitted from the buffer + !! layers [H ~> m or kg m-2]. + + ! Local variables + real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. + real :: h_ent ! The thickness from a layer that is + ! entrained [H ~> m or kg m-2]. + real :: max_det_rem(SZI_(G)) ! Remaining permitted detrainment [H ~> m or kg m-2]. + real :: detrain(SZI_(G)) ! The thickness of fluid to detrain + ! from the mixed layer [H ~> m or kg m-2]. + real :: dT_dS_wt2 ! The square of the relative weighting of temperature and salinity changes + ! when extraploating to match a target density [C2 S-2 ~> degC2 ppt-2] + real :: dT_dR ! The ratio of temperature changes to density changes when + ! extrapolating [C R-1 ~> degC m3 kg-1] + real :: dS_dR ! The ratio of salinity changes to density changes when + ! extrapolating [S R-1 ~> ppt m3 kg-1] + real :: dRml ! The density range within the extent of the mixed layers [R ~> kg m-3] + real :: dR0_dRcv ! The relative changes in the potential density and the coordinate density [nondim] + real :: dSpV0_dRcv ! The relative changes in the specific volume and the coordinate density [R-2 ~> m6 kg-2] + real :: I_denom ! A work variable [S2 R-2 ~> ppt2 m6 kg-2]. + real :: Sdown ! The salinity of the detrained water [S ~> ppt] + real :: Tdown ! The temperature of the detrained water [C ~> degC] + real :: dt_Time ! The timestep divided by the detrainment timescale [nondim]. + real :: g_H_2Rho0dt ! Half the gravitational acceleration times the + ! conversion from H to m divided by the mean density times the time + ! step [L2 T-3 H-1 R-1 ~> m4 s-3 kg-1 or m7 s-3 kg-2]. + real :: g_H2_2dt ! Half the gravitational acceleration times the square of the + ! conversion from H to Z divided by the diagnostic time step + ! [L2 Z H-2 T-3 ~> m s-3 or m7 kg-2 s-3]. + real :: nB_g_H_2dt ! Half the gravitational acceleration times the conversion from + ! H to RZ divided by the diagnostic time step + ! [L2 R H-1 T-3 ~> kg m s-3 or m4 s-3]. + real :: nB_gRZ_H2_2dt ! Half the gravitational acceleration times the conversion from + ! H to RZ squared divided by the diagnostic time step + ! [L2 R2 Z H-2 T-3 ~> kg2 m-2 s-3 or m4 s-3]. + real :: x1 ! A temporary work variable [various] + logical :: splittable_BL(SZI_(G)), orthogonal_extrap + logical :: must_unmix + integer :: i, is, ie, k, k1, nkmb, nz + + is = G%isc ; ie = G%iec ; nz = GV%ke + nkmb = CS%nkml+CS%nkbl + if (CS%nkbl /= 1) call MOM_error(FATAL,"MOM_mixed_layer: "// & + "CS%nkbl must be 1 in mixedlayer_detrain_1.") + + dt_Time = dt / CS%BL_detrain_time + + if (CS%nonBous_energetics) then + nB_g_H_2dt = (GV%g_Earth * GV%H_to_RZ) / (2.0 * dt_diag) + nB_gRZ_H2_2dt = GV%H_to_RZ * nB_g_H_2dt + else + g_H2_2dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * dt_diag) + g_H_2Rho0dt = g_H2_2dt * GV%RZ_to_H + endif + + ! Move detrained water into the buffer layer. + do k=1,CS%nkml + do i=is,ie ; if (h(i,k) > 0.0) then + Ih = 1.0 / (h(i,nkmb) + h(i,k)) + + if (CS%nonBous_energetics) then + if (CS%TKE_diagnostics) & + CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) - & + nB_g_H_2dt * (h(i,k) * h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,k)) + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) - & + nB_gRZ_H2_2dt * (h(i,k) * h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,k)) + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) - & + nB_gRZ_H2_2dt * (h(i,k) * h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,k)) + + SpV0(i,nkmb) = (SpV0(i,nkmb)*h(i,nkmb) + SpV0(i,k)*h(i,k)) * Ih + else + if (CS%TKE_diagnostics) & + CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) + & + g_H_2Rho0dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + & + g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + & + g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) + + R0(i,nkmb) = (R0(i,nkmb)*h(i,nkmb) + R0(i,k)*h(i,k)) * Ih + endif + Rcv(i,nkmb) = (Rcv(i,nkmb)*h(i,nkmb) + Rcv(i,k)*h(i,k)) * Ih + T(i,nkmb) = (T(i,nkmb)*h(i,nkmb) + T(i,k)*h(i,k)) * Ih + S(i,nkmb) = (S(i,nkmb)*h(i,nkmb) + S(i,k)*h(i,k)) * Ih + + d_ea(i,k) = d_ea(i,k) - h(i,k) + d_ea(i,nkmb) = d_ea(i,nkmb) + h(i,k) + h(i,nkmb) = h(i,nkmb) + h(i,k) + h(i,k) = 0.0 + endif ; enddo + enddo + + do i=is,ie + max_det_rem(i) = 10.0 * h(i,nkmb) + if (max_BL_det(i) >= 0.0) max_det_rem(i) = max_BL_det(i) + enddo + +! If the mixed layer was denser than the densest interior layer, +! but is now lighter than this layer, leaving a buffer layer that +! is denser than this layer, there are problems. This should prob- +! ably be considered a case of an inadequate choice of resolution in +! density space and should be avoided. To make the model run sens- +! ibly in this case, it will make the mixed layer denser while making +! the buffer layer the density of the densest interior layer (pro- +! vided that the this will not make the mixed layer denser than the +! interior layer). Otherwise, make the mixed layer the same density +! as the densest interior layer and lighten the buffer layer with +! the released buoyancy. With multiple buffer layers, much more +! graceful options are available. + do i=is,ie ; if (h(i,nkmb) > 0.0) then + if (CS%nonBous_energetics) then + must_unmix = (SpV0(i,0) > SpV0(i,nz)) .and. (SpV0(i,nz) > SpV0(i,nkmb)) + else + must_unmix = (R0(i,0) < R0(i,nz)) .and. (R0(i,nz) < R0(i,nkmb)) + endif + if (must_unmix) then + if (CS%nonBous_energetics) then + if ((SpV0(i,0)-SpV0(i,nz))*h(i,0) > (SpV0(i,nz)-SpV0(i,nkmb))*h(i,nkmb)) then + detrain(i) = (SpV0(i,nz)-SpV0(i,nkmb))*h(i,nkmb) / (SpV0(i,0)-SpV0(i,nkmb)) + else + detrain(i) = (SpV0(i,0)-SpV0(i,nz))*h(i,0) / (SpV0(i,0)-SpV0(i,nkmb)) + endif + else + if ((R0(i,nz)-R0(i,0))*h(i,0) > (R0(i,nkmb)-R0(i,nz))*h(i,nkmb)) then + detrain(i) = (R0(i,nkmb)-R0(i,nz))*h(i,nkmb) / (R0(i,nkmb)-R0(i,0)) + else + detrain(i) = (R0(i,nz)-R0(i,0))*h(i,0) / (R0(i,nkmb)-R0(i,0)) + endif + endif + + d_eb(i,CS%nkml) = d_eb(i,CS%nkml) + detrain(i) + d_ea(i,CS%nkml) = d_ea(i,CS%nkml) - detrain(i) + d_eb(i,nkmb) = d_eb(i,nkmb) - detrain(i) + d_ea(i,nkmb) = d_ea(i,nkmb) + detrain(i) + + if (CS%nonBous_energetics) then + if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & + CS%diag_PE_detrain(i,j) - nB_gRZ_H2_2dt * detrain(i)* & + (h(i,0) + h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,0)) + x1 = SpV0(i,0) + SpV0(i,0) = SpV0(i,0) - detrain(i)*(SpV0(i,0)-SpV0(i,nkmb)) / h(i,0) + SpV0(i,nkmb) = SpV0(i,nkmb) - detrain(i)*(SpV0(i,nkmb)-x1) / h(i,nkmb) + else + if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & + CS%diag_PE_detrain(i,j) + g_H2_2dt * detrain(i)* & + (h(i,0) + h(i,nkmb)) * (R0(i,nkmb) - R0(i,0)) + x1 = R0(i,0) + R0(i,0) = R0(i,0) - detrain(i)*(R0(i,0)-R0(i,nkmb)) / h(i,0) + R0(i,nkmb) = R0(i,nkmb) - detrain(i)*(R0(i,nkmb)-x1) / h(i,nkmb) + endif + + x1 = Rcv(i,0) + Rcv(i,0) = Rcv(i,0) - detrain(i)*(Rcv(i,0)-Rcv(i,nkmb)) / h(i,0) + Rcv(i,nkmb) = Rcv(i,nkmb) - detrain(i)*(Rcv(i,nkmb)-x1) / h(i,nkmb) + x1 = T(i,0) + T(i,0) = T(i,0) - detrain(i)*(T(i,0)-T(i,nkmb)) / h(i,0) + T(i,nkmb) = T(i,nkmb) - detrain(i)*(T(i,nkmb)-x1) / h(i,nkmb) + x1 = S(i,0) + S(i,0) = S(i,0) - detrain(i)*(S(i,0)-S(i,nkmb)) / h(i,0) + S(i,nkmb) = S(i,nkmb) - detrain(i)*(S(i,nkmb)-x1) / h(i,nkmb) + + endif + endif ; enddo + + ! Move water out of the buffer layer, if convenient. +! Split the buffer layer if possible, and replace the buffer layer +! with a small amount of fluid from the mixed layer. +! This is the exponential-in-time splitting, circa 2005. + do i=is,ie + if (h(i,nkmb) > 0.0) then ; splittable_BL(i) = .true. + else ; splittable_BL(i) = .false. ; endif + enddo + + dT_dS_wt2 = CS%dT_dS_wt**2 + + do k=nz-1,nkmb+1,-1 ; do i=is,ie + if (splittable_BL(i)) then + if (RcvTgt(k) <= Rcv(i,nkmb)) then +! Estimate dR/drho, dTheta/dR, and dS/dR, where R is the coordinate variable +! and rho is in-situ (or surface) potential density. +! There is no "right" way to do this, so this keeps things reasonable, if +! slightly arbitrary. + splittable_BL(i) = .false. + + k1 = k+1 ; orthogonal_extrap = .false. + ! Here we try to find a massive layer to use for interpolating the + ! temperature and salinity. If none is available a pseudo-orthogonal + ! extrapolation is used. The 10.0 and 0.9 in the following are + ! arbitrary but probably about right. + if ((h(i,k+1) < 10.0*GV%Angstrom_H) .or. & + ((RcvTgt(k+1)-Rcv(i,nkmb)) >= 0.9*(Rcv(i,k1) - Rcv(i,0)))) then + if (k>=nz-1) then ; orthogonal_extrap = .true. + elseif ((h(i,k+2) <= 10.0*GV%Angstrom_H) .and. & + ((RcvTgt(k+1)-Rcv(i,nkmb)) < 0.9*(Rcv(i,k+2)-Rcv(i,0)))) then + k1 = k+2 + else ; orthogonal_extrap = .true. ; endif + endif + + ! Check for the case when there is an inversion of in-situ density relative to + ! the coordinate variable. Do not detrain from the buffer layer in this case. + if (CS%nonBous_energetics) then + if ((SpV0(i,0) <= SpV0(i,k1)) .or. (Rcv(i,0) >= Rcv(i,nkmb))) cycle + else + if ((R0(i,0) >= R0(i,k1)) .or. (Rcv(i,0) >= Rcv(i,nkmb))) cycle + endif + + if (orthogonal_extrap) then + ! 36 here is a typical oceanic value of (dR/dS) / (dR/dT) - it says + ! that the relative weights of T & S changes is a plausible 6:1. + ! Also, this was coded on Athena's 6th birthday! + I_denom = 1.0 / (dRcv_dS(i)**2 + dT_dS_wt2*dRcv_dT(i)**2) + dT_dR = dT_dS_wt2*dRcv_dT(i) * I_denom + dS_dR = dRcv_dS(i) * I_denom + else + dT_dR = (T(i,0) - T(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + dS_dR = (S(i,0) - S(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + endif + + if (CS%nonBous_energetics) then + dRml = dt_Time * (SpV0(i,0) - SpV0(i,nkmb)) * & + (Rcv(i,0) - Rcv(i,k1)) / (SpV0(i,k1) - SpV0(i,0)) + if (dRml < 0.0) cycle ! Once again, there is an apparent density inversion in Rcv. + dSpV0_dRcv = (SpV0(i,0) - SpV0(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + else + dRml = dt_Time * (R0(i,nkmb) - R0(i,0)) * & + (Rcv(i,0) - Rcv(i,k1)) / (R0(i,0) - R0(i,k1)) + if (dRml < 0.0) cycle ! Once again, there is an apparent density inversion in Rcv. + dR0_dRcv = (R0(i,0) - R0(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + endif + + if ((Rcv(i,nkmb) - dRml < RcvTgt(k)) .and. (max_det_rem(i) > h(i,nkmb))) then + ! In this case, the buffer layer is split into two isopycnal layers. + detrain(i) = h(i,nkmb) * (Rcv(i,nkmb) - RcvTgt(k)) / & + (RcvTgt(k+1) - RcvTgt(k)) + + if (allocated(CS%diag_PE_detrain)) then + if (CS%nonBous_energetics) then + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + nB_gRZ_H2_2dt * detrain(i) * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - RcvTgt(k)) * dSpV0_dRcv + else + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - RcvTgt(k)) * dR0_dRcv + endif + endif + + Tdown = detrain(i) * (T(i,nkmb) + dT_dR*(RcvTgt(k+1)-Rcv(i,nkmb))) + T(i,k) = (h(i,k) * T(i,k) + & + (h(i,nkmb) * T(i,nkmb) - Tdown)) / & + (h(i,k) + (h(i,nkmb) - detrain(i))) + T(i,k+1) = (h(i,k+1) * T(i,k+1) + Tdown)/ & + (h(i,k+1) + detrain(i)) + T(i,nkmb) = T(i,0) + Sdown = detrain(i) * (S(i,nkmb) + dS_dR*(RcvTgt(k+1)-Rcv(i,nkmb))) + S(i,k) = (h(i,k) * S(i,k) + & + (h(i,nkmb) * S(i,nkmb) - Sdown)) / & + (h(i,k) + (h(i,nkmb) - detrain(i))) + S(i,k+1) = (h(i,k+1) * S(i,k+1) + Sdown)/ & + (h(i,k+1) + detrain(i)) + S(i,nkmb) = S(i,0) + Rcv(i,nkmb) = Rcv(i,0) + + d_ea(i,k+1) = d_ea(i,k+1) + detrain(i) + d_ea(i,k) = d_ea(i,k) + (h(i,nkmb) - detrain(i)) + d_ea(i,nkmb) = d_ea(i,nkmb) - h(i,nkmb) + + h(i,k+1) = h(i,k+1) + detrain(i) + h(i,k) = h(i,k) + h(i,nkmb) - detrain(i) + h(i,nkmb) = 0.0 + else + ! Here only part of the buffer layer is moved into the interior. + detrain(i) = h(i,nkmb) * dRml / (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) + if (detrain(i) > max_det_rem(i)) detrain(i) = max_det_rem(i) + Ih = 1.0 / (h(i,k+1) + detrain(i)) + + Tdown = (T(i,nkmb) + dT_dR*(RcvTgt(k+1)-Rcv(i,nkmb))) + T(i,nkmb) = T(i,nkmb) - dT_dR * dRml + T(i,k+1) = (h(i,k+1) * T(i,k+1) + detrain(i) * Tdown) * Ih + Sdown = (S(i,nkmb) + dS_dR*(RcvTgt(k+1)-Rcv(i,nkmb))) +! The following two expressions updating S(nkmb) are mathematically identical. +! S(i,nkmb) = (h(i,nkmb) * S(i,nkmb) - detrain(i) * Sdown) / & +! (h(i,nkmb) - detrain(i)) + S(i,nkmb) = S(i,nkmb) - dS_dR * dRml + S(i,k+1) = (h(i,k+1) * S(i,k+1) + detrain(i) * Sdown) * Ih + + d_ea(i,k+1) = d_ea(i,k+1) + detrain(i) + d_ea(i,nkmb) = d_ea(i,nkmb) - detrain(i) + + h(i,k+1) = h(i,k+1) + detrain(i) + h(i,nkmb) = h(i,nkmb) - detrain(i) + + if (allocated(CS%diag_PE_detrain)) then + if (CS%nonBous_energetics) then + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + nB_gRZ_H2_2dt * detrain(i) * dSpV0_dRcv * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) + else + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * dR0_dRcv * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) + endif + endif + endif + endif ! (RcvTgt(k) <= Rcv(i,nkmb)) + endif ! splittable_BL + enddo ; enddo ! i & k loops + +! The numerical behavior of the buffer layer is dramatically improved +! if it is always at least a small fraction (say 10%) of the thickness +! of the mixed layer. As the physical distinction between the mixed +! and buffer layers is vague anyway, this seems hard to argue against. + do i=is,ie + if (h(i,nkmb) < 0.1*h(i,0)) then + h_ent = 0.1*h(i,0) - h(i,nkmb) + Ih = 10.0/h(i,0) + T(i,nkmb) = (h(i,nkmb)*T(i,nkmb) + h_ent*T(i,0)) * Ih + S(i,nkmb) = (h(i,nkmb)*S(i,nkmb) + h_ent*S(i,0)) * Ih + + d_ea(i,1) = d_ea(i,1) - h_ent + d_ea(i,nkmb) = d_ea(i,nkmb) + h_ent + + h(i,0) = h(i,0) - h_ent + h(i,nkmb) = h(i,nkmb) + h_ent + endif + enddo + +end subroutine mixedlayer_detrain_1 + +!> This subroutine initializes the MOM bulk mixed layer module. +subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) + type(time_type), target, intent(in) :: Time !< The model's clock with the current time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic + !! output. + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_mixed_layer" ! This module's name. + real :: omega_frac_dflt ! The default value for ML_OMEGA_FRAC [nondim] + real :: ustar_min_dflt ! The default value for BML_USTAR_MIN [Z T-1 ~> m s-1] + real :: Hmix_min_z ! HMIX_MIN in units of vertical extent [Z ~> m], used to set other defaults + integer :: isd, ied, jsd, jed + logical :: use_temperature, use_omega + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + CS%initialized = .true. + CS%diag => diag + CS%Time => Time + + if (GV%nkml < 1) return + +! Set default, read and log parameters + call log_version(param_file, mdl, version, "") + + CS%nkml = GV%nkml + call log_param(param_file, mdl, "NKML", CS%nkml, & + "The number of sublayers within the mixed layer if "//& + "BULKMIXEDLAYER is true.", units="nondim", default=2) + CS%nkbl = GV%nk_rho_varies - GV%nkml + call log_param(param_file, mdl, "NKBL", CS%nkbl, & + "The number of variable density buffer layers if "//& + "BULKMIXEDLAYER is true.", units="nondim", default=2) + call get_param(param_file, mdl, "MSTAR", CS%mstar, & + "The ratio of the friction velocity cubed to the TKE "//& + "input to the mixed layer.", units="nondim", default=1.2) + call get_param(param_file, mdl, "NSTAR", CS%nstar, & + "The portion of the buoyant potential energy imparted by "//& + "surface fluxes that is available to drive entrainment "//& + "at the base of mixed layer when that energy is positive.", & + units="nondim", default=0.15) + call get_param(param_file, mdl, "BULK_RI_ML", CS%bulk_Ri_ML, & + "The efficiency with which mean kinetic energy released "//& + "by mechanically forced entrainment of the mixed layer "//& + "is converted to turbulent kinetic energy.", & + units="nondim", fail_if_missing=.true.) + call get_param(param_file, mdl, "ABSORB_ALL_SW", CS%absorb_all_sw, & + "If true, all shortwave radiation is absorbed by the "//& + "ocean, instead of passing through to the bottom mud.", & + default=.false.) + call get_param(param_file, mdl, "TKE_DECAY", CS%TKE_decay, & + "TKE_DECAY relates the vertical rate of decay of the "//& + "TKE available for mechanical entrainment to the natural "//& + "Ekman depth.", units="nondim", default=2.5) + call get_param(param_file, mdl, "NSTAR2", CS%nstar2, & + "The portion of any potential energy released by "//& + "convective adjustment that is available to drive "//& + "entrainment at the base of mixed layer. By default NSTAR2=NSTAR.", & + units="nondim", default=CS%nstar) + call get_param(param_file, mdl, "BULK_RI_CONVECTIVE", CS%bulk_Ri_convective, & + "The efficiency with which convectively released mean "//& + "kinetic energy is converted to turbulent kinetic "//& + "energy. By default BULK_RI_CONVECTIVE=BULK_RI_ML.", & + units="nondim", default=CS%bulk_Ri_ML) + call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) + call get_param(param_file, mdl, "HMIX_MIN", Hmix_min_Z, & + "The minimum mixed layer depth if the mixed layer depth "//& + "is determined dynamically.", units="m", default=0.0, scale=US%m_to_Z) + CS%Hmix_min = GV%m_to_H * (US%Z_to_m * Hmix_min_Z) + call get_param(param_file, mdl, "MECH_TKE_FLOOR", CS%mech_TKE_floor, & + "A tiny floor on the amount of turbulent kinetic energy that is used when "//& + "the mixed layer does not yet contain HMIX_MIN fluid. The default is so "//& + "small that its actual value is irrelevant, so long as it is greater than 0.", & + units="m3 s-2", default=1.0e-150, scale=GV%m_to_H*US%m_s_to_L_T**2, & + do_not_log=(Hmix_min_Z<=0.0)) + + call get_param(param_file, mdl, "LIMIT_BUFFER_DETRAIN", CS%limit_det, & + "If true, limit the detrainment from the buffer layers "//& + "to not be too different from the neighbors.", default=.false.) + call get_param(param_file, mdl, "ALLOWED_DETRAIN_TEMP_CHG", CS%Allowed_T_chg, & + "The amount by which temperature is allowed to exceed previous values "//& + "during detrainment.", units="K", default=0.5, scale=US%degC_to_C) + call get_param(param_file, mdl, "ALLOWED_DETRAIN_SALT_CHG", CS%Allowed_S_chg, & + "The amount by which salinity is allowed to exceed previous values "//& + "during detrainment.", units="ppt", default=0.1, scale=US%ppt_to_S) + call get_param(param_file, mdl, "ML_DT_DS_WEIGHT", CS%dT_dS_wt, & + "When forced to extrapolate T & S to match the layer "//& + "densities, this factor (in deg C / PSU) is combined "//& + "with the derivatives of density with T & S to determine "//& + "what direction is orthogonal to density contours. It "//& + "should be a typical value of (dR/dS) / (dR/dT) in oceanic profiles.", & + units="degC ppt-1", default=6.0, scale=US%degC_to_C*US%S_to_ppt) + call get_param(param_file, mdl, "BUFFER_LAYER_EXTRAP_LIMIT", CS%BL_extrap_lim, & + "A limit on the density range over which extrapolation "//& + "can occur when detraining from the buffer layers, "//& + "relative to the density range within the mixed and "//& + "buffer layers, when the detrainment is going into the "//& + "lightest interior layer, nondimensional, or a negative "//& + "value not to apply this limit.", units="nondim", default=-1.0) + call get_param(param_file, mdl, "BUFFER_LAYER_HMIN_THICK", CS%Hbuffer_min, & + "The minimum buffer layer thickness when the mixed layer is very thick.", & + units="m", default=5.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "BUFFER_LAYER_HMIN_REL", CS%Hbuffer_rel_min, & + "The minimum buffer layer thickness relative to the combined mixed "//& + "land buffer ayer thicknesses when they are thin.", & + units="nondim", default=0.1/CS%nkbl) + if (CS%nkbl==1) then + call get_param(param_file, mdl, "BUFFER_LAY_DETRAIN_TIME", CS%BL_detrain_time, & + "A timescale that characterizes buffer layer detrainment events.", & + units="s", default=86400.0*30.0, scale=US%s_to_T) + else + call get_param(param_file, mdl, "BUFFER_LAY_DETRAIN_TIME", CS%BL_detrain_time, & + "A timescale that characterizes buffer layer detrainment events.", & + units="s", default=4.0*3600.0, scale=US%s_to_T) + endif + call get_param(param_file, mdl, "BUFFER_SPLIT_RHO_TOL", CS%BL_split_rho_tol, & + "The fractional tolerance for matching layer target densities when splitting "//& + "layers to deal with massive interior layers that are lighter than one of the "//& + "mixed or buffer layers.", units="nondim", default=0.1) + + call get_param(param_file, mdl, "DEPTH_LIMIT_FLUXES", CS%H_limit_fluxes, & + "The surface fluxes are scaled away when the total ocean "//& + "depth is less than DEPTH_LIMIT_FLUXES.", & + units="m", default=0.1*US%Z_to_m*Hmix_min_z, scale=GV%m_to_H) + call get_param(param_file, mdl, "OMEGA", CS%omega, & + "The rotation rate of the earth.", & + default=7.2921e-5, units="s-1", scale=US%T_to_s) + call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & + "If true, use the absolute rotation rate instead of the "//& + "vertical component of rotation when setting the decay "//& + "scale for turbulence.", default=.false., do_not_log=.true.) + omega_frac_dflt = 0.0 + if (use_omega) then + call MOM_error(WARNING, "ML_USE_OMEGA is depricated; use ML_OMEGA_FRAC=1.0 instead.") + omega_frac_dflt = 1.0 + endif + call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%omega_frac, & + "When setting the decay scale for turbulence, use this "//& + "fraction of the absolute rotation rate blended with the "//& + "local value of f, as sqrt((1-of)*f^2 + of*4*omega^2).", & + units="nondim", default=omega_frac_dflt) + call get_param(param_file, mdl, "ML_RESORT", CS%ML_resort, & + "If true, resort the topmost layers by potential density "//& + "before the mixed layer calculations.", default=.false.) + if (CS%ML_resort) & + call get_param(param_file, mdl, "ML_PRESORT_NK_CONV_ADJ", CS%ML_presort_nz_conv_adj, & + "Convectively mix the first ML_PRESORT_NK_CONV_ADJ "//& + "layers before sorting when ML_RESORT is true.", & + units="nondim", default=0, fail_if_missing=.true.) ! Fail added by AJA. + ! This gives a minimum decay scale that is typically much less than Angstrom. + ustar_min_dflt = 2e-4*CS%omega*(GV%Angstrom_Z + GV%dZ_subroundoff) + call get_param(param_file, mdl, "BML_USTAR_MIN", CS%ustar_min, & + "The minimum value of ustar that should be used by the "//& + "bulk mixed layer model in setting vertical TKE decay "//& + "scales. This must be greater than 0.", & + units="m s-1", default=US%Z_to_m*US%s_to_T*ustar_min_dflt, scale=US%m_to_Z*US%T_to_s) + if (CS%ustar_min<=0.0) call MOM_error(FATAL, "BML_USTAR_MIN must be positive.") + + call get_param(param_file, mdl, "BML_NONBOUSINESQ", CS%nonBous_energetics, & + "If true, use non-Boussinesq expressions for the energetic calculations "//& + "used in the bulk mixed layer calculations.", & + default=.not.(GV%Boussinesq.or.GV%semi_Boussinesq)) + + call get_param(param_file, mdl, "RESOLVE_EKMAN", CS%Resolve_Ekman, & + "If true, the NKML>1 layers in the mixed layer are "//& + "chosen to optimally represent the impact of the Ekman "//& + "transport on the mixed layer TKE budget. Otherwise, "//& + "the sublayers are distributed uniformly through the "//& + "mixed layer.", default=.false.) + call get_param(param_file, mdl, "CORRECT_ABSORPTION_DEPTH", CS%correct_absorption, & + "If true, the average depth at which penetrating shortwave "//& + "radiation is absorbed is adjusted to match the average "//& + "heating depth of an exponential profile by moving some "//& + "of the heating upward in the water column.", default=.false.) + call get_param(param_file, mdl, "DO_RIVERMIX", CS%do_rivermix, & + "If true, apply additional mixing wherever there is "//& + "runoff, so that it is mixed down to RIVERMIX_DEPTH, "//& + "if the ocean is that deep.", default=.false.) + if (CS%do_rivermix) & + call get_param(param_file, mdl, "RIVERMIX_DEPTH", CS%rivermix_depth, & + "The depth to which rivers are mixed if DO_RIVERMIX is "//& + "defined.", units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "USE_RIVER_HEAT_CONTENT", CS%use_river_heat_content, & + "If true, use the fluxes%runoff_Hflx field to set the "//& + "heat carried by runoff, instead of using SST*CP*liq_runoff.", & + default=.false.) + call get_param(param_file, mdl, "USE_CALVING_HEAT_CONTENT", CS%use_calving_heat_content, & + "If true, use the fluxes%calving_Hflx field to set the "//& + "heat carried by runoff, instead of using SST*CP*froz_runoff.", & + default=.false.) + call get_param(param_file, mdl, "BULKML_CONV_MOMENTUM_BUG", CS%convect_mom_bug, & + "If true, use code with a bug that causes a loss of momentum conservation "//& + "during mixedlayer convection.", default=.false.) + + CS%id_ML_depth = register_diag_field('ocean_model', 'h_ML', diag%axesT1, & + Time, 'Surface mixed layer depth', 'm', conversion=GV%H_to_m) + CS%id_TKE_wind = register_diag_field('ocean_model', 'TKE_wind', diag%axesT1, & + Time, 'Wind-stirring source of mixed layer TKE', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + CS%id_TKE_RiBulk = register_diag_field('ocean_model', 'TKE_RiBulk', diag%axesT1, & + Time, 'Mean kinetic energy source of mixed layer TKE', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + CS%id_TKE_conv = register_diag_field('ocean_model', 'TKE_conv', diag%axesT1, & + Time, 'Convective source of mixed layer TKE', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + CS%id_TKE_pen_SW = register_diag_field('ocean_model', 'TKE_pen_SW', diag%axesT1, & + Time, 'TKE consumed by mixing penetrative shortwave radation through the mixed layer', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + CS%id_TKE_mixing = register_diag_field('ocean_model', 'TKE_mixing', diag%axesT1, & + Time, 'TKE consumed by mixing that deepens the mixed layer', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + CS%id_TKE_mech_decay = register_diag_field('ocean_model', 'TKE_mech_decay', diag%axesT1, & + Time, 'Mechanical energy decay sink of mixed layer TKE', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + CS%id_TKE_conv_decay = register_diag_field('ocean_model', 'TKE_conv_decay', diag%axesT1, & + Time, 'Convective energy decay sink of mixed layer TKE', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + CS%id_TKE_conv_s2 = register_diag_field('ocean_model', 'TKE_conv_s2', diag%axesT1, & + Time, 'Spurious source of mixed layer TKE from sigma2', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + CS%id_PE_detrain = register_diag_field('ocean_model', 'PE_detrain', diag%axesT1, & + Time, 'Spurious source of potential energy from mixed layer detrainment', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + CS%id_PE_detrain2 = register_diag_field('ocean_model', 'PE_detrain2', diag%axesT1, & + Time, 'Spurious source of potential energy from mixed layer only detrainment', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + CS%id_h_mismatch = register_diag_field('ocean_model', 'h_miss_ML', diag%axesT1, & + Time, 'Summed absolute mismatch in entrainment terms', 'm', conversion=GV%H_to_m) + CS%id_Hsfc_used = register_diag_field('ocean_model', 'Hs_used', diag%axesT1, & + Time, 'Surface region thickness that is used', 'm', conversion=GV%H_to_m) + CS%id_Hsfc_max = register_diag_field('ocean_model', 'Hs_max', diag%axesT1, & + Time, 'Maximum surface region thickness', 'm', conversion=GV%H_to_m) + CS%id_Hsfc_min = register_diag_field('ocean_model', 'Hs_min', diag%axesT1, & + Time, 'Minimum surface region thickness', 'm', conversion=GV%H_to_m) + !CS%lim_det_dH_sfc = 0.5 ; CS%lim_det_dH_bathy = 0.2 ! Technically these should not get used if limit_det is false? + if (CS%limit_det .or. (CS%id_Hsfc_min > 0)) then + call get_param(param_file, mdl, "LIMIT_BUFFER_DET_DH_SFC", CS%lim_det_dH_sfc, & + "The fractional limit in the change between grid points "//& + "of the surface region (mixed & buffer layer) thickness.", & + units="nondim", default=0.5) + call get_param(param_file, mdl, "LIMIT_BUFFER_DET_DH_BATHY", CS%lim_det_dH_bathy, & + "The fraction of the total depth by which the thickness "//& + "of the surface region (mixed & buffer layer) is allowed "//& + "to change between grid points.", units="nondim", default=0.2) + endif + + call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & + "If true, temperature and salinity are used as state "//& + "variables.", default=.true.) + CS%nsw = 0 + if (use_temperature) then + call get_param(param_file, mdl, "PEN_SW_NBANDS", CS%nsw, default=1) + endif + + + if (max(CS%id_TKE_wind, CS%id_TKE_RiBulk, CS%id_TKE_conv, CS%id_TKE_mixing, & + CS%id_TKE_pen_SW, CS%id_TKE_mech_decay, CS%id_TKE_conv_decay) > 0) then + call safe_alloc_alloc(CS%diag_TKE_wind, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_RiBulk, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_conv, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_pen_SW, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_mixing, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_mech_decay, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_conv_decay, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_conv_s2, isd, ied, jsd, jed) + + CS%TKE_diagnostics = .true. + endif + if (CS%id_PE_detrain > 0) call safe_alloc_alloc(CS%diag_PE_detrain, isd, ied, jsd, jed) + if (CS%id_PE_detrain2 > 0) call safe_alloc_alloc(CS%diag_PE_detrain2, isd, ied, jsd, jed) + if (CS%id_ML_depth > 0) call safe_alloc_alloc(CS%ML_depth, isd, ied, jsd, jed) + + if (CS%limit_det .or. (CS%id_Hsfc_min > 0)) & + id_clock_pass = cpu_clock_id('(Ocean mixed layer halo updates)', grain=CLOCK_ROUTINE) + +end subroutine bulkmixedlayer_init + +!> This subroutine returns an approximation to the integral +!! R = exp(-L*(H+E)) integral(LH to L(H+E)) L/(1-(1+x)exp(-x)) dx. +!! The approximation to the integrand is good to within -2% at x~.3 +!! and +25% at x~3.5, but the exponential deemphasizes the importance of +!! large x. When L=0, EF4 returns E/((Ht+E)*Ht). +function EF4(Ht, En, I_L, dR_de) + real, intent(in) :: Ht !< Total thickness [H ~> m or kg m-2]. + real, intent(in) :: En !< Entrainment [H ~> m or kg m-2]. + real, intent(in) :: I_L !< The e-folding scale [H-1 ~> m-1 or m2 kg-1] + real, optional, intent(inout) :: dR_de !< The partial derivative of the result R with E [H-2 ~> m-2 or m4 kg-2]. + real :: EF4 !< The integral [H-1 ~> m-1 or m2 kg-1]. + + ! Local variables + real :: exp_LHpE ! A nondimensional exponential decay [nondim]. + real :: I_HpE ! An inverse thickness plus entrainment [H-1 ~> m-1 or m2 kg-1]. + real :: Res ! The result of the integral above [H-1 ~> m-1 or m2 kg-1]. + + exp_LHpE = exp(-I_L*(En+Ht)) + I_HpE = 1.0/(Ht+En) + Res = exp_LHpE * (En*I_HpE/Ht - 0.5*I_L*log(Ht*I_HpE) + 0.5*I_L*I_L*En) + if (PRESENT(dR_de)) & + dR_de = -I_L*Res + exp_LHpE*(I_HpE*I_HpE + 0.5*I_L*I_HpE + 0.5*I_L*I_L) + EF4 = Res + +end function EF4 + +!> \namespace mom_bulk_mixed_layer +!! +!! By Robert Hallberg, 1997 - 2005. +!! +!! This file contains the subroutine (bulkmixedlayer) that +!! implements a Kraus-Turner-like bulk mixed layer, based on the work +!! of various people, as described in the review paper by \cite Niiler1977, +!! with particular attention to the form proposed by \cite Oberhuber1993, +!! with an extension to a refined bulk mixed layer as described in +!! Hallberg (\cite muller2003). The physical processes portrayed in +!! this subroutine include convective adjustment and mixed layer entrainment +!! and detrainment. Penetrating shortwave radiation and an exponential decay +!! of TKE fluxes are also supported by this subroutine. Several constants +!! can alternately be set to give a traditional Kraus-Turner mixed +!! layer scheme, although that is not the preferred option. The +!! physical processes and arguments are described in detail in \ref BML. + +end module MOM_bulk_mixed_layer diff --git a/parameterizations/vertical/MOM_diabatic_aux.F90 b/parameterizations/vertical/MOM_diabatic_aux.F90 new file mode 100644 index 0000000000..1ba5aef392 --- /dev/null +++ b/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -0,0 +1,1979 @@ +!> Provides functions for some diabatic processes such as fraxil, brine rejection, +!! tendency due to surface flux divergence. +module MOM_diabatic_aux + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_EOS, only : calculate_density, calculate_TFreeze, EOS_domain +use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density_derivs +use MOM_error_handler, only : MOM_error, FATAL, WARNING, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing, extractFluxes1d, forcing_SinglePointPrint +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init +use MOM_interpolate, only : external_field +use MOM_io, only : slasher +use MOM_opacity, only : set_opacity, opacity_CS, extract_optics_slice, extract_optics_fields +use MOM_opacity, only : optics_type, optics_nbands, absorbRemainingSW, sumSWoverBands +use MOM_tracer_flow_control, only : get_chl_from_model, tracer_flow_control_CS +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public diabatic_aux_init, diabatic_aux_end +public make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS, triDiagTS_Eulerian +public find_uv_at_h, applyBoundaryFluxesInOut, set_pen_shortwave +public diagnoseMLDbyEnergy, diagnoseMLDbyDensityDifference + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure for diabatic_aux +type, public :: diabatic_aux_CS ; private + logical :: do_rivermix = .false. !< Provide additional TKE to mix river runoff at the + !! river mouths to a depth of "rivermix_depth" + real :: rivermix_depth = 0.0 !< The depth to which rivers are mixed if do_rivermix = T [Z ~> m]. + real :: dSalt_frac_max !< An upper limit on the fraction of the salt in a layer that can be + !! lost to the net surface salt fluxes within a timestep [nondim] + logical :: reclaim_frazil !< If true, try to use any frazil heat deficit to + !! to cool the topmost layer down to the freezing + !! point. The default is true. + logical :: pressure_dependent_frazil !< If true, use a pressure dependent + !! freezing temperature when making frazil. The + !! default is false, which will be faster but is + !! inappropriate with ice-shelf cavities. + logical :: ignore_fluxes_over_land !< If true, the model does not check + !! if fluxes are applied over land points. This + !! flag must be used when the ocean is coupled with + !! sea ice and ice shelves and use_ePBL = true. + logical :: use_river_heat_content !< If true, assumes that ice-ocean boundary + !! has provided a river heat content. Otherwise, runoff + !! is added with a temperature of the local SST. + logical :: use_calving_heat_content !< If true, assumes that ice-ocean boundary + !! has provided a calving heat content. Otherwise, calving + !! is added with a temperature of the local SST. + logical :: var_pen_sw !< If true, use one of the CHL_A schemes to determine the + !! e-folding depth of incoming shortwave radiation. + type(external_field) :: sbc_chl !< A handle used in time interpolation of + !! chlorophyll read from a file. + logical :: chl_from_file !< If true, chl_a is read from a file. + logical :: do_brine_plume !< If true, insert salt flux below the surface according to + !! a parameterization by \cite Nguyen2009. + integer :: brine_plume_n !< The exponent in the brine plume parameterization. + real :: plume_strength !< Fraction of the available brine to take to the bottom of the mixed + !! layer [nondim]. + + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag !< Structure used to regulate timing of diagnostic output + + ! Diagnostic handles + integer :: id_createdH = -1 !< Diagnostic ID of mass added to avoid grounding + integer :: id_brine_lay = -1 !< Diagnostic ID of which layer receives the brine + integer :: id_penSW_diag = -1 !< Diagnostic ID of Penetrative shortwave heating (flux convergence) + integer :: id_penSWflux_diag = -1 !< Diagnostic ID of Penetrative shortwave flux + integer :: id_nonpenSW_diag = -1 !< Diagnostic ID of Non-penetrative shortwave heating + integer :: id_Chl = -1 !< Diagnostic ID of chlorophyll-A handles for opacity + + ! Optional diagnostic arrays + real, allocatable, dimension(:,:) :: createdH !< The amount of volume added in order to + !! avoid grounding [H T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: penSW_diag !< Heating in a layer from convergence of + !! penetrative SW [Q R Z T-1 ~> W m-2] + real, allocatable, dimension(:,:,:) :: penSWflux_diag !< Penetrative SW flux at base of grid + !! layer [Q R Z T-1 ~> W m-2] + real, allocatable, dimension(:,:) :: nonpenSW_diag !< Non-downwelling SW radiation at ocean + !! surface [Q R Z T-1 ~> W m-2] + +end type diabatic_aux_CS + +!>@{ CPU time clock IDs +integer :: id_clock_uv_at_h, id_clock_frazil +!>@} + +contains + +!> Frazil formation keeps the temperature above the freezing point. +!! This subroutine warms any water that is colder than the (currently +!! surface) freezing point up to the freezing point and accumulates +!! the required heat (in [Q R Z ~> J m-2]) in tv%frazil. +subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous + !! call to diabatic_aux_init. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa]. + integer, optional, intent(in) :: halo !< Halo width over which to calculate frazil + + ! Local variables + real, dimension(SZI_(G)) :: & + fraz_col, & ! The accumulated heat requirement due to frazil [Q R Z ~> J m-2]. + T_freeze, & ! The freezing potential temperature at the current salinity [C ~> degC]. + ps ! Surface pressure [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZK_(GV)) :: & + pressure ! The pressure at the middle of each layer [R L2 T-2 ~> Pa]. + real :: H_to_RL2_T2 ! A conversion factor from thicknesses in H to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] + real :: hc ! A layer's heat capacity [Q R Z C-1 ~> J m-2 degC-1]. + logical :: T_fr_set ! True if the freezing point has been calculated for a + ! row of points. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (present(halo)) then + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + endif + + call cpu_clock_begin(id_clock_frazil) + + if (.not.CS%pressure_dependent_frazil) then + do k=1,nz ; do i=is,ie ; pressure(i,k) = 0.0 ; enddo ; enddo + else + H_to_RL2_T2 = GV%H_to_RZ * GV%g_Earth + endif + !$OMP parallel do default(shared) private(fraz_col,T_fr_set,T_freeze,hc,ps) & + !$OMP firstprivate(pressure) ! pressure might be set above, so should be firstprivate + do j=js,je + ps(:) = 0.0 + if (PRESENT(p_surf)) then ; do i=is,ie + ps(i) = p_surf(i,j) + enddo ; endif + + do i=is,ie ; fraz_col(i) = 0.0 ; enddo + + if (CS%pressure_dependent_frazil) then + do i=is,ie + pressure(i,1) = ps(i) + (0.5*H_to_RL2_T2)*h(i,j,1) + enddo + do k=2,nz ; do i=is,ie + pressure(i,k) = pressure(i,k-1) + (0.5*H_to_RL2_T2) * (h(i,j,k) + h(i,j,k-1)) + enddo ; enddo + endif + + if (CS%reclaim_frazil) then + T_fr_set = .false. + do i=is,ie ; if (tv%frazil(i,j) > 0.0) then + if (.not.T_fr_set) then + call calculate_TFreeze(tv%S(i:ie,j,1), pressure(i:ie,1), T_freeze(i:ie), & + tv%eqn_of_state) + T_fr_set = .true. + endif + + if (tv%T(i,j,1) > T_freeze(i)) then + ! If frazil had previously been formed, but the surface temperature is now + ! above freezing, cool the surface layer with the frazil heat deficit. + hc = (tv%C_p*GV%H_to_RZ) * h(i,j,1) + if (tv%frazil(i,j) - hc * (tv%T(i,j,1) - T_freeze(i)) <= 0.0) then + tv%T(i,j,1) = tv%T(i,j,1) - tv%frazil(i,j) / hc + tv%frazil(i,j) = 0.0 + else + tv%frazil(i,j) = tv%frazil(i,j) - hc * (tv%T(i,j,1) - T_freeze(i)) + tv%T(i,j,1) = T_freeze(i) + endif + endif + endif ; enddo + endif + + do k=nz,1,-1 + T_fr_set = .false. + do i=is,ie + if ((G%mask2dT(i,j) > 0.0) .and. & + ((tv%T(i,j,k) < 0.0) .or. (fraz_col(i) > 0.0))) then + if (.not.T_fr_set) then + call calculate_TFreeze(tv%S(i:ie,j,k), pressure(i:ie,k), T_freeze(i:ie), & + tv%eqn_of_state) + T_fr_set = .true. + endif + + hc = (tv%C_p*GV%H_to_RZ) * h(i,j,k) + if (h(i,j,k) <= 10.0*(GV%Angstrom_H + GV%H_subroundoff)) then + ! Very thin layers should not be cooled by the frazil flux. + if (tv%T(i,j,k) < T_freeze(i)) then + fraz_col(i) = fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) + tv%T(i,j,k) = T_freeze(i) + endif + elseif ((fraz_col(i) > 0.0) .or. (tv%T(i,j,k) < T_freeze(i))) then + if (fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) < 0.0) then + tv%T(i,j,k) = tv%T(i,j,k) - fraz_col(i) / hc + fraz_col(i) = 0.0 + else + fraz_col(i) = fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) + tv%T(i,j,k) = T_freeze(i) + endif + endif + endif + enddo + enddo + do i=is,ie + tv%frazil(i,j) = tv%frazil(i,j) + fraz_col(i) + enddo + enddo + call cpu_clock_end(id_clock_frazil) + +end subroutine make_frazil + +!> This subroutine applies double diffusion to T & S, assuming no diapycnal mass +!! fluxes, using a simple tridiagonal solver. +subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: T !< Potential temperature [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: S !< Salinity [PSU] or [gSalt/kg], generically [S ~> ppt]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(in) :: Kd_T !< The extra diffusivity of temperature due to + !! double diffusion relative to the diffusivity of + !! density [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(in) :: Kd_S !< The extra diffusivity of salinity due to + !! double diffusion relative to the diffusivity of + !! density [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, intent(in) :: dt !< Time increment [T ~> s]. + + ! local variables + real, dimension(SZI_(G)) :: & + b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S [H ~> m or kg m-2]. + d1_T, d1_S ! Variables used by the tridiagonal solvers [nondim]. + real, dimension(SZI_(G),SZK_(GV)) :: & + dz, & ! Height change across layers [Z ~> m] + c1_T, c1_S ! Variables used by the tridiagonal solvers [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)+1) :: & + mix_T, mix_S ! Mixing distances in both directions across each interface [H ~> m or kg m-2]. + real :: h_tr ! h_tr is h at tracer points with a tiny thickness + ! added to ensure positive definiteness [H ~> m or kg m-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + real :: I_dz_int ! The inverse of the height scale associated with an interface [Z-1 ~> m-1]. + real :: b_denom_T ! The first term in the denominator for the expression for b1_T [H ~> m or kg m-2]. + real :: b_denom_S ! The first term in the denominator for the expression for b1_S [H ~> m or kg m-2]. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff + + !$OMP parallel do default(private) shared(is,ie,js,je,h,h_neglect,dt,Kd_T,Kd_S,G,GV,T,S,nz) + do j=js,je + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + do i=is,ie + I_dz_int = 1.0 / (0.5 * (dz(i,1) + dz(i,2)) + dz_neglect) + mix_T(i,2) = (dt * Kd_T(i,j,2)) * I_dz_int + mix_S(i,2) = (dt * Kd_S(i,j,2)) * I_dz_int + + h_tr = h(i,j,1) + h_neglect + b1_T(i) = 1.0 / (h_tr + mix_T(i,2)) + b1_S(i) = 1.0 / (h_tr + mix_S(i,2)) + d1_T(i) = h_tr * b1_T(i) + d1_S(i) = h_tr * b1_S(i) + T(i,j,1) = (b1_T(i)*h_tr)*T(i,j,1) + S(i,j,1) = (b1_S(i)*h_tr)*S(i,j,1) + enddo + do k=2,nz-1 ; do i=is,ie + ! Calculate the mixing across the interface below this layer. + I_dz_int = 1.0 / (0.5 * (dz(i,k) + dz(i,k+1)) + dz_neglect) + mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1))) * I_dz_int + mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1))) * I_dz_int + + c1_T(i,k) = mix_T(i,K) * b1_T(i) + c1_S(i,k) = mix_S(i,K) * b1_S(i) + + h_tr = h(i,j,k) + h_neglect + b_denom_T = h_tr + d1_T(i)*mix_T(i,K) + b_denom_S = h_tr + d1_S(i)*mix_S(i,K) + b1_T(i) = 1.0 / (b_denom_T + mix_T(i,K+1)) + b1_S(i) = 1.0 / (b_denom_S + mix_S(i,K+1)) + d1_T(i) = b_denom_T * b1_T(i) + d1_S(i) = b_denom_S * b1_S(i) + + T(i,j,k) = b1_T(i) * (h_tr*T(i,j,k) + mix_T(i,K)*T(i,j,k-1)) + S(i,j,k) = b1_S(i) * (h_tr*S(i,j,k) + mix_S(i,K)*S(i,j,k-1)) + enddo ; enddo + do i=is,ie + c1_T(i,nz) = mix_T(i,nz) * b1_T(i) + c1_S(i,nz) = mix_S(i,nz) * b1_S(i) + + h_tr = h(i,j,nz) + h_neglect + b1_T(i) = 1.0 / (h_tr + d1_T(i)*mix_T(i,nz)) + b1_S(i) = 1.0 / (h_tr + d1_S(i)*mix_S(i,nz)) + + T(i,j,nz) = b1_T(i) * (h_tr*T(i,j,nz) + mix_T(i,nz)*T(i,j,nz-1)) + S(i,j,nz) = b1_S(i) * (h_tr*S(i,j,nz) + mix_S(i,nz)*S(i,j,nz-1)) + enddo + do k=nz-1,1,-1 ; do i=is,ie + T(i,j,k) = T(i,j,k) + c1_T(i,k+1)*T(i,j,k+1) + S(i,j,k) = S(i,j,k) + c1_S(i,k+1)*S(i,j,k+1) + enddo ; enddo + enddo +end subroutine differential_diffuse_T_S + +!> This subroutine keeps salinity from falling below a small but positive threshold. +!! This usually occurs when the ice model attempts to extract more salt then +!! is actually available to it from the ocean. +subroutine adjust_salt(h, tv, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous + !! call to diabatic_aux_init. + + ! local variables + real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement [S R Z ~> gSalt m-2] + real :: S_min !< The minimum salinity [S ~> ppt]. + real :: mc !< A layer's mass [R Z ~> kg m-2]. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + +! call cpu_clock_begin(id_clock_adjust_salt) + + S_min = tv%min_salinity + + salt_add_col(:,:) = 0.0 + + !$OMP parallel do default(shared) private(mc) + do j=js,je + do k=nz,1,-1 ; do i=is,ie + if ( (G%mask2dT(i,j) > 0.0) .and. & + ((tv%S(i,j,k) < S_min) .or. (salt_add_col(i,j) > 0.0)) ) then + mc = GV%H_to_RZ * h(i,j,k) + if (h(i,j,k) <= 10.0*GV%Angstrom_H) then + ! Very thin layers should not be adjusted by the salt flux + if (tv%S(i,j,k) < S_min) then + salt_add_col(i,j) = salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) + tv%S(i,j,k) = S_min + endif + elseif (salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) <= 0.0) then + tv%S(i,j,k) = tv%S(i,j,k) - salt_add_col(i,j) / mc + salt_add_col(i,j) = 0.0 + else + salt_add_col(i,j) = salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) + tv%S(i,j,k) = S_min + endif + endif + enddo ; enddo + do i=is,ie + tv%salt_deficit(i,j) = tv%salt_deficit(i,j) + salt_add_col(i,j) + enddo + enddo +! call cpu_clock_end(id_clock_adjust_salt) + +end subroutine adjust_salt + +!> This is a simple tri-diagonal solver for T and S. +!! "Simple" means it only uses arrays hold, ea and eb. +subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: is !< The start i-index to work on. + integer, intent(in) :: ie !< The end i-index to work on. + integer, intent(in) :: js !< The start j-index to work on. + integer, intent(in) :: je !< The end j-index to work on. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: hold !< The layer thicknesses before entrainment, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: ea !< The amount of fluid entrained from the layer + !! above within this time step [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: eb !< The amount of fluid entrained from the layer + !! below within this time step [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: T !< Layer potential temperatures [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: S !< Layer salinities [S ~> ppt]. + + ! Local variables + real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: d1(SZIB_(G)) ! A variable used by the tridiagonal solver [nondim]. + real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. + real :: h_tr, b_denom_1 ! Two temporary thicknesses [H ~> m or kg m-2]. + integer :: i, j, k + + !$OMP parallel do default(shared) private(h_tr,b1,d1,c1,b_denom_1) + do j=js,je + do i=is,ie + h_tr = hold(i,j,1) + GV%H_subroundoff + b1(i) = 1.0 / (h_tr + eb(i,j,1)) + d1(i) = h_tr * b1(i) + T(i,j,1) = (b1(i)*h_tr)*T(i,j,1) + S(i,j,1) = (b1(i)*h_tr)*S(i,j,1) + enddo + do k=2,GV%ke ; do i=is,ie + c1(i,k) = eb(i,j,k-1) * b1(i) + h_tr = hold(i,j,k) + GV%H_subroundoff + b_denom_1 = h_tr + d1(i)*ea(i,j,k) + b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) + d1(i) = b_denom_1 * b1(i) + T(i,j,k) = b1(i) * (h_tr*T(i,j,k) + ea(i,j,k)*T(i,j,k-1)) + S(i,j,k) = b1(i) * (h_tr*S(i,j,k) + ea(i,j,k)*S(i,j,k-1)) + enddo ; enddo + do k=GV%ke-1,1,-1 ; do i=is,ie + T(i,j,k) = T(i,j,k) + c1(i,k+1)*T(i,j,k+1) + S(i,j,k) = S(i,j,k) + c1(i,k+1)*S(i,j,k+1) + enddo ; enddo + enddo +end subroutine triDiagTS + +!> This is a simple tri-diagonal solver for T and S, with mixing across interfaces but no net +!! transfer of mass. +subroutine triDiagTS_Eulerian(G, GV, is, ie, js, je, hold, ent, T, S) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: is !< The start i-index to work on. + integer, intent(in) :: ie !< The end i-index to work on. + integer, intent(in) :: js !< The start j-index to work on. + integer, intent(in) :: je !< The end j-index to work on. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: hold !< The layer thicknesses before entrainment, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: ent !< The amount of fluid mixed across an interface + !! within this time step [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: T !< Layer potential temperatures [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: S !< Layer salinities [S ~> ppt]. + + ! Local variables + real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: d1(SZIB_(G)) ! A variable used by the tridiagonal solver [nondim]. + real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. + real :: h_tr, b_denom_1 ! Two temporary thicknesses [H ~> m or kg m-2]. + integer :: i, j, k + + !$OMP parallel do default(shared) private(h_tr,b1,d1,c1,b_denom_1) + do j=js,je + do i=is,ie + h_tr = hold(i,j,1) + GV%H_subroundoff + b1(i) = 1.0 / (h_tr + ent(i,j,2)) + d1(i) = h_tr * b1(i) + T(i,j,1) = (b1(i)*h_tr)*T(i,j,1) + S(i,j,1) = (b1(i)*h_tr)*S(i,j,1) + enddo + do k=2,GV%ke ; do i=is,ie + c1(i,k) = ent(i,j,K) * b1(i) + h_tr = hold(i,j,k) + GV%H_subroundoff + b_denom_1 = h_tr + d1(i)*ent(i,j,K) + b1(i) = 1.0 / (b_denom_1 + ent(i,j,K+1)) + d1(i) = b_denom_1 * b1(i) + T(i,j,k) = b1(i) * (h_tr*T(i,j,k) + ent(i,j,K)*T(i,j,k-1)) + S(i,j,k) = b1(i) * (h_tr*S(i,j,k) + ent(i,j,K)*S(i,j,k-1)) + enddo ; enddo + do k=GV%ke-1,1,-1 ; do i=is,ie + T(i,j,k) = T(i,j,k) + c1(i,k+1)*T(i,j,k+1) + S(i,j,k) = S(i,j,k) + c1(i,k+1)*S(i,j,k+1) + enddo ; enddo + enddo +end subroutine triDiagTS_Eulerian + + +!> This subroutine calculates u_h and v_h (velocities at thickness +!! points), optionally using the entrainment amounts passed in as arguments. +subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: u_h !< Zonal velocity interpolated to h points [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: v_h !< Meridional velocity interpolated to h points [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: ea !< The amount of fluid entrained from the layer + !! above within this time step [H ~> m or kg m-2]. + !! Omitting ea is the same as setting it to 0. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: eb !< The amount of fluid entrained from the layer + !! below within this time step [H ~> m or kg m-2]. + !! Omitting eb is the same as setting it to 0. + logical, optional, intent(in) :: zero_mix !< If true, do the calculation of u_h and + !! v_h as though ea and eb were being supplied with + !! uniformly zero values. + + ! Local variables + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: b1(SZI_(G)) ! A thickness used in the tridiagonal solver [H ~> m or kg m-2] + real :: c1(SZI_(G),SZK_(GV)) ! A variable used in the tridiagonal solver [nondim] + real :: d1(SZI_(G)) ! The complement of c1 [nondim] + ! Fractional weights of the neighboring velocity points, ~1/2 in the open ocean. + real :: a_n(SZI_(G)), a_s(SZI_(G)) ! Fractional weights of the neighboring velocity points [nondim] + real :: a_e(SZI_(G)), a_w(SZI_(G)) ! Fractional weights of the neighboring velocity points [nondim] + real :: sum_area ! A sum of adjacent areas [L2 ~> m2] + real :: Idenom ! The inverse of the denominator in a weighted average [L-2 ~> m-2] + logical :: mix_vertically, zero_mixing + integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + call cpu_clock_begin(id_clock_uv_at_h) + h_neglect = GV%H_subroundoff + + mix_vertically = present(ea) + if (present(ea) .neqv. present(eb)) call MOM_error(FATAL, & + "find_uv_at_h: Either both ea and eb or neither one must be present "// & + "in call to find_uv_at_h.") + zero_mixing = .false. ; if (present(zero_mix)) zero_mixing = zero_mix + if (zero_mixing) mix_vertically = .false. + !$OMP parallel do default(none) shared(is,ie,js,je,G,GV,mix_vertically,zero_mixing,h, & + !$OMP h_neglect,ea,eb,u_h,u,v_h,v,nz) & + !$OMP private(sum_area,Idenom,a_w,a_e,a_s,a_n,b_denom_1,b1,d1,c1) + 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 this were a simple area weighted average, this would just be I_denom = 1.0 / sum_area. + ! The other factor of sqrt(0.5*sum_area*G%IareaT(i,j)) is 1 for open ocean points on a + ! Cartesian grid. This construct predates the initial commit of the MOM6 code, and was + ! present in the GOLD code before February, 2010. I do not recall why this was added, and + ! the GOLD CVS server that contained the relevant history and logs appears to have been + ! decommissioned. + 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 + else + a_w(i) = 0.0 ; a_e(i) = 0.0 + endif + + sum_area = G%areaCv(i,J-1) + G%areaCv(i,J) + 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 + else + a_s(i) = 0.0 ; a_n(i) = 0.0 + endif + enddo + + if (mix_vertically) then + do i=is,ie + b_denom_1 = h(i,j,1) + h_neglect + b1(i) = 1.0 / (b_denom_1 + eb(i,j,1)) + d1(i) = b_denom_1 * b1(i) + u_h(i,j,1) = (h(i,j,1)*b1(i)) * (a_e(i)*u(I,j,1) + a_w(i)*u(I-1,j,1)) + v_h(i,j,1) = (h(i,j,1)*b1(i)) * (a_n(i)*v(i,J,1) + a_s(i)*v(i,J-1,1)) + enddo + do k=2,nz ; do i=is,ie + c1(i,k) = eb(i,j,k-1) * b1(i) + b_denom_1 = h(i,j,k) + d1(i)*ea(i,j,k) + h_neglect + b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) + d1(i) = b_denom_1 * b1(i) + u_h(i,j,k) = (h(i,j,k) * (a_e(i)*u(I,j,k) + a_w(i)*u(I-1,j,k)) + & + ea(i,j,k)*u_h(i,j,k-1))*b1(i) + v_h(i,j,k) = (h(i,j,k) * (a_n(i)*v(i,J,k) + a_s(i)*v(i,J-1,k)) + & + ea(i,j,k)*v_h(i,j,k-1))*b1(i) + enddo ; enddo + do k=nz-1,1,-1 ; do i=is,ie + u_h(i,j,k) = u_h(i,j,k) + c1(i,k+1)*u_h(i,j,k+1) + v_h(i,j,k) = v_h(i,j,k) + c1(i,k+1)*v_h(i,j,k+1) + enddo ; enddo + elseif (zero_mixing) then + do i=is,ie + b1(i) = 1.0 / (h(i,j,1) + h_neglect) + u_h(i,j,1) = (h(i,j,1)*b1(i)) * (a_e(i)*u(I,j,1) + a_w(i)*u(I-1,j,1)) + v_h(i,j,1) = (h(i,j,1)*b1(i)) * (a_n(i)*v(i,J,1) + a_s(i)*v(i,J-1,1)) + enddo + do k=2,nz ; do i=is,ie + b1(i) = 1.0 / (h(i,j,k) + h_neglect) + u_h(i,j,k) = (h(i,j,k) * (a_e(i)*u(I,j,k) + a_w(i)*u(I-1,j,k))) * b1(i) + v_h(i,j,k) = (h(i,j,k) * (a_n(i)*v(i,J,k) + a_s(i)*v(i,J-1,k))) * b1(i) + enddo ; enddo + else + do k=1,nz ; do i=is,ie + u_h(i,j,k) = a_e(i)*u(I,j,k) + a_w(i)*u(I-1,j,k) + v_h(i,j,k) = a_n(i)*v(i,J,k) + a_s(i)*v(i,J-1,k) + enddo ; enddo + endif + enddo + + call cpu_clock_end(id_clock_uv_at_h) +end subroutine find_uv_at_h + +!> Estimate the optical properties of the water column and determine the penetrating shortwave +!! radiation by band, extracting the relevant information from the fluxes type and storing it +!! in the optics type for later application. This routine is effectively a wrapper for +!! set_opacity with added error handling and diagnostics. +subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow_CSp) + type(optics_type), pointer :: optics !< An optics structure that has will contain + !! information about shortwave fluxes and absorption. + type(forcing), intent(inout) :: fluxes !< points to forcing fields + !! unused fields have NULL pointers + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diabatic_aux_CS), pointer :: CS !< Control structure for diabatic_aux + type(opacity_CS) :: opacity !< The control structure for the opacity module. + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< A pointer to the control structure + !! organizing the tracer modules. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: chl_2d !< Vertically uniform chlorophyll-A concentrations [mg m-3] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: chl_3d !< The chlorophyll-A concentrations of each layer [mg m-3] + character(len=128) :: mesg + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if (.not.associated(optics)) return + + if (CS%var_pen_sw) then + if (CS%chl_from_file) then + ! Only the 2-d surface chlorophyll can be read in from a file. The + ! same value is assumed for all layers. + call time_interp_external(CS%sbc_chl, CS%Time, chl_2d, turns=G%HI%turns) + do j=js,je ; do i=is,ie + 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) + call MOM_error(FATAL, "MOM_diabatic_aux set_pen_shortwave: "//trim(mesg)) + endif + enddo ; enddo + + if (CS%id_chl > 0) call post_data(CS%id_chl, chl_2d, CS%diag) + + call set_opacity(optics, fluxes%sw, fluxes%sw_vis_dir, fluxes%sw_vis_dif, & + fluxes%sw_nir_dir, fluxes%sw_nir_dif, G, GV, US, opacity, chl_2d=chl_2d) + else + if (.not.associated(tracer_flow_CSp)) call MOM_error(FATAL, & + "The tracer flow control structure must be associated when the model sets "//& + "the chlorophyll internally in set_pen_shortwave.") + call get_chl_from_model(chl_3d, G, GV, tracer_flow_CSp) + + if (CS%id_chl > 0) call post_data(CS%id_chl, chl_3d(:,:,1), CS%diag) + + call set_opacity(optics, fluxes%sw, fluxes%sw_vis_dir, fluxes%sw_vis_dif, & + fluxes%sw_nir_dir, fluxes%sw_nir_dif, G, GV, US, opacity, chl_3d=chl_3d) + endif + else + call set_opacity(optics, fluxes%sw, fluxes%sw_vis_dir, fluxes%sw_vis_dif, & + fluxes%sw_nir_dir, fluxes%sw_nir_dif, G, GV, US, opacity) + endif + +end subroutine set_pen_shortwave + + +!> Diagnose a mixed layer depth (MLD) determined by a given density difference with the surface. +!> This routine is appropriate in MOM_diabatic_aux due to its position within the time stepping. +subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, & + id_N2subML, id_MLDsq, dz_subML) + type(ocean_grid_type), intent(in) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: id_MLD !< Handle (ID) of MLD diagnostic + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, intent(in) :: densityDiff !< Density difference to determine MLD [R ~> kg m-3] + type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure + integer, optional, intent(in) :: id_N2subML !< Optional handle (ID) of subML stratification + integer, optional, intent(in) :: id_MLDsq !< Optional handle (ID) of squared MLD + real, optional, intent(in) :: dz_subML !< The distance over which to calculate N2subML + !! or 50 m if missing [Z ~> m] + + ! Local variables + real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. + real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m or kg m-2] + real, dimension(SZI_(G)) :: dZ_N2 ! Summed vertical distance used in N2 calculation [Z ~> m] + real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [C ~> degC]. + real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [S ~> ppt]. + real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)) :: dZ_2d ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G)) :: dZ, dZm1 ! Layer thicknesses associated with interfaces [Z ~> m] + real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixed layer depth [R ~> kg m-3]. + real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. + real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [T-2 ~> s-2]. + real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. + logical, dimension(SZI_(G)) :: N2_region_set ! If true, all necessary values for calculating N2 + ! have been stored already. + real :: gE_Rho0 ! The gravitational acceleration, sometimes divided by the Boussinesq + ! reference density [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. + real :: dZ_sub_ML ! Depth below ML over which to diagnose stratification [Z ~> m] + real :: aFac ! A nondimensional factor [nondim] + real :: ddRho ! A density difference [R ~> kg m-3] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ + + id_SQ = -1 ; if (PRESENT(id_MLDsq)) id_SQ = id_MLDsq + + id_N2 = -1 + if (present(id_N2subML)) then + if (present(dz_subML)) then + id_N2 = id_N2subML + dZ_sub_ML = dz_subML + else + call MOM_error(FATAL, "When the diagnostic of the subML stratification is "//& + "requested by providing id_N2_subML to diagnoseMLDbyDensityDifference, "//& + "the distance over which to calculate that distance must also be provided.") + endif + endif + + gE_rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%H_to_RZ + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + pRef_MLD(:) = 0.0 + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dZ_2d, j, G, GV) + + do i=is,ie ; dZ(i) = 0.5 * dZ_2d(i,1) ; enddo ! Depth of center of surface layer + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) + do i=is,ie + deltaRhoAtK(i) = 0. + MLD(i,j) = 0. + if (id_N2>0) then + subMLN2(i,j) = 0.0 + H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 + T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 + N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. + endif + enddo + do k=2,nz + do i=is,ie + dZm1(i) = dZ(i) ! Depth of center of layer K-1 + dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K + enddo + + ! Prepare to calculate stratification, N2, immediately below the mixed layer by finding + ! the cells that extend over at least dz_subML. + if (id_N2>0) then + do i=is,ie + if (MLD(i,j) == 0.0) then ! Still in the mixed layer. + H_subML(i) = H_subML(i) + h(i,j,k) + elseif (.not.N2_region_set(i)) then ! This block is below the mixed layer, but N2 has not been found yet. + if (dZ_N2(i) == 0.0) then ! Record the temperature, salinity, pressure, immediately below the ML + T_subML(i) = tv%T(i,j,k) ; S_subML(i) = tv%S(i,j,k) + H_subML(i) = H_subML(i) + 0.5 * h(i,j,k) ! Start midway through this layer. + dH_N2(i) = 0.5 * h(i,j,k) + dZ_N2(i) = 0.5 * dz_2d(i,k) + elseif (dZ_N2(i) + dZ_2d(i,k) < dZ_sub_ML) then + dH_N2(i) = dH_N2(i) + h(i,j,k) + dZ_N2(i) = dZ_N2(i) + dz_2d(i,k) + else ! This layer includes the base of the region where N2 is calculated. + T_deeper(i) = tv%T(i,j,k) ; S_deeper(i) = tv%S(i,j,k) + dH_N2(i) = dH_N2(i) + 0.5 * h(i,j,k) + dZ_N2(i) = dZ_N2(i) + 0.5 * dz_2d(i,k) + N2_region_set(i) = .true. + endif + endif + enddo ! i-loop + endif ! id_N2>0 + + ! Mixed-layer depth, using sigma-0 (surface reference pressure) + do i=is,ie ; deltaRhoAtKm1(i) = deltaRhoAtK(i) ; enddo ! Store value from previous iteration of K + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) + do i = is, ie + deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface + ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) + if ((MLD(i,j) == 0.) .and. (ddRho > 0.) .and. & + (deltaRhoAtKm1(i) < densityDiff) .and. (deltaRhoAtK(i) >= densityDiff)) then + aFac = ( densityDiff - deltaRhoAtKm1(i) ) / ddRho + MLD(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) + endif + if (id_SQ > 0) MLD2(i,j) = MLD(i,j)**2 + enddo ! i-loop + enddo ! k-loop + do i=is,ie + if ((MLD(i,j) == 0.) .and. (deltaRhoAtK(i) < densityDiff)) MLD(i,j) = dZ(i) ! Mixing goes to the bottom + enddo + + if (id_N2>0) then ! Now actually calculate stratification, N2, below the mixed layer. + do i=is,ie ; pRef_N2(i) = (GV%g_Earth * GV%H_to_RZ) * (H_subML(i) + 0.5*dH_N2(i)) ; enddo + ! if ((.not.N2_region_set(i)) .and. (dZ_N2(i) > 0.5*dZ_sub_ML)) then + ! ! Use whatever stratification we can, measured over whatever distance is available? + ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) + ! N2_region_set(i) = .true. + ! 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.0) .and. N2_region_set(i)) then + subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / dH_N2(i) + endif ; enddo + endif + enddo ! j-loop + + if (id_MLD > 0) call post_data(id_MLD, MLD, diagPtr) + if (id_N2 > 0) call post_data(id_N2, subMLN2, diagPtr) + if (id_SQ > 0) call post_data(id_SQ, MLD2, diagPtr) + +end subroutine diagnoseMLDbyDensityDifference + +!> Diagnose a mixed layer depth (MLD) determined by the depth a given energy value would mix. +!> This routine is appropriate in MOM_diabatic_aux due to its position within the time stepping. +subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) + ! Author: Brandon Reichl + ! Date: October 2, 2020 + ! // + ! *Note that gravity is assumed constant everywhere and divided out of all calculations. + ! + ! This code has been written to step through the columns layer by layer, summing the PE + ! change inferred by mixing the layer with all layers above. When the change exceeds a + ! threshold (determined by input array Mixing_Energy), the code needs to solve for how far + ! into this layer the threshold PE change occurs (assuming constant density layers). + ! This is expressed here via solving the function F(X) = 0 where: + ! F(X) = 0.5 * ( Ca*X^3/(D1+X) + Cb*X^2/(D1+X) + Cc*X/(D1+X) + Dc/(D1+X) + ! + Ca2*X^2 + Cb2*X + Cc2) + ! where all coefficients are determined by the previous mixed layer depth, the + ! density of the previous mixed layer, the present layer thickness, and the present + ! layer density. This equation is worked out by computing the total PE assuming constant + ! density in the mixed layer as well as in the remaining part of the present layer that is + ! not mixed. + ! To solve for X in this equation a Newton's method iteration is employed, which + ! converges extremely quickly (usually 1 guess) since this equation turns out to be rather + ! linear for PE change with increasing X. + ! Input parameters: + integer, dimension(3), intent(in) :: id_MLD !< Energy output diagnostic IDs + type(ocean_grid_type), intent(in) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(3), intent(in) :: Mixing_Energy !< Energy values for up to 3 MLDs [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),3) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. + real, dimension(SZK_(GV)+1) :: Z_int ! Depths of the interfaces from the surface [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: dZ ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: Rho_c ! Columns of layer densities [R ~> kg m-3] + real, dimension(SZI_(G)) :: pRef_MLD ! The reference pressure for the mixed layer + ! depth calculation [R L2 T-2 ~> Pa] + real, dimension(3) :: PE_threshold ! The energy threshold divided by g [R Z2 ~> kg m-1] + + real :: PE_Threshold_fraction ! The fractional tolerance of the specified energy + ! for the energy used to mix to the diagnosed depth [nondim] + real :: H_ML ! The accumulated depth of the mixed layer [Z ~> m] + real :: PE ! The cumulative potential energy of the unmixed water column to a depth + ! of H_ML, divided by the gravitational acceleration [R Z2 ~> kg m-1] + real :: PE_Mixed ! The potential energy of the completely mixed water column to a depth + ! of H_ML, divided by the gravitational acceleration [R Z2 ~> kg m-1] + real :: RhoDZ_ML ! The depth integrated density of the mixed layer [R Z ~> kg m-2] + real :: H_ML_TST ! A new test value for the depth of the mixed layer [Z ~> m] + real :: PE_Mixed_TST ! The potential energy of the completely mixed water column to a depth + ! of H_ML_TST, divided by the gravitational acceleration [R Z2 ~> kg m-1] + real :: RhoDZ_ML_TST ! A test value of the new depth integrated density of the mixed layer [R Z ~> kg m-2] + real :: Rho_ML ! The average density of the mixed layer [R ~> kg m-3] + + ! These are all temporary variables used to shorten the expressions in the iterations. + real :: R1, R2, Ca, Ca2 ! Some densities [R ~> kg m-3] + real :: D1, D2, X, X2 ! Some thicknesses [Z ~> m] + real :: Cb, Cb2 ! A depth integrated density [R Z ~> kg m-2] + real :: C, D ! A depth squared [Z2 ~> m2] + real :: Cc, Cc2 ! A density times a depth squared [R Z2 ~> kg m-1] + real :: Cd ! A density times a depth cubed [R Z3 ~> kg] + real :: Gx ! A triple integral in depth of density [R Z3 ~> kg] + real :: Gpx ! The derivative of Gx with x [R Z2 ~> kg m-1] + real :: Hx ! The vertical integral depth [Z ~> m] + real :: iHx ! The inverse of Hx [Z-1 ~> m-1] + real :: Hpx ! The derivative of Hx with x, hard coded to 1. Why? [nondim] + real :: Ix ! A double integral in depth of density [R Z2 ~> kg m-1] + real :: Ipx ! The derivative of Ix with x [R Z ~> kg m-2] + real :: Fgx ! The mixing energy difference from the target [R Z2 ~> kg m-1] + real :: Fpx ! The derivative of Fgx with x [R Z ~> kg m-2] + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: IT, iM + integer :: i, j, is, ie, js, je, k, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + pRef_MLD(:) = 0.0 + mld(:,:,:) = 0.0 + PE_Threshold_fraction = 1.e-4 !Fixed threshold of 0.01%, could be runtime. + + do iM=1,3 + PE_threshold(iM) = Mixing_Energy(iM) / (US%L_to_Z**2*GV%g_Earth) + enddo + + MLD(:,:,:) = 0.0 + + EOSdom(:) = EOS_domain(G%HI) + + do j=js,je + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + do k=1,nz + call calculate_density(tv%T(:,j,k), tv%S(:,j,K), pRef_MLD, rho_c(:,k), tv%eqn_of_state, EOSdom) + enddo + + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + + Z_int(1) = 0.0 + do k=1,nz + Z_int(K+1) = Z_int(K) - dZ(i,k) + enddo + + do iM=1,3 + + ! Initialize these for each column-wise calculation + PE = 0.0 + RhoDZ_ML = 0.0 + H_ML = 0.0 + RhoDZ_ML_TST = 0.0 + H_ML_TST = 0.0 + PE_Mixed = 0.0 + + do k=1,nz + + ! This is the unmixed PE cumulative sum from top down + PE = PE + 0.5 * Rho_c(i,k) * (Z_int(K)**2 - Z_int(K+1)**2) + + ! This is the depth and integral of density + H_ML_TST = H_ML + dZ(i,k) + RhoDZ_ML_TST = RhoDZ_ML + Rho_c(i,k) * dZ(i,k) + + ! The average density assuming all layers including this were mixed + Rho_ML = RhoDZ_ML_TST/H_ML_TST + + ! The PE assuming all layers including this were mixed + ! Note that 0. could be replaced with "Surface", which doesn't have to be 0 + ! but 0 is a good reference value. + PE_Mixed_TST = 0.5 * Rho_ML * (0.**2 - (0. - H_ML_TST)**2) + + ! Check if we supplied enough energy to mix to this layer + if (PE_Mixed_TST - PE <= PE_threshold(iM)) then + H_ML = H_ML_TST + RhoDZ_ML = RhoDZ_ML_TST + + else ! If not, we need to solve where the energy ran out + ! This will be done with a Newton's method iteration: + + R1 = RhoDZ_ML / H_ML ! The density of the mixed layer (not including this layer) + D1 = H_ML ! The thickness of the mixed layer (not including this layer) + R2 = Rho_c(i,k) ! The density of this layer + D2 = dZ(i,k) ! The thickness of this layer + + ! This block could be used to calculate the function coefficients if + ! we don't reference all values to a surface designated as z=0 + ! S = Surface + ! Ca = -(R2) + ! Cb = -( (R1*D1) + R2*(2.*D1-2.*S) ) + ! D = D1**2. - 2.*D1*S + ! Cc = -( R1*D1*(2.*D1-2.*S) + R2*D ) + ! Cd = -(R1*D1*D) + ! Ca2 = R2 + ! Cb2 = R2*(2*D1-2*S) + ! C = S**2 + D2**2 + D1**2 - 2*D1*S - 2.*D2*S +2.*D1*D2 + ! Cc2 = R2*(D+S**2-C) + ! + ! If the surface is S = 0, it simplifies to: + Ca = -R2 + Cb = -(R1 * D1 + R2 * (2. * D1)) + D = D1**2 + Cc = -(R1 * D1 * (2. * D1) + (R2 * D)) + Cd = -R1 * (D1 * D) + Ca2 = R2 + Cb2 = R2 * (2. * D1) + C = D2**2 + D1**2 + 2. * (D1 * D2) + Cc2 = R2 * (D - C) + + ! First guess for an iteration using Newton's method + X = dZ(i,k) * 0.5 + + IT=0 + do while(IT<10)!We can iterate up to 10 times + ! We are trying to solve the function: + ! F(x) = G(x)/H(x)+I(x) + ! for where F(x) = PE+PE_threshold, or equivalently for where + ! F(x) = G(x)/H(x)+I(x) - (PE+PE_threshold) = 0 + ! We also need the derivative of this function for the Newton's method iteration + ! F'(x) = (G'(x)H(x)-G(x)H'(x))/H(x)^2 + I'(x) + ! G and its derivative + Gx = 0.5 * (Ca * (X*X*X) + Cb * X**2 + Cc * X + Cd) + Gpx = 0.5 * (3. * (Ca * X**2) + 2. * (Cb * X) + Cc) + ! H, its inverse, and its derivative + Hx = D1 + X + iHx = 1. / Hx + Hpx = 1. + ! I and its derivative + Ix = 0.5 * (Ca2 * X**2 + Cb2 * X + Cc2) + Ipx = 0.5 * (2. * Ca2 * X + Cb2) + + ! The Function and its derivative: + PE_Mixed = Gx * iHx + Ix + Fgx = PE_Mixed - (PE + PE_threshold(iM)) + Fpx = (Gpx * Hx - Hpx * Gx) * iHx**2 + Ipx + + ! Check if our solution is within the threshold bounds, if not update + ! using Newton's method. This appears to converge almost always in + ! one step because the function is very close to linear in most applications. + if (abs(Fgx) > PE_Threshold(iM) * PE_Threshold_fraction) then + X2 = X - Fgx / Fpx + IT = IT + 1 + if (X2 < 0. .or. X2 > dZ(i,k)) then + ! The iteration seems to be robust, but we need to do something *if* + ! things go wrong... How should we treat failed iteration? + ! Present solution: Stop trying to compute and just say we can't mix this layer. + X=0 + exit + else + X = X2 + endif + else + exit! Quit the iteration + endif + enddo + H_ML = H_ML + X + exit! Quit looping through the column + endif + enddo + MLD(i,j,iM) = H_ML + enddo + endif ; enddo + enddo + + if (id_MLD(1) > 0) call post_data(id_MLD(1), MLD(:,:,1), diagPtr) + if (id_MLD(2) > 0) call post_data(id_MLD(2), MLD(:,:,2), diagPtr) + if (id_MLD(3) > 0) call post_data(id_MLD(3), MLD(:,:,3), diagPtr) + +end subroutine diagnoseMLDbyEnergy + +!> Update the thickness, temperature, and salinity due to thermodynamic +!! boundary forcing (contained in fluxes type) applied to h, tv%T and tv%S, +!! and calculate the TKE implications of this heating. +subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, tv, & + aggregate_FW_forcing, evap_CFL_limit, & + minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, & + SkinBuoyFlux, MLD) + type(diabatic_aux_CS), pointer :: CS !< Control structure for diabatic_aux + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: dt !< Time-step over which forcing is applied [T ~> s] + type(forcing), intent(inout) :: fluxes !< Surface fluxes container + type(optics_type), pointer :: optics !< Optical properties container + integer, intent(in) :: nsw !< The number of frequency bands of penetrating + !! shortwave radiation + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + logical, intent(in) :: aggregate_FW_forcing !< If False, treat in/out fluxes separately. + real, intent(in) :: evap_CFL_limit !< The largest fraction of a layer that + !! can be evaporated in one time-step [nondim]. + real, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! heat and freshwater fluxes is applied [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: cTKE !< Turbulent kinetic energy requirement to mix + !! forcing through each layer [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: dSV_dT !< Partial derivative of specific volume with + !! potential temperature [R-1 C-1 ~> m3 kg-1 degC-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: dSV_dS !< Partial derivative of specific volume with + !! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: SkinBuoyFlux !< Buoyancy flux at surface [Z2 T-3 ~> m2 s-3]. + real, pointer, dimension(:,:), optional :: MLD !< Mixed layer depth for brine plumes [Z ~> m] + + ! Local variables + integer, parameter :: maxGroundings = 5 + integer :: numberOfGroundings, iGround(maxGroundings), jGround(maxGroundings) + real :: H_limit_fluxes ! Surface fluxes are scaled down fluxes when the total depth of the ocean + ! drops below this value [H ~> m or kg m-2] + real :: IforcingDepthScale ! The inverse of the layer thickness below which mass losses are + ! shifted to the next deeper layer [H ~> m or kg m-2] + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: dThickness ! The change in layer thickness [H ~> m or kg m-2] + real :: dTemp ! The integrated change in layer temperature [C H ~> degC m or degC kg m-2] + real :: dSalt ! The integrated change in layer salinity [S H ~> ppt m or ppt kg m-2] + real :: fractionOfForcing ! THe fraction of the remaining forcing applied to a layer [nondim] + real :: hOld ! The original thickness of a layer [H ~> m or kg m-2] + real :: Ithickness ! The inverse of the new layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: RivermixConst ! A constant used in implementing river mixing [R Z2 T-1 ~> Pa s]. + real :: EnthalpyConst ! A constant used to control the enthalpy calculation [nondim] + ! By default EnthalpyConst = 1.0. If fluxes%heat_content_evap + ! is associated enthalpy is provided via coupler and EnthalpyConst = 0.0. + real, dimension(SZI_(G)) :: & + d_pres, & ! pressure change across a layer [R L2 T-2 ~> Pa] + p_lay, & ! average pressure in a layer [R L2 T-2 ~> Pa] + pres, & ! pressure at an interface [R L2 T-2 ~> Pa] + netMassInOut, & ! surface water fluxes [H ~> m or kg m-2] over time step + netMassIn, & ! mass entering ocean surface [H ~> m or kg m-2] over a time step + netMassOut, & ! mass leaving ocean surface [H ~> m or kg m-2] over a time step + netHeat, & ! heat via surface fluxes excluding Pen_SW_bnd and netMassOut + ! [C H ~> degC m or degC kg m-2] + netSalt, & ! surface salt flux ( g(salt)/m2 for non-Bouss and ppt*H for Bouss ) + ! [S H ~> ppt m or ppt kg m-2] + nonpenSW, & ! non-downwelling SW, which is absorbed at ocean surface + ! [C H ~> degC m or degC kg m-2] + SurfPressure, & ! Surface pressure (approximated as 0.0) [R L2 T-2 ~> Pa] + dRhodT, & ! change in density per change in temperature [R C-1 ~> kg m-3 degC-1] + dRhodS, & ! change in density per change in salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! Partial derivative of specific volume with to salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + netheat_rate, & ! netheat but for dt=1 [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) + ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + netMassInOut_rate, & ! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] + mixing_depth, & ! The mixing depth for brine plumes [H ~> m or kg m-2] + MLD_H, & ! The mixed layer depth for brine plumes in thickness units [H ~> m or kg m-2] + MLD_Z, & ! Running sum of distance from the surface for finding MLD_H [Z ~> m] + total_h ! Total thickness of the water column [H ~> m or kg m-2] + real, dimension(SZI_(G), SZK_(GV)) :: & + h2d, & ! A 2-d copy of the thicknesses [H ~> m or kg m-2] + ! dz, & ! Layer thicknesses in depth units [Z ~> m] + T2d, & ! A 2-d copy of the layer temperatures [C ~> degC] + pen_TKE_2d, & ! The TKE required to homogenize the heating by shortwave radiation within + ! a layer [R Z3 T-2 ~> J m-2] + dSV_dT_2d ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)) :: & + netPen_rate ! The surface penetrative shortwave heating rate summed over all bands + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real, dimension(max(nsw,1),SZI_(G)) :: & + Pen_SW_bnd, & ! The penetrative shortwave heating integrated over a timestep by band + ! [C H ~> degC m or degC kg m-2] + Pen_SW_bnd_rate ! The penetrative shortwave heating rate by band + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real, dimension(max(nsw,1),SZI_(G),SZK_(GV)) :: & + opacityBand ! The opacity (inverse of the exponential absorption length) of each frequency + ! band of shortwave radiation in each layer [H-1 ~> m-1 or m2 kg-1] + real, dimension(maxGroundings) :: hGrounding ! Thickness added by each grounding event [H ~> m or kg m-2] + real :: Temp_in ! The initial temperature of a layer [C ~> degC] + real :: Salin_in ! The initial salinity of a layer [S ~> ppt] + real :: g_Hconv2 ! A conversion factor for use in the TKE calculation + ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. + real :: GoRho ! g_Earth times a unit conversion factor divided by density + ! [Z T-2 R-1 ~> m4 s-2 kg-1] + real :: g_conv ! The gravitational acceleration times the conversion factors from non-Boussinesq + ! thickness units to mass per units area [R Z2 H-1 T-2 ~> kg m-2 s-2 or m s-2] + logical :: calculate_energetics ! If true, calculate the energy required to mix the newly added + ! water over the topmost grid cell, assuming that the fluxes of heat and salt + ! and rejected brine are initially applied in vanishingly thin layers at the + ! top of the layer before being mixed throughout the layer. + logical :: calculate_buoyancy ! If true, calculate the surface buoyancy flux. + real :: dK(SZI_(G)) ! Depth of the layer center in thickness units [H ~> m or kg m-2] + real :: A_brine(SZI_(G)) ! Constant [H-(n+1) ~> m-(n+1) or m(2n+2) kg-(n+1)]. + real :: fraction_left_brine ! Fraction of the brine that has not been applied yet [nondim] + real :: plume_fraction ! Fraction of the brine that is applied to a layer [nondim] + real :: plume_flux ! Brine flux to move downwards [S H ~> ppt m or ppt kg m-2] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, is, ie, js, je, k, nz, nb + character(len=45) :: mesg + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + Idt = 1.0 / dt + plume_flux = 0.0 + + calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) + calculate_buoyancy = present(SkinBuoyFlux) + if (calculate_buoyancy) SkinBuoyFlux(:,:) = 0.0 + if (present(cTKE)) cTKE(:,:,:) = 0.0 + g_Hconv2 = (US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ) * GV%H_to_RZ + EOSdom(:) = EOS_domain(G%HI) + + ! Only apply forcing if fluxes%sw is associated. + if (.not.associated(fluxes%sw) .and. .not.calculate_energetics) return + + EnthalpyConst = 1.0 + if (associated(fluxes%heat_content_evap)) EnthalpyConst = 0.0 + + if (calculate_buoyancy) then + SurfPressure(:) = 0.0 + GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 + endif + + if (CS%do_brine_plume .and. .not. associated(MLD)) then + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Brine plume parameterization requires a mixed-layer depth,\n"//& + "currently coming from the energetic PBL scheme.") + endif + if (CS%do_brine_plume .and. .not. associated(fluxes%salt_left_behind)) then + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Brine plume parameterization requires DO_BRINE_PLUME\n"//& + "to be turned on in SIS2 as well as MOM6.") + endif + + ! H_limit_fluxes is used by extractFluxes1d to scale down fluxes if the total + ! depth of the ocean is vanishing. It does not (yet) handle a value of zero. + ! To accommodate vanishing upper layers, we need to allow for an instantaneous + ! distribution of forcing over some finite vertical extent. The bulk mixed layer + ! code handles this issue properly. + H_limit_fluxes = max(GV%Angstrom_H, GV%H_subroundoff) + + ! diagnostic to see if need to create mass to avoid grounding + if (CS%id_createdH>0) CS%createdH(:,:) = 0. + numberOfGroundings = 0 + + !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,tv,nsw,G,GV,US,optics,fluxes, & + !$OMP H_limit_fluxes,numberOfGroundings,iGround,jGround,& + !$OMP nonPenSW,hGrounding,CS,Idt,aggregate_FW_forcing, & + !$OMP minimum_forcing_depth,evap_CFL_limit,dt,EOSdom, & + !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho,& + !$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2, & + !$OMP EnthalpyConst,MLD) & + !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & + !$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & + !$OMP IforcingDepthScale,g_conv,dSpV_dT,dSpV_dS, & + !$OMP dThickness,dTemp,dSalt,hOld,Ithickness, & + !$OMP netMassIn,pres,d_pres,p_lay,dSV_dT_2d, & + !$OMP netmassinout_rate,netheat_rate,netsalt_rate, & + !$OMP drhodt,drhods,pen_sw_bnd_rate, & + !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst, & + !$OMP mixing_depth,A_brine,fraction_left_brine, & + !$OMP plume_fraction,dK,MLD_H,MLD_Z,total_h) & + !$OMP firstprivate(SurfPressure,plume_flux) + do j=js,je + ! Work in vertical slices for efficiency + + ! Copy state into 2D-slice arrays + do k=1,nz ; do i=is,ie + h2d(i,k) = h(i,j,k) + T2d(i,k) = tv%T(i,j,k) + enddo ; enddo + + if (calculate_energetics) then + ! The partial derivatives of specific volume with temperature and + ! salinity need to be precalculated to avoid having heating of + ! tiny layers give nonsensical values. + if (associated(tv%p_surf)) then + do i=is,ie ; pres(i) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; pres(i) = 0.0 ; enddo + endif + do k=1,nz + do i=is,ie + d_pres(i) = (GV%g_Earth * GV%H_to_RZ) * h2d(i,k) + p_lay(i) = pres(i) + 0.5*d_pres(i) + pres(i) = pres(i) + d_pres(i) + enddo + call calculate_specific_vol_derivs(T2d(:,k), tv%S(:,j,k), p_lay(:), & + dSV_dT(:,j,k), dSV_dS(:,j,k), tv%eqn_of_state, EOSdom) + do i=is,ie ; dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; enddo + enddo + pen_TKE_2d(:,:) = 0.0 + endif + + ! Nothing more is done on this j-slice if there is no buoyancy forcing. + if (.not.associated(fluxes%sw)) cycle + + if (nsw>0) then + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=GV%H_to_Z) + else + call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=GV%H_to_RZ, & + SpV_avg=tv%SpV_avg) + endif + endif + + ! The surface forcing is contained in the fluxes type. + ! We aggregate the thermodynamic forcing for a time step into the following: + ! netMassInOut = surface water fluxes [H ~> m or kg m-2] over time step + ! = lprec + fprec + vprec + evap + lrunoff + frunoff + ! note that lprec generally has sea ice melt/form included. + ! netMassOut = net mass leaving ocean surface [H ~> m or kg m-2] over a time step. + ! netMassOut < 0 means mass leaves ocean. + ! netHeat = heat via surface fluxes [C H ~> degC m or degC kg m-2], excluding the part + ! contained in Pen_SW_bnd; and excluding heat_content of netMassOut < 0. + ! netSalt = surface salt fluxes [S H ~> ppt m or gSalt m-2] + ! Pen_SW_bnd = components to penetrative shortwave radiation split according to bands. + ! This field provides that portion of SW from atmosphere that in fact + ! enters to the ocean and participates in penetrative SW heating. + ! nonpenSW = non-downwelling SW flux, which is absorbed in ocean surface + ! (in tandem w/ LW,SENS,LAT); saved only for diagnostic purposes. + + !---------------------------------------------------------------------------------------- + !BGR-June 26, 2017{ + !Temporary action to preserve answers while fixing a bug. + ! To fix a bug in a diagnostic calculation, applyboundaryfluxesinout now returns + ! the surface buoyancy flux. Previously, extractbuoyancyflux2d was called, meaning + ! a second call to extractfluxes1d (causing the diagnostic net_heat to be incorrect). + ! Note that this call to extract buoyancyflux2d was AFTER applyboundaryfluxesinout, + ! which means it used the T/S fields after this routine. Therefore, the surface + ! buoyancy flux is computed here at the very end of this routine for legacy reasons. + ! A few specific notes follow: + ! 1) The old method did not included river/calving contributions to heat flux. This + ! is kept consistent here via commenting code in the present extractFluxes1d <_rate> + ! outputs, but we may reconsider this approach. + ! 2) The old method computed the buoyancy flux rate directly (by setting dt=1), instead + ! of computing the integrated value (and dividing by dt). Hence the required + ! additional outputs from extractFluxes1d. + ! *** This is because: A*dt/dt =/= A due to round off. + ! 3) The old method computed buoyancy flux after this routine, meaning the returned + ! surface fluxes (from extractfluxes1d) must be recorded for use later in the code. + ! We could (and maybe should) move that loop up to before the surface fluxes are + ! applied, but this will change answers. + ! For all these reasons we compute additional values of <_rate> which are preserved + ! for the buoyancy flux calculation and reproduce the old answers. + ! In the future this needs more detailed investigation to make sure everything is + ! consistent and correct. These details should not significantly effect climate, + ! but do change answers. + !----------------------------------------------------------------------------------------- + if (calculate_buoyancy) then + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & + H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & + h2d, T2d, netMassInOut, netMassOut, netHeat, netSalt, & + Pen_SW_bnd, tv, aggregate_FW_forcing, nonpenSW=nonpenSW, & + net_Heat_rate=netheat_rate, net_salt_rate=netsalt_rate, & + netmassinout_rate=netmassinout_rate, pen_sw_bnd_rate=pen_sw_bnd_rate) + else + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & + H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & + h2d, T2d, netMassInOut, netMassOut, netHeat, netSalt, & + Pen_SW_bnd, tv, aggregate_FW_forcing, nonpenSW=nonpenSW) + endif + ! ea is for passive tracers + do i=is,ie + ! ea(i,j,1) = netMassInOut(i) + if (aggregate_FW_forcing) then + netMassOut(i) = netMassInOut(i) + netMassIn(i) = 0. + else + netMassIn(i) = netMassInOut(i) - netMassOut(i) + endif + if (G%mask2dT(i,j) > 0.0) then + fluxes%netMassOut(i,j) = netMassOut(i) + fluxes%netMassIn(i,j) = netMassIn(i) + else + fluxes%netMassOut(i,j) = 0.0 + fluxes%netMassIn(i,j) = 0.0 + endif + enddo + + ! Apply the surface boundary fluxes in three steps: + ! A/ update mass, temp, and salinity due to all terms except mass leaving + ! ocean (and corresponding outward heat content), and ignoring penetrative SW. + ! B/ update mass, salt, temp from mass leaving ocean. + ! C/ update temp due to penetrative SW + if (CS%do_brine_plume) then + ! Find the plume mixing depth. + if (GV%Boussinesq .or. .not.allocated(tv%SpV_avg)) then + do i=is,ie ; MLD_H(i) = GV%Z_to_H * MLD(i,j) ; total_h(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie ; total_h(i) = total_h(i) + h(i,j,k) ; enddo ; enddo + else + do i=is,ie ; MLD_H(i) = 0.0 ; MLD_Z(i) = 0.0 ; total_h(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + total_h(i) = total_h(i) + h(i,j,k) + if (MLD_Z(i) + GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) < MLD(i,j)) then + MLD_H(i) = MLD_H(i) + h(i,j,k) + MLD_Z(i) = MLD_Z(i) + GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + elseif (MLD_Z(i) < MLD(i,j)) then ! This is the last layer in the mixed layer + MLD_H(i) = MLD_H(i) + GV%RZ_to_H * (MLD(i,j) - MLD_Z(i)) / tv%SpV_avg(i,j,k) + MLD_Z(i) = MLD(i,j) + endif + enddo ; enddo + endif + do i=is,ie + mixing_depth(i) = min( max(MLD_H(i) - minimum_forcing_depth, minimum_forcing_depth), & + max(total_h(i), GV%angstrom_h) ) + GV%H_subroundoff + A_brine(i) = (CS%brine_plume_n + 1) / (mixing_depth(i) ** (CS%brine_plume_n + 1)) + enddo + endif + + do i=is,ie + if (G%mask2dT(i,j) > 0.) then + + ! A/ Update mass, temp, and salinity due to incoming mass flux. + do k=1,1 + + ! Change in state due to forcing + dThickness = netMassIn(i) ! Since we are adding mass, we can use all of it + dTemp = 0. + dSalt = 0. + + ! Update the forcing by the part to be consumed within the present k-layer. + ! If fractionOfForcing = 1, then updated netMassIn, netHeat, and netSalt vanish. + netMassIn(i) = netMassIn(i) - dThickness + ! This line accounts for the temperature of the mass exchange + Temp_in = T2d(i,k) + Salin_in = 0.0 + dTemp = dTemp + dThickness*Temp_in*EnthalpyConst + + ! Diagnostics of heat content associated with mass fluxes + if (.not. associated(fluxes%heat_content_evap)) then + if (associated(fluxes%heat_content_massin)) & + fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & + T2d(i,k) * max(0.,dThickness) * GV%H_to_RZ * tv%C_p * Idt + if (associated(fluxes%heat_content_massout)) & + fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) + & + T2d(i,k) * min(0.,dThickness) * GV%H_to_RZ * tv%C_p * Idt + if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & + T2d(i,k) * dThickness * GV%H_to_RZ + endif + + ! Determine the energetics of river mixing before updating the state. + if (calculate_energetics .and. associated(fluxes%lrunoff) .and. CS%do_rivermix) then + ! Here we add an additional source of TKE to the mixed layer where river + ! is present to simulate unresolved estuaries. The TKE input, TKE_river in + ! [Z3 T-3 ~> m3 s-3], is diagnosed as follows: + ! TKE_river = 0.5*rivermix_depth*g*(1/rho)*drho_ds* + ! River*(Samb - Sriver) = CS%mstar*U_star^3 + ! where River is in units of [Z T-1 ~> m s-1]. + ! Samb = Ambient salinity at the mouth of the estuary + ! rivermix_depth = The prescribed depth over which to mix river inflow + ! drho_ds = The derivative of density with salt at the ambient surface salinity. + ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) + if (GV%Boussinesq) then + RivermixConst = -0.5*(CS%rivermix_depth*dt) * ( US%L_to_Z**2*GV%g_Earth ) * GV%Rho0 + elseif (allocated(tv%SpV_avg)) then + RivermixConst = -0.5*(CS%rivermix_depth*dt) * ( US%L_to_Z**2*GV%g_Earth ) / tv%SpV_avg(i,j,1) + else + RivermixConst = -0.5*(CS%rivermix_depth*dt) * GV%Rho0 * ( US%L_to_Z**2*GV%g_Earth ) + endif + cTKE(i,j,k) = cTKE(i,j,k) + max(0.0, RivermixConst*dSV_dS(i,j,1) * & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * tv%S(i,j,1)) + endif + + ! Update state + hOld = h2d(i,k) ! Keep original thickness in hand + h2d(i,k) = h2d(i,k) + dThickness ! New thickness + if (h2d(i,k) > 0.0) then + if (calculate_energetics .and. (dThickness > 0.)) then + ! Calculate the energy required to mix the newly added water over + ! the topmost grid cell. + cTKE(i,j,k) = cTKE(i,j,k) + 0.5*g_Hconv2*(hOld*dThickness) * & + ((T2d(i,k) - Temp_in) * dSV_dT(i,j,k) + (tv%S(i,j,k) - Salin_in) * dSV_dS(i,j,k)) + endif + Ithickness = 1.0/h2d(i,k) ! Inverse new thickness + ! The "if"s below avoid changing T/S by roundoff unnecessarily + if (dThickness /= 0. .or. dTemp /= 0.) T2d(i,k) = (hOld*T2d(i,k) + dTemp)*Ithickness + if (dThickness /= 0. .or. dSalt /= 0.) tv%S(i,j,k) = (hOld*tv%S(i,j,k) + dSalt)*Ithickness + + endif + + enddo ! k=1,1 + + ! B/ Update mass, salt, temp from mass leaving ocean and other fluxes of heat and salt. + fraction_left_brine = 1.0 + do k=1,nz + ! Place forcing into this layer if this layer has nontrivial thickness. + ! For layers thin relative to 1/IforcingDepthScale, then distribute + ! forcing into deeper layers. + IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) + ! fractionOfForcing = 1.0, unless h2d is less than IforcingDepthScale. + fractionOfForcing = min(1.0, h2d(i,k)*IforcingDepthScale) + + ! In the case with (-1)*netMassOut*fractionOfForcing greater than cfl*h, we + ! limit the forcing applied to this cell, leaving the remaining forcing to + ! be distributed downwards. + if (-fractionOfForcing*netMassOut(i) > evap_CFL_limit*h2d(i,k)) then + fractionOfForcing = -evap_CFL_limit*h2d(i,k)/netMassOut(i) + endif + + if (CS%do_brine_plume .and. associated(fluxes%salt_left_behind)) then + if (fluxes%salt_left_behind(i,j) > 0 .and. fraction_left_brine > 0.0) then + ! Place forcing into this layer by depth for brine plume parameterization. + if (k == 1) then + dK(i) = 0.5 * h(i,j,k) ! Depth of center of layer K + plume_flux = - (1000.0*US%ppt_to_S * (CS%plume_strength * fluxes%salt_left_behind(i,j))) * GV%RZ_to_H + plume_fraction = 1.0 + else + dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) ! Depth of center of layer K + plume_flux = 0.0 + endif + if (dK(i) <= mixing_depth(i) .and. fraction_left_brine > 0.0) then + plume_fraction = min(fraction_left_brine, (A_brine(i) * dK(i)**CS%brine_plume_n) * h(i,j,k)) + else + IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) + ! plume_fraction = fraction_left_brine, unless h2d is less than IforcingDepthScale. + plume_fraction = min(fraction_left_brine, h2d(i,k)*IforcingDepthScale) + endif + fraction_left_brine = fraction_left_brine - plume_fraction + plume_flux = plume_flux + plume_fraction * (1000.0*US%ppt_to_S * (CS%plume_strength * & + fluxes%salt_left_behind(i,j))) * GV%RZ_to_H + else + plume_flux = 0.0 + endif + endif + + ! Change in state due to forcing + + dThickness = max( fractionOfForcing*netMassOut(i), -h2d(i,k) ) + dTemp = fractionOfForcing*netHeat(i) + dSalt = max( fractionOfForcing*netSalt(i), -CS%dSalt_frac_max * h2d(i,k) * tv%S(i,j,k)) + + ! Update the forcing by the part to be consumed within the present k-layer. + ! If fractionOfForcing = 1, then new netMassOut vanishes. + netMassOut(i) = netMassOut(i) - dThickness + netHeat(i) = netHeat(i) - dTemp + netSalt(i) = netSalt(i) - dSalt + + ! This line accounts for the temperature of the mass exchange + dTemp = dTemp + dThickness*T2d(i,k)*EnthalpyConst + + ! Diagnostics of heat content associated with mass fluxes + if (.not. associated(fluxes%heat_content_evap)) then + if (associated(fluxes%heat_content_massin)) & + fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & + T2d(i,k) * max(0.,dThickness) * GV%H_to_RZ * tv%C_p * Idt + if (associated(fluxes%heat_content_massout)) & + fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) + & + T2d(i,k) * min(0.,dThickness) * GV%H_to_RZ * tv%C_p * Idt + if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & + T2d(i,k) * dThickness * GV%H_to_RZ + endif + + ! Update state by the appropriate increment. + hOld = h2d(i,k) ! Keep original thickness in hand + h2d(i,k) = h2d(i,k) + dThickness ! New thickness + + if (h2d(i,k) > 0.) then + if (calculate_energetics) then + ! Calculate the energy required to mix the newly added water over the topmost grid + ! cell, assuming that the fluxes of heat and salt and rejected brine are initially + ! applied in vanishingly thin layers at the top of the layer before being mixed + ! throughout the layer. Note that dThickness is always <= 0 here, and that + ! negative cTKE is a deficit that will need to be filled later. + cTKE(i,j,k) = cTKE(i,j,k) - (0.5*h2d(i,k)*g_Hconv2) * & + ((dTemp - dthickness*T2d(i,k)) * dSV_dT(i,j,k) + & + (dSalt - dthickness*tv%S(i,j,k)) * dSV_dS(i,j,k)) + endif + Ithickness = 1.0/h2d(i,k) ! Inverse of new thickness + T2d(i,k) = (hOld*T2d(i,k) + dTemp)*Ithickness + tv%S(i,j,k) = (hOld*tv%S(i,j,k) + dSalt + plume_flux)*Ithickness + elseif (h2d(i,k) < 0.0) then ! h2d==0 is a special limit that needs no extra handling + call forcing_SinglePointPrint(fluxes,G,i,j,'applyBoundaryFluxesInOut (h<0)') + write(0,*) 'applyBoundaryFluxesInOut(): lon,lat=',G%geoLonT(i,j),G%geoLatT(i,j) + write(0,*) 'applyBoundaryFluxesInOut(): netT,netS,netH=', & + US%C_to_degC*netHeat(i), US%S_to_ppt*netSalt(i), netMassInOut(i) + write(0,*) 'applyBoundaryFluxesInOut(): dT,dS,dH=', & + US%C_to_degC*dTemp, US%S_to_ppt*dSalt, dThickness + write(0,*) 'applyBoundaryFluxesInOut(): h(n),h(n+1),k=',hOld,h2d(i,k),k + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Complete mass loss in column!") + endif + + enddo ! k + + ! Check if trying to apply fluxes over land points + elseif ((abs(netHeat(i)) + abs(netSalt(i)) + abs(netMassIn(i)) + abs(netMassOut(i))) > 0.) then + + if (.not. CS%ignore_fluxes_over_land) then + call forcing_SinglePointPrint(fluxes,G,i,j,'applyBoundaryFluxesInOut (land)') + write(0,*) 'applyBoundaryFluxesInOut(): lon,lat=',G%geoLonT(i,j),G%geoLatT(i,j) + write(0,*) 'applyBoundaryFluxesInOut(): netHeat,netSalt,netMassIn,netMassOut=',& + US%C_to_degC*netHeat(i), US%S_to_ppt*netSalt(i), netMassIn(i), netMassOut(i) + + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Mass loss over land?") + endif + + endif + + ! If anything remains after the k-loop, then we have grounded out, which is a problem. + if (netMassIn(i)+netMassOut(i) /= 0.0) then +!$OMP critical + numberOfGroundings = numberOfGroundings +1 + if (numberOfGroundings<=maxGroundings) then + iGround(numberOfGroundings) = i ! Record i,j location of event for + jGround(numberOfGroundings) = j ! warning message + hGrounding(numberOfGroundings) = netMassIn(i)+netMassOut(i) + endif +!$OMP end critical + if (CS%id_createdH>0) CS%createdH(i,j) = CS%createdH(i,j) - (netMassIn(i)+netMassOut(i))/dt + endif + + enddo ! i + + ! Step C/ in the application of fluxes + ! Heat by the convergence of penetrating SW. + ! SW penetrative heating uses the updated thickness from above. + + ! Save temperature before increment with SW heating + ! and initialize CS%penSWflux_diag to zero. + if (CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then + do k=1,nz ; do i=is,ie + CS%penSW_diag(i,j,k) = T2d(i,k) + CS%penSWflux_diag(i,j,k) = 0.0 + enddo ; enddo + k=nz+1 ; do i=is,ie + CS%penSWflux_diag(i,j,k) = 0.0 + enddo + endif + + if (calculate_energetics) then + call absorbRemainingSW(G, GV, US, h2d, opacityBand, nsw, optics, j, dt, H_limit_fluxes, & + .false., .true., T2d, Pen_SW_bnd, TKE=pen_TKE_2d, dSV_dT=dSV_dT_2d) + k = 1 ! For setting break-points. + do k=1,nz ; do i=is,ie + cTKE(i,j,k) = cTKE(i,j,k) + pen_TKE_2d(i,k) + enddo ; enddo + else + call absorbRemainingSW(G, GV, US, h2d, opacityBand, nsw, optics, j, dt, H_limit_fluxes, & + .false., .true., T2d, Pen_SW_bnd) + endif + + + ! Step D/ copy updated thickness and temperature + ! 2d slice now back into model state. + do k=1,nz ; do i=is,ie + h(i,j,k) = h2d(i,k) + tv%T(i,j,k) = T2d(i,k) + enddo ; enddo + + ! Diagnose heating [Q R Z T-1 ~> W m-2] applied to a grid cell from SW penetration + ! Also diagnose the penetrative SW heat flux at base of layer. + if (CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then + + ! convergence of SW into a layer + do k=1,nz ; do i=is,ie + ! Note that the units of penSW_diag change here, from [C ~> degC] to [Q R Z T-1 ~> W m-2]. + CS%penSW_diag(i,j,k) = (T2d(i,k)-CS%penSW_diag(i,j,k))*h(i,j,k) * Idt * tv%C_p * GV%H_to_RZ + enddo ; enddo + + ! Perform a cumulative sum upwards from bottom to + ! diagnose penetrative SW flux at base of tracer cell. + ! CS%penSWflux_diag(i,j,k=1) is penetrative shortwave at top of ocean. + ! CS%penSWflux_diag(i,j,k=kbot+1) is zero, since assume no SW penetrates rock. + ! CS%penSWflux_diag = rsdo and CS%penSW_diag = rsdoabsorb + ! rsdoabsorb(k) = rsdo(k) - rsdo(k+1), so that rsdo(k) = rsdo(k+1) + rsdoabsorb(k) + if (CS%id_penSWflux_diag > 0) then + do k=nz,1,-1 ; do i=is,ie + CS%penSWflux_diag(i,j,k) = CS%penSW_diag(i,j,k) + CS%penSWflux_diag(i,j,k+1) + enddo ; enddo + endif + + endif + + ! Fill CS%nonpenSW_diag + if (CS%id_nonpenSW_diag > 0) then + do i=is,ie + CS%nonpenSW_diag(i,j) = nonpenSW(i) * Idt * tv%C_p * GV%H_to_RZ + enddo + endif + + ! BGR: Get buoyancy flux to return for ePBL + ! We want the rate, so we use the rate values returned from extractfluxes1d. + ! Note that the *dt values could be divided by dt here, but + ! 1) Answers will change due to round-off + ! 2) Be sure to save their values BEFORE fluxes are used. + if (Calculate_Buoyancy) then + netPen_rate(:) = 0.0 + ! Sum over bands and attenuate as a function of depth. + ! netPen_rate is the netSW as a function of depth, but only the surface value is used here, + ! in which case the values of dt, h, optics and H_limit_fluxes are irrelevant. Consider + ! writing a shorter and simpler variant to handle this very limited case. + ! Find the vertical distances across layers. + ! call thickness_to_dz(h, tv, dz, j, G, GV) + ! call sumSWoverBands(G, GV, US, h2d, dz, optics_nbands(optics), optics, j, dt, & + ! H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) + do i=is,ie ; do nb=1,nsw ; netPen_rate(i) = netPen_rate(i) + pen_SW_bnd_rate(nb,i) ; enddo ; enddo + + ! 1. Adjust netSalt to reflect dilution effect of FW flux + ! 2. Add in the SW heating for purposes of calculating the net + ! surface buoyancy flux affecting the top layer. + ! 3. Convert to a buoyancy flux, excluding penetrating SW heating + ! BGR-Jul 5, 2017: The contribution of SW heating here needs investigated for ePBL. + if (associated(tv%p_surf)) then ; do i=is,ie ; SurfPressure(i) = tv%p_surf(i,j) ; enddo ; endif + + if ((.not.GV%Boussinesq) .and. (.not.GV%semi_Boussinesq)) then + g_conv = GV%g_Earth * GV%H_to_RZ * US%L_to_Z**2 + + ! Specific volume derivatives + call calculate_specific_vol_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, EOS_domain(G%HI)) + do i=is,ie + SkinBuoyFlux(i,j) = g_conv * & + (dSpV_dS(i) * ( netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & + dSpV_dT(i) * ( netHeat_rate(i) + netPen_rate(i)) ) ! [Z2 T-3 ~> m2 s-3] + enddo + else + ! Density derivatives + call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, & + tv%eqn_of_state, EOSdom) + do i=is,ie + SkinBuoyFlux(i,j) = - GoRho * GV%H_to_Z * & + (dRhodS(i) * ( netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & + dRhodT(i) * ( netHeat_rate(i) + netPen_rate(i)) ) ! [Z2 T-3 ~> m2 s-3] + enddo + endif + endif + + enddo ! j-loop finish + + ! Post the diagnostics + if (CS%id_createdH > 0) call post_data(CS%id_createdH , CS%createdH , CS%diag) + if (CS%id_penSW_diag > 0) call post_data(CS%id_penSW_diag , CS%penSW_diag , CS%diag) + if (CS%id_penSWflux_diag > 0) call post_data(CS%id_penSWflux_diag, CS%penSWflux_diag, CS%diag) + if (CS%id_nonpenSW_diag > 0) call post_data(CS%id_nonpenSW_diag , CS%nonpenSW_diag , CS%diag) + +! The following check will be ignored if ignore_fluxes_over_land = true + if ((numberOfGroundings > 0) .and. .not.CS%ignore_fluxes_over_land) then + do i = 1, min(numberOfGroundings, maxGroundings) + call forcing_SinglePointPrint(fluxes,G,iGround(i),jGround(i),'applyBoundaryFluxesInOut (grounding)') + write(mesg(1:45),'(3es15.3)') G%geoLonT( iGround(i), jGround(i) ), & + G%geoLatT( iGround(i), jGround(i)), hGrounding(i)*GV%H_to_m + call MOM_error(WARNING, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Mass created. x,y,dh= "//trim(mesg), all_print=.true.) + enddo + + if (numberOfGroundings - maxGroundings > 0) then + write(mesg, '(i4)') numberOfGroundings - maxGroundings + call MOM_error(WARNING, "MOM_diabatic_aux:F90, applyBoundaryFluxesInOut(): "//& + trim(mesg) // " groundings remaining") + endif + endif + +end subroutine applyBoundaryFluxesInOut + +!> This subroutine initializes the parameters and control structure of the diabatic_aux module. +subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgorithm, use_ePBL) + type(time_type), target, intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(inout) :: diag !< A structure used to regulate diagnostic output + type(diabatic_aux_CS), pointer :: CS !< A pointer to the control structure for the + !! diabatic_aux module, which is initialized here. + logical, intent(in) :: useALEalgorithm !< If true, use the ALE algorithm rather + !! than layered mode. + logical, intent(in) :: use_ePBL !< If true, use the implicit energetics planetary + !! boundary layer scheme to determine the diffusivity + !! in the surface boundary layer. + + ! This "include" declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_diabatic_aux" ! This module's name. + character(len=200) :: inputdir ! The directory where NetCDF input files + character(len=240) :: chl_filename ! A file from which chl_a concentrations are to be read. + character(len=128) :: chl_file ! Data containing chl_a concentrations. Used + ! when var_pen_sw is defined and reading from file. + character(len=32) :: chl_varname ! Name of chl_a variable in chl_file. + logical :: use_temperature ! True if thermodynamics are enabled. + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (associated(CS)) then + call MOM_error(WARNING, "diabatic_aux_init called with an "// & + "associated control structure.") + return + else + allocate(CS) + endif + + CS%diag => diag + CS%Time => Time + +! Set default, read and log parameters + call log_version(param_file, mdl, version, & + "The following parameters are used for auxiliary diabatic processes.") + + call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & + "If true, temperature and salinity are used as state variables.", default=.true.) + + call get_param(param_file, mdl, "RECLAIM_FRAZIL", CS%reclaim_frazil, & + "If true, try to use any frazil heat deficit to cool any "//& + "overlying layers down to the freezing point, thereby "//& + "avoiding the creation of thin ice when the SST is above "//& + "the freezing point.", default=.true., do_not_log=.not.use_temperature) + call get_param(param_file, mdl, "SALT_EXTRACTION_LIMIT", CS%dSalt_frac_max, & + "An upper limit on the fraction of the salt in a layer that can be lost to the "//& + "net surface salt fluxes within a timestep.", & + units="nondim", default=0.9999, do_not_log=.not.use_temperature) + CS%dSalt_frac_max = max(min(CS%dSalt_frac_max, 1.0), 0.0) + call get_param(param_file, mdl, "PRESSURE_DEPENDENT_FRAZIL", CS%pressure_dependent_frazil, & + "If true, use a pressure dependent freezing temperature "//& + "when making frazil. The default is false, which will be "//& + "faster but is inappropriate with ice-shelf cavities.", & + default=.false., do_not_log=.not.use_temperature) + + if (use_ePBL) then + call get_param(param_file, mdl, "IGNORE_FLUXES_OVER_LAND", CS%ignore_fluxes_over_land,& + "If true, the model does not check if fluxes are being applied "//& + "over land points. This is needed when the ocean is coupled "//& + "with ice shelves and sea ice, since the sea ice mask needs to "//& + "be different than the ocean mask to avoid sea ice formation "//& + "under ice shelves. This flag only works when use_ePBL = True.", default=.false.) + call get_param(param_file, mdl, "DO_RIVERMIX", CS%do_rivermix, & + "If true, apply additional mixing wherever there is "//& + "runoff, so that it is mixed down to RIVERMIX_DEPTH "//& + "if the ocean is that deep.", default=.false.) + if (CS%do_rivermix) & + call get_param(param_file, mdl, "RIVERMIX_DEPTH", CS%rivermix_depth, & + "The depth to which rivers are mixed if DO_RIVERMIX is "//& + "defined.", units="m", default=0.0, scale=US%m_to_Z) + else + CS%do_rivermix = .false. ; CS%rivermix_depth = 0.0 ; CS%ignore_fluxes_over_land = .false. + endif + + if (GV%nkml == 0) then + call get_param(param_file, mdl, "USE_RIVER_HEAT_CONTENT", CS%use_river_heat_content, & + "If true, use the fluxes%runoff_Hflx field to set the "//& + "heat carried by runoff, instead of using SST*CP*liq_runoff.", & + default=.false., do_not_log=.not.use_temperature) + call get_param(param_file, mdl, "USE_CALVING_HEAT_CONTENT", CS%use_calving_heat_content, & + "If true, use the fluxes%calving_Hflx field to set the "//& + "heat carried by runoff, instead of using SST*CP*froz_runoff.", & + default=.false., do_not_log=.not.use_temperature) + else + CS%use_river_heat_content = .false. + CS%use_calving_heat_content = .false. + endif + + call get_param(param_file, mdl, "DO_BRINE_PLUME", CS%do_brine_plume, & + "If true, use a brine plume parameterization from "//& + "Nguyen et al., 2009.", default=.false.) + call get_param(param_file, mdl, "BRINE_PLUME_EXPONENT", CS%brine_plume_n, & + "If using the brine plume parameterization, set the integer exponent.", & + default=5, do_not_log=.not.CS%do_brine_plume) + call get_param(param_file, mdl, "BRINE_PLUME_FRACTION", CS%plume_strength, & + "Fraction of the available brine to mix down using the brine plume parameterization.", & + units="nondim", default=1.0, do_not_log=.not.CS%do_brine_plume) + + if (useALEalgorithm) then + CS%id_createdH = register_diag_field('ocean_model',"created_H",diag%axesT1, & + Time, "The volume flux added to stop the ocean from drying out and becoming negative in depth", & + "m s-1", conversion=GV%H_to_m*US%s_to_T) + if (CS%id_createdH>0) allocate(CS%createdH(isd:ied,jsd:jed)) + + ! diagnostic for heating of a grid cell from convergence of SW heat into the cell + CS%id_penSW_diag = register_diag_field('ocean_model', 'rsdoabsorb', & + diag%axesTL, Time, 'Convergence of Penetrative Shortwave Flux in Sea Water Layer',& + 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='net_rate_of_absorption_of_shortwave_energy_in_ocean_layer', v_extensive=.true.) + + ! diagnostic for penetrative SW heat flux at top interface of tracer cell (nz+1 interfaces) + ! k=1 gives penetrative SW at surface; SW(k=nz+1)=0 (no penetration through rock). + CS%id_penSWflux_diag = register_diag_field('ocean_model', 'rsdo', & + diag%axesTi, Time, 'Downwelling Shortwave Flux in Sea Water at Grid Cell Upper Interface',& + 'W m-2', conversion=US%QRZ_T_to_W_m2, standard_name='downwelling_shortwave_flux_in_sea_water') + + ! need both arrays for the SW diagnostics (one for flux, one for convergence) + if (CS%id_penSW_diag>0 .or. CS%id_penSWflux_diag>0) then + allocate(CS%penSW_diag(isd:ied,jsd:jed,nz), source=0.0) + allocate(CS%penSWflux_diag(isd:ied,jsd:jed,nz+1), source=0.0) + endif + + ! diagnostic for non-downwelling SW radiation (i.e., SW absorbed at ocean surface) + CS%id_nonpenSW_diag = register_diag_field('ocean_model', 'nonpenSW', & + diag%axesT1, Time, & + 'Non-downwelling SW radiation (i.e., SW absorbed in ocean surface with LW,SENS,LAT)',& + 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='nondownwelling_shortwave_flux_in_sea_water') + if (CS%id_nonpenSW_diag > 0) then + allocate(CS%nonpenSW_diag(isd:ied,jsd:jed), source=0.0) + endif + endif + + if (use_temperature) then + call get_param(param_file, mdl, "VAR_PEN_SW", CS%var_pen_sw, & + "If true, use one of the CHL_A schemes specified by "//& + "OPACITY_SCHEME to determine the e-folding depth of "//& + "incoming short wave radiation.", default=.false.) + if (CS%var_pen_sw) then + + call get_param(param_file, mdl, "CHL_FROM_FILE", CS%chl_from_file, & + "If true, chl_a is read from a file.", default=.true.) + if (CS%chl_from_file) then + call time_interp_external_init() + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + call get_param(param_file, mdl, "CHL_FILE", chl_file, & + "CHL_FILE is the file containing chl_a concentrations in "//& + "the variable CHL_A. It is used when VAR_PEN_SW and "//& + "CHL_FROM_FILE are true.", fail_if_missing=.true.) + chl_filename = trim(slasher(inputdir))//trim(chl_file) + call log_param(param_file, mdl, "INPUTDIR/CHL_FILE", chl_filename) + call get_param(param_file, mdl, "CHL_VARNAME", chl_varname, & + "Name of CHL_A variable in CHL_FILE.", default='CHL_A') + if (modulo(G%Domain%turns, 4) /= 0) then + CS%sbc_chl = init_external_field(chl_filename, trim(chl_varname), MOM_domain=G%Domain%domain_in) + else + CS%sbc_chl = init_external_field(chl_filename, trim(chl_varname), MOM_domain=G%Domain) + endif + endif + + CS%id_chl = register_diag_field('ocean_model', 'Chl_opac', diag%axesT1, Time, & + 'Surface chlorophyll A concentration used to find opacity', 'mg m-3') + endif + endif + + id_clock_uv_at_h = cpu_clock_id('(Ocean find_uv_at_h)', grain=CLOCK_ROUTINE) + id_clock_frazil = cpu_clock_id('(Ocean frazil)', grain=CLOCK_ROUTINE) + +end subroutine diabatic_aux_init + +!> This subroutine initializes the control structure and any related memory +!! for the diabatic_aux module. +subroutine diabatic_aux_end(CS) + type(diabatic_aux_CS), pointer :: CS !< The control structure returned by a previous + !! call to diabatic_aux_init; it is deallocated here. + + if (.not.associated(CS)) return + + if (CS%id_createdH >0) deallocate(CS%createdH) + if (CS%id_penSW_diag >0) deallocate(CS%penSW_diag) + if (CS%id_penSWflux_diag >0) deallocate(CS%penSWflux_diag) + if (CS%id_nonpenSW_diag >0) deallocate(CS%nonpenSW_diag) + + if (associated(CS)) deallocate(CS) + +end subroutine diabatic_aux_end + +!> \namespace mom_diabatic_aux +!! +!! This module contains subroutines that apply various diabatic processes. Usually these +!! subroutines are called from the MOM_diabatic module. All of these routines use appropriate +!! limiters or logic to work properly with arbitrary layer thicknesses (including massless layers) +!! and an arbitrarily large timestep. +!! +!! The subroutine make_frazil facilitates the formation of frazil ice when the ocean water +!! drops below the in situ freezing point by heating the water to the freezing point and +!! accumulating the required heat for exchange with the sea-ice module. +!! +!! The subroutine adjust_salt adds salt as necessary to keep the salinity above a +!! specified minimum value, and keeps track of the cumulative additions. If the minimum +!! salinity is the natural value of 0, this routine should never do anything. +!! +!! The subroutine differential_diffuse_T_S solves a pair of tridiagonal equations for +!! the diffusion of temperatures and salinities with differing diffusivities. +!! +!! The subroutine triDiagTS solves a tridiagonal equations for the evolution of temperatures +!! and salinities due to net entrainment by layers and a diffusion with the same diffusivity. +!! +!! The subroutine triDiagTS_Eulerian solves a tridiagonal equations for the evolution of +!! temperatures and salinities due to diffusion with the same diffusivity, but no net entrainment. +!! +!! The subroutine find_uv_at_h interpolates velocities to thickness points, optionally also +!! using tridiagonal equations to solve for the impacts of net entrainment or mixing of +!! momentum between layers. +!! +!! The subroutine set_pen_shortwave determines the optical properties of the water column and +!! the net shortwave fluxes, and stores them in the optics type, working via calls to set_opacity. +!! +!! The subroutine diagnoseMLDbyDensityDifference diagnoses a mixed layer depth based on a +!! density difference criterion, and may also estimate the stratification of the water below +!! this diagnosed mixed layer. +!! +!! The subroutine diagnoseMLDbyEnergy diagnoses a mixed layer depth based on a mixing-energy +!! criterion, as described by Reichl et al., 2022, JGR: Oceans, doi:10.1029/2021JC018140. +!! +!! The subroutine applyBoundaryFluxesInOut updates the layer thicknesses, temperatures and +!! salinities due to the application of the surface forcing. It may also calculate the implied +!! turbulent kinetic energy requirements for this forcing to be mixed over the model's finite +!! vertical resolution in the surface layers. + +end module MOM_diabatic_aux diff --git a/parameterizations/vertical/MOM_diabatic_driver.F90 b/parameterizations/vertical/MOM_diabatic_driver.F90 new file mode 100644 index 0000000000..081f065f3e --- /dev/null +++ b/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -0,0 +1,3674 @@ +!> This routine drives the diabatic/dianeutral physics for MOM +module MOM_diabatic_driver + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_bulk_mixed_layer, only : bulkmixedlayer, bulkmixedlayer_init, bulkmixedlayer_CS +use MOM_debugging, only : hchksum +use MOM_checksum_packages, only : MOM_state_chksum, MOM_state_stats +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_CVMix_shear, only : CVMix_shear_is_used +use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used +use MOM_diabatic_aux, only : diabatic_aux_init, diabatic_aux_end, diabatic_aux_CS +use MOM_diabatic_aux, only : make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS +use MOM_diabatic_aux, only : triDiagTS_Eulerian, find_uv_at_h +use MOM_diabatic_aux, only : applyBoundaryFluxesInOut, set_pen_shortwave +use MOM_diabatic_aux, only : diagnoseMLDbyDensityDifference, diagnoseMLDbyEnergy +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : post_product_sum_u, post_product_sum_v +use MOM_diag_mediator, only : diag_ctrl, time_type, diag_update_remap_grids +use MOM_diag_mediator, only : diag_ctrl, query_averaging_enabled, enable_averages, disable_averaging +use MOM_diag_mediator, only : diag_grid_storage, diag_grid_storage_init, diag_grid_storage_end +use MOM_diag_mediator, only : diag_copy_diag_to_storage, diag_copy_storage_to_diag +use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids +use MOM_diapyc_energy_req, only : diapyc_energy_req_init, diapyc_energy_req_end +use MOM_diapyc_energy_req, only : diapyc_energy_req_calc, diapyc_energy_req_test, diapyc_energy_req_CS +use MOM_CVMix_conv, only : CVMix_conv_init, CVMix_conv_cs +use MOM_CVMix_conv, only : calculate_CVMix_conv +use MOM_domains, only : pass_var, To_West, To_South, To_All, Omit_Corners +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_energetic_PBL, only : energetic_PBL, energetic_PBL_init +use MOM_energetic_PBL, only : energetic_PBL_end, energetic_PBL_CS +use MOM_energetic_PBL, only : energetic_PBL_get_MLD +use MOM_entrain_diffusive, only : entrainment_diffusive, entrain_diffusive_init +use MOM_entrain_diffusive, only : entrain_diffusive_CS +use MOM_EOS, only : calculate_density, calculate_TFreeze, EOS_domain +use MOM_error_handler, only : MOM_error, FATAL, WARNING, callTree_showQuery,MOM_mesg +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_version, param_file_type, read_param +use MOM_forcing_type, only : forcing, MOM_forcing_chksum, find_ustar +use MOM_forcing_type, only : calculateBuoyancyFlux2d, forcing_SinglePointPrint +use MOM_geothermal, only : geothermal_entraining, geothermal_in_place +use MOM_geothermal, only : geothermal_init, geothermal_end, geothermal_CS +use MOM_grid, only : ocean_grid_type +use MOM_int_tide_input, only : set_int_tide_input, int_tide_input_init +use MOM_int_tide_input, only : int_tide_input_end, int_tide_input_CS, int_tide_input_type +use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz +use MOM_internal_tides, only : propagate_int_tide, register_int_tide_restarts +use MOM_internal_tides, only : internal_tides_init, internal_tides_end, int_tide_CS +use MOM_kappa_shear, only : kappa_shear_is_used +use MOM_CVMix_KPP, only : KPP_CS, KPP_init, KPP_compute_BLD, KPP_calculate +use MOM_CVMix_KPP, only : KPP_end, KPP_get_BLD +use MOM_CVMix_KPP, only : KPP_NonLocalTransport_temp, KPP_NonLocalTransport_saln +use MOM_oda_incupd, only : apply_oda_incupd, oda_incupd_CS +use MOM_opacity, only : opacity_init, opacity_end, opacity_CS +use MOM_opacity, only : absorbRemainingSW, optics_type, optics_nbands +use MOM_open_boundary, only : ocean_OBC_type +use MOM_regularize_layers, only : regularize_layers, regularize_layers_init, regularize_layers_CS +use MOM_restart, only : MOM_restart_CS +use MOM_set_diffusivity, only : set_diffusivity, set_BBL_TKE +use MOM_set_diffusivity, only : set_diffusivity_init, set_diffusivity_end +use MOM_set_diffusivity, only : set_diffusivity_CS +use MOM_sponge, only : apply_sponge, sponge_CS +use MOM_ALE_sponge, only : apply_ALE_sponge, ALE_sponge_CS +use MOM_time_manager, only : time_type, real_to_time, operator(-), operator(<=) +use MOM_tracer_flow_control, only : call_tracer_column_fns, tracer_flow_control_CS +use MOM_tracer_diabatic, only : tracer_vertdiff, tracer_vertdiff_Eulerian +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs +use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units +use MOM_wave_interface, only : wave_parameters_CS +use MOM_stochastics, only : stochastic_CS + +implicit none ; private + +#include + +public diabatic +public diabatic_driver_init +public diabatic_driver_end +public extract_diabatic_member +public adiabatic +public adiabatic_driver_init +public register_diabatic_restarts + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure for this module +type, public :: diabatic_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + + logical :: use_legacy_diabatic !< If true (default), use a legacy version of the diabatic + !! algorithm. This is temporary and is needed to avoid change + !! in answers. + logical :: use_bulkmixedlayer !< If true, a refined bulk mixed layer is used with + !! nkml sublayers (and additional buffer layers). + logical :: use_energetic_PBL !< If true, use the implicit energetics planetary + !! boundary layer scheme to determine the diffusivity + !! in the surface boundary layer. + logical :: use_KPP !< If true, use CVMix/KPP boundary layer scheme to determine the + !! OBLD and the diffusivities within this layer. + logical :: use_kappa_shear !< If true, use the kappa_shear module to find the + !! shear-driven diapycnal diffusivity. + logical :: use_CVMix_shear !< If true, use the CVMix module to find the + !! shear-driven diapycnal diffusivity. + logical :: use_CVMix_ddiff !< If true, use the CVMix double diffusion module. + logical :: use_CVMix_conv !< If true, use the CVMix module to get enhanced + !! mixing due to convection. + logical :: double_diffuse !< If true, some form of double-diffusive mixing is used. + logical :: use_sponge !< If true, sponges may be applied anywhere in the + !! domain. The exact location and properties of + !! those sponges are set by calls to + !! initialize_sponge and set_up_sponge_field. + logical :: use_oda_incupd !< If True, DA incremental update is + !! applied everywhere + logical :: use_geothermal !< If true, apply geothermal heating. + logical :: use_int_tides !< If true, use the code that advances a separate set + !! of equations for the internal tide energy density. + logical :: ePBL_is_additive !< If true, the diffusivity from ePBL is added to all + !! other diffusivities. Otherwise, the larger of kappa- + !! shear and ePBL diffusivities are used. + real :: ePBL_Prandtl !< The Prandtl number used by ePBL to convert vertical + !! diffusivities into viscosities [nondim]. + logical :: useALEalgorithm !< If true, use the ALE algorithm rather than layered + !! isopycnal/stacked shallow water mode. This logical + !! passed by argument to diabatic_driver_init. + logical :: aggregate_FW_forcing !< Determines whether net incoming/outgoing surface + !! FW fluxes are applied separately or combined before + !! being applied. + real :: ML_mix_first !< The nondimensional fraction of the mixed layer + !! algorithm that is applied before diffusive mixing [nondim]. + !! The default is 0, while 0.5 gives Strang splitting + !! and 1 is a sensible value too. Note that if there + !! are convective instabilities in the initial state, + !! the first call may do much more than the second. + integer :: NKBL !< The number of buffer layers (if bulk_mixed_layer) + logical :: massless_match_targets !< If true (the default), keep the T & S + !! consistent with the target values. + logical :: mix_boundary_tracers !< If true, mix the passive tracers in massless layers at the + !! bottom into the interior as though a diffusivity of + !! Kd_min_tr (see below) were operating. + logical :: mix_boundary_tracer_ALE !< If true, in ALE mode mix the passive tracers in massless + !! layers at the bottom into the interior as though a + !! diffusivity of Kd_min_tr (see below) were operating. + real :: Kd_BBL_tr !< A bottom boundary layer tracer diffusivity that + !! will allow for explicitly specified bottom fluxes + !! [H2 T-1 ~> m2 s-1 or kg2 m-4 s-2]. The entrainment at the + !! bottom is at least sqrt(Kd_BBL_tr*dt) over the same distance. + real :: Kd_min_tr !< A minimal diffusivity that should always be + !! applied to tracers, especially in massless layers + !! near the bottom [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: minimum_forcing_depth !< The smallest depth over which heat and freshwater + !! fluxes are applied [H ~> m or kg m-2]. + real :: evap_CFL_limit = 0.8 !< The largest fraction of a layer that can be + !! evaporated in one time-step [nondim]. + integer :: halo_TS_diff = 0 !< The temperature, salinity and thickness halo size that + !! must be valid for the diffusivity calculations. + integer :: halo_diabatic = 0 !< The temperature, salinity, specific volume and thickness + !! halo size that must be valid for the diabatic calculations, + !! including vertical mixing and internal tide propagation. + logical :: useKPP = .false. !< use CVMix/KPP diffusivities and non-local transport + logical :: KPPisPassive !< If true, KPP is in passive mode, not changing answers. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: debugConservation !< If true, monitor conservation and extrema. + logical :: tracer_tridiag !< If true, use tracer_vertdiff instead of tridiagTS for + !< vertical diffusion of T and S + logical :: debug_energy_req !< If true, test the mixing energy requirement code. + type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output + real :: MLDdensityDifference !< Density difference used to determine MLD_user [R ~> kg m-3] + real :: dz_subML_N2 !< The distance over which to calculate a diagnostic of the + !! average stratification at the base of the mixed layer [Z ~> m]. + real :: MLD_En_vals(3) !< Energy values for energy mixed layer diagnostics [R Z3 T-2 ~> J m-2] + + !>@{ Diagnostic IDs + integer :: id_ea = -1, id_eb = -1 ! used by layer diabatic + integer :: id_ea_t = -1, id_eb_t = -1, id_ea_s = -1, id_eb_s = -1 + integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_int = -1, id_Kd_ePBL = -1 + integer :: id_Tdif = -1, id_Sdif = -1, id_Tadv = -1, id_Sadv = -1 + ! These are handles to diagnostics related to the mixed layer properties. + integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 + integer :: id_MLD_EN1 = -1, id_MLD_EN2 = -1, id_MLD_EN3 = -1, id_subMLN2 = -1 + + ! These are handles to diagnostics that are only available in non-ALE layered mode. + integer :: id_wd = -1 + integer :: id_dudt_dia = -1, id_dvdt_dia = -1 + integer :: id_hf_dudt_dia_2d = -1, id_hf_dvdt_dia_2d = -1 + + ! diagnostic for fields prior to applying diapycnal physics + integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 + integer :: id_T_predia = -1, id_S_predia = -1, id_e_predia = -1 + + integer :: id_diabatic_diff_temp_tend = -1 + integer :: id_diabatic_diff_saln_tend = -1 + integer :: id_diabatic_diff_heat_tend = -1 + integer :: id_diabatic_diff_salt_tend = -1 + integer :: id_diabatic_diff_heat_tend_2d = -1 + integer :: id_diabatic_diff_salt_tend_2d = -1 + integer :: id_diabatic_diff_h = -1 + + integer :: id_boundary_forcing_h = -1 + integer :: id_boundary_forcing_h_tendency = -1 + integer :: id_boundary_forcing_temp_tend = -1 + integer :: id_boundary_forcing_saln_tend = -1 + integer :: id_boundary_forcing_heat_tend = -1 + integer :: id_boundary_forcing_salt_tend = -1 + integer :: id_boundary_forcing_heat_tend_2d = -1 + integer :: id_boundary_forcing_salt_tend_2d = -1 + + integer :: id_frazil_h = -1 + integer :: id_frazil_temp_tend = -1 + integer :: id_frazil_heat_tend = -1 + integer :: id_frazil_heat_tend_2d = -1 + !>@} + + logical :: diabatic_diff_tendency_diag = .false. !< If true calculate diffusive tendency diagnostics + logical :: boundary_forcing_tendency_diag = .false. !< If true calculate frazil diagnostics + logical :: frazil_tendency_diag = .false. !< If true calculate frazil tendency diagnostics + + type(diabatic_aux_CS), pointer :: diabatic_aux_CSp => NULL() !< Control structure for a child module + type(int_tide_input_CS), pointer :: int_tide_input_CSp => NULL() !< Control structure for a child module + type(int_tide_input_type), pointer :: int_tide_input => NULL() !< Control structure for a child module + type(set_diffusivity_CS), pointer :: set_diff_CSp => NULL() !< Control structure for a child module + type(sponge_CS), pointer :: sponge_CSp => NULL() !< Control structure for a child module + type(ALE_sponge_CS), pointer :: ALE_sponge_CSp => NULL() !< Control structure for a child module + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() !< Control structure for a child module + type(optics_type), pointer :: optics => NULL() !< Control structure for a child module + type(KPP_CS), pointer :: KPP_CSp => NULL() !< Control structure for a child module + type(diapyc_energy_req_CS), pointer :: diapyc_en_rec_CSp => NULL() !< Control structure for a child module + type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() !< Control structure for a child module + type(int_tide_CS), pointer :: int_tide_CSp => NULL() !< Control structure for a child module + + type(bulkmixedlayer_CS) :: bulkmixedlayer !< Bulk mixed layer control structure + type(CVMix_conv_CS) :: CVMix_conv !< CVMix convection control structure + type(energetic_PBL_CS) :: ePBL !< Energetic PBL control structure + type(entrain_diffusive_CS) :: entrain_diffusive !< Diffusive entrainment control structure + type(geothermal_CS) :: geothermal !< Geothermal control structure + type(opacity_CS) :: opacity !< Opacity control structure + type(regularize_layers_CS) :: regularize_layers !< Regularize layer control structure + + type(group_pass_type) :: pass_hold_eb_ea !< For group halo pass + type(group_pass_type) :: pass_Kv !< For group halo pass + type(diag_grid_storage) :: diag_grids_prev!< Stores diagnostic grids at some previous point in the algorithm + ! Data arrays for communicating between components + !### Why are these arrays in this control structure, and not local variables in the various routines? + real, allocatable, dimension(:,:,:) :: KPP_NLTheat !< KPP non-local transport for heat [nondim] + real, allocatable, dimension(:,:,:) :: KPP_NLTscalar !< KPP non-local transport for scalars [nondim] + real, allocatable, dimension(:,:,:) :: KPP_buoy_flux !< KPP forcing buoyancy flux [L2 T-3 ~> m2 s-3] + real, allocatable, dimension(:,:) :: KPP_temp_flux !< KPP effective temperature flux + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real, allocatable, dimension(:,:) :: KPP_salt_flux !< KPP effective salt flux + !! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + + type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) +end type diabatic_CS + +!>@{ clock ids +integer :: id_clock_entrain, id_clock_mixedlayer, id_clock_set_diffusivity +integer :: id_clock_tracers, id_clock_tridiag, id_clock_pass, id_clock_sponge +integer :: id_clock_geothermal, id_clock_differential_diff, id_clock_remap +integer :: id_clock_kpp, id_clock_oda_incupd +!>@} + +contains + +!> This subroutine imposes the diapycnal mass fluxes and the +!! accompanying diapycnal advection of momentum and tracers. +subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, stoch_CS, OBC, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + !! unused have NULL ptrs + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + type(forcing), intent(inout) :: fluxes !< points to forcing fields + !! unused fields have NULL ptrs + type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, + !! BBL properties and related fields + type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum + !! equations, to enable the later derived + !! diagnostics, like energy budgets + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diabatic_CS), pointer :: CS !< module control structure + type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves + + ! local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + eta ! Interface heights before diapycnal mixing [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: temp_diag ! Previous temperature for diagnostics [C ~> degC] + real, dimension(SZI_(G)) :: T_freeze, & ! The freezing potential temperature at the current salinity [C ~> degC]. + ps ! Surface pressure [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZK_(GV)) :: & + pressure ! The pressure at the middle of each layer [R L2 T-2 ~> Pa]. + real :: H_to_RL2_T2 ! A conversion factor from thicknesses in H to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] + integer :: i, j, k, m, is, ie, js, je, nz + logical :: showCallTree ! If true, show the call tree + + real, allocatable, dimension(:,:,:) :: h_in ! thickness before thermodynamics [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: t_in ! temperature before thermodynamics [C ~> degC] + real, allocatable, dimension(:,:,:) :: s_in ! salinity before thermodynamics [S ~> ppt] + + if (GV%ke == 1) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "Module must be initialized before it is used.") + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "Module must be initialized before it is used.") + + if (dt == 0.0) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "diabatic was called with a zero length timestep.") + if (dt < 0.0) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "diabatic was called with a negative timestep.") + + showCallTree = callTree_showQuery() + + ! Offer diagnostics of various state variables at the start of diabatic + ! these are mostly for debugging purposes. + if (CS%id_u_predia > 0) call post_data(CS%id_u_predia, u, CS%diag) + if (CS%id_v_predia > 0) call post_data(CS%id_v_predia, v, CS%diag) + if (CS%id_h_predia > 0) call post_data(CS%id_h_predia, h, CS%diag) + if (CS%id_T_predia > 0) call post_data(CS%id_T_predia, tv%T, CS%diag) + if (CS%id_S_predia > 0) call post_data(CS%id_S_predia, tv%S, CS%diag) + if (CS%id_e_predia > 0) then + call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref) + call post_data(CS%id_e_predia, eta, CS%diag) + endif + + ! Save a copy of the initial state if stochastic perturbations are active. + if (stoch_CS%do_sppt) then + allocate(h_in(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ; h_in(:,:,:) = h(:,:,:) + allocate(t_in(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ; t_in(:,:,:) = tv%T(:,:,:) + allocate(s_in(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ; s_in(:,:,:) = tv%S(:,:,:) + endif + + if (CS%debug) then + call MOM_state_chksum("Start of diabatic ", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("Start of diabatic", fluxes, G, US, haloshift=0) + endif + if (CS%debugConservation) call MOM_state_stats('Start of diabatic', u, v, h, tv%T, tv%S, G, GV, US) + + if (CS%debug_energy_req) & + call diapyc_energy_req_test(h, dt, tv, G, GV, US, CS%diapyc_en_rec_CSp) + + call cpu_clock_begin(id_clock_set_diffusivity) + call set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS%set_diff_CSp, OBC=OBC) + call cpu_clock_end(id_clock_set_diffusivity) + + ! Frazil formation keeps the temperature above the freezing point. + ! make_frazil is deliberately called at both the beginning and at + ! the end of the diabatic processes. + if (associated(tv%T) .AND. associated(tv%frazil)) then + ! For frazil diagnostic, the first call covers the first half of the time step + call enable_averages(0.5*dt, Time_end - real_to_time(0.5*US%T_to_s*dt), CS%diag) + if (CS%frazil_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + enddo ; enddo ; enddo + endif + + if (associated(fluxes%p_surf_full)) then + call make_frazil(h, tv, G, GV, US, CS%diabatic_aux_CSp, fluxes%p_surf_full, halo=CS%halo_TS_diff) + else + call make_frazil(h, tv, G, GV, US, CS%diabatic_aux_CSp, halo=CS%halo_TS_diff) + endif + if (showCallTree) call callTree_waypoint("done with 1st make_frazil (diabatic)") + + if (CS%frazil_tendency_diag) then + call diagnose_frazil_tendency(tv, h, temp_diag, 0.5*dt, G, GV, US, CS) + if (CS%id_frazil_h > 0) call post_data(CS%id_frazil_h, h, CS%diag) + endif + call disable_averaging(CS%diag) + endif ! associated(tv%T) .AND. associated(tv%frazil) + if (CS%debugConservation) call MOM_state_stats('1st make_frazil', u, v, h, tv%T, tv%S, G, GV, US) + + if (CS%use_int_tides) then + ! This block provides an interface for the unresolved low-mode internal tide module. + call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & + CS%int_tide_input_CSp) + + call propagate_int_tide(h, tv, CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, & + G, GV, US, CS%int_tide_input_CSp, CS%int_tide_CSp) + + if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") + endif ! end CS%use_int_tides + + if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then + call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, stoch_CS, Waves) + elseif (CS%useALEalgorithm) then + call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, stoch_CS, Waves) + else + call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves) + endif + + + call cpu_clock_begin(id_clock_pass) + if (associated(visc%Kv_shear)) & + call pass_var(visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) + call cpu_clock_end(id_clock_pass) + + call disable_averaging(CS%diag) + ! Frazil formation keeps temperature above the freezing point. + ! make_frazil is deliberately called at both the beginning and at + ! the end of the diabatic processes. + if (associated(tv%T) .AND. associated(tv%frazil)) then + call enable_averages(0.5*dt, Time_end, CS%diag) + if (CS%frazil_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + enddo ; enddo ; enddo + endif + + if (associated(fluxes%p_surf_full)) then + call make_frazil(h, tv, G, GV, US, CS%diabatic_aux_CSp, fluxes%p_surf_full) + else + call make_frazil(h, tv, G, GV, US, CS%diabatic_aux_CSp) + endif + + if (CS%frazil_tendency_diag) then + call diagnose_frazil_tendency(tv, h, temp_diag, 0.5*dt, G, GV, US, CS) + if (CS%id_frazil_h > 0 ) call post_data(CS%id_frazil_h, h, CS%diag) + endif + + if (showCallTree) call callTree_waypoint("done with 2nd make_frazil (diabatic)") + if (CS%debugConservation) call MOM_state_stats('2nd make_frazil', u, v, h, tv%T, tv%S, G, GV, US) + call disable_averaging(CS%diag) + + endif ! endif for frazil + + if (stoch_CS%do_sppt) then + ! perturb diabatic tendencies. + ! These stochastic perturbations do not conserve heat, salt or mass. + do k=1,nz; do j=js,je; do i=is,ie + h(i,j,k) = max(h_in(i,j,k) + (h(i,j,k)-h_in(i,j,k)) * stoch_CS%sppt_wts(i,j), GV%Angstrom_H) + tv%S(i,j,k) = max(s_in(i,j,k) + (tv%S(i,j,k)-s_in(i,j,k)) * stoch_CS%sppt_wts(i,j), 0.0) + enddo; enddo; enddo + ! now that we have updated thickness and salinity, calculate freeing point + H_to_RL2_T2 = GV%H_to_RZ * GV%g_Earth + do j=js,je + ps(:) = 0.0 + if (associated(fluxes%p_surf)) then + do i=is,ie + ps(i) = fluxes%p_surf(i,j) + enddo + endif + + do i=is,ie + pressure(i,1) = ps(i) + (0.5*H_to_RL2_T2)*h(i,j,1) + enddo + do k=2,nz ; do i=is,ie + pressure(i,k) = pressure(i,k-1) + & + (0.5*H_to_RL2_T2) * (h(i,j,k) + h(i,j,k-1)) + enddo ; enddo + do k=1,nz + call calculate_TFreeze(tv%S(is:ie,j,k), pressure(is:ie,k), T_freeze(is:ie), & + tv%eqn_of_state) + do i=is,ie + tv%T(i,j,k) = max(t_in(i,j,k) + (tv%T(i,j,k)-t_in(i,j,k)) * stoch_CS%sppt_wts(i,j), T_freeze(i)) + enddo + enddo + enddo + + deallocate(h_in, t_in, s_in) + endif + + ! Diagnose mixed layer depths. + call enable_averages(dt, Time_end, CS%diag) + if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then + call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03*US%kg_m3_to_R, G, GV, US, CS%diag, & + id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) + endif + if (CS%id_MLD_0125 > 0) then + call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125*US%kg_m3_to_R, G, GV, US, CS%diag) + endif + if (CS%id_MLD_user > 0) then + call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, US, CS%diag) + endif + if ((CS%id_MLD_EN1 > 0) .or. (CS%id_MLD_EN2 > 0) .or. (CS%id_MLD_EN3 > 0)) then + call diagnoseMLDbyEnergy((/CS%id_MLD_EN1, CS%id_MLD_EN2, CS%id_MLD_EN3/),& + h, tv, G, GV, US, CS%MLD_En_vals, CS%diag) + endif + + if (stoch_CS%do_sppt .and. stoch_CS%id_sppt_wts > 0) & + call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) + + call disable_averaging(CS%diag) + + if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) + +end subroutine diabatic + + +!> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use +!! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. +subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, stoch_CS, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + !! unused have NULL ptrs + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + type(forcing), intent(inout) :: fluxes !< points to forcing fields + !! unused fields have NULL ptrs + type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, + !! BBL properties and related fields + type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum + !! equations, to enable the later derived + !! diagnostics, like energy budgets + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure + type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves + + ! local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + h_orig, & ! Initial layer thicknesses [H ~> m or kg m-2] + dz, & ! The vertical distance between interfaces around a layer [Z ~> m] + dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + cTKE, & ! convective TKE requirements for each layer [R Z3 T-2 ~> J m-2]. + u_h, & ! Zonal velocities interpolated to thickness points [L T-1 ~> m s-1] + v_h, & ! Meridional velocities interpolated to thickness points [L T-1 ~> m s-1] + temp_diag, & ! Diagnostic array of previous temperatures [C ~> degC] + saln_diag ! Diagnostic array of previous salinity [S ~> ppt] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + ent_s, & ! The diffusive coupling across interfaces within one time step for + ! salinity and passive tracers [H ~> m or kg m-2] + ent_t, & ! The diffusive coupling across interfaces within one time step for + ! temperature [H ~> m or kg m-2] + Kd_int, & ! diapycnal diffusivity of interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_heat, & ! diapycnal diffusivity of heat [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_extra_T , & ! The extra diffusivity of temperature due to double diffusion relative to + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Sdif_flx ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + + real, dimension(SZI_(G),SZJ_(G)) :: & + U_star, & ! The friction velocity [Z T-1 ~> m s-1]. + SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + + logical, dimension(SZI_(G)) :: & + in_boundary ! True if there are no massive layers below, where massive is defined as + ! sufficiently thick that the no-flux boundary conditions have not restricted + ! the entrainment - usually sqrt(Kd*dt). + + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] + real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] + real :: I_dzval ! The inverse of the thicknesses averaged to interfaces [Z-1 ~> m-1] + real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is + ! coupled to the bottom within a timestep [H ~> m or kg m-2] + real :: Kd_add_here ! An added diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. + + real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] + real :: Idt ! The inverse time step [T-1 ~> s-1] + + logical :: showCallTree ! If true, show the call tree + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + + 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 + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect + + Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 + + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("diabatic_ALE_legacy(), MOM_diabatic_driver.F90") + + ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep + call enable_averages(dt, Time_end, CS%diag) + + if (CS%use_geothermal) then + call cpu_clock_begin(id_clock_geothermal) + call geothermal_in_place(h, tv, dt, G, GV, US, CS%geothermal, halo=CS%halo_TS_diff) + call cpu_clock_end(id_clock_geothermal) + if (showCallTree) call callTree_waypoint("geothermal (diabatic)") + if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G, GV, US) + endif + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! Set_pen_shortwave estimates the optical properties of the water column. + ! It will need to be modified later to include information about the + ! biological properties and layer thicknesses. + if (associated(CS%optics)) & + call set_pen_shortwave(CS%optics, fluxes, G, GV, US, CS%diabatic_aux_CSp, CS%opacity, CS%tracer_flow_CSp) + + if (CS%debug) call MOM_state_chksum("before find_uv_at_h", u, v, h, G, GV, US, haloshift=0) + + if (CS%use_kappa_shear .or. CS%use_CVMix_shear) then + if (CS%use_geothermal) then + call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, zero_mix=.true.) + else + call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) + endif + if (showCallTree) call callTree_waypoint("done with find_uv_at_h (diabatic)") + endif + + call cpu_clock_begin(id_clock_set_diffusivity) + ! Sets: Kd_int, Kd_extra_T, Kd_extra_S and visc%TKE_turb + ! Also changes: visc%Kd_shear, visc%Kv_shear and visc%Kv_slow + if (CS%debug) & + call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) + if (CS%double_diffuse) then + call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, Kd_int, G, GV, US, & + CS%set_diff_CSp, Kd_extra_T=Kd_extra_T, Kd_extra_S=Kd_extra_S) + else + call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, Kd_int, G, GV, US, & + CS%set_diff_CSp) + endif + call cpu_clock_end(id_clock_set_diffusivity) + if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") + + + if (CS%debug) then + call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + + ! Set diffusivities for heat and salt separately + if (CS%useKPP) then + ! Add contribution from double diffusion + if (CS%double_diffuse) then + !$OMP parallel do default(shared) + do K=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_salt(i,j,K) = Kd_int(i,j,K) + Kd_extra_S(i,j,K) + Kd_heat(i,j,K) = Kd_int(i,j,K) + Kd_extra_T(i,j,K) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do K=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_salt(i,j,K) = Kd_int(i,j,K) + Kd_heat(i,j,K) = Kd_int(i,j,K) + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after set_diffusivity Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + + call cpu_clock_begin(id_clock_kpp) + ! total vertical viscosity in the interior is represented via visc%Kv_shear + + ! KPP needs the surface buoyancy flux but does not update state variables. + ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. + ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux + ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) + ! unlike other instances where the fluxes are integrated in time over a time-step. + call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & + CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + + ! Determine the friction velocity, perhaps using the evovling surface density. + call find_ustar(fluxes, tv, U_star, G, GV, US) + + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. + if ( associated(fluxes%lamult) ) then + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & + U_star, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) + else + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & + U_star, CS%KPP_buoy_flux, Waves=Waves) + + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) + endif + + if (associated(Hml)) then + call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US) + call pass_var(Hml, G%domain, halo=1) + ! If visc%MLD exists, copy KPP's BLD into it + if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) + endif + if (associated(visc%sfc_buoy_flx)) then + visc%sfc_buoy_flx(:,:) = CS%KPP_buoy_flux(:,:,1) + call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) + endif + + if (.not.CS%KPPisPassive) then + !$OMP parallel do default(shared) + do K=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_int(i,j,K) = min( Kd_salt(i,j,K), Kd_heat(i,j,K) ) + enddo ; enddo ; enddo + if (CS%double_diffuse) then + !$OMP parallel do default(shared) + do K=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_extra_S(i,j,K) = (Kd_salt(i,j,K) - Kd_int(i,j,K)) + Kd_extra_T(i,j,K) = (Kd_heat(i,j,K) - Kd_int(i,j,K)) + enddo ; enddo ; enddo + endif + endif ! not passive + + if (showCallTree) call callTree_waypoint("done with KPP_calculate (diabatic)") + if (CS%debug) then + call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after KPP", tv, G, US) + call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & + scale=US%C_to_degC*GV%H_to_m*US%s_to_T) + call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & + scale=US%S_to_ppt*GV%H_to_m*US%s_to_T) + call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) + call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) + endif + ! Apply non-local transport of heat and salt + ! Changes: tv%T, tv%S + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, & + dt, tv%tr_T, tv%T, tv%C_p) + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & + dt, tv%tr_S, tv%S) + call cpu_clock_end(id_clock_kpp) + if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") + if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G, GV, US) + + if (CS%debug) then + call MOM_state_chksum("after KPP_applyNLT ", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("after KPP_applyNLT ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after KPP_applyNLT ", tv, G, US) + endif + if (.not.associated(fluxes%KPP_salt_flux)) fluxes%KPP_salt_flux => CS%KPP_salt_flux + endif ! endif for KPP + + ! This is the "old" method for applying differential diffusion. + ! Changes: tv%T, tv%S + if (CS%double_diffuse .and. associated(tv%T)) then + + call cpu_clock_begin(id_clock_differential_diff) + call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, tv, dt, G, GV) + call cpu_clock_end(id_clock_differential_diff) + + if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") + if (CS%debugConservation) call MOM_state_stats('differential_diffuse_T_S', u, v, h, tv%T, tv%S, G, GV, US) + + ! increment heat and salt diffusivity. + ! CS%useKPP==.true. already has extra_T and extra_S included + if (.not. CS%useKPP) then + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_extra_T(i,j,K) + Kd_salt(i,j,K) = Kd_salt(i,j,K) + Kd_extra_S(i,j,K) + enddo ; enddo ; enddo + endif + + endif + + ! Calculate vertical mixing due to convection (computed via CVMix) + if (CS%use_CVMix_conv) then + ! Increment vertical diffusion and viscosity due to convection + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, Hml, Kd_int, visc%Kv_shear) + endif + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US) + + ! This block sets ent_t and ent_s from h and Kd_int. + do j=js,je ; do i=is,ie + ent_s(i,j,1) = 0.0 ; ent_s(i,j,nz+1) = 0.0 + ent_t(i,j,1) = 0.0 ; ent_t(i,j,nz+1) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) private(I_dzval) + do K=2,nz ; do j=js,je ; do i=is,ie + I_dzval = 1.0 / (dz_neglect + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + ent_s(i,j,K) = dt * I_dzval * Kd_int(i,j,K) + ent_t(i,j,K) = ent_s(i,j,K) + enddo ; enddo ; enddo + if (showCallTree) call callTree_waypoint("done setting ent_s and ent_t from Kd_int (diabatic)") + + if (CS%debug) then + call MOM_forcing_chksum("after calc_entrain ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after calc_entrain ", tv, G, US) + call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, US, haloshift=0) + call hchksum(ent_s, "after calc_entrain ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + endif + + ! Save fields before boundary forcing is applied for tendency diagnostics + do k=1,nz ; do j=js,je ; do i=is,ie + h_orig(i,j,k) = h(i,j,k) + enddo ; enddo ; enddo + if (CS%boundary_forcing_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + ! Apply forcing + ! Changes made to following fields: h, tv%T and tv%S. + call cpu_clock_begin(id_clock_remap) + + if (CS%use_energetic_PBL) then + + skinbuoyflux(:,:) = 0.0 + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & + optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) + + if (CS%debug) then + call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_mks) + call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_mks) + call hchksum(cTKE, "after applyBoundaryFluxes cTKE", G%HI, haloshift=0, & + scale=US%RZ3_T3_to_W_m2*US%T_to_s) + call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, & + scale=US%kg_m3_to_R*US%degC_to_C) + call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, & + scale=US%kg_m3_to_R*US%ppt_to_S) + call hchksum(h, "after applyBoundaryFluxes h", G%HI, haloshift=0, scale=GV%H_to_mks) + call hchksum(tv%T, "after applyBoundaryFluxes tv%T", G%HI, haloshift=0, scale=US%C_to_degC) + call hchksum(tv%S, "after applyBoundaryFluxes tv%S", G%HI, haloshift=0, scale=US%S_to_ppt) + call hchksum(SkinBuoyFlux, "after applyBdryFlux SkinBuoyFlux", G%HI, haloshift=0, & + scale=US%Z_to_m**2*US%s_to_T**3) + endif + + call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) + call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & + CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + + if (associated(Hml)) then + call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) + call pass_var(Hml, G%domain, halo=1) + ! If visc%MLD exists, copy ePBL's MLD into it + if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) + elseif (associated(visc%MLD)) then + call energetic_PBL_get_MLD(CS%ePBL, visc%MLD, G, US) + call pass_var(visc%MLD, G%domain, halo=1) + endif + if (associated(visc%sfc_buoy_flx)) then + visc%sfc_buoy_flx(:,:) = SkinBuoyFlux(:,:) + call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) + endif + + ! Find the vertical distances across layers, which may have been modified by the net surface flux + call thickness_to_dz(h, tv, dz, G, GV, US) + + ! Augment the diffusivities and viscosity due to those diagnosed in energetic_PBL. + do K=2,nz ; do j=js,je ; do i=is,ie + if (CS%ePBL_is_additive) then + Kd_add_here = Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*Kd_ePBL(i,j,K) + else + Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) + endif + + Ent_int = Kd_add_here * dt / (0.5*(dz(i,j,k-1) + dz(i,j,k)) + dz_neglect) + ent_s(i,j,K) = ent_s(i,j,K) + Ent_int + Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_add_here + + ! for diagnostics + Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_int(i,j,K) + Kd_salt(i,j,K) = Kd_salt(i,j,K) + Kd_int(i,j,K) + + enddo ; enddo ; enddo + + if (CS%debug) then + call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + + else + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & + optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & + CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD=visc%MLD) + + ! Find the vertical distances across layers, which may have been modified by the net surface flux + call thickness_to_dz(h, tv, dz, G, GV, US) + + endif ! endif for CS%use_energetic_PBL + + ! diagnose the tendencies due to boundary forcing + ! At this point, the diagnostic grids have not been updated since the call to the boundary layer scheme + ! so all tendency diagnostics need to be posted on h_orig, and grids rebuilt afterwards + if (CS%boundary_forcing_tendency_diag) then + call diagnose_boundary_forcing_tendency(tv, h, temp_diag, saln_diag, h_orig, dt, G, GV, US, CS) + if (CS%id_boundary_forcing_h > 0) call post_data(CS%id_boundary_forcing_h, h, CS%diag, alt_h=h_orig) + endif + ! Boundary fluxes may have changed T, S, and h + call diag_update_remap_grids(CS%diag) + call cpu_clock_end(id_clock_remap) + if (CS%debug) then + call MOM_forcing_chksum("after applyBoundaryFluxes ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after applyBoundaryFluxes ", tv, G, US) + call MOM_state_chksum("after applyBoundaryFluxes ", u, v, h, G, GV, US, haloshift=0) + endif + if (showCallTree) call callTree_waypoint("done with applyBoundaryFluxes (diabatic)") + if (CS%debugConservation) call MOM_state_stats('applyBoundaryFluxes', u, v, h, tv%T, tv%S, G, GV, US) + + if (CS%debug) then + call MOM_state_chksum("after negative check ", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("after negative check ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after negative check ", tv, G, US) + endif + if (showCallTree) call callTree_waypoint("done with h=ea-eb (diabatic)") + if (CS%debugConservation) call MOM_state_stats('h=ea-eb', u, v, h, tv%T, tv%S, G, GV, US) + + ! calculate change in temperature & salinity due to dia-coordinate surface diffusion + if (associated(tv%T)) then + + if (CS%debug) then + call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, scale=GV%H_to_m) + endif + + call cpu_clock_begin(id_clock_tridiag) + ! Keep salinity from falling below a small but positive threshold. + ! This constraint is needed for SIS1 ice model, which can extract + ! more salt than is present in the ocean. SIS2 does not suffer + ! from this limitation, in which case we can let salinity=0 and still + ! have salt conserved with SIS2 ice. So for SIS2, we can run with + ! BOUND_SALINITY=False in MOM.F90. + if (associated(tv%S) .and. associated(tv%salt_deficit)) & + call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) + + if (CS%diabatic_diff_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + ! Changes T and S via the tridiagonal solver; no change to h + do k=1,nz ; do j=js,je ; do i=is,ie + ent_t(i,j,K) = ent_s(i,j,K) ; ent_t(i,j,K+1) = ent_s(i,j,K+1) + enddo ; enddo ; enddo + if (CS%tracer_tridiag) then + call tracer_vertdiff_Eulerian(h, ent_t, dt, tv%T, G, GV) + call tracer_vertdiff_Eulerian(h, ent_s, dt, tv%S, G, GV) + else + call triDiagTS_Eulerian(G, GV, is, ie, js, je, h, ent_s, tv%T, tv%S) + endif + + ! diagnose temperature, salinity, heat, and salt tendencies + if (CS%diabatic_diff_tendency_diag) then + call diagnose_diabatic_diff_tendency(tv, h, temp_diag, saln_diag, dt, G, GV, US, CS) + if (CS%id_diabatic_diff_h > 0) call post_data(CS%id_diabatic_diff_h, h, CS%diag, alt_h=h) + endif + + call cpu_clock_end(id_clock_tridiag) + + if (showCallTree) call callTree_waypoint("done with triDiagTS (diabatic)") + + endif ! endif corresponding to if (associated(tv%T)) + + if (CS%debugConservation) call MOM_state_stats('triDiagTS', u, v, h, tv%T, tv%S, G, GV, US) + + if (CS%debug) then + call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, US, haloshift=0) + call MOM_thermovar_chksum("after mixed layer ", tv, G, US) + endif + + ! Whenever thickness changes let the diag manager know, as the + ! target grids for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! Diagnose the diapycnal diffusivities and other related quantities. + if (CS%id_Kd_int > 0) call post_data(CS%id_Kd_int, Kd_int, CS%diag) + if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) + if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) + if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) + + if (CS%id_ea > 0) call post_data(CS%id_ea, ent_s(:,:,1:nz), CS%diag) + if (CS%id_eb > 0) call post_data(CS%id_eb, ent_s(:,:,2:nz+1), CS%diag) + if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ent_t(:,:,1:nz), CS%diag) + if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, ent_t(:,:,2:nz+1), CS%diag) + if (CS%id_ea_s > 0) call post_data(CS%id_ea_s, ent_s(:,:,1:nz), CS%diag) + if (CS%id_eb_s > 0) call post_data(CS%id_eb_s, ent_s(:,:,2:nz+1), CS%diag) + Idt = 1.0 / dt + if (CS%id_Tdif > 0) then + do j=js,je ; do i=is,ie + Tdif_flx(i,j,1) = 0.0 ; Tdif_flx(i,j,nz+1) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Tdif_flx(i,j,K) = (Idt * ent_t(i,j,K)) * (tv%T(i,j,k-1) - tv%T(i,j,k)) + enddo ; enddo ; enddo + if (CS%id_Tdif > 0) call post_data(CS%id_Tdif, Tdif_flx, CS%diag) + endif + if (CS%id_Sdif > 0) then + do j=js,je ; do i=is,ie + Sdif_flx(i,j,1) = 0.0 ; Sdif_flx(i,j,nz+1) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Sdif_flx(i,j,K) = (Idt * ent_s(i,j,K)) * (tv%S(i,j,k-1) - tv%S(i,j,k)) + enddo ; enddo ; enddo + if (CS%id_Sdif > 0) call post_data(CS%id_Sdif, Sdif_flx, CS%diag) + endif + + ! mixing of passive tracers from massless boundary layers to interior + call cpu_clock_begin(id_clock_tracers) + + if (CS%mix_boundary_tracer_ALE) then + Tr_ea_BBL = sqrt(dt * CS%Kd_BBL_tr) + + !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) + do j=js,je + do i=is,ie + htot(i) = 0.0 + in_boundary(i) = (G%mask2dT(i,j) > 0.0) + enddo + do k=nz,2,-1 ; do i=is,ie + if (in_boundary(i)) then + htot(i) = htot(i) + h(i,j,k) + ! If diapycnal mixing has been suppressed because this is a massless + ! layer near the bottom, add some mixing of tracers between these + ! layers. This flux is based on the harmonic mean of the two + ! thicknesses, as this corresponds pretty closely (to within + ! differences in the density jumps between layers) with what is done + ! in the calculation of the fluxes in the first place. Kd_min_tr + ! should be much less than the values that have been set in Kd_int, + ! perhaps a molecular diffusivity. + add_ent = ((dt * CS%Kd_min_tr)) * & + ((dz(i,j,k-1)+dz(i,j,k)+dz_neglect) / (dz(i,j,k-1)*dz(i,j,k)+dz_neglect2)) - & + 0.5*(ent_s(i,j,K) + ent_s(i,j,K)) + if (htot(i) < Tr_ea_BBL) then + add_ent = max(0.0, add_ent, (Tr_ea_BBL - htot(i)) - ent_s(i,j,K)) + elseif (add_ent < 0.0) then + add_ent = 0.0 ; in_boundary(i) = .false. + endif + + ent_s(i,j,K) = ent_s(i,j,K) + add_ent + endif + + if (CS%double_diffuse) then ; if (Kd_extra_S(i,j,k) > 0.0) then + add_ent = (dt * Kd_extra_S(i,j,k)) / & + (0.5 * (dz(i,j,k-1) + dz(i,j,k)) + dz_neglect) + ent_s(i,j,K) = ent_s(i,j,K) + add_ent + endif ; endif + enddo ; enddo + + enddo + elseif (CS%double_diffuse .and. .not.CS%mix_boundary_tracers) then ! extra diffusivity for passive tracers + !$OMP parallel do default(shared) private(add_ent) + do k=nz,2,-1 ; do j=js,je ; do i=is,ie + if (Kd_extra_S(i,j,k) > 0.0) then + add_ent = (dt * Kd_extra_S(i,j,k)) / & + (0.5 * (dz(i,j,k-1) + dz(i,j,k)) + dz_neglect) + else + add_ent = 0.0 + endif + ent_s(i,j,K) = ent_s(i,j,K) + add_ent + enddo ; enddo ; enddo + endif ! (CS%mix_boundary_tracers) + + ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied + call call_tracer_column_fns(h_orig, h, ent_s(:,:,1:nz), ent_s(:,:,2:nz+1), fluxes, Hml, dt, & + G, GV, US, tv, CS%optics, CS%tracer_flow_CSp, CS%debug, & + KPP_CSp=CS%KPP_CSp, & + nonLocalTrans=CS%KPP_NLTscalar, & + evap_CFL_limit=CS%evap_CFL_limit, & + minimum_forcing_depth=CS%minimum_forcing_depth) + + call cpu_clock_end(id_clock_tracers) + + ! Apply ALE sponge + if (CS%use_sponge .and. associated(CS%ALE_sponge_CSp)) then + call cpu_clock_begin(id_clock_sponge) + call apply_ALE_sponge(h, tv, dt, G, GV, US, CS%ALE_sponge_CSp, CS%Time) + call cpu_clock_end(id_clock_sponge) + if (CS%debug) then + call MOM_state_chksum("apply_sponge ", u, v, h, G, GV, US, haloshift=0) + call MOM_thermovar_chksum("apply_sponge ", tv, G, US) + endif + endif ! CS%use_sponge + + ! Apply data assimilation incremental update -oda_incupd- + if (CS%use_oda_incupd .and. associated(CS%oda_incupd_CSp)) then + call MOM_mesg("Starting ODA_INCUPD legacy ", 5) + call cpu_clock_begin(id_clock_oda_incupd) + call apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS%oda_incupd_CSp) + call cpu_clock_end(id_clock_oda_incupd) + if (CS%debug) then + call MOM_state_chksum("apply_oda_incupd ", u, v, h, G, GV, US, haloshift=0) + call MOM_thermovar_chksum("apply_oda_incupd ", tv, G, US) + endif + endif ! CS%use_oda_incupd + + + + call disable_averaging(CS%diag) + + if (showCallTree) call callTree_leave("diabatic_ALE_legacy()") + +end subroutine diabatic_ALE_legacy + + +!> This subroutine imposes the diapycnal mass fluxes and the +!! accompanying diapycnal advection of momentum and tracers. +subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, stoch_CS, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + !! unused have NULL ptrs + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + type(forcing), intent(inout) :: fluxes !< points to forcing fields + !! unused fields have NULL ptrs + type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, + !! BBL properties and related fields + type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum + !! equations, to enable the later derived + !! diagnostics, like energy budgets + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(stochastic_CS), pointer :: stoch_CS !< stochastic control structure + type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves + + ! local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + h_orig, & ! Initial layer thicknesses [H ~> m or kg m-2] + dz, & ! The vertical distance between interfaces around a layer [Z ~> m] + dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + cTKE, & ! convective TKE requirements for each layer [R Z3 T-2 ~> J m-2]. + u_h, & ! Zonal velocities interpolated to thickness points [L T-1 ~> m s-1] + v_h, & ! Meridional velocities interpolated to thickness points [L T-1 ~> m s-1] + temp_diag, & ! Diagnostic array of previous temperatures [C ~> degC] + saln_diag ! Diagnostic array of previous salinity [S ~> ppt] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + ent_s, & ! The diffusive coupling across interfaces within one time step for + ! salinity and passive tracers [H ~> m or kg m-2] + ent_t, & ! The diffusive coupling across interfaces within one time step for + ! temperature [H ~> m or kg m-2] + Kd_heat, & ! diapycnal diffusivity of heat or the smaller of the diapycnal diffusivities of + ! heat and salt [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_extra_T , & ! The extra diffusivity of temperature due to double diffusion relative to + ! Kd_int returned from set_diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to + ! Kd_int returned from set_diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_ePBL, & ! boundary layer or convective diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Sdif_flx ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + + real, dimension(SZI_(G),SZJ_(G)) :: & + U_star, & ! The friction velocity [Z T-1 ~> m s-1]. + SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + + logical, dimension(SZI_(G)) :: & + in_boundary ! True if there are no massive layers below, where massive is defined as + ! sufficiently thick that the no-flux boundary conditions have not restricted + ! the entrainment - usually sqrt(Kd*dt). + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] + real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] + real :: I_dzval ! The inverse of the thicknesses averaged to interfaces [Z-1 ~> m-1] + real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is + ! coupled to the bottom within a timestep [H ~> m or kg m-2] + real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. + real :: Kd_add_here ! An added diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: Idt ! The inverse time step [T-1 ~> s-1] + + logical :: showCallTree ! If true, show the call tree + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + + 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 + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect + + Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 + ent_s(:,:,:) = 0.0 ; ent_t(:,:,:) = 0.0 + + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("diabatic_ALE(), MOM_diabatic_driver.F90") + + if (.not. (CS%useALEalgorithm)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "The ALE algorithm must be enabled when using MOM_diabatic_driver.") + + ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep + call enable_averages(dt, Time_end, CS%diag) + + if (CS%use_geothermal) then + call cpu_clock_begin(id_clock_geothermal) + call geothermal_in_place(h, tv, dt, G, GV, US, CS%geothermal, halo=CS%halo_TS_diff) + call cpu_clock_end(id_clock_geothermal) + if (showCallTree) call callTree_waypoint("geothermal (diabatic)") + if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G, GV, US) + endif + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! Set_pen_shortwave estimates the optical properties of the water column. + ! It will need to be modified later to include information about the + ! biological properties and layer thicknesses. + if (associated(CS%optics)) & + call set_pen_shortwave(CS%optics, fluxes, G, GV, US, CS%diabatic_aux_CSp, CS%opacity, CS%tracer_flow_CSp) + + if (CS%debug) call MOM_state_chksum("before find_uv_at_h", u, v, h, G, GV, US, haloshift=0) + + if (CS%use_kappa_shear .or. CS%use_CVMix_shear) then + if (CS%use_geothermal) then + call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, zero_mix=.true.) + else + call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) + endif + if (showCallTree) call callTree_waypoint("done with find_uv_at_h (diabatic)") + endif + + call cpu_clock_begin(id_clock_set_diffusivity) + ! Sets: Kd_heat, Kd_extra_T, Kd_extra_S and visc%TKE_turb + ! Also changes: visc%Kd_shear, visc%Kv_shear and visc%Kv_slow + if (CS%debug) & + call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) + if (CS%double_diffuse) then + call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, Kd_heat, G, GV, US, & + CS%set_diff_CSp, Kd_extra_T=Kd_extra_T, Kd_extra_S=Kd_extra_S) + else + call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, Kd_heat, G, GV, US, & + CS%set_diff_CSp) + endif + call cpu_clock_end(id_clock_set_diffusivity) + if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") + + if (CS%debug) then + call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + + ! Store the diagnosed typical diffusivity at interfaces. + if (CS%id_Kd_int > 0) call post_data(CS%id_Kd_int, Kd_heat, CS%diag) + + ! Set diffusivities for heat and salt separately, and possibly change the meaning of Kd_heat. + if (CS%double_diffuse) then + ! Add contributions from double diffusion + !$OMP parallel do default(shared) + do K=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_salt(i,j,K) = Kd_heat(i,j,K) + Kd_extra_S(i,j,K) + Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_extra_T(i,j,K) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do K=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_salt(i,j,K) = Kd_heat(i,j,K) + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(Kd_heat, "after double diffuse Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after double diffuse Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + + if (CS%useKPP) then + call cpu_clock_begin(id_clock_kpp) + ! total vertical viscosity in the interior is represented via visc%Kv_shear + do k=1,nz+1 ; do j=js,je ; do i=is,ie + visc%Kv_shear(i,j,k) = visc%Kv_shear(i,j,k) + visc%Kv_slow(i,j,k) + enddo ; enddo ; enddo + + ! KPP needs the surface buoyancy flux but does not update state variables. + ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. + ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux + ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) + ! unlike other instances where the fluxes are integrated in time over a time-step. + call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & + CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + + ! Determine the friction velocity, perhaps using the evovling surface density. + call find_ustar(fluxes, tv, U_star, G, GV, US) + + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. + if ( associated(fluxes%lamult) ) then + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & + U_star, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) + else + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & + U_star, CS%KPP_buoy_flux, Waves=Waves) + + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) + endif + + if (associated(Hml)) then + call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US) + call pass_var(Hml, G%domain, halo=1) + ! If visc%MLD exists, copy KPP's BLD into it + if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) + endif + if (associated(visc%sfc_buoy_flx)) then + visc%sfc_buoy_flx(:,:) = CS%KPP_buoy_flux(:,:,1) + call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) + endif + + if (showCallTree) call callTree_waypoint("done with KPP_calculate (diabatic)") + if (CS%debug) then + call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after KPP", tv, G, US) + call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & + scale=US%C_to_degC*GV%H_to_m*US%s_to_T) + call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & + scale=US%S_to_ppt*GV%H_to_m*US%s_to_T) + call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) + call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) + endif + ! Apply non-local transport of heat and salt + ! Changes: tv%T, tv%S + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, & + dt, tv%tr_T, tv%T, tv%C_p) + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & + dt, tv%tr_S, tv%S) + call cpu_clock_end(id_clock_kpp) + if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") + if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G, GV, US) + + if (CS%debug) then + call MOM_state_chksum("after KPP_applyNLT ", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("after KPP_applyNLT ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after KPP_applyNLT ", tv, G, US) + endif + if (.not.associated(fluxes%KPP_salt_flux)) fluxes%KPP_salt_flux => CS%KPP_salt_flux + endif ! endif for KPP + + ! Calculate vertical mixing due to convection (computed via CVMix) + if (CS%use_CVMix_conv) then + ! Increment vertical diffusion and viscosity due to convection + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, Hml, Kd_heat, visc%Kv_shear, Kd_aux=Kd_salt) + endif + + ! Save fields before boundary forcing is applied for tendency diagnostics + do k=1,nz ; do j=js,je ; do i=is,ie + h_orig(i,j,k) = h(i,j,k) + enddo ; enddo ; enddo + if (CS%boundary_forcing_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + ! Apply forcing + ! Changes made to following fields: h, tv%T and tv%S. + call cpu_clock_begin(id_clock_remap) + + if (CS%use_energetic_PBL) then + + skinbuoyflux(:,:) = 0.0 + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & + optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) + + if (CS%debug) then + call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(cTKE, "after applyBoundaryFluxes cTKE", G%HI, haloshift=0, & + scale=US%RZ3_T3_to_W_m2*US%T_to_s) + call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, & + scale=US%kg_m3_to_R*US%degC_to_C) + call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, & + scale=US%kg_m3_to_R*US%ppt_to_S) + endif + + call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) + call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & + CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + + if (associated(Hml)) then + call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) + call pass_var(Hml, G%domain, halo=1) + ! If visc%MLD exists, copy ePBL's MLD into it + if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) + elseif (associated(visc%MLD)) then + call energetic_PBL_get_MLD(CS%ePBL, visc%MLD, G, US) + call pass_var(visc%MLD, G%domain, halo=1) + endif + if (associated(visc%sfc_buoy_flx)) then + visc%sfc_buoy_flx(:,:) = SkinBuoyFlux(:,:) + call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) + endif + + ! Augment the diffusivities and viscosity due to those diagnosed in energetic_PBL. + do K=2,nz ; do j=js,je ; do i=is,ie + if (CS%ePBL_is_additive) then + Kd_add_here = Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*Kd_ePBL(i,j,K) + else + Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) + endif + + Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_add_here + Kd_salt(i,j,K) = Kd_salt(i,j,K) + Kd_add_here + enddo ; enddo ; enddo + + if (CS%debug) then + call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + + else + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & + optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & + CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD=visc%MLD) + + endif ! endif for CS%use_energetic_PBL + + ! diagnose the tendencies due to boundary forcing + ! At this point, the diagnostic grids have not been updated since the call to the boundary layer scheme + ! so all tendency diagnostics need to be posted on h_orig, and grids rebuilt afterwards + if (CS%boundary_forcing_tendency_diag) then + call diagnose_boundary_forcing_tendency(tv, h, temp_diag, saln_diag, h_orig, dt, G, GV, US, CS) + if (CS%id_boundary_forcing_h > 0) call post_data(CS%id_boundary_forcing_h, h, CS%diag, alt_h=h_orig) + endif + ! Boundary fluxes may have changed T, S, and h + call diag_update_remap_grids(CS%diag) + call cpu_clock_end(id_clock_remap) + if (CS%debug) then + call MOM_forcing_chksum("after applyBoundaryFluxes ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after applyBoundaryFluxes ", tv, G, US) + call MOM_state_chksum("after applyBoundaryFluxes ", u, v, h, G, GV, US, haloshift=0) + endif + if (showCallTree) call callTree_waypoint("done with applyBoundaryFluxes (diabatic)") + if (CS%debugConservation) call MOM_state_stats('applyBoundaryFluxes', u, v, h, tv%T, tv%S, G, GV, US) + + if (showCallTree) call callTree_waypoint("done with h=ea-eb (diabatic)") + if (CS%debugConservation) call MOM_state_stats('h=ea-eb', u, v, h, tv%T, tv%S, G, GV, US) + + ! calculate change in temperature & salinity due to dia-coordinate surface diffusion + if (associated(tv%T)) then + + if (CS%debug) then + call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, scale=GV%H_to_m) + endif + + call cpu_clock_begin(id_clock_tridiag) + ! Keep salinity from falling below a small but positive threshold. + ! This constraint is needed for SIS1 ice model, which can extract + ! more salt than is present in the ocean. SIS2 does not suffer + ! from this limitation, in which case we can let salinity=0 and still + ! have salt conserved with SIS2 ice. So for SIS2, we can run with + ! BOUND_SALINITY=False in MOM.F90. + if (associated(tv%S) .and. associated(tv%salt_deficit)) & + call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) + + if (CS%diabatic_diff_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + ! Find the vertical distances across layers, which may have been modified by the net surface flux + call thickness_to_dz(h, tv, dz, G, GV, US) + + ! set ent_t=dt*Kd_heat/h_int and est_s=dt*Kd_salt/h_int on interfaces for use in the tridiagonal solver. + do j=js,je ; do i=is,ie + ent_t(i,j,1) = 0. ; ent_t(i,j,nz+1) = 0. + ent_s(i,j,1) = 0. ; ent_s(i,j,nz+1) = 0. + enddo ; enddo + + !$OMP parallel do default(shared) private(I_dzval) + do K=2,nz ; do j=js,je ; do i=is,ie + I_dzval = 1.0 / (dz_neglect + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + ent_t(i,j,K) = dt * I_dzval * Kd_heat(i,j,k) + ent_s(i,j,K) = dt * I_dzval * Kd_salt(i,j,k) + enddo ; enddo ; enddo + if (showCallTree) call callTree_waypoint("done setting ent_t and ent_t from Kd_heat and " //& + "Kd_salt (diabatic_ALE)") + + ! Changes T and S via the tridiagonal solver; no change to h + call tracer_vertdiff_Eulerian(h, ent_t, dt, tv%T, G, GV) + call tracer_vertdiff_Eulerian(h, ent_s, dt, tv%S, G, GV) + + ! In ALE-mode, layer thicknesses do not change. Therefore, we can use h below + if (CS%diabatic_diff_tendency_diag) then + call diagnose_diabatic_diff_tendency(tv, h, temp_diag, saln_diag, dt, G, GV, US, CS) + endif + call cpu_clock_end(id_clock_tridiag) + + if (showCallTree) call callTree_waypoint("done with triDiagTS (diabatic)") + + endif ! endif corresponding to if (associated(tv%T)) + + if (CS%debugConservation) call MOM_state_stats('triDiagTS', u, v, h, tv%T, tv%S, G, GV, US) + + if (CS%debug) then + call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, US, haloshift=0) + call MOM_thermovar_chksum("after mixed layer ", tv, G, US) + endif + + ! Whenever thickness changes let the diag manager know, as the + ! target grids for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! Diagnose the diapycnal diffusivities and other related quantities. + if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) + if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) + if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) + + if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ent_t(:,:,1:nz), CS%diag) + if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, ent_t(:,:,2:nz+1), CS%diag) + if (CS%id_ea_s > 0) call post_data(CS%id_ea_s, ent_s(:,:,1:nz), CS%diag) + if (CS%id_eb_s > 0) call post_data(CS%id_eb_s, ent_s(:,:,2:nz+1), CS%diag) + + Idt = 1.0 / dt + if (CS%id_Tdif > 0) then + do j=js,je ; do i=is,ie + Tdif_flx(i,j,1) = 0.0 ; Tdif_flx(i,j,nz+1) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Tdif_flx(i,j,K) = (Idt * ent_t(i,j,K)) * (tv%T(i,j,k-1) - tv%T(i,j,k)) + enddo ; enddo ; enddo + if (CS%id_Tdif > 0) call post_data(CS%id_Tdif, Tdif_flx, CS%diag) + endif + if (CS%id_Sdif > 0) then + do j=js,je ; do i=is,ie + Sdif_flx(i,j,1) = 0.0 ; Sdif_flx(i,j,nz+1) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Sdif_flx(i,j,K) = (Idt * ent_s(i,j,K)) * (tv%S(i,j,k-1) - tv%S(i,j,k)) + enddo ; enddo ; enddo + if (CS%id_Sdif > 0) call post_data(CS%id_Sdif, Sdif_flx, CS%diag) + endif + + ! mixing of passive tracers from massless boundary layers to interior + call cpu_clock_begin(id_clock_tracers) + + if (CS%mix_boundary_tracer_ALE) then + Tr_ea_BBL = sqrt(dt * CS%Kd_BBL_tr) + !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) + do j=js,je + do i=is,ie + htot(i) = 0.0 + in_boundary(i) = (G%mask2dT(i,j) > 0.0) + enddo + do k=nz,2,-1 ; do i=is,ie + if (in_boundary(i)) then + htot(i) = htot(i) + h(i,j,k) + ! If diapycnal mixing has been suppressed because this is a massless layer near the + ! bottom, add some mixing of tracers between these layers. This flux is based on the + ! harmonic mean of the two thicknesses, following what is done in layered mode. Kd_min_tr + ! should be much less than the values in Kd_salt, perhaps a molecular diffusivity. + add_ent = (dt * CS%Kd_min_tr) * & + ((dz(i,j,k-1)+dz(i,j,k) + dz_neglect) / (dz(i,j,k-1)*dz(i,j,k) + dz_neglect2)) - & + ent_s(i,j,K) + if (htot(i) < Tr_ea_BBL) then + add_ent = max(0.0, add_ent, (Tr_ea_BBL - htot(i)) - ent_s(i,j,K)) + elseif (add_ent < 0.0) then + add_ent = 0.0 ; in_boundary(i) = .false. + endif + + ent_s(i,j,K) = ent_s(i,j,K) + add_ent + endif + enddo ; enddo + enddo + endif ! (CS%mix_boundary_tracer_ALE) + + ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied + call call_tracer_column_fns(h_orig, h, ent_s(:,:,1:nz), ent_s(:,:,2:nz+1), fluxes, Hml, dt, & + G, GV, US, tv, CS%optics, CS%tracer_flow_CSp, CS%debug, & + KPP_CSp=CS%KPP_CSp, & + nonLocalTrans=CS%KPP_NLTscalar, & + evap_CFL_limit=CS%evap_CFL_limit, & + minimum_forcing_depth=CS%minimum_forcing_depth) + + call cpu_clock_end(id_clock_tracers) + + ! Apply ALE sponge + if (CS%use_sponge .and. associated(CS%ALE_sponge_CSp)) then + call cpu_clock_begin(id_clock_sponge) + call apply_ALE_sponge(h, tv, dt, G, GV, US, CS%ALE_sponge_CSp, CS%Time) + call cpu_clock_end(id_clock_sponge) + if (CS%debug) then + call MOM_state_chksum("apply_sponge ", u, v, h, G, GV, US, haloshift=0) + call MOM_thermovar_chksum("apply_sponge ", tv, G, US) + endif + endif ! CS%use_sponge + + ! Apply data assimilation incremental update -oda_incupd- + if (CS%use_oda_incupd .and. associated(CS%oda_incupd_CSp)) then + call MOM_mesg("Starting ODA_INCUPD ", 5) + call cpu_clock_begin(id_clock_oda_incupd) + call apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS%oda_incupd_CSp) + call cpu_clock_end(id_clock_oda_incupd) + if (CS%debug) then + call MOM_state_chksum("apply_oda_incupd ", u, v, h, G, GV, US, haloshift=0) + call MOM_thermovar_chksum("apply_oda_incupd ", tv, G, US) + endif + endif ! CS%use_oda_incupd + + + call cpu_clock_begin(id_clock_pass) + ! visc%Kv_slow is not in the group pass because it has larger vertical extent. + if (associated(visc%Kv_slow)) & + call pass_var(visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) + call cpu_clock_end(id_clock_pass) + + call disable_averaging(CS%diag) + + if (showCallTree) call callTree_leave("diabatic_ALE()") + +end subroutine diabatic_ALE + +!> Imposes the diapycnal mass fluxes and the accompanying diapycnal advection of momentum and tracers +!! using the original MOM6 algorithms. +subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + !! unused have NULL ptrs + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + type(forcing), intent(inout) :: fluxes !< points to forcing fields + !! unused fields have NULL ptrs + type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, + !! BBL properties and related fields + type(accel_diag_ptrs), intent(inout) :: ADp !< Points to accelerations in momentum + !! equations, to enable the later derived + !! diagnostics, like energy budgets + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(Wave_parameters_CS), pointer :: Waves !< Surface gravity waves + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + ea, & ! amount of fluid entrained from the layer above within + ! one time step [H ~> m or kg m-2] + eb, & ! amount of fluid entrained from the layer below within + ! one time step [H ~> m or kg m-2] + Kd_lay, & ! diapycnal diffusivity of layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + h_orig, & ! initial layer thicknesses [H ~> m or kg m-2] + dz, & ! The vertical distance between interfaces around a layer [Z ~> m] + hold, & ! layer thickness before diapycnal entrainment, and later the initial + ! layer thicknesses (if a mixed layer is used) [H ~> m or kg m-2] + dz_old, & ! The initial vertical distance between interfaces around a layer + ! or the distance before entrainment [Z ~> m] + u_h, & ! Zonal velocities at thickness points after entrainment [L T-1 ~> m s-1] + v_h, & ! Meridional velocities at thickness points after entrainment [L T-1 ~> m s-1] + temp_diag, & ! Diagnostic array of previous temperatures [C ~> degC] + saln_diag ! Diagnostic array of previous salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G)) :: & + U_star, & ! The friction velocity [Z T-1 ~> m s-1]. + Rcv_ml ! Coordinate density of mixed layer [R ~> kg m-3], used for applying sponges + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & + ! These are targets so that the space can be shared with eaml & ebml. + eatr, & ! The equivalent of ea for tracers, which differs from ea in that it tends to + ! homogenize tracers in massless layers near the boundaries [H ~> m or kg m-2] + ebtr ! The equivalent of eb for tracers, which differs from eb in that it tends to + ! homogenize tracers in massless layers near the boundaries [H ~> m or kg m-2] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + Kd_int, & ! diapycnal diffusivity of interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_heat, & ! diapycnal diffusivity of heat [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_extra_T , & ! The extra diffusivity of temperature due to double diffusion relative to + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Tadv_flx, & ! advective diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + Sadv_flx ! advective diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + + ! The following 3 variables are only used with a bulk mixed layer. + real, pointer, dimension(:,:,:) :: & + eaml, & ! The equivalent of ea due to mixed layer processes [H ~> m or kg m-2]. + ebml ! The equivalent of eb due to mixed layer processes [H ~> m or kg m-2]. + ! eaml and ebml are pointers to eatr and ebtr so as to reuse the memory as + ! the arrays are not needed at the same time. + + integer :: kb(SZI_(G),SZJ_(G)) ! index of the lightest layer denser + ! than the buffer layer [nondim] + + real :: p_ref_cv(SZI_(G)) ! Reference pressure for the potential density that defines the + ! coordinate variable, set to P_Ref [R L2 T-2 ~> Pa]. + + logical :: in_boundary(SZI_(G)) ! True if there are no massive layers below, + ! where massive is defined as sufficiently thick that + ! the no-flux boundary conditions have not restricted + ! the entrainment - usually sqrt(Kd*dt). + + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2] + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] + real :: net_ent ! The net of ea-eb at an interface [H ~> m or kg m-2] + real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] + real :: eaval ! eaval is 2*ea at velocity grid points [H ~> m or kg m-2] + real :: hval ! hval is 2*h at velocity grid points [H ~> m or kg m-2] + real :: h_tr ! h_tr is h at tracer points with a tiny thickness + ! added to ensure positive definiteness [H ~> m or kg m-2] + real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is + ! coupled to the bottom within a timestep [H ~> m or kg m-2] + + real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. + real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1] + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2] + real :: d1(SZIB_(G)) ! A variable used by the tridiagonal solver [nondim] + real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim] + + real :: dt_mix ! The amount of time over which to apply mixing [T ~> s] + real :: Idt ! The inverse time step [T-1 ~> s-1] + + integer :: dir_flag ! An integer encoding the directions in which to do halo updates. + logical :: showCallTree ! If true, show the call tree + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, halo + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + nkmb = GV%nk_rho_varies + h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect + Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 + + + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("layered_diabatic(), MOM_diabatic_driver.F90") + + ! set equivalence between the same bits of memory for these arrays + eaml => eatr ; ebml => ebtr + + ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep + call enable_averages(dt, Time_end, CS%diag) + + if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then + halo = CS%halo_TS_diff + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-halo,je+halo ; do i=is-halo,ie+halo + h_orig(i,j,k) = h(i,j,k) ; eaml(i,j,k) = 0.0 ; ebml(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif + + if (CS%use_geothermal) then + call cpu_clock_begin(id_clock_geothermal) + call geothermal_entraining(h, tv, dt, eaml, ebml, G, GV, US, CS%geothermal, halo=CS%halo_TS_diff) + call cpu_clock_end(id_clock_geothermal) + if (showCallTree) call callTree_waypoint("geothermal (diabatic)") + if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G, GV, US) + endif + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! Set_pen_shortwave estimates the optical properties of the water column. + ! It will need to be modified later to include information about the + ! biological properties and layer thicknesses. + if (associated(CS%optics)) & + call set_pen_shortwave(CS%optics, fluxes, G, GV, US, CS%diabatic_aux_CSp, CS%opacity, CS%tracer_flow_CSp) + + if (CS%use_bulkmixedlayer) then + if (CS%debug) call MOM_forcing_chksum("Before mixedlayer", fluxes, G, US, haloshift=0) + + if (CS%ML_mix_first > 0.0) then +! This subroutine +! (1) Cools the mixed layer. +! (2) Performs convective adjustment by mixed layer entrainment. +! (3) Heats the mixed layer and causes it to detrain to +! Monin-Obukhov depth or minimum mixed layer depth. +! (4) Uses any remaining TKE to drive mixed layer entrainment. +! (5) Possibly splits buffer layer into two isopycnal layers (when using isopycnal coordinate) + call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) + + call cpu_clock_begin(id_clock_mixedlayer) + if (CS%ML_mix_first < 1.0) then + ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) + call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt*CS%ML_mix_first, & + eaml, ebml, G, GV, US, CS%bulkmixedlayer, CS%optics, & + Hml, CS%aggregate_FW_forcing, dt, last_call=.false.) + else + ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) + call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt, eaml, ebml, & + G, GV, US, CS%bulkmixedlayer, CS%optics, & + Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) + endif + + ! Keep salinity from falling below a small but positive threshold. + ! This constraint is needed for SIS1 ice model, which can extract + ! more salt than is present in the ocean. SIS2 does not suffer + ! from this limitation, in which case we can let salinity=0 and still + ! have salt conserved with SIS2 ice. So for SIS2, we can run with + ! BOUND_SALINITY=False in MOM.F90. + if (associated(tv%S) .and. associated(tv%salt_deficit)) & + call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) + call cpu_clock_end(id_clock_mixedlayer) + if (CS%debug) then + call MOM_state_chksum("After mixedlayer ", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("After mixedlayer", fluxes, G, US, haloshift=0) + endif + if (showCallTree) call callTree_waypoint("done with 1st bulkmixedlayer (diabatic)") + if (CS%debugConservation) call MOM_state_stats('1st bulkmixedlayer', u, v, h, tv%T, tv%S, G, GV, US) + endif + endif + + if (CS%debug) & + call MOM_state_chksum("before find_uv_at_h", u, v, h, G, GV, US, haloshift=0) + if (CS%use_kappa_shear .or. CS%use_CVMix_shear) then + if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then + call find_uv_at_h(u, v, h_orig, u_h, v_h, G, GV, US, eaml, ebml) + if (CS%debug) then + call hchksum(eaml, "after find_uv_at_h eaml", G%HI, scale=GV%H_to_m) + call hchksum(ebml, "after find_uv_at_h ebml", G%HI, scale=GV%H_to_m) + endif + else + call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) + endif + if (showCallTree) call callTree_waypoint("done with find_uv_at_h (diabatic)") + endif + + call cpu_clock_begin(id_clock_set_diffusivity) + ! Sets: Kd_lay, Kd_int, Kd_extra_T, Kd_extra_S and visc%TKE_turb + ! Also changes: visc%Kd_shear and visc%Kv_shear + if ((CS%halo_TS_diff > 0) .and. (CS%ML_mix_first > 0.0)) then + if (associated(tv%T)) call pass_var(tv%T, G%Domain, halo=CS%halo_TS_diff, complete=.false.) + if (associated(tv%S)) call pass_var(tv%S, G%Domain, halo=CS%halo_TS_diff, complete=.false.) + call pass_var(h, G%domain, halo=CS%halo_TS_diff, complete=.true.) + endif + + ! Update derived thermodynamic quantities. + if ((CS%ML_mix_first > 0.0) .and. allocated(tv%SpV_avg)) then + call calc_derived_thermo(tv, h, G, GV, US, halo=CS%halo_TS_diff) + endif + + if (CS%debug) & + call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) + if (CS%double_diffuse) then + call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, Kd_int, G, GV, US, & + CS%set_diff_CSp, Kd_lay=Kd_lay, Kd_extra_T=Kd_extra_T, Kd_extra_S=Kd_extra_S) + else + call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, Kd_int, G, GV, US, & + CS%set_diff_CSp, Kd_lay=Kd_lay) + endif + call cpu_clock_end(id_clock_set_diffusivity) + if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") + + if (CS%debug) then + call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) + call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + + + if (CS%useKPP) then + call cpu_clock_begin(id_clock_kpp) + ! KPP needs the surface buoyancy flux but does not update state variables. + ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. + ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux + ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) + ! unlike other instances where the fluxes are integrated in time over a time-step. + call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & + CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. + + ! Set diffusivities for heat and salt separately + + if (CS%double_diffuse) then + ! Add contribution from double diffusion + !$OMP parallel do default(shared) + do K=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_salt(i,j,K) = Kd_int(i,j,K) + Kd_extra_S(i,j,K) + Kd_heat(i,j,K) = Kd_int(i,j,K) + Kd_extra_T(i,j,K) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do K=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_salt(i,j,K) = Kd_int(i,j,K) + Kd_heat(i,j,K) = Kd_int(i,j,K) + enddo ; enddo ; enddo + endif + + ! Determine the friction velocity, perhaps using the evovling surface density. + call find_ustar(fluxes, tv, U_star, G, GV, US) + + if ( associated(fluxes%lamult) ) then + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & + U_star, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) + else + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & + U_star, CS%KPP_buoy_flux, Waves=Waves) + + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) + endif + + if (associated(Hml)) then + call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US) + call pass_var(Hml, G%domain, halo=1) + ! If visc%MLD exists, copy KPP's BLD into it + if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) + endif + if (associated(visc%sfc_buoy_flx)) then + visc%sfc_buoy_flx(:,:) = CS%KPP_buoy_flux(:,:,1) + call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) + endif + + if (.not. CS%KPPisPassive) then + !$OMP parallel do default(shared) + do k=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_int(i,j,K) = min( Kd_salt(i,j,k), Kd_heat(i,j,k) ) + enddo ; enddo ; enddo + if (CS%double_diffuse) then + !$OMP parallel do default(shared) + do k=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_extra_S(i,j,k) = (Kd_salt(i,j,k) - Kd_int(i,j,K)) + Kd_extra_T(i,j,k) = (Kd_heat(i,j,k) - Kd_int(i,j,K)) + enddo ; enddo ; enddo + endif + endif ! not passive + + call cpu_clock_end(id_clock_kpp) + if (showCallTree) call callTree_waypoint("done with KPP_calculate (diabatic)") + if (CS%debug) then + call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after KPP", tv, G, US) + call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + if (.not.associated(fluxes%KPP_salt_flux)) fluxes%KPP_salt_flux => CS%KPP_salt_flux + endif ! endif for KPP + + ! Add vertical diff./visc. due to convection (computed via CVMix) + if (CS%use_CVMix_conv) then + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, Hml, Kd_int, visc%Kv_shear) + endif + + if (CS%useKPP) then + call cpu_clock_begin(id_clock_kpp) + if (CS%debug) then + call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & + scale=US%C_to_degC*GV%H_to_m*US%s_to_T) + call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & + scale=US%S_to_ppt*GV%H_to_m*US%s_to_T) + call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) + call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) + endif + ! Apply non-local transport of heat and salt + ! Changes: tv%T, tv%S + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, & + dt, tv%tr_T, tv%T, tv%C_p) + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & + dt, tv%tr_S, tv%S) + call cpu_clock_end(id_clock_kpp) + if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") + if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G, GV, US) + + if (CS%debug) then + call MOM_state_chksum("after KPP_applyNLT ", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("after KPP_applyNLT ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after KPP_applyNLT ", tv, G, US) + endif + endif ! endif for KPP + + ! Differential diffusion done here. + ! Changes: tv%T, tv%S + if (CS%double_diffuse .and. associated(tv%T)) then + + call cpu_clock_begin(id_clock_differential_diff) + call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, tv, dt, G, GV) + call cpu_clock_end(id_clock_differential_diff) + if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") + if (CS%debugConservation) call MOM_state_stats('differential_diffuse_T_S', u, v, h, tv%T, tv%S, G, GV, US) + + ! increment heat and salt diffusivity. + ! CS%useKPP==.true. already has extra_T and extra_S included + if (.not. CS%useKPP) then + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_extra_T(i,j,K) + Kd_salt(i,j,K) = Kd_salt(i,j,K) + Kd_extra_S(i,j,K) + enddo ; enddo ; enddo + endif + + endif + + ! Calculate layer entrainments and detrainments from diffusivities and differences between + ! layer and target densities (i.e. do remapping as well as diffusion). + call cpu_clock_begin(id_clock_entrain) + ! Calculate appropriately limited diapycnal mass fluxes to account + ! for diapycnal diffusion and advection. Sets: ea, eb. Changes: kb + call Entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS%entrain_diffusive, & + ea, eb, kb, Kd_lay=Kd_lay, Kd_int=Kd_int) + call cpu_clock_end(id_clock_entrain) + if (showCallTree) call callTree_waypoint("done with Entrainment_diffusive (diabatic)") + + if (CS%debug) then + call MOM_forcing_chksum("after calc_entrain ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after calc_entrain ", tv, G, US) + call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, US, haloshift=0) + call hchksum(ea, "after calc_entrain ea", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(eb, "after calc_entrain eb", G%HI, haloshift=0, scale=GV%H_to_m) + endif + + ! Save fields before boundary forcing is applied for tendency diagnostics + if (CS%boundary_forcing_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + ! Update h according to divergence of the difference between + ! ea and eb. We keep a record of the original h in hold. + ! In the following, the checks for negative values are to guard + ! against instances where entrainment drives a layer to + ! negative thickness. This situation will never happen if + ! enough iterations are permitted in Calculate_Entrainment. + ! Even if too few iterations are allowed, it is still guarded + ! against. In other words the checks are probably unnecessary. + !$OMP parallel do default(shared) + do j=js,je + do i=is,ie + hold(i,j,1) = h(i,j,1) + h(i,j,1) = h(i,j,1) + (eb(i,j,1) - ea(i,j,2)) + hold(i,j,nz) = h(i,j,nz) + h(i,j,nz) = h(i,j,nz) + (ea(i,j,nz) - eb(i,j,nz-1)) + if (h(i,j,1) <= 0.0) then + h(i,j,1) = GV%Angstrom_H + endif + if (h(i,j,nz) <= 0.0) then + h(i,j,nz) = GV%Angstrom_H + endif + enddo + do k=2,nz-1 ; do i=is,ie + hold(i,j,k) = h(i,j,k) + h(i,j,k) = h(i,j,k) + ((ea(i,j,k) - eb(i,j,k-1)) + & + (eb(i,j,k) - ea(i,j,k+1))) + if (h(i,j,k) <= 0.0) then + h(i,j,k) = GV%Angstrom_H + endif + enddo ; enddo + enddo + ! Checks for negative thickness may have changed layer thicknesses + call diag_update_remap_grids(CS%diag) + + if (CS%debug) then + call MOM_state_chksum("after negative check ", u, v, h, G, GV, US, haloshift=0) + call MOM_forcing_chksum("after negative check ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after negative check ", tv, G, US) + endif + if (showCallTree) call callTree_waypoint("done with h=ea-eb (diabatic)") + if (CS%debugConservation) call MOM_state_stats('h=ea-eb', u, v, h, tv%T, tv%S, G, GV, US) + + ! Here, T and S are updated according to ea and eb. + ! If using the bulk mixed layer, T and S are also updated + ! by surface fluxes (in fluxes%*). + ! This is a very long block. + if (CS%use_bulkmixedlayer) then + + if (associated(tv%T)) then + call cpu_clock_begin(id_clock_tridiag) + ! Temperature and salinity (as state variables) are treated + ! differently from other tracers to insure massless layers that + ! are lighter than the mixed layer have temperatures and salinities + ! that correspond to their prescribed densities. + if (CS%massless_match_targets) then + !$OMP parallel do default (shared) private(h_tr,b1,d1,c1,b_denom_1) + do j=js,je + do i=is,ie + h_tr = hold(i,j,1) + h_neglect + b1(i) = 1.0 / (h_tr + eb(i,j,1)) + d1(i) = h_tr * b1(i) + tv%T(i,j,1) = b1(i) * (h_tr*tv%T(i,j,1)) + tv%S(i,j,1) = b1(i) * (h_tr*tv%S(i,j,1)) + enddo + do k=2,nkmb ; do i=is,ie + c1(i,k) = eb(i,j,k-1) * b1(i) + h_tr = hold(i,j,k) + h_neglect + b_denom_1 = h_tr + d1(i)*ea(i,j,k) + b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) + if (k kb(i,j)) then + c1(i,k) = eb(i,j,k-1) * b1(i) + h_tr = hold(i,j,k) + h_neglect + b_denom_1 = h_tr + d1(i)*ea(i,j,k) + b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) + d1(i) = b_denom_1 * b1(i) + tv%T(i,j,k) = b1(i) * (h_tr*tv%T(i,j,k) + ea(i,j,k)*tv%T(i,j,k-1)) + tv%S(i,j,k) = b1(i) * (h_tr*tv%S(i,j,k) + ea(i,j,k)*tv%S(i,j,k-1)) + elseif (eb(i,j,k) < eb(i,j,k-1)) then ! (note that k < kb(i,j)) + ! The bottommost buffer layer might entrain all the mass from some + ! of the interior layers that are thin and lighter in the coordinate + ! density than that buffer layer. The T and S of these newly + ! massless interior layers are unchanged. + tv%T(i,j,nkmb) = tv%T(i,j,nkmb) + b1(i) * (eb(i,j,k-1) - eb(i,j,k)) * tv%T(i,j,k) + tv%S(i,j,nkmb) = tv%S(i,j,nkmb) + b1(i) * (eb(i,j,k-1) - eb(i,j,k)) * tv%S(i,j,k) + endif + enddo ; enddo + + do k=nz-1,nkmb,-1 ; do i=is,ie + if (k >= kb(i,j)) then + tv%T(i,j,k) = tv%T(i,j,k) + c1(i,k+1)*tv%T(i,j,k+1) + tv%S(i,j,k) = tv%S(i,j,k) + c1(i,k+1)*tv%S(i,j,k+1) + endif + enddo ; enddo + do i=is,ie ; if (kb(i,j) <= nz) then + tv%T(i,j,nkmb) = tv%T(i,j,nkmb) + c1(i,kb(i,j))*tv%T(i,j,kb(i,j)) + tv%S(i,j,nkmb) = tv%S(i,j,nkmb) + c1(i,kb(i,j))*tv%S(i,j,kb(i,j)) + endif ; enddo + do k=nkmb-1,1,-1 ; do i=is,ie + tv%T(i,j,k) = tv%T(i,j,k) + c1(i,k+1)*tv%T(i,j,k+1) + tv%S(i,j,k) = tv%S(i,j,k) + c1(i,k+1)*tv%S(i,j,k+1) + enddo ; enddo + enddo ! end of j loop + else ! .not. massless_match_targets + ! This simpler form allows T & S to be too dense for the layers + ! between the buffer layers and the interior. + ! Changes: T, S + if (CS%tracer_tridiag) then + call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) + call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) + else + call triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, tv%T, tv%S) + endif + endif ! massless_match_targets + call cpu_clock_end(id_clock_tridiag) + + endif ! endif for associated(T) + if (CS%debugConservation) call MOM_state_stats('BML tridiag', u, v, h, tv%T, tv%S, G, GV, US) + + if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then + ! The mixed layer code has already been called, but there is some needed + ! bookkeeping. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do i=is,ie + hold(i,j,k) = h_orig(i,j,k) + ea(i,j,k) = ea(i,j,k) + eaml(i,j,k) + eb(i,j,k) = eb(i,j,k) + ebml(i,j,k) + enddo ; enddo ; enddo + if (CS%debug) then + call hchksum(ea, "after ea = ea + eaml", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(eb, "after eb = eb + ebml", G%HI, haloshift=0, scale=GV%H_to_m) + endif + endif + + if (CS%ML_mix_first < 1.0) then + ! Call the mixed layer code now, perhaps for a second time. + ! This subroutine (1) Cools the mixed layer. + ! (2) Performs convective adjustment by mixed layer entrainment. + ! (3) Heats the mixed layer and causes it to detrain to + ! Monin-Obukhov depth or minimum mixed layer depth. + ! (4) Uses any remaining TKE to drive mixed layer entrainment. + ! (5) Possibly splits the buffer layer into two isopycnal layers. + + call find_uv_at_h(u, v, hold, u_h, v_h, G, GV, US, ea, eb) + if (CS%debug) call MOM_state_chksum("find_uv_at_h1 ", u, v, h, G, GV, US, haloshift=0) + + dt_mix = min(dt, dt*(1.0 - CS%ML_mix_first)) + call cpu_clock_begin(id_clock_mixedlayer) + ! Changes: h, tv%T, tv%S, ea and eb (G is also inout???) + call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt_mix, ea, eb, & + G, GV, US, CS%bulkmixedlayer, CS%optics, & + Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) + + ! Keep salinity from falling below a small but positive threshold. + ! This constraint is needed for SIS1 ice model, which can extract + ! more salt than is present in the ocean. SIS2 does not suffer + ! from this limitation, in which case we can let salinity=0 and still + ! have salt conserved with SIS2 ice. So for SIS2, we can run with + ! BOUND_SALINITY=False in MOM.F90. + if (associated(tv%S) .and. associated(tv%salt_deficit)) & + call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) + + call cpu_clock_end(id_clock_mixedlayer) + if (showCallTree) call callTree_waypoint("done with 2nd bulkmixedlayer (diabatic)") + if (CS%debugConservation) call MOM_state_stats('2nd bulkmixedlayer', u, v, h, tv%T, tv%S, G, GV, US) + endif + + else ! following block for when NOT using BULKMIXEDLAYER + + ! calculate change in temperature & salinity due to dia-coordinate surface diffusion + if (associated(tv%T)) then + + if (CS%debug) then + call hchksum(ea, "before triDiagTS ea ", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(eb, "before triDiagTS eb ", G%HI, haloshift=0, scale=GV%H_to_m) + endif + call cpu_clock_begin(id_clock_tridiag) + + ! Keep salinity from falling below a small but positive threshold. + ! This constraint is needed for SIS1 ice model, which can extract + ! more salt than is present in the ocean. SIS2 does not suffer + ! from this limitation, in which case we can let salinity=0 and still + ! have salt conserved with SIS2 ice. So for SIS2, we can run with + ! BOUND_SALINITY=False in MOM.F90. + if (associated(tv%S) .and. associated(tv%salt_deficit)) & + call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) + + if (CS%diabatic_diff_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + ! Changes T and S via the tridiagonal solver; no change to h + if (CS%tracer_tridiag) then + call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) + call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) + else + call triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, tv%T, tv%S) + endif + + ! diagnose temperature, salinity, heat, and salt tendencies + ! Note: hold here refers to the thicknesses from before the dual-entrainment when using + ! the bulk mixed layer scheme, so tendencies should be posted on hold. + if (CS%diabatic_diff_tendency_diag) then + call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, US, CS) + if (CS%id_diabatic_diff_h > 0) call post_data(CS%id_diabatic_diff_h, hold, CS%diag, alt_h=hold) + endif + + call cpu_clock_end(id_clock_tridiag) + if (showCallTree) call callTree_waypoint("done with triDiagTS (diabatic)") + + endif ! endif corresponding to if (associated(tv%T)) + if (CS%debugConservation) call MOM_state_stats('triDiagTS', u, v, h, tv%T, tv%S, G, GV, US) + + endif ! endif for the BULKMIXEDLAYER block + + if (CS%debug) then + call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, US, haloshift=0) + call MOM_thermovar_chksum("after mixed layer ", tv, G, US) + call hchksum(ea, "after mixed layer ea", G%HI, scale=GV%H_to_m) + call hchksum(eb, "after mixed layer eb", G%HI, scale=GV%H_to_m) + endif + + call cpu_clock_begin(id_clock_remap) + call regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS%regularize_layers) + call cpu_clock_end(id_clock_remap) + if (showCallTree) call callTree_waypoint("done with regularize_layers (diabatic)") + if (CS%debugConservation) call MOM_state_stats('regularize_layers', u, v, h, tv%T, tv%S, G, GV, US) + + ! Whenever thickness changes let the diag manager know, as the + ! target grids for vertical remapping may need to be regenerated. + if (associated(ADp%du_dt_dia) .or. associated(ADp%dv_dt_dia)) & + ! Remapped d[uv]dt_dia require east/north halo updates of h + call pass_var(h, G%domain, To_West+To_South+Omit_Corners, halo=1) + call diag_update_remap_grids(CS%diag) + + ! diagnostics + Idt = 1.0 / dt + if ((CS%id_Tdif > 0) .or. (CS%id_Tadv > 0)) then + do j=js,je ; do i=is,ie + Tdif_flx(i,j,1) = 0.0 ; Tdif_flx(i,j,nz+1) = 0.0 + Tadv_flx(i,j,1) = 0.0 ; Tadv_flx(i,j,nz+1) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Tdif_flx(i,j,K) = (Idt * 0.5*(ea(i,j,k) + eb(i,j,k-1))) * & + (tv%T(i,j,k-1) - tv%T(i,j,k)) + Tadv_flx(i,j,K) = (Idt * (ea(i,j,k) - eb(i,j,k-1))) * & + 0.5*(tv%T(i,j,k-1) + tv%T(i,j,k)) + enddo ; enddo ; enddo + endif + if ((CS%id_Sdif > 0) .or. (CS%id_Sadv > 0)) then + do j=js,je ; do i=is,ie + Sdif_flx(i,j,1) = 0.0 ; Sdif_flx(i,j,nz+1) = 0.0 + Sadv_flx(i,j,1) = 0.0 ; Sadv_flx(i,j,nz+1) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Sdif_flx(i,j,K) = (Idt * 0.5*(ea(i,j,k) + eb(i,j,k-1))) * & + (tv%S(i,j,k-1) - tv%S(i,j,k)) + Sadv_flx(i,j,K) = (Idt * (ea(i,j,k) - eb(i,j,k-1))) * & + 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) + enddo ; enddo ; enddo + endif + + ! mixing of passive tracers from massless boundary layers to interior + call cpu_clock_begin(id_clock_tracers) + + ! Find the vertical distances across layers. + if (CS%mix_boundary_tracers .or. CS%double_diffuse) & + call thickness_to_dz(h, tv, dz, G, GV, US) + if (CS%double_diffuse) & + call thickness_to_dz(hold, tv, dz_old, G, GV, US) + + if (CS%mix_boundary_tracers) then + Tr_ea_BBL = sqrt(dt * CS%Kd_BBL_tr) + !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) + do j=js,je + do i=is,ie + ebtr(i,j,nz) = eb(i,j,nz) + htot(i) = 0.0 + in_boundary(i) = (G%mask2dT(i,j) > 0.0) + enddo + do k=nz,2,-1 ; do i=is,ie + if (in_boundary(i)) then + htot(i) = htot(i) + h(i,j,k) + ! If diapycnal mixing has been suppressed because this is a massless + ! layer near the bottom, add some mixing of tracers between these + ! layers. This flux is based on the harmonic mean of the two + ! thicknesses, as this corresponds pretty closely (to within + ! differences in the density jumps between layers) with what is done + ! in the calculation of the fluxes in the first place. Kd_min_tr + ! should be much less than the values that have been set in Kd_lay, + ! perhaps a molecular diffusivity. + add_ent = (dt * CS%Kd_min_tr) * & + ((dz(i,j,k-1) + dz(i,j,k) + dz_neglect) / & + (dz(i,j,k-1)*dz(i,j,k) + dz_neglect2)) - & + 0.5*(ea(i,j,k) + eb(i,j,k-1)) + if (htot(i) < Tr_ea_BBL) then + add_ent = max(0.0, add_ent, & + (Tr_ea_BBL - htot(i)) - min(ea(i,j,k), eb(i,j,k-1))) + elseif (add_ent < 0.0) then + add_ent = 0.0 ; in_boundary(i) = .false. + endif + + ebtr(i,j,k-1) = eb(i,j,k-1) + add_ent + eatr(i,j,k) = ea(i,j,k) + add_ent + else + ebtr(i,j,k-1) = eb(i,j,k-1) ; eatr(i,j,k) = ea(i,j,k) + endif + if (CS%double_diffuse) then ; if (Kd_extra_S(i,j,K) > 0.0) then + add_ent = (dt * Kd_extra_S(i,j,K)) / & + (0.25 * ((dz(i,j,k-1) + dz(i,j,k)) + (dz_old(i,j,k-1) + dz_old(i,j,k))) + dz_neglect) + ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent + eatr(i,j,k) = eatr(i,j,k) + add_ent + endif ; endif + enddo ; enddo + do i=is,ie ; eatr(i,j,1) = ea(i,j,1) ; enddo + + enddo + + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug, & + KPP_CSp=CS%KPP_CSp, & + nonLocalTrans=CS%KPP_NLTscalar) + + elseif (CS%double_diffuse) then ! extra diffusivity for passive tracers + + do j=js,je ; do i=is,ie + ebtr(i,j,nz) = eb(i,j,nz) ; eatr(i,j,1) = ea(i,j,1) + enddo ; enddo + !$OMP parallel do default(shared) private(add_ent) + do k=nz,2,-1 ; do j=js,je ; do i=is,ie + if (Kd_extra_S(i,j,K) > 0.0) then + add_ent = (dt * Kd_extra_S(i,j,K)) / & + (0.25 * ((dz(i,j,k-1) + dz(i,j,k)) + (dz_old(i,j,k-1) + dz_old(i,j,k))) + dz_neglect) + else + add_ent = 0.0 + endif + ebtr(i,j,k-1) = eb(i,j,k-1) + add_ent + eatr(i,j,k) = ea(i,j,k) + add_ent + enddo ; enddo ; enddo + + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug, & + KPP_CSp=CS%KPP_CSp, & + nonLocalTrans=CS%KPP_NLTscalar) + + else + call call_tracer_column_fns(hold, h, ea, eb, fluxes, Hml, dt, G, GV, US, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug, & + KPP_CSp=CS%KPP_CSp, & + nonLocalTrans=CS%KPP_NLTscalar) + + endif ! (CS%mix_boundary_tracers) + + call cpu_clock_end(id_clock_tracers) + + ! sponges + if (CS%use_sponge) then + call cpu_clock_begin(id_clock_sponge) + ! Layer mode sponge + if (CS%use_bulkmixedlayer .and. associated(tv%eqn_of_state)) then + do i=is,ie ; p_ref_cv(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) + !$OMP parallel do default(shared) + do j=js,je + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), & + tv%eqn_of_state, EOSdom) + enddo + call apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) + else + call apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS%sponge_CSp) + endif + call cpu_clock_end(id_clock_sponge) + if (CS%debug) then + call MOM_state_chksum("apply_sponge ", u, v, h, G, GV, US, haloshift=0) + call MOM_thermovar_chksum("apply_sponge ", tv, G, US) + endif + endif ! CS%use_sponge + + ! Apply data assimilation incremental update -oda_incupd- + if (CS%use_oda_incupd .and. associated(CS%oda_incupd_CSp)) then + call cpu_clock_begin(id_clock_oda_incupd) + call apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS%oda_incupd_CSp) + call cpu_clock_end(id_clock_oda_incupd) + if (CS%debug) then + call MOM_state_chksum("apply_oda_incupd ", u, v, h, G, GV, US, haloshift=0) + call MOM_thermovar_chksum("apply_oda_incupd ", tv, G, US) + endif + endif ! CS%use_oda_incupd + + + +! Save the diapycnal mass fluxes as a diagnostic field. + if (associated(CDp%diapyc_vel)) then + !$OMP parallel do default(shared) + do j=js,je + do K=2,nz ; do i=is,ie + CDp%diapyc_vel(i,j,K) = Idt * (ea(i,j,k) - eb(i,j,k-1)) + enddo ; enddo + do i=is,ie + CDp%diapyc_vel(i,j,1) = 0.0 + CDp%diapyc_vel(i,j,nz+1) = 0.0 + enddo + enddo + endif + +! For momentum, it is only the net flux that homogenizes within +! the mixed layer. Vertical viscosity that is proportional to the +! mixed layer turbulence is applied elsewhere. + if (CS%use_bulkmixedlayer) then + if (CS%debug) then + call hchksum(ea, "before net flux rearrangement ea", G%HI, scale=GV%H_to_m) + call hchksum(eb, "before net flux rearrangement eb", G%HI, scale=GV%H_to_m) + endif + !$OMP parallel do default(shared) private(net_ent) + do j=js,je + do K=2,GV%nkml ; do i=is,ie + net_ent = ea(i,j,k) - eb(i,j,k-1) + ea(i,j,k) = max(net_ent, 0.0) + eb(i,j,k-1) = max(-net_ent, 0.0) + enddo ; enddo + enddo + if (CS%debug) then + call hchksum(ea, "after net flux rearrangement ea", G%HI, scale=GV%H_to_m) + call hchksum(eb, "after net flux rearrangement eb", G%HI, scale=GV%H_to_m) + endif + endif + +! Initialize halo regions of ea, eb, and hold to default values. + !$OMP parallel do default(shared) + do k=1,nz + do i=is-1,ie+1 + hold(i,js-1,k) = GV%Angstrom_H ; ea(i,js-1,k) = 0.0 ; eb(i,js-1,k) = 0.0 + hold(i,je+1,k) = GV%Angstrom_H ; ea(i,je+1,k) = 0.0 ; eb(i,je+1,k) = 0.0 + enddo + do j=js,je + hold(is-1,j,k) = GV%Angstrom_H ; ea(is-1,j,k) = 0.0 ; eb(is-1,j,k) = 0.0 + hold(ie+1,j,k) = GV%Angstrom_H ; ea(ie+1,j,k) = 0.0 ; eb(ie+1,j,k) = 0.0 + enddo + enddo + + call cpu_clock_begin(id_clock_pass) + if (G%symmetric) then ; dir_flag = To_All+Omit_Corners + else ; dir_flag = To_West+To_South+Omit_Corners ; endif + call create_group_pass(CS%pass_hold_eb_ea, hold, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, eb, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, ea, G%Domain, dir_flag, halo=1) + call do_group_pass(CS%pass_hold_eb_ea, G%Domain) + call cpu_clock_end(id_clock_pass) + + ! Use a tridiagonal solver to determine effect of the diapycnal + ! advection on velocity field. It is assumed that water leaves + ! or enters the ocean with the surface velocity. + if (CS%debug) then + call MOM_state_chksum("before u/v tridiag ", u, v, h, G, GV, US, haloshift=0) + call hchksum(ea, "before u/v tridiag ea", G%HI, scale=GV%H_to_m) + call hchksum(eb, "before u/v tridiag eb", G%HI, scale=GV%H_to_m) + call hchksum(hold, "before u/v tridiag hold", G%HI, scale=GV%H_to_m) + endif + call cpu_clock_begin(id_clock_tridiag) + + !$OMP parallel do default(shared) private(hval,b1,d1,c1,eaval) + do j=js,je + do I=Isq,Ieq + if (associated(ADp%du_dt_dia)) ADp%du_dt_dia(I,j,1) = u(I,j,1) + hval = (hold(i,j,1) + hold(i+1,j,1)) + (ea(i,j,1) + ea(i+1,j,1)) + h_neglect + b1(I) = 1.0 / (hval + (eb(i,j,1) + eb(i+1,j,1))) + d1(I) = hval * b1(I) + u(I,j,1) = b1(I) * (hval * u(I,j,1)) + enddo + do k=2,nz ; do I=Isq,Ieq + if (associated(ADp%du_dt_dia)) ADp%du_dt_dia(I,j,k) = u(I,j,k) + c1(I,k) = (eb(i,j,k-1)+eb(i+1,j,k-1)) * b1(I) + eaval = ea(i,j,k) + ea(i+1,j,k) + hval = hold(i,j,k) + hold(i+1,j,k) + h_neglect + b1(I) = 1.0 / ((eb(i,j,k) + eb(i+1,j,k)) + (hval + d1(I)*eaval)) + d1(I) = (hval + d1(I)*eaval) * b1(I) + u(I,j,k) = (hval*u(I,j,k) + eaval*u(I,j,k-1))*b1(I) + enddo ; enddo + do k=nz-1,1,-1 ; do I=Isq,Ieq + u(I,j,k) = u(I,j,k) + c1(I,k+1)*u(I,j,k+1) + if (associated(ADp%du_dt_dia)) & + ADp%du_dt_dia(I,j,k) = (u(I,j,k) - ADp%du_dt_dia(I,j,k)) * Idt + enddo ; enddo + if (associated(ADp%du_dt_dia)) then + do I=Isq,Ieq + ADp%du_dt_dia(I,j,nz) = (u(I,j,nz)-ADp%du_dt_dia(I,j,nz)) * Idt + enddo + endif + enddo + if (CS%debug) then + call MOM_state_chksum("aft 1st loop tridiag ", u, v, h, G, GV, US, haloshift=0) + endif + !$OMP parallel do default(shared) private(hval,b1,d1,c1,eaval) + do J=Jsq,Jeq + do i=is,ie + if (associated(ADp%dv_dt_dia)) ADp%dv_dt_dia(i,J,1) = v(i,J,1) + hval = (hold(i,j,1) + hold(i,j+1,1)) + (ea(i,j,1) + ea(i,j+1,1)) + h_neglect + b1(i) = 1.0 / (hval + (eb(i,j,1) + eb(i,j+1,1))) + d1(I) = hval * b1(I) + v(i,J,1) = b1(i) * (hval * v(i,J,1)) + enddo + do k=2,nz ; do i=is,ie + if (associated(ADp%dv_dt_dia)) ADp%dv_dt_dia(i,J,k) = v(i,J,k) + c1(i,k) = (eb(i,j,k-1)+eb(i,j+1,k-1)) * b1(i) + eaval = ea(i,j,k) + ea(i,j+1,k) + hval = hold(i,j,k) + hold(i,j+1,k) + h_neglect + b1(i) = 1.0 / ((eb(i,j,k) + eb(i,j+1,k)) + (hval + d1(i)*eaval)) + d1(i) = (hval + d1(i)*eaval) * b1(i) + v(i,J,k) = (hval*v(i,J,k) + eaval*v(i,J,k-1))*b1(i) + enddo ; enddo + do k=nz-1,1,-1 ; do i=is,ie + v(i,J,k) = v(i,J,k) + c1(i,k+1)*v(i,J,k+1) + if (associated(ADp%dv_dt_dia)) & + ADp%dv_dt_dia(i,J,k) = (v(i,J,k) - ADp%dv_dt_dia(i,J,k)) * Idt + enddo ; enddo + if (associated(ADp%dv_dt_dia)) then + do i=is,ie + ADp%dv_dt_dia(i,J,nz) = (v(i,J,nz)-ADp%dv_dt_dia(i,J,nz)) * Idt + enddo + endif + enddo + call cpu_clock_end(id_clock_tridiag) + if (CS%debug) then + call MOM_state_chksum("after u/v tridiag ", u, v, h, G, GV, US, haloshift=0) + endif + + ! Diagnose the diapycnal diffusivities and other related quantities. + if (CS%id_Kd_int > 0) call post_data(CS%id_Kd_int, Kd_int, CS%diag) + if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) + if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) + + if (CS%id_ea > 0) call post_data(CS%id_ea, ea, CS%diag) + if (CS%id_eb > 0) call post_data(CS%id_eb, eb, CS%diag) + + if (CS%id_dudt_dia > 0) call post_data(CS%id_dudt_dia, ADp%du_dt_dia, CS%diag) + if (CS%id_dvdt_dia > 0) call post_data(CS%id_dvdt_dia, ADp%dv_dt_dia, CS%diag) + if (CS%id_wd > 0) call post_data(CS%id_wd, CDp%diapyc_vel, CS%diag) + + if (CS%id_Tdif > 0) call post_data(CS%id_Tdif, Tdif_flx, CS%diag) + if (CS%id_Tadv > 0) call post_data(CS%id_Tadv, Tadv_flx, CS%diag) + if (CS%id_Sdif > 0) call post_data(CS%id_Sdif, Sdif_flx, CS%diag) + if (CS%id_Sadv > 0) call post_data(CS%id_Sadv, Sadv_flx, CS%diag) + + ! Diagnostics for thickness-weighted vertically averaged diapycnal accelerations + if (CS%id_hf_dudt_dia_2d > 0) & + call post_product_sum_u(CS%id_hf_dudt_dia_2d, ADp%du_dt_dia, ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_dvdt_dia_2d > 0) & + call post_product_sum_v(CS%id_hf_dvdt_dia_2d, ADp%dv_dt_dia, ADp%diag_hfrac_v, G, nz, CS%diag) + + call disable_averaging(CS%diag) + + if (showCallTree) call callTree_leave("layered_diabatic()") + +end subroutine layered_diabatic + +!> Returns pointers or values of members within the diabatic_CS type. For extensibility, +!! each returned argument is an optional argument +subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, minimum_forcing_depth, & + KPP_CSp, energetic_PBL_CSp, diabatic_aux_CSp, diabatic_halo, use_KPP) + type(diabatic_CS), target, intent(in) :: CS !< module control structure + ! All output arguments are optional + type(opacity_CS), optional, pointer :: opacity_CSp !< A pointer to be set to the opacity control structure + type(optics_type), optional, pointer :: optics_CSp !< A pointer to be set to the optics control structure + type(KPP_CS), optional, pointer :: KPP_CSp !< A pointer to be set to the KPP CS + type(energetic_PBL_CS), optional, pointer :: energetic_PBL_CSp !< A pointer to be set to the ePBL CS + real, optional, intent( out) :: evap_CFL_limit ! m or kg m-2]. + type(diabatic_aux_CS), optional, pointer :: diabatic_aux_CSp !< A pointer to be set to the diabatic_aux + !! control structure + integer, optional, intent( out) :: diabatic_halo !< The halo size where the diabatic algorithms + !! assume thermodynamics properties are valid. + logical, optional, intent( out) :: use_KPP !< If true, diabatic is using KPP vertical mixing + + ! Pointers to control structures + if (present(opacity_CSp)) opacity_CSp => CS%opacity + if (present(optics_CSp)) optics_CSp => CS%optics + if (present(KPP_CSp)) KPP_CSp => CS%KPP_CSp + if (present(energetic_PBL_CSp) .and. CS%use_energetic_PBL) energetic_PBL_CSp => CS%ePBL + if (present(diabatic_aux_CSp)) diabatic_aux_CSp => CS%diabatic_aux_CSp + + ! Constants within diabatic_CS + if (present(evap_CFL_limit)) evap_CFL_limit = CS%evap_CFL_limit + if (present(minimum_forcing_depth)) minimum_forcing_depth = CS%minimum_forcing_depth + if (present(diabatic_halo)) diabatic_halo = CS%halo_diabatic + if (present(use_KPP)) use_KPP = CS%use_KPP +end subroutine extract_diabatic_member + +!> Routine called for adiabatic physics +subroutine adiabatic(h, tv, fluxes, dt, G, GV, US, CS) + type(ocean_grid_type), intent(inout) :: 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 !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + type(forcing), intent(inout) :: fluxes !< boundary fluxes + real, intent(in) :: dt !< time step [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diabatic_CS), pointer :: CS !< module control structure + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: zeros ! An array of zeros with units of [H ~> m or kg m-2] + + zeros(:,:,:) = 0.0 + + call call_tracer_column_fns(h, h, zeros, zeros, fluxes, zeros(:,:,1), dt, G, GV, US, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug) + +end subroutine adiabatic + + +!> This routine diagnoses tendencies from application of diabatic diffusion +!! using ALE algorithm. Note that layer thickness is not altered by +!! diabatic diffusion. +subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: temp_old !< temperature prior to diabatic + !! physics [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: saln_old !< salinity prior to diabatic physics [S ~> ppt] + real, intent(in) :: dt !< time step [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diabatic_CS), pointer :: CS !< module control structure + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d ! A 3-d work array for diagnostics [various] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array for diagnostics [various] + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: ppt2mks ! Conversion factor from S to kg/kg [S-1 ~> ppt-1]. + integer :: i, j, k, is, ie, js, je, nz + logical :: do_saln_tend ! Calculate salinity-based tendency diagnostics + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Idt = 0.0 ; if (dt > 0.0) Idt = 1. / dt + work_3d(:,:,:) = 0.0 + work_2d(:,:) = 0.0 + + + ! temperature tendency + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = (tv%T(i,j,k)-temp_old(i,j,k))*Idt + enddo ; enddo ; enddo + if (CS%id_diabatic_diff_temp_tend > 0) then + call post_data(CS%id_diabatic_diff_temp_tend, work_3d, CS%diag, alt_h=h) + endif + + ! heat tendency + if (CS%id_diabatic_diff_heat_tend > 0 .or. CS%id_diabatic_diff_heat_tend_2d > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = h(i,j,k)*GV%H_to_RZ * tv%C_p * work_3d(i,j,k) + enddo ; enddo ; enddo + if (CS%id_diabatic_diff_heat_tend > 0) then + call post_data(CS%id_diabatic_diff_heat_tend, work_3d, CS%diag, alt_h=h) + endif + if (CS%id_diabatic_diff_heat_tend_2d > 0) then + work_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work_2d(i,j) = work_2d(i,j) + work_3d(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_diabatic_diff_heat_tend_2d, work_2d, CS%diag) + endif + endif + + ! salinity tendency + do_saln_tend = CS%id_diabatic_diff_saln_tend > 0 & + .or. CS%id_diabatic_diff_salt_tend > 0 & + .or. CS%id_diabatic_diff_salt_tend_2d > 0 + + if (do_saln_tend) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = (tv%S(i,j,k) - saln_old(i,j,k)) * Idt + enddo ; enddo ; enddo + + if (CS%id_diabatic_diff_saln_tend > 0) & + call post_data(CS%id_diabatic_diff_saln_tend, work_3d, CS%diag, alt_h=h) + + ! salt tendency + if (CS%id_diabatic_diff_salt_tend > 0 .or. CS%id_diabatic_diff_salt_tend_2d > 0) then + ppt2mks = US%S_to_ppt*0.001 + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = h(i,j,k)*GV%H_to_RZ * ppt2mks * work_3d(i,j,k) + enddo ; enddo ; enddo + if (CS%id_diabatic_diff_salt_tend > 0) then + call post_data(CS%id_diabatic_diff_salt_tend, work_3d, CS%diag, alt_h=h) + endif + if (CS%id_diabatic_diff_salt_tend_2d > 0) then + work_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work_2d(i,j) = work_2d(i,j) + work_3d(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_diabatic_diff_salt_tend_2d, work_2d, CS%diag) + endif + endif + endif + +end subroutine diagnose_diabatic_diff_tendency + + +!> This routine diagnoses tendencies from application of boundary fluxes. +!! These impacts are generally 3d, in particular for penetrative shortwave. +!! Other fluxes contribute 3d in cases when the layers vanish or are very thin, +!! in which case we distribute the flux into k > 1 layers. +subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, & + dt, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< thickness after boundary flux application [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: temp_old !< temperature prior to boundary flux application [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: saln_old !< salinity prior to boundary flux application [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< thickness prior to boundary flux application [H ~> m or kg m-2] + real, intent(in) :: dt !< time step [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diabatic_CS), pointer :: CS !< module control structure + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d ! A 3-d work array for diagnostics [various] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array for diagnostics [various] + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: ppt2mks ! Conversion factor from S to kg/kg [S-1 ~> ppt-1]. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Idt = 0.0 ; if (dt > 0.0) Idt = 1. / dt + work_3d(:,:,:) = 0.0 + work_2d(:,:) = 0.0 + + ! Thickness tendency + if (CS%id_boundary_forcing_h_tendency > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = (h(i,j,k) - h_old(i,j,k))*Idt + enddo ; enddo ; enddo + call post_data(CS%id_boundary_forcing_h_tendency, work_3d, CS%diag, alt_h=h_old) + endif + + ! temperature tendency + if (CS%id_boundary_forcing_temp_tend > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = (tv%T(i,j,k)-temp_old(i,j,k))*Idt + enddo ; enddo ; enddo + call post_data(CS%id_boundary_forcing_temp_tend, work_3d, CS%diag, alt_h=h_old) + endif + + ! heat tendency + if (CS%id_boundary_forcing_heat_tend > 0 .or. CS%id_boundary_forcing_heat_tend_2d > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = GV%H_to_RZ * tv%C_p * Idt * (h(i,j,k) * tv%T(i,j,k) - h_old(i,j,k) * temp_old(i,j,k)) + enddo ; enddo ; enddo + if (CS%id_boundary_forcing_heat_tend > 0) then + call post_data(CS%id_boundary_forcing_heat_tend, work_3d, CS%diag, alt_h=h_old) + endif + if (CS%id_boundary_forcing_heat_tend_2d > 0) then + work_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work_2d(i,j) = work_2d(i,j) + work_3d(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_boundary_forcing_heat_tend_2d, work_2d, CS%diag) + endif + endif + + ! salinity tendency + if (CS%id_boundary_forcing_saln_tend > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = (tv%S(i,j,k)-saln_old(i,j,k))*Idt + enddo ; enddo ; enddo + call post_data(CS%id_boundary_forcing_saln_tend, work_3d, CS%diag, alt_h=h_old) + endif + + ! salt tendency + if (CS%id_boundary_forcing_salt_tend > 0 .or. CS%id_boundary_forcing_salt_tend_2d > 0) then + ppt2mks = US%S_to_ppt*0.001 + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = GV%H_to_RZ * ppt2mks * Idt * (h(i,j,k) * tv%S(i,j,k) - h_old(i,j,k) * saln_old(i,j,k)) + enddo ; enddo ; enddo + if (CS%id_boundary_forcing_salt_tend > 0) then + call post_data(CS%id_boundary_forcing_salt_tend, work_3d, CS%diag, alt_h=h_old) + endif + if (CS%id_boundary_forcing_salt_tend_2d > 0) then + work_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work_2d(i,j) = work_2d(i,j) + work_3d(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_boundary_forcing_salt_tend_2d, work_2d, CS%diag) + endif + endif + +end subroutine diagnose_boundary_forcing_tendency + + +!> This routine diagnoses tendencies for temperature and heat from frazil formation. +!! This routine is called twice from within subroutine diabatic; at start and at +!! end of the diabatic processes. The impacts from frazil are generally a function +!! of depth. Hence, when checking heat budget, be sure to remove HFSIFRAZIL from HFDS in k=1. +subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: temp_old !< temperature prior to frazil formation [C ~> degC] + real, intent(in) :: dt !< time step [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diabatic_CS), pointer :: CS !< module control structure + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d ! A 3-d work array for diagnostics [various] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array for diagnostics [various] + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Idt = 0.0 ; if (dt > 0.0) Idt = 1. / dt + + ! temperature tendency + if (CS%id_frazil_temp_tend > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = Idt * (tv%T(i,j,k)-temp_old(i,j,k)) + enddo ; enddo ; enddo + call post_data(CS%id_frazil_temp_tend, work_3d, CS%diag) + endif + + ! heat tendency + if (CS%id_frazil_heat_tend > 0 .or. CS%id_frazil_heat_tend_2d > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = GV%H_to_RZ * tv%C_p * h(i,j,k) * Idt * (tv%T(i,j,k)-temp_old(i,j,k)) + enddo ; enddo ; enddo + if (CS%id_frazil_heat_tend > 0) call post_data(CS%id_frazil_heat_tend, work_3d, CS%diag) + + ! As a consistency check, we must have + ! FRAZIL_HEAT_TENDENCY_2d = HFSIFRAZIL + if (CS%id_frazil_heat_tend_2d > 0) then + work_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work_2d(i,j) = work_2d(i,j) + work_3d(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_frazil_heat_tend_2d, work_2d, CS%diag) + endif + endif + +end subroutine diagnose_frazil_tendency + + +!> A simplified version of diabatic_driver_init that will allow +!! tracer column functions to be called without allowing any +!! of the diabatic processes to be used. +subroutine adiabatic_driver_init(Time, G, param_file, diag, CS, & + tracer_flow_CSp) + type(time_type), intent(in) :: Time !< current model time + type(ocean_grid_type), intent(in) :: G !< model grid structure + type(param_file_type), intent(in) :: param_file !< the file to parse for parameter values + type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output + type(diabatic_CS), pointer :: CS !< module control structure + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< pointer to control structure of the + !! tracer flow control module + + ! This "include" declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_diabatic_driver" ! This module's name. + + if (associated(CS)) then + call MOM_error(WARNING, "adiabatic_driver_init called with an "// & + "associated control structure.") + return + else ; allocate(CS) ; endif + + CS%diag => diag + if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp + + ! Set default, read and log parameters + call log_version(param_file, mdl, version, & + "The following parameters are used for diabatic processes.") + + ! Check for any subsidiary parameters that are inconsistent with the adiabatic mode. + call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified via calls to initialize_sponge and possibly "//& + "set_up_sponge_field.", default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "ENERGETICS_SFC_PBL", CS%use_energetic_PBL, & + "If true, use an implied energetics planetary boundary "//& + "layer scheme to determine the diffusivity and viscosity "//& + "in the surface boundary layer.", default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_KPP", CS%use_KPP, & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& + "to calculate diffusivities and non-local transport in the OBL.", & + default=.false., do_not_log=.true.) + + if (CS%use_sponge) call MOM_error(WARNING, & + "When ADIABATIC = True, it is inconsistent to set SPONGE = True.") + if (CS%use_energetic_PBL) call MOM_error(WARNING, & + "When ADIABATIC = True, it is inconsistent to set ENERGETICS_SFC_PBL = True.") + if (CS%use_KPP) call MOM_error(WARNING, & + "When ADIABATIC = True, it is inconsistent to set USE_KPP = True.") + + if (CS%use_sponge .or. CS%use_energetic_PBL .or. CS%use_KPP) & + call MOM_error(FATAL, "adiabatic_driver_init is aborting due to inconsistent parameter settings.") + +end subroutine adiabatic_driver_init + + +!> This routine initializes the diabatic driver module. +subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, diag, & + ADp, CDp, CS, tracer_flow_CSp, sponge_CSp, & + ALE_sponge_CSp, oda_incupd_CSp, int_tide_CSp) + type(time_type), target :: Time !< model time + type(ocean_grid_type), intent(inout) :: G !< model grid structure + type(verticalGrid_type), intent(in) :: GV !< model vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< file to parse for parameter values + logical, intent(in) :: useALEalgorithm !< logical for whether to use ALE remapping + type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output + type(accel_diag_ptrs), intent(inout) :: ADp !< pointers to accelerations in momentum equations, + !! to enable diagnostics, like energy budgets + type(cont_diag_ptrs), intent(inout) :: CDp !< pointers to terms in continuity equations + type(diabatic_CS), pointer :: CS !< module control structure + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< pointer to control structure of the + !! tracer flow control module + type(sponge_CS), pointer :: sponge_CSp !< pointer to the sponge module control structure + type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< pointer to the ALE sponge module control structure + type(oda_incupd_CS), pointer :: oda_incupd_CSp !< pointer to the ocean data assimilation incremental + !! update module control structure + type(int_tide_CS), pointer :: int_tide_CSp !< pointer to the internal tide structure + + ! Local variables + real :: Kd ! A diffusivity used in the default for other tracer diffusivities [Z2 T-1 ~> m2 s-1] + logical :: use_temperature + character(len=20) :: EN1, EN2, EN3 + + ! This "include" declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_diabatic_driver" ! This module's name. + character(len=48) :: thickness_units + character(len=40) :: var_name + character(len=160) :: var_descript + logical :: physical_OBL_scheme + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nbands, m + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (associated(CS)) then + call MOM_error(WARNING, "diabatic_driver_init called with an "// & + "associated control structure.") + return + else + allocate(CS) + endif + + CS%initialized = .true. + + CS%diag => diag + CS%Time => Time + + if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp + if (associated(sponge_CSp)) CS%sponge_CSp => sponge_CSp + if (associated(ALE_sponge_CSp)) CS%ALE_sponge_CSp => ALE_sponge_CSp + if (associated(oda_incupd_CSp)) CS%oda_incupd_CSp => oda_incupd_CSp + if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp + + CS%useALEalgorithm = useALEalgorithm + CS%use_bulkmixedlayer = (GV%nkml > 0) + + ! Set default, read and log parameters + call log_version(param_file, mdl, version, & + "The following parameters are used for diabatic processes.", & + log_to_all=.true., debugging=.true.) + call get_param(param_file, mdl, "USE_LEGACY_DIABATIC_DRIVER", CS%use_legacy_diabatic, & + "If true, use a legacy version of the diabatic subroutine. "//& + "This is temporary and is needed to avoid change in answers.", & + default=.true.) + call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified via calls to initialize_sponge and possibly "//& + "set_up_sponge_field.", default=.false.) + call get_param(param_file, mdl, "ODA_INCUPD", CS%use_oda_incupd, & + "If true, oda incremental updates will be applied "//& + "everywhere in the domain.", default=.false.) + call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & + "If true, temperature and salinity are used as state "//& + "variables.", default=.true.) + call get_param(param_file, mdl, "ENERGETICS_SFC_PBL", CS%use_energetic_PBL, & + "If true, use an implied energetics planetary boundary "//& + "layer scheme to determine the diffusivity and viscosity "//& + "in the surface boundary layer.", default=.false.) + call get_param(param_file, mdl, "EPBL_IS_ADDITIVE", CS%ePBL_is_additive, & + "If true, the diffusivity from ePBL is added to all "//& + "other diffusivities. Otherwise, the larger of kappa-shear "//& + "and ePBL diffusivities are used.", default=.true.) + call get_param(param_file, mdl, "PRANDTL_EPBL", CS%ePBL_Prandtl, & + "The Prandtl number used by ePBL to convert vertical diffusivities into "//& + "viscosities.", default=1.0, units="nondim", do_not_log=.not.CS%use_energetic_PBL) + call get_param(param_file, mdl, "USE_KPP", CS%use_KPP, & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& + "to calculate diffusivities and non-local transport in the OBL.", & + default=.false., do_not_log=.true.) + CS%use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) + + CS%use_kappa_shear = kappa_shear_is_used(param_file) + CS%use_CVMix_shear = CVMix_shear_is_used(param_file) + + if (CS%use_bulkmixedlayer) then + call get_param(param_file, mdl, "ML_MIX_FIRST", CS%ML_mix_first, & + "The fraction of the mixed layer mixing that is applied "//& + "before interior diapycnal mixing. 0 by default.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "NKBL", CS%nkbl, default=2, do_not_log=.true.) + else + CS%ML_mix_first = 0.0 + endif + if (use_temperature) then + call get_param(param_file, mdl, "DO_GEOTHERMAL", CS%use_geothermal, & + "If true, apply geothermal heating.", default=.false.) + else + CS%use_geothermal = .false. + endif + call get_param(param_file, mdl, "INTERNAL_TIDES", CS%use_int_tides, & + "If true, use the code that advances a separate set of "//& + "equations for the internal tide energy density.", default=.false.) + + call get_param(param_file, mdl, "MASSLESS_MATCH_TARGETS", CS%massless_match_targets, & + "If true, the temperature and salinity of massless layers "//& + "are kept consistent with their target densities. "//& + "Otherwise the properties of massless layers evolve "//& + "diffusively to match massive neighboring layers.", & + default=.true.) + + call get_param(param_file, mdl, "AGGREGATE_FW_FORCING", CS%aggregate_FW_forcing, & + "If true, the net incoming and outgoing fresh water fluxes are combined "//& + "and applied as either incoming or outgoing depending on the sign of the net. "//& + "If false, the net incoming fresh water flux is added to the model and "//& + "thereafter the net outgoing is removed from the topmost non-vanished "//& + "layers of the updated state.", default=.true.) + + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_CONSERVATION", CS%debugConservation, & + "If true, monitor conservation and extrema.", & + default=.false., debuggingParam=.true.) + + call get_param(param_file, mdl, "DEBUG_ENERGY_REQ", CS%debug_energy_req, & + "If true, debug the energy requirements.", default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "MIX_BOUNDARY_TRACERS", CS%mix_boundary_tracers, & + "If true, mix the passive tracers in massless layers at "//& + "the bottom into the interior as though a diffusivity of "//& + "KD_MIN_TR were operating.", default=.true.) + call get_param(param_file, mdl, "MIX_BOUNDARY_TRACER_ALE", CS%mix_boundary_tracer_ALE, & + "If true and in ALE mode, mix the passive tracers in massless layers at "//& + "the bottom into the interior as though a diffusivity of "//& + "KD_MIN_TR were operating.", default=.false., do_not_log=.not.CS%useALEalgorithm) + + if (CS%mix_boundary_tracers .or. CS%mix_boundary_tracer_ALE) then + call get_param(param_file, mdl, "KD", Kd, units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) + call get_param(param_file, mdl, "KD_MIN_TR", CS%Kd_min_tr, & + "A minimal diffusivity that should always be applied to "//& + "tracers, especially in massless layers near the bottom. "//& + "The default is 0.1*KD.", & + units="m2 s-1", default=0.1*Kd*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "KD_BBL_TR", CS%Kd_BBL_tr, & + "A bottom boundary layer tracer diffusivity that will "//& + "allow for explicitly specified bottom fluxes. The "//& + "entrainment at the bottom is at least sqrt(Kd_BBL_tr*dt) "//& + "over the same distance.", & + units="m2 s-1", default=0., scale=GV%m2_s_to_HZ_T*(US%Z_to_m*GV%m_to_H)) + ! The scaling factor here is usually equivalent to GV%m2_s_to_HZ_T*GV%Z_to_H. + endif + + call get_param(param_file, mdl, "TRACER_TRIDIAG", CS%tracer_tridiag, & + "If true, use the passive tracer tridiagonal solver for T and S", & + default=.false.) + + call get_param(param_file, mdl, "MINIMUM_FORCING_DEPTH", CS%minimum_forcing_depth, & + "The smallest depth over which forcing can be applied. This "//& + "only takes effect when near-surface layers become thin "//& + "relative to this scale, in which case the forcing tendencies "//& + "scaled down by distributing the forcing over this depth scale.", & + units="m", default=0.001, scale=GV%m_to_H) + call get_param(param_file, mdl, "EVAP_CFL_LIMIT", CS%evap_CFL_limit, & + "The largest fraction of a layer than can be lost to forcing "//& + "(e.g. evaporation, sea-ice formation) in one time-step. The unused "//& + "mass loss is passed down through the column.", & + units="nondim", default=0.8) + + if (CS%use_energetic_PBL .and. .not.CS%useALEalgorithm) & + call MOM_error(FATAL, "diabatic_driver_init: "//& + "ENERGETICS_SFC_PBL = True is only coded to work when USE_REGRIDDING = True.") + + ! Register all available diagnostics for this module. + thickness_units = get_thickness_units(GV) + + CS%id_ea_t = register_diag_field('ocean_model', 'ea_t', diag%axesTL, Time, & + 'Layer (heat) entrainment from above per timestep', 'm', conversion=GV%H_to_m) + CS%id_eb_t = register_diag_field('ocean_model', 'eb_t', diag%axesTL, Time, & + 'Layer (heat) entrainment from below per timestep', 'm', conversion=GV%H_to_m) + CS%id_ea_s = register_diag_field('ocean_model', 'ea_s', diag%axesTL, Time, & + 'Layer (salt) entrainment from above per timestep', 'm', conversion=GV%H_to_m) + CS%id_eb_s = register_diag_field('ocean_model', 'eb_s', diag%axesTL, Time, & + 'Layer (salt) entrainment from below per timestep', 'm', conversion=GV%H_to_m) + ! used by layer diabatic + CS%id_ea = register_diag_field('ocean_model', 'ea', diag%axesTL, Time, & + 'Layer entrainment from above per timestep', 'm', conversion=GV%H_to_m) + CS%id_eb = register_diag_field('ocean_model', 'eb', diag%axesTL, Time, & + 'Layer entrainment from below per timestep', 'm', conversion=GV%H_to_m) + if (.not.CS%useALEalgorithm) then + CS%id_wd = register_diag_field('ocean_model', 'wd', diag%axesTi, Time, & + 'Diapycnal velocity', 'm s-1', conversion=GV%H_to_m*US%s_to_T) + if (CS%id_wd > 0) call safe_alloc_ptr(CDp%diapyc_vel,isd,ied,jsd,jed,nz+1) + + CS%id_dudt_dia = register_diag_field('ocean_model', 'dudt_dia', diag%axesCuL, Time, & + 'Zonal Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_dvdt_dia = register_diag_field('ocean_model', 'dvdt_dia', diag%axesCvL, Time, & + 'Meridional Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) + + CS%id_hf_dudt_dia_2d = register_diag_field('ocean_model', 'hf_dudt_dia_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Diapycnal Mixing', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_dudt_dia_2d > 0) call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_dvdt_dia_2d = register_diag_field('ocean_model', 'hf_dvdt_dia_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Diapycnal Mixing', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_dvdt_dia_2d > 0) call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + if ((CS%id_dudt_dia > 0) .or. (CS%id_hf_dudt_dia_2d > 0)) & + call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) + if ((CS%id_dvdt_dia > 0) .or. (CS%id_hf_dvdt_dia_2d > 0)) & + call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) + endif + + if (use_temperature) then + CS%id_Tdif = register_diag_field('ocean_model',"Tflx_dia_diff", diag%axesTi, & + Time, "Diffusive diapycnal temperature flux across interfaces", & + units="degC m s-1", conversion=US%C_to_degC*GV%H_to_m*US%s_to_T) + if (.not.CS%useALEalgorithm) then + CS%id_Tadv = register_diag_field('ocean_model',"Tflx_dia_adv", diag%axesTi, & + Time, "Advective diapycnal temperature flux across interfaces", & + units="degC m s-1", conversion=US%C_to_degC*GV%H_to_m*US%s_to_T) + endif + CS%id_Sdif = register_diag_field('ocean_model',"Sflx_dia_diff", diag%axesTi, & + Time, "Diffusive diapycnal salnity flux across interfaces", & + units="psu m s-1", conversion=US%S_to_ppt*GV%H_to_m*US%s_to_T) + if (.not.CS%useALEalgorithm) then + CS%id_Sadv = register_diag_field('ocean_model',"Sflx_dia_adv", diag%axesTi, & + Time, "Advective diapycnal salnity flux across interfaces", & + units="psu m s-1", conversion=US%S_to_ppt*GV%H_to_m*US%s_to_T) + endif + CS%id_MLD_003 = register_diag_field('ocean_model', 'MLD_003', diag%axesT1, Time, & + 'Mixed layer depth (delta rho = 0.03)', units='m', conversion=US%Z_to_m, & + cmor_field_name='mlotst', cmor_long_name='Ocean Mixed Layer Thickness Defined by Sigma T', & + cmor_standard_name='ocean_mixed_layer_thickness_defined_by_sigma_t') + CS%id_mlotstsq = register_diag_field('ocean_model', 'mlotstsq', diag%axesT1, Time, & + long_name='Square of Ocean Mixed Layer Thickness Defined by Sigma T', & + standard_name='square_of_ocean_mixed_layer_thickness_defined_by_sigma_t', & + units='m2', conversion=US%Z_to_m**2) + CS%id_MLD_0125 = register_diag_field('ocean_model', 'MLD_0125', diag%axesT1, Time, & + 'Mixed layer depth (delta rho = 0.125)', 'm', conversion=US%Z_to_m) + call get_param(param_file, mdl, "MLD_EN_VALS", CS%MLD_En_vals, & + "The energy values used to compute MLDs. If not set (or all set to 0.), the "//& + "default will overwrite to 25., 2500., 250000.", & + units='J/m2', default=0., scale=US%W_m2_to_RZ3_T3*US%s_to_T) + if ((CS%MLD_En_vals(1)==0.).and.(CS%MLD_En_vals(2)==0.).and.(CS%MLD_En_vals(3)==0.)) then + CS%MLD_En_vals = (/ 25.*US%W_m2_to_RZ3_T3*US%s_to_T, & + 2500.*US%W_m2_to_RZ3_T3*US%s_to_T, & + 250000.*US%W_m2_to_RZ3_T3*US%s_to_T /) + endif + write(EN1,'(F10.2)') CS%MLD_En_vals(1)*US%RZ3_T3_to_W_m2*US%T_to_s + write(EN2,'(F10.2)') CS%MLD_En_vals(2)*US%RZ3_T3_to_W_m2*US%T_to_s + write(EN3,'(F10.2)') CS%MLD_En_vals(3)*US%RZ3_T3_to_W_m2*US%T_to_s + CS%id_MLD_EN1 = register_diag_field('ocean_model', 'MLD_EN1', diag%axesT1, Time, & + 'Mixed layer depth for energy value set to '//trim(EN1)//' J/m2 (Energy set by 1st MLD_EN_VALS)', & + units='m', conversion=US%Z_to_m) + CS%id_MLD_EN2 = register_diag_field('ocean_model', 'MLD_EN2', diag%axesT1, Time, & + 'Mixed layer depth for energy value set to '//trim(EN2)//' J/m2 (Energy set by 2nd MLD_EN_VALS)', & + units='m', conversion=US%Z_to_m) + CS%id_MLD_EN3 = register_diag_field('ocean_model', 'MLD_EN3', diag%axesT1, Time, & + 'Mixed layer depth for energy value set to '//trim(EN3)//' J/m2 (Energy set by 3rd MLD_EN_VALS)', & + units='m', conversion=US%Z_to_m) + CS%id_subMLN2 = register_diag_field('ocean_model', 'subML_N2', diag%axesT1, Time, & + 'Squared buoyancy frequency below mixed layer', units='s-2', conversion=US%s_to_T**2) + CS%id_MLD_user = register_diag_field('ocean_model', 'MLD_user', diag%axesT1, Time, & + 'Mixed layer depth (used defined)', units='m', conversion=US%Z_to_m) + endif + call get_param(param_file, mdl, "DIAG_MLD_DENSITY_DIFF", CS%MLDdensityDifference, & + "The density difference used to determine a diagnostic mixed "//& + "layer depth, MLD_user, following the definition of Levitus 1982. "//& + "The MLD is the depth at which the density is larger than the "//& + "surface density by the specified amount.", & + units='kg/m3', default=0.1, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "DIAG_DEPTH_SUBML_N2", CS%dz_subML_N2, & + "The distance over which to calculate a diagnostic of the "//& + "stratification at the base of the mixed layer.", & + units='m', default=50.0, scale=US%m_to_Z) + + ! diagnostics for values prior to diabatic and prior to ALE + CS%id_u_predia = register_diag_field('ocean_model', 'u_predia', diag%axesCuL, Time, & + 'Zonal velocity before diabatic forcing', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_v_predia = register_diag_field('ocean_model', 'v_predia', diag%axesCvL, Time, & + 'Meridional velocity before diabatic forcing', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_h_predia = register_diag_field('ocean_model', 'h_predia', diag%axesTL, Time, & + 'Layer Thickness before diabatic forcing', & + trim(thickness_units), conversion=GV%H_to_MKS, v_extensive=.true.) + CS%id_e_predia = register_diag_field('ocean_model', 'e_predia', diag%axesTi, Time, & + 'Interface Heights before diabatic forcing', 'm', conversion=US%Z_to_m) + if (use_temperature) then + CS%id_T_predia = register_diag_field('ocean_model', 'temp_predia', diag%axesTL, Time, & + 'Potential Temperature', 'degC', conversion=US%C_to_degC) + CS%id_S_predia = register_diag_field('ocean_model', 'salt_predia', diag%axesTL, Time, & + 'Salinity', 'PSU', conversion=US%S_to_ppt) + endif + + CS%id_Kd_int = register_diag_field('ocean_model', 'Kd_interface', diag%axesTi, Time, & + 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + if (CS%use_energetic_PBL) then + CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & + 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + endif + + CS%id_Kd_heat = register_diag_field('ocean_model', 'Kd_heat', diag%axesTi, Time, & + 'Total diapycnal diffusivity for heat at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s, & + cmor_field_name='difvho', & + cmor_standard_name='ocean_vertical_heat_diffusivity', & + cmor_long_name='Ocean vertical heat diffusivity') + CS%id_Kd_salt = register_diag_field('ocean_model', 'Kd_salt', diag%axesTi, Time, & + 'Total diapycnal diffusivity for salt at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s, & + cmor_field_name='difvso', & + cmor_standard_name='ocean_vertical_salt_diffusivity', & + cmor_long_name='Ocean vertical salt diffusivity') + + ! CS%useKPP is set to True if KPP-scheme is to be used, False otherwise. + ! KPP_init() allocated CS%KPP_Csp and also sets CS%KPPisPassive + CS%useKPP = KPP_init(param_file, G, GV, US, diag, Time, CS%KPP_CSp, passive=CS%KPPisPassive) + if (CS%useKPP) then + allocate(CS%KPP_NLTheat(isd:ied,jsd:jed,nz+1), source=0.0) + allocate(CS%KPP_NLTscalar(isd:ied,jsd:jed,nz+1), source=0.0) + allocate(CS%KPP_buoy_flux(isd:ied,jsd:jed,nz+1), source=0.0) + allocate(CS%KPP_temp_flux(isd:ied,jsd:jed), source=0.0) + allocate(CS%KPP_salt_flux(isd:ied,jsd:jed), source=0.0) + endif + + + ! Diagnostics for tendencies of temperature and salinity due to diabatic processes, + ! available only for ALE algorithm. + ! Diagnostics for tendencies of temperature and heat due to frazil + CS%id_diabatic_diff_h = register_diag_field('ocean_model', 'diabatic_diff_h', diag%axesTL, Time, & + 'Cell thickness used during diabatic diffusion', & + thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) + + if (CS%useALEalgorithm) then + CS%id_diabatic_diff_temp_tend = register_diag_field('ocean_model', & + 'diabatic_diff_temp_tendency', diag%axesTL, Time, & + 'Diabatic diffusion temperature tendency', 'degC s-1', conversion=US%C_to_degC*US%s_to_T) + if (CS%id_diabatic_diff_temp_tend > 0) then + CS%diabatic_diff_tendency_diag = .true. + endif + + CS%id_diabatic_diff_saln_tend = register_diag_field('ocean_model',& + 'diabatic_diff_saln_tendency', diag%axesTL, Time, & + 'Diabatic diffusion salinity tendency', 'psu s-1', conversion=US%S_to_ppt*US%s_to_T) + if (CS%id_diabatic_diff_saln_tend > 0) then + CS%diabatic_diff_tendency_diag = .true. + endif + + CS%id_diabatic_diff_heat_tend = register_diag_field('ocean_model', & + 'diabatic_heat_tendency', diag%axesTL, Time, & + 'Diabatic diffusion heat tendency', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, cmor_field_name='opottempdiff', & + cmor_standard_name='tendency_of_sea_water_potential_temperature_expressed_as_heat_content_'// & + 'due_to_parameterized_dianeutral_mixing', & + cmor_long_name='Tendency of sea water potential temperature expressed as heat content '// & + 'due to parameterized dianeutral mixing', & + v_extensive=.true.) + if (CS%id_diabatic_diff_heat_tend > 0) then + CS%diabatic_diff_tendency_diag = .true. + endif + + CS%id_diabatic_diff_salt_tend = register_diag_field('ocean_model', & + 'diabatic_salt_tendency', diag%axesTL, Time, & + 'Diabatic diffusion of salt tendency', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, cmor_field_name='osaltdiff', & + cmor_standard_name='tendency_of_sea_water_salinity_expressed_as_salt_content_'// & + 'due_to_parameterized_dianeutral_mixing', & + cmor_long_name='Tendency of sea water salinity expressed as salt content '// & + 'due to parameterized dianeutral mixing', & + v_extensive=.true.) + if (CS%id_diabatic_diff_salt_tend > 0) then + CS%diabatic_diff_tendency_diag = .true. + endif + + ! This diagnostic should equal to roundoff if all is working well. + CS%id_diabatic_diff_heat_tend_2d = register_diag_field('ocean_model', & + 'diabatic_heat_tendency_2d', diag%axesT1, Time, & + 'Depth integrated diabatic diffusion heat tendency', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, cmor_field_name='opottempdiff_2d', & + cmor_standard_name='tendency_of_sea_water_potential_temperature_expressed_as_heat_content_'//& + 'due_to_parameterized_dianeutral_mixing_depth_integrated', & + cmor_long_name='Tendency of sea water potential temperature expressed as heat content '//& + 'due to parameterized dianeutral mixing depth integrated') + if (CS%id_diabatic_diff_heat_tend_2d > 0) then + CS%diabatic_diff_tendency_diag = .true. + endif + + ! This diagnostic should equal to roundoff if all is working well. + CS%id_diabatic_diff_salt_tend_2d = register_diag_field('ocean_model', & + 'diabatic_salt_tendency_2d', diag%axesT1, Time, & + 'Depth integrated diabatic diffusion salt tendency', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, cmor_field_name='osaltdiff_2d', & + cmor_standard_name='tendency_of_sea_water_salinity_expressed_as_salt_content_'// & + 'due_to_parameterized_dianeutral_mixing_depth_integrated', & + cmor_long_name='Tendency of sea water salinity expressed as salt content '// & + 'due to parameterized dianeutral mixing depth integrated') + if (CS%id_diabatic_diff_salt_tend_2d > 0) then + CS%diabatic_diff_tendency_diag = .true. + endif + + ! Diagnostics for tendencies of thickness temperature and salinity due to boundary forcing, + ! available only for ALE algorithm. + ! Diagnostics for tendencies of temperature and heat due to frazil + CS%id_boundary_forcing_h = register_diag_field('ocean_model', 'boundary_forcing_h', diag%axesTL, Time, & + 'Cell thickness after applying boundary forcing', & + thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) + CS%id_boundary_forcing_h_tendency = register_diag_field('ocean_model', & + 'boundary_forcing_h_tendency', diag%axesTL, Time, & + 'Cell thickness tendency due to boundary forcing', & + trim(thickness_units)//" s-1", conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) + if (CS%id_boundary_forcing_h_tendency > 0) then + CS%boundary_forcing_tendency_diag = .true. + endif + + CS%id_boundary_forcing_temp_tend = register_diag_field('ocean_model',& + 'boundary_forcing_temp_tendency', diag%axesTL, Time, & + 'Boundary forcing temperature tendency', 'degC s-1', conversion=US%C_to_degC*US%s_to_T) + if (CS%id_boundary_forcing_temp_tend > 0) then + CS%boundary_forcing_tendency_diag = .true. + endif + + CS%id_boundary_forcing_saln_tend = register_diag_field('ocean_model',& + 'boundary_forcing_saln_tendency', diag%axesTL, Time, & + 'Boundary forcing saln tendency', 'psu s-1', conversion=US%S_to_ppt*US%s_to_T) + if (CS%id_boundary_forcing_saln_tend > 0) then + CS%boundary_forcing_tendency_diag = .true. + endif + + 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.) + if (CS%id_boundary_forcing_heat_tend > 0) then + CS%boundary_forcing_tendency_diag = .true. + endif + + CS%id_boundary_forcing_salt_tend = register_diag_field('ocean_model',& + 'boundary_forcing_salt_tendency', diag%axesTL, Time, & + 'Boundary forcing salt tendency', 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + v_extensive = .true.) + if (CS%id_boundary_forcing_salt_tend > 0) then + CS%boundary_forcing_tendency_diag = .true. + endif + + ! This diagnostic should equal to surface heat flux if all is working well. + CS%id_boundary_forcing_heat_tend_2d = register_diag_field('ocean_model',& + 'boundary_forcing_heat_tendency_2d', diag%axesT1, Time, & + 'Depth integrated boundary forcing of ocean heat', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) + if (CS%id_boundary_forcing_heat_tend_2d > 0) then + CS%boundary_forcing_tendency_diag = .true. + endif + + ! This diagnostic should equal to surface salt flux if all is working well. + CS%id_boundary_forcing_salt_tend_2d = register_diag_field('ocean_model',& + 'boundary_forcing_salt_tendency_2d', diag%axesT1, Time, & + 'Depth integrated boundary forcing of ocean salt', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + if (CS%id_boundary_forcing_salt_tend_2d > 0) then + CS%boundary_forcing_tendency_diag = .true. + endif + endif + + ! diagnostics for tendencies of temp and heat due to frazil + CS%id_frazil_h = register_diag_field('ocean_model', 'frazil_h', diag%axesTL, Time, & + long_name='Cell Thickness', standard_name='cell_thickness', & + units=thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) + + ! diagnostic for tendency of temp due to frazil + CS%id_frazil_temp_tend = register_diag_field('ocean_model',& + 'frazil_temp_tendency', diag%axesTL, Time, & + 'Temperature tendency due to frazil formation', 'degC s-1', conversion=US%C_to_degC*US%s_to_T) + if (CS%id_frazil_temp_tend > 0) then + CS%frazil_tendency_diag = .true. + endif + + ! diagnostic for tendency of heat due to frazil + CS%id_frazil_heat_tend = register_diag_field('ocean_model',& + 'frazil_heat_tendency', diag%axesTL, Time, & + 'Heat tendency due to frazil formation', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive=.true.) + if (CS%id_frazil_heat_tend > 0) then + CS%frazil_tendency_diag = .true. + endif + + ! If all is working properly, this diagnostic should equal to hfsifrazil. + CS%id_frazil_heat_tend_2d = register_diag_field('ocean_model',& + 'frazil_heat_tendency_2d', diag%axesT1, Time, & + 'Depth integrated heat tendency due to frazil formation', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) + if (CS%id_frazil_heat_tend_2d > 0) then + CS%frazil_tendency_diag = .true. + endif + + ! CS%use_CVMix_conv is set to True if CVMix convection will be used, otherwise it is False. + CS%use_CVMix_conv = CVMix_conv_init(Time, G, GV, US, param_file, diag, CS%CVMix_conv) + + call entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS%entrain_diffusive, & + just_read_params=CS%useALEalgorithm) + + ! initialize the geothermal heating module + if (CS%use_geothermal) & + call geothermal_init(Time, G, GV, US, param_file, diag, CS%geothermal, useALEalgorithm) + + ! initialize module for internal tide induced mixing + if (CS%use_int_tides) then + call int_tide_input_init(Time, G, GV, US, param_file, diag, CS%int_tide_input_CSp, & + CS%int_tide_input) + call internal_tides_init(Time, G, GV, US, param_file, diag, int_tide_CSp) + endif + + !if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp + + physical_OBL_scheme = (CS%use_bulkmixedlayer .or. CS%use_KPP .or. CS%use_energetic_PBL) + ! initialize module for setting diffusivities + call set_diffusivity_init(Time, G, GV, US, param_file, diag, CS%set_diff_CSp, CS%int_tide_CSp, & + halo_TS=CS%halo_TS_diff, double_diffuse=CS%double_diffuse, & + physical_OBL_scheme=physical_OBL_scheme) + + CS%halo_diabatic = CS%halo_TS_diff + if (CS%use_int_tides) CS%halo_diabatic = max(CS%halo_TS_diff, 2) + + if (CS%useKPP .and. (CS%double_diffuse .and. .not.CS%use_CVMix_ddiff)) & + call MOM_error(FATAL, 'diabatic_driver_init: DOUBLE_DIFFUSION (old method) does not work '//& + 'with KPP. Please set DOUBLE_DIFFUSION=False and USE_CVMIX_DDIFF=True.') + + ! set up the clocks for this module + id_clock_entrain = cpu_clock_id('(Ocean diabatic entrain)', grain=CLOCK_MODULE) + if (CS%use_bulkmixedlayer) & + id_clock_mixedlayer = cpu_clock_id('(Ocean mixed layer)', grain=CLOCK_MODULE) + id_clock_remap = cpu_clock_id('(Ocean vert remap)', grain=CLOCK_MODULE) + if (CS%use_geothermal) & + id_clock_geothermal = cpu_clock_id('(Ocean geothermal)', grain=CLOCK_ROUTINE) + id_clock_set_diffusivity = cpu_clock_id('(Ocean set_diffusivity)', grain=CLOCK_MODULE) + id_clock_kpp = cpu_clock_id('(Ocean KPP)', grain=CLOCK_MODULE) + id_clock_tracers = cpu_clock_id('(Ocean tracer_columns)', grain=CLOCK_MODULE_DRIVER+5) + if (CS%use_sponge) & + id_clock_sponge = cpu_clock_id('(Ocean sponges)', grain=CLOCK_MODULE) + if (CS%use_oda_incupd) & + id_clock_oda_incupd = cpu_clock_id('(Ocean inc. update data assimilation)', grain=CLOCK_MODULE) + id_clock_tridiag = cpu_clock_id('(Ocean diabatic tridiag)', grain=CLOCK_ROUTINE) + id_clock_pass = cpu_clock_id('(Ocean diabatic message passing)', grain=CLOCK_ROUTINE) + id_clock_differential_diff = -1 ; if (CS%double_diffuse .and. .not.CS%use_CVMix_ddiff) & + id_clock_differential_diff = cpu_clock_id('(Ocean differential diffusion)', grain=CLOCK_ROUTINE) + + ! initialize the auxiliary diabatic driver module + call diabatic_aux_init(Time, G, GV, US, param_file, diag, CS%diabatic_aux_CSp, & + CS%useALEalgorithm, CS%use_energetic_PBL) + + ! initialize the boundary layer modules + if (CS%use_bulkmixedlayer) & + call bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS%bulkmixedlayer) + if (CS%use_energetic_PBL) & + call energetic_PBL_init(Time, G, GV, US, param_file, diag, CS%ePBL) + + call regularize_layers_init(Time, G, GV, param_file, diag, CS%regularize_layers) + + if (CS%debug_energy_req) & + call diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS%diapyc_en_rec_CSp) + + ! obtain information about the number of bands for penetrative shortwave + if (use_temperature) then + call get_param(param_file, mdl, "PEN_SW_NBANDS", nbands, default=1) + if (nbands > 0) then + allocate(CS%optics) + call opacity_init(Time, G, GV, US, param_file, diag, CS%opacity, CS%optics) + endif + endif + + ! Initialize the diagnostic grid storage + call diag_grid_storage_init(CS%diag_grids_prev, G, GV, diag) + +end subroutine diabatic_driver_init + +!> Routine to register restarts, pass-through to children modules +subroutine register_diabatic_restarts(G, US, param_file, int_tide_CSp, restart_CSp) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure + type(MOM_restart_CS), pointer :: restart_CSp !< MOM restart control structure + + logical :: use_int_tides + + use_int_tides=.false. + + call read_param(param_file, "INTERNAL_TIDES", use_int_tides) + + if (use_int_tides) then + call register_int_tide_restarts(G, US, param_file, int_tide_CSp, restart_CSp) + endif + +end subroutine register_diabatic_restarts + +!> Routine to close the diabatic driver module +subroutine diabatic_driver_end(CS) + type(diabatic_CS), intent(inout) :: CS !< module control structure + + if (associated(CS%optics)) then + call opacity_end(CS%opacity, CS%optics) + deallocate(CS%optics) + endif + + if (CS%debug_energy_req) & + call diapyc_energy_req_end(CS%diapyc_en_rec_CSp) + + if (CS%use_energetic_PBL) & + call energetic_PBL_end(CS%ePBL) + + call diabatic_aux_end(CS%diabatic_aux_CSp) + + call set_diffusivity_end(CS%set_diff_CSp) + + deallocate(CS%set_diff_CSp) + + if (CS%use_geothermal) & + call geothermal_end(CS%geothermal) + + if (CS%useKPP) then + deallocate( CS%KPP_buoy_flux ) + deallocate( CS%KPP_temp_flux ) + deallocate( CS%KPP_salt_flux ) + deallocate( CS%KPP_NLTheat ) + deallocate( CS%KPP_NLTscalar ) + call KPP_end(CS%KPP_CSp) + endif + + ! GMM, the following is commented out because arrays in + ! CS%diag_grids_prev are neither pointers or allocatables + ! and, therefore, cannot be deallocated. + + !call diag_grid_storage_end(CS%diag_grids_prev) +end subroutine diabatic_driver_end + + +!> \namespace mom_diabatic_driver +!! +!! By Robert Hallberg, Alistair Adcroft, and Stephen Griffies +!! +!! This program contains the subroutine that, along with the +!! subroutines that it calls, implements diapycnal mass and momentum +!! fluxes and a bulk mixed layer. The diapycnal diffusion can be +!! used without the bulk mixed layer. +!! +!! \section section_diabatic Outline of MOM diabatic +!! +!! * diabatic first determines the (diffusive) diapycnal mass fluxes +!! based on the convergence of the buoyancy fluxes within each layer. +!! +!! * The dual-stream entrainment scheme of MacDougall and Dewar (JPO, +!! 1997) is used for combined diapycnal advection and diffusion, +!! calculated implicitly and potentially with the Richardson number +!! dependent mixing, as described by Hallberg (MWR, 2000). +!! +!! * Diapycnal advection is the residual of diapycnal diffusion, +!! so the fully implicit upwind differencing scheme that is used is +!! entirely appropriate. +!! +!! * The downward buoyancy flux in each layer is determined from +!! an implicit calculation based on the previously +!! calculated flux of the layer above and an estimated flux in the +!! layer below. This flux is subject to the following conditions: +!! (1) the flux in the top and bottom layers are set by the boundary +!! conditions, and (2) no layer may be driven below a minimal thickness. +!! If there is a bulk mixed layer, the buffer layer is treated +!! as a fixed density layer with vanishingly small diffusivity. +!! +!! diabatic takes 5 arguments: the two velocities (u and v), the +!! thicknesses (h), a structure containing the forcing fields, and +!! the length of time over which to act (dt). The velocities and +!! thickness are taken as inputs and modified within the subroutine. +!! There is no limit on the time step. + +end module MOM_diabatic_driver diff --git a/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/parameterizations/vertical/MOM_diapyc_energy_req.F90 new file mode 100644 index 0000000000..7ca432fea4 --- /dev/null +++ b/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -0,0 +1,1110 @@ +!> Calculates the energy requirements of mixing. +module MOM_diapyc_energy_req + +! This file is part of MOM6. See LICENSE.md for the license. + +!! \author By Robert Hallberg, May 2015 + +use MOM_diag_mediator, only : diag_ctrl, Time_type, post_data, register_diag_field +use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +public diapyc_energy_req_init, diapyc_energy_req_calc, diapyc_energy_req_test, diapyc_energy_req_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> This control structure holds parameters for the MOM_diapyc_energy_req module +type, public :: diapyc_energy_req_CS ; private + logical :: initialized = .false. !< A variable that is here because empty + !! structures are not permitted by some compilers. + real :: test_Kh_scaling !< A scaling factor for the diapycnal diffusivity [nondim] + real :: ColHt_scaling !< A scaling factor for the column height change correction term [nondim] + real :: VonKar !< The von Karman coefficient as used in this module [nondim] + logical :: use_test_Kh_profile !< If true, use the internal test diffusivity profile in place of + !! any that might be passed in as an argument. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + + !>@{ Diagnostic IDs + integer :: id_ERt=-1, id_ERb=-1, id_ERc=-1, id_ERh=-1, id_Kddt=-1, id_Kd=-1 + integer :: id_CHCt=-1, id_CHCb=-1, id_CHCc=-1, id_CHCh=-1 + integer :: id_T0=-1, id_Tf=-1, id_S0=-1, id_Sf=-1, id_N2_0=-1, id_N2_f=-1 + integer :: id_h=-1, id_zInt=-1 + !>@} +end type diapyc_energy_req_CS + +contains + +!> This subroutine helps test the accuracy of the diapycnal mixing energy requirement code +!! by writing diagnostics, possibly using an intensely mixing test profile of diffusivity +subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(G%isd:G%ied,G%jsd:G%jed,GV%ke), & + intent(in) :: h_3d !< Layer thickness before entrainment [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. + !! Absent fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. + type(diapyc_energy_req_CS), pointer :: CS !< This module's control structure. + real, dimension(G%isd:G%ied,G%jsd:G%jed,GV%ke+1), & + optional, intent(in) :: Kd_int !< Interface diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + ! Local variables + real, dimension(GV%ke) :: & + T0, S0, & ! T0 & S0 are columns of initial temperatures and salinities [C ~> degC] and [S ~> ppt]. + h_col, & ! h_col is a column of thicknesses h at tracer points [H ~> m or kg m-2]. + dz_col ! dz_col is a column of vertical distances across layers at tracer points [Z ~> m] + real, dimension( G%isd:G%ied,GV%ke) :: & + dz_2d ! A 2-d slice of the vertical distance across layers [Z ~> m] + real, dimension(GV%ke+1) :: & + Kd, & ! A column of diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + h_top, h_bot ! Distances from the top or bottom [H ~> m or kg m-2]. + real :: dz_h_int ! The ratio of the vertical distances across the layers surrounding an interface + ! over the layer thicknesses [H Z-1 ~> nonodim or kg m-3] + real :: ustar ! The local friction velocity [Z T-1 ~> m s-1] + real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] + real :: htot ! The sum of the thicknesses [H ~> m or kg m-2]. + real :: energy_Kd ! The energy used by diapycnal mixing [R Z L2 T-3 ~> W m-2]. + real :: tmp1 ! A temporary array [H2 ~> m2 or kg2 m-6] + integer :: i, j, k, is, ie, js, je, nz + logical :: may_print + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not. associated(CS)) call MOM_error(FATAL, "diapyc_energy_req_test: "// & + "Module must be initialized before it is used.") + + if (.not. CS%initialized) call MOM_error(FATAL, "diapyc_energy_req_test: "// & + "Module must be initialized before it is used.") + +!$OMP do + do j=js,je + call thickness_to_dz(h_3d, tv, dz_2d, j, G, GV) + + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + + do k=1,nz + T0(k) = tv%T(i,j,k) ; S0(k) = tv%S(i,j,k) + h_col(k) = h_3d(i,j,k) + dz_col(k) = dz_2d(i,k) + enddo + + if (present(Kd_int) .and. .not.CS%use_test_Kh_profile) then + do k=1,nz+1 ; Kd(K) = CS%test_Kh_scaling*Kd_int(i,j,K) ; enddo + else + htot = 0.0 ; h_top(1) = 0.0 + do k=1,nz + h_top(K+1) = h_top(K) + h_col(k) + enddo + htot = h_top(nz+1) + + h_bot(nz+1) = 0.0 + do k=nz,1,-1 + h_bot(K) = h_bot(K+1) + h_col(k) + enddo + + ustar = 0.01*US%m_to_Z*US%T_to_s ! Change this to being an input parameter? + absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) + Kd(1) = 0.0 ; Kd(nz+1) = 0.0 + if (GV%Boussinesq) then + do K=2,nz + tmp1 = h_top(K) * h_bot(K) + Kd(K) = CS%test_Kh_scaling * & + ustar * CS%VonKar * (tmp1*ustar) / (absf*GV%H_to_Z*tmp1 + htot*ustar) + enddo + else + do K=2,nz + tmp1 = h_top(K) * h_bot(K) + dz_h_int = (dz_2d(j,k-1) + dz_2d(j,k) + GV%dz_subroundoff) / & + (h_3d(i,j,k-1) + h_3d(i,j,k) + GV%H_subroundoff) + Kd(K) = CS%test_Kh_scaling * & + ustar * CS%VonKar * (tmp1*ustar) / (dz_h_int*absf*tmp1 + htot*ustar) + enddo + endif + endif + may_print = is_root_PE() .and. (i==ie) .and. (j==je) + call diapyc_energy_req_calc(h_col, dz_col, T0, S0, Kd, energy_Kd, dt, tv, G, GV, US, & + may_print=may_print, CS=CS) + endif ; enddo + enddo + +end subroutine diapyc_energy_req_test + +!> This subroutine uses a substantially refactored tridiagonal equation for +!! diapycnal mixing of temperature and salinity to estimate the potential energy +!! change due to diapycnal mixing in a column of water. It does this estimate +!! 4 different ways, all of which should be equivalent, but reports only one. +!! The various estimates are taken because they will later be used as templates +!! for other bits of code +subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv, & + G, GV, US, may_print, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(GV%ke), intent(in) :: h_in !< Layer thickness before entrainment, + !! [H ~> m or kg m-2] + real, dimension(GV%ke), intent(in) :: dz_in !< Vertical distance across layers before + !! entrainment [Z ~> m] + real, dimension(GV%ke), intent(in) :: T_in !< The layer temperatures [C ~> degC]. + real, dimension(GV%ke), intent(in) :: S_in !< The layer salinities [S ~> ppt]. + real, dimension(GV%ke+1), intent(in) :: Kd !< The interfaces diapycnal diffusivities + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. + real, intent(out) :: energy_Kd !< The column-integrated rate of energy + !! consumption by diapycnal diffusion [R Z L2 T-3 ~> W m-2]. + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. + !! Absent fields have NULL ptrs. + logical, optional, intent(in) :: may_print !< If present and true, write out diagnostics + !! of energy use. + type(diapyc_energy_req_CS), & + optional, pointer :: CS !< This module's control structure. + +! This subroutine uses a substantially refactored tridiagonal equation for +! diapycnal mixing of temperature and salinity to estimate the potential energy +! change due to diapycnal mixing in a column of water. It does this estimate +! 4 different ways, all of which should be equivalent, but reports only one. +! The various estimates are taken because they will later be used as templates +! for other bits of code. + + real, dimension(GV%ke) :: & + p_lay, & ! Average pressure of a layer [R L2 T-2 ~> Pa]. + dSV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. + dSV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + T0, S0, & ! Initial temperatures and salinities [C ~> degC] and [S ~> ppt]. + Tf, Sf, & ! New final values of the temperatures and salinities [C ~> degC] and [S ~> ppt]. + Th_a, & ! An effective temperature times a thickness in the layer above, including implicit + ! mixing effects with other yet higher layers [C H ~> degC m or degC kg m-2]. + Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit + ! mixing effects with other yet higher layers [S H ~> ppt m or ppt kg m-2]. + Th_b, & ! An effective temperature times a thickness in the layer below, including implicit + ! mixing effects with other yet lower layers [C H ~> degC m or degC kg m-2]. + Sh_b, & ! An effective salinity times a thickness in the layer below, including implicit + ! mixing effects with other yet lower layers [S H ~> ppt m or ppt kg m-2]. + dT_to_dPE, & ! Partial derivative of column potential energy with the temperature changes within + ! a layer [R Z L2 T-2 C-1 ~> J m-2 degC-1] + dS_to_dPE, & ! Partial derivative of column potential energy with the salinity changes within + ! a layer [R Z L2 T-2 S-1 ~> J m-2 ppt-1] + dT_to_dColHt, & ! Partial derivative of the total column height with the temperature + ! changes within a layer [Z C-1 ~> m degC-1] + dS_to_dColHt, & ! Partial derivative of the total column height with the + ! salinity changes within a layer [Z S-1 ~> m ppt-1]. + dT_to_dColHt_a, & ! Partial derivative of the total column height with the temperature changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column [Z C-1 ~> m degC-1]. + dS_to_dColHt_a, & ! Partial derivative of the total column height with the salinity changes + ! within a layer, including the implicit effects of mixing with layers higher + ! of mixing with layers higher in the water column [Z S-1 ~> m ppt-1]. + dT_to_dColHt_b, & ! Partial derivative of the total column height with the temperature changes + ! within a layer, including the implicit effects of mixing with layers lower + ! in the water column [Z C-1 ~> m degC-1]. + dS_to_dColHt_b, & ! Partial derivative of the total column height with the salinity changes + ! within a layer, including the implicit effects of mixing with layers lower + ! in the water column [Z S-1 ~> m ppt-1]. + dT_to_dPE_a, & ! Partial derivative of column potential energy with the temperature changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column, in units of [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + dS_to_dPE_a, & ! Partial derivative of column potential energy with the salinity changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column, in units of [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + dT_to_dPE_b, & ! Partial derivative of column potential energy with the temperature changes + ! within a layer, including the implicit effects of mixing with layers lower + ! in the water column, in units of [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + dS_to_dPE_b, & ! Partial derivative of column potential energy with the salinity changes + ! within a layer, including the implicit effects of mixing with layers lower + ! in the water column, in units of [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + hp_a, & ! An effective pivot thickness of the layer including the effects + ! of coupling with layers above [H ~> m or kg m-2]. This is the first term + ! in the denominator of b1 in a downward-oriented tridiagonal solver. + hp_b, & ! An effective pivot thickness of the layer including the effects + ! of coupling with layers below [H ~> m or kg m-2]. This is the first term + ! in the denominator of b1 in an upward-oriented tridiagonal solver. + c1_a, & ! c1_a is used by a downward-oriented tridiagonal solver [nondim]. + c1_b, & ! c1_b is used by an upward-oriented tridiagonal solver [nondim]. + h_tr, & ! h_tr is h at tracer points with a h_neglect added to + ! ensure positive definiteness [H ~> m or kg m-2]. + dz_tr ! dz_tr is dz at tracer points with dz_neglect added to + ! ensure positive definiteness [Z ~> m] + ! Note that the following arrays have extra (ficticious) layers above or below the + ! water column for code convenience + real, dimension(0:GV%ke+1) :: & + Te, Se ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] + real, dimension(0:GV%ke) :: & + Te_a, Se_a ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] + real, dimension(GV%ke+1) :: & + Te_b, Se_b ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] + real, dimension(GV%ke+1) :: & + pres, & ! Interface pressures [R L2 T-2 ~> Pa]. + pres_Z, & ! The hydrostatic interface pressure, which is used to relate + ! the changes in column thickness to the energy that is radiated + ! as gravity waves and unavailable to drive mixing [R L2 T-2 ~> J m-3]. + z_Int, & ! Interface heights relative to the surface [H ~> m or kg m-2]. + N2, & ! An estimate of the buoyancy frequency [T-2 ~> s-2]. + Kddt_h, & ! The diapycnal diffusivity times a timestep divided by the + ! average thicknesses around a layer [H ~> m or kg m-2]. + Kddt_h_a, & ! The value of Kddt_h for layers above the central point in the + ! tridiagonal solver [H ~> m or kg m-2]. + Kddt_h_b, & ! The value of Kddt_h for layers below the central point in the + ! tridiagonal solver [H ~> m or kg m-2]. + Kd_so_far ! The value of Kddt_h that has been applied already in + ! calculating the energy changes [H ~> m or kg m-2]. + real, dimension(GV%ke+1,4) :: & + PE_chg_k, & ! The integrated potential energy change within a timestep due + ! to the diffusivity at interface K for 4 different orders of + ! accumulating the diffusivities [R Z L2 T-2 ~> J m-2]. + ColHt_cor_k ! The correction to the potential energy change due to + ! changes in the net column height [R Z L2 T-2 ~> J m-2]. + real :: b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: Kd0 ! The value of Kddt_h that has already been applied [H ~> m or kg m-2]. + real :: dKd ! The change in the value of Kddt_h [H ~> m or kg m-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: Kddt_h_guess ! A guess of the final value of Kddt_h [H ~> m or kg m-2]. + real :: dMass ! The mass per unit area within a layer [R Z ~> kg m-2]. + real :: dPres ! The hydrostatic pressure change across a layer [R L2 T-2 ~> Pa]. + real :: rho_here ! The in-situ density [R ~> kg m-3]. + real :: PE_change ! The change in column potential energy from applying Kddt_h at the + ! present interface [R L2 Z T-2 ~> J m-2]. + real :: ColHt_cor ! The correction to PE_chg that is made due to a net + ! change in the column height [R L2 Z T-2 ~> J m-2]. + real :: htot ! A running sum of thicknesses [H ~> m or kg m-2]. + real :: dztot ! A running sum of vertical distances across layers [Z ~> m] + logical :: do_print + + ! The following are a bunch of diagnostic arrays for debugging purposes. + real, dimension(GV%ke) :: & + Ta, Tb, & ! Copies of temperature profiles for debugging [C ~> degC] + Sa, Sb ! Copies of salinity profiles for debugging [S ~> ppt] + real, dimension(GV%ke+1) :: & + dPEa_dKd, dPEa_dKd_est, & ! Estimates of the partial derivative of the column potential energy + ! change with Kddt_h [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + dPEb_dKd, dPEb_dKd_est, & ! Estimates of the partial derivative of the column potential energy + ! change with Kddt_h [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + dPEa_dKd_err, dPEb_dKd_err, & ! Differences in estimates of the partial derivative of the column + ! potential energy change with Kddt_h [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + dPEa_dKd_err_norm, dPEb_dKd_err_norm, & ! Normalized changes in sensitivities [nondim] + dPEa_dKd_trunc, dPEb_dKd_trunc ! Estimates of the truncation error in estimates of the partial + ! derivative of the column potential energy change with + ! Kddt_h [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + real :: PE_chg_tot1A, PE_chg_tot2A ! Changes in column potential energy [R Z L2 T-2 ~> J m-2] + real :: PE_chg_tot1B, PE_chg_tot2B ! Changes in column potential energy [R Z L2 T-2 ~> J m-2] + real :: PE_chg_tot1C, PE_chg_tot2C ! Changes in column potential energy [R Z L2 T-2 ~> J m-2] + real :: PE_chg_tot1D, PE_chg_tot2D ! Changes in column potential energy [R Z L2 T-2 ~> J m-2] + real :: T_chg_totA, T_chg_totB ! Vertically integrated temperature changes [C H ~> degC m or degC kg m-2] + real :: T_chg_totC, T_chg_totD ! Vertically integrated temperature changes [C H ~> degC m or degC kg m-2] + real :: PE_chg(6) ! The potential energy change within the first few iterations [R Z L2 T-2 ~> J m-2] + + integer :: k, nz, itt, k_cent + logical :: surface_BL, bottom_BL, central, halves, debug + nz = GV%ke + h_neglect = GV%H_subroundoff + + debug = .true. + + surface_BL = .true. ; bottom_BL = .true. ; halves = .true. + central = .true. ; K_cent = nz/2 + + do_print = .false. ; if (present(may_print) .and. present(CS)) do_print = may_print + + dPEa_dKd(:) = 0.0 ; dPEa_dKd_est(:) = 0.0 ; dPEa_dKd_err(:) = 0.0 + dPEa_dKd_err_norm(:) = 0.0 ; dPEa_dKd_trunc(:) = 0.0 + dPEb_dKd(:) = 0.0 ; dPEb_dKd_est(:) = 0.0 ; dPEb_dKd_err(:) = 0.0 + dPEb_dKd_err_norm(:) = 0.0 ; dPEb_dKd_trunc(:) = 0.0 + + htot = 0.0 ; dztot = 0.0 ; pres(1) = 0.0 ; pres_Z(1) = 0.0 ; Z_int(1) = 0.0 + do k=1,nz + T0(k) = T_in(k) ; S0(k) = S_in(k) + h_tr(k) = h_in(k) + dz_tr(k) = dz_in(k) + htot = htot + h_tr(k) + dztot = dztot + dz_tr(k) + pres(K+1) = pres(K) + (GV%g_Earth * GV%H_to_RZ) * h_tr(k) + pres_Z(K+1) = pres(K+1) + p_lay(k) = 0.5*(pres(K) + pres(K+1)) + Z_int(K+1) = Z_int(K) - h_tr(k) + enddo + do k=1,nz + h_tr(k) = max(h_tr(k), 1e-15*htot) + dz_tr(k) = max(dz_tr(k), 1e-15*dztot) + enddo + + ! Introduce a diffusive flux variable, Kddt_h(K) = ea(k) = eb(k-1) + + Kddt_h(1) = 0.0 ; Kddt_h(nz+1) = 0.0 + do K=2,nz + Kddt_h(K) = min(dt * Kd(k) / (0.5*(dz_tr(k-1) + dz_tr(k))), 1e3*dztot) + enddo + + ! Zero out the temperature and salinity estimates in the extra (ficticious) layers. + ! The actual values set here are irrelevant (so long as they are not NaNs) because they + ! are always multiplied by a zero value of Kddt_h reflecting the no-flux boundary condition. + Te(0) = 0.0 ; Se(0) = 0.0 ; Te(nz+1) = 0.0 ; Se(nz+1) = 0.0 + Te_a(0) = 0.0 ; Se_a(0) = 0.0 + Te_b(nz+1) = 0.0 ; Se_b(nz+1) = 0.0 + + ! Solve the tridiagonal equations for new temperatures. + + call calculate_specific_vol_derivs(T0, S0, p_lay, dSV_dT, dSV_dS, tv%eqn_of_state) + + do k=1,nz + dMass = GV%H_to_RZ * h_tr(k) + dPres = (GV%g_Earth * GV%H_to_RZ) * h_tr(k) + dT_to_dPE(k) = (dMass * (pres(K) + 0.5*dPres)) * dSV_dT(k) + dS_to_dPE(k) = (dMass * (pres(K) + 0.5*dPres)) * dSV_dS(k) + dT_to_dColHt(k) = dMass * dSV_dT(k) * CS%ColHt_scaling + dS_to_dColHt(k) = dMass * dSV_dS(k) * CS%ColHt_scaling + enddo + +! PE_chg_k(1) = 0.0 ; PE_chg_k(nz+1) = 0.0 + ! PEchg(:) = 0.0 + PE_chg_k(:,:) = 0.0 ; ColHt_cor_k(:,:) = 0.0 + + if (surface_BL) then ! This version is appropriate for a surface boundary layer. + + ! Set up values appropriate for no diffusivity. + do k=1,nz + hp_a(k) = h_tr(k) ; hp_b(k) = h_tr(k) + dT_to_dPE_a(k) = dT_to_dPE(k) ; dS_to_dPE_a(k) = dS_to_dPE(k) + dT_to_dPE_b(k) = dT_to_dPE(k) ; dS_to_dPE_b(k) = dS_to_dPE(k) + dT_to_dColHt_a(k) = dT_to_dColHt(k) ; dS_to_dColHt_a(k) = dS_to_dColHt(k) + dT_to_dColHt_b(k) = dT_to_dColHt(k) ; dS_to_dColHt_b(k) = dS_to_dColHt(k) + enddo + + do K=2,nz + ! At this point, Kddt_h(K) will be unknown because its value may depend + ! on how much energy is available. + + ! Precalculate some temporary expressions that are independent of Kddt_h_guess. + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) + Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) + + + ! Find the energy change due to a guess at the strength of diffusion at interface K. + + Kddt_h_guess = Kddt_h(K) + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg_k(K,1), dPEc_dKd=dPEa_dKd(K), & + PE_ColHt_cor=ColHt_cor_k(K,1)) + + if (debug) then + do itt=1,5 + Kddt_h_guess = (1.0+0.01*(itt-3))*Kddt_h(K) + + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg(itt)) + enddo + ! Compare with a 4th-order finite difference estimate. + dPEa_dKd_est(k) = (4.0*(PE_chg(4)-Pe_chg(2))/(0.02*Kddt_h(K)) - & + (PE_chg(5)-Pe_chg(1))/(0.04*Kddt_h(K))) / 3.0 + dPEa_dKd_trunc(k) = (PE_chg(4)-Pe_chg(2))/(0.02*Kddt_h(K)) - & + (PE_chg(5)-Pe_chg(1))/(0.04*Kddt_h(K)) + dPEa_dKd_err(k) = (dPEa_dKd_est(k) - dPEa_dKd(k)) + dPEa_dKd_err_norm(k) = (dPEa_dKd_est(k) - dPEa_dKd(k)) / & + (abs(dPEa_dKd_est(k)) + abs(dPEa_dKd(k)) + 1e-100*US%RZ_to_kg_m2*US%L_T_to_m_s**2) + endif + + ! At this point, the final value of Kddt_h(K) is known, so the estimated + ! properties for layer k-1 can be calculated. + + b1 = 1.0 / (hp_a(k-1) + Kddt_h(K)) + c1_a(K) = Kddt_h(K) * b1 + Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) + Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) + + hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kddt_h(K) + dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) + dS_to_dPE_a(k) = dS_to_dPE(k) + c1_a(K)*dS_to_dPE_a(k-1) + dT_to_dColHt_a(k) = dT_to_dColHt(k) + c1_a(K)*dT_to_dColHt_a(k-1) + dS_to_dColHt_a(k) = dS_to_dColHt(k) + c1_a(K)*dS_to_dColHt_a(k-1) + + enddo + + b1 = 1.0 / (hp_a(nz)) + Tf(nz) = b1 * (h_tr(nz) * T0(nz) + Kddt_h(nz) * Te(nz-1)) + Sf(nz) = b1 * (h_tr(nz) * S0(nz) + Kddt_h(nz) * Se(nz-1)) + + do k=nz-1,1,-1 + Tf(k) = Te(k) + c1_a(K+1)*Tf(k+1) + Sf(k) = Se(k) + c1_a(K+1)*Sf(k+1) + enddo + + if (debug) then + do k=1,nz ; Ta(k) = Tf(k) ; Sa(k) = Sf(k) ; enddo + PE_chg_tot1A = 0.0 ; PE_chg_tot2A = 0.0 ; T_chg_totA = 0.0 + do k=1,nz + PE_chg_tot1A = PE_chg_tot1A + (dT_to_dPE(k) * (Tf(k) - T0(k)) + & + dS_to_dPE(k) * (Sf(k) - S0(k))) + T_chg_totA = T_chg_totA + h_tr(k) * (Tf(k) - T0(k)) + enddo + do K=2,nz + PE_chg_tot2A = PE_chg_tot2A + (PE_chg_k(K,1) - ColHt_cor_k(K,1)) + enddo + endif + + endif + + if (bottom_BL) then ! This version is appropriate for a bottom boundary layer. + + ! Set up values appropriate for no diffusivity. + do k=1,nz + hp_a(k) = h_tr(k) ; hp_b(k) = h_tr(k) + dT_to_dPE_a(k) = dT_to_dPE(k) ; dS_to_dPE_a(k) = dS_to_dPE(k) + dT_to_dPE_b(k) = dT_to_dPE(k) ; dS_to_dPE_b(k) = dS_to_dPE(k) + dT_to_dColHt_a(k) = dT_to_dColHt(k) ; dS_to_dColHt_a(k) = dS_to_dColHt(k) + dT_to_dColHt_b(k) = dT_to_dColHt(k) ; dS_to_dColHt_b(k) = dS_to_dColHt(k) + enddo + + do K=nz,2,-1 ! Loop over interior interfaces. + ! At this point, Kddt_h(K) will be unknown because its value may depend + ! on how much energy is available. + + ! Precalculate some temporary expressions that are independent of Kddt_h_guess. + Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se(k+1) + + ! Find the energy change due to a guess at the strength of diffusion at interface K. + Kddt_h_guess = Kddt_h(K) + + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K), & + PE_ColHt_cor=ColHt_cor_k(K,2)) + + if (debug) then + ! Compare with a 4th-order finite difference estimate. + do itt=1,5 + Kddt_h_guess = (1.0+0.01*(itt-3))*Kddt_h(K) + + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg(itt)) + enddo + + dPEb_dKd_est(k) = (4.0*(PE_chg(4)-Pe_chg(2))/(0.02*Kddt_h(K)) - & + (PE_chg(5)-Pe_chg(1))/(0.04*Kddt_h(K))) / 3.0 + dPEb_dKd_trunc(k) = (PE_chg(4)-Pe_chg(2))/(0.02*Kddt_h(K)) - & + (PE_chg(5)-Pe_chg(1))/(0.04*Kddt_h(K)) + dPEb_dKd_err(k) = (dPEb_dKd_est(k) - dPEb_dKd(k)) + dPEb_dKd_err_norm(k) = (dPEb_dKd_est(k) - dPEb_dKd(k)) / & + (abs(dPEb_dKd_est(k)) + abs(dPEb_dKd(k)) + 1e-100*US%RZ_to_kg_m2*US%L_T_to_m_s**2) + endif + + ! At this point, the final value of Kddt_h(K) is known, so the estimated + ! properties for layer k can be calculated. + + b1 = 1.0 / (hp_b(k) + Kddt_h(K)) + c1_b(K) = Kddt_h(K) * b1 + + Te(k) = b1 * (h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1)) + Se(k) = b1 * (h_tr(k) * S0(k) + Kddt_h(K+1) * Se(k+1)) + + hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kddt_h(K) + dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) + dS_to_dPE_b(k-1) = dS_to_dPE(k-1) + c1_b(K)*dS_to_dPE_b(k) + dT_to_dColHt_b(k-1) = dT_to_dColHt(k-1) + c1_b(K)*dT_to_dColHt_b(k) + dS_to_dColHt_b(k-1) = dS_to_dColHt(k-1) + c1_b(K)*dS_to_dColHt_b(k) + + enddo + + b1 = 1.0 / (hp_b(1)) + Tf(1) = b1 * (h_tr(1) * T0(1) + Kddt_h(2) * Te(2)) + Sf(1) = b1 * (h_tr(1) * S0(1) + Kddt_h(2) * Se(2)) + + do k=2,nz + Tf(k) = Te(k) + c1_b(K)*Tf(k-1) + Sf(k) = Se(k) + c1_b(K)*Sf(k-1) + enddo + + if (debug) then + do k=1,nz ; Tb(k) = Tf(k) ; Sb(k) = Sf(k) ; enddo + PE_chg_tot1B = 0.0 ; PE_chg_tot2B = 0.0 ; T_chg_totB = 0.0 + do k=1,nz + PE_chg_tot1B = PE_chg_tot1B + (dT_to_dPE(k) * (Tf(k) - T0(k)) + & + dS_to_dPE(k) * (Sf(k) - S0(k))) + T_chg_totB = T_chg_totB + h_tr(k) * (Tf(k) - T0(k)) + enddo + do K=2,nz + PE_chg_tot2B = PE_chg_tot2B + (PE_chg_k(K,2) - ColHt_cor_k(K,2)) + enddo + endif + + endif + + if (central) then + + ! Set up values appropriate for no diffusivity. + do k=1,nz + hp_a(k) = h_tr(k) ; hp_b(k) = h_tr(k) + dT_to_dPE_a(k) = dT_to_dPE(k) ; dS_to_dPE_a(k) = dS_to_dPE(k) + dT_to_dPE_b(k) = dT_to_dPE(k) ; dS_to_dPE_b(k) = dS_to_dPE(k) + dT_to_dColHt_a(k) = dT_to_dColHt(k) ; dS_to_dColHt_a(k) = dS_to_dColHt(k) + dT_to_dColHt_b(k) = dT_to_dColHt(k) ; dS_to_dColHt_b(k) = dS_to_dColHt(k) + enddo + + ! Calculate the dependencies on layers above. + Kddt_h_a(1) = 0.0 + do K=2,nz ! Loop over interior interfaces. + ! First calculate some terms that are independent of the change in Kddt_h(K). + Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) + Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) + + Kddt_h_a(K) = 0.0 ; if (K < K_cent) Kddt_h_a(K) = Kddt_h(K) + dKd = Kddt_h_a(K) + + call find_PE_chg(Kd0, dKd, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) + PE_chg_k(K,3) = PE_change + ColHt_cor_k(K,3) = ColHt_cor + + b1 = 1.0 / (hp_a(k-1) + Kddt_h_a(K)) + c1_a(K) = Kddt_h_a(K) * b1 + + Te_a(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h_a(K-1) * Te_a(k-2)) + Se_a(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h_a(K-1) * Se_a(k-2)) + + hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kddt_h_a(K) + dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) + dS_to_dPE_a(k) = dS_to_dPE(k) + c1_a(K)*dS_to_dPE_a(k-1) + dT_to_dColHt_a(k) = dT_to_dColHt(k) + c1_a(K)*dT_to_dColHt_a(k-1) + dS_to_dColHt_a(k) = dS_to_dColHt(k) + c1_a(K)*dS_to_dColHt_a(k-1) + enddo + + ! Calculate the dependencies on layers below. + Kddt_h_b(nz+1) = 0.0 + do K=nz,2,-1 ! Loop over interior interfaces. + ! First calculate some terms that are independent of the change in Kddt_h(K). + Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). + + Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) +! Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) +! Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) + + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se_b(k+1) + + Kddt_h_b(K) = 0.0 ; if (K > K_cent) Kddt_h_b(K) = Kddt_h(K) + dKd = Kddt_h_b(K) + + call find_PE_chg(Kd0, dKd, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) + PE_chg_k(K,3) = PE_chg_k(K,3) + PE_change + ColHt_cor_k(K,3) = ColHt_cor_k(K,3) + ColHt_cor + + b1 = 1.0 / (hp_b(k) + Kddt_h_b(K)) + c1_b(K) = Kddt_h_b(K) * b1 + + Te_b(k) = b1 * (h_tr(k) * T0(k) + Kddt_h_b(K+1) * Te_b(k+1)) + Se_b(k) = b1 * (h_tr(k) * S0(k) + Kddt_h_b(K+1) * Se_b(k+1)) + + hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kddt_h_b(K) + dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) + dS_to_dPE_b(k-1) = dS_to_dPE(k-1) + c1_b(K)*dS_to_dPE_b(k) + dT_to_dColHt_b(k-1) = dT_to_dColHt(k-1) + c1_b(K)*dT_to_dColHt_b(k) + dS_to_dColHt_b(k-1) = dS_to_dColHt(k-1) + c1_b(K)*dS_to_dColHt_b(k) + + enddo + + ! Calculate the final solution for the layers surrounding interface K_cent + K = K_cent + + ! First calculate some terms that are independent of the change in Kddt_h(K). + Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se_b(k+1) + + dKd = Kddt_h(K) + + call find_PE_chg(Kd0, dKd, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) + PE_chg_k(K,3) = PE_chg_k(K,3) + PE_change + ColHt_cor_k(K,3) = ColHt_cor_k(K,3) + ColHt_cor + + + ! To derive the following, first to a partial update for the estimated + ! temperatures and salinities in the layers around this interface: + ! b1_a = 1.0 / (hp_a(k-1) + Kddt_h(K)) + ! b1_b = 1.0 / (hp_b(k) + Kddt_h(K)) + ! Te_up(k) = Th_b(k) * b1_b ; Se_up(k) = Sh_b(k) * b1_b + ! Te_up(k-1) = Th_a(k-1) * b1_a ; Se_up(k-1) = Sh_a(k-1) * b1_a + ! Find the final values of T & S for both layers around K_cent, using that + ! c1_a(K) = Kddt_h(K) * b1_a ; c1_b(K) = Kddt_h(K) * b1_b + ! Tf(K_cent-1) = Te_up(K_cent-1) + c1_a(K_cent)*Tf(K_cent) + ! Tf(K_cent) = Te_up(K_cent) + c1_b(K_cent)*Tf(K_cent-1) + ! but further exploiting the expressions for c1_a and c1_b to avoid + ! subtraction in the denominator, and use only a single division. + b1 = 1.0 / (hp_a(k-1)*hp_b(k) + Kddt_h(K)*(hp_a(k-1) + hp_b(k))) + Tf(k-1) = ((hp_b(k) + Kddt_h(K)) * Th_a(k-1) + Kddt_h(K) * Th_b(k) ) * b1 + Sf(k-1) = ((hp_b(k) + Kddt_h(K)) * Sh_a(k-1) + Kddt_h(K) * Sh_b(k) ) * b1 + Tf(k) = (Kddt_h(K) * Th_a(k-1) + (hp_a(k-1) + Kddt_h(K)) * Th_b(k) ) * b1 + Sf(k) = (Kddt_h(K) * Sh_a(k-1) + (hp_a(k-1) + Kddt_h(K)) * Sh_b(k) ) * b1 + + c1_a(K) = Kddt_h(K) / (hp_a(k-1) + Kddt_h(K)) + c1_b(K) = Kddt_h(K) / (hp_b(k) + Kddt_h(K)) + + ! Now update the other layer working outward from k_cent to determine the final + ! temperatures and salinities. + do k=K_cent-2,1,-1 + Tf(k) = Te_a(k) + c1_a(K+1)*Tf(k+1) + Sf(k) = Se_a(k) + c1_a(K+1)*Sf(k+1) + enddo + do k=K_cent+1,nz + Tf(k) = Te_b(k) + c1_b(K)*Tf(k-1) + Sf(k) = Se_b(k) + c1_b(K)*Sf(k-1) + enddo + + if (debug) then + PE_chg_tot1C = 0.0 ; PE_chg_tot2C = 0.0 ; T_chg_totC = 0.0 + do k=1,nz + PE_chg_tot1C = PE_chg_tot1C + (dT_to_dPE(k) * (Tf(k) - T0(k)) + & + dS_to_dPE(k) * (Sf(k) - S0(k))) + T_chg_totC = T_chg_totC + h_tr(k) * (Tf(k) - T0(k)) + enddo + do K=2,nz + PE_chg_tot2C = PE_chg_tot2C + (PE_chg_k(K,3) - ColHt_cor_k(K,3)) + enddo + endif + + endif + + if (halves) then + + ! Set up values appropriate for no diffusivity. + do k=1,nz + hp_a(k) = h_tr(k) ; hp_b(k) = h_tr(k) + dT_to_dPE_a(k) = dT_to_dPE(k) ; dS_to_dPE_a(k) = dS_to_dPE(k) + dT_to_dPE_b(k) = dT_to_dPE(k) ; dS_to_dPE_b(k) = dS_to_dPE(k) + dT_to_dColHt_a(k) = dT_to_dColHt(k) ; dS_to_dColHt_a(k) = dS_to_dColHt(k) + dT_to_dColHt_b(k) = dT_to_dColHt(k) ; dS_to_dColHt_b(k) = dS_to_dColHt(k) + enddo + do K=1,nz+1 + Kd_so_far(K) = 0.0 + enddo + + ! Calculate the dependencies on layers above. + do K=2,nz ! Loop over interior interfaces. + ! First calculate some terms that are independent of the change in Kddt_h(K). + Kd0 = Kd_so_far(K) + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) + Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) + + dKd = 0.5 * Kddt_h(K) - Kd_so_far(K) + + call find_PE_chg(Kd0, dKd, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) + + PE_chg_k(K,4) = PE_change + ColHt_cor_k(K,4) = ColHt_cor + + Kd_so_far(K) = Kd_so_far(K) + dKd + + b1 = 1.0 / (hp_a(k-1) + Kd_so_far(K)) + c1_a(K) = Kd_so_far(K) * b1 + + Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2)) + Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2)) + + hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kd_so_far(K) + dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) + dS_to_dPE_a(k) = dS_to_dPE(k) + c1_a(K)*dS_to_dPE_a(k-1) + dT_to_dColHt_a(k) = dT_to_dColHt(k) + c1_a(K)*dT_to_dColHt_a(k-1) + dS_to_dColHt_a(k) = dS_to_dColHt(k) + c1_a(K)*dS_to_dColHt_a(k-1) + enddo + + ! Calculate the dependencies on layers below. + do K=nz,2,-1 ! Loop over interior interfaces. + ! First calculate some terms that are independent of the change in Kddt_h(K). + Kd0 = Kd_so_far(K) + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) + Th_b(k) = h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1) + + dKd = Kddt_h(K) - Kd_so_far(K) + + call find_PE_chg(Kd0, dKd, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) + + PE_chg_k(K,4) = PE_chg_k(K,4) + PE_change + ColHt_cor_k(K,4) = ColHt_cor_k(K,4) + ColHt_cor + + + Kd_so_far(K) = Kd_so_far(K) + dKd + + b1 = 1.0 / (hp_b(k) + Kd_so_far(K)) + c1_b(K) = Kd_so_far(K) * b1 + + Te(k) = b1 * (h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1)) + Se(k) = b1 * (h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1)) + + hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kd_so_far(K) + dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) + dS_to_dPE_b(k-1) = dS_to_dPE(k-1) + c1_b(K)*dS_to_dPE_b(k) + dT_to_dColHt_b(k-1) = dT_to_dColHt(k-1) + c1_b(K)*dT_to_dColHt_b(k) + dS_to_dColHt_b(k-1) = dS_to_dColHt(k-1) + c1_b(K)*dS_to_dColHt_b(k) + + enddo + + ! Now update the other layer working down from the top to determine the + ! final temperatures and salinities. + b1 = 1.0 / (hp_b(1)) + Tf(1) = b1 * (h_tr(1) * T0(1) + Kddt_h(2) * Te(2)) + Sf(1) = b1 * (h_tr(1) * S0(1) + Kddt_h(2) * Se(2)) + do k=2,nz + Tf(k) = Te(k) + c1_b(K)*Tf(k-1) + Sf(k) = Se(k) + c1_b(K)*Sf(k-1) + enddo + + if (debug) then + PE_chg_tot1D = 0.0 ; PE_chg_tot2D = 0.0 ; T_chg_totD = 0.0 + do k=1,nz + PE_chg_tot1D = PE_chg_tot1D + (dT_to_dPE(k) * (Tf(k) - T0(k)) + & + dS_to_dPE(k) * (Sf(k) - S0(k))) + T_chg_totD = T_chg_totD + h_tr(k) * (Tf(k) - T0(k)) + enddo + do K=2,nz + PE_chg_tot2D = PE_chg_tot2D + (PE_chg_k(K,4) - ColHt_cor_k(K,4)) + enddo + endif + + endif + + energy_Kd = 0.0 ; do K=2,nz ; energy_Kd = energy_Kd + PE_chg_k(K,1) ; enddo + energy_Kd = energy_Kd / dt + + if (do_print) then + if (CS%id_ERt>0) call post_data(CS%id_ERt, PE_chg_k(:,1), CS%diag) + if (CS%id_ERb>0) call post_data(CS%id_ERb, PE_chg_k(:,2), CS%diag) + if (CS%id_ERc>0) call post_data(CS%id_ERc, PE_chg_k(:,3), CS%diag) + if (CS%id_ERh>0) call post_data(CS%id_ERh, PE_chg_k(:,4), CS%diag) + if (CS%id_Kddt>0) call post_data(CS%id_Kddt, Kddt_h, CS%diag) + if (CS%id_Kd>0) call post_data(CS%id_Kd, Kd, CS%diag) + if (CS%id_h>0) call post_data(CS%id_h, h_tr, CS%diag) + if (CS%id_zInt>0) call post_data(CS%id_zInt, Z_int, CS%diag) + if (CS%id_CHCt>0) call post_data(CS%id_CHCt, ColHt_cor_k(:,1), CS%diag) + if (CS%id_CHCb>0) call post_data(CS%id_CHCb, ColHt_cor_k(:,2), CS%diag) + if (CS%id_CHCc>0) call post_data(CS%id_CHCc, ColHt_cor_k(:,3), CS%diag) + if (CS%id_CHCh>0) call post_data(CS%id_CHCh, ColHt_cor_k(:,4), CS%diag) + if (CS%id_T0>0) call post_data(CS%id_T0, T0, CS%diag) + if (CS%id_Tf>0) call post_data(CS%id_Tf, Tf, CS%diag) + if (CS%id_S0>0) call post_data(CS%id_S0, S0, CS%diag) + if (CS%id_Sf>0) call post_data(CS%id_Sf, Sf, CS%diag) + if (CS%id_N2_0>0) then + N2(1) = 0.0 ; N2(nz+1) = 0.0 + do K=2,nz + call calculate_density(0.5*(T0(k-1) + T0(k)), 0.5*(S0(k-1) + S0(k)), & + pres(K), rho_here, tv%eqn_of_state) + N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*(dz_tr(k-1) + dz_tr(k)))) * & + ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (T0(k-1) - T0(k)) + & + 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (S0(k-1) - S0(k)) ) + enddo + call post_data(CS%id_N2_0, N2, CS%diag) + endif + if (CS%id_N2_f>0) then + N2(1) = 0.0 ; N2(nz+1) = 0.0 + do K=2,nz + call calculate_density(0.5*(Tf(k-1) + Tf(k)), 0.5*(Sf(k-1) + Sf(k)), & + pres(K), rho_here, tv%eqn_of_state) + N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*(dz_tr(k-1) + dz_tr(k)))) * & + ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (Tf(k-1) - Tf(k)) + & + 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (Sf(k-1) - Sf(k)) ) + enddo + call post_data(CS%id_N2_f, N2, CS%diag) + endif + endif + +end subroutine diapyc_energy_req_calc + +!> This subroutine calculates the change in potential energy and or derivatives +!! for several changes in an interface's diapycnal diffusivity times a timestep. +subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & + dT_to_dPE_a, dS_to_dPE_a, dT_to_dPE_b, dS_to_dPE_b, & + pres_Z, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & + PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, PE_ColHt_cor) + real, intent(in) :: Kddt_h0 !< The previously used diffusivity at an interface times + !! the time step and divided by the average of the + !! thicknesses around the interface [H ~> m or kg m-2]. + real, intent(in) :: dKddt_h !< The trial change in the diffusivity at an interface times + !! the time step and divided by the average of the + !! thicknesses around the interface [H ~> m or kg m-2]. + real, intent(in) :: hp_a !< The effective pivot thickness of the layer above the + !! interface, given by h_k plus a term that + !! is a fraction (determined from the tridiagonal solver) of + !! Kddt_h for the interface above [H ~> m or kg m-2]. + real, intent(in) :: hp_b !< The effective pivot thickness of the layer below the + !! interface, given by h_k plus a term that + !! is a fraction (determined from the tridiagonal solver) of + !! Kddt_h for the interface above [H ~> m or kg m-2]. + real, intent(in) :: Th_a !< An effective temperature times a thickness in the layer + !! above, including implicit mixing effects with other + !! yet higher layers [C H ~> degC m or degC kg m-2]. + real, intent(in) :: Sh_a !< An effective salinity times a thickness in the layer + !! above, including implicit mixing effects with other + !! yet higher layers [S H ~> ppt m or ppt kg m-2]. + real, intent(in) :: Th_b !< An effective temperature times a thickness in the layer + !! below, including implicit mixing effects with other + !! yet lower layers [C H ~> degC m or degC kg m-2]. + real, intent(in) :: Sh_b !< An effective salinity times a thickness in the layer + !! below, including implicit mixing effects with other + !! yet lower layers [S H ~> ppt m or ppt kg m-2]. + real, intent(in) :: dT_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers above [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + real, intent(in) :: dS_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers above [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + real, intent(in) :: dT_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers below [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + real, intent(in) :: dS_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers below [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which relates + !! the changes in column thickness to the energy that is radiated + !! as gravity waves and unavailable to drive mixing [R L2 T-2 ~> J m-3]. + real, intent(in) :: dT_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dT) relating + !! a layer's temperature change to the change in column + !! height, including all implicit diffusive changes + !! in the temperatures of all the layers above [Z C-1 ~> m degC-1]. + real, intent(in) :: dS_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dS) relating + !! a layer's salinity change to the change in column + !! height, including all implicit diffusive changes + !! in the salinities of all the layers above [Z S-1 ~> m ppt-1]. + real, intent(in) :: dT_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dT) relating + !! a layer's temperature change to the change in column + !! height, including all implicit diffusive changes + !! in the temperatures of all the layers below [Z C-1 ~> m degC-1]. + real, intent(in) :: dS_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dS) relating + !! a layer's salinity change to the change in column + !! height, including all implicit diffusive changes + !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. + + real, intent(out) :: PE_chg !< The change in column potential energy from applying + !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. + real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, + !! [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could + !! be realized by applying a huge value of Kddt_h at the + !! present interface [R Z L2 T-2 ~> J m-2]. + real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the + !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + real, optional, intent(out) :: PE_ColHt_cor !< The correction to PE_chg that is made due to a net + !! change in the column height [R Z L2 T-2 ~> J m-2]. + + ! Local variables + real :: hps ! The sum of the two effective pivot thicknesses [H ~> m or kg m-2]. + real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term [H2 ~> m2 or kg2 m-4]. + real :: dT_c ! The core term in the expressions for the temperature changes [C H2 ~> degC m2 or degC kg2 m-4]. + real :: dS_c ! The core term in the expressions for the salinity changes [S H2 ~> ppt m2 or ppt kg2 m-4]. + real :: PEc_core ! The diffusivity-independent core term in the expressions + ! for the potential energy changes [H3 R Z L2 T-2 ~> J m or J kg3 m-8]. + real :: ColHt_core ! The diffusivity-independent core term in the expressions + ! for the column height changes [H3 Z ~> m4 or kg3 m-5]. + real :: ColHt_chg ! The change in the column height [Z ~> m]. + real :: y1_3 ! A local temporary term in [H-3 ~> m-3 or m6 kg-3]. + real :: y1_4 ! A local temporary term in [H-4 ~> m-4 or m8 kg-4]. + + ! The expression for the change in potential energy used here is derived + ! from the expression for the final estimates of the changes in temperature + ! and salinities, and then extensively manipulated to get it into its most + ! succinct form. The derivation is not necessarily obvious, but it demonstrably + ! works by comparison with separate calculations of the energy changes after + ! the tridiagonal solver for the final changes in temperature and salinity are + ! applied. + + hps = hp_a + hp_b + bdt1 = hp_a * hp_b + Kddt_h0 * hps + dT_c = hp_a * Th_b - hp_b * Th_a + dS_c = hp_a * Sh_b - hp_b * Sh_a + PEc_core = hp_b * (dT_to_dPE_a * dT_c + dS_to_dPE_a * dS_c) - & + hp_a * (dT_to_dPE_b * dT_c + dS_to_dPE_b * dS_c) + ColHt_core = hp_b * (dT_to_dColHt_a * dT_c + dS_to_dColHt_a * dS_c) - & + hp_a * (dT_to_dColHt_b * dT_c + dS_to_dColHt_b * dS_c) + + ! Find the change in column potential energy due to the change in the + ! diffusivity at this interface by dKddt_h. + y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) + PE_chg = PEc_core * y1_3 + ColHt_chg = ColHt_core * y1_3 + if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg + + if (present(PE_ColHt_cor)) PE_ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) + + if (present(dPEc_dKd)) then + ! Find the derivative of the potential energy change with dKddt_h. + y1_4 = 1.0 / (bdt1 + dKddt_h * hps)**2 + dPEc_dKd = PEc_core * y1_4 + ColHt_chg = ColHt_core * y1_4 + if (ColHt_chg < 0.0) dPEc_dKd = dPEc_dKd - pres_Z * ColHt_chg + endif + + if (present(dPE_max)) then + ! This expression is the limit of PE_chg for infinite dKddt_h. + y1_3 = 1.0 / (bdt1 * hps) + dPE_max = PEc_core * y1_3 + ColHt_chg = ColHt_core * y1_3 + if (ColHt_chg < 0.0) dPE_max = dPE_max - pres_Z * ColHt_chg + endif + + if (present(dPEc_dKd_0)) then + ! This expression is the limit of dPEc_dKd for dKddt_h = 0. + y1_4 = 1.0 / bdt1**2 + dPEc_dKd_0 = PEc_core * y1_4 + ColHt_chg = ColHt_core * y1_4 + if (ColHt_chg < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres_Z * ColHt_chg + endif + +end subroutine find_PE_chg + + +!> Initialize parameters and allocate memory associated with the diapycnal energy requirement module. +subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< model time + type(ocean_grid_type), intent(in) :: G !< model grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< file to parse for parameter values + type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output + type(diapyc_energy_req_CS), pointer :: CS !< module control structure + +! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mdl = "MOM_diapyc_energy_req" ! This module's name. + + if (.not.associated(CS)) then ; allocate(CS) + else ; return ; endif + + CS%initialized = .true. + CS%diag => diag + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "ENERGY_REQ_KH_SCALING", CS%test_Kh_scaling, & + "A scaling factor for the diapycnal diffusivity used in "//& + "testing the energy requirements.", default=1.0, units="nondim") + call get_param(param_file, mdl, "ENERGY_REQ_COL_HT_SCALING", CS%ColHt_scaling, & + "A scaling factor for the column height change correction "//& + "used in testing the energy requirements.", default=1.0, units="nondim") + call get_param(param_file, mdl, "ENERGY_REQ_USE_TEST_PROFILE", CS%use_test_Kh_profile, & + "If true, use the internal test diffusivity profile in "//& + "place of any that might be passed in as an argument.", default=.false.) + call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) + + CS%id_ERt = register_diag_field('ocean_model', 'EnReqTest_ERt', diag%axesZi, Time, & + "Diffusivity Energy Requirements, top-down", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) + CS%id_ERb = register_diag_field('ocean_model', 'EnReqTest_ERb', diag%axesZi, Time, & + "Diffusivity Energy Requirements, bottom-up", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) + CS%id_ERc = register_diag_field('ocean_model', 'EnReqTest_ERc', diag%axesZi, Time, & + "Diffusivity Energy Requirements, center-last", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) + CS%id_ERh = register_diag_field('ocean_model', 'EnReqTest_ERh', diag%axesZi, Time, & + "Diffusivity Energy Requirements, halves", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) + CS%id_Kddt = register_diag_field('ocean_model', 'EnReqTest_Kddt', diag%axesZi, Time, & + "Implicit diffusive coupling coefficient", "m", conversion=GV%H_to_m) + CS%id_Kd = register_diag_field('ocean_model', 'EnReqTest_Kd', diag%axesZi, Time, & + "Diffusivity in test", "m2 s-1", conversion=US%Z2_T_to_m2_s) + CS%id_h = register_diag_field('ocean_model', 'EnReqTest_h_lay', diag%axesZL, Time, & + "Test column layer thicknesses", "m", conversion=GV%H_to_m) + CS%id_zInt = register_diag_field('ocean_model', 'EnReqTest_z_int', diag%axesZi, Time, & + "Test column layer interface heights", "m", conversion=GV%H_to_m) + CS%id_CHCt = register_diag_field('ocean_model', 'EnReqTest_CHCt', diag%axesZi, Time, & + "Column Height Correction to Energy Requirements, top-down", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) + CS%id_CHCb = register_diag_field('ocean_model', 'EnReqTest_CHCb', diag%axesZi, Time, & + "Column Height Correction to Energy Requirements, bottom-up", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) + CS%id_CHCc = register_diag_field('ocean_model', 'EnReqTest_CHCc', diag%axesZi, Time, & + "Column Height Correction to Energy Requirements, center-last", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) + CS%id_CHCh = register_diag_field('ocean_model', 'EnReqTest_CHCh', diag%axesZi, Time, & + "Column Height Correction to Energy Requirements, halves", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) + CS%id_T0 = register_diag_field('ocean_model', 'EnReqTest_T0', diag%axesZL, Time, & + "Temperature before mixing", "deg C", conversion=US%C_to_degC) + CS%id_Tf = register_diag_field('ocean_model', 'EnReqTest_Tf', diag%axesZL, Time, & + "Temperature after mixing", "deg C", conversion=US%C_to_degC) + CS%id_S0 = register_diag_field('ocean_model', 'EnReqTest_S0', diag%axesZL, Time, & + "Salinity before mixing", "g kg-1", conversion=US%S_to_ppt) + CS%id_Sf = register_diag_field('ocean_model', 'EnReqTest_Sf', diag%axesZL, Time, & + "Salinity after mixing", "g kg-1", conversion=US%S_to_ppt) + CS%id_N2_0 = register_diag_field('ocean_model', 'EnReqTest_N2_0', diag%axesZi, Time, & + "Squared buoyancy frequency before mixing", "second-2", conversion=US%s_to_T**2) + CS%id_N2_f = register_diag_field('ocean_model', 'EnReqTest_N2_f', diag%axesZi, Time, & + "Squared buoyancy frequency after mixing", "second-2", conversion=US%s_to_T**2) + +end subroutine diapyc_energy_req_init + +!> Clean up and deallocate memory associated with the diapycnal energy requirement module. +subroutine diapyc_energy_req_end(CS) + type(diapyc_energy_req_CS), pointer :: CS !< Diapycnal energy requirement control structure that + !! will be deallocated in this subroutine. + if (associated(CS)) deallocate(CS) +end subroutine diapyc_energy_req_end + +end module MOM_diapyc_energy_req diff --git a/parameterizations/vertical/MOM_energetic_PBL.F90 b/parameterizations/vertical/MOM_energetic_PBL.F90 new file mode 100644 index 0000000000..10907c04ed --- /dev/null +++ b/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -0,0 +1,2573 @@ +!> Energetically consistent planetary boundary layer parameterization +module MOM_energetic_PBL + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_coms, only : EFP_type, real_to_EFP, EFP_to_real, operator(+), assignment(=), EFP_sum_across_PEs +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc +use MOM_diag_mediator, only : time_type, diag_ctrl +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_intrinsic_functions, only : cuberoot +use MOM_string_functions, only : uppercase +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number +use MOM_stochastics, only : stochastic_CS + +implicit none ; private + +#include + +public energetic_PBL, energetic_PBL_init, energetic_PBL_end +public energetic_PBL_get_MLD + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> This control structure holds parameters for the MOM_energetic_PBL module +type, public :: energetic_PBL_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + + !/ Constants + real :: VonKar !< The von Karman coefficient as used in the ePBL module [nondim] + real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. + real :: omega_frac !< When setting the decay scale for turbulence, use this fraction of + !! the absolute rotation rate blended with the local value of f, as + !! sqrt((1-omega_frac)*f^2 + omega_frac*4*omega^2) [nondim]. + + !/ Convection related terms + real :: nstar !< The fraction of the TKE input to the mixed layer available to drive + !! entrainment [nondim]. This quantity is the vertically integrated + !! buoyancy production minus the vertically integrated dissipation of + !! TKE produced by buoyancy. + + !/ Mixing Length terms + logical :: Use_MLD_iteration !< If true, use the proximity to the bottom of the actively turbulent + !! surface boundary layer to constrain the mixing lengths. + logical :: MLD_iteration_guess !< False to default to guessing half the + !! ocean depth for the first iteration. + logical :: MLD_bisection !< If true, use bisection with the iterative determination of the + !! self-consistent mixed layer depth. Otherwise use the false position + !! after a maximum and minimum bound have been evaluated and the + !! returned value from the previous guess or bisection before this. + integer :: max_MLD_its !< The maximum number of iterations that can be used to find a + !! self-consistent mixed layer depth with Use_MLD_iteration. + real :: MixLenExponent !< Exponent in the mixing length shape-function [nondim]. + !! 1 is law-of-the-wall at top and bottom, + !! 2 is more KPP like. + real :: MKE_to_TKE_effic !< The efficiency with which mean kinetic energy released by + !! mechanically forced entrainment of the mixed layer is converted to + !! TKE [nondim]. + real :: ustar_min !< A minimum value of ustar to avoid numerical problems [Z T-1 ~> m s-1]. + !! If the value is small enough, this should not affect the solution. + real :: Ekman_scale_coef !< A nondimensional scaling factor controlling the inhibition of the + !! diffusive length scale by rotation [nondim]. Making this larger decreases + !! the diffusivity in the planetary boundary layer. + real :: transLay_scale !< A scale for the mixing length in the transition layer + !! at the edge of the boundary layer as a fraction of the + !! boundary layer thickness [nondim]. The default is 0, but a + !! value of 0.1 might be better justified by observations. + real :: MLD_tol !< A tolerance for determining the boundary layer thickness when + !! Use_MLD_iteration is true [Z ~> m]. + real :: min_mix_len !< The minimum mixing length scale that will be used by ePBL [Z ~> m]. + !! The default (0) does not set a minimum. + + !/ Velocity scale terms + integer :: wT_scheme !< An enumerated value indicating the method for finding the turbulent + !! velocity scale. There are currently two options: + !! wT_mwT_from_cRoot_TKE is the original (TKE_remaining)^1/3 + !! wT_from_RH18 is the version described by Reichl and Hallberg, 2018 + real :: wstar_ustar_coef !< A ratio relating the efficiency with which convectively released + !! energy is converted to a turbulent velocity, relative to + !! mechanically forced turbulent kinetic energy [nondim]. + !! Making this larger increases the diffusivity. + real :: vstar_surf_fac !< If (wT_scheme == wT_from_RH18) this is the proportionality coefficient between + !! ustar and the surface mechanical contribution to vstar [nondim] + real :: vstar_scale_fac !< An overall nondimensional scaling factor for vstar times a unit + !! conversion factor [Z s T-1 m-1 ~> nondim]. Making this larger increases + !! the diffusivity. + + !mstar related options + integer :: mstar_scheme !< An encoded integer to determine which formula is used to set mstar + logical :: MSTAR_FLATCAP=.true. !< Set false to use asymptotic mstar cap. + real :: mstar_cap !< Since MSTAR is restoring undissipated energy to mixing, + !! there must be a cap on how large it can be [nondim]. This + !! is definitely a function of latitude (Ekman limit), + !! but will be taken as constant for now. + + !/ vertical decay related options + real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE decay scale [nondim]. + + !/ mstar_scheme == 0 + real :: fixed_mstar !< Mstar is the ratio of the friction velocity cubed to the TKE available to + !! drive entrainment [nondim]. This quantity is the vertically + !! integrated shear production minus the vertically integrated + !! dissipation of TKE produced by shear. This value is used if the option + !! for using a fixed mstar is used. + + !/ mstar_scheme == 2 + real :: C_EK = 0.17 !< MSTAR Coefficient in rotation limit for mstar_scheme=OM4 [nondim] + real :: MSTAR_COEF = 0.3 !< MSTAR coefficient in rotation/stabilizing balance for mstar_scheme=OM4 [nondim] + + !/ mstar_scheme == 3 + real :: RH18_mstar_cN1 !< MSTAR_N coefficient 1 (outer-most coefficient for fit) [nondim]. + !! Value of 0.275 in RH18. Increasing this + !! coefficient increases mechanical mixing for all values of Hf/ust, + !! but is most effective at low values (weakly developed OSBLs). + real :: RH18_mstar_cN2 !< MSTAR_N coefficient 2 (coefficient outside of exponential decay) [nondim]. + !! Value of 8.0 in RH18. Increasing this coefficient increases MSTAR + !! for all values of HF/ust, with a consistent affect across + !! a wide range of Hf/ust. + real :: RH18_mstar_cN3 !< MSTAR_N coefficient 3 (exponential decay coefficient) [nondim]. Value of + !! -5.0 in RH18. Increasing this increases how quickly the value + !! of MSTAR decreases as Hf/ust increases. + real :: RH18_mstar_cS1 !< MSTAR_S coefficient for RH18 in stabilizing limit [nondim]. + !! Value of 0.2 in RH18. + real :: RH18_mstar_cS2 !< MSTAR_S exponent for RH18 in stabilizing limit [nondim]. + !! Value of 0.4 in RH18. + + !/ Coefficient for shear/convective turbulence interaction + real :: mstar_convect_coef !< Factor to reduce mstar when statically unstable [nondim]. + + !/ Langmuir turbulence related parameters + logical :: Use_LT = .false. !< Flag for using LT in Energy calculation + integer :: LT_ENHANCE_FORM !< Integer for Enhancement functional form (various options) + real :: LT_ENHANCE_COEF !< Coefficient in fit for Langmuir Enhancement [nondim] + real :: LT_ENHANCE_EXP !< Exponent in fit for Langmuir Enhancement [nondim] + real :: LaC_MLDoEK !< Coefficient for Langmuir number modification based on the ratio of + !! the mixed layer depth over the Ekman depth [nondim]. + real :: LaC_MLDoOB_stab !< Coefficient for Langmuir number modification based on the ratio of + !! the mixed layer depth over the Obukhov depth with stabilizing forcing [nondim]. + real :: LaC_EKoOB_stab !< Coefficient for Langmuir number modification based on the ratio of + !! the Ekman depth over the Obukhov depth with stabilizing forcing [nondim]. + real :: LaC_MLDoOB_un !< Coefficient for Langmuir number modification based on the ratio of + !! the mixed layer depth over the Obukhov depth with destabilizing forcing [nondim]. + real :: LaC_EKoOB_un !< Coefficient for Langmuir number modification based on the ratio of + !! the Ekman depth over the Obukhov depth with destabilizing forcing [nondim]. + real :: Max_Enhance_M = 5. !< The maximum allowed LT enhancement to the mixing [nondim]. + + !/ Others + type(time_type), pointer :: Time=>NULL() !< A pointer to the ocean model's clock. + + logical :: TKE_diagnostics = .false. !< If true, diagnostics of the TKE budget are being calculated. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the ePBL + !! calculations. Values below 20190101 recover the answers from the + !! end of 2018, while higher values use updated and more robust forms + !! of the same expressions. Values below 20240101 use A**(1./3.) to + !! estimate the cube root of A in several expressions, while higher + !! values use the integer root function cuberoot(A) and therefore + !! can work with scaled variables. + logical :: orig_PE_calc !< If true, the ePBL code uses the original form of the + !! potential energy change code. Otherwise, it uses a newer version + !! that can work with successive increments to the diffusivity in + !! upward or downward passes. + type(diag_ctrl), pointer :: diag=>NULL() !< A structure that is used to regulate the + !! timing of diagnostic output. + + real, allocatable, dimension(:,:) :: & + ML_depth !< The mixed layer depth determined by active mixing in ePBL [H ~> m or kg m-2] + ! These are terms in the mixed layer TKE budget, all in [R Z3 T-3 ~> W m-2 = kg s-3]. + real, allocatable, dimension(:,:) :: & + diag_TKE_wind, & !< The wind source of TKE [R Z3 T-3 ~> W m-2]. + diag_TKE_MKE, & !< The resolved KE source of TKE [R Z3 T-3 ~> W m-2]. + diag_TKE_conv, & !< The convective source of TKE [R Z3 T-3 ~> W m-2]. + diag_TKE_forcing, & !< The TKE sink required to mix surface penetrating shortwave heating + !! [R Z3 T-3 ~> W m-2]. + diag_TKE_mech_decay, & !< The decay of mechanical TKE [R Z3 T-3 ~> W m-2]. + diag_TKE_conv_decay, & !< The decay of convective TKE [R Z3 T-3 ~> W m-2]. + diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer [R Z3 T-3 ~> W m-2]. + ! These additional diagnostics are also 2d. + MSTAR_MIX, & !< Mstar used in EPBL [nondim] + MSTAR_LT, & !< Mstar due to Langmuir turbulence [nondim] + LA, & !< Langmuir number [nondim] + LA_MOD !< Modified Langmuir number [nondim] + + type(EFP_type), dimension(2) :: sum_its !< The total number of iterations and columns worked on + + real, allocatable, dimension(:,:,:) :: & + Velocity_Scale, & !< The velocity scale used in getting Kd [Z T-1 ~> m s-1] + Mixing_Length !< The length scale used in getting Kd [Z ~> m] + !>@{ Diagnostic IDs + integer :: id_ML_depth = -1, id_hML_depth = -1, id_TKE_wind = -1, id_TKE_mixing = -1 + integer :: id_TKE_MKE = -1, id_TKE_conv = -1, id_TKE_forcing = -1 + integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 + integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 + integer :: id_MSTAR_mix = -1, id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 + !>@} +end type energetic_PBL_CS + +!>@{ Enumeration values for mstar_Scheme +integer, parameter :: Use_Fixed_MStar = 0 !< The value of mstar_scheme to use a constant mstar +integer, parameter :: MStar_from_Ekman = 2 !< The value of mstar_scheme to base mstar on the ratio + !! of the Ekman layer depth to the Obukhov depth +integer, parameter :: MStar_from_RH18 = 3 !< The value of mstar_scheme to base mstar of of RH18 +integer, parameter :: No_Langmuir = 0 !< The value of LT_ENHANCE_FORM not use Langmuir turbulence. +integer, parameter :: Langmuir_rescale = 2 !< The value of LT_ENHANCE_FORM to use a multiplicative + !! rescaling of mstar to account for Langmuir turbulence. +integer, parameter :: Langmuir_add = 3 !< The value of LT_ENHANCE_FORM to add a contribution to + !! mstar from Langmuir turbulence to other contributions. +integer, parameter :: wT_from_cRoot_TKE = 0 !< Use a constant times the cube root of remaining TKE + !! to calculate the turbulent velocity. +integer, parameter :: wT_from_RH18 = 1 !< Use a scheme based on a combination of w* and v* as + !! documented in Reichl & Hallberg (2018) to calculate + !! the turbulent velocity. +character*(20), parameter :: CONSTANT_STRING = "CONSTANT" +character*(20), parameter :: OM4_STRING = "OM4" +character*(20), parameter :: RH18_STRING = "REICHL_H18" +character*(20), parameter :: ROOT_TKE_STRING = "CUBE_ROOT_TKE" +character*(20), parameter :: NONE_STRING = "NONE" +character*(20), parameter :: RESCALED_STRING = "RESCALE" +character*(20), parameter :: ADDITIVE_STRING = "ADDITIVE" +!>@} + +logical :: report_avg_its = .false. !< Report the average number of ePBL iterations for debugging. + +!> A type for conveniently passing around ePBL diagnostics for a column. +type, public :: ePBL_column_diags ; private + !>@{ Local column copies of energy change diagnostics, all in [R Z3 T-3 ~> W m-2]. + real :: dTKE_conv, dTKE_forcing, dTKE_wind, dTKE_mixing ! Local column diagnostics [R Z3 T-3 ~> W m-2] + real :: dTKE_MKE, dTKE_mech_decay, dTKE_conv_decay ! Local column diagnostics [R Z3 T-3 ~> W m-2] + !>@} + real :: LA !< The value of the Langmuir number [nondim] + real :: LAmod !< The modified Langmuir number by convection [nondim] + real :: mstar !< The value of mstar used in ePBL [nondim] + real :: mstar_LT !< The portion of mstar due to Langmuir turbulence [nondim] +end type ePBL_column_diags + +contains + +!> This subroutine determines the diffusivities from the integrated energetics +!! mixed layer model. It assumes that heating, cooling and freshwater fluxes +!! have already been applied. All calculations are done implicitly, and there +!! is no stability limit on the time step. +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & + stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, Waves ) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_3d !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u_3d !< Zonal velocities interpolated to h points + !! [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: v_3d !< Zonal velocities interpolated to h points + !! [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dSV_dT !< The partial derivative of in-situ specific + !! volume with potential temperature + !! [R-1 C-1 ~> m3 kg-1 degC-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dSV_dS !< The partial derivative of in-situ specific + !! volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: TKE_forced !< The forcing requirements to homogenize the + !! forcing that has been applied to each layer + !! [R Z3 T-2 ~> J m-2]. + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent fields + !! have NULL ptrs. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields have + !! NULL ptrs. + real, intent(in) :: dt !< Time increment [T ~> s]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. + type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence + type(stochastic_CS), pointer :: stoch_CS !< The control structure returned by a previous + +! This subroutine determines the diffusivities from the integrated energetics +! mixed layer model. It assumes that heating, cooling and freshwater fluxes +! have already been applied. All calculations are done implicitly, and there +! is no stability limit on the time step. +! +! For each interior interface, first discard the TKE to account for mixing +! of shortwave radiation through the next denser cell. Next drive mixing based +! on the local? values of ustar + wstar, subject to available energy. This +! step sets the value of Kd(K). Any remaining energy is then subject to decay +! before being handed off to the next interface. mech_TKE and conv_PErel are treated +! separately for the purposes of decay, but are used proportionately to drive +! mixing. +! +! The key parameters for the mixed layer are found in the control structure. +! To use the classic constant mstar mixed layers choose MSTAR_SCHEME=CONSTANT. +! The key parameters then include mstar, nstar, TKE_decay, and conv_decay. +! For the Oberhuber (1993) mixed layer,the values of these are: +! mstar = 1.25, nstar = 1, TKE_decay = 2.5, conv_decay = 0.5 +! TKE_decay is 1/kappa in eq. 28 of Oberhuber (1993), while conv_decay is 1/mu. +! For a traditional Kraus-Turner mixed layer, the values are: +! mstar = 1.25, nstar = 0.4, TKE_decay = 0.0, conv_decay = 0.0 + + ! Local variables + real, dimension(SZI_(G),SZK_(GV)) :: & + h_2d, & ! A 2-d slice of the layer thickness [H ~> m or kg m-2]. + dz_2d, & ! A 2-d slice of the vertical distance across layers [Z ~> m]. + T_2d, & ! A 2-d slice of the layer temperatures [C ~> degC]. + S_2d, & ! A 2-d slice of the layer salinities [S ~> ppt]. + TKE_forced_2d, & ! A 2-d slice of TKE_forced [R Z3 T-2 ~> J m-2]. + dSV_dT_2d, & ! A 2-d slice of dSV_dT [R-1 C-1 ~> m3 kg-1 degC-1]. + dSV_dS_2d, & ! A 2-d slice of dSV_dS [R-1 S-1 ~> m3 kg-1 ppt-1]. + u_2d, & ! A 2-d slice of the zonal velocity [L T-1 ~> m s-1]. + v_2d ! A 2-d slice of the meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZK_(GV)+1) :: & + Kd_2d ! A 2-d version of the diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: & + h, & ! The layer thickness [H ~> m or kg m-2]. + dz, & ! The vertical distance across layers [Z ~> m]. + T0, & ! The initial layer temperatures [C ~> degC]. + S0, & ! The initial layer salinities [S ~> ppt]. + dSV_dT_1d, & ! The partial derivatives of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. + dSV_dS_1d, & ! The partial derivatives of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + TKE_forcing, & ! Forcing of the TKE in the layer coming from TKE_forced [R Z3 T-2 ~> J m-2]. + u, & ! The zonal velocity [L T-1 ~> m s-1]. + v ! The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZK_(GV)+1) :: & + Kd, & ! The diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + mixvel, & ! A turbulent mixing velocity [Z T-1 ~> m s-1]. + mixlen, & ! A turbulent mixing length [Z ~> m]. + SpV_dt ! Specific volume interpolated to interfaces divided by dt or 1.0 / (dt * Rho0) + ! times conversion factors for answer dates before 20240101 in + ! [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1] or without the convsersion factors for + ! answer dates of 20240101 and later in [R-1 T-1 ~> m3 kg-1 s-1], used to + ! convert local TKE into a turbulence velocity cubed. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + + real :: absf ! The absolute value of f [T-1 ~> s-1]. + real :: U_star ! The surface friction velocity [Z T-1 ~> m s-1]. + real :: U_Star_Mean ! The surface friction without gustiness [Z T-1 ~> m s-1]. + real :: mech_TKE ! The mechanically generated turbulent kinetic energy available for mixing over a + ! timestep before the application of the efficiency in mstar [R Z3 T-2 ~> J m-2] + real :: I_rho ! The inverse of the Boussinesq reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] + real :: I_dt ! The Adcroft reciprocal of the timestep [T-1 ~> s-1] + real :: I_rho0dt ! The inverse of the Boussinesq reference density times the time + ! step [R-1 T-1 ~> m3 kg-1 s-1] + real :: B_Flux ! The surface buoyancy flux [Z2 T-3 ~> m2 s-3] + real :: MLD_io ! The mixed layer depth found by ePBL_column [Z ~> m] + + type(ePBL_column_diags) :: eCD ! A container for passing around diagnostics. + + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not. CS%initialized) call MOM_error(FATAL, "energetic_PBL: "//& + "Module must be initialized before it is used.") + if (.not. associated(tv%eqn_of_state)) call MOM_error(FATAL, & + "energetic_PBL: Temperature, salinity and an equation of state "//& + "must now be used.") + if (.not.(associated(fluxes%ustar) .or. associated(fluxes%tau_mag))) call MOM_error(FATAL, & + "energetic_PBL: No surface friction velocity (ustar or tau_mag) defined in fluxes type.") + if ((.not.GV%Boussinesq) .and. (.not.associated(fluxes%tau_mag))) call MOM_error(FATAL, & + "energetic_PBL: No surface wind stress magnitude defined in fluxes type in non-Boussinesq mode.") + if (CS%use_LT .and. .not.associated(Waves)) call MOM_error(FATAL, & + "energetic_PBL: The Waves control structure must be associated if CS%use_LT "//& + "(i.e., USE_LA_LI2016 or EPBL_LT) is True.") + + + h_neglect = GV%H_subroundoff + I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 ! This is not used when fully non-Boussinesq. + I_dt = 0.0 ; if (dt > 0.0) I_dt = 1.0 / dt + I_rho0dt = 1.0 / (GV%Rho0 * dt) ! This is not used when fully non-Boussinesq. + + ! Zero out diagnostics before accumulation. + if (CS%TKE_diagnostics) then + !!OMP parallel do default(none) shared(is,ie,js,je,CS) + do j=js,je ; do i=is,ie + CS%diag_TKE_wind(i,j) = 0.0 ; CS%diag_TKE_MKE(i,j) = 0.0 + CS%diag_TKE_conv(i,j) = 0.0 ; CS%diag_TKE_forcing(i,j) = 0.0 + CS%diag_TKE_mixing(i,j) = 0.0 ; CS%diag_TKE_mech_decay(i,j) = 0.0 + CS%diag_TKE_conv_decay(i,j) = 0.0 !; CS%diag_TKE_unbalanced(i,j) = 0.0 + enddo ; enddo + endif + ! if (CS%id_Mixing_Length>0) CS%Mixing_Length(:,:,:) = 0.0 + ! if (CS%id_Velocity_Scale>0) CS%Velocity_Scale(:,:,:) = 0.0 + + !!OMP parallel do default(private) shared(js,je,nz,is,ie,h_3d,u_3d,v_3d,tv,dt,I_dt, & + !!OMP CS,G,GV,US,fluxes,TKE_forced,dSV_dT,dSV_dS,Kd_int) + do j=js,je + ! Copy the thicknesses and other fields to 2-d arrays. + do k=1,nz ; do i=is,ie + h_2d(i,k) = h_3d(i,j,k) ; u_2d(i,k) = u_3d(i,j,k) ; v_2d(i,k) = v_3d(i,j,k) + T_2d(i,k) = tv%T(i,j,k) ; S_2d(i,k) = tv%S(i,j,k) + TKE_forced_2d(i,k) = TKE_forced(i,j,k) + dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; dSV_dS_2d(i,k) = dSV_dS(i,j,k) + enddo ; enddo + call thickness_to_dz(h_3d, tv, dz_2d, j, G, GV) + + ! Set the inverse density used to translating local TKE into a turbulence velocity + SpV_dt(:) = 0.0 + if ((dt > 0.0) .and. GV%Boussinesq .or. .not.allocated(tv%SpV_avg)) then + if (CS%answer_date < 20240101) then + do K=1,nz+1 + SpV_dt(K) = (US%Z_to_m**3*US%s_to_T**3) / (dt*GV%Rho0) + enddo + else + do K=1,nz+1 + SpV_dt(K) = I_rho0dt + enddo + endif + endif + + ! Determine the initial mech_TKE and conv_PErel, including the energy required + ! to mix surface heating through the topmost cell, the energy released by mixing + ! surface cooling & brine rejection down through the topmost cell, and + ! 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.0) then + + ! Copy the thicknesses and other fields to 1-d arrays. + do k=1,nz + h(k) = h_2d(i,k) + GV%H_subroundoff ; dz(k) = dz_2d(i,k) + GV%dZ_subroundoff + u(k) = u_2d(i,k) ; v(k) = v_2d(i,k) + T0(k) = T_2d(i,k) ; S0(k) = S_2d(i,k) ; TKE_forcing(k) = TKE_forced_2d(i,k) + dSV_dT_1d(k) = dSV_dT_2d(i,k) ; dSV_dS_1d(k) = dSV_dS_2d(i,k) + enddo + do K=1,nz+1 ; Kd(K) = 0.0 ; enddo + + ! Make local copies of surface forcing and process them. + if (associated(fluxes%ustar) .and. (GV%Boussinesq .or. .not.associated(fluxes%tau_mag))) then + u_star = fluxes%ustar(i,j) + u_star_Mean = fluxes%ustar_gustless(i,j) + mech_TKE = dt * GV%Rho0 * u_star**3 + elseif (allocated(tv%SpV_avg)) then + u_star = sqrt(US%L_to_Z*fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + u_star_Mean = sqrt(US%L_to_Z*fluxes%tau_mag_gustless(i,j) * tv%SpV_avg(i,j,1)) + mech_TKE = dt * u_star * US%L_to_Z*fluxes%tau_mag(i,j) + else + u_star = sqrt(fluxes%tau_mag(i,j) * I_rho) + u_star_Mean = sqrt(US%L_to_Z*fluxes%tau_mag_gustless(i,j) * I_rho) + mech_TKE = dt * GV%Rho0 * u_star**3 + ! The line above is equivalent to: mech_TKE = dt * u_star * US%L_to_Z*fluxes%tau_mag(i,j) + endif + + if (allocated(tv%SpV_avg) .and. .not.GV%Boussinesq) then + if (CS%answer_date < 20240101) then + SpV_dt(1) = (US%Z_to_m**3*US%s_to_T**3) * tv%SpV_avg(i,j,1) * I_dt + do K=2,nz + SpV_dt(K) = (US%Z_to_m**3*US%s_to_T**3) * 0.5*(tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) * I_dt + enddo + SpV_dt(nz+1) = (US%Z_to_m**3*US%s_to_T**3) * tv%SpV_avg(i,j,nz) * I_dt + else + SpV_dt(1) = tv%SpV_avg(i,j,1) * I_dt + do K=2,nz + SpV_dt(K) = 0.5*(tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) * I_dt + enddo + SpV_dt(nz+1) = tv%SpV_avg(i,j,nz) * I_dt + endif + endif + + B_flux = buoy_flux(i,j) + if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then + if (fluxes%frac_shelf_h(i,j) > 0.0) & + u_star = (1.0 - fluxes%frac_shelf_h(i,j)) * u_star + & + fluxes%frac_shelf_h(i,j) * fluxes%ustar_shelf(i,j) + endif + if (u_star < CS%ustar_min) u_star = CS%ustar_min + if (CS%omega_frac >= 1.0) then + absf = 2.0*CS%omega + else + absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & + (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) + if (CS%omega_frac > 0.0) & + absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) + endif + + ! Perhaps provide a first guess for MLD based on a stored previous value. + MLD_io = -1.0 + if (CS%MLD_iteration_guess .and. (CS%ML_depth(i,j) > 0.0)) MLD_io = CS%ML_depth(i,j) + + if (stoch_CS%pert_epbl) then ! stochastics are active + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, mech_TKE, dt, MLD_io, Kd, mixvel, mixlen, GV, & + US, CS, eCD, Waves, G, i, j, & + TKE_gen_stoch=stoch_CS%epbl1_wts(i,j), TKE_diss_stoch=stoch_CS%epbl2_wts(i,j)) + else + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, mech_TKE, dt, MLD_io, Kd, mixvel, mixlen, GV, & + US, CS, eCD, Waves, G, i, j) + endif + + ! Copy the diffusivities to a 2-d array. + do K=1,nz+1 + Kd_2d(i,K) = Kd(K) + enddo + CS%ML_depth(i,j) = MLD_io + + if (CS%TKE_diagnostics) then + CS%diag_TKE_MKE(i,j) = CS%diag_TKE_MKE(i,j) + eCD%dTKE_MKE + CS%diag_TKE_conv(i,j) = CS%diag_TKE_conv(i,j) + eCD%dTKE_conv + CS%diag_TKE_forcing(i,j) = CS%diag_TKE_forcing(i,j) + eCD%dTKE_forcing + CS%diag_TKE_wind(i,j) = CS%diag_TKE_wind(i,j) + eCD%dTKE_wind + CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) + eCD%dTKE_mixing + CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + eCD%dTKE_mech_decay + CS%diag_TKE_conv_decay(i,j) = CS%diag_TKE_conv_decay(i,j) + eCD%dTKE_conv_decay + ! CS%diag_TKE_unbalanced(i,j) = CS%diag_TKE_unbalanced(i,j) + eCD%dTKE_unbalanced + endif + ! Write to 3-D for outputting Mixing length and velocity scale. + if (CS%id_Mixing_Length>0) then ; do k=1,nz + CS%Mixing_Length(i,j,k) = mixlen(k) + enddo ; endif + if (CS%id_Velocity_Scale>0) then ; do k=1,nz + CS%Velocity_Scale(i,j,k) = mixvel(k) + enddo ; endif + if (allocated(CS%mstar_mix)) CS%mstar_mix(i,j) = eCD%mstar + if (allocated(CS%mstar_lt)) CS%mstar_lt(i,j) = eCD%mstar_LT + if (allocated(CS%La)) CS%La(i,j) = eCD%LA + if (allocated(CS%La_mod)) CS%La_mod(i,j) = eCD%LAmod + else ! End of the ocean-point part of the i-loop + ! For masked points, Kd_int must still be set (to 0) because it has intent out. + do K=1,nz+1 ; Kd_2d(i,K) = 0. ; enddo + CS%ML_depth(i,j) = 0.0 + endif ; enddo ! Close of i-loop - Note unusual loop order! + + do K=1,nz+1 ; do i=is,ie ; Kd_int(i,j,K) = Kd_2d(i,K) ; enddo ; enddo + + enddo ! j-loop + + if (CS%id_ML_depth > 0) call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) + if (CS%id_hML_depth > 0) call post_data(CS%id_hML_depth, CS%ML_depth, CS%diag) + if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, CS%diag_TKE_wind, CS%diag) + if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, CS%diag_TKE_MKE, CS%diag) + if (CS%id_TKE_conv > 0) call post_data(CS%id_TKE_conv, CS%diag_TKE_conv, CS%diag) + if (CS%id_TKE_forcing > 0) call post_data(CS%id_TKE_forcing, CS%diag_TKE_forcing, CS%diag) + if (CS%id_TKE_mixing > 0) call post_data(CS%id_TKE_mixing, CS%diag_TKE_mixing, CS%diag) + if (CS%id_TKE_mech_decay > 0) & + call post_data(CS%id_TKE_mech_decay, CS%diag_TKE_mech_decay, CS%diag) + if (CS%id_TKE_conv_decay > 0) & + call post_data(CS%id_TKE_conv_decay, CS%diag_TKE_conv_decay, CS%diag) + if (CS%id_Mixing_Length > 0) call post_data(CS%id_Mixing_Length, CS%Mixing_Length, CS%diag) + if (CS%id_Velocity_Scale >0) call post_data(CS%id_Velocity_Scale, CS%Velocity_Scale, CS%diag) + if (CS%id_MSTAR_MIX > 0) call post_data(CS%id_MSTAR_MIX, CS%MSTAR_MIX, CS%diag) + if (CS%id_LA > 0) call post_data(CS%id_LA, CS%LA, CS%diag) + if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, CS%LA_MOD, CS%diag) + if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) + if (stoch_CS%pert_epbl) then + if (stoch_CS%id_epbl1_wts > 0) call post_data(stoch_CS%id_epbl1_wts, stoch_CS%epbl1_wts, CS%diag) + if (stoch_CS%id_epbl2_wts > 0) call post_data(stoch_CS%id_epbl2_wts, stoch_CS%epbl2_wts, CS%diag) + endif + +end subroutine energetic_PBL + + + +!> This subroutine determines the diffusivities from the integrated energetics +!! mixed layer model for a single column of water. +subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, mech_TKE_in, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & + Waves, G, i, j, TKE_gen_stoch, TKE_diss_stoch) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m]. + real, dimension(SZK_(GV)), intent(in) :: u !< Zonal velocities interpolated to h points + !! [L T-1 ~> m s-1]. + real, dimension(SZK_(GV)), intent(in) :: v !< Zonal velocities interpolated to h points + !! [L T-1 ~> m s-1]. + real, dimension(SZK_(GV)), intent(in) :: T0 !< The initial layer temperatures [C ~> degC]. + real, dimension(SZK_(GV)), intent(in) :: S0 !< The initial layer salinities [S ~> ppt]. + + real, dimension(SZK_(GV)), intent(in) :: dSV_dT !< The partial derivative of in-situ specific + !! volume with potential temperature + !! [R-1 C-1 ~> m3 kg-1 degC-1]. + real, dimension(SZK_(GV)), intent(in) :: dSV_dS !< The partial derivative of in-situ specific + !! volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + real, dimension(SZK_(GV)+1), intent(in) :: SpV_dt !< Specific volume interpolated to interfaces + !! divided by dt or 1.0 / (dt * Rho0), times conversion + !! factors for answer dates before 20240101 in + !! [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1] or without + !! the convsersion factors for answer dates of + !! 20240101 and later in [R-1 T-1 ~> m3 kg-1 s-1], + !! used to convert local TKE into a turbulence + !! velocity cubed. + real, dimension(SZK_(GV)), intent(in) :: TKE_forcing !< The forcing requirements to homogenize the + !! forcing that has been applied to each layer + !! [R Z3 T-2 ~> J m-2]. + real, intent(in) :: B_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] + real, intent(in) :: absf !< The absolute value of the Coriolis parameter [T-1 ~> s-1]. + real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1]. + real, intent(in) :: u_star_mean !< The surface friction velocity without any + !! contribution from unresolved gustiness [Z T-1 ~> m s-1]. + real, intent(in) :: mech_TKE_in !< The mechanically generated turbulent + !! kinetic energy available for mixing over a time + !! step before the application of the efficiency + !! in mstar. [R Z3 T-2 ~> J m-2]. + real, intent(inout) :: MLD_io !< A first guess at the mixed layer depth on input, and + !! the calculated mixed layer depth on output [Z ~> m] + real, intent(in) :: dt !< Time increment [T ~> s]. + real, dimension(SZK_(GV)+1), & + intent(out) :: Kd !< The diagnosed diffusivities at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZK_(GV)+1), & + intent(out) :: mixvel !< The mixing velocity scale used in Kd + !! [Z T-1 ~> m s-1]. + real, dimension(SZK_(GV)+1), & + intent(out) :: mixlen !< The mixing length scale used in Kd [Z ~> m]. + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure + type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. + type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + real, optional, intent(in) :: TKE_gen_stoch !< random factor used to perturb TKE generation [nondim] + real, optional, intent(in) :: TKE_diss_stoch !< random factor used to perturb TKE dissipation [nondim] + integer, intent(in) :: i !< The i-index to work on (used for Waves) + integer, intent(in) :: j !< The i-index to work on (used for Waves) + +! This subroutine determines the diffusivities in a single column from the integrated energetics +! planetary boundary layer (ePBL) model. It assumes that heating, cooling and freshwater fluxes +! have already been applied. All calculations are done implicitly, and there +! is no stability limit on the time step. +! +! For each interior interface, first discard the TKE to account for mixing +! of shortwave radiation through the next denser cell. Next drive mixing based +! on the local? values of ustar + wstar, subject to available energy. This +! step sets the value of Kd(K). Any remaining energy is then subject to decay +! before being handed off to the next interface. mech_TKE and conv_PErel are treated +! separately for the purposes of decay, but are used proportionately to drive +! mixing. + + ! Local variables + real, dimension(SZK_(GV)+1) :: & + pres_Z, & ! Interface pressures with a rescaling factor to convert interface height + ! movements into changes in column potential energy [R Z2 T-2 ~> kg m-1 s-2]. + hb_hs ! The distance from the bottom over the thickness of the + ! water column [nondim]. + real :: mech_TKE ! The mechanically generated turbulent kinetic energy + ! available for mixing over a time step [R Z3 T-2 ~> J m-2]. + real :: conv_PErel ! The potential energy that has been convectively released + ! during this timestep [R Z3 T-2 ~> J m-2]. A portion nstar_FC + ! of conv_PErel is available to drive mixing. + real :: htot ! The total thickness of the layers above an interface [H ~> m or kg m-2]. + real :: dztot ! The total depth of the layers above an interface [Z ~> m]. + real :: uhtot ! The depth integrated zonal velocities in the layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1] + real :: vhtot ! The depth integrated meridional velocities in the layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Idecay_len_TKE ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. + real :: dz_sum ! The total thickness of the water column [Z ~> m]. + + real, dimension(SZK_(GV)) :: & + dT_to_dColHt, & ! Partial derivative of the total column height with the temperature changes + ! within a layer [Z C-1 ~> m degC-1]. + dS_to_dColHt, & ! Partial derivative of the total column height with the salinity changes + ! within a layer [Z S-1 ~> m ppt-1]. + dT_to_dPE, & ! Partial derivatives of column potential energy with the temperature + ! changes within a layer, in [R Z3 T-2 C-1 ~> J m-2 degC-1]. + dS_to_dPE, & ! Partial derivatives of column potential energy with the salinity changes + ! within a layer, in [R Z3 T-2 S-1 ~> J m-2 ppt-1]. + dT_to_dColHt_a, & ! Partial derivative of the total column height with the temperature changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column [Z C-1 ~> m degC-1]. + dS_to_dColHt_a, & ! Partial derivative of the total column height with the salinity changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column [Z S-1 ~> m ppt-1]. + dT_to_dPE_a, & ! Partial derivatives of column potential energy with the temperature changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column [R Z3 T-2 C-1 ~> J m-2 degC-1]. + dS_to_dPE_a, & ! Partial derivative of column potential energy with the salinity changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column [R Z3 T-2 S-1 ~> J m-2 ppt-1]. + c1, & ! c1 is used by the tridiagonal solver [nondim]. + Te, & ! Estimated final values of T in the column [C ~> degC]. + Se, & ! Estimated final values of S in the column [S ~> ppt]. + dTe, & ! Running (1-way) estimates of temperature change [C ~> degC]. + dSe, & ! Running (1-way) estimates of salinity change [S ~> ppt]. + Th_a, & ! An effective temperature times a thickness in the layer above, including implicit + ! mixing effects with other yet higher layers [C H ~> degC m or degC kg m-2]. + Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit + ! mixing effects with other yet higher layers [S H ~> ppt m or ppt kg m-2]. + Th_b, & ! An effective temperature times a thickness in the layer below, including implicit + ! mixing effects with other yet lower layers [C H ~> degC m or degC kg m-2]. + Sh_b ! An effective salinity times a thickness in the layer below, including implicit + ! mixing effects with other yet lower layers [S H ~> ppt m or ppt kg m-2]. + real, dimension(SZK_(GV)+1) :: & + MixLen_shape, & ! A nondimensional shape factor for the mixing length that + ! gives it an appropriate asymptotic value at the bottom of + ! the boundary layer [nondim]. + h_dz_int, & ! The ratio of the layer thicknesses over the vertical distances + ! across the layers surrounding an interface [H Z-1 ~> nondim or kg m-3] + Kddt_h ! The diapycnal diffusivity times a timestep divided by the + ! average thicknesses around a layer [H ~> m or kg m-2]. + real :: b1 ! b1 is inverse of the pivot used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: hp_a ! An effective pivot thickness of the layer including the effects + ! of coupling with layers above [H ~> m or kg m-2]. This is the first term + ! in the denominator of b1 in a downward-oriented tridiagonal solver. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + real :: dMass ! The mass per unit area within a layer [Z R ~> kg m-2]. + real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> Pa = J m-3]. + real :: dMKE_max ! The maximum amount of mean kinetic energy that could be + ! converted to turbulent kinetic energy if the velocity in + ! the layer below an interface were homogenized with all of + ! the water above the interface [R Z3 T-2 ~> J m-2]. + real :: MKE2_Hharm ! Twice the inverse of the harmonic mean of the thickness + ! of a layer and the thickness of the water above, used in + ! the MKE conversion equation [H-1 ~> m-1 or m2 kg-1]. + + real :: dt_h ! The timestep divided by the averages of the vertical distances around + ! a layer [T Z-1 ~> s m-1]. + real :: dz_bot ! The distance from the bottom [Z ~> m]. + real :: dz_rsum ! The running sum of dz from the top [Z ~> m]. + real :: I_dzsum ! The inverse of dz_sum [Z-1 ~> m-1]. + real :: I_MLD ! The inverse of the current value of MLD [Z-1 ~> m-1]. + real :: dz_tt ! The distance from the surface or up to the next interface + ! that did not exhibit turbulent mixing from this scheme plus + ! a surface mixing roughness length given by dz_tt_min [Z ~> m]. + real :: dz_tt_min ! A surface roughness length [Z ~> m]. + + real :: C1_3 ! = 1/3 [nondim] + real :: vstar ! An in-situ turbulent velocity [Z T-1 ~> m s-1]. + real :: mstar_total ! The value of mstar used in ePBL [nondim] + real :: mstar_LT ! An addition to mstar due to Langmuir turbulence [nondim] (output for diagnostic) + real :: MLD_output ! The mixed layer depth output from this routine [Z ~> m] + real :: LA ! The value of the Langmuir number [nondim] + real :: LAmod ! The modified Langmuir number by convection [nondim] + real :: hbs_here ! The local minimum of hb_hs and MixLen_shape [nondim] + real :: nstar_FC ! The fraction of conv_PErel that can be converted to mixing [nondim]. + real :: TKE_reduc ! The fraction by which TKE and other energy fields are + ! reduced to support mixing [nondim]. between 0 and 1. + real :: tot_TKE ! The total TKE available to support mixing at interface K [R Z3 T-2 ~> J m-2]. + real :: TKE_here ! The total TKE at this point in the algorithm [R Z3 T-2 ~> J m-2]. + real :: dT_km1_t2 ! A diffusivity-independent term related to the temperature + ! change in the layer above the interface [C ~> degC]. + real :: dS_km1_t2 ! A diffusivity-independent term related to the salinity + ! change in the layer above the interface [S ~> ppt]. + real :: dTe_term ! A diffusivity-independent term related to the temperature + ! change in the layer below the interface [C H ~> degC m or degC kg m-2]. + real :: dSe_term ! A diffusivity-independent term related to the salinity + ! change in the layer above the interface [S H ~> ppt m or ppt kg m-2]. + real :: dTe_t2 ! A part of dTe_term [C H ~> degC m or degC kg m-2]. + real :: dSe_t2 ! A part of dSe_term [S H ~> ppt m or ppt kg m-2]. + real :: dPE_conv ! The convective change in column potential energy [R Z3 T-2 ~> J m-2]. + real :: MKE_src ! The mean kinetic energy source of TKE due to Kddt_h(K) [R Z3 T-2 ~> J m-2]. + real :: dMKE_src_dK ! The partial derivative of MKE_src with Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. + real :: Kd_guess0 ! A first guess of the diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: PE_chg_g0 ! The potential energy change when Kd is Kd_guess0 [R Z3 T-2 ~> J m-2] + real :: Kddt_h_g0 ! The first guess diapycnal diffusivity times a timestep divided + ! by the average thicknesses around a layer [H ~> m or kg m-2]. + real :: PE_chg_max ! The maximum PE change for very large values of Kddt_h(K) [R Z3 T-2 ~> J m-2]. + real :: dPEc_dKd_Kd0 ! The partial derivative of PE change with Kddt_h(K) + ! for very small values of Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. + real :: PE_chg ! The change in potential energy due to mixing at an + ! interface [R Z3 T-2 ~> J m-2], positive for the column increasing + ! in potential energy (i.e., consuming TKE). + real :: TKE_left ! The amount of turbulent kinetic energy left for the most + ! recent guess at Kddt_h(K) [R Z3 T-2 ~> J m-2]. + real :: dPEc_dKd ! The partial derivative of PE_chg with Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. + real :: TKE_left_min, TKE_left_max ! Maximum and minimum values of TKE_left [R Z3 T-2 ~> J m-2]. + real :: Kddt_h_max, Kddt_h_min ! Maximum and minimum values of Kddt_h(K) [H ~> m or kg m-2]. + real :: Kddt_h_guess ! A guess at the value of Kddt_h(K) [H ~> m or kg m-2]. + real :: Kddt_h_next ! The next guess at the value of Kddt_h(K) [H ~> m or kg m-2]. + real :: dKddt_h ! The change between guesses at Kddt_h(K) [H ~> m or kg m-2]. + real :: dKddt_h_Newt ! The change between guesses at Kddt_h(K) with Newton's method [H ~> m or kg m-2]. + real :: Kddt_h_newt ! The Newton's method next guess for Kddt_h(K) [H ~> m or kg m-2]. + real :: exp_kh ! The nondimensional decay of TKE across a layer [nondim]. + real :: vstar_unit_scale ! A unit conversion factor for turbulent velocities [Z T-1 s m-1 ~> 1] + logical :: use_Newt ! Use Newton's method for the next guess at Kddt_h(K). + logical :: convectively_stable ! If true the water column is convectively stable at this interface. + logical :: sfc_connected ! If true the ocean is actively turbulent from the present + ! interface all the way up to the surface. + logical :: sfc_disconnect ! If true, any turbulence has become disconnected + ! from the surface. + + ! The following is only used for diagnostics. + real :: I_dtdiag ! = 1.0 / dt [T-1 ~> s-1]. + + !---------------------------------------------------------------------- + !/BGR added Aug24,2016 for adding iteration to get boundary layer depth + ! - needed to compute new mixing length. + real :: MLD_guess, MLD_found ! Mixing Layer depth guessed/found for iteration [Z ~> m] + real :: min_MLD, max_MLD ! Iteration bounds on MLD [Z ~> m], which are adjusted at each step + ! - These are initialized based on surface/bottom + ! 1. The iteration guesses a value (possibly from prev step or neighbor). + ! 2. The iteration checks if value is converged, too shallow, or too deep. + ! 3. Based on result adjusts the Max/Min and searches through the water column. + ! - If using an accurate guess the iteration is very quick (e.g. if MLD doesn't + ! change over timestep). Otherwise it takes 5-10 passes, but has a high + ! convergence rate. Other iteration may be tried, but this method seems to + ! fail very rarely and the added cost is likely not significant. + ! Additionally, when it fails to converge it does so in a reasonable + ! manner giving a usable guess. When it does fail, it is due to convection + ! within the boundary layer. Likely, a new method e.g. surface_disconnect, + ! can improve this. + real :: dMLD_min ! The change in diagnosed mixed layer depth when the guess is min_MLD [Z ~> m] + real :: dMLD_max ! The change in diagnosed mixed layer depth when the guess is max_MLD [Z ~> m] + logical :: OBL_converged ! Flag for convergence of MLD + integer :: OBL_it ! Iteration counter + + real :: Surface_Scale ! Surface decay scale for vstar [nondim] + logical :: calc_Te ! If true calculate the expected final temperature and salinity values. + logical :: debug ! This is used as a hard-coded value for debugging. + + ! The following arrays are used only for debugging purposes. + real :: dPE_debug ! An estimate of the potential energy change [R Z3 T-2 ~> J m-2] + real :: mixing_debug ! An estimate of the rate of change of potential energy due to mixing [R Z3 T-3 ~> W m-2] + real, dimension(20) :: TKE_left_itt ! The value of TKE_left after each iteration [R Z3 T-2 ~> J m-2] + real, dimension(20) :: PE_chg_itt ! The value of PE_chg after each iteration [R Z3 T-2 ~> J m-2] + real, dimension(20) :: Kddt_h_itt ! The value of Kddt_h_guess after each iteration [H ~> m or kg m-2] + real, dimension(20) :: dPEa_dKd_itt ! The value of dPEc_dKd after each iteration [R Z3 T-2 H-1 ~> J m-3 or J kg-1] + real, dimension(20) :: MKE_src_itt ! The value of MKE_src after each iteration [R Z3 T-2 ~> J m-2] + real, dimension(SZK_(GV)) :: mech_TKE_k ! The mechanically generated turbulent kinetic energy + ! available for mixing over a time step for each layer [R Z3 T-2 ~> J m-2]. + real, dimension(SZK_(GV)) :: conv_PErel_k ! The potential energy that has been convectively released + ! during this timestep for each layer [R Z3 T-2 ~> J m-2]. + real, dimension(SZK_(GV)) :: nstar_k ! The fraction of conv_PErel that can be converted to mixing + ! for each layer [nondim]. + real, dimension(SZK_(GV)) :: dT_expect !< Expected temperature changes [C ~> degC] + real, dimension(SZK_(GV)) :: dS_expect !< Expected salinity changes [S ~> ppt] + integer, dimension(SZK_(GV)) :: num_itts + + integer :: k, nz, itt, max_itt + + nz = GV%ke + + debug = .false. ! Change this hard-coded value for debugging. + calc_Te = (debug .or. (.not.CS%orig_PE_calc)) + + h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff + + C1_3 = 1.0 / 3.0 + I_dtdiag = 1.0 / dt + max_itt = 20 + + dz_tt_min = 0.0 + if (CS%answer_date < 20240101) vstar_unit_scale = US%m_to_Z * US%T_to_s + + MLD_guess = MLD_io + +! Determine the initial mech_TKE and conv_PErel, including the energy required +! to mix surface heating through the topmost cell, the energy released by mixing +! surface cooling & brine rejection down through the topmost cell, and +! 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 K=1,nz+1 ; Kd(K) = 0.0 ; enddo + + pres_Z(1) = 0.0 + do k=1,nz + dMass = GV%H_to_RZ * h(k) + dPres = US%L_to_Z**2 * GV%g_Earth * dMass + dT_to_dPE(k) = (dMass * (pres_Z(K) + 0.5*dPres)) * dSV_dT(k) + dS_to_dPE(k) = (dMass * (pres_Z(K) + 0.5*dPres)) * dSV_dS(k) + dT_to_dColHt(k) = dMass * dSV_dT(k) + dS_to_dColHt(k) = dMass * dSV_dS(k) + + pres_Z(K+1) = pres_Z(K) + dPres + enddo + + ! Determine the total thickness (dz_sum) and the fractional distance from the bottom (hb_hs). + dz_sum = dz_neglect ; do k=1,nz ; dz_sum = dz_sum + dz(k) ; enddo + I_dzsum = 0.0 ; if (dz_sum > 0.0) I_dzsum = 1.0 / dz_sum + dz_bot = 0.0 + hb_hs(nz+1) = 0.0 + do k=nz,1,-1 + dz_bot = dz_bot + dz(k) + hb_hs(K) = dz_bot * I_dzsum + enddo + + MLD_output = dz(1) + + !/The following lines are for the iteration over MLD + ! max_MLD will initialized as ocean bottom depth + max_MLD = 0.0 ; do k=1,nz ; max_MLD = max_MLD + dz(k) ; enddo + ! min_MLD will be initialized to 0. + min_MLD = 0.0 + ! Set values of the wrong signs to indicate that these changes are not based on valid estimates + dMLD_min = -1.0*US%m_to_Z ; dMLD_max = 1.0*US%m_to_Z + + ! If no first guess is provided for MLD, try the middle of the water column + if (MLD_guess <= min_MLD) MLD_guess = 0.5 * (min_MLD + max_MLD) + + if (GV%Boussinesq) then + do K=1,nz+1 ; h_dz_int(K) = GV%Z_to_H ; enddo + else + h_dz_int(1) = (h(1) + h_neglect) / (dz(1) + dz_neglect) + do K=2,nz + h_dz_int(K) = (h(k-1) + h(k) + h_neglect) / (dz(k-1) + dz(k) + dz_neglect) + enddo + h_dz_int(nz+1) = (h(nz) + h_neglect) / (dz(nz) + dz_neglect) + endif + + ! Iterate to determine a converged EPBL depth. + OBL_converged = .false. + do OBL_it=1,CS%Max_MLD_Its + + if (.not. OBL_converged) then + ! If not using MLD_Iteration flag loop to only execute once. + if (.not.CS%Use_MLD_iteration) OBL_converged = .true. + + if (debug) then ; mech_TKE_k(:) = 0.0 ; conv_PErel_k(:) = 0.0 ; endif + + ! Reset ML_depth + MLD_output = dz(1) + sfc_connected = .true. + + !/ Here we get MStar, which is the ratio of convective TKE driven mixing to UStar**3 + if (CS%Use_LT) then + call get_Langmuir_Number(LA, G, GV, US, abs(MLD_guess), u_star_mean, i, j, dz, Waves, & + U_H=u, V_H=v) + call find_mstar(CS, US, B_flux, u_star, MLD_guess, absf, & + MStar_total, Langmuir_Number=La, Convect_Langmuir_Number=LAmod,& + mstar_LT=mstar_LT) + else + call find_mstar(CS, US, B_flux, u_star, MLD_guess, absf, mstar_total) + endif + + !/ Apply MStar to get mech_TKE + if ((CS%answer_date < 20190101) .and. (CS%mstar_scheme==Use_Fixed_MStar)) then + mech_TKE = (dt*MSTAR_total*GV%Rho0) * u_star**3 + else + mech_TKE = MSTAR_total * mech_TKE_in + ! mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) + endif + ! stochastically perturb mech_TKE in the UFS + if (present(TKE_gen_stoch)) mech_TKE = mech_TKE*TKE_gen_stoch + + if (CS%TKE_diagnostics) then + eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 + eCD%dTKE_MKE = 0.0 ; eCD%dTKE_mech_decay = 0.0 ; eCD%dTKE_conv_decay = 0.0 + + eCD%dTKE_wind = mech_TKE * I_dtdiag + if (TKE_forcing(1) <= 0.0) then + eCD%dTKE_forcing = max(-mech_TKE, TKE_forcing(1)) * I_dtdiag + ! eCD%dTKE_unbalanced = min(0.0, TKE_forcing(1) + mech_TKE) * I_dtdiag + else + eCD%dTKE_forcing = CS%nstar*TKE_forcing(1) * I_dtdiag + ! eCD%dTKE_unbalanced = 0.0 + endif + endif + + if (TKE_forcing(1) <= 0.0) then + mech_TKE = mech_TKE + TKE_forcing(1) + if (mech_TKE < 0.0) mech_TKE = 0.0 + conv_PErel = 0.0 + else + conv_PErel = TKE_forcing(1) + endif + + + ! Store in 1D arrays for output. + do K=1,nz+1 ; mixvel(K) = 0.0 ; mixlen(K) = 0.0 ; enddo + + ! Determine the mixing shape function MixLen_shape. + if ((.not.CS%Use_MLD_iteration) .or. & + (CS%transLay_scale >= 1.0) .or. (CS%transLay_scale < 0.0) ) then + do K=1,nz+1 + MixLen_shape(K) = 1.0 + enddo + elseif (MLD_guess <= 0.0) then + if (CS%transLay_scale > 0.0) then ; do K=1,nz+1 + MixLen_shape(K) = CS%transLay_scale + enddo ; else ; do K=1,nz+1 + MixLen_shape(K) = 1.0 + enddo ; endif + else + ! Reduce the mixing length based on MLD, with a quadratic + ! expression that follows KPP. + I_MLD = 1.0 / MLD_guess + dz_rsum = 0.0 + MixLen_shape(1) = 1.0 + do K=2,nz+1 + dz_rsum = dz_rsum + dz(k-1) + if (CS%MixLenExponent==2.0) then + MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & + (max(0.0, (MLD_guess - dz_rsum)*I_MLD) )**2 ! CS%MixLenExponent + else + MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & + (max(0.0, (MLD_guess - dz_rsum)*I_MLD) )**CS%MixLenExponent + endif + enddo + endif + + Kd(1) = 0.0 ; Kddt_h(1) = 0.0 + hp_a = h(1) + dT_to_dPE_a(1) = dT_to_dPE(1) ; dT_to_dColHt_a(1) = dT_to_dColHt(1) + dS_to_dPE_a(1) = dS_to_dPE(1) ; dS_to_dColHt_a(1) = dS_to_dColHt(1) + + htot = h(1) ; dztot = dz(1) ; uhtot = u(1)*h(1) ; vhtot = v(1)*h(1) + + if (debug) then + mech_TKE_k(1) = mech_TKE ; conv_PErel_k(1) = conv_PErel + nstar_k(:) = 0.0 ; nstar_k(1) = CS%nstar ; num_itts(:) = -1 + endif + + do K=2,nz + ! Apply dissipation to the TKE, here applied as an exponential decay + ! due to 3-d turbulent energy being lost to inefficient rotational modes. + + ! There should be several different "flavors" of TKE that decay at + ! different rates. The following form is often used for mechanical + ! stirring from the surface, perhaps due to breaking surface gravity + ! waves and wind-driven turbulence. + if (GV%Boussinesq) then + Idecay_len_TKE = (CS%TKE_decay * absf / u_star) * GV%H_to_Z + else + Idecay_len_TKE = (CS%TKE_decay * absf) / (h_dz_int(K) * u_star) + endif + exp_kh = 1.0 + if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) + if (CS%TKE_diagnostics) & + eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag + if (present(TKE_diss_stoch)) then ! perturb the TKE destruction + mech_TKE = mech_TKE * (1.0 + (exp_kh-1.0) * TKE_diss_stoch) + else + mech_TKE = mech_TKE * exp_kh + endif + + ! Accumulate any convectively released potential energy to contribute + ! to wstar and to drive penetrating convection. + if (TKE_forcing(k) > 0.0) then + conv_PErel = conv_PErel + TKE_forcing(k) + if (CS%TKE_diagnostics) & + eCD%dTKE_forcing = eCD%dTKE_forcing + CS%nstar*TKE_forcing(k) * I_dtdiag + endif + + if (debug) then + mech_TKE_k(K) = mech_TKE ; conv_PErel_k(K) = conv_PErel + endif + + ! Determine the total energy + nstar_FC = CS%nstar + if (CS%nstar * conv_PErel > 0.0) then + ! Here nstar is a function of the natural Rossby number 0.2/(1+0.2/Ro), based + ! on a curve fit from the data of Wang (GRL, 2003). + ! Note: Ro = 1.0 / sqrt(0.5 * dt * Rho0 * (absf*dztot)**3 / conv_PErel) + if (GV%Boussinesq) then + nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & + sqrt(0.5 * dt * GV%Rho0 * (absf*dztot)**3 * conv_PErel)) + else + nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & + sqrt(0.5 * dt * GV%H_to_RZ * (absf**3 * (dztot**2 * htot)) * conv_PErel)) + endif + endif + + if (debug) nstar_k(K) = nstar_FC + + tot_TKE = mech_TKE + nstar_FC * conv_PErel + + ! For each interior interface, first discard the TKE to account for + ! mixing of shortwave radiation through the next denser cell. + if (TKE_forcing(k) < 0.0) then + if (TKE_forcing(k) + tot_TKE < 0.0) then + ! The shortwave requirements deplete all the energy in this layer. + if (CS%TKE_diagnostics) then + eCD%dTKE_mixing = eCD%dTKE_mixing + tot_TKE * I_dtdiag + eCD%dTKE_forcing = eCD%dTKE_forcing - tot_TKE * I_dtdiag + ! eCD%dTKE_unbalanced = eCD%dTKE_unbalanced + (TKE_forcing(k) + tot_TKE) * I_dtdiag + eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + (CS%nstar-nstar_FC) * conv_PErel * I_dtdiag + endif + tot_TKE = 0.0 ; mech_TKE = 0.0 ; conv_PErel = 0.0 + else + ! Reduce the mechanical and convective TKE proportionately. + TKE_reduc = (tot_TKE + TKE_forcing(k)) / tot_TKE + if (CS%TKE_diagnostics) then + eCD%dTKE_mixing = eCD%dTKE_mixing - TKE_forcing(k) * I_dtdiag + eCD%dTKE_forcing = eCD%dTKE_forcing + TKE_forcing(k) * I_dtdiag + eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + & + (1.0-TKE_reduc)*(CS%nstar-nstar_FC) * conv_PErel * I_dtdiag + endif + tot_TKE = TKE_reduc*tot_TKE ! = tot_TKE + TKE_forcing(k) + mech_TKE = TKE_reduc*mech_TKE + conv_PErel = TKE_reduc*conv_PErel + endif + endif + + ! Precalculate some temporary expressions that are independent of Kddt_h(K). + if (CS%orig_PE_calc) then + if (K==2) then + dTe_t2 = 0.0 ; dSe_t2 = 0.0 + else + dTe_t2 = Kddt_h(K-1) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) + dSe_t2 = Kddt_h(K-1) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) + endif + endif + dt_h = dt / max(0.5*(dz(k-1)+dz(k)), 1e-15*dz_sum) + + ! This tests whether the layers above and below this interface are in + ! a convectively stable configuration, without considering any effects of + ! mixing at higher interfaces. It is an approximation to the more + ! complete test dPEc_dKd_Kd0 >= 0.0, that would include the effects of + ! mixing across interface K-1. The dT_to_dColHt here are effectively + ! mass-weighted estimates of dSV_dT. + Convectively_stable = ( 0.0 <= & + ( (dT_to_dColHt(k) + dT_to_dColHt(k-1) ) * (T0(k-1)-T0(k)) + & + (dS_to_dColHt(k) + dS_to_dColHt(k-1) ) * (S0(k-1)-S0(k)) ) ) + + if ((mech_TKE + conv_PErel) <= 0.0 .and. Convectively_stable) then + ! Energy is already exhausted, so set Kd = 0 and cycle or exit? + tot_TKE = 0.0 ; mech_TKE = 0.0 ; conv_PErel = 0.0 + Kd(K) = 0.0 ; Kddt_h(K) = 0.0 + sfc_disconnect = .true. + ! if (.not.debug) exit + + ! The estimated properties for layer k-1 can be calculated, using + ! greatly simplified expressions when Kddt_h = 0. This enables the + ! tridiagonal solver for the whole column to be completed for debugging + ! purposes, and also allows for something akin to convective adjustment + ! in unstable interior regions? + b1 = 1.0 / hp_a + c1(K) = 0.0 + if (CS%orig_PE_calc) then + dTe(k-1) = b1 * ( dTe_t2 ) + dSe(k-1) = b1 * ( dSe_t2 ) + endif + + hp_a = h(k) + dT_to_dPE_a(k) = dT_to_dPE(k) + dS_to_dPE_a(k) = dS_to_dPE(k) + dT_to_dColHt_a(k) = dT_to_dColHt(k) + dS_to_dColHt_a(k) = dS_to_dColHt(k) + + else ! tot_TKE > 0.0 or this is a potentially convectively unstable profile. + sfc_disconnect = .false. + + ! Precalculate some more temporary expressions that are independent of + ! Kddt_h(K). + if (CS%orig_PE_calc) then + if (K==2) then + dT_km1_t2 = (T0(k)-T0(k-1)) + dS_km1_t2 = (S0(k)-S0(k-1)) + else + dT_km1_t2 = (T0(k)-T0(k-1)) - & + (Kddt_h(K-1) / hp_a) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) + dS_km1_t2 = (S0(k)-S0(k-1)) - & + (Kddt_h(K-1) / hp_a) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) + endif + dTe_term = dTe_t2 + hp_a * (T0(k-1)-T0(k)) + dSe_term = dSe_t2 + hp_a * (S0(k-1)-S0(k)) + else + if (K<=2) then + Th_a(k-1) = h(k-1) * T0(k-1) ; Sh_a(k-1) = h(k-1) * S0(k-1) + else + Th_a(k-1) = h(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) + Sh_a(k-1) = h(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) + endif + Th_b(k) = h(k) * T0(k) ; Sh_b(k) = h(k) * S0(k) + endif + + ! Using Pr=1 and the diffusivity at the bottom interface (once it is + ! known), determine how much resolved mean kinetic energy (MKE) will be + ! extracted within a timestep and add a fraction CS%MKE_to_TKE_effic of + ! this to the mTKE budget available for mixing in the next layer. + + if ((CS%MKE_to_TKE_effic > 0.0) .and. (htot*h(k) > 0.0)) then + ! This is the energy that would be available from homogenizing the + ! velocities between layer k and the layers above. + dMKE_max = (US%L_to_Z**2*GV%H_to_RZ * CS%MKE_to_TKE_effic) * 0.5 * & + (h(k) / ((htot + h(k))*htot)) * & + ((uhtot-u(k)*htot)**2 + (vhtot-v(k)*htot)**2) + ! A fraction (1-exp(Kddt_h*MKE2_Hharm)) of this energy would be + ! extracted by mixing with a finite viscosity. + MKE2_Hharm = (htot + h(k) + 2.0*h_neglect) / & + ((htot+h_neglect) * (h(k)+h_neglect)) + else + dMKE_max = 0.0 + MKE2_Hharm = 0.0 + endif + + ! At this point, Kddt_h(K) will be unknown because its value may depend + ! on how much energy is available. mech_TKE might be negative due to + ! contributions from TKE_forced. + dz_tt = dztot + dz_tt_min + TKE_here = mech_TKE + CS%wstar_ustar_coef*conv_PErel + if (TKE_here > 0.0) then + if (CS%answer_date < 20240101) then + if (CS%wT_scheme==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac * vstar_unit_scale * (SpV_dt(K)*TKE_here)**C1_3 + elseif (CS%wT_scheme==wT_from_RH18) then + Surface_Scale = max(0.05, 1.0 - dztot / MLD_guess) + vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & + vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*SpV_dt(K))**C1_3) + endif + else + if (CS%wT_scheme==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac * cuberoot(SpV_dt(K)*TKE_here) + elseif (CS%wT_scheme==wT_from_RH18) then + Surface_Scale = max(0.05, 1.0 - dztot / MLD_guess) + vstar = (CS%vstar_scale_fac * Surface_Scale) * ( CS%vstar_surf_fac*u_star + & + cuberoot((CS%wstar_ustar_coef*conv_PErel) * SpV_dt(K)) ) + endif + endif + hbs_here = min(hb_hs(K), MixLen_shape(K)) + mixlen(K) = MAX(CS%min_mix_len, ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar)) + !Note setting Kd_guess0 to vstar * CS%vonKar * mixlen(K) here will + ! change the answers. Therefore, skipping that. + if (.not.CS%Use_MLD_iteration) then + Kd_guess0 = (h_dz_int(K)*vstar) * CS%vonKar * ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar) + else + Kd_guess0 = (h_dz_int(K)*vstar) * CS%vonKar * mixlen(K) + endif + else + vstar = 0.0 ; Kd_guess0 = 0.0 + endif + mixvel(K) = vstar ! Track vstar + Kddt_h_g0 = Kd_guess0 * dt_h + + if (CS%orig_PE_calc) then + call find_PE_chg_orig(Kddt_h_g0, h(k), hp_a, dTe_term, dSe_term, & + dT_km1_t2, dS_km1_t2, dT_to_dPE(k), dS_to_dPE(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & + pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & + dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + PE_chg=PE_chg_g0, dPE_max=PE_chg_max, dPEc_dKd_0=dPEc_dKd_Kd0 ) + else + call find_PE_chg(0.0, Kddt_h_g0, hp_a, h(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE(k), dS_to_dPE(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt(k), dS_to_dColHt(k), & + PE_chg=PE_chg_g0, dPE_max=PE_chg_max, dPEc_dKd_0=dPEc_dKd_Kd0 ) + endif + + MKE_src = dMKE_max*(1.0 - exp(-Kddt_h_g0 * MKE2_Hharm)) + + ! This block checks out different cases to determine Kd at the present interface. + if ((PE_chg_g0 < 0.0) .or. ((vstar == 0.0) .and. (dPEc_dKd_Kd0 < 0.0))) then + ! This column is convectively unstable. + if (PE_chg_max <= 0.0) then + ! Does MKE_src need to be included in the calculation of vstar here? + TKE_here = mech_TKE + CS%wstar_ustar_coef*(conv_PErel-PE_chg_max) + if (TKE_here > 0.0) then + if (CS%answer_date < 20240101) then + if (CS%wT_scheme==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac * vstar_unit_scale * (SpV_dt(K)*TKE_here)**C1_3 + elseif (CS%wT_scheme==wT_from_RH18) then + Surface_Scale = max(0.05, 1. - dztot / MLD_guess) + vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & + vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*SpV_dt(K))**C1_3) + endif + else + if (CS%wT_scheme==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac * cuberoot(SpV_dt(K)*TKE_here) + elseif (CS%wT_scheme==wT_from_RH18) then + Surface_Scale = max(0.05, 1. - dztot / MLD_guess) + vstar = (CS%vstar_scale_fac * Surface_Scale) * ( CS%vstar_surf_fac*u_star + & + cuberoot((CS%wstar_ustar_coef*conv_PErel) * SpV_dt(K)) ) + endif + endif + hbs_here = min(hb_hs(K), MixLen_shape(K)) + mixlen(K) = max(CS%min_mix_len, ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar)) + if (.not.CS%Use_MLD_iteration) then + ! Note again (as prev) that using mixlen here + ! instead of redoing the computation will change answers... + Kd(K) = (h_dz_int(K)*vstar) * CS%vonKar * ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar) + else + Kd(K) = (h_dz_int(K)*vstar) * CS%vonKar * mixlen(K) + endif + else + vstar = 0.0 ; Kd(K) = 0.0 + endif + mixvel(K) = vstar + + if (CS%orig_PE_calc) then + call find_PE_chg_orig(Kd(K)*dt_h, h(k), hp_a, dTe_term, dSe_term, & + dT_km1_t2, dS_km1_t2, dT_to_dPE(k), dS_to_dPE(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & + pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & + dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + PE_chg=dPE_conv) + else + call find_PE_chg(0.0, Kd(K)*dt_h, hp_a, h(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE(k), dS_to_dPE(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt(k), dS_to_dColHt(k), & + PE_chg=dPE_conv) + endif + ! Should this be iterated to convergence for Kd? + if (dPE_conv > 0.0) then + Kd(K) = Kd_guess0 ; dPE_conv = PE_chg_g0 + else + MKE_src = dMKE_max*(1.0 - exp(-(Kd(K)*dt_h) * MKE2_Hharm)) + endif + else + ! The energy change does not vary monotonically with Kddt_h. Find the maximum? + Kd(K) = Kd_guess0 ; dPE_conv = PE_chg_g0 + endif + + conv_PErel = conv_PErel - dPE_conv + mech_TKE = mech_TKE + MKE_src + if (CS%TKE_diagnostics) then + eCD%dTKE_conv = eCD%dTKE_conv - CS%nstar*dPE_conv * I_dtdiag + eCD%dTKE_MKE = eCD%dTKE_MKE + MKE_src * I_dtdiag + endif + if (sfc_connected) then + MLD_output = MLD_output + dz(k) + endif + + Kddt_h(K) = Kd(K) * dt_h + elseif (tot_TKE + (MKE_src - PE_chg_g0) >= 0.0) then + ! This column is convectively stable and there is energy to support the suggested + ! mixing. Keep that estimate. + Kd(K) = Kd_guess0 + Kddt_h(K) = Kddt_h_g0 + + ! Reduce the mechanical and convective TKE proportionately. + tot_TKE = tot_TKE + MKE_src + TKE_reduc = 0.0 ! tot_TKE could be 0 if Convectively_stable is false. + if (tot_TKE > 0.0) TKE_reduc = (tot_TKE - PE_chg_g0) / tot_TKE + if (CS%TKE_diagnostics) then + eCD%dTKE_mixing = eCD%dTKE_mixing - PE_chg_g0 * I_dtdiag + eCD%dTKE_MKE = eCD%dTKE_MKE + MKE_src * I_dtdiag + eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + & + (1.0-TKE_reduc)*(CS%nstar-nstar_FC) * conv_PErel * I_dtdiag + endif + tot_TKE = TKE_reduc*tot_TKE + mech_TKE = TKE_reduc*(mech_TKE + MKE_src) + conv_PErel = TKE_reduc*conv_PErel + if (sfc_connected) then + MLD_output = MLD_output + dz(k) + endif + + elseif (tot_TKE == 0.0) then + ! This can arise if nstar_FC = 0, but it is not common. + Kd(K) = 0.0 ; Kddt_h(K) = 0.0 + tot_TKE = 0.0 ; conv_PErel = 0.0 ; mech_TKE = 0.0 + sfc_disconnect = .true. + else + ! There is not enough energy to support the mixing, so reduce the + ! diffusivity to what can be supported. + Kddt_h_max = Kddt_h_g0 ; Kddt_h_min = 0.0 + TKE_left_max = tot_TKE + (MKE_src - PE_chg_g0) + TKE_left_min = tot_TKE + + ! As a starting guess, take the minimum of a false position estimate + ! and a Newton's method estimate starting from Kddt_h = 0.0. + Kddt_h_guess = tot_TKE * Kddt_h_max / max( PE_chg_g0 - MKE_src, & + Kddt_h_max * (dPEc_dKd_Kd0 - dMKE_max * MKE2_Hharm) ) + ! The above expression is mathematically the same as the following + ! except it is not susceptible to division by zero when + ! dPEc_dKd_Kd0 = dMKE_max = 0 . + ! Kddt_h_guess = tot_TKE * min( Kddt_h_max / (PE_chg_g0 - MKE_src), & + ! 1.0 / (dPEc_dKd_Kd0 - dMKE_max * MKE2_Hharm) ) + if (debug) then + TKE_left_itt(:) = 0.0 ; dPEa_dKd_itt(:) = 0.0 ; PE_chg_itt(:) = 0.0 + MKE_src_itt(:) = 0.0 ; Kddt_h_itt(:) = 0.0 + endif + do itt=1,max_itt + if (CS%orig_PE_calc) then + call find_PE_chg_orig(Kddt_h_guess, h(k), hp_a, dTe_term, dSe_term, & + dT_km1_t2, dS_km1_t2, dT_to_dPE(k), dS_to_dPE(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & + pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & + dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + PE_chg=PE_chg, dPEc_dKd=dPEc_dKd ) + else + call find_PE_chg(0.0, Kddt_h_guess, hp_a, h(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE(k), dS_to_dPE(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt(k), dS_to_dColHt(k), & + PE_chg=dPE_conv, dPEc_dKd=dPEc_dKd) + endif + MKE_src = dMKE_max * (1.0 - exp(-MKE2_Hharm * Kddt_h_guess)) + dMKE_src_dK = dMKE_max * MKE2_Hharm * exp(-MKE2_Hharm * Kddt_h_guess) + + TKE_left = tot_TKE + (MKE_src - PE_chg) + if (debug .and. itt<=20) then + Kddt_h_itt(itt) = Kddt_h_guess ; MKE_src_itt(itt) = MKE_src + PE_chg_itt(itt) = PE_chg ; dPEa_dKd_itt(itt) = dPEc_dKd + TKE_left_itt(itt) = TKE_left + endif + ! Store the new bounding values, bearing in mind that min and max + ! here refer to Kddt_h and dTKE_left/dKddt_h < 0: + if (TKE_left >= 0.0) then + Kddt_h_min = Kddt_h_guess ; TKE_left_min = TKE_left + else + Kddt_h_max = Kddt_h_guess ; TKE_left_max = TKE_left + endif + + ! Try to use Newton's method, but if it would go outside the bracketed + ! values use the false-position method instead. + use_Newt = .true. + if (dPEc_dKd - dMKE_src_dK <= 0.0) then + use_Newt = .false. + else + dKddt_h_Newt = TKE_left / (dPEc_dKd - dMKE_src_dK) + Kddt_h_Newt = Kddt_h_guess + dKddt_h_Newt + if ((Kddt_h_Newt > Kddt_h_max) .or. (Kddt_h_Newt < Kddt_h_min)) & + use_Newt = .false. + endif + + if (use_Newt) then + Kddt_h_next = Kddt_h_guess + dKddt_h_Newt + dKddt_h = dKddt_h_Newt + else + Kddt_h_next = (TKE_left_max * Kddt_h_min - Kddt_h_max * TKE_left_min) / & + (TKE_left_max - TKE_left_min) + dKddt_h = Kddt_h_next - Kddt_h_guess + endif + + if ((abs(dKddt_h) < 1e-9*Kddt_h_guess) .or. (itt==max_itt)) then + ! Use the old value so that the energy calculation does not need to be repeated. + if (debug) num_itts(K) = itt + exit + else + Kddt_h_guess = Kddt_h_next + endif + enddo ! Inner iteration loop on itt. + Kd(K) = Kddt_h_guess / dt_h ; Kddt_h(K) = Kd(K) * dt_h + + ! All TKE should have been consumed. + if (CS%TKE_diagnostics) then + eCD%dTKE_mixing = eCD%dTKE_mixing - (tot_TKE + MKE_src) * I_dtdiag + eCD%dTKE_MKE = eCD%dTKE_MKE + MKE_src * I_dtdiag + eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + & + (CS%nstar-nstar_FC) * conv_PErel * I_dtdiag + endif + + if (sfc_connected) MLD_output = MLD_output + (PE_chg / (PE_chg_g0)) * dz(k) + + tot_TKE = 0.0 ; mech_TKE = 0.0 ; conv_PErel = 0.0 + sfc_disconnect = .true. + endif ! End of convective or forced mixing cases to determine Kd. + + Kddt_h(K) = Kd(K) * dt_h + ! At this point, the final value of Kddt_h(K) is known, so the + ! estimated properties for layer k-1 can be calculated. + b1 = 1.0 / (hp_a + Kddt_h(K)) + c1(K) = Kddt_h(K) * b1 + if (CS%orig_PE_calc) then + dTe(k-1) = b1 * ( Kddt_h(K)*(T0(k)-T0(k-1)) + dTe_t2 ) + dSe(k-1) = b1 * ( Kddt_h(K)*(S0(k)-S0(k-1)) + dSe_t2 ) + endif + + hp_a = h(k) + (hp_a * b1) * Kddt_h(K) + dT_to_dPE_a(k) = dT_to_dPE(k) + c1(K)*dT_to_dPE_a(k-1) + dS_to_dPE_a(k) = dS_to_dPE(k) + c1(K)*dS_to_dPE_a(k-1) + dT_to_dColHt_a(k) = dT_to_dColHt(k) + c1(K)*dT_to_dColHt_a(k-1) + dS_to_dColHt_a(k) = dS_to_dColHt(k) + c1(K)*dS_to_dColHt_a(k-1) + + endif ! tot_TKT > 0.0 branch. Kddt_h(K) has been set. + + ! Store integrated velocities and thicknesses for MKE conversion calculations. + if (sfc_disconnect) then + ! There is no turbulence at this interface, so zero out the running sums. + uhtot = u(k)*h(k) + vhtot = v(k)*h(k) + htot = h(k) + dztot = dz(k) + sfc_connected = .false. + else + uhtot = uhtot + u(k)*h(k) + vhtot = vhtot + v(k)*h(k) + htot = htot + h(k) + dztot = dztot + dz(k) + endif + + if (calc_Te) then + if (k==2) then + Te(1) = b1*(h(1)*T0(1)) + Se(1) = b1*(h(1)*S0(1)) + else + Te(k-1) = b1 * (h(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) + Se(k-1) = b1 * (h(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) + endif + endif + enddo + Kd(nz+1) = 0.0 + + if (debug) then + ! Complete the tridiagonal solve for Te. + b1 = 1.0 / hp_a + Te(nz) = b1 * (h(nz) * T0(nz) + Kddt_h(nz) * Te(nz-1)) + Se(nz) = b1 * (h(nz) * S0(nz) + Kddt_h(nz) * Se(nz-1)) + dT_expect(nz) = Te(nz) - T0(nz) ; dS_expect(nz) = Se(nz) - S0(nz) + do k=nz-1,1,-1 + Te(k) = Te(k) + c1(K+1)*Te(k+1) + Se(k) = Se(k) + c1(K+1)*Se(k+1) + dT_expect(k) = Te(k) - T0(k) ; dS_expect(k) = Se(k) - S0(k) + enddo + endif + + if (debug) then + dPE_debug = 0.0 + do k=1,nz + dPE_debug = dPE_debug + (dT_to_dPE(k) * (Te(k) - T0(k)) + & + dS_to_dPE(k) * (Se(k) - S0(k))) + enddo + mixing_debug = dPE_debug * I_dtdiag + endif + k = nz ! This is here to allow a breakpoint to be set. + !/BGR + ! The following lines are used for the iteration + ! note the iteration has been altered to use the value predicted by + ! the TKE threshold (ML_DEPTH). This is because the MSTAR + ! is now dependent on the ML, and therefore the ML needs to be estimated + ! more precisely than the grid spacing. + + !New method uses ML_DEPTH as computed in ePBL routine + MLD_found = MLD_output + if (MLD_found - MLD_guess > CS%MLD_tol) then + min_MLD = MLD_guess ; dMLD_min = MLD_found - MLD_guess + elseif (abs(MLD_found - MLD_guess) < CS%MLD_tol) then + OBL_converged = .true. ! Break convergence loop + else ! We know this guess was too deep + max_MLD = MLD_guess ; dMLD_max = MLD_found - MLD_guess ! < -CS%MLD_tol + endif + + if (.not.OBL_converged) then ; if (CS%MLD_bisection) then + ! For the next pass, guess the average of the minimum and maximum values. + MLD_guess = 0.5*(min_MLD + max_MLD) + else ! Try using the false position method or the returned value instead of simple bisection. + ! Taking the occasional step with MLD_output empirically helps to converge faster. + if ((dMLD_min > 0.0) .and. (dMLD_max < 0.0) .and. (OBL_it > 2) .and. (mod(OBL_it-1,4) > 0)) then + ! Both bounds have valid change estimates and are probably in the range of possible outputs. + MLD_guess = (dMLD_min*max_MLD - dMLD_max*min_MLD) / (dMLD_min - dMLD_max) + elseif ((MLD_found > min_MLD) .and. (MLD_found < max_MLD)) then + ! The output MLD_found is an interesting guess, as it likely to bracket the true solution + ! along with the previous value of MLD_guess and to be close to the solution. + MLD_guess = MLD_found + else ! Bisect if the other guesses would be out-of-bounds. This does not happen much. + MLD_guess = 0.5*(min_MLD + max_MLD) + endif + endif ; endif + endif + if ((OBL_converged) .or. (OBL_it==CS%Max_MLD_Its)) then + if (report_avg_its) then + CS%sum_its(1) = CS%sum_its(1) + real_to_EFP(real(OBL_it)) + CS%sum_its(2) = CS%sum_its(2) + real_to_EFP(1.0) + endif + exit + endif + enddo ! Iteration loop for converged boundary layer thickness. + if (CS%Use_LT) then + eCD%LA = LA ; eCD%LAmod = LAmod ; eCD%mstar = mstar_total ; eCD%mstar_LT = mstar_LT + else + eCD%LA = 0.0 ; eCD%LAmod = 0.0 ; eCD%mstar = mstar_total ; eCD%mstar_LT = 0.0 + endif + + MLD_io = MLD_output + +end subroutine ePBL_column + +!> This subroutine calculates the change in potential energy and or derivatives +!! for several changes in an interface's diapycnal diffusivity times a timestep. +subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & + dT_to_dPE_a, dS_to_dPE_a, dT_to_dPE_b, dS_to_dPE_b, & + pres_Z, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & + PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, PE_ColHt_cor) + real, intent(in) :: Kddt_h0 !< The previously used diffusivity at an interface times + !! the time step and divided by the average of the + !! thicknesses around the interface [H ~> m or kg m-2]. + real, intent(in) :: dKddt_h !< The trial change in the diffusivity at an interface times + !! the time step and divided by the average of the + !! thicknesses around the interface [H ~> m or kg m-2]. + real, intent(in) :: hp_a !< The effective pivot thickness of the layer above the + !! interface, given by h_k plus a term that + !! is a fraction (determined from the tridiagonal solver) of + !! Kddt_h for the interface above [H ~> m or kg m-2]. + real, intent(in) :: hp_b !< The effective pivot thickness of the layer below the + !! interface, given by h_k plus a term that + !! is a fraction (determined from the tridiagonal solver) of + !! Kddt_h for the interface above [H ~> m or kg m-2]. + real, intent(in) :: Th_a !< An effective temperature times a thickness in the layer + !! above, including implicit mixing effects with other + !! yet higher layers [C H ~> degC m or degC kg m-2]. + real, intent(in) :: Sh_a !< An effective salinity times a thickness in the layer + !! above, including implicit mixing effects with other + !! yet higher layers [S H ~> ppt m or ppt kg m-2]. + real, intent(in) :: Th_b !< An effective temperature times a thickness in the layer + !! below, including implicit mixing effects with other + !! yet lower layers [C H ~> degC m or degC kg m-2]. + real, intent(in) :: Sh_b !< An effective salinity times a thickness in the layer + !! below, including implicit mixing effects with other + !! yet lower layers [S H ~> ppt m or ppt kg m-2]. + real, intent(in) :: dT_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers above [R Z3 T-2 C-1 ~> J m-2 degC-1]. + real, intent(in) :: dS_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers above [R Z3 T-2 S-1 ~> J m-2 ppt-1]. + real, intent(in) :: dT_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers below [R Z3 T-2 C-1 ~> J m-2 degC-1]. + real, intent(in) :: dS_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers below [R Z3 T-2 S-1 ~> J m-2 ppt-1]. + real, intent(in) :: pres_Z !< The rescaled hydrostatic interface pressure, which relates + !! the changes in column thickness to the energy that is radiated + !! as gravity waves and unavailable to drive mixing [R Z2 T-2 ~> J m-3]. + real, intent(in) :: dT_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dT) relating + !! a layer's temperature change to the change in column + !! height, including all implicit diffusive changes + !! in the temperatures of all the layers above [Z C-1 ~> m degC-1]. + real, intent(in) :: dS_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dS) relating + !! a layer's salinity change to the change in column + !! height, including all implicit diffusive changes + !! in the salinities of all the layers above [Z S-1 ~> m ppt-1]. + real, intent(in) :: dT_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dT) relating + !! a layer's temperature change to the change in column + !! height, including all implicit diffusive changes + !! in the temperatures of all the layers below [Z C-1 ~> m degC-1]. + real, intent(in) :: dS_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dS) relating + !! a layer's salinity change to the change in column + !! height, including all implicit diffusive changes + !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. + + real, intent(out) :: PE_chg !< The change in column potential energy from applying + !! Kddt_h at the present interface [R Z3 T-2 ~> J m-2]. + real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h + !! [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. + real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could + !! be realized by applying a huge value of Kddt_h at the + !! present interface [R Z3 T-2 ~> J m-2]. + real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the + !! limit where Kddt_h = 0 [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. + real, optional, intent(out) :: PE_ColHt_cor !< The correction to PE_chg that is made due to a net + !! change in the column height [R Z3 T-2 ~> J m-2]. + + ! Local variables + real :: hps ! The sum of the two effective pivot thicknesses [H ~> m or kg m-2]. + real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term [H2 ~> m2 or kg2 m-4]. + real :: dT_c ! The core term in the expressions for the temperature changes [C H2 ~> degC m2 or degC kg2 m-4]. + real :: dS_c ! The core term in the expressions for the salinity changes [S H2 ~> ppt m2 or ppt kg2 m-4]. + real :: PEc_core ! The diffusivity-independent core term in the expressions + ! for the potential energy changes [R Z2 T-2 ~> J m-3]. + real :: ColHt_core ! The diffusivity-independent core term in the expressions + ! for the column height changes [H Z ~> m2 or kg m-1]. + real :: ColHt_chg ! The change in the column height [H ~> m or kg m-2]. + real :: y1_3 ! A local temporary term in [H-3 ~> m-3 or m6 kg-3]. + real :: y1_4 ! A local temporary term in [H-4 ~> m-4 or m8 kg-4]. + + ! The expression for the change in potential energy used here is derived + ! from the expression for the final estimates of the changes in temperature + ! and salinities, and then extensively manipulated to get it into its most + ! succinct form. The derivation is not necessarily obvious, but it demonstrably + ! works by comparison with separate calculations of the energy changes after + ! the tridiagonal solver for the final changes in temperature and salinity are + ! applied. + + hps = hp_a + hp_b + bdt1 = hp_a * hp_b + Kddt_h0 * hps + dT_c = hp_a * Th_b - hp_b * Th_a + dS_c = hp_a * Sh_b - hp_b * Sh_a + PEc_core = hp_b * (dT_to_dPE_a * dT_c + dS_to_dPE_a * dS_c) - & + hp_a * (dT_to_dPE_b * dT_c + dS_to_dPE_b * dS_c) + ColHt_core = hp_b * (dT_to_dColHt_a * dT_c + dS_to_dColHt_a * dS_c) - & + hp_a * (dT_to_dColHt_b * dT_c + dS_to_dColHt_b * dS_c) + + ! Find the change in column potential energy due to the change in the + ! diffusivity at this interface by dKddt_h. + y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) + PE_chg = PEc_core * y1_3 + ColHt_chg = ColHt_core * y1_3 + if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg + + if (present(PE_ColHt_cor)) PE_ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) + + if (present(dPEc_dKd)) then + ! Find the derivative of the potential energy change with dKddt_h. + y1_4 = 1.0 / (bdt1 + dKddt_h * hps)**2 + dPEc_dKd = PEc_core * y1_4 + ColHt_chg = ColHt_core * y1_4 + if (ColHt_chg < 0.0) dPEc_dKd = dPEc_dKd - pres_Z * ColHt_chg + endif + + if (present(dPE_max)) then + ! This expression is the limit of PE_chg for infinite dKddt_h. + y1_3 = 1.0 / (bdt1 * hps) + dPE_max = PEc_core * y1_3 + ColHt_chg = ColHt_core * y1_3 + if (ColHt_chg < 0.0) dPE_max = dPE_max - pres_Z * ColHt_chg + endif + + if (present(dPEc_dKd_0)) then + ! This expression is the limit of dPEc_dKd for dKddt_h = 0. + y1_4 = 1.0 / bdt1**2 + dPEc_dKd_0 = PEc_core * y1_4 + ColHt_chg = ColHt_core * y1_4 + if (ColHt_chg < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres_Z * ColHt_chg + endif + +end subroutine find_PE_chg + +!> This subroutine calculates the change in potential energy and or derivatives +!! for several changes in an interface's diapycnal diffusivity times a timestep +!! using the original form used in the first version of ePBL. +subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & + dT_km1_t2, dS_km1_t2, dT_to_dPE_k, dS_to_dPE_k, & + dT_to_dPEa, dS_to_dPEa, pres_Z, dT_to_dColHt_k, & + dS_to_dColHt_k, dT_to_dColHta, dS_to_dColHta, PE_chg, & + dPEc_dKd, dPE_max, dPEc_dKd_0) + real, intent(in) :: Kddt_h !< The diffusivity at an interface times the time step and + !! divided by the average of the thicknesses around the + !! interface [H ~> m or kg m-2]. + real, intent(in) :: h_k !< The thickness of the layer below the interface [H ~> m or kg m-2]. + real, intent(in) :: b_den_1 !< The first term in the denominator of the pivot + !! for the tridiagonal solver, given by h_k plus a term that + !! is a fraction (determined from the tridiagonal solver) of + !! Kddt_h for the interface above [H ~> m or kg m-2]. + real, intent(in) :: dTe_term !< A diffusivity-independent term related to the temperature change + !! in the layer below the interface [C H ~> degC m or degC kg m-2]. + real, intent(in) :: dSe_term !< A diffusivity-independent term related to the salinity change + !! in the layer below the interface [S H ~> ppt m or ppt kg m-2]. + real, intent(in) :: dT_km1_t2 !< A diffusivity-independent term related to the + !! temperature change in the layer above the interface [C ~> degC]. + real, intent(in) :: dS_km1_t2 !< A diffusivity-independent term related to the + !! salinity change in the layer above the interface [S ~> ppt]. + real, intent(in) :: pres_Z !< The rescaled hydrostatic interface pressure, which relates + !! the changes in column thickness to the energy that is radiated + !! as gravity waves and unavailable to drive mixing [R Z2 T-2 ~> J m-3]. + real, intent(in) :: dT_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers below [R Z3 T-2 C-1 ~> J m-2 degC-1]. + real, intent(in) :: dS_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! in the salinities of all the layers below [R Z3 T-2 S-1 ~> J m-2 ppt-1]. + real, intent(in) :: dT_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers above [R Z3 T-2 C-1 ~> J m-2 degC-1]. + real, intent(in) :: dS_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers above [R Z3 T-2 S-1 ~> J m-2 ppt-1]. + real, intent(in) :: dT_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dT) relating + !! a layer's temperature change to the change in column + !! height, including all implicit diffusive changes in the + !! temperatures of all the layers below [Z C-1 ~> m degC-1]. + real, intent(in) :: dS_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dS) relating + !! a layer's salinity change to the change in column + !! height, including all implicit diffusive changes + !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. + real, intent(in) :: dT_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dT) relating + !! a layer's temperature change to the change in column + !! height, including all implicit diffusive changes + !! in the temperatures of all the layers above [Z C-1 ~> m degC-1]. + real, intent(in) :: dS_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dS) relating + !! a layer's salinity change to the change in column + !! height, including all implicit diffusive changes + !! in the salinities of all the layers above [Z S-1 ~> m ppt-1]. + + real, intent(out) :: PE_chg !< The change in column potential energy from applying + !! Kddt_h at the present interface [R Z3 T-2 ~> J m-2]. + real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h + !! [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. + real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could + !! be realized by applying a huge value of Kddt_h at the + !! present interface [R Z3 T-2 ~> J m-2]. + real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the + !! limit where Kddt_h = 0 [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. + +! This subroutine determines the total potential energy change due to mixing +! at an interface, including all of the implicit effects of the prescribed +! mixing at interfaces above. Everything here is derived by careful manipulation +! of the robust tridiagonal solvers used for tracers by MOM6. The results are +! positive for mixing in a stably stratified environment. +! The comments describing these arguments are for a downward mixing pass, but +! this routine can also be used for an upward pass with the sense of direction +! reversed. + + ! Local variables + real :: b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: b1Kd ! Temporary array [nondim] + real :: ColHt_chg ! The change in column thickness [Z ~> m]. + real :: dColHt_max ! The change in column thickness for infinite diffusivity [Z ~> m]. + real :: dColHt_dKd ! The partial derivative of column thickness with Kddt_h [Z H-1 ~> nondim or m3 kg-1] + real :: dT_k, dT_km1 ! Temperature changes in layers k and k-1 [C ~> degC] + real :: dS_k, dS_km1 ! Salinity changes in layers k and k-1 [S ~> ppt] + real :: I_Kr_denom ! Temporary array [H-2 ~> m-2 or m4 kg-2] + real :: dKr_dKd ! Temporary array [H-2 ~> m-2 or m4 kg-2] + real :: ddT_k_dKd, ddT_km1_dKd ! Temporary arrays indicating the temperature changes + ! per unit change in Kddt_h [C H-1 ~> degC m-1 or degC m2 kg-1] + real :: ddS_k_dKd, ddS_km1_dKd ! Temporary arrays indicating the salinity changes + ! per unit change in Kddt_h [S H-1 ~> ppt m-1 or ppt m2 kg-1] + + b1 = 1.0 / (b_den_1 + Kddt_h) + b1Kd = Kddt_h*b1 + + ! Start with the temperature change in layer k-1 due to the diffusivity at + ! interface K without considering the effects of changes in layer k. + + ! Calculate the change in PE due to the diffusion at interface K + ! if Kddt_h(K+1) = 0. + I_Kr_denom = 1.0 / (h_k*b_den_1 + (b_den_1 + h_k)*Kddt_h) + + dT_k = (Kddt_h*I_Kr_denom) * dTe_term + dS_k = (Kddt_h*I_Kr_denom) * dSe_term + + ! Find the change in energy due to diffusion with strength Kddt_h at this interface. + ! Increment the temperature changes in layer k-1 due the changes in layer k. + dT_km1 = b1Kd * ( dT_k + dT_km1_t2 ) + dS_km1 = b1Kd * ( dS_k + dS_km1_t2 ) + PE_chg = (dT_to_dPE_k * dT_k + dT_to_dPEa * dT_km1) + & + (dS_to_dPE_k * dS_k + dS_to_dPEa * dS_km1) + ColHt_chg = (dT_to_dColHt_k * dT_k + dT_to_dColHta * dT_km1) + & + (dS_to_dColHt_k * dS_k + dS_to_dColHta * dS_km1) + if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg + + if (present(dPEc_dKd)) then + ! Find the derivatives of the temperature and salinity changes with Kddt_h. + dKr_dKd = (h_k*b_den_1) * I_Kr_denom**2 + + ddT_k_dKd = dKr_dKd * dTe_term + ddS_k_dKd = dKr_dKd * dSe_term + ddT_km1_dKd = (b1**2 * b_den_1) * ( dT_k + dT_km1_t2 ) + b1Kd * ddT_k_dKd + ddS_km1_dKd = (b1**2 * b_den_1) * ( dS_k + dS_km1_t2 ) + b1Kd * ddS_k_dKd + + ! Calculate the partial derivative of Pe_chg with Kddt_h. + dPEc_dKd = (dT_to_dPE_k * ddT_k_dKd + dT_to_dPEa * ddT_km1_dKd) + & + (dS_to_dPE_k * ddS_k_dKd + dS_to_dPEa * ddS_km1_dKd) + dColHt_dKd = (dT_to_dColHt_k * ddT_k_dKd + dT_to_dColHta * ddT_km1_dKd) + & + (dS_to_dColHt_k * ddS_k_dKd + dS_to_dColHta * ddS_km1_dKd) + if (dColHt_dKd < 0.0) dPEc_dKd = dPEc_dKd - pres_Z * dColHt_dKd + endif + + if (present(dPE_max)) then + ! This expression is the limit of PE_chg for infinite Kddt_h. + dPE_max = (dT_to_dPEa * dT_km1_t2 + dS_to_dPEa * dS_km1_t2) + & + ((dT_to_dPE_k + dT_to_dPEa) * dTe_term + & + (dS_to_dPE_k + dS_to_dPEa) * dSe_term) / (b_den_1 + h_k) + dColHt_max = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) + & + ((dT_to_dColHt_k + dT_to_dColHta) * dTe_term + & + (dS_to_dColHt_k + dS_to_dColHta) * dSe_term) / (b_den_1 + h_k) + if (dColHt_max < 0.0) dPE_max = dPE_max - pres_Z*dColHt_max + endif + + if (present(dPEc_dKd_0)) then + ! This expression is the limit of dPEc_dKd for Kddt_h = 0. + dPEc_dKd_0 = (dT_to_dPEa * dT_km1_t2 + dS_to_dPEa * dS_km1_t2) / (b_den_1) + & + (dT_to_dPE_k * dTe_term + dS_to_dPE_k * dSe_term) / (h_k*b_den_1) + dColHt_dKd = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) / (b_den_1) + & + (dT_to_dColHt_k * dTe_term + dS_to_dColHt_k * dSe_term) / (h_k*b_den_1) + if (dColHt_dKd < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres_Z*dColHt_dKd + endif + +end subroutine find_PE_chg_orig + +!> This subroutine finds the Mstar value for ePBL +subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, & + BLD, Abs_Coriolis, MStar, Langmuir_Number,& + MStar_LT, Convect_Langmuir_Number) + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: UStar !< ustar including gustiness [Z T-1 ~> m s-1] + real, intent(in) :: Abs_Coriolis !< absolute value of the Coriolis parameter [T-1 ~> s-1] + real, intent(in) :: Buoyancy_Flux !< Buoyancy flux [Z2 T-3 ~> m2 s-3] + real, intent(in) :: BLD !< boundary layer depth [Z ~> m] + real, intent(out) :: Mstar !< Output mstar (Mixing/ustar**3) [nondim] + real, optional, intent(in) :: Langmuir_Number !< Langmuir number [nondim] + real, optional, intent(out) :: MStar_LT !< Mstar increase due to Langmuir turbulence [nondim] + real, optional, intent(out) :: Convect_Langmuir_number !< Langmuir number including buoyancy flux [nondim] + + !/ Variables used in computing mstar + real :: MSN_term ! Temporary terms [nondim] + real :: MSCR_term1, MSCR_term2 ! Temporary terms [Z3 T-3 ~> m3 s-3] + real :: MStar_Conv_Red ! Adjustment made to mstar due to convection reducing mechanical mixing [nondim] + real :: MStar_S, MStar_N ! Mstar in (S)tabilizing/(N)ot-stabilizing buoyancy flux [nondim] + + !/ Integer options for how to find mstar + + !/ + + if (CS%mstar_scheme == Use_Fixed_MStar) then + MStar = CS%Fixed_MStar + !/ 1. Get mstar + elseif (CS%mstar_scheme == MStar_from_Ekman) then + + if (CS%answer_date < 20190101) then + ! The limit for the balance of rotation and stabilizing is f(L_Ekman,L_Obukhov) + MStar_S = CS%MStar_coef*sqrt(max(0.0,Buoyancy_Flux) / UStar**2 / & + (Abs_Coriolis + 1.e-10*US%T_to_s) ) + ! The limit for rotation (Ekman length) limited mixing + MStar_N = CS%C_Ek * log( max( 1., UStar / (Abs_Coriolis + 1.e-10*US%T_to_s) / BLD ) ) + else + ! The limit for the balance of rotation and stabilizing is f(L_Ekman,L_Obukhov) + MStar_S = CS%MSTAR_COEF*sqrt(max(0.0, Buoyancy_Flux) / (UStar**2 * max(Abs_Coriolis, 1.e-20*US%T_to_s))) + ! The limit for rotation (Ekman length) limited mixing + MStar_N = 0.0 + if (UStar > Abs_Coriolis * BLD) Mstar_N = CS%C_EK * log(UStar / (Abs_Coriolis * BLD)) + endif + + ! Here 1.25 is about .5/von Karman, which gives the Obukhov limit. + MStar = max(MStar_S, min(1.25, MStar_N)) + if (CS%MStar_Cap > 0.0) MStar = min( CS%MStar_Cap,MStar ) + elseif ( CS%mstar_scheme == MStar_from_RH18 ) then + if (CS%answer_date < 20190101) then + MStar_N = CS%RH18_MStar_cn1 * ( 1.0 - 1.0 / ( 1. + CS%RH18_MStar_cn2 * & + exp( CS%RH18_mstar_CN3 * BLD * Abs_Coriolis / UStar) ) ) + else + MSN_term = CS%RH18_MStar_cn2 * exp( CS%RH18_mstar_CN3 * BLD * Abs_Coriolis / UStar) + MStar_N = (CS%RH18_MStar_cn1 * MSN_term) / ( 1. + MSN_term) + endif + MStar_S = CS%RH18_MStar_CS1 * ( max(0.0, Buoyancy_Flux)**2 * BLD / & + ( UStar**5 * max(Abs_Coriolis,1.e-20*US%T_to_s) ) )**CS%RH18_mstar_cs2 + MStar = MStar_N + MStar_S + endif + + !/ 2. Adjust mstar to account for convective turbulence + if (CS%answer_date < 20190101) then + MStar_Conv_Red = 1. - CS%MStar_Convect_coef * (-min(0.0,Buoyancy_Flux) + 1.e-10*US%T_to_s**3*US%m_to_Z**2) / & + ( (-min(0.0,Buoyancy_Flux) + 1.e-10*US%T_to_s**3*US%m_to_Z**2) + & + 2.0 *MStar * UStar**3 / BLD ) + else + MSCR_term1 = -BLD * min(0.0, Buoyancy_Flux) + MSCR_term2 = 2.0*MStar * UStar**3 + if ( abs(MSCR_term2) > 0.0) then + MStar_Conv_Red = ((1.-CS%mstar_convect_coef) * MSCR_term1 + MSCR_term2) / (MSCR_term1 + MSCR_term2) + else + MStar_Conv_Red = 1.-CS%mstar_convect_coef + endif + endif + + !/3. Combine various mstar terms to get final value + MStar = MStar * MStar_Conv_Red + + if (present(Langmuir_Number)) then + call mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, MStar, & + MStar_LT, Convect_Langmuir_Number) + endif + +end subroutine Find_Mstar + +!> This subroutine modifies the Mstar value if the Langmuir number is present +subroutine Mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, & + Mstar, MStar_LT, Convect_Langmuir_Number) + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Abs_Coriolis !< Absolute value of the Coriolis parameter [T-1 ~> s-1] + real, intent(in) :: Buoyancy_Flux !< Buoyancy flux [Z2 T-3 ~> m2 s-3] + real, intent(in) :: UStar !< Surface friction velocity with? gustiness [Z T-1 ~> m s-1] + real, intent(in) :: BLD !< boundary layer depth [Z ~> m] + real, intent(inout) :: Mstar !< Input/output mstar (Mixing/ustar**3) [nondim] + real, intent(in) :: Langmuir_Number !< Langmuir number [nondim] + real, intent(out) :: MStar_LT !< Mstar increase due to Langmuir turbulence [nondim] + real, intent(out) :: Convect_Langmuir_number !< Langmuir number including buoyancy flux [nondim] + + !/ + real, parameter :: Max_ratio = 1.0e16 ! The maximum value of a nondimensional ratio [nondim]. + real :: enhance_mstar ! A multiplicative scaling of mstar due to Langmuir turbulence [nondim]. + real :: mstar_LT_add ! A value that is added to mstar due to Langmuir turbulence [nondim]. + real :: iL_Ekman ! Inverse of Ekman length scale [Z-1 ~> m-1]. + real :: iL_Obukhov ! Inverse of Obukhov length scale [Z-1 ~> m-1]. + real :: I_ustar ! The Adcroft reciprocal of ustar [T Z-1 ~> s m-1] + real :: I_f ! The Adcroft reciprocal of the Coriolis parameter [T ~> s] + real :: MLD_Ekman ! The ratio of the mixed layer depth to the Ekman layer depth [nondim]. + real :: Ekman_Obukhov ! The Ekman layer thickness divided by the Obukhov depth [nondim]. + real :: MLD_Obukhov ! The mixed layer depth divided by the Obukhov depth [nondim]. + real :: MLD_Obukhov_stab ! The mixed layer depth divided by the Obukhov depth under stable + ! conditions or 0 under unstable conditions [nondim]. + real :: Ekman_Obukhov_stab ! The Ekman layer thickness divided by the Obukhov depth under stable + ! conditions or 0 under unstable conditions [nondim]. + real :: MLD_Obukhov_un ! The mixed layer depth divided by the Obukhov depth under unstable + ! conditions or 0 under stable conditions [nondim]. + real :: Ekman_Obukhov_un ! The Ekman layer thickness divided by the Obukhov depth under unstable + ! conditions or 0 under stable conditions [nondim]. + + ! Set default values for no Langmuir effects. + enhance_mstar = 1.0 ; mstar_LT_add = 0.0 + + if (CS%LT_Enhance_Form /= No_Langmuir) then + ! a. Get parameters for modified LA + if (CS%answer_date < 20190101) then + iL_Ekman = Abs_Coriolis / Ustar + iL_Obukhov = Buoyancy_Flux*CS%vonkar / Ustar**3 + Ekman_Obukhov_stab = abs(max(0., iL_Obukhov / (iL_Ekman + 1.e-10*US%Z_to_m))) + Ekman_Obukhov_un = abs(min(0., iL_Obukhov / (iL_Ekman + 1.e-10*US%Z_to_m))) + MLD_Obukhov_stab = abs(max(0., BLD*iL_Obukhov)) + MLD_Obukhov_un = abs(min(0., BLD*iL_Obukhov)) + MLD_Ekman = abs( BLD*iL_Ekman ) + else + Ekman_Obukhov = Max_ratio ; MLD_Obukhov = Max_ratio ; MLD_Ekman = Max_ratio + I_f = 0.0 ; if (abs(abs_Coriolis) > 0.0) I_f = 1.0 / abs_Coriolis + I_ustar = 0.0 ; if (abs(Ustar) > 0.0) I_ustar = 1.0 / Ustar + if (abs(Buoyancy_Flux*CS%vonkar) < Max_ratio*(abs_Coriolis * Ustar**2)) & + Ekman_Obukhov = abs(Buoyancy_Flux*CS%vonkar) * (I_f * I_Ustar**2) + if (abs(BLD*Buoyancy_Flux*CS%vonkar) < Max_ratio*Ustar**3) & + MLD_Obukhov = abs(BLD*Buoyancy_Flux*CS%vonkar) * I_Ustar**3 + if (BLD*Abs_Coriolis < Max_ratio*Ustar) & + MLD_Ekman = BLD*Abs_Coriolis * I_Ustar + + if (Buoyancy_Flux > 0.0) then + Ekman_Obukhov_stab = Ekman_Obukhov ; Ekman_Obukhov_un = 0.0 + MLD_Obukhov_stab = MLD_Obukhov ; MLD_Obukhov_un = 0.0 + else + Ekman_Obukhov_un = Ekman_Obukhov ; Ekman_Obukhov_stab = 0.0 + MLD_Obukhov_un = MLD_Obukhov ; MLD_Obukhov_stab = 0.0 + endif + endif + + ! b. Adjust LA based on various parameters. + ! Assumes linear factors based on length scale ratios to adjust LA + ! Note when these coefficients are set to 0 recovers simple LA. + Convect_Langmuir_Number = Langmuir_Number * & + ( (1.0 + max(-0.5, CS%LaC_MLDoEK * MLD_Ekman)) + & + ((CS%LaC_EKoOB_stab * Ekman_Obukhov_stab + CS%LaC_EKoOB_un * Ekman_Obukhov_un) + & + (CS%LaC_MLDoOB_stab * MLD_Obukhov_stab + CS%LaC_MLDoOB_un * MLD_Obukhov_un)) ) + + if (CS%LT_Enhance_Form == Langmuir_rescale) then + ! Enhancement is multiplied (added mst_lt set to 0) + Enhance_mstar = min(CS%Max_Enhance_M, & + (1. + CS%LT_ENHANCE_COEF * Convect_Langmuir_Number**CS%LT_ENHANCE_EXP) ) + elseif (CS%LT_ENHANCE_Form == Langmuir_add) then + ! or Enhancement is additive (multiplied enhance_m set to 1) + mstar_LT_add = CS%LT_ENHANCE_COEF * Convect_Langmuir_Number**CS%LT_ENHANCE_EXP + endif + endif + + mstar_LT = (enhance_mstar - 1.0)*mstar + mstar_LT_add ! Diagnose the full increase in mstar. + mstar = mstar*enhance_mstar + mstar_LT_add + +end subroutine Mstar_Langmuir + + +!> Copies the ePBL active mixed layer depth into MLD, in units of [Z ~> m] unless other units are specified. +subroutine energetic_PBL_get_MLD(CS, MLD, G, US, m_to_MLD_units) + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [Z ~> m] + !! or other units + real, optional, intent(in) :: m_to_MLD_units !< A conversion factor from meters + !! to the desired units for MLD, sometimes [Z m-1 ~> 1] + ! Local variables + real :: scale ! A dimensional rescaling factor, often [nondim] or [m Z-1 ~> 1] + integer :: i, j + + scale = 1.0 ; if (present(m_to_MLD_units)) scale = US%Z_to_m * m_to_MLD_units + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + MLD(i,j) = scale*CS%ML_depth(i,j) + enddo ; enddo + +end subroutine energetic_PBL_get_MLD + + +!> This subroutine initializes the energetic_PBL module +subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) + type(time_type), target, intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic output + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure + + ! Local variables + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_energetic_PBL" ! This module's name. + character(len=20) :: tmpstr + real :: omega_frac_dflt ! The default for omega_frac [nondim] + integer :: isd, ied, jsd, jed + integer :: mstar_mode, LT_enhance, wT_mode + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: use_temperature, use_omega + logical :: use_la_windsea + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + CS%initialized = .true. + CS%diag => diag + CS%Time => Time + +! Set default, read and log parameters + call log_version(param_file, mdl, version, "") + + +!/1. General ePBL settings + call get_param(param_file, mdl, "OMEGA", CS%omega, & + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_S) + call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & + "If true, use the absolute rotation rate instead of the "//& + "vertical component of rotation when setting the decay "//& + "scale for turbulence.", default=.false., do_not_log=.true.) + omega_frac_dflt = 0.0 + if (use_omega) then + call MOM_error(WARNING, "ML_USE_OMEGA is depricated; use ML_OMEGA_FRAC=1.0 instead.") + omega_frac_dflt = 1.0 + endif + call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%omega_frac, & + "When setting the decay scale for turbulence, use this "//& + "fraction of the absolute rotation rate blended with the "//& + "local value of f, as sqrt((1-of)*f^2 + of*4*omega^2).", & + units="nondim", default=omega_frac_dflt) + call get_param(param_file, mdl, "EKMAN_SCALE_COEF", CS%Ekman_scale_coef, & + "A nondimensional scaling factor controlling the inhibition "//& + "of the diffusive length scale by rotation. Making this larger "//& + "decreases the PBL diffusivity.", units="nondim", default=1.0) + call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "EPBL_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the energetic "//& + "PBL calculations. Values below 20190101 recover the answers from the "//& + "end of 2018, while higher values use updated and more robust forms of the "//& + "same expressions. Values below 20240101 use A**(1./3.) to estimate the cube "//& + "root of A in several expressions, while higher values use the integer root "//& + "function cuberoot(A) and therefore can work with scaled variables.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + + call get_param(param_file, mdl, "EPBL_ORIGINAL_PE_CALC", CS%orig_PE_calc, & + "If true, the ePBL code uses the original form of the "//& + "potential energy change code. Otherwise, the newer "//& + "version that can work with successive increments to the "//& + "diffusivity in upward or downward passes is used.", default=.true.) + + call get_param(param_file, mdl, "MKE_TO_TKE_EFFIC", CS%MKE_to_TKE_effic, & + "The efficiency with which mean kinetic energy released "//& + "by mechanically forced entrainment of the mixed layer "//& + "is converted to turbulent kinetic energy.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "TKE_DECAY", CS%TKE_decay, & + "TKE_DECAY relates the vertical rate of decay of the "//& + "TKE available for mechanical entrainment to the natural "//& + "Ekman depth.", units="nondim", default=2.5) + + +!/2. Options related to setting MSTAR + call get_param(param_file, mdl, "EPBL_MSTAR_SCHEME", tmpstr, & + "EPBL_MSTAR_SCHEME selects the method for setting mstar. Valid values are: \n"//& + "\t CONSTANT - Use a fixed mstar given by MSTAR \n"//& + "\t OM4 - Use L_Ekman/L_Obukhov in the sabilizing limit, as in OM4 \n"//& + "\t REICHL_H18 - Use the scheme documented in Reichl & Hallberg, 2018.", & + default=CONSTANT_STRING, do_not_log=.true.) + call get_param(param_file, mdl, "MSTAR_MODE", mstar_mode, default=-1) + if (mstar_mode == 0) then + tmpstr = CONSTANT_STRING + call MOM_error(WARNING, "Use EPBL_MSTAR_SCHEME = CONSTANT instead of the archaic MSTAR_MODE = 0.") + elseif (mstar_mode == 1) then + call MOM_error(FATAL, "You are using a legacy mstar mode in ePBL that has been phased out. "//& + "If you need to use this setting please report this error. Also use "//& + "EPBL_MSTAR_SCHEME to specify the scheme for mstar.") + elseif (mstar_mode == 2) then + tmpstr = OM4_STRING + call MOM_error(WARNING, "Use EPBL_MSTAR_SCHEME = OM4 instead of the archaic MSTAR_MODE = 2.") + elseif (mstar_mode == 3) then + tmpstr = RH18_STRING + call MOM_error(WARNING, "Use EPBL_MSTAR_SCHEME = REICHL_H18 instead of the archaic MSTAR_MODE = 3.") + elseif (mstar_mode > 3) then + call MOM_error(FATAL, "An unrecognized value of the obsolete parameter MSTAR_MODE was specified.") + endif + call log_param(param_file, mdl, "EPBL_MSTAR_SCHEME", tmpstr, & + "EPBL_MSTAR_SCHEME selects the method for setting mstar. Valid values are: \n"//& + "\t CONSTANT - Use a fixed mstar given by MSTAR \n"//& + "\t OM4 - Use L_Ekman/L_Obukhov in the stabilizing limit, as in OM4 \n"//& + "\t REICHL_H18 - Use the scheme documented in Reichl & Hallberg, 2018.", & + default=CONSTANT_STRING) + tmpstr = uppercase(tmpstr) + select case (tmpstr) + case (CONSTANT_STRING) + CS%mstar_Scheme = Use_Fixed_MStar + case (OM4_STRING) + CS%mstar_Scheme = MStar_from_Ekman + case (RH18_STRING) + CS%mstar_Scheme = MStar_from_RH18 + case default + call MOM_mesg('energetic_PBL_init: EPBL_MSTAR_SCHEME ="'//trim(tmpstr)//'"', 0) + call MOM_error(FATAL, "energetic_PBL_init: Unrecognized setting "// & + "EPBL_MSTAR_SCHEME = "//trim(tmpstr)//" found in input file.") + end select + + call get_param(param_file, mdl, "MSTAR", CS%fixed_mstar, & + "The ratio of the friction velocity cubed to the TKE input to the "//& + "mixed layer. This option is used if EPBL_MSTAR_SCHEME = CONSTANT.", & + units="nondim", default=1.2, do_not_log=(CS%mstar_scheme/=Use_Fixed_MStar)) + call get_param(param_file, mdl, "MSTAR_CAP", CS%mstar_cap, & + "If this value is positive, it sets the maximum value of mstar "//& + "allowed in ePBL. (This is not used if EPBL_MSTAR_SCHEME = CONSTANT).", & + units="nondim", default=-1.0, do_not_log=(CS%mstar_scheme==Use_Fixed_MStar)) + ! mstar_scheme==MStar_from_Ekman options + call get_param(param_file, mdl, "MSTAR2_COEF1", CS%MSTAR_COEF, & + "Coefficient in computing mstar when rotation and stabilizing "//& + "effects are both important (used if EPBL_MSTAR_SCHEME = OM4).", & + units="nondim", default=0.3, do_not_log=(CS%mstar_scheme/=MStar_from_Ekman)) + call get_param(param_file, mdl, "MSTAR2_COEF2", CS%C_EK, & + "Coefficient in computing mstar when only rotation limits "// & + "the total mixing (used if EPBL_MSTAR_SCHEME = OM4)", & + units="nondim", default=0.085, do_not_log=(CS%mstar_scheme/=MStar_from_Ekman)) + ! mstar_scheme==MStar_from_RH18 options + call get_param(param_file, mdl, "RH18_MSTAR_CN1", CS%RH18_mstar_cn1,& + "MSTAR_N coefficient 1 (outter-most coefficient for fit). "//& + "The value of 0.275 is given in RH18. Increasing this "//& + "coefficient increases MSTAR for all values of Hf/ust, but more "//& + "effectively at low values (weakly developed OSBLs).", & + units="nondim", default=0.275, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + call get_param(param_file, mdl, "RH18_MSTAR_CN2", CS%RH18_mstar_cn2,& + "MSTAR_N coefficient 2 (coefficient outside of exponential decay). "//& + "The value of 8.0 is given in RH18. Increasing this coefficient "//& + "increases MSTAR for all values of HF/ust, with a much more even "//& + "effect across a wide range of Hf/ust than CN1.", & + units="nondim", default=8.0, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + call get_param(param_file, mdl, "RH18_MSTAR_CN3", CS%RH18_mstar_CN3,& + "MSTAR_N coefficient 3 (exponential decay coefficient). "//& + "The value of -5.0 is given in RH18. Increasing this increases how "//& + "quickly the value of MSTAR decreases as Hf/ust increases.", & + units="nondim", default=-5.0, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + call get_param(param_file, mdl, "RH18_MSTAR_CS1", CS%RH18_mstar_cs1,& + "MSTAR_S coefficient for RH18 in stabilizing limit. "//& + "The value of 0.2 is given in RH18 and increasing it increases "//& + "MSTAR in the presence of a stabilizing surface buoyancy flux.", & + units="nondim", default=0.2, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + call get_param(param_file, mdl, "RH18_MSTAR_CS2", CS%RH18_mstar_cs2,& + "MSTAR_S exponent for RH18 in stabilizing limit. "//& + "The value of 0.4 is given in RH18 and increasing it increases MSTAR "//& + "exponentially in the presence of a stabilizing surface buoyancy flux.", & + Units="nondim", default=0.4, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + + +!/ Convective turbulence related options + call get_param(param_file, mdl, "NSTAR", CS%nstar, & + "The portion of the buoyant potential energy imparted by "//& + "surface fluxes that is available to drive entrainment "//& + "at the base of mixed layer when that energy is positive.", & + units="nondim", default=0.2) + call get_param(param_file, mdl, "MSTAR_CONV_ADJ", CS%mstar_convect_coef, & + "Coefficient used for reducing mstar during convection "//& + "due to reduction of stable density gradient.", & + units="nondim", default=0.0) + +!/ Mixing Length Options + call get_param(param_file, mdl, "USE_MLD_ITERATION", CS%Use_MLD_iteration, & + "A logical that specifies whether or not to use the "//& + "distance to the bottom of the actively turbulent boundary "//& + "layer to help set the EPBL length scale.", default=.true.) + call get_param(param_file, mdl, "EPBL_TRANSITION_SCALE", CS%transLay_scale, & + "A scale for the mixing length in the transition layer "//& + "at the edge of the boundary layer as a fraction of the "//& + "boundary layer thickness.", units="nondim", default=0.1) + if ( CS%Use_MLD_iteration .and. abs(CS%transLay_scale-0.5) >= 0.5) then + call MOM_error(FATAL, "If flag USE_MLD_ITERATION is true, then "//& + "EPBL_TRANSITION should be greater than 0 and less than 1.") + endif + + call get_param(param_file, mdl, "MLD_ITERATION_GUESS", CS%MLD_ITERATION_GUESS, & + "If true, use the previous timestep MLD as a first guess in the MLD iteration, "//& + "otherwise use half the ocean depth as the first guess of the boundary layer "//& + "depth. The default is false to facilitate reproducibility.", & + default=.false., do_not_log=.not.CS%Use_MLD_iteration) + call get_param(param_file, mdl, "EPBL_MLD_TOLERANCE", CS%MLD_tol, & + "The tolerance for the iteratively determined mixed "//& + "layer depth. This is only used with USE_MLD_ITERATION.", & + units="meter", default=1.0, scale=US%m_to_Z, do_not_log=.not.CS%Use_MLD_iteration) + call get_param(param_file, mdl, "EPBL_MLD_BISECTION", CS%MLD_bisection, & + "If true, use bisection with the iterative determination of the self-consistent "//& + "mixed layer depth. Otherwise use the false position after a maximum and minimum "//& + "bound have been evaluated and the returned value or bisection before this.", & + default=.false., do_not_log=.not.CS%Use_MLD_iteration) + call get_param(param_file, mdl, "EPBL_MLD_MAX_ITS", CS%max_MLD_its, & + "The maximum number of iterations that can be used to find a self-consistent "//& + "mixed layer depth. If EPBL_MLD_BISECTION is true, the maximum number "//& + "iteractions needed is set by Depth/2^MAX_ITS < EPBL_MLD_TOLERANCE.", & + default=20, do_not_log=.not.CS%Use_MLD_iteration) + if (.not.CS%Use_MLD_iteration) CS%Max_MLD_Its = 1 + call get_param(param_file, mdl, "EPBL_MIN_MIX_LEN", CS%min_mix_len, & + "The minimum mixing length scale that will be used "//& + "by ePBL. The default (0) does not set a minimum.", & + units="meter", default=0.0, scale=US%m_to_Z) + + call get_param(param_file, mdl, "MIX_LEN_EXPONENT", CS%MixLenExponent, & + "The exponent applied to the ratio of the distance to the MLD "//& + "and the MLD depth which determines the shape of the mixing length. "//& + "This is only used if USE_MLD_ITERATION is True.", & + units="nondim", default=2.0) + +!/ Turbulent velocity scale in mixing coefficient + call get_param(param_file, mdl, "EPBL_VEL_SCALE_SCHEME", tmpstr, & + "Selects the method for translating TKE into turbulent velocities. "//& + "Valid values are: \n"//& + "\t CUBE_ROOT_TKE - A constant times the cube root of remaining TKE. \n"//& + "\t REICHL_H18 - Use the scheme based on a combination of w* and v* as \n"//& + "\t documented in Reichl & Hallberg, 2018.", & + default=ROOT_TKE_STRING, do_not_log=.true.) + call get_param(param_file, mdl, "EPBL_VEL_SCALE_MODE", wT_mode, default=-1) + if (wT_mode == 0) then + tmpstr = ROOT_TKE_STRING + call MOM_error(WARNING, "Use EPBL_VEL_SCALE_SCHEME = CUBE_ROOT_TKE instead of the archaic EPBL_VEL_SCALE_MODE = 0.") + elseif (wT_mode == 1) then + tmpstr = RH18_STRING + call MOM_error(WARNING, "Use EPBL_VEL_SCALE_SCHEME = REICHL_H18 instead of the archaic EPBL_VEL_SCALE_MODE = 1.") + elseif (wT_mode >= 2) then + call MOM_error(FATAL, "An unrecognized value of the obsolete parameter EPBL_VEL_SCALE_MODE was specified.") + endif + call log_param(param_file, mdl, "EPBL_VEL_SCALE_SCHEME", tmpstr, & + "Selects the method for translating TKE into turbulent velocities. "//& + "Valid values are: \n"//& + "\t CUBE_ROOT_TKE - A constant times the cube root of remaining TKE. \n"//& + "\t REICHL_H18 - Use the scheme based on a combination of w* and v* as \n"//& + "\t documented in Reichl & Hallberg, 2018.", & + default=ROOT_TKE_STRING) + tmpstr = uppercase(tmpstr) + select case (tmpstr) + case (ROOT_TKE_STRING) + CS%wT_scheme = wT_from_cRoot_TKE + case (RH18_STRING) + CS%wT_scheme = wT_from_RH18 + case default + call MOM_mesg('energetic_PBL_init: EPBL_VEL_SCALE_SCHEME ="'//trim(tmpstr)//'"', 0) + call MOM_error(FATAL, "energetic_PBL_init: Unrecognized setting "// & + "EPBL_VEL_SCALE_SCHEME = "//trim(tmpstr)//" found in input file.") + end select + + call get_param(param_file, mdl, "WSTAR_USTAR_COEF", CS%wstar_ustar_coef, & + "A ratio relating the efficiency with which convectively "//& + "released energy is converted to a turbulent velocity, "//& + "relative to mechanically forced TKE. Making this larger "//& + "increases the BL diffusivity", units="nondim", default=1.0) + call get_param(param_file, mdl, "EPBL_VEL_SCALE_FACTOR", CS%vstar_scale_fac, & + "An overall nondimensional scaling factor for wT. "//& + "Making this larger increases the PBL diffusivity.", & + units="nondim", default=1.0) + call get_param(param_file, mdl, "VSTAR_SURF_FAC", CS%vstar_surf_fac,& + "The proportionality times ustar to set vstar at the surface.", & + units="nondim", default=1.2) + + !/ Options related to Langmuir turbulence + call get_param(param_file, mdl, "USE_LA_LI2016", use_LA_Windsea, & + "A logical to use the Li et al. 2016 (submitted) formula to "//& + "determine the Langmuir number.", default=.false.) + ! Note this can be activated in other ways, but this preserves the old method. + if (use_LA_windsea) then + CS%use_LT = .true. + else + call get_param(param_file, mdl, "EPBL_LT", CS%use_LT, & + "A logical to use a LT parameterization.", default=.false.) + endif + if (CS%use_LT) then + call get_param(param_file, mdl, "EPBL_LANGMUIR_SCHEME", tmpstr, & + "EPBL_LANGMUIR_SCHEME selects the method for including Langmuir turbulence. "//& + "Valid values are: \n"//& + "\t NONE - Do not do any extra mixing due to Langmuir turbulence \n"//& + "\t RESCALE - Use a multiplicative rescaling of mstar to account for Langmuir turbulence \n"//& + "\t ADDITIVE - Add a Langmuir turblence contribution to mstar to other contributions", & + default=NONE_STRING, do_not_log=.true.) + call get_param(param_file, mdl, "LT_ENHANCE", LT_enhance, default=-1) + if (LT_ENHANCE == 0) then + tmpstr = NONE_STRING + call MOM_error(WARNING, "Use EPBL_LANGMUIR_SCHEME = NONE instead of the archaic LT_ENHANCE = 0.") + elseif (LT_ENHANCE == 1) then + call MOM_error(FATAL, "You are using a legacy LT_ENHANCE mode in ePBL that has been phased out. "//& + "If you need to use this setting please report this error. Also use "//& + "EPBL_LANGMUIR_SCHEME to specify the scheme for mstar.") + elseif (LT_ENHANCE == 2) then + tmpstr = RESCALED_STRING + call MOM_error(WARNING, "Use EPBL_LANGMUIR_SCHEME = RESCALE instead of the archaic LT_ENHANCE = 2.") + elseif (LT_ENHANCE == 3) then + tmpstr = ADDITIVE_STRING + call MOM_error(WARNING, "Use EPBL_LANGMUIR_SCHEME = ADDITIVE instead of the archaic LT_ENHANCE = 3.") + elseif (LT_ENHANCE > 3) then + call MOM_error(FATAL, "An unrecognized value of the obsolete parameter LT_ENHANCE was specified.") + endif + call log_param(param_file, mdl, "EPBL_LANGMUIR_SCHEME", tmpstr, & + "EPBL_LANGMUIR_SCHEME selects the method for including Langmuir turbulence. "//& + "Valid values are: \n"//& + "\t NONE - Do not do any extra mixing due to Langmuir turbulence \n"//& + "\t RESCALE - Use a multiplicative rescaling of mstar to account for Langmuir turbulence \n"//& + "\t ADDITIVE - Add a Langmuir turblence contribution to mstar to other contributions", & + default=NONE_STRING) + tmpstr = uppercase(tmpstr) + select case (tmpstr) + case (NONE_STRING) + CS%LT_enhance_form = No_Langmuir + case (RESCALED_STRING) + CS%LT_enhance_form = Langmuir_rescale + case (ADDITIVE_STRING) + CS%LT_enhance_form = Langmuir_add + case default + call MOM_mesg('energetic_PBL_init: EPBL_LANGMUIR_SCHEME ="'//trim(tmpstr)//'"', 0) + call MOM_error(FATAL, "energetic_PBL_init: Unrecognized setting "// & + "EPBL_LANGMUIR_SCHEME = "//trim(tmpstr)//" found in input file.") + end select + + call get_param(param_file, mdl, "LT_ENHANCE_COEF", CS%LT_ENHANCE_COEF, & + "Coefficient for Langmuir enhancement of mstar", & + units="nondim", default=0.447, do_not_log=(CS%LT_enhance_form==No_Langmuir)) + call get_param(param_file, mdl, "LT_ENHANCE_EXP", CS%LT_ENHANCE_EXP, & + "Exponent for Langmuir enhancementt of mstar", & + units="nondim", default=-1.33, do_not_log=(CS%LT_enhance_form==No_Langmuir)) + call get_param(param_file, mdl, "LT_MOD_LAC1", CS%LaC_MLDoEK, & + "Coefficient for modification of Langmuir number due to "//& + "MLD approaching Ekman depth.", & + units="nondim", default=-0.87, do_not_log=(CS%LT_enhance_form==No_Langmuir)) + call get_param(param_file, mdl, "LT_MOD_LAC2", CS%LaC_MLDoOB_stab, & + "Coefficient for modification of Langmuir number due to "//& + "MLD approaching stable Obukhov depth.", & + units="nondim", default=0.0, do_not_log=(CS%LT_enhance_form==No_Langmuir)) + call get_param(param_file, mdl, "LT_MOD_LAC3", CS%LaC_MLDoOB_un, & + "Coefficient for modification of Langmuir number due to "//& + "MLD approaching unstable Obukhov depth.", & + units="nondim", default=0.0, do_not_log=(CS%LT_enhance_form==No_Langmuir)) + call get_param(param_file, mdl, "LT_MOD_LAC4", CS%Lac_EKoOB_stab, & + "Coefficient for modification of Langmuir number due to "//& + "ratio of Ekman to stable Obukhov depth.", & + units="nondim", default=0.95, do_not_log=(CS%LT_enhance_form==No_Langmuir)) + call get_param(param_file, mdl, "LT_MOD_LAC5", CS%Lac_EKoOB_un, & + "Coefficient for modification of Langmuir number due to "//& + "ratio of Ekman to unstable Obukhov depth.", & + units="nondim", default=0.95, do_not_log=(CS%LT_enhance_form==No_Langmuir)) + endif + + +!/ Logging parameters + ! This gives a minimum decay scale that is typically much less than Angstrom. + CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%dZ_subroundoff) + call log_param(param_file, mdl, "!EPBL_USTAR_MIN", CS%ustar_min, & + "The (tiny) minimum friction velocity used within the "//& + "ePBL code, derived from OMEGA and ANGSTROM.", & + units="m s-1", unscale=US%Z_to_m*US%s_to_T, & + like_default=.true.) + + +!/ Checking output flags + CS%id_ML_depth = register_diag_field('ocean_model', 'ePBL_h_ML', diag%axesT1, & + Time, 'Surface boundary layer depth', 'm', conversion=US%Z_to_m, & + cmor_long_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') + ! This is an alias for the same variable as ePBL_h_ML + CS%id_hML_depth = register_diag_field('ocean_model', 'h_ML', diag%axesT1, & + Time, 'Surface mixed layer depth based on active turbulence', 'm', conversion=US%Z_to_m) + CS%id_TKE_wind = register_diag_field('ocean_model', 'ePBL_TKE_wind', diag%axesT1, & + Time, 'Wind-stirring source of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_TKE_MKE = register_diag_field('ocean_model', 'ePBL_TKE_MKE', diag%axesT1, & + Time, 'Mean kinetic energy source of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_TKE_conv = register_diag_field('ocean_model', 'ePBL_TKE_conv', diag%axesT1, & + Time, 'Convective source of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_TKE_forcing = register_diag_field('ocean_model', 'ePBL_TKE_forcing', diag%axesT1, & + Time, 'TKE consumed by mixing surface forcing or penetrative shortwave radation '//& + 'through model layers', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_TKE_mixing = register_diag_field('ocean_model', 'ePBL_TKE_mixing', diag%axesT1, & + Time, 'TKE consumed by mixing that deepens the mixed layer', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_TKE_mech_decay = register_diag_field('ocean_model', 'ePBL_TKE_mech_decay', diag%axesT1, & + Time, 'Mechanical energy decay sink of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_TKE_conv_decay = register_diag_field('ocean_model', 'ePBL_TKE_conv_decay', diag%axesT1, & + Time, 'Convective energy decay sink of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_Mixing_Length = register_diag_field('ocean_model', 'Mixing_Length', diag%axesTi, & + Time, 'Mixing Length that is used', 'm', conversion=US%Z_to_m) + CS%id_Velocity_Scale = register_diag_field('ocean_model', 'Velocity_Scale', diag%axesTi, & + Time, 'Velocity Scale that is used.', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + CS%id_MSTAR_mix = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & + Time, 'Total mstar that is used.', 'nondim') + if (CS%use_LT) then + CS%id_LA = register_diag_field('ocean_model', 'LA', diag%axesT1, & + Time, 'Langmuir number.', 'nondim') + CS%id_LA_mod = register_diag_field('ocean_model', 'LA_MOD', diag%axesT1, & + Time, 'Modified Langmuir number.', 'nondim') + CS%id_MSTAR_LT = register_diag_field('ocean_model', 'MSTAR_LT', diag%axesT1, & + Time, 'Increase in mstar due to Langmuir Turbulence.', 'nondim') + endif + + call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & + "If true, temperature and salinity are used as state "//& + "variables.", default=.true.) + + if (report_avg_its) then + CS%sum_its(1) = real_to_EFP(0.0) ; CS%sum_its(2) = real_to_EFP(0.0) + endif + + if (max(CS%id_TKE_wind, CS%id_TKE_MKE, CS%id_TKE_conv, & + CS%id_TKE_mixing, CS%id_TKE_mech_decay, CS%id_TKE_forcing, & + CS%id_TKE_conv_decay) > 0) then + call safe_alloc_alloc(CS%diag_TKE_wind, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_MKE, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_conv, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_forcing, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_mixing, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_mech_decay, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%diag_TKE_conv_decay, isd, ied, jsd, jed) + + CS%TKE_diagnostics = .true. + endif + if (CS%id_Velocity_Scale>0) call safe_alloc_alloc(CS%Velocity_Scale, isd, ied, jsd, jed, GV%ke+1) + if (CS%id_Mixing_Length>0) call safe_alloc_alloc(CS%Mixing_Length, isd, ied, jsd, jed, GV%ke+1) + + call safe_alloc_alloc(CS%ML_depth, isd, ied, jsd, jed) + if (max(CS%id_mstar_mix, CS%id_LA, CS%id_LA_mod, CS%id_MSTAR_LT ) >0) then + call safe_alloc_alloc(CS%Mstar_mix, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%LA, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%LA_MOD, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%MSTAR_LT, isd, ied, jsd, jed) + endif + +end subroutine energetic_PBL_init + +!> Clean up and deallocate memory associated with the energetic_PBL module. +subroutine energetic_PBL_end(CS) + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic_PBL control structure + + character(len=256) :: mesg + real :: avg_its ! The averaged number of iterations used by ePBL [nondim] + + if (allocated(CS%ML_depth)) deallocate(CS%ML_depth) + if (allocated(CS%LA)) deallocate(CS%LA) + if (allocated(CS%LA_MOD)) deallocate(CS%LA_MOD) + if (allocated(CS%MSTAR_MIX)) deallocate(CS%MSTAR_MIX) + if (allocated(CS%MSTAR_LT)) deallocate(CS%MSTAR_LT) + if (allocated(CS%diag_TKE_wind)) deallocate(CS%diag_TKE_wind) + if (allocated(CS%diag_TKE_MKE)) deallocate(CS%diag_TKE_MKE) + if (allocated(CS%diag_TKE_conv)) deallocate(CS%diag_TKE_conv) + if (allocated(CS%diag_TKE_forcing)) deallocate(CS%diag_TKE_forcing) + if (allocated(CS%diag_TKE_mixing)) deallocate(CS%diag_TKE_mixing) + if (allocated(CS%diag_TKE_mech_decay)) deallocate(CS%diag_TKE_mech_decay) + if (allocated(CS%diag_TKE_conv_decay)) deallocate(CS%diag_TKE_conv_decay) + if (allocated(CS%Mixing_Length)) deallocate(CS%Mixing_Length) + if (allocated(CS%Velocity_Scale)) deallocate(CS%Velocity_Scale) + + if (report_avg_its) then + call EFP_sum_across_PEs(CS%sum_its, 2) + + avg_its = EFP_to_real(CS%sum_its(1)) / EFP_to_real(CS%sum_its(2)) + write (mesg,*) "Average ePBL iterations = ", avg_its + call MOM_mesg(mesg) + endif +end subroutine energetic_PBL_end + +!> \namespace MOM_energetic_PBL +!! +!! By Robert Hallberg, 2015. +!! +!! This file contains the subroutine (energetic_PBL) that uses an +!! integrated boundary layer energy budget (like a bulk- or refined- +!! bulk mixed layer scheme), but instead of homogenizing this model +!! calculates a finite diffusivity and viscosity, which in this +!! regard is conceptually similar to what is done with KPP or various +!! two-equation closures. However, the scheme that is implemented +!! here has the big advantage that is entirely implicit, but is +!! simple enough that it requires only a single vertical pass to +!! determine the diffusivity. The development of bulk mixed layer +!! models stems from the work of various people, as described in the +!! review paper by \cite niiler1977. The work here draws in +!! with particular on the form for TKE decay proposed by +!! \cite oberhuber1993, with an extension to a refined bulk mixed +!! layer as described in Hallberg (\cite muller2003). The physical +!! processes portrayed in this subroutine include convectively driven +!! mixing and mechanically driven mixing. Unlike boundary-layer +!! mixing, stratified shear mixing is not a one-directional turbulent +!! process, and it is dealt with elsewhere in the MOM6 code within +!! the module MOM_kappa_shear.F90. It is assumed that the heat, +!! mass, and salt fluxes have been applied elsewhere, but that their +!! implications for the integrated TKE budget have been captured in +!! an array that is provided as an argument to this subroutine. This +!! is a full 3-d array due to the effects of penetrating shortwave +!! radiation. + +end module MOM_energetic_PBL diff --git a/parameterizations/vertical/MOM_entrain_diffusive.F90 b/parameterizations/vertical/MOM_entrain_diffusive.F90 new file mode 100644 index 0000000000..de13322652 --- /dev/null +++ b/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -0,0 +1,2193 @@ +!> Diapycnal mixing and advection in isopycnal mode +module MOM_entrain_diffusive + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_specific_vol_derivs, EOS_domain +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public entrainment_diffusive, entrain_diffusive_init + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> The control structure holding parametes for the MOM_entrain_diffusive module +type, public :: entrain_diffusive_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with + !! GV%nk_rho_varies variable density mixed & buffer layers. + integer :: max_ent_it !< The maximum number of iterations that may be used to + !! calculate the diapycnal entrainment. + real :: Tolerance_Ent !< The tolerance with which to solve for entrainment values + !! [H ~> m or kg m-2]. + real :: max_Ent !< A large ceiling on the maximum permitted amount of entrainment + !! across each interface between the mixed and buffer layers within + !! a timestep [H ~> m or kg m-2]. + real :: Rho_sig_off !< The offset between potential density and a sigma value [R ~> kg m-3] + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + integer :: id_Kd = -1 !< Diagnostic ID for diffusivity + integer :: id_diff_work = -1 !< Diagnostic ID for mixing work +end type entrain_diffusive_CS + +contains + +!> This subroutine calculates ea and eb, the rates at which a layer entrains +!! from the layers above and below. The entrainment rates are proportional to +!! the buoyancy flux in a layer and inversely proportional to the density +!! differences between layers. The scheme that is used here is described in +!! detail in Hallberg, Mon. Wea. Rev. 2000. +subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & + kb_out, Kd_Lay, Kd_int) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields. Absent fields have NULL + !! ptrs. + type(forcing), intent(in) :: fluxes !< A structure of surface fluxes that may + !! be used. + real, intent(in) :: dt !< The time increment [T ~> s]. + type(entrain_diffusive_CS), intent(in) :: CS !< The control structure returned by a previous + !! call to entrain_diffusive_init. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: ea !< The amount of fluid entrained from the layer + !! above within this time step [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: eb !< The amount of fluid entrained from the layer + !! below within this time step [H ~> m or kg m-2]. + integer, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: kb_out !< The index of the lightest layer denser than + !! the buffer layer. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + +! This subroutine calculates ea and eb, the rates at which a layer entrains +! from the layers above and below. The entrainment rates are proportional to +! the buoyancy flux in a layer and inversely proportional to the density +! differences between layers. The scheme that is used here is described in +! detail in Hallberg, Mon. Wea. Rev. 2000. + + real, dimension(SZI_(G),SZK_(GV)) :: & + dtKd ! The layer diapycnal diffusivity times the time step [H2 ~> m2 or kg2 m-4]. + real, dimension(SZI_(G),SZK_(GV)+1) :: & + dtKd_int ! The diapycnal diffusivity at the interfaces times the time step [H2 ~> m2 or kg2 m-4] + real, dimension(SZI_(G),SZK_(GV)) :: & + F, & ! The density flux through a layer within a time step divided by the + ! density difference across the interface below the layer [H ~> m or kg m-2]. + maxF, & ! maxF is the maximum value of F that will not deplete all of the + ! layers above or below a layer within a timestep [H ~> m or kg m-2]. + minF, & ! minF is the minimum flux that should be expected in the absence of + ! interactions between layers [H ~> m or kg m-2]. + Fprev, &! The previous estimate of F [H ~> m or kg m-2]. + dFdfm, &! The partial derivative of F with respect to changes in F of the + ! neighboring layers. [nondim] + h_guess ! An estimate of the layer thicknesses after entrainment, but + ! before the entrainments are adjusted to drive the layer + ! densities toward their target values [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)+1) :: & + Ent_bl ! The average entrainment upward and downward across + ! each interface around the buffer layers [H ~> m or kg m-2]. + real, allocatable, dimension(:,:,:) :: & + Kd_eff, & ! The effective diffusivity that actually applies to each + ! layer after the effects of boundary conditions are + ! considered [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + diff_work ! The work actually done by diffusion across each + ! interface [R Z3 T-3 ~> W m-2]. Sum vertically for the total work. + + real :: hm, fm, fr ! Work variables with units of [H ~> m or kg m-2]. + real :: fk ! A Work variable with units of [H2 ~> m2 or kg2 m-4] + + real :: b1(SZI_(G)) ! A variable used by the tridiagonal solver [H ~> m or kg m-2] + real :: c1(SZI_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim] + + real, dimension(SZI_(G)) :: & + htot, & ! The total thickness above or below a layer [H ~> m or kg m-2]. + Rcv, & ! Value of the coordinate variable (potential density) + ! based on the simulated T and S and P_Ref [R ~> kg m-3]. + pres, & ! Reference pressure (P_Ref) [R L2 T-2 ~> Pa]. + eakb, & ! The entrainment from above by the layer below the buffer + ! layer (i.e. layer kb) [H ~> m or kg m-2]. + ea_kbp1, & ! The entrainment from above by layer kb+1 [H ~> m or kg m-2]. + eb_kmb, & ! The entrainment from below by the deepest buffer layer [H ~> m or kg m-2]. + dS_kb, & ! The reference potential density difference across the + ! interface between the buffer layers and layer kb [R ~> kg m-3]. + dS_anom_lim, &! The amount by which dS_kb is reduced when limits are + ! applied [R ~> kg m-3]. + I_dSkbp1, & ! The inverse of the potential density difference across the + ! interface below layer kb [R-1 ~> m3 kg-1]. + dtKd_kb, & ! The diapycnal diffusivity in layer kb times the time step + ! [H2 ~> m2 or kg2 m-4]. + maxF_correct, & ! An amount by which to correct maxF due to excessive + ! surface heat loss [H ~> m or kg m-2]. + zeros, & ! An array of all zeros. (Usually used with [H ~> m or kg m-2].) + max_eakb, & ! The maximum value of eakb that might be realized [H ~> m or kg m-2]. + min_eakb, & ! The minimum value of eakb that might be realized [H ~> m or kg m-2]. + err_max_eakb0, & ! The value of error returned by determine_Ea_kb when eakb = max_eakb + ! and ea_kbp1 = 0 [H2 ~> m2 or kg2 m-4]. + err_min_eakb0, & ! The value of error returned by determine_Ea_kb when eakb = min_eakb + ! and ea_kbp1 = 0 [H2 ~> m2 or kg2 m-4]. + err_eakb0, & ! A value of error returned by determine_Ea_kb [H2 ~> m2 or kg2 m-4]. + F_kb, & ! The value of F in layer kb, or equivalently the entrainment + ! from below by layer kb [H ~> m or kg m-2]. + dFdfm_kb, & ! The partial derivative of F with fm [nondim]. See dFdfm. + maxF_kb, & ! The maximum value of F_kb that might be realized [H ~> m or kg m-2]. + eakb_maxF, & ! The value of eakb that gives F_kb=maxF_kb [H ~> m or kg m-2]. + F_kb_maxEnt ! The value of F_kb when eakb = max_eakb [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)) :: & + Sref, & ! The reference potential density of the mixed and buffer layers, + ! and of the two lightest interior layers (kb and kb+1) copied + ! into layers kmb+1 and kmb+2 [R ~> kg m-3]. + h_bl ! The thicknesses of the mixed and buffer layers, and of the two + ! lightest interior layers (kb and kb+1) copied into layers kmb+1 + ! and kmb+2 [H ~> m or kg m-2]. + + real, dimension(SZI_(G),SZK_(GV)) :: & + ds_dsp1, & ! The coordinate variable (sigma-2) difference across an + ! interface divided by the difference across the interface + ! below it. [nondim] + dsp1_ds, & ! The inverse coordinate variable (sigma-2) difference + ! across an interface times the difference across the + ! interface above it. [nondim] + I2p2dsp1_ds, & ! 1 / (2 + 2 * ds_k+1 / ds_k). [nondim] + grats ! 2*(2 + ds_k+1 / ds_k + ds_k / ds_k+1) = + ! 4*ds_Lay*(1/ds_k + 1/ds_k+1). [nondim] + + real :: dRho ! The change in locally referenced potential density between + ! the layers above and below an interface [R ~> kg m-3] + real :: dSpV ! The change in locally referenced specific volume between + ! the layers above and below an interface [R-1 ~> m3 kg-1] + real :: g_2dt ! 0.5 * G_Earth / dt, times unit conversion factors + ! [Z3 H-2 T-3 or R2 Z3 H-2 T-3 ~> m s-3]. + real, dimension(SZI_(G)) :: & + pressure, & ! The pressure at an interface [R L2 T-2 ~> Pa]. + T_eos, S_eos, & ! The potential temperature and salinity at which to + ! evaluate dRho_dT and dRho_dS [C ~> degC] and [S ~> ppt]. + dRho_dT, & ! The partial derivative of potential density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & ! The partial derivative of potential density with salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS ! The partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + + real :: tolerance ! The tolerance within which E must be converged [H ~> m or kg m-2]. + real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: F_cor ! A correction to the amount of F that is used to + ! entrain from the layer above [H ~> m or kg m-2]. + real :: Kd_here ! The effective diapycnal diffusivity times the timestep [H2 ~> m2 or kg2 m-4]. + real :: h_avail ! The thickness that is available for entrainment [H ~> m or kg m-2]. + real :: dS_kb_eff ! The value of dS_kb after limiting is taken into account [R ~> kg m-3]. + real :: Rho_cor ! The depth-integrated potential density anomaly that + ! needs to be corrected for [H R ~> kg m-2 or kg2 m-5]. + real :: ea_cor ! The corrective adjustment to eakb [H ~> m or kg m-2]. + real :: h1 ! The layer thickness after entrainment through the + ! interface below is taken into account [H ~> m or kg m-2]. + real :: Idt ! The inverse of the time step [Z H-1 T-1 ~> s-1 or m3 kg-1 s-1]. + + logical :: do_any + logical :: do_entrain_eakb ! True if buffer layer is entrained + logical :: do_i(SZI_(G)), did_i(SZI_(G)), reiterate + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: it, i, j, k, is, ie, js, je, nz, K2, kmb + integer :: kb(SZI_(G)) ! The value of kb in row j. + integer :: kb_min ! The minimum value of kb in the current j-row. + integer :: kb_min_act ! The minimum active value of kb in the current j-row. + integer :: is1, ie1 ! The minimum and maximum active values of i in the current j-row. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Angstrom = GV%Angstrom_H + h_neglect = GV%H_subroundoff + + if (.not. CS%initialized) call MOM_error(FATAL, & + "MOM_entrain_diffusive: Module must be initialized before it is used.") + + if ((.not.CS%bulkmixedlayer .and. .not.associated(fluxes%buoy)) .and. & + (associated(fluxes%lprec) .or. associated(fluxes%evap) .or. & + associated(fluxes%sens) .or. associated(fluxes%sw))) then + if (is_root_pe()) call MOM_error(NOTE, "Calculate_Entrainment: & + &The code to handle evaporation and precipitation without & + &a bulk mixed layer has not been implemented.") + if (is_root_pe()) call MOM_error(FATAL, & + "Either define BULKMIXEDLAYER in MOM_input or use fluxes%buoy & + &and a linear equation of state to drive the model.") + endif + + tolerance = CS%Tolerance_Ent + kmb = GV%nk_rho_varies + K2 = max(kmb+1,2) ; kb_min = K2 + if (.not. CS%bulkmixedlayer) then + kb(:) = 1 + ! These lines fill in values that are arbitrary, but needed because + ! they are used to normalize the buoyancy flux in layer nz. + do i=is,ie ; ds_dsp1(i,nz) = 2.0 ; dsp1_ds(i,nz) = 0.5 ; enddo + else + kb(:) = 0 + do i=is,ie ; ds_dsp1(i,nz) = 0.0 ; dsp1_ds(i,nz) = 0.0 ; enddo + endif + + if (CS%id_diff_work > 0) allocate(diff_work(G%isd:G%ied,G%jsd:G%jed,nz+1)) + if (CS%id_Kd > 0) allocate(Kd_eff(G%isd:G%ied,G%jsd:G%jed,nz)) + + if (associated(tv%eqn_of_state)) then + pres(:) = tv%P_Ref + else + pres(:) = 0.0 + endif + EOSdom(:) = EOS_domain(G%HI) + + !$OMP parallel do default(private) shared(is,ie,js,je,nz,Kd_Lay,G,GV,US,dt,CS,h,tv, & + !$OMP kmb,Angstrom,fluxes,K2,h_neglect,tolerance, & + !$OMP ea,eb,Kd_int,Kd_eff,EOSdom,diff_work,g_2dt, kb_out) & + !$OMP firstprivate(kb,ds_dsp1,dsp1_ds,pres,kb_min) + do j=js,je + do i=is,ie ; kb(i) = 1 ; enddo + + if (allocated(tv%SpV_avg)) then + do k=1,nz ; do i=is,ie + dtKd(i,k) = GV%RZ_to_H * (dt * Kd_lay(i,j,k)) / tv%SpV_avg(i,j,k) + enddo ; enddo + do i=is,ie + dtKd_int(i,1) = GV%RZ_to_H * (dt * Kd_int(i,j,1)) / tv%SpV_avg(i,j,1) + dtKd_int(i,nz+1) = GV%RZ_to_H * (dt * Kd_int(i,j,nz+1)) / tv%SpV_avg(i,j,nz) + enddo + ! Use the mass-weighted average specific volume to translate thicknesses to verti distances. + do K=2,nz ; do i=is,ie + dtKd_int(i,K) = GV%RZ_to_H * (dt * Kd_int(i,j,K)) * & + ( (h(i,j,k-1) + h(i,j,k) + 2.0*h_neglect) / & + ((h(i,j,k-1)+h_neglect) * tv%SpV_avg(i,j,k-1) + & + (h(i,j,k)+h_neglect) * tv%SpV_avg(i,j,k)) ) + enddo ; enddo + else + do k=1,nz ; do i=is,ie + dtKd(i,k) = GV%Z_to_H * (dt * Kd_lay(i,j,k)) + enddo ; enddo + do K=1,nz+1 ; do i=is,ie + dtKd_int(i,K) = GV%Z_to_H * (dt * Kd_int(i,j,K)) + enddo ; enddo + endif + + 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 + + if (GV%Boussinesq .or. GV%Semi_Boussinesq) then + do k=2,nz-1 ; do i=is,ie + ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) + enddo ; enddo + else ! Use a mathematically equivalent form that avoids any dependency on RHO_0. + do k=2,nz-1 ; do i=is,ie + ds_dsp1(i,k) = (GV%Rlay(k) - GV%Rlay(k-1)) / (GV%Rlay(k+1) - GV%Rlay(k)) + enddo ; enddo + endif + + if (CS%bulkmixedlayer) then + ! This subroutine determines the averaged entrainment across each + ! interface and causes thin and relatively light interior layers to be + ! entrained by the deepest buffer layer. This also determines kb. + call set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, Sref, h_bl) + + do i=is,ie + dtKd_kb(i) = 0.0 ; if (kb(i) < nz) dtKd_kb(i) = dtKd(i,kb(i)) + enddo + else + do i=is,ie ; Ent_bl(i,Kmb+1) = 0.0 ; enddo + endif + + do k=2,nz-1 ; do i=is,ie + dsp1_ds(i,k) = 1.0 / ds_dsp1(i,k) + I2p2dsp1_ds(i,k) = 0.5/(1.0+dsp1_ds(i,k)) + grats(i,k) = 2.0*(2.0+(dsp1_ds(i,k)+ds_dsp1(i,k))) + enddo ; enddo + +! Determine the maximum flux, maxF, for each of the isopycnal layers. +! Also determine when the fluxes start entraining +! from various buffer or mixed layers, where appropriate. + if (CS%bulkmixedlayer) then + kb_min = nz + do i=is,ie + htot(i) = h(i,j,1) - Angstrom + enddo + do k=2,kmb ; do i=is,ie + htot(i) = htot(i) + (h(i,j,k) - Angstrom) + enddo ; enddo + do i=is,ie + max_eakb(i) = MAX(Ent_bl(i,Kmb+1) + 0.5*htot(i), htot(i)) + I_dSkbp1(i) = 1.0 / (Sref(i,kmb+2) - Sref(i,kmb+1)) + zeros(i) = 0.0 + enddo + + ! Find the maximum amount of entrainment from below that the top + ! interior layer could exhibit (maxF(i,kb)), approximating that + ! entrainment by (eakb*max(dS_kb/dSkbp1,0)). eakb is in the range + ! from 0 to max_eakb. + call find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, zeros, max_eakb, kmb, & + is, ie, G, GV, CS, maxF_kb, eakb_maxF, do_i, F_kb_maxent) + do i=is,ie ; if (kb(i) <= nz) then + maxF(i,kb(i)) = MAX(0.0, maxF_kb(i), F_kb_maxent(i)) + if ((maxF_kb(i) > F_kb_maxent(i)) .and. (eakb_maxF(i) >= htot(i))) & + max_eakb(i) = eakb_maxF(i) + endif ; enddo + + do i=is,ie ; ea_kbp1(i) = 0.0 ; eakb(i) = max_eakb(i) ; enddo + call determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & + max_eakb, max_eakb, kmb, is, ie, do_i, G, GV, CS, eakb, & + error=err_max_eakb0, F_kb=F_kb) + + ! The maximum value of F(kb) between htot and max_eakb determines + ! what maxF(kb+1) should be. + do i=is,ie ; min_eakb(i) = MIN(htot(i), max_eakb(i)) ; enddo + call find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_eakb, max_eakb, & + kmb, is, ie, G, GV, CS, F_kb_maxEnt, do_i_in=do_i) + + do i=is,ie + do_entrain_eakb = .false. + ! If error_max_eakb0 < 0, then buffer layers are always all entrained + if (do_i(i)) then ; if (err_max_eakb0(i) < 0.0) then + do_entrain_eakb = .true. + endif ; endif + + if (do_entrain_eakb) then + eakb(i) = max_eakb(i) ; min_eakb(i) = max_eakb(i) + else + eakb(i) = 0.0 ; min_eakb(i) = 0.0 + endif + enddo + + ! Find the amount of entrainment of the buffer layers that would occur + ! if there were no entrainment by the deeper interior layers. Also find + ! how much entrainment of the deeper layers would occur. + call determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & + zeros, max_eakb, kmb, is, ie, do_i, G, GV, CS, min_eakb, & + error=err_min_eakb0, F_kb=F_kb, err_max_eakb0=err_max_eakb0) + ! Error_min_eakb0 should be ~0 unless error_max_eakb0 < 0. + do i=is,ie ; if ((kb(i)kb(i))) kb_min = kb(i) ; enddo + else + ! Without a bulk mixed layer, surface fluxes are applied in this + ! subroutine. (Otherwise, they are handled in mixedlayer.) + ! Initially the maximum flux in layer zero is given by the surface + ! buoyancy flux. It will later be limited if the surface flux is + ! too large. Here buoy is the surface buoyancy flux. + do i=is,ie + maxF(i,1) = 0.0 + htot(i) = h(i,j,1) - Angstrom + enddo + if (associated(fluxes%buoy) .and. GV%Boussinesq) then + do i=is,ie + maxF(i,1) = GV%Z_to_H * (dt*fluxes%buoy(i,j)) / GV%g_prime(2) + enddo + elseif (associated(fluxes%buoy)) then + do i=is,ie + maxF(i,1) = (GV%RZ_to_H * 0.5*(GV%Rlay(1) + GV%Rlay(2)) * (dt*fluxes%buoy(i,j))) / & + GV%g_prime(2) + enddo + endif + endif + +! The following code calculates the maximum flux, maxF, for the interior +! layers. + do k=kb_min,nz-1 ; do i=is,ie + if ((k == kb(i)+1) .and. CS%bulkmixedlayer) then + maxF(i,k) = ds_dsp1(i,k)*(F_kb_maxEnt(i) + htot(i)) + htot(i) = htot(i) + (h(i,j,k) - Angstrom) + elseif (k > kb(i)) then + maxF(i,k) = ds_dsp1(i,k)*(maxF(i,k-1) + htot(i)) + htot(i) = htot(i) + (h(i,j,k) - Angstrom) + endif + enddo ; enddo + do i=is,ie + maxF(i,nz) = 0.0 + if (.not.CS%bulkmixedlayer) then + maxF_correct(i) = MAX(0.0, -(maxF(i,nz-1) + htot(i))) + endif + htot(i) = h(i,j,nz) - Angstrom + enddo + if (.not.CS%bulkmixedlayer) then + do_any = .false. ; do i=is,ie ; if (maxF_correct(i) > 0.0) do_any = .true. ; enddo + if (do_any) then + do k=nz-1,1,-1 ; do i=is,ie + maxF(i,k) = maxF(i,k) + maxF_correct(i) + maxF_correct(i) = maxF_correct(i) * dsp1_ds(i,k) + enddo ; enddo + endif + endif + do k=nz-1,kb_min,-1 ; do i=is,ie ; if (do_i(i)) then + if (k >= kb(i)) then + maxF(i,k) = MIN(maxF(i,k),dsp1_ds(i,k+1)*maxF(i,k+1) + htot(i)) + htot(i) = htot(i) + (h(i,j,k) - Angstrom) + endif + if (k == kb(i)) then + if ((maxF(i,k) < F_kb(i)) .or. (maxF(i,k) < maxF_kb(i)) & + .and. (eakb_maxF(i) <= max_eakb(i))) then + ! In this case, too much was being entrained by the topmost interior + ! layer, even with the minimum initial estimate. The buffer layer + ! will always entrain the maximum amount. + F_kb(i) = maxF(i,k) + if ((F_kb(i) <= maxF_kb(i)) .and. (eakb_maxF(i) <= max_eakb(i))) then + eakb(i) = eakb_maxF(i) + else + eakb(i) = max_eakb(i) + endif + call F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & + G, GV, CS, eakb, Angstrom) + if ((eakb(i) < max_eakb(i)) .or. (eakb(i) < min_eakb(i))) then + call determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, zeros, & + eakb, eakb, kmb, i, i, do_i, G, GV, CS, eakb, & + error=err_eakb0) + if (eakb(i) < max_eakb(i)) then + max_eakb(i) = eakb(i) ; err_max_eakb0(i) = err_eakb0(i) + endif + if (eakb(i) < min_eakb(i)) then + min_eakb(i) = eakb(i) ; err_min_eakb0(i) = err_eakb0(i) + endif + endif + endif + endif + endif ; enddo ; enddo + if (.not.CS%bulkmixedlayer) then + do i=is,ie + maxF(i,1) = MIN(maxF(i,1),dsp1_ds(i,2)*maxF(i,2) + htot(i)) + enddo + endif + +! The following code provides an initial estimate of the flux in +! each layer, F. The initial guess for the layer diffusive flux is +! the smaller of a forward discretization or the maximum diffusive +! flux starting from zero thickness in one time step without +! considering adjacent layers. + do i=is,ie + F(i,1) = maxF(i,1) + F(i,nz) = maxF(i,nz) ; minF(i,nz) = 0.0 + enddo + do k=nz-1,K2,-1 + do i=is,ie + if ((k==kb(i)) .and. (do_i(i))) then + eakb(i) = min_eakb(i) + minF(i,k) = 0.0 + elseif ((k>kb(i)) .and. (do_i(i))) then +! Here the layer flux is estimated, assuming no entrainment from +! the surrounding layers. The estimate is a forward (steady) flux, +! limited by the maximum flux for a layer starting with zero +! thickness. This is often a good guess and leads to few iterations. + hm = h(i,j,k) + h_neglect + ! Note: Tried sqrt((0.5*ds_dsp1(i,k))*dtKd(i,k)) for the second limit, + ! but it usually doesn't work as well. + F(i,k) = MIN(maxF(i,k), sqrt(ds_dsp1(i,k)*dtKd(i,k)), & + 0.5*(ds_dsp1(i,k)+1.0) * (dtKd(i,k) / hm)) + +! Calculate the minimum flux that can be expected if there is no entrainment +! from the neighboring layers. The 0.9 is used to give used to give a 10% +! known error tolerance. + fk = dtKd(i,k) * grats(i,k) + minF(i,k) = MIN(maxF(i,k), & + 0.9*(I2p2dsp1_ds(i,k) * fk / (hm + sqrt(hm*hm + fk)))) + if (k==kb(i)) minF(i,k) = 0.0 ! BACKWARD COMPATIBILITY - DELETE LATER? + else + F(i,k) = 0.0 + minF(i,k) = 0.0 + endif + enddo ! end of i loop + enddo ! end of k loop + + ! This is where the fluxes are actually calculated. + + is1 = ie+1 ; ie1 = is-1 + do i=is,ie ; if (do_i(i)) then ; is1 = i ; exit ; endif ; enddo + do i=ie,is,-1 ; if (do_i(i)) then ; ie1 = i ; exit ; endif ; enddo + + if (CS%bulkmixedlayer) then + kb_min_act = nz + do i=is,ie + if (do_i(i) .and. (kb(i) < kb_min_act)) kb_min_act = kb(i) + enddo + ! Solve for the entrainment rate from above in the topmost interior + ! layer, eakb, such that + ! eakb*dS_implicit = dt*Kd*dS_layer_implicit / h_implicit. + do i=is1,ie1 + ea_kbp1(i) = 0.0 + if (do_i(i) .and. (kb(i) < nz)) & + ea_kbp1(i) = dsp1_ds(i,kb(i)+1)*F(i,kb(i)+1) + enddo + call determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, min_eakb, & + max_eakb, kmb, is1, ie1, do_i, G, GV, CS, eakb, F_kb=F_kb, & + err_max_eakb0=err_max_eakb0, err_min_eakb0=err_min_eakb0, & + dFdfm_kb=dFdfm_kb) + else + kb_min_act = kb_min + endif + + do it=0,CS%max_ent_it-1 + do i=is1,ie1 ; if (do_i(i)) then + if (.not.CS%bulkmixedlayer) F(i,1) = MIN(F(i,1),maxF(i,1)) + b1(i) = 1.0 + endif ; enddo ! end of i loop + + ! F_kb has already been found for this iteration, either above or at + ! the end of the code for the previous iteration. + do k=kb_min_act,nz-1 ; do i=is1,ie1 ; if (do_i(i) .and. (k>=kb(i))) then + ! Calculate the flux in layer k. + if (CS%bulkmixedlayer .and. (k==kb(i))) then + F(i,k) = F_kb(i) + dFdfm(i,k) = dFdfm_kb(i) + else ! k > kb(i) + Fprev(i,k) = F(i,k) + fm = (F(i,k-1) - h(i,j,k)) + dsp1_ds(i,k+1)*F(i,k+1) + fk = grats(i,k)*dtKd(i,k) + fr = sqrt(fm*fm + fk) + + if (fm>=0) then + F(i,k) = MIN(maxF(i,k), I2p2dsp1_ds(i,k) * (fm+fr)) + else + F(i,k) = MIN(maxF(i,k), I2p2dsp1_ds(i,k) * (fk / (-1.0*fm+fr))) + endif + + if ((F(i,k) >= maxF(i,k)) .or. (fr == 0.0)) then + dFdfm(i,k) = 0.0 + else + dFdfm(i,k) = I2p2dsp1_ds(i,k) * ((fr + fm) / fr) + endif + + if (k > K2) then + ! This is part of a tridiagonal solver for the actual flux. + c1(i,k) = dFdfm(i,k-1)*(dsp1_ds(i,k)*b1(i)) + b1(i) = 1.0 / (1.0 - c1(i,k)*dFdfm(i,k)) + F(i,k) = MIN(b1(i)*(F(i,k)-Fprev(i,k)) + Fprev(i,k), maxF(i,k)) + if (F(i,k) >= maxF(i,k)) dFdfm(i,k) = 0.0 + endif + endif + endif ; enddo ; enddo + + do k=nz-2,kb_min_act,-1 ; do i=is1,ie1 + if (do_i(i) .and. (k > kb(i))) & + F(i,k) = MIN((F(i,k)+c1(i,k+1)*(F(i,k+1)-Fprev(i,k+1))),maxF(i,k)) + enddo ; enddo + + if (CS%bulkmixedlayer) then + do i=is1,ie1 + if (do_i(i) .and. (kb(i) < nz)) then + ! F will be increased to minF later. + ea_kbp1(i) = dsp1_ds(i,kb(i)+1)*max(F(i,kb(i)+1), minF(i,kb(i)+1)) + else + ea_kbp1(i) = 0.0 + endif + enddo + call determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, min_eakb, & + max_eakb, kmb, is1, ie1, do_i, G, GV, CS, eakb, F_kb=F_kb, & + err_max_eakb0=err_max_eakb0, err_min_eakb0=err_min_eakb0, & + dFdfm_kb=dFdfm_kb) + do i=is1,ie1 + if (do_i(i) .and. (kb(i) < nz)) F(i,kb(i)) = F_kb(i) + enddo + endif + +! Determine whether to do another iteration. + if (it < CS%max_ent_it-1) then + + reiterate = .false. + if (CS%bulkmixedlayer) then ; do i=is1,ie1 ; if (do_i(i)) then + eb_kmb(i) = max(2.0*Ent_bl(i,Kmb+1) - eakb(i), 0.0) + endif ; enddo ; endif + do i=is1,ie1 + did_i(i) = do_i(i) ; do_i(i) = .false. + enddo + do k=kb_min_act,nz-1 ; do i=is1,ie1 + if (did_i(i) .and. (k >= kb(i))) then + if (F(i,k) < minF(i,k)) then + F(i,k) = minF(i,k) + do_i(i) = .true. ; reiterate = .true. + elseif (k > kb(i)) then + if ((abs(F(i,k) - Fprev(i,k)) > tolerance) .or. & + ((h(i,j,k) + ((1.0+dsp1_ds(i,k))*F(i,k) - & + (F(i,k-1) + dsp1_ds(i,k+1)*F(i,k+1)))) < 0.9*Angstrom)) then + do_i(i) = .true. ; reiterate = .true. + endif + else ! (k == kb(i)) +! A more complicated test is required for the layer beneath the buffer layer, +! since its flux may be partially used to entrain directly from the mixed layer. +! Negative fluxes should not occur with the bulk mixed layer. + if (h(i,j,k) + ((F(i,k) + eakb(i)) - & + (eb_kmb(i) + dsp1_ds(i,k+1)*F(i,k+1))) < 0.9*Angstrom) then + do_i(i) = .true. ; reiterate = .true. + endif + endif + endif + enddo ; enddo + if (.not.reiterate) exit + endif ! end of if (it < CS%max_ent_it-1) + enddo ! end of it loop +! This is the end of the section that might be iterated. + + + if (it == (CS%max_ent_it)) then + ! Limit the flux so that the layer below is not depleted. + ! This should only be applied to the last iteration. + do i=is1,ie1 ; if (do_i(i)) then + F(i,nz-1) = MAX(F(i,nz-1), MIN(minF(i,nz-1), 0.0)) + if (kb(i) >= nz-1) then ; ea_kbp1(i) = 0.0 ; endif + endif ; enddo + do k=nz-2,kb_min_act,-1 ; do i=is1,ie1 ; if (do_i(i)) then + if (k>kb(i)) then + F(i,k) = MIN(MAX(minF(i,k),F(i,k)), (dsp1_ds(i,k+1)*F(i,k+1) + & + MAX(((F(i,k+1)-dsp1_ds(i,k+2)*F(i,k+2)) + & + (h(i,j,k+1) - Angstrom)), 0.5*(h(i,j,k+1)-Angstrom)))) + elseif (k==kb(i)) then + ea_kbp1(i) = dsp1_ds(i,k+1)*F(i,k+1) + h_avail = dsp1_ds(i,k+1)*F(i,k+1) + MAX(0.5*(h(i,j,k+1)-Angstrom), & + ((F(i,k+1)-dsp1_ds(i,k+2)*F(i,k+2)) + (h(i,j,k+1) - Angstrom))) + if ((F(i,k) > 0.0) .and. (F(i,k) > h_avail)) then + F_kb(i) = MAX(0.0, h_avail) + F(i,k) = F_kb(i) + if ((F_kb(i) < maxF_kb(i)) .and. (eakb_maxF(i) <= eakb(i))) & + eakb(i) = eakb_maxF(i) + call F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & + G, GV, CS, eakb) + endif + endif + endif ; enddo ; enddo + + + if (CS%bulkmixedlayer) then ; do i=is1,ie1 + if (do_i(i) .and. (kb(i) < nz)) then + h_avail = eakb(i) + MAX(0.5*(h_bl(i,kmb+1)-Angstrom), & + (F_kb(i)-ea_kbp1(i)) + (h_bl(i,kmb+1)-Angstrom)) + ! Ensure that 0 < eb_kmb < h_avail. + Ent_bl(i,Kmb+1) = MIN(Ent_bl(i,Kmb+1),0.5*(eakb(i) + h_avail)) + + eb_kmb(i) = max(2.0*Ent_bl(i,Kmb+1) - eakb(i), 0.0) + endif + enddo ; endif + + ! Limit the flux so that the layer above is not depleted. + do k=kb_min_act+1,nz-1 ; do i=is1,ie1 ; if (do_i(i)) then + if ((.not.CS%bulkmixedlayer) .or. (k > kb(i)+1)) then + F(i,k) = MIN(F(i,k), ds_dsp1(i,k)*( ((F(i,k-1) + & + dsp1_ds(i,k-1)*F(i,k-1)) - F(i,k-2)) + (h(i,j,k-1) - Angstrom))) + F(i,k) = MAX(F(i,k),MIN(minF(i,k),0.0)) + elseif (k == kb(i)+1) then + F(i,k) = MIN(F(i,k), ds_dsp1(i,k)*( ((F(i,k-1) + eakb(i)) - & + eb_kmb(i)) + (h(i,j,k-1) - Angstrom))) + F(i,k) = MAX(F(i,k),MIN(minF(i,k),0.0)) + endif + endif ; enddo ; enddo + endif ! (it == (CS%max_ent_it)) + + call F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb) + + ! Calculate the layer thicknesses after the entrainment to constrain the + ! corrective fluxes. + if (associated(tv%eqn_of_state)) then + do i=is,ie + h_guess(i,1) = (h(i,j,1) - Angstrom) + (eb(i,j,1) - ea(i,j,2)) + h_guess(i,nz) = (h(i,j,nz) - Angstrom) + (ea(i,j,nz) - eb(i,j,nz-1)) + if (h_guess(i,1) < 0.0) h_guess(i,1) = 0.0 + if (h_guess(i,nz) < 0.0) h_guess(i,nz) = 0.0 + enddo + do k=2,nz-1 ; do i=is,ie + h_guess(i,k) = (h(i,j,k) - Angstrom) + ((ea(i,j,k) - eb(i,j,k-1)) + & + (eb(i,j,k) - ea(i,j,k+1))) + if (h_guess(i,k) < 0.0) h_guess(i,k) = 0.0 + enddo ; enddo + if (CS%bulkmixedlayer) then + call determine_dSkb(h_bl, Sref, Ent_bl, eakb, is, ie, kmb, G, GV, & + .true., dS_kb, dS_anom_lim=dS_anom_lim) + do k=nz-1,kb_min,-1 + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, tv%eqn_of_state, EOSdom) + do i=is,ie + if ((k>kb(i)) .and. (F(i,k) > 0.0)) then + ! Within a time step, a layer may entrain no more than its + ! thickness for correction. This limitation should apply + ! extremely rarely, but precludes undesirable behavior. + ! Note: Corrected a sign/logic error & factor of 2 error, and + ! the layers tracked the target density better, mostly due to + ! the factor of 2 error. + F_cor = h(i,j,k) * MIN(1.0 , MAX(-ds_dsp1(i,k), & + (GV%Rlay(k) - Rcv(i)) / (GV%Rlay(k+1)-GV%Rlay(k))) ) + + ! Ensure that (1) Entrainments are positive, (2) Corrections in + ! a layer cannot deplete the layer itself (very generously), and + ! (3) a layer can take no more than a quarter the mass of its + ! neighbor. + if (F_cor > 0.0) then + F_cor = MIN(F_cor, 0.9*F(i,k), ds_dsp1(i,k)*0.5*h_guess(i,k), & + 0.25*h_guess(i,k+1)) + else + F_cor = -MIN(-F_cor, 0.9*F(i,k), 0.5*h_guess(i,k), & + 0.25*ds_dsp1(i,k)*h_guess(i,k-1) ) + endif + + ea(i,j,k) = ea(i,j,k) - dsp1_ds(i,k)*F_cor + eb(i,j,k) = eb(i,j,k) + F_cor + elseif ((k==kb(i)) .and. (F(i,k) > 0.0)) then + ! Rho_cor is the density anomaly that needs to be corrected, + ! taking into account that the true potential density of the + ! deepest buffer layer is not exactly what is returned as dS_kb. + dS_kb_eff = 2.0*dS_kb(i) - dS_anom_lim(i) ! Could be negative!!! + Rho_cor = h(i,j,k) * (GV%Rlay(k)-Rcv(i)) + eakb(i)*dS_anom_lim(i) + + ! Ensure that -.9*eakb < ea_cor < .9*eakb + if (abs(Rho_cor) < abs(0.9*eakb(i)*dS_kb_eff)) then + ea_cor = -Rho_cor / dS_kb_eff + else + ea_cor = sign(0.9*eakb(i),-Rho_cor*dS_kb_eff) + endif + + if (ea_cor > 0.0) then + ! Ensure that -F_cor < 0.5*h_guess + ea_cor = MIN(ea_cor, 0.5*(max_eakb(i) - eakb(i)), & + 0.5*h_guess(i,k) / (dS_kb(i) * I_dSkbp1(i))) + else + ! Ensure that -ea_cor < 0.5*h_guess & F_cor < 0.25*h_guess(k+1) + ea_cor = -MIN(-ea_cor, 0.5*h_guess(i,k), & + 0.25*h_guess(i,k+1) / (dS_kb(i) * I_dSkbp1(i))) + endif + + ea(i,j,k) = ea(i,j,k) + ea_cor + eb(i,j,k) = eb(i,j,k) - (dS_kb(i) * I_dSkbp1(i)) * ea_cor + elseif (k < kb(i)) then + ! Repetitive, unless ea(kb) has been corrected. + ea(i,j,k) = ea(i,j,k+1) + endif + enddo + enddo + do k=kb_min-1,K2,-1 ; do i=is,ie + ea(i,j,k) = ea(i,j,k+1) + enddo ; enddo + + ! Repetitive, unless ea(kb) has been corrected. + k=kmb + do i=is,ie + ! Do not adjust eb through the base of the buffer layers, but it + ! may be necessary to change entrainment from above. + h1 = (h(i,j,k) - Angstrom) + (eb(i,j,k) - ea(i,j,k+1)) + ea(i,j,k) = MAX(Ent_bl(i,K), Ent_bl(i,K)-0.5*h1, -h1) + enddo + do k=kmb-1,2,-1 ; do i=is,ie + ! Determine the entrainment from below for each buffer layer. + eb(i,j,k) = max(2.0*Ent_bl(i,K+1) - ea(i,j,k+1), 0.0) + + ! Determine the entrainment from above for each buffer layer. + h1 = (h(i,j,k) - Angstrom) + (eb(i,j,k) - ea(i,j,k+1)) + ea(i,j,k) = MAX(Ent_bl(i,K), Ent_bl(i,K)-0.5*h1, -h1) + enddo ; enddo + do i=is,ie + eb(i,j,1) = max(2.0*Ent_bl(i,2) - ea(i,j,2), 0.0) + enddo + + else ! not bulkmixedlayer + do k=K2,nz-1 + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, tv%eqn_of_state, EOSdom) + do i=is,ie ; if (F(i,k) > 0.0) then + ! Within a time step, a layer may entrain no more than + ! its thickness for correction. This limitation should + ! apply extremely rarely, but precludes undesirable + ! behavior. + F_cor = h(i,j,k) * MIN(dsp1_ds(i,k) , MAX(-1.0, & + (GV%Rlay(k) - Rcv(i)) / (GV%Rlay(k+1)-GV%Rlay(k))) ) + + ! Ensure that (1) Entrainments are positive, (2) Corrections in + ! a layer cannot deplete the layer itself (very generously), and + ! (3) a layer can take no more than a quarter the mass of its + ! neighbor. + if (F_cor >= 0.0) then + F_cor = MIN(F_cor, 0.9*F(i,k), 0.5*dsp1_ds(i,k)*h_guess(i,k), & + 0.25*h_guess(i,k+1)) + else + F_cor = -MIN(-F_cor, 0.9*F(i,k), 0.5*h_guess(i,k), & + 0.25*ds_dsp1(i,k)*h_guess(i,k-1) ) + endif + + ea(i,j,k) = ea(i,j,k) - dsp1_ds(i,k)*F_cor + eb(i,j,k) = eb(i,j,k) + F_cor + endif ; enddo + enddo + endif + + endif ! associated(tv%eqn_of_state)) + + if (CS%id_Kd > 0) then + Idt = (GV%H_to_m*US%m_to_Z) / dt + do k=2,nz-1 ; do i=is,ie + if (k 0) then + if (GV%Boussinesq .or. .not.associated(tv%eqn_of_state)) then + g_2dt = 0.5 * GV%H_to_Z**2 * US%L_to_Z**2 * (GV%g_Earth / dt) + else + g_2dt = 0.5 * GV%H_to_RZ**2 * US%L_to_Z**2 * (GV%g_Earth / dt) + endif + do i=is,ie ; diff_work(i,j,1) = 0.0 ; diff_work(i,j,nz+1) = 0.0 ; enddo + if (associated(tv%eqn_of_state)) then + if (associated(fluxes%p_surf)) then + do i=is,ie ; pressure(i) = fluxes%p_surf(i,j) ; enddo + else + do i=is,ie ; pressure(i) = 0.0 ; enddo + endif + do K=2,nz + do i=is,ie ; pressure(i) = pressure(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) ; enddo + do i=is,ie + if (k==kb(i)) then + T_eos(i) = 0.5*(tv%T(i,j,kmb) + tv%T(i,j,k)) + S_eos(i) = 0.5*(tv%S(i,j,kmb) + tv%S(i,j,k)) + else + T_eos(i) = 0.5*(tv%T(i,j,k-1) + tv%T(i,j,k)) + S_eos(i) = 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) + endif + enddo + if (GV%Boussinesq) then + call calculate_density_derivs(T_EOS, S_EOS, pressure, dRho_dT, dRho_dS, & + tv%eqn_of_state, EOSdom) + do i=is,ie + if ((k>kmb) .and. (kkmb) .and. (k 0) call post_data(CS%id_Kd, Kd_eff, CS%diag) + if (CS%id_Kd > 0) deallocate(Kd_eff) + if (CS%id_diff_work > 0) call post_data(CS%id_diff_work, diff_work, CS%diag) + if (CS%id_diff_work > 0) deallocate(diff_work) + +end subroutine entrainment_diffusive + +!> This subroutine calculates the actual entrainments (ea and eb) and the +!! amount of surface forcing that is applied to each layer if there is no bulk +!! mixed layer. +subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: F !< The density flux through a layer within + !! a time step divided by the density + !! difference across the interface below + !! the layer [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + integer, dimension(SZI_(G)), intent(in) :: kb !< The index of the lightest layer denser than + !! the deepest buffer layer. + integer, intent(in) :: kmb !< The number of mixed and buffer layers. + integer, intent(in) :: j !< The meridional index upon which to work. + type(entrain_diffusive_CS), intent(in) :: CS !< This module's control structure. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dsp1_ds !< The ratio of coordinate variable + !! differences across the interfaces below + !! a layer over the difference across the + !! interface above the layer [nondim]. + real, dimension(SZI_(G)), intent(in) :: eakb !< The entrainment from above by the layer + !! below the buffer layer [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: Ent_bl !< The average entrainment upward and + !! downward across each interface around + !! the buffer layers [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ea !< The amount of fluid entrained from the layer + !! above within this time step [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: eb !< The amount of fluid entrained from the layer + !! below within this time step [H ~> m or kg m-2]. + + real :: h1 ! The thickness in excess of the minimum that will remain + ! after exchange with the layer below [H ~> m or kg m-2]. + integer :: i, k, is, ie, nz + + is = G%isc ; ie = G%iec ; nz = GV%ke + + do i=is,ie + ea(i,j,nz) = 0.0 ; eb(i,j,nz) = 0.0 + enddo + if (CS%bulkmixedlayer) then + do i=is,ie + eb(i,j,kmb) = max(2.0*Ent_bl(i,Kmb+1) - eakb(i), 0.0) + enddo + do k=nz-1,kmb+1,-1 ; do i=is,ie + if (k > kb(i)) then + ! With a bulk mixed layer, surface buoyancy fluxes are applied + ! elsewhere, so F should always be nonnegative. + ea(i,j,k) = dsp1_ds(i,k)*F(i,k) + eb(i,j,k) = F(i,k) + elseif (k == kb(i)) then + ea(i,j,k) = eakb(i) + eb(i,j,k) = F(i,k) + elseif (k == kb(i)-1) then + ea(i,j,k) = ea(i,j,k+1) + eb(i,j,k) = eb(i,j,kmb) + else + ea(i,j,k) = ea(i,j,k+1) + ! Add the entrainment of the thin interior layers to eb going + ! up into the buffer layer. + eb(i,j,k) = eb(i,j,k+1) + max(0.0, h(i,j,k+1) - GV%Angstrom_H) + endif + enddo ; enddo + k = kmb + do i=is,ie + ! Adjust the previously calculated entrainment from below by the deepest + ! buffer layer to account for entrainment of thin interior layers . + if (kb(i) > kmb+1) & + eb(i,j,k) = eb(i,j,k+1) + max(0.0, h(i,j,k+1) - GV%Angstrom_H) + + ! Determine the entrainment from above for each buffer layer. + h1 = (h(i,j,k) - GV%Angstrom_H) + (eb(i,j,k) - ea(i,j,k+1)) + ea(i,j,k) = MAX(Ent_bl(i,K), Ent_bl(i,K)-0.5*h1, -h1) + enddo + do k=kmb-1,2,-1 ; do i=is,ie + ! Determine the entrainment from below for each buffer layer. + eb(i,j,k) = max(2.0*Ent_bl(i,K+1) - ea(i,j,k+1), 0.0) + + ! Determine the entrainment from above for each buffer layer. + h1 = (h(i,j,k) - GV%Angstrom_H) + (eb(i,j,k) - ea(i,j,k+1)) + ea(i,j,k) = MAX(Ent_bl(i,K), Ent_bl(i,K)-0.5*h1, -h1) +! if (h1 >= 0.0) then ; ea(i,j,k) = Ent_bl(i,K) +! elseif (Ent_bl(i,K)+0.5*h1 >= 0.0) then ; ea(i,j,k) = Ent_bl(i,K)-0.5*h1 +! else ; ea(i,j,k) = -h1 ; endif + enddo ; enddo + do i=is,ie + eb(i,j,1) = max(2.0*Ent_bl(i,2) - ea(i,j,2), 0.0) + ea(i,j,1) = 0.0 + enddo + else ! not BULKMIXEDLAYER + ! Calculate the entrainment by each layer from above and below. + ! Entrainment is always positive, but F may be negative due to + ! surface buoyancy fluxes. + do i=is,ie + ea(i,j,1) = 0.0 ; eb(i,j,1) = MAX(F(i,1),0.0) + ea(i,j,2) = dsp1_ds(i,2)*F(i,2) - MIN(F(i,1),0.0) + enddo + + do k=2,nz-1 ; do i=is,ie + eb(i,j,k) = MAX(F(i,k),0.0) + ea(i,j,k+1) = dsp1_ds(i,k+1)*F(i,k+1) - (F(i,k)-eb(i,j,k)) + if (ea(i,j,k+1) < 0.0) then + eb(i,j,k) = eb(i,j,k) - ea(i,j,k+1) + ea(i,j,k+1) = 0.0 + endif + enddo ; enddo + endif ! end BULKMIXEDLAYER +end subroutine F_to_ent + +!> This subroutine sets the average entrainment across each of the interfaces +!! between buffer layers within a timestep. It also causes thin and relatively +!! light interior layers to be entrained by the deepest buffer layer. +!! Also find the initial coordinate potential densities (Sref) of each layer. +subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, Sref, h_bl) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(in) :: dtKd_int !< The diapycnal diffusivity across + !! each interface times the time step + !! [H2 ~> m2 or kg2 m-4]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent + !! fields have NULL ptrs. + integer, dimension(SZI_(G)), intent(inout) :: kb !< The index of the lightest layer denser + !! than the buffer layer or 1 if there is + !! no buffer layer. + integer, intent(in) :: kmb !< The number of mixed and buffer layers. + logical, dimension(SZI_(G)), intent(in) :: do_i !< A logical variable indicating which + !! i-points to work on. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(entrain_diffusive_CS), intent(in) :: CS !< This module's control structure. + integer, intent(in) :: j !< The meridional index upon which to work. + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(out) :: Ent_bl !< The average entrainment upward and + !! downward across each interface around + !! the buffer layers [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: Sref !< The coordinate potential density minus + !! 1000 for each layer [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: h_bl !< The thickness of each layer [H ~> m or kg m-2]. + +! This subroutine sets the average entrainment across each of the interfaces +! between buffer layers within a timestep. It also causes thin and relatively +! light interior layers to be entrained by the deepest buffer layer. +! Also find the initial coordinate potential densities (Sref) of each layer. +! Does there need to be limiting when the layers below are all thin? + + ! Local variables + real, dimension(SZI_(G)) :: & + b1, d1, & ! Variables used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1] and [nondim]. + Rcv, & ! Value of the coordinate variable (potential density) + ! based on the simulated T and S and P_Ref [R ~> kg m-3]. + pres, & ! Reference pressure (P_Ref) [R L2 T-2 ~> Pa]. + frac_rem, & ! The fraction of the diffusion remaining [nondim]. + h_interior ! The interior thickness available for entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G), SZK_(GV)) :: & + S_est ! An estimate of the coordinate potential density - 1000 after + ! entrainment for each layer [R ~> kg m-3]. + real :: dh ! An available thickness [H ~> m or kg m-2]. + real :: Kd_x_dt ! The diffusion that remains after thin layers are + ! entrained [H2 ~> m2 or kg2 m-4]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, k, is, ie, nz + is = G%isc ; ie = G%iec ; nz = GV%ke + + h_neglect = GV%H_subroundoff + + do i=is,ie ; pres(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) + do k=1,kmb + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, tv%eqn_of_state, EOSdom) + do i=is,ie + h_bl(i,k) = h(i,j,k) + h_neglect + Sref(i,k) = Rcv(i) - CS%Rho_sig_off + enddo + enddo + + do i=is,ie + h_interior(i) = 0.0 ; Ent_bl(i,1) = 0.0 +! if (kb(i) > nz) Ent_bl(i,Kmb+1) = 0.0 + enddo + + do k=2,kmb ; do i=is,ie + if (do_i(i)) then + Ent_bl(i,K) = min(2.0 * dtKd_int(i,K) / (h(i,j,k-1) + h(i,j,k) + h_neglect), CS%max_Ent) + else ; Ent_bl(i,K) = 0.0 ; endif + enddo ; enddo + + ! Determine the coordinate density of the bottommost buffer layer if there + ! is no entrainment from the layers below. This is a partial solver, based + ! on the first pass of a tridiagonal solver, as the values in the upper buffer + ! layers are not needed. + + do i=is,ie + b1(i) = 1.0 / (h_bl(i,1) + Ent_bl(i,2)) + d1(i) = h_bl(i,1) * b1(i) ! = 1.0 - Ent_bl(i,2)*b1(i) + S_est(i,1) = (h_bl(i,1)*Sref(i,1)) * b1(i) + enddo + do k=2,kmb-1 ; do i=is,ie + b1(i) = 1.0 / ((h_bl(i,k) + Ent_bl(i,K+1)) + d1(i)*Ent_bl(i,K)) + d1(i) = (h_bl(i,k) + d1(i)*Ent_bl(i,K)) * b1(i) ! = 1.0 - Ent_bl(i,K+1)*b1(i) + S_est(i,k) = (h_bl(i,k)*Sref(i,k) + Ent_bl(i,K)*S_est(i,k-1)) * b1(i) + enddo ; enddo + do i=is,ie + S_est(i,kmb) = (h_bl(i,kmb)*Sref(i,kmb) + Ent_bl(i,Kmb)*S_est(i,kmb-1)) / & + (h_bl(i,kmb) + d1(i)*Ent_bl(i,Kmb)) + frac_rem(i) = 1.0 + enddo + + ! Entrain any thin interior layers that are lighter (in the coordinate + ! potential density) than the deepest buffer layer will be, and adjust kb. + do i=is,ie ; kb(i) = nz+1 ; if (do_i(i)) kb(i) = kmb+1 ; enddo + + do k=kmb+1,nz ; do i=is,ie ; if (do_i(i)) then + if ((k == kb(i)) .and. (S_est(i,kmb) > (GV%Rlay(k) - CS%Rho_sig_off))) then + if (4.0*dtKd_int(i,Kmb+1)*frac_rem(i) > & + (h_bl(i,kmb) + h(i,j,k)) * (h(i,j,k) - GV%Angstrom_H)) then + ! Entrain this layer into the buffer layer and move kb down. + dh = max((h(i,j,k) - GV%Angstrom_H), 0.0) + if (dh > 0.0) then + frac_rem(i) = frac_rem(i) - ((h_bl(i,kmb) + h(i,j,k)) * dh) / & + (4.0*dtKd_int(i,Kmb+1)) + Sref(i,kmb) = (h_bl(i,kmb)*Sref(i,kmb) + dh*(GV%Rlay(k)-CS%Rho_sig_off)) / & + (h_bl(i,kmb) + dh) + h_bl(i,kmb) = h_bl(i,kmb) + dh + S_est(i,kmb) = (h_bl(i,kmb)*Sref(i,kmb) + Ent_bl(i,Kmb)*S_est(i,kmb-1)) / & + (h_bl(i,kmb) + d1(i)*Ent_bl(i,Kmb)) + endif + kb(i) = kb(i) + 1 + endif + endif + endif ; enddo ; enddo + + ! This is where variables are be set up with a different vertical grid + ! in which the (newly?) massless layers are taken out. + do k=nz,kmb+1,-1 ; do i=is,ie + if (k >= kb(i)) h_interior(i) = h_interior(i) + (h(i,j,k)-GV%Angstrom_H) + if (k==kb(i)) then + h_bl(i,kmb+1) = h(i,j,k) ; Sref(i,kmb+1) = GV%Rlay(k) - CS%Rho_sig_off + elseif (k==kb(i)+1) then + h_bl(i,kmb+2) = h(i,j,k) ; Sref(i,kmb+2) = GV%Rlay(k) - CS%Rho_sig_off + endif + enddo ; enddo + do i=is,ie ; if (kb(i) >= nz) then + h_bl(i,kmb+1) = h(i,j,nz) + Sref(i,kmb+1) = GV%Rlay(nz) - CS%Rho_sig_off + h_bl(i,kmb+2) = GV%Angstrom_H + Sref(i,kmb+2) = Sref(i,kmb+1) + (GV%Rlay(nz) - GV%Rlay(nz-1)) + endif ; enddo + + ! Perhaps we should revisit the way that the average entrainment between the + ! buffer layer and the interior is calculated so that it is not unduly + ! limited when the layers are less than sqrt(Kd * dt) thick? + do i=is,ie ; if (do_i(i)) then + Kd_x_dt = frac_rem(i) * dtKd_int(i,Kmb+1) + if ((Kd_x_dt <= 0.0) .or. (h_interior(i) <= 0.0)) then + Ent_bl(i,Kmb+1) = 0.0 + else + ! If the combined layers are exceptionally thin, use sqrt(Kd*dt) as the + ! estimate of the thickness in the denominator of the thickness diffusion. + Ent_bl(i,Kmb+1) = MIN(0.5*h_interior(i), sqrt(Kd_x_dt), & + Kd_x_dt / (0.5*(h_bl(i,kmb) + h_bl(i,kmb+1)))) + endif + else + Ent_bl(i,Kmb+1) = 0.0 + endif ; enddo + +end subroutine set_Ent_bl + +!> This subroutine determines the reference density difference between the +!! bottommost buffer layer and the first interior after the mixing between mixed +!! and buffer layers and mixing with the layer below. Within the mixed and buffer +!! layers, entrainment from the layer above is increased when it is necessary to +!! keep the layers from developing a negative thickness; otherwise it equals +!! Ent_bl. At each interface, the upward and downward fluxes average out to +!! Ent_bl, unless entrainment by the layer below is larger than twice Ent_bl. +!! The density difference across the first interior layer may also be returned. +!! It could also be limited to avoid negative values or values that greatly +!! exceed the density differences across an interface. +!! Additionally, the partial derivatives of dSkb and dSlay with E_kb could +!! also be returned. +subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & + dSkb, ddSkb_dE, dSlay, ddSlay_dE, dS_anom_lim, do_i_in) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid + !! structure. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: h_bl !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: Sref !< Reference potential density [R ~> kg m-3] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: Ent_bl !< The average entrainment upward and + !! downward across each interface + !! around the buffer layers [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: E_kb !< The entrainment by the top interior + !! layer [H ~> m or kg m-2]. + integer, intent(in) :: is !< The start of the i-index range to work on. + integer, intent(in) :: ie !< The end of the i-index range to work on. + integer, intent(in) :: kmb !< The number of mixed and buffer layers. + logical, intent(in) :: limit !< If true, limit dSkb and dSlay to + !! avoid negative values. + real, dimension(SZI_(G)), intent(inout) :: dSkb !< The limited potential density + !! difference across the interface + !! between the bottommost buffer layer + !! and the topmost interior layer. [R ~> kg m-3] + !! dSkb > 0. + real, dimension(SZI_(G)), optional, intent(inout) :: ddSkb_dE !< The partial derivative of dSkb + !! with E [R H-1 ~> kg m-4 or m-1]. + real, dimension(SZI_(G)), optional, intent(inout) :: dSlay !< The limited potential density + !! difference across the topmost + !! interior layer. 0 < dSkb [R ~> kg m-3] + real, dimension(SZI_(G)), optional, intent(inout) :: ddSlay_dE !< The partial derivative of dSlay + !! with E [R H-1 ~> kg m-4 or m-1]. + real, dimension(SZI_(G)), optional, intent(inout) :: dS_anom_lim !< A limiting value to use for + !! the density anomalies below the + !! buffer layer [R ~> kg m-3]. + logical, dimension(SZI_(G)), optional, intent(in) :: do_i_in !< If present, determines which + !! columns are worked on. + +! Note that dSkb, ddSkb_dE, dSlay, ddSlay_dE, and dS_anom_lim are declared +! intent inout because they should not change where do_i_in is false. + +! This subroutine determines the reference density difference between the +! bottommost buffer layer and the first interior after the mixing between mixed +! and buffer layers and mixing with the layer below. Within the mixed and buffer +! layers, entrainment from the layer above is increased when it is necessary to +! keep the layers from developing a negative thickness; otherwise it equals +! Ent_bl. At each interface, the upward and downward fluxes average out to +! Ent_bl, unless entrainment by the layer below is larger than twice Ent_bl. +! The density difference across the first interior layer may also be returned. +! It could also be limited to avoid negative values or values that greatly +! exceed the density differences across an interface. +! Additionally, the partial derivatives of dSkb and dSlay with E_kb could +! also be returned. + + ! Local variables + real, dimension(SZI_(G),SZK_(GV)) :: & + b1, c1, & ! b1 [H-1 ~> m-1 or m2 kg-1] and c1 [nondim] are variables used by the tridiagonal solver. + S, dS_dE, & ! The coordinate density [R ~> kg m-3] and its derivative with E [R H-1 ~> kg m-4 or m-1]. + ea, dea_dE, & ! The entrainment from above [H ~> m or kg m-2] and its derivative with E [nondim]. + eb, deb_dE ! The entrainment from below [H ~> m or kg m-2] and its derivative with E [nondim]. + real :: deriv_dSkb(SZI_(G)) ! The limited derivative of the new density difference across the base of + ! the buffer layers with the new density of the bottommost buffer layer [nondim] + real :: d1(SZI_(G)) ! d1 = 1.0-c1 is also used by the tridiagonal solver [nondim]. + real :: src ! A source term for dS_dR [R ~> kg m-3]. + real :: h1 ! The thickness in excess of the minimum that will remain + ! after exchange with the layer below [H ~> m or kg m-2]. + logical, dimension(SZI_(G)) :: do_i + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: h_tr ! h_tr is h at tracer points with a tiny thickness + ! added to ensure positive definiteness [H ~> m or kg m-2]. + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: rat ! A ratio of density differences [nondim] + real :: dS_kbp1 ! The density difference between the top two interior layers [R ~> kg m-3]. + real :: IdS_kbp1 ! The inverse of dS_kbp1 [R-1 ~> m3 kg-1] + real :: deriv_dSLay ! The derivative of the projected density difference across the topmost interior + ! layer with the density difference across the interface above it [nondim] + real :: Inv_term ! The inverse of a nondimensional expression [nondim] + real :: f1, df1_drat ! Temporary variables [nondim]. + real :: z, dz_drat, f2, df2_dz, expz ! Temporary variables [nondim]. + real :: eps_dSLay, eps_dSkb ! Small nondimensional constants [nondim]. + integer :: i, k + + if (present(ddSlay_dE) .and. .not.present(dSlay)) call MOM_error(FATAL, & + "In deterimine_dSkb, ddSLay_dE may only be present if dSlay is.") + + h_neglect = GV%H_subroundoff + + do i=is,ie + ea(i,kmb+1) = E_kb(i) ; dea_dE(i,kmb+1) = 1.0 + S(i,kmb+1) = Sref(i,kmb+1) ; dS_dE(i,kmb+1) = 0.0 + b1(i,kmb+1) = 0.0 + d1(i) = 1.0 + do_i(i) = .true. + enddo + if (present(do_i_in)) then + do i=is,ie ; do_i(i) = do_i_in(i) ; enddo + endif + do k=kmb,1,-1 ; do i=is,ie + if (do_i(i)) then + ! The do_i test here is only for efficiency. + ! Determine the entrainment from below for each buffer layer. + if (2.0*Ent_bl(i,K+1) > ea(i,k+1)) then + eb(i,k) = 2.0*Ent_bl(i,K+1) - ea(i,k+1) ; deb_dE(i,k) = -dea_dE(i,k+1) + else + eb(i,k) = 0.0 ; deb_dE(i,k) = 0.0 + endif + + ! Determine the entrainment from above for each buffer layer. + h1 = (h_bl(i,k) - GV%Angstrom_H) + (eb(i,k) - ea(i,k+1)) + if (h1 >= 0.0) then + ea(i,k) = Ent_bl(i,K) ; dea_dE(i,k) = 0.0 + elseif (Ent_bl(i,K) + 0.5*h1 >= 0.0) then + ea(i,k) = Ent_bl(i,K) - 0.5*h1 + dea_dE(i,k) = 0.5*(dea_dE(i,k+1) - deb_dE(i,k)) + else + ea(i,k) = -h1 + dea_dE(i,k) = dea_dE(i,k+1) - deb_dE(i,k) + endif + else + ea(i,k) = 0.0 ; dea_dE(i,k) = 0.0 ; eb(i,k) = 0.0 ; deb_dE(i,k) = 0.0 + endif + + ! This is the first-pass of a tridiagonal solver for S. + h_tr = h_bl(i,k) + h_neglect + c1(i,k) = ea(i,k+1) * b1(i,k+1) + b_denom_1 = (h_tr + d1(i)*eb(i,k)) + b1(i,k) = 1.0 / (b_denom_1 + ea(i,k)) + d1(i) = b_denom_1 * b1(i,k) + + S(i,k) = (h_tr*Sref(i,k) + eb(i,k)*S(i,k+1)) * b1(i,k) + enddo ; enddo + do k=2,kmb ; do i=is,ie + S(i,k) = S(i,k) + c1(i,k-1)*S(i,k-1) + enddo ; enddo + + if (present(ddSkb_dE) .or. present(ddSlay_dE)) then + ! These two tridiagonal solvers cannot be combined because the solutions for + ! S are required as a source for dS_dE. + do k=kmb,2,-1 ; do i=is,ie + if (do_i(i) .and. (dea_dE(i,k) - deb_dE(i,k) > 0.0)) then + src = (((S(i,k+1) - Sref(i,k)) * (h_bl(i,k) + h_neglect) + & + (S(i,k+1) - S(i,k-1)) * ea(i,k)) * deb_dE(i,k) - & + ((Sref(i,k) - S(i,k-1)) * h_bl(i,k) + & + (S(i,k+1) - S(i,k-1)) * eb(i,k)) * dea_dE(i,k)) / & + ((h_bl(i,k) + h_neglect + ea(i,k)) + eb(i,k)) + else ; src = 0.0 ; endif + dS_dE(i,k) = (src + eb(i,k)*dS_dE(i,k+1)) * b1(i,k) + enddo ; enddo + do i=is,ie + if (do_i(i) .and. (deb_dE(i,1) < 0.0)) then + src = (((S(i,2) - Sref(i,1)) * (h_bl(i,1) + h_neglect)) * deb_dE(i,1)) / & + (h_bl(i,1) + h_neglect + eb(i,1)) + else ; src = 0.0 ; endif + dS_dE(i,1) = (src + eb(i,1)*dS_dE(i,2)) * b1(i,1) + enddo + do k=2,kmb ; do i=is,ie + dS_dE(i,k) = dS_dE(i,k) + c1(i,k-1)*dS_dE(i,k-1) + enddo ; enddo + endif + + ! Now, apply any limiting and return the requested variables. + + eps_dSkb = 1.0e-6 ! Should be a small, nondimensional, positive number. + if (.not.limit) then + do i=is,ie ; if (do_i(i)) then + dSkb(i) = Sref(i,kmb+1) - S(i,kmb) + endif ; enddo + if (present(ddSkb_dE)) then ; do i=is,ie ; if (do_i(i)) then + ddSkb_dE(i) = -1.0*dS_dE(i,kmb) + endif ; enddo ; endif + + if (present(dSlay)) then ; do i=is,ie ; if (do_i(i)) then + dSlay(i) = 0.5 * (Sref(i,kmb+2) - S(i,kmb)) + endif ; enddo ; endif + if (present(ddSlay_dE)) then ; do i=is,ie ; if (do_i(i)) then + ddSlay_dE(i) = -0.5*dS_dE(i,kmb) + endif ; enddo ; endif + else + do i=is,ie ; if (do_i(i)) then + ! Need to ensure that 0 < dSkb <= S_kb - Sbl + if (Sref(i,kmb+1) - S(i,kmb) < eps_dSkb*(Sref(i,kmb+2) - Sref(i,kmb+1))) then + dSkb(i) = eps_dSkb * (Sref(i,kmb+2) - Sref(i,kmb+1)) ; deriv_dSkb(i) = 0.0 + else + dSkb(i) = Sref(i,kmb+1) - S(i,kmb) ; deriv_dSkb(i) = -1.0 + endif + if (present(ddSkb_dE)) ddSkb_dE(i) = deriv_dSkb(i)*dS_dE(i,kmb) + endif ; enddo + + if (present(dSLay)) then + dz_drat = 1000.0 ! The limit of large dz_drat the same as choosing a + ! Heaviside function. + eps_dSLay = 1.0e-10 ! Should be ~= GV%Angstrom_H / sqrt(Kd*dt) + do i=is,ie ; if (do_i(i)) then + dS_kbp1 = Sref(i,kmb+2) - Sref(i,kmb+1) + IdS_kbp1 = 1.0 / (Sref(i,kmb+2) - Sref(i,kmb+1)) + rat = (Sref(i,kmb+1) - S(i,kmb)) * IdS_kbp1 + ! Need to ensure that 0 < dSLay <= 2*dSkb + if (rat < 0.5) then + ! The coefficients here are chosen so that at rat = 0.5, the value (1.5) + ! and first derivative (-0.5) match with the "typical" case (next). + ! The functional form here is arbitrary. + ! f1 provides a reasonable profile that matches the value and derivative + ! of the "typical" case at rat = 0.5, and has a maximum of less than 2. + Inv_term = 1.0 / (1.0-rat) + f1 = 2.0 - 0.125*(Inv_term**2) + df1_drat = - 0.25*(Inv_term**3) + + ! f2 ensures that dSLay goes to 0 rapidly if rat is significantly + ! negative. + z = dz_drat * rat + 4.0 ! The 4 here gives f2(0) = 0.982. + if (z >= 18.0) then ; f2 = 1.0 ; df2_dz = 0.0 + elseif (z <= -58.0) then ; f2 = eps_dSLay ; df2_dz = 0.0 + else + expz = exp(z) ; Inv_term = 1.0 / (1.0 + expz) + f2 = (eps_dSLay + expz) * Inv_term + df2_dz = (1.0 - eps_dSLay) * expz * Inv_term**2 + endif + + dSLay(i) = dSkb(i) * f1 * f2 + deriv_dSLay = deriv_dSkb(i) * (f1 * f2) - (dSkb(i)*IdS_kbp1) * & + (df1_drat*f2 + f1 * dz_drat * df2_dz) + elseif (dSkb(i) <= 3.0*dS_kbp1) then + ! This is the "typical" case. + dSLay(i) = 0.5 * (dSkb(i) + dS_kbp1) + deriv_dSLay = 0.5 * deriv_dSkb(i) ! = -0.5 + else + dSLay(i) = 2.0*dS_kbp1 + deriv_dSLay = 0.0 + endif + if (present(ddSlay_dE)) ddSlay_dE(i) = deriv_dSLay*dS_dE(i,kmb) + endif ; enddo + endif ! present(dSlay) + endif ! Not limited. + + if (present(dS_anom_lim)) then ; do i=is,ie ; if (do_i(i)) then + dS_anom_lim(i) = max(0.0, eps_dSkb * (Sref(i,kmb+2) - Sref(i,kmb+1)) - & + (Sref(i,kmb+1) - S(i,kmb)) ) + endif ; enddo ; endif + +end subroutine determine_dSkb + +!> Given an entrainment from below for layer kb, determine a consistent +!! entrainment from above, such that dSkb * ea_kb = dSkbp1 * F_kb. The input +!! value of ea_kb is both the maximum value that can be obtained and the first +!! guess of the iterations. Ideally ea_kb should be an under-estimate +subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & + G, GV, CS, ea_kb, tol_in) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: h_bl !< Layer thickness, with the top interior + !! layer at k-index kmb+1 [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: Sref !< The coordinate reference potential density, + !! with the value of the topmost interior layer + !! at index kmb+1 [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: Ent_bl !< The average entrainment upward and downward + !! across each interface around the buffer layers, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in reference + !! potential density across the base of the + !! uppermost interior layer [R-1 ~> m3 kg-1]. + real, dimension(SZI_(G)), intent(in) :: F_kb !< The entrainment from below by the + !! uppermost interior layer [H ~> m or kg m-2] + integer, intent(in) :: kmb !< The number of mixed and buffer layers. + integer, intent(in) :: i !< The i-index to work on + type(entrain_diffusive_CS), intent(in) :: CS !< This module's control structure. + real, dimension(SZI_(G)), intent(inout) :: ea_kb !< The entrainment from above by the layer below + !! the buffer layer (i.e. layer kb) [H ~> m or kg m-2]. + real, optional, intent(in) :: tol_in !< A tolerance for the iterative determination + !! of the entrainment [H ~> m or kg m-2]. + + real :: max_ea, min_ea ! Bounds on the estimated entraiment [H ~> m or kg m-2] + real :: err, err_min, err_max ! Errors in the mass flux balance [H R ~> kg m-2 or kg2 m-5] + real :: derr_dea ! The change in error with the change in ea [R ~> kg m-3] + real :: val ! An estimate mass flux [H R ~> kg m-2 or kg2 m-5] + real :: tolerance, tol1 ! Tolerances for the determination of the entrainment [H ~> m or kg m-2] + real :: ea_prev ! A previous estimate of ea_kb [H ~> m or kg m-2] + real :: dS_kbp1 ! The density difference between two interior layers [R ~> kg m-3] + real :: dS_kb(SZI_(G)) ! The limited potential density difference across the interface + ! between the bottommost buffer layer and the topmost interior layer [R ~> kg m-3] + real :: maxF(SZI_(G)) ! The maximum value of F (the density flux divided by density + ! differences) found in the range min_ent < ent < max_ent [H ~> m or kg m-2]. + real :: ent_maxF(SZI_(G)) ! The value of entrainment that gives maxF [H ~> m or kg m-2] + real :: zeros(SZI_(G)) ! An array of zero entrainments [H ~> m or kg m-2] + real :: ddSkb_dE(SZI_(G)) ! The partial derivative of dS_kb with ea_kb [R H-1 ~> kg m-4 or m-1] + logical :: bisect_next, Newton ! These indicate what method the next iteration should use + integer :: it + integer, parameter :: MAXIT = 30 + + dS_kbp1 = Sref(i,kmb+2) - Sref(i,kmb+1) + max_ea = ea_kb(i) ; min_ea = 0.0 + val = dS_kbp1 * F_kb(i) + err_min = -val + + tolerance = CS%Tolerance_Ent + if (present(tol_in)) tolerance = tol_in + bisect_next = .true. + + call determine_dSkb(h_bl, Sref, Ent_bl, ea_kb, i, i, kmb, G, GV, .true., & + dS_kb, ddSkb_dE) + + err = dS_kb(i) * ea_kb(i) - val + derr_dea = dS_kb(i) + ddSkb_dE(i) * ea_kb(i) + ! Return if Newton's method on the first guess would give a tolerably small + ! change in the value of ea_kb. + if ((err <= 0.0) .and. (abs(err) <= tolerance*abs(derr_dea))) return + + if (err == 0.0) then ; return ! The exact solution on the first guess... + elseif (err > 0.0) then ! The root is properly bracketed. + max_ea = ea_kb(i) ; err_max = err + ! Use Newton's method (if it stays bounded) or the false position method + ! to find the next value. + if ((derr_dea > 0.0) .and. (derr_dea*(ea_kb(i) - min_ea) > err) .and. & + (derr_dea*(max_ea - ea_kb(i)) > -1.0*err)) then + ea_kb(i) = ea_kb(i) - err / derr_dea + else ! Use the bisection for the next guess. + ea_kb(i) = 0.5*(max_ea+min_ea) + endif + else + ! Try to bracket the root first. If unable to bracket the root, return + ! the maximum. + zeros(i) = 0.0 + call find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, zeros, ea_kb, & + kmb, i, i, G, GV, CS, maxF, ent_maxF, F_thresh=F_kb) + err_max = dS_kbp1 * maxF(i) - val + ! If err_max is negative, there is no good solution, so use the maximum + ! value of F in the valid range. + if (err_max <= 0.0) then + ea_kb(i) = ent_maxF(i) ; return + else + max_ea = ent_maxF(i) + ea_kb(i) = 0.5*(max_ea+min_ea) ! Use bisection for the next guess. + endif + endif + + ! Exit if the range between max_ea and min_ea already acceptable. + ! if (abs(max_ea - min_ea) < 0.1*tolerance) return + + do it = 1, MAXIT + call determine_dSkb(h_bl, Sref, Ent_bl, ea_kb, i, i, kmb, G, GV, .true., & + dS_kb, ddSkb_dE) + + err = dS_kb(i) * ea_kb(i) - val + derr_dea = dS_kb(i) + ddSkb_dE(i) * ea_kb(i) + + ea_prev = ea_kb(i) + ! Use Newton's method or the false position method to find the next value. + Newton = .false. + if (err > 0.0) then + max_ea = ea_kb(i) ; err_max = err + if ((derr_dea > 0.0) .and. (derr_dea*(ea_kb(i)-min_ea) > err)) Newton = .true. + else + min_ea = ea_kb(i) ; err_min = err + if ((derr_dea > 0.0) .and. (derr_dea*(ea_kb(i)-max_ea) < err)) Newton = .true. + endif + + if (Newton) then + ea_kb(i) = ea_kb(i) - err / derr_dea + elseif (bisect_next) then ! Use bisection to reduce the range. + ea_kb(i) = 0.5*(max_ea+min_ea) + bisect_next = .false. + else ! Use the false-position method for the next guess. + ea_kb(i) = min_ea + (max_ea-min_ea) * (err_min/(err_min - err_max)) + bisect_next = .true. + endif + + tol1 = tolerance ; if (err > 0.0) tol1 = 0.099*tolerance + if (dS_kb(i) <= dS_kbp1) then + if (abs(ea_kb(i) - ea_prev) <= tol1) return + else + if (dS_kbp1*abs(ea_kb(i) - ea_prev) <= dS_kb(i)*tol1) return + endif + enddo + +end subroutine F_kb_to_ea_kb + + +!> This subroutine determines the entrainment from above by the top interior +!! layer (labeled kb elsewhere) given an entrainment by the layer below it, +!! constrained to be within the provided bounds. +subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & + min_eakb, max_eakb, kmb, is, ie, do_i, G, GV, CS, Ent, & + error, err_min_eakb0, err_max_eakb0, F_kb, dFdfm_kb) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: h_bl !< Layer thickness, with the top interior + !! layer at k-index kmb+1 [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: Sref !< The coordinate reference potential + !! density, with the value of the + !! topmost interior layer at layer + !! kmb+1 [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: Ent_bl !< The average entrainment upward and + !! downward across each interface around + !! the buffer layers [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in + !! reference potential density across + !! the base of the uppermost interior + !! layer [R-1 ~> m3 kg-1]. + real, dimension(SZI_(G)), intent(in) :: dtKd_kb !< The diapycnal diffusivity in the top + !! interior layer times the time step + !! [H2 ~> m2 or kg2 m-4]. + real, dimension(SZI_(G)), intent(in) :: ea_kbp1 !< The entrainment from above by layer + !! kb+1 [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: min_eakb !< The minimum permissible rate of + !! entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: max_eakb !< The maximum permissible rate of + !! entrainment [H ~> m or kg m-2]. + integer, intent(in) :: kmb !< The number of mixed and buffer layers. + integer, intent(in) :: is !< The start of the i-index range to work on. + integer, intent(in) :: ie !< The end of the i-index range to work on. + logical, dimension(SZI_(G)), intent(in) :: do_i !< A logical variable indicating which + !! i-points to work on. + type(entrain_diffusive_CS), intent(in) :: CS !< This module's control structure. + real, dimension(SZI_(G)), intent(inout) :: Ent !< The entrainment rate of the uppermost + !! interior layer [H ~> m or kg m-2]. + !! The input value is the first guess. + real, dimension(SZI_(G)), optional, intent(out) :: error !< The error (locally defined in this + !! routine) associated with the returned + !! solution [H2 ~> m2 or kg2 m-4] + real, dimension(SZI_(G)), optional, intent(in) :: err_min_eakb0 !< The errors (locally defined) + !! associated with min_eakb when ea_kbp1 = 0, + !! returned from a previous call to this + !! subroutine [H2 ~> m2 or kg2 m-4]. + real, dimension(SZI_(G)), optional, intent(in) :: err_max_eakb0 !< The errors (locally defined) + !! associated with min_eakb when ea_kbp1 = 0, + !! returned from a previous call to this + !! subroutine [H2 ~> m2 or kg2 m-4]. + real, dimension(SZI_(G)), optional, intent(out) :: F_kb !< The entrainment from below by the + !! uppermost interior layer + !! corresponding to the returned + !! value of Ent [H ~> m or kg m-2]. + real, dimension(SZI_(G)), optional, intent(out) :: dFdfm_kb !< The partial derivative of F_kb with + !! ea_kbp1 [nondim]. + +! This subroutine determines the entrainment from above by the top interior +! layer (labeled kb elsewhere) given an entrainment by the layer below it, +! constrained to be within the provided bounds. + + ! Local variables + real, dimension(SZI_(G)) :: & + dS_kb, & ! The coordinate-density difference between the + ! layer kb and deepest buffer layer, limited to + ! ensure that it is positive [R ~> kg m-3]. + dS_Lay, & ! The coordinate-density difference across layer + ! kb, limited to ensure that it is positive and not + ! too much bigger than dS_kb or dS_kbp1 [R ~> kg m-3]. + ddSkb_dE, ddSlay_dE, & ! The derivatives of dS_kb and dS_Lay with E + ! [R H-1 ~> kg m-4 or m-1]. + derror_dE, & ! The derivative of err with E [H ~> m or kg m-2]. + err, & ! The "error" whose zero is being sought [H2 ~> m2 or kg2 m-4]. + E_min, E_max, & ! The minimum and maximum values of E [H ~> m or kg m-2]. + error_minE, error_maxE ! err when E = E_min or E = E_max [H2 ~> m2 or kg2 m-4]. + real :: err_est ! An estimate of what err will be [H2 ~> m2 or kg2 m-4]. + real :: eL ! 1 or 0, depending on whether increases in E lead + ! to decreases in the entrainment from below by the + ! deepest buffer layer [nondim]. + real :: fa ! Temporary variable used to calculate err [nondim]. + real :: fk ! Temporary variable used to calculate err [H2 ~> m2 or kg2 m-4]. + real :: fm, fr ! Temporary variables used to calculate err [H ~> m or kg m-2]. + real :: tolerance ! The tolerance within which E must be converged [H ~> m or kg m-2]. + real :: E_prev ! The previous value of E [H ~> m or kg m-2]. + logical, dimension(SZI_(G)) :: false_position ! If true, the false position + ! method might be used for the next iteration. + logical, dimension(SZI_(G)) :: redo_i ! If true, more work is needed on this column. + logical :: do_any + real :: large_err ! A large error measure [H2 ~> m2 or kg2 m-4]. + integer :: i, it + integer, parameter :: MAXIT = 30 + + if (.not.CS%bulkmixedlayer) then + call MOM_error(FATAL, "determine_Ea_kb should not be called "//& + "unless BULKMIXEDLAYER is defined.") + endif + tolerance = CS%Tolerance_Ent + large_err = GV%m_to_H**2 * 1.0e30 + + do i=is,ie ; redo_i(i) = do_i(i) ; enddo + + do i=is,ie ; if (do_i(i)) then + ! The first guess of Ent was the value from the previous iteration. + + ! These were previously calculated and provide good limits and estimates + ! of the errors there. By construction the errors increase with R*ea_kbp1. + E_min(i) = min_eakb(i) ; E_max(i) = max_eakb(i) + error_minE(i) = -large_err ; error_maxE(i) = large_err + false_position(i) = .true. ! Used to alternate between false_position and + ! bisection when Newton's method isn't working. + if (present(err_min_eakb0)) error_minE(i) = err_min_eakb0(i) - E_min(i) * ea_kbp1(i) + if (present(err_max_eakb0)) error_maxE(i) = err_max_eakb0(i) - E_max(i) * ea_kbp1(i) + + if ((error_maxE(i) <= 0.0) .or. (error_minE(i) >= 0.0)) then + ! The root is not bracketed and one of the limiting values should be used. + if (error_maxE(i) <= 0.0) then + ! The errors decrease with E*ea_kbp1, so E_max is the best solution. + Ent(i) = E_max(i) ; err(i) = error_maxE(i) + else ! error_minE >= 0 is equivalent to ea_kbp1 = 0.0. + Ent(i) = E_min(i) ; err(i) = error_minE(i) + endif + derror_dE(i) = 0.0 + redo_i(i) = .false. + endif + endif ; enddo ! End of i-loop + + do it = 1,MAXIT + do_any = .false. ; do i=is,ie ; if (redo_i(i)) do_any = .true. ; enddo + if (.not.do_any) exit + call determine_dSkb(h_bl, Sref, Ent_bl, Ent, is, ie, kmb, G, GV, .true., dS_kb, & + ddSkb_dE, dS_lay, ddSlay_dE, do_i_in=redo_i) + do i=is,ie ; if (redo_i(i)) then + ! The correct root is bracketed between E_min and E_max. + ! Note the following limits: Ent >= 0 ; fa > 1 ; fk > 0 + eL = 0.0 ; if (2.0*Ent_bl(i,Kmb+1) >= Ent(i)) eL = 1.0 + fa = (1.0 + eL) + dS_kb(i)*I_dSkbp1(i) + fk = dtKd_kb(i) * (dS_Lay(i)/dS_kb(i)) + fm = (ea_kbp1(i) - h_bl(i,kmb+1)) + eL*2.0*Ent_bl(i,Kmb+1) + if (fm > -GV%Angstrom_H) fm = fm + GV%Angstrom_H ! This could be smooth if need be. + err(i) = (fa * Ent(i)**2 - fm * Ent(i)) - fk + derror_dE(i) = ((2.0*fa + (ddSkb_dE(i)*I_dSkbp1(i))*Ent(i))*Ent(i) - fm) - & + dtKd_kb(i) * (ddSlay_dE(i)*dS_kb(i) - ddSkb_dE(i)*dS_Lay(i))/(dS_kb(i)**2) + + if (err(i) == 0.0) then + redo_i(i) = .false. ; cycle + elseif (err(i) > 0.0) then + E_max(i) = Ent(i) ; error_maxE(i) = err(i) + else + E_min(i) = Ent(i) ; error_minE(i) = err(i) + endif + + E_prev = Ent(i) + if ((it == 1) .or. (derror_dE(i) <= 0.0)) then + ! Assuming that the coefficients of the quadratic equation are correct + ! will usually give a very good first guess. Also, if derror_dE < 0.0, + ! R is on the wrong side of the approximate parabola. In either case, + ! try assuming that the error is approximately a parabola and solve. + fr = sqrt(fm**2 + 4.0*fa*fk) + if (fm >= 0.0) then + Ent(i) = (fm + fr) / (2.0 * fa) + else + Ent(i) = (2.0 * fk) / (fr - fm) + endif + ! But make sure that the root stays bracketed, bisecting if needed. + if ((Ent(i) > E_max(i)) .or. (Ent(i) < E_min(i))) & + Ent(i) = 0.5*(E_max(i) + E_min(i)) + elseif (((E_max(i)-Ent(i))*derror_dE(i) > -err(i)) .and. & + ((Ent(i)-E_min(i))*derror_dE(i) > err(i)) ) then + ! Use Newton's method for the next estimate, provided it will + ! remain bracketed between Rmin and Rmax. + Ent(i) = Ent(i) - err(i) / derror_dE(i) + elseif (false_position(i) .and. & + (error_maxE(i) - error_minE(i) < 0.9*large_err)) then + ! Use the false position method if there are decent error estimates. + Ent(i) = E_min(i) + (E_max(i)-E_min(i)) * & + (-error_minE(i)/(error_maxE(i) - error_minE(i))) + false_position(i) = .false. + else ! Bisect as a last resort or if the false position method was used last. + Ent(i) = 0.5*(E_max(i) + E_min(i)) + false_position(i) = .true. + endif + + if (abs(E_prev - Ent(i)) < tolerance) then + err_est = err(i) + (Ent(i) - E_prev) * derror_dE(i) + if ((it > 1) .or. (err_est*err(i) <= 0.0) .or. & + (abs(err_est) < abs(tolerance*derror_dE(i)))) redo_i(i) = .false. + endif + + endif ; enddo ! End of i-loop + enddo ! End of iterations to determine Ent(i). + + ! Update the value of dS_kb for consistency with Ent. + if (present(F_kb) .or. present(dFdfm_kb)) & + call determine_dSkb(h_bl, Sref, Ent_bl, Ent, is, ie, kmb, G, GV, .true., & + dS_kb, do_i_in=do_i) + + if (present(F_kb)) then ; do i=is,ie ; if (do_i(i)) then + F_kb(i) = Ent(i) * (dS_kb(i) * I_dSkbp1(i)) + endif ; enddo ; endif + if (present(error)) then ; do i=is,ie ; if (do_i(i)) then + error(i) = err(i) + endif ; enddo ; endif + if (present(dFdfm_kb)) then ; do i=is,ie ; if (do_i(i)) then + ! derror_dE and ddSkb_dE are _not_ recalculated here, since dFdfm_kb is + ! only used in Newton's method, and slightly increasing the accuracy of the + ! estimate is unlikely to speed convergence. + if (derror_dE(i) > 0.0) then + dFdfm_kb(i) = ((dS_kb(i) + Ent(i) * ddSkb_dE(i)) * I_dSkbp1(i)) * & + (Ent(i) / derror_dE(i)) + else ! Use Adcroft's division by 0 convention. + dFdfm_kb(i) = 0.0 + endif + endif ; enddo ; endif + +end subroutine determine_Ea_kb + +!> Maximize F = ent*ds_kb*I_dSkbp1 in the range min_ent < ent < max_ent. +subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & + kmb, is, ie, G, GV, CS, maxF, ent_maxF, do_i_in, & + F_lim_maxent, F_thresh) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: h_bl !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: Sref !< Reference potential density [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: Ent_bl !< The average entrainment upward and + !! downward across each interface around + !! the buffer layers [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in + !! reference potential density across the + !! base of the uppermost interior layer + !! [R-1 ~> m3 kg-1]. + real, dimension(SZI_(G)), intent(in) :: min_ent_in !< The minimum value of ent to search, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: max_ent_in !< The maximum value of ent to search, + !! [H ~> m or kg m-2]. + integer, intent(in) :: kmb !< The number of mixed and buffer layers. + integer, intent(in) :: is !< The start of the i-index range to work on. + integer, intent(in) :: ie !< The end of the i-index range to work on. + type(entrain_diffusive_CS), intent(in) :: CS !< This module's control structure. + real, dimension(SZI_(G)), intent(out) :: maxF !< The maximum value of F + !! = ent*ds_kb*I_dSkbp1 found in the range + !! min_ent < ent < max_ent [H ~> m or kg m-2]. + real, dimension(SZI_(G)), & + optional, intent(out) :: ent_maxF !< The value of ent at that maximum [H ~> m or kg m-2]. + logical, dimension(SZI_(G)), & + optional, intent(in) :: do_i_in !< A logical array indicating which columns + !! to work on. + real, dimension(SZI_(G)), & + optional, intent(out) :: F_lim_maxent !< If present, do not apply the limit in + !! finding the maximum value, but return the + !! limited value at ent=max_ent_in in this + !! array [H ~> m or kg m-2]. + real, dimension(SZI_(G)), & + optional, intent(in) :: F_thresh !< If F_thresh is present, return the first value + !! found that has F > F_thresh [H ~> m or kg m-2], or + !! the maximum root if it is absent. + +! Maximize F = ent*ds_kb*I_dSkbp1 in the range min_ent < ent < max_ent. +! ds_kb may itself be limited to positive values in determine_dSkb, which gives +! the prospect of two local maxima in the range - one at max_ent_in with that +! minimum value of ds_kb, and the other due to the unlimited (potentially +! negative) value. It is faster to find the true maximum by first finding the +! unlimited maximum and comparing it to the limited value at max_ent_in. + real, dimension(SZI_(G)) :: & + ent, & ! The updated estimate of the entrainment [H ~> m or kg m-2] + minent, maxent, ent_best, & ! Various previous estimates of the entrainment [H ~> m or kg m-2] + F_max_ent_in, & ! The value of F that gives the input maximum value of ent [H ~> m or kg m-2] + F_maxent, F_minent, F, F_best, & ! Various estimates of F [H ~> m or kg m-2] + dF_dent, dF_dE_max, dF_dE_min, dF_dE_best, & ! Various derivatives of F with ent [nondim] + dS_kb, & ! The density difference across the interface between the bottommost + ! buffer layer and the topmost interior layer [R ~> kg m-3] + dS_kb_lim, dS_anom_lim, & ! Various limits on dS_kb [R ~> kg m-3] + ddSkb_dE, & ! The partial derivative of dS_kb with ent [R H-1 ~> kg m-4 or m-1]. + chg_prev, chg_pre_prev ! Changes in estimates of the entrainment from previous iterations [H ~> m or kg m-2] + real :: dF_dE_mean, maxslope, minslope ! Various derivatives of F with ent [nondim] + real :: tolerance ! The tolerance within which ent must be converged [H ~> m or kg m-2] + real :: ratio_select_end, rat ! Fractional changes in the value of ent to use for the next iteration + ! relative to its bounded range [nondim] + real :: max_chg, min_chg, chg1, chg2, chg ! Changes in entrainment estimates [H ~> m or kg m-2] + logical, dimension(SZI_(G)) :: do_i, last_it, need_bracket, may_use_best + logical :: doany, OK1, OK2, bisect, new_min_bound + integer :: i, it, is1, ie1 + integer, parameter :: MAXIT = 20 + + tolerance = CS%Tolerance_Ent + + if (present(do_i_in)) then + do i=is,ie ; do_i(i) = do_i_in(i) ; enddo + else + do i=is,ie ; do_i(i) = .true. ; enddo + endif + + ! The most likely value is at max_ent. + call determine_dSkb(h_bl, Sref, Ent_bl, max_ent_in, is, ie, kmb, G, GV, .false., & + dS_kb, ddSkb_dE, dS_anom_lim=dS_anom_lim) + ie1 = is-1 ; doany = .false. + do i=is,ie + dS_kb_lim(i) = dS_kb(i) + dS_anom_lim(i) + F_max_ent_in(i) = max_ent_in(i)*dS_kb_lim(i)*I_dSkbp1(i) + maxent(i) = max_ent_in(i) ; minent(i) = min_ent_in(i) + if ((abs(maxent(i) - minent(i)) < tolerance) .or. (.not.do_i(i))) then + F_best(i) = max_ent_in(i)*dS_kb(i)*I_dSkbp1(i) + ent_best(i) = max_ent_in(i) ; ent(i) = max_ent_in(i) + do_i(i) = .false. + else + F_maxent(i) = maxent(i) * dS_kb(i) * I_dSkbp1(i) + dF_dE_max(i) = (dS_kb(i) + maxent(i)*ddSkb_dE(i)) * I_dSkbp1(i) + doany = .true. ; last_it(i) = .false. ; need_bracket(i) = .true. + endif + enddo + + if (doany) then + ie1 = is-1 ; do i=is,ie ; if (do_i(i)) ie1 = i ; enddo + do i=ie1,is,-1 ; if (do_i(i)) is1 = i ; enddo + ! Find the value of F and its derivative at min_ent. + call determine_dSkb(h_bl, Sref, Ent_bl, minent, is1, ie1, kmb, G, GV, .false., & + dS_kb, ddSkb_dE, do_i_in=do_i) + do i=is1,ie1 ; if (do_i(i)) then + F_minent(i) = minent(i) * dS_kb(i) * I_dSkbp1(i) + dF_dE_min(i) = (dS_kb(i) + minent(i)*ddSkb_dE(i)) * I_dSkbp1(i) + endif ; enddo + + ratio_select_end = 0.9 + do it=1,MAXIT + ratio_select_end = 0.5*ratio_select_end + do i=is1,ie1 ; if (do_i(i)) then + if (need_bracket(i)) then + dF_dE_mean = (F_maxent(i) - F_minent(i)) / (maxent(i) - minent(i)) + maxslope = MAX(dF_dE_mean, dF_dE_min(i), dF_dE_max(i)) + minslope = MIN(dF_dE_mean, dF_dE_min(i), dF_dE_max(i)) + if (F_minent(i) >= F_maxent(i)) then + if (dF_dE_min(i) > 0.0) then ; rat = 0.02 ! A small step should bracket the solution. + elseif (maxslope < ratio_select_end*minslope) then + ! The maximum of F is at minent. + F_best(i) = F_minent(i) ; ent_best(i) = minent(i) ; rat = 0.0 + do_i(i) = .false. + else ; rat = 0.382 ; endif ! Use the golden ratio + else + if (dF_dE_max(i) < 0.0) then ; rat = 0.98 ! A small step should bracket the solution. + elseif (minslope > ratio_select_end*maxslope) then + ! The maximum of F is at maxent. + F_best(i) = F_maxent(i) ; ent_best(i) = maxent(i) ; rat = 1.0 + do_i(i) = .false. + else ; rat = 0.618 ; endif ! Use the golden ratio + endif + + if (rat >= 0.0) ent(i) = rat*maxent(i) + (1.0-rat)*minent(i) + if (((maxent(i) - minent(i)) < tolerance) .or. (it==MAXIT)) & + last_it(i) = .true. + else ! The maximum is bracketed by minent, ent_best, and maxent. + chg1 = 2.0*(maxent(i) - minent(i)) ; chg2 = chg1 + if (dF_dE_best(i) > 0) then + max_chg = maxent(i) - ent_best(i) ; min_chg = 0.0 + else + max_chg = 0.0 ; min_chg = minent(i) - ent_best(i) ! < 0 + endif + if (max_chg - min_chg < 2.0*tolerance) last_it(i) = .true. + if (dF_dE_max(i) /= dF_dE_best(i)) & + chg1 = (maxent(i) - ent_best(i))*dF_dE_best(i) / & + (dF_dE_best(i) - dF_dE_max(i)) + if (dF_dE_min(i) /= dF_dE_best(i)) & + chg2 = (minent(i) - ent_best(i))*dF_dE_best(i) / & + (dF_dE_best(i) - dF_dE_min(i)) + OK1 = ((chg1 < max_chg) .and. (chg1 > min_chg)) + OK2 = ((chg2 < max_chg) .and. (chg2 > min_chg)) + if (.not.(OK1 .or. OK2)) then ; bisect = .true. ; else + if (OK1 .and. OK2) then ! Take the acceptable smaller change. + chg = chg1 ; if (abs(chg2) < abs(chg1)) chg = chg2 + elseif (OK1) then ; chg = chg1 + else ; chg = chg2 ; endif + if (abs(chg) > 0.5*abs(chg_pre_prev(i))) then ; bisect = .true. + else ; bisect = .false. ; endif + endif + chg_pre_prev(i) = chg_prev(i) + if (bisect) then + if (dF_dE_best(i) > 0.0) then + ent(i) = 0.5*(maxent(i) + ent_best(i)) + chg_prev(i) = 0.5*(maxent(i) - ent_best(i)) + else + ent(i) = 0.5*(minent(i) + ent_best(i)) + chg_prev(i) = 0.5*(minent(i) - ent_best(i)) + endif + else + if (abs(chg) < tolerance) chg = SIGN(tolerance,chg) + ent(i) = ent_best(i) + chg + chg_prev(i) = chg + endif + endif + endif ; enddo + + if (mod(it,3) == 0) then ! Re-determine the loop bounds. + ie1 = is-1 ; do i=is1,ie ; if (do_i(i)) ie1 = i ; enddo + do i=ie1,is,-1 ; if (do_i(i)) is1 = i ; enddo + endif + + call determine_dSkb(h_bl, Sref, Ent_bl, ent, is1, ie1, kmb, G, GV, .false., & + dS_kb, ddSkb_dE, do_i_in=do_i) + do i=is1,ie1 ; if (do_i(i)) then + F(i) = ent(i)*dS_kb(i)*I_dSkbp1(i) + dF_dent(i) = (dS_kb(i) + ent(i)*ddSkb_dE(i)) * I_dSkbp1(i) + endif ; enddo + + if (present(F_thresh)) then ; do i=is1,ie1 ; if (do_i(i)) then + if (F(i) >= F_thresh(i)) then + F_best(i) = F(i) ; ent_best(i) = ent(i) ; do_i(i) = .false. + endif + endif ; enddo ; endif + + doany = .false. + do i=is1,ie1 ; if (do_i(i)) then + if (.not.last_it(i)) doany = .true. + if (last_it(i)) then + if (need_bracket(i)) then + if ((F(i) > F_maxent(i)) .and. (F(i) > F_minent(i))) then + F_best(i) = F(i) ; ent_best(i) = ent(i) + elseif (F_maxent(i) > F_minent(i)) then + F_best(i) = F_maxent(i) ; ent_best(i) = maxent(i) + else + F_best(i) = F_minent(i) ; ent_best(i) = minent(i) + endif + elseif (F(i) > F_best(i)) then + F_best(i) = F(i) ; ent_best(i) = ent(i) + endif + do_i(i) = .false. + elseif (need_bracket(i)) then + if ((F(i) > F_maxent(i)) .and. (F(i) > F_minent(i))) then + need_bracket(i) = .false. ! The maximum is now bracketed. + chg_prev(i) = (maxent(i) - minent(i)) + chg_pre_prev(i) = 2.0*chg_prev(i) + ent_best(i) = ent(i) ; F_best(i) = F(i) ; dF_dE_best(i) = dF_dent(i) + elseif ((F(i) <= F_maxent(i)) .and. (F(i) > F_minent(i))) then + new_min_bound = .true. ! We have a new minimum bound. + elseif ((F(i) <= F_maxent(i)) .and. (F(i) > F_minent(i))) then + new_min_bound = .false. ! We have a new maximum bound. + else ! This case would bracket a minimum. Weird. + ! Unless the derivative indicates that there is a maximum near the + ! lower bound, try keeping the end with the larger value of F + ! in a tie keep the minimum as the answer here will be compared + ! with the maximum input value later. + new_min_bound = .true. + if (dF_dE_min(i) > 0.0 .or. (F_minent(i) >= F_maxent(i))) & + new_min_bound = .false. + endif + if (need_bracket(i)) then ! Still not bracketed. + if (new_min_bound) then + minent(i) = ent(i) ; F_minent(i) = F(i) ; dF_dE_min(i) = dF_dent(i) + else + maxent(i) = ent(i) ; F_maxent(i) = F(i) ; dF_dE_max(i) = dF_dent(i) + endif + endif + else ! The root was previously bracketed. + if (F(i) >= F_best(i)) then ! There is a new maximum. + if (ent(i) > ent_best(i)) then ! Replace minent with ent_prev. + minent(i) = ent_best(i) ; F_minent(i) = F_best(i) ; dF_dE_min(i) = dF_dE_best(i) + else ! Replace maxent with ent_best. + maxent(i) = ent_best(i) ; F_maxent(i) = F_best(i) ; dF_dE_max(i) = dF_dE_best(i) + endif + ent_best(i) = ent(i) ; F_best(i) = F(i) ; dF_dE_best(i) = dF_dent(i) + else + if (ent(i) < ent_best(i)) then ! Replace the minent with ent. + minent(i) = ent(i) ; F_minent(i) = F(i) ; dF_dE_min(i) = dF_dent(i) + else ! Replace maxent with ent_prev. + maxent(i) = ent(i) ; F_maxent(i) = F(i) ; dF_dE_max(i) = dF_dent(i) + endif + endif + if ((maxent(i) - minent(i)) <= tolerance) do_i(i) = .false. ! Done. + endif ! need_bracket. + endif ; enddo + if (.not.doany) exit + enddo + endif + + if (present(F_lim_maxent)) then + ! Return the unlimited maximum in maxF, and the limited value of F at maxent. + do i=is,ie + maxF(i) = F_best(i) + F_lim_maxent(i) = F_max_ent_in(i) + if (present(ent_maxF)) ent_maxF(i) = ent_best(i) + enddo + else + ! Now compare the two? potential maxima using the limited value of dF_kb. + doany = .false. + do i=is,ie + may_use_best(i) = (ent_best(i) /= max_ent_in(i)) + if (may_use_best(i)) doany = .true. + enddo + if (doany) then + ! For efficiency, could save previous value of dS_anom_lim_best? + call determine_dSkb(h_bl, Sref, Ent_bl, ent_best, is, ie, kmb, G, GV, .true., dS_kb_lim) + do i=is,ie + F_best(i) = ent_best(i)*dS_kb_lim(i)*I_dSkbp1(i) + ! The second test seems necessary because of roundoff differences that + ! can arise during compilation. + if ((F_best(i) > F_max_ent_in(i)) .and. (may_use_best(i))) then + maxF(i) = F_best(i) + if (present(ent_maxF)) ent_maxF(i) = ent_best(i) + else + maxF(i) = F_max_ent_in(i) + if (present(ent_maxF)) ent_maxF(i) = max_ent_in(i) + endif + enddo + else + ! All of the maxima are at the maximum entrainment. + do i=is,ie ; maxF(i) = F_max_ent_in(i) ; enddo + if (present(ent_maxF)) then + do i=is,ie ; ent_maxF(i) = max_ent_in(i) ; enddo + endif + endif + endif + +end subroutine find_maxF_kb + +!> This subroutine initializes the parameters and memory associated with the +!! entrain_diffusive module. +subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_read_params) + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic + !! output. + type(entrain_diffusive_CS), intent(inout) :: CS !< Entrainment diffusion control structure + logical, intent(in) :: just_read_params !< If true, this call will only read + !! and log parameters without registering + !! any diagnostics + + ! Local variables + real :: dt ! The dynamics timestep, used here in the default for TOLERANCE_ENT [T ~> s] + real :: Kd ! A diffusivity used in the default for TOLERANCE_ENT [Z2 T-1 ~> m2 s-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_entrain_diffusive" ! This module's name. + + CS%initialized = .true. + CS%diag => diag + + CS%bulkmixedlayer = (GV%nkml > 0) + + ! Set default, read and log parameters + if (.not.just_read_params) call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "MAX_ENT_IT", CS%max_ent_it, & + "The maximum number of iterations that may be used to "//& + "calculate the interior diapycnal entrainment.", default=5, do_not_log=just_read_params) + ! In this module, KD is only used to set the default for TOLERANCE_ENT. [Z2 T-1 ~> m2 s-1] + call get_param(param_file, mdl, "KD", Kd, units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) + call get_param(param_file, mdl, "DT", dt, & + "The (baroclinic) dynamics time step.", & + units="s", scale=US%s_to_T, fail_if_missing=.true., do_not_log=just_read_params) + call get_param(param_file, mdl, "TOLERANCE_ENT", CS%Tolerance_Ent, & + "The tolerance with which to solve for entrainment values.", & + units="m", default=US%Z_to_m*MAX(100.0*GV%Angstrom_Z,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H, & + do_not_log=just_read_params) + call get_param(param_file, mdl, "ENTRAIN_DIFFUSIVE_MAX_ENT", CS%max_Ent, & + "A large ceiling on the maximum permitted amount of entrainment across each "//& + "interface between the mixed and buffer layers within a timestep.", & + units="m", default=1.0e4, scale=GV%m_to_H, do_not_log=.not.CS%bulkmixedlayer) + + CS%Rho_sig_off = 1000.0*US%kg_m3_to_R + + if (.not.just_read_params) then + CS%id_Kd = register_diag_field('ocean_model', 'Kd_effective', diag%axesTL, Time, & + 'Diapycnal diffusivity as applied', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + CS%id_diff_work = register_diag_field('ocean_model', 'diff_work', diag%axesTi, Time, & + 'Work actually done by diapycnal diffusion across each interface', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + endif +end subroutine entrain_diffusive_init + +!> \namespace mom_entrain_diffusive +!! +!! By Robert Hallberg, September 1997 - July 2000 +!! +!! This file contains the subroutines that implement diapycnal +!! mixing and advection in isopycnal layers. The main subroutine, +!! calculate_entrainment, returns the entrainment by each layer +!! across the interfaces above and below it. These are calculated +!! subject to the constraints that no layers can be driven to negative +!! thickness and that the each layer maintains its target density, +!! using the scheme described in Hallberg (MWR 2000). There may or +!! may not be a bulk mixed layer above the isopycnal layers. +!! The solution is iterated until the change in the entrainment +!! between successive iterations is less than some small tolerance. +!! +!! The dual-stream entrainment scheme of MacDougall and Dewar +!! (JPO 1997) is used for combined diapycnal advection and diffusion, +!! modified as described in Hallberg (MWR 2000) to be solved +!! implicitly in time. Any profile of diffusivities may be used. +!! Diapycnal advection is fundamentally the residual of diapycnal +!! diffusion, so the fully implicit upwind differencing scheme that +!! is used is entirely appropriate. The downward buoyancy flux in +!! each layer is determined from an implicit calculation based on +!! the previously calculated flux of the layer above and an estimated +!! flux in the layer below. This flux is subject to the following +!! conditions: (1) the flux in the top and bottom layers are +!! set by the boundary conditions, and (2) no layer may be driven +!! below an Angstrom thickness. If there is a bulk mixed layer, the +!! mixed and buffer layers are treated as Eulerian layers, whose +!! thicknesses only change due to entrainment by the interior layers. + +end module MOM_entrain_diffusive diff --git a/parameterizations/vertical/MOM_full_convection.F90 b/parameterizations/vertical/MOM_full_convection.F90 new file mode 100644 index 0000000000..a5fba3adc6 --- /dev/null +++ b/parameterizations/vertical/MOM_full_convection.F90 @@ -0,0 +1,419 @@ +!> Does full convective adjustment of unstable regions via a strong diffusivity. +module MOM_full_convection + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs, EOS_domain + +implicit none ; private + +#include + +public full_convection + +contains + +!> Calculate new temperatures and salinities that have been subject to full convective mixing. +subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, halo) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: T_adj !< Adjusted potential temperature [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: S_adj !< Adjusted salinity [S ~> ppt]. + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] (or NULL). + real, intent(in) :: Kddt_smooth !< A smoothing vertical diffusivity + !! times a timestep [H Z ~> m2 or kg m-1]. + integer, intent(in) :: halo !< Halo width over which to compute + + ! Local variables + real, dimension(SZI_(G),SZK_(GV)+1) :: & + dRho_dT, & ! The derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS ! The derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. +! logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + real, dimension(SZI_(G),SZK0_(G)) :: & + Te_a, & ! A partially updated temperature estimate including the influence from + ! mixing with layers above rescaled by a factor of d_a [C ~> degC]. + ! This array is discretized on tracer cells, but contains an extra + ! layer at the top for algorithmic convenience. + Se_a ! A partially updated salinity estimate including the influence from + ! mixing with layers above rescaled by a factor of d_a [S ~> ppt]. + ! This array is discretized on tracer cells, but contains an extra + ! layer at the top for algorithmic convenience. + real, dimension(SZI_(G),SZK_(GV)+1) :: & + Te_b, & ! A partially updated temperature estimate including the influence from + ! mixing with layers below rescaled by a factor of d_b [C ~> degC]. + ! This array is discretized on tracer cells, but contains an extra + ! layer at the bottom for algorithmic convenience. + Se_b ! A partially updated salinity estimate including the influence from + ! mixing with layers below rescaled by a factor of d_b [S ~> ppt]. + ! This array is discretized on tracer cells, but contains an extra + ! layer at the bottom for algorithmic convenience. + real, dimension(SZI_(G),SZK_(GV)+1) :: & + c_a, & ! The fractional influence of the properties of the layer below + ! in the final properties with a downward-first solver [nondim] + d_a, & ! The fractional influence of the properties of the layer in question + ! and layers above in the final properties with a downward-first solver [nondim] + ! d_a = 1.0 - c_a + c_b, & ! The fractional influence of the properties of the layer above + ! in the final properties with a upward-first solver [nondim] + d_b ! The fractional influence of the properties of the layer in question + ! and layers below in the final properties with a upward-first solver [nondim] + ! d_b = 1.0 - c_b + real, dimension(SZI_(G),SZK_(GV)+1) :: & + mix !< The amount of mixing across the interface between layers [H ~> m or kg m-2]. + real :: mix_len ! The length-scale of mixing, when it is active [H ~> m or kg m-2] + real :: h_b, h_a ! The thicknesses of the layers above and below an interface [H ~> m or kg m-2] + real :: b_b, b_a ! Inverse pivots used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + + logical, dimension(SZI_(G)) :: do_i ! Do more work on this column. + logical, dimension(SZI_(G)) :: last_down ! The last setup pass was downward. + integer, dimension(SZI_(G)) :: change_ct ! The number of interfaces where the + ! mixing has changed this iteration. + integer :: changed_col ! The number of columns whose mixing changed. + integer :: i, j, k, is, ie, js, je, nz, itt + + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + nz = GV%ke + + if (.not.associated(tv%eqn_of_state)) return + + h_neglect = GV%H_subroundoff + mix_len = (1.0e20 * nz) * (G%max_depth * US%Z_to_m * GV%m_to_H) + + do j=js,je + mix(:,:) = 0.0 ; d_b(:,:) = 1.0 + ! These would be Te_b(:,:) = tv%T(:,j,:), etc., but the values are not used + Te_b(:,:) = 0.0 ; Se_b(:,:) = 0.0 + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV, halo_size=halo) + + call smoothed_dRdT_dRdS(h, dz, tv, Kddt_smooth, dRho_dT, dRho_dS, G, GV, US, j, p_surf, halo) + + do i=is,ie + do_i(i) = (G%mask2dT(i,j) > 0.0) + + d_a(i,1) = 1.0 + last_down(i) = .true. ! This is set for debuggers. + ! These are extra values are used for convenience in the stability test + Te_a(i,0) = 0.0 ; Se_a(i,0) = 0.0 + enddo + + do itt=1,nz ! At least 2 interfaces will change with each full pass, or the + ! iterations stop, so the maximum count of nz is very conservative. + + do i=is,ie ; change_ct(i) = 0 ; enddo + ! Move down the water column, finding unstable interfaces, and building up the + ! temporary arrays for the tridiagonal solver. + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + + h_a = h(i,j,k-1) + h_neglect ; h_b = h(i,j,k) + h_neglect + if (mix(i,K) <= 0.0) then + if (is_unstable(dRho_dT(i,K), dRho_dS(i,K), h_a, h_b, mix(i,K-1), mix(i,K+1), & + tv%T(i,j,k-1), tv%T(i,j,k), tv%S(i,j,k-1), tv%S(i,j,k), & + Te_a(i,k-2), Te_b(i,k+1), Se_a(i,k-2), Se_b(i,k+1), & + d_a(i,K-1), d_b(i,K+1))) then + mix(i,K) = mix_len + change_ct(i) = change_ct(i) + 1 + endif + endif + + b_a = 1.0 / ((h_a + d_a(i,K-1)*mix(i,K-1)) + mix(i,K)) + if (mix(i,K) <= 0.0) then + c_a(i,K) = 0.0 ; d_a(i,K) = 1.0 + else + d_a(i,K) = b_a * (h_a + d_a(i,K-1)*mix(i,K-1)) ! = 1.0-c_a(i,K) + c_a(i,K) = 1.0 ; if (d_a(i,K) > epsilon(b_a)) c_a(i,K) = b_a * mix(i,K) + endif + + if (K>2) then + Te_a(i,k-1) = b_a * (h_a*tv%T(i,j,k-1) + mix(i,K-1)*Te_a(i,k-2)) + Se_a(i,k-1) = b_a * (h_a*tv%S(i,j,k-1) + mix(i,K-1)*Se_a(i,k-2)) + else + Te_a(i,k-1) = b_a * (h_a*tv%T(i,j,k-1)) + Se_a(i,k-1) = b_a * (h_a*tv%S(i,j,k-1)) + endif + endif ; enddo ; enddo + + ! Determine which columns might have further instabilities. + changed_col = 0 + do i=is,ie ; if (do_i(i)) then + if (change_ct(i) == 0) then + last_down(i) = .true. ; do_i(i) = .false. + else + changed_col = changed_col + 1 ; change_ct(i) = 0 + endif + endif ; enddo + if (changed_col == 0) exit ! No more columns are unstable. + + ! This is the same as above, but with the direction reversed (bottom to top) + do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then + + h_a = h(i,j,k-1) + h_neglect ; h_b = h(i,j,k) + h_neglect + if (mix(i,K) <= 0.0) then + if (is_unstable(dRho_dT(i,K), dRho_dS(i,K), h_a, h_b, mix(i,K-1), mix(i,K+1), & + tv%T(i,j,k-1), tv%T(i,j,k), tv%S(i,j,k-1), tv%S(i,j,k), & + Te_a(i,k-2), Te_b(i,k+1), Se_a(i,k-2), Se_b(i,k+1), & + d_a(i,K-1), d_b(i,K+1))) then + mix(i,K) = mix_len + change_ct(i) = change_ct(i) + 1 + endif + endif + + b_b = 1.0 / ((h_b + d_b(i,K+1)*mix(i,K+1)) + mix(i,K)) + if (mix(i,K) <= 0.0) then + c_b(i,K) = 0.0 ; d_b(i,K) = 1.0 + else + d_b(i,K) = b_b * (h_b + d_b(i,K+1)*mix(i,K+1)) ! = 1.0-c_b(i,K) + c_b(i,K) = 1.0 ; if (d_b(i,K) > epsilon(b_b)) c_b(i,K) = b_b * mix(i,K) + endif + + if (k 0.0) .and. last_down(i)) ; enddo + do i=is,ie ; if (do_i(i)) then + h_a = h(i,j,nz) + h_neglect + b_a = 1.0 / (h_a + d_a(i,nz)*mix(i,nz)) + T_adj(i,j,nz) = b_a * (h_a*tv%T(i,j,nz) + mix(i,nz)*Te_a(i,nz-1)) + S_adj(i,j,nz) = b_a * (h_a*tv%S(i,j,nz) + mix(i,nz)*Se_a(i,nz-1)) + endif ; enddo + do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then + T_adj(i,j,k) = Te_a(i,k) + c_a(i,K+1)*T_adj(i,j,k+1) + S_adj(i,j,k) = Se_a(i,k) + c_a(i,K+1)*S_adj(i,j,k+1) + endif ; enddo ; enddo + + do i=is,ie ; if (do_i(i)) then + k = 1 ! A hook for debugging. + endif ; enddo + + ! Do the final return pass on the columns where the penultimate pass was upward. + ! Also do a simple copy of T & S values on land points. + do i=is,ie + do_i(i) = ((G%mask2dT(i,j) > 0.0) .and. .not.last_down(i)) + if (do_i(i)) then + h_b = h(i,j,1) + h_neglect + b_b = 1.0 / (h_b + d_b(i,2)*mix(i,2)) + T_adj(i,j,1) = b_b * (h_b*tv%T(i,j,1) + mix(i,2)*Te_b(i,2)) + S_adj(i,j,1) = b_b * (h_b*tv%S(i,j,1) + mix(i,2)*Se_b(i,2)) + elseif (G%mask2dT(i,j) <= 0.0) then + T_adj(i,j,1) = tv%T(i,j,1) ; S_adj(i,j,1) = tv%S(i,j,1) + endif + enddo + do k=2,nz ; do i=is,ie + if (do_i(i)) then + T_adj(i,j,k) = Te_b(i,k) + c_b(i,K)*T_adj(i,j,k-1) + S_adj(i,j,k) = Se_b(i,k) + c_b(i,K)*S_adj(i,j,k-1) + elseif (G%mask2dT(i,j) <= 0.0) then + T_adj(i,j,k) = tv%T(i,j,k) ; S_adj(i,j,k) = tv%S(i,j,k) + endif + enddo ; enddo + + do i=is,ie ; if (do_i(i)) then + k = 1 ! A hook for debugging. + endif ; enddo + + enddo ! j-loop + + k = 1 ! A hook for debugging. + + ! The following set of expressions for the final values are derived from the partial + ! updates for the estimated temperatures and salinities around an interface, then directly + ! solving for the final temperatures and salinities. They are here for later reference + ! and to document an intermediate step in the stability calculation. + ! hp_a = (h_a + d_a(i,K-1)*mix(i,K-1)) + ! hp_b = (h_b + d_b(i,K+1)*mix(i,K+1)) + ! b2_c = 1.0 / (hp_a*hp_b + (hp_a + hp_b) * mix(i,K)) + ! Th_a = h_a*tv%T(i,j,k-1) + mix(i,K-1)*Te_a(i,k-2) + ! Th_b = h_b*tv%T(i,j,k) + mix(i,K+1)*Te_b(i,k+1) + ! T_fin(i,k) = ( (hp_a + mix(i,K)) * Th_b + Th_a * mix(i,K) ) * b2_c + ! T_fin(i,k-1) = ( (hp_b + mix(i,K)) * Th_a + Th_b * mix(i,K) ) * b2_c + ! Sh_a = h_a*tv%S(i,j,k-1) + mix(i,K-1)*Se_a(i,k-2) + ! Sh_b = h_b*tv%S(i,j,k) + mix(i,K+1)*Se_b(i,k+1) + ! S_fin(i,k) = ( (hp_a + mix(i,K)) * Sh_b + Sh_a * mix(i,K) ) * b2_c + ! S_fin(i,k-1) = ( (hp_b + mix(i,K)) * Sh_a + Sh_b * mix(i,K) ) * b2_c + +end subroutine full_convection + +!> This function returns True if the profiles around the given interface will be +!! statically unstable after mixing above below. The arguments are the ocean state +!! above and below, including partial calculations from a tridiagonal solver. +function is_unstable(dRho_dT, dRho_dS, h_a, h_b, mix_A, mix_B, T_a, T_b, S_a, S_b, & + Te_aa, Te_bb, Se_aa, Se_bb, d_A, d_B) + real, intent(in) :: dRho_dT !< The derivative of in situ density with temperature [R C-1 ~> kg m-3 degC-1] + real, intent(in) :: dRho_dS !< The derivative of in situ density with salinity [R S-1 ~> kg m-3 ppt-1] + real, intent(in) :: h_a !< The thickness of the layer above [H ~> m or kg m-2] + real, intent(in) :: h_b !< The thickness of the layer below [H ~> m or kg m-2] + real, intent(in) :: mix_A !< The time integrated mixing rate of the interface above [H ~> m or kg m-2] + real, intent(in) :: mix_B !< The time integrated mixing rate of the interface below [H ~> m or kg m-2] + real, intent(in) :: T_a !< The initial temperature of the layer above [C ~> degC] + real, intent(in) :: T_b !< The initial temperature of the layer below [C ~> degC] + real, intent(in) :: S_a !< The initial salinity of the layer below [S ~> ppt] + real, intent(in) :: S_b !< The initial salinity of the layer below [S ~> ppt] + real, intent(in) :: Te_aa !< The estimated temperature two layers above rescaled by d_A [C ~> degC] + real, intent(in) :: Te_bb !< The estimated temperature two layers below rescaled by d_B [C ~> degC] + real, intent(in) :: Se_aa !< The estimated salinity two layers above rescaled by d_A [S ~> ppt] + real, intent(in) :: Se_bb !< The estimated salinity two layers below rescaled by d_B [S ~> ppt] + real, intent(in) :: d_A !< The rescaling dependency across the interface above [nondim] + real, intent(in) :: d_B !< The rescaling dependency across the interface below [nondim] + logical :: is_unstable !< The return value, true if the profile is statically unstable + !! around the interface in question. + + ! These expressions for the local stability are long, but they have been carefully + ! grouped for accuracy even when the mixing rates are huge or tiny, and common + ! positive definite factors that would appear in the final expression for the + ! locally referenced potential density difference across an interface have been omitted. + is_unstable = (dRho_dT * ((h_a * h_b * (T_b - T_a) + & + mix_A*mix_B * (d_A*Te_bb - d_B*Te_aa)) + & + (h_a*mix_B * (Te_bb - d_B*T_a) + & + h_b*mix_A * (d_A*T_b - Te_aa)) ) + & + dRho_dS * ((h_a * h_b * (S_b - S_a) + & + mix_A*mix_B * (d_A*Se_bb - d_B*Se_aa)) + & + (h_a*mix_B * (Se_bb - d_B*S_a) + & + h_b*mix_A * (d_A*S_b - Se_aa)) ) < 0.0) +end function is_unstable + +!> Returns the partial derivatives of locally referenced potential density with +!! temperature and salinity after the properties have been smoothed with a small +!! constant diffusivity. +subroutine smoothed_dRdT_dRdS(h, dz, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, halo) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dz !< Height change across layers [Z ~> m] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, intent(in) :: Kddt !< A diffusivity times a time increment [H Z ~> m2 or kg m-1]. + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(out) :: dR_dT !< Derivative of locally referenced + !! potential density with temperature [R C-1 ~> kg m-3 degC-1] + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(out) :: dR_dS !< Derivative of locally referenced + !! potential density with salinity [R S-1 ~> kg m-3 ppt-1] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: j !< The j-point to work on. + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa]. + integer, intent(in) :: halo !< Halo width over which to compute + + ! Local variables + real :: mix(SZI_(G),SZK_(GV)+1) ! The diffusive mixing length (kappa*dt)/dz + ! between layers within in a timestep [H ~> m or kg m-2]. + real :: b1(SZI_(G)) ! A tridiagonal solver variable [H-1 ~> m-1 or m2 kg-1] + real :: d1(SZI_(G)) ! A tridiagonal solver variable [nondim] + real :: c1(SZI_(G),SZK_(GV)) ! A tridiagonal solver variable [nondim] + real :: T_f(SZI_(G),SZK_(GV)) ! Filtered temperatures [C ~> degC] + real :: S_f(SZI_(G),SZK_(GV)) ! Filtered salinities [S ~> ppt] + real :: pres(SZI_(G)) ! Interface pressures [R L2 T-2 ~> Pa]. + real :: T_EOS(SZI_(G)) ! Filtered and vertically averaged temperatures [C ~> degC] + real :: S_EOS(SZI_(G)) ! Filtered and vertically averaged salinities [S ~> ppt] + real :: kap_dt_x2 ! The product of 2*kappa*dt [H Z ~> m2 or kg m-1]. + real :: dz_neglect, h0 ! A negligible vertical distances [Z ~> m] + real :: h_neglect ! A negligible thickness to allow for zero thicknesses + ! [H ~> m or kg m-2]. + real :: h_tr ! The thickness at tracer points, plus h_neglect [H ~> m or kg m-2]. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, k, is, ie, nz + + is = G%isc-halo ; ie = G%iec+halo + nz = GV%ke + + h_neglect = GV%H_subroundoff + dz_neglect = GV%dz_subroundoff + kap_dt_x2 = 2.0*Kddt + + if (Kddt <= 0.0) then + do k=1,nz ; do i=is,ie + T_f(i,k) = tv%T(i,j,k) ; S_f(i,k) = tv%S(i,j,k) + enddo ; enddo + else + h0 = 1.0e-16*sqrt(GV%H_to_m*US%m_to_Z*Kddt) + dz_neglect + do i=is,ie + mix(i,2) = kap_dt_x2 / ((dz(i,1)+dz(i,2)) + h0) + + h_tr = h(i,j,1) + h_neglect + b1(i) = 1.0 / (h_tr + mix(i,2)) + d1(i) = b1(i) * h(i,j,1) + T_f(i,1) = (b1(i)*h_tr)*tv%T(i,j,1) + S_f(i,1) = (b1(i)*h_tr)*tv%S(i,j,1) + enddo + do k=2,nz-1 ; do i=is,ie + mix(i,K+1) = kap_dt_x2 / ((dz(i,k)+dz(i,k+1)) + h0) + + c1(i,k) = mix(i,K) * b1(i) + h_tr = h(i,j,k) + h_neglect + b1(i) = 1.0 / ((h_tr + d1(i)*mix(i,K)) + mix(i,K+1)) + d1(i) = b1(i) * (h_tr + d1(i)*mix(i,K)) + T_f(i,k) = b1(i) * (h_tr*tv%T(i,j,k) + mix(i,K)*T_f(i,k-1)) + S_f(i,k) = b1(i) * (h_tr*tv%S(i,j,k) + mix(i,K)*S_f(i,k-1)) + enddo ; enddo + do i=is,ie + c1(i,nz) = mix(i,nz) * b1(i) + h_tr = h(i,j,nz) + h_neglect + b1(i) = 1.0 / (h_tr + d1(i)*mix(i,nz)) + T_f(i,nz) = b1(i) * (h_tr*tv%T(i,j,nz) + mix(i,nz)*T_f(i,nz-1)) + S_f(i,nz) = b1(i) * (h_tr*tv%S(i,j,nz) + mix(i,nz)*S_f(i,nz-1)) + enddo + do k=nz-1,1,-1 ; do i=is,ie + T_f(i,k) = T_f(i,k) + c1(i,k+1)*T_f(i,k+1) + S_f(i,k) = S_f(i,k) + c1(i,k+1)*S_f(i,k+1) + enddo ; enddo + endif + + if (associated(p_surf)) then + do i=is,ie ; pres(i) = p_surf(i,j) ; enddo + else + do i=is,ie ; pres(i) = 0.0 ; enddo + endif + EOSdom(:) = EOS_domain(G%HI, halo) + call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), tv%eqn_of_state, EOSdom) + do i=is,ie ; pres(i) = pres(i) + h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) ; enddo + do K=2,nz + do i=is,ie + T_EOS(i) = 0.5*(T_f(i,k-1) + T_f(i,k)) + S_EOS(i) = 0.5*(S_f(i,k-1) + S_f(i,k)) + enddo + call calculate_density_derivs(T_EOS, S_EOS, pres, dR_dT(:,K), dR_dS(:,K), tv%eqn_of_state, EOSdom) + do i=is,ie ; pres(i) = pres(i) + h(i,j,k)*(GV%H_to_RZ*GV%g_Earth) ; enddo + enddo + call calculate_density_derivs(T_f(:,nz), S_f(:,nz), pres, dR_dT(:,nz+1), dR_dS(:,nz+1), & + tv%eqn_of_state, EOSdom) + +end subroutine smoothed_dRdT_dRdS + +end module MOM_full_convection diff --git a/parameterizations/vertical/MOM_geothermal.F90 b/parameterizations/vertical/MOM_geothermal.F90 new file mode 100644 index 0000000000..3769721da1 --- /dev/null +++ b/parameterizations/vertical/MOM_geothermal.F90 @@ -0,0 +1,609 @@ +!> Implemented geothermal heating at the ocean bottom. +module MOM_geothermal + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc +use MOM_diag_mediator, only : register_static_field, time_type, diag_ctrl +use MOM_domains, only : pass_var +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_io, only : MOM_read_data, slasher +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units +use MOM_EOS, only : calculate_density, calculate_density_derivs + +implicit none ; private + +#include + +public geothermal_entraining, geothermal_in_place, geothermal_init, geothermal_end + +!> Control structure for geothermal heating +type, public :: geothermal_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + real :: dRcv_dT_inplace !< The value of dRcv_dT above which (dRcv_dT is negative) the + !! water is heated in place instead of moving upward between + !! layers in non-ALE layered mode [R C-1 ~> kg m-3 degC-1] + real, allocatable, dimension(:,:) :: geo_heat !< The geothermal heat flux [Q R Z T-1 ~> W m-2] + real :: geothermal_thick !< The thickness over which geothermal heating is + !! applied [H ~> m or kg m-2] + logical :: apply_geothermal !< If true, geothermal heating will be applied. This is false if + !! GEOTHERMAL_SCALE is 0 and there is no heat to apply. + + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the timing + !! timing of diagnostic output + integer :: id_internal_heat_heat_tendency = -1 !< ID for diagnostic of heat tendency + integer :: id_internal_heat_temp_tendency = -1 !< ID for diagnostic of temperature tendency + integer :: id_internal_heat_h_tendency = -1 !< ID for diagnostic of thickness tendency + +end type geothermal_CS + +contains + +!> Applies geothermal heating, including the movement of water +!! between isopycnal layers to match the target densities. The heating is +!! applied to the bottommost layers that occur within GEOTHERMAL_THICKNESS of the bottom. If +!! the partial derivative of the coordinate density with temperature is positive +!! or very small, the layers are simply heated in place. Any heat that can not +!! be applied to the ocean is returned (WHERE)? +subroutine geothermal_entraining(h, tv, dt, ea, eb, G, GV, US, CS, halo) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers + !! to any available thermodynamic fields. + real, intent(in) :: dt !< Time increment [T ~> s]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: ea !< The amount of fluid moved + !! downward into a layer; this + !! should be increased due to mixed + !! layer detrainment [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: eb !< The amount of fluid moved upward + !! into a layer; this should be + !! increased due to mixed layer + !! entrainment [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(geothermal_CS), intent(in) :: CS !< The control structure returned by + !! a previous call to + !! geothermal_init. + integer, optional, intent(in) :: halo !< Halo width over which to work + ! Local variables + real, dimension(SZI_(G)) :: & + heat_rem, & ! remaining heat [H C ~> m degC or kg degC m-2] + h_geo_rem, & ! remaining thickness to apply geothermal heating [H ~> m or kg m-2] + Rcv_BL, & ! coordinate density in the deepest variable density layer [R ~> kg m-3] + p_ref ! coordinate densities reference pressure [R L2 T-2 ~> Pa] + + real, dimension(2) :: & + T2, S2, & ! temp and saln in the present and target layers [C ~> degC] and [S ~> ppt] + dRcv_dT_, & ! partial derivative of coordinate density wrt temp [R C-1 ~> kg m-3 degC-1] + dRcv_dS_ ! partial derivative of coordinate density wrt saln [R S-1 ~> kg m-3 ppt-1] + + real :: Angstrom, H_neglect ! small thicknesses [H ~> m or kg m-2] + real :: Rcv ! coordinate density of present layer [R ~> kg m-3] + real :: Rcv_tgt ! coordinate density of target layer [R ~> kg m-3] + real :: dRcv ! difference between Rcv and Rcv_tgt [R ~> kg m-3] + real :: dRcv_dT ! partial derivative of coordinate density wrt temp + ! in the present layer [R C-1 ~> kg m-3 degC-1]; usually negative + real :: h_heated ! thickness that is being heated [H ~> m or kg m-2] + real :: heat_avail ! heating available for the present layer [C H ~> degC m or degC kg m-2] + real :: heat_in_place ! heating to warm present layer w/o movement between layers + ! [C H ~> degC m or degC kg m-2] + real :: heat_trans ! heating available to move water from present layer to target + ! layer [C H ~> degC m or degC kg m-2] + real :: heating ! heating used to move water from present layer to target layer + ! [C H ~> degC m or degC kg m-2] + ! 0 <= heating <= heat_trans + real :: h_transfer ! thickness moved between layers [H ~> m or kg m-2] + real :: wt_in_place ! relative weighting that goes from 0 to 1 [nondim] + real :: I_h ! inverse thickness [H-1 ~> m-1 or m2 kg-1] + real :: dTemp ! temperature increase in a layer [C ~> degC] + real :: Irho_cp ! inverse of heat capacity per unit layer volume + ! [C H Q-1 R-1 Z-1 ~> degC m3 J-1 or degC kg J-1] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + T_old, & ! Temperature of each layer before any heat is added, for diagnostics [C ~> degC] + h_old, & ! Thickness of each layer before any heat is added, for diagnostics [H ~> m or kg m-2] + work_3d ! Scratch variable used to calculate changes due to geothermal [various] + real :: Idt ! inverse of the timestep [T-1 ~> s-1] + + logical :: do_i(SZI_(G)) + logical :: compute_h_old, compute_T_old + integer :: i, j, k, is, ie, js, je, nz, k2 + integer :: isj, iej, num_left, nkmb, k_tgt + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (present(halo)) then + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + endif + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_geothermal: "//& + "Module must be initialized before it is used.") + if (.not.CS%apply_geothermal) return + + nkmb = GV%nk_rho_varies + Irho_cp = 1.0 / (GV%H_to_RZ * tv%C_p) + Angstrom = GV%Angstrom_H + H_neglect = GV%H_subroundoff + p_ref(:) = tv%P_Ref + Idt = 1.0 / dt + + if (.not.associated(tv%T)) call MOM_error(FATAL, "MOM geothermal_entraining: "//& + "Geothermal heating can only be applied if T & S are state variables.") + +! do j=js,je ; do i=is,ie +! resid(i,j) = tv%internal_heat(i,j) +! enddo ; enddo + + ! Conditionals for tracking diagnostic depdendencies + compute_h_old = CS%id_internal_heat_h_tendency > 0 & + .or. CS%id_internal_heat_heat_tendency > 0 & + .or. CS%id_internal_heat_temp_tendency > 0 + + compute_T_old = CS%id_internal_heat_heat_tendency > 0 & + .or. CS%id_internal_heat_temp_tendency > 0 + + if (CS%id_internal_heat_heat_tendency > 0) work_3d(:,:,:) = 0.0 + + if (compute_h_old .or. compute_T_old) then ; do k=1,nz ; do j=js,je ; do i=is,ie + ! Save temperature and thickness before any changes are made (for diagnostics) + h_old(i,j,k) = h(i,j,k) + T_old(i,j,k) = tv%T(i,j,k) + enddo ; enddo ; enddo ; endif + +!$OMP parallel do default(none) shared(is,ie,js,je,G,GV,US,CS,dt,Irho_cp,nkmb,tv, & +!$OMP p_Ref,h,Angstrom,nz,H_neglect,eb, & +!$OMP h_old,T_old,work_3d,Idt) & +!$OMP private(heat_rem,do_i,h_geo_rem,num_left, & +!$OMP isj,iej,Rcv_BL,h_heated,heat_avail,k_tgt, & +!$OMP Rcv_tgt,Rcv,dRcv_dT,T2,S2,dRcv_dT_, & +!$OMP dRcv_dS_,heat_in_place,heat_trans, & +!$OMP wt_in_place,dTemp,dRcv,h_transfer,heating, & +!$OMP I_h) + + do j=js,je + ! 1. Only work on columns that are being heated. + ! 2. Find the deepest layer with any mass. + ! 3. Find the partial derivative of locally referenced potential density + ! and coordinate density with temperature, and the density of the layer + ! and the layer above. + ! 4. Heat a portion of the bottommost layer until it matches the target + ! density of the layer above, and move it. + ! 4a. In the case of variable density layers, heat but do not move. + ! 5. If there is still heat left over, repeat for the next layer up. + ! This subroutine updates thickness, T & S, and increments eb accordingly. + + ! 6. If there is not enough mass in the ocean, pass some of the heat up + ! from the ocean via the frazil field? + + num_left = 0 + do i=is,ie + heat_rem(i) = G%mask2dT(i,j) * (CS%geo_heat(i,j) * (dt*Irho_cp)) + do_i(i) = .true. ; if (heat_rem(i) <= 0.0) do_i(i) = .false. + if (do_i(i)) num_left = num_left + 1 + h_geo_rem(i) = CS%Geothermal_thick + enddo + if (num_left == 0) cycle + + ! Find the first and last columns that need to be worked on. + isj = ie+1 ; do i=is,ie ; if (do_i(i)) then ; isj = i ; exit ; endif ; enddo + iej = is-1 ; do i=ie,is,-1 ; if (do_i(i)) then ; iej = i ; exit ; endif ; enddo + + if (nkmb > 0) then + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_Ref(:), Rcv_BL(:), & + tv%eqn_of_state, (/isj-(G%isd-1),iej-(G%isd-1)/) ) + else + Rcv_BL(:) = -1.0 + endif + + do k=nz,1,-1 + do i=isj,iej ; if (do_i(i)) then + + if (h(i,j,k) > Angstrom) then + if ((h(i,j,k)-Angstrom) >= h_geo_rem(i)) then + h_heated = h_geo_rem(i) + heat_avail = heat_rem(i) + h_geo_rem(i) = 0.0 + else + h_heated = (h(i,j,k)-Angstrom) + heat_avail = heat_rem(i) * (h_heated / & + (h_geo_rem(i) + H_neglect)) + h_geo_rem(i) = h_geo_rem(i) - h_heated + endif + + if (k<=nkmb .or. nkmb<=0) then + ! Simply heat the layer; convective adjustment occurs later + ! if necessary. + k_tgt = k + elseif ((k==nkmb+1) .or. (GV%Rlay(k-1) < Rcv_BL(i))) then + ! Add enough heat to match the lowest buffer layer density. + k_tgt = nkmb + Rcv_tgt = Rcv_BL(i) + else + ! Add enough heat to match the target density of layer k-1. + k_tgt = k-1 + Rcv_tgt = GV%Rlay(k-1) + endif + + if (k<=nkmb .or. nkmb<=0) then + Rcv = 0.0 ; dRcv_dT = 0.0 ! Is this OK? + else + call calculate_density(tv%T(i,j,k), tv%S(i,j,k), tv%P_Ref, & + Rcv, tv%eqn_of_state) + T2(1) = tv%T(i,j,k) ; S2(1) = tv%S(i,j,k) + T2(2) = tv%T(i,j,k_tgt) ; S2(2) = tv%S(i,j,k_tgt) + call calculate_density_derivs(T2(:), S2(:), p_Ref(:), dRcv_dT_, dRcv_dS_, & + tv%eqn_of_state, (/1,2/) ) + dRcv_dT = 0.5*(dRcv_dT_(1) + dRcv_dT_(2)) + endif + + if ((dRcv_dT >= 0.0) .or. (k<=nkmb .or. nkmb<=0)) then + ! This applies to variable density layers. + heat_in_place = heat_avail + heat_trans = 0.0 + elseif (dRcv_dT <= CS%dRcv_dT_inplace) then + ! This is the option that usually applies in isopycnal coordinates. + heat_in_place = min(heat_avail, max(0.0, h(i,j,k) * & + ((GV%Rlay(k)-Rcv) / dRcv_dT))) + heat_trans = heat_avail - heat_in_place + else + ! wt_in_place should go from 0 to 1. + wt_in_place = (CS%dRcv_dT_inplace - dRcv_dT) / CS%dRcv_dT_inplace + heat_in_place = max(wt_in_place*heat_avail, & + h(i,j,k) * ((GV%Rlay(k)-Rcv) / dRcv_dT) ) + heat_trans = heat_avail - heat_in_place + endif + + if (heat_in_place > 0.0) then + ! This applies to variable density layers. In isopycnal coordinates + ! this only arises for relatively fresh water near the freezing + ! point, in which case heating in place will eventually cause things + ! to sort themselves out, if only because the water will warm to + ! the temperature of maximum density. + dTemp = heat_in_place / (h(i,j,k) + H_neglect) + tv%T(i,j,k) = tv%T(i,j,k) + dTemp + heat_rem(i) = heat_rem(i) - heat_in_place + Rcv = Rcv + dRcv_dT * dTemp + endif + + if (heat_trans > 0.0) then + ! The second expression might never be used, but will avoid + ! division by 0. + dRcv = max(Rcv - Rcv_tgt, 0.0) + + ! dTemp = -dRcv / dRcv_dT + ! h_transfer = min(heat_rem(i) / dTemp, h(i,j,k)-Angstrom) + if ((-dRcv_dT * heat_trans) >= dRcv * (h(i,j,k)-Angstrom)) then + h_transfer = h(i,j,k) - Angstrom + heating = (h_transfer * dRcv) / (-dRcv_dT) + ! Since not all the heat has been applied, return the fraction + ! of the layer thickness that has not yet been fully heated to + ! the h_geo_rem. + h_geo_rem(i) = h_geo_rem(i) + h_heated * & + ((heat_avail - (heating + heat_in_place)) / heat_avail) + else + h_transfer = (-dRcv_dT * heat_trans) / dRcv + heating = heat_trans + endif + heat_rem(i) = heat_rem(i) - heating + + I_h = 1.0 / ((h(i,j,k_tgt) + H_neglect) + h_transfer) + tv%T(i,j,k_tgt) = ((h(i,j,k_tgt) + H_neglect) * tv%T(i,j,k_tgt) + & + (h_transfer * tv%T(i,j,k) + heating)) * I_h + tv%S(i,j,k_tgt) = ((h(i,j,k_tgt) + H_neglect) * tv%S(i,j,k_tgt) + & + h_transfer * tv%S(i,j,k)) * I_h + + h(i,j,k) = h(i,j,k) - h_transfer + h(i,j,k_tgt) = h(i,j,k_tgt) + h_transfer + eb(i,j,k_tgt) = eb(i,j,k_tgt) + h_transfer + if (k_tgt < k-1) then + do k2 = k_tgt+1,k-1 + eb(i,j,k2) = eb(i,j,k2) + h_transfer + enddo + endif + endif + + if (heat_rem(i) <= 0.0) then + do_i(i) = .false. ; num_left = num_left-1 + ! For efficiency, uncomment these? + ! if ((i==isj) .and. (num_left > 0)) then ; do i2=isj+1,iej ; if (do_i(i2)) then + ! isj = i2 ; exit ! Set the new starting value. + ! endif ; enddo ; endif + ! if ((i==iej) .and. (num_left > 0)) then ; do i2=iej-1,isj,-1 ; if (do_i(i2)) then + ! iej = i2 ; exit ! Set the new ending value. + ! endif ; enddo ; endif + endif + endif + + ! Calculate heat tendency due to addition and transfer of internal heat + if (CS%id_internal_heat_heat_tendency > 0) then + work_3d(i,j,k) = ((GV%H_to_RZ*tv%C_p) * Idt) * (h(i,j,k) * tv%T(i,j,k) - h_old(i,j,k) * T_old(i,j,k)) + endif + + endif ; enddo + if (num_left <= 0) exit + enddo ! k-loop + + if (associated(tv%internal_heat)) then ; do i=is,ie + tv%internal_heat(i,j) = tv%internal_heat(i,j) + GV%H_to_RZ * & + (G%mask2dT(i,j) * (CS%geo_heat(i,j) * (dt*Irho_cp)) - heat_rem(i)) + enddo ; endif + enddo ! j-loop + + ! Post diagnostic of 3D tendencies (heat, temperature, and thickness) due to internal heat + if (CS%id_internal_heat_heat_tendency > 0) then + call post_data(CS%id_internal_heat_heat_tendency, work_3d, CS%diag, alt_h=h_old) + endif + if (CS%id_internal_heat_temp_tendency > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = Idt * (tv%T(i,j,k) - T_old(i,j,k)) + enddo ; enddo ; enddo + call post_data(CS%id_internal_heat_temp_tendency, work_3d, CS%diag, alt_h=h_old) + endif + if (CS%id_internal_heat_h_tendency > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = Idt * (h(i,j,k) - h_old(i,j,k)) + enddo ; enddo ; enddo + call post_data(CS%id_internal_heat_h_tendency, work_3d, CS%diag, alt_h=h_old) + endif + +! do j=js,je ; do i=is,ie +! resid(i,j) = tv%internal_heat(i,j) - resid(i,j) - GV%H_to_RZ * & +! (G%mask2dT(i,j) * (CS%geo_heat(i,j) * (dt*Irho_cp))) +! enddo ; enddo + +end subroutine geothermal_entraining + +!> Applies geothermal heating to the bottommost layers that occur within GEOTHERMAL_THICKNESS of +!! the bottom, by simply heating the water in place. Any heat that can not be applied to the ocean +!! is returned (WHERE)? +subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers + !! to any available thermodynamic fields. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(geothermal_CS), intent(in) :: CS !< Geothermal heating control struct + integer, optional, intent(in) :: halo !< Halo width over which to work + + ! Local variables + real, dimension(SZI_(G)) :: & + heat_rem, & ! remaining heat [H C ~> m degC or kg degC m-2] + h_geo_rem ! remaining thickness to apply geothermal heating [H ~> m or kg m-2] + + real :: Angstrom, H_neglect ! small thicknesses [H ~> m or kg m-2] + real :: heat_here ! heating applied to the present layer [C H ~> degC m or degC kg m-2] + real :: dTemp ! temperature increase in a layer [C ~> degC] + real :: Irho_cp ! inverse of heat capacity per unit layer volume + ! [C H Q-1 R-1 Z-1 ~> degC m3 J-1 or degC kg J-1] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + dTdt_diag ! Diagnostic of temperature tendency [C T-1 ~> degC s-1] which might be + ! converted into a layer-integrated heat tendency [Q R Z T-1 ~> W m-2] + real :: Idt ! inverse of the timestep [T-1 ~> s-1] + logical :: do_any ! True if there is more to be done on the current j-row. + logical :: calc_diags ! True if diagnostic tendencies are needed. + integer :: i, j, k, is, ie, js, je, nz, isj, iej + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (present(halo)) then + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + endif + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_geothermal: "//& + "Module must be initialized before it is used.") + if (.not.CS%apply_geothermal) return + + Irho_cp = 1.0 / (GV%H_to_RZ * tv%C_p) + Angstrom = GV%Angstrom_H + H_neglect = GV%H_subroundoff + Idt = 1.0 / dt + + if (.not.associated(tv%T)) call MOM_error(FATAL, "MOM geothermal_in_place: "//& + "Geothermal heating can only be applied if T & S are state variables.") + +! do j=js,je ; do i=is,ie +! resid(i,j) = tv%internal_heat(i,j) +! enddo ; enddo + + ! Conditionals for tracking diagnostic depdendencies + calc_diags = (CS%id_internal_heat_heat_tendency > 0) .or. (CS%id_internal_heat_temp_tendency > 0) + + if (calc_diags) dTdt_diag(:,:,:) = 0.0 + + !$OMP parallel do default(shared) private(heat_rem,do_any,h_geo_rem,isj,iej,heat_here,dTemp) + do j=js,je + ! Only work on columns that are being heated, and heat the near-bottom water. + + ! If there is not enough mass in the ocean, pass some of the heat up + ! from the ocean via the frazil field? + + do_any = .false. + do i=is,ie + heat_rem(i) = G%mask2dT(i,j) * (CS%geo_heat(i,j) * (dt*Irho_cp)) + if (heat_rem(i) > 0.0) do_any = .true. + h_geo_rem(i) = CS%Geothermal_thick + enddo + if (.not.do_any) cycle + + ! Find the first and last columns that need to be worked on. + isj = ie+1 ; do i=is,ie ; if (heat_rem(i) > 0.0) then ; isj = i ; exit ; endif ; enddo + iej = is-1 ; do i=ie,is,-1 ; if (heat_rem(i) > 0.0) then ; iej = i ; exit ; endif ; enddo + + do k=nz,1,-1 + do_any = .false. + do i=isj,iej + if ((heat_rem(i) > 0.0) .and. (h(i,j,k) > Angstrom)) then + ! Apply some or all of the remaining heat to this layer. + ! Convective adjustment occurs outside of this module if necessary. + if ((h(i,j,k)-Angstrom) >= h_geo_rem(i)) then + heat_here = heat_rem(i) + h_geo_rem(i) = 0.0 + heat_rem(i) = 0.0 + else + heat_here = heat_rem(i) * ((h(i,j,k)-Angstrom) / (h_geo_rem(i) + H_neglect)) + h_geo_rem(i) = h_geo_rem(i) - (h(i,j,k)-Angstrom) + heat_rem(i) = heat_rem(i) - heat_here + endif + + dTemp = heat_here / (h(i,j,k) + H_neglect) + tv%T(i,j,k) = tv%T(i,j,k) + dTemp + if (calc_diags) dTdt_diag(i,j,k) = dTemp * Idt + endif + + if (heat_rem(i) > 0.0) do_any= .true. + enddo + + if (.not.do_any) exit + enddo ! k-loop + + if (associated(tv%internal_heat)) then ; do i=is,ie + tv%internal_heat(i,j) = tv%internal_heat(i,j) + GV%H_to_RZ * & + (G%mask2dT(i,j) * (CS%geo_heat(i,j) * (dt*Irho_cp)) - heat_rem(i)) + enddo ; endif + enddo ! j-loop + + ! Post diagnostics of 3D tendencies of heat and temperature due to geothermal heat + if (CS%id_internal_heat_temp_tendency > 0) then + call post_data(CS%id_internal_heat_temp_tendency, dTdt_diag, CS%diag, alt_h=h) + endif + if (CS%id_internal_heat_heat_tendency > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + ! Dangerously reuse dTdt_diag for a related variable with different units, going from + ! units of [C T-1 ~> degC s-1] to units of [Q R Z T-1 ~> W m-2] + dTdt_diag(i,j,k) = (GV%H_to_RZ*tv%C_p) * (h(i,j,k) * dTdt_diag(i,j,k)) + enddo ; enddo ; enddo + call post_data(CS%id_internal_heat_heat_tendency, dTdt_diag, CS%diag, alt_h=h) + endif + +! do j=js,je ; do i=is,ie +! resid(i,j) = tv%internal_heat(i,j) - resid(i,j) - GV%H_to_RZ * & +! (G%mask2dT(i,j) * (CS%geo_heat(i,j) * (dt*Irho_cp))) +! enddo ; enddo + +end subroutine geothermal_in_place + +!> Initialize parameters and allocate memory associated with the geothermal heating module. +subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS, useALEalgorithm) + type(time_type), target, intent(in) :: Time !< Current model time. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(diag_ctrl), target, intent(inout) :: diag !< Structure used to regulate diagnostic output. + type(geothermal_CS), intent(inout) :: CS !< Geothermal heating control struct + logical, optional, intent(in) :: useALEalgorithm !< logical for whether to use ALE remapping + +! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mdl = "MOM_geothermal" ! module name + character(len=48) :: thickness_units + ! Local variables + character(len=200) :: inputdir, geo_file, filename, geotherm_var + real :: geo_scale ! A constant heat flux or dimensionally rescaled geothermal flux scaling factor + ! [Q R Z T-1 ~> W m-2] or [Q R Z m2 s J-1 T-1 ~> nondim] + integer :: i, j, isd, ied, jsd, jed, id + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + CS%initialized = .true. + CS%diag => diag + CS%Time => Time + + ! write parameters to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "GEOTHERMAL_SCALE", geo_scale, & + "The constant geothermal heat flux, a rescaling "//& + "factor for the heat flux read from GEOTHERMAL_FILE, or "//& + "0 to disable the geothermal heating.", & + units="W m-2 or various", default=0.0, scale=US%W_m2_to_QRZ_T) + CS%apply_geothermal = .not.(geo_scale == 0.0) + if (.not.CS%apply_geothermal) return + + call safe_alloc_alloc(CS%geo_heat, isd, ied, jsd, jed) ; CS%geo_heat(:,:) = 0.0 + + call get_param(param_file, mdl, "GEOTHERMAL_FILE", geo_file, & + "The file from which the geothermal heating is to be "//& + "read, or blank to use a constant heating rate.", default=" ") + call get_param(param_file, mdl, "GEOTHERMAL_THICKNESS", CS%geothermal_thick, & + "The thickness over which to apply geothermal heating.", & + units="m", default=0.1, scale=GV%m_to_H) + call get_param(param_file, mdl, "GEOTHERMAL_DRHO_DT_INPLACE", CS%dRcv_dT_inplace, & + "The value of drho_dT above which geothermal heating "//& + "simply heats water in place instead of moving it between "//& + "isopycnal layers. This must be negative.", & + units="kg m-3 K-1", scale=US%kg_m3_to_R*US%C_to_degC, default=-0.01, & + do_not_log=((GV%nk_rho_varies<=0).or.(GV%nk_rho_varies>=GV%ke)) ) + if (CS%dRcv_dT_inplace >= 0.0) call MOM_error(FATAL, "geothermal_init: "//& + "GEOTHERMAL_DRHO_DT_INPLACE must be negative.") + + if (len_trim(geo_file) >= 1) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + filename = trim(inputdir)//trim(geo_file) + call log_param(param_file, mdl, "INPUTDIR/GEOTHERMAL_FILE", filename) + call get_param(param_file, mdl, "GEOTHERMAL_VARNAME", geotherm_var, & + "The name of the geothermal heating variable in GEOTHERMAL_FILE.", & + default="geo_heat") + call MOM_read_data(filename, trim(geotherm_var), CS%geo_heat, G%Domain) + do j=jsd,jed ; do i=isd,ied + CS%geo_heat(i,j) = (G%mask2dT(i,j) * geo_scale) * CS%geo_heat(i,j) + enddo ; enddo + else + do j=jsd,jed ; do i=isd,ied + CS%geo_heat(i,j) = G%mask2dT(i,j) * geo_scale + enddo ; enddo + endif + call pass_var(CS%geo_heat, G%domain) + + thickness_units = get_thickness_units(GV) + + ! post the static geothermal heating field + id = register_static_field('ocean_model', 'geo_heat', diag%axesT1, & + 'Geothermal heat flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & + cmor_field_name='hfgeou', & + cmor_standard_name='upward_geothermal_heat_flux_at_sea_floor', & + cmor_long_name='Upward geothermal heat flux at sea floor', & + x_cell_method='mean', y_cell_method='mean', area_cell_method='mean') + if (id > 0) call post_data(id, CS%geo_heat, diag, .true.) + + ! Diagnostic for tendencies due to internal heat (in 3d) + CS%id_internal_heat_heat_tendency = register_diag_field('ocean_model', & + 'internal_heat_heat_tendency', diag%axesTL, Time, & + 'Heat tendency (in 3D) due to internal (geothermal) sources', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive=.true.) + CS%id_internal_heat_temp_tendency = register_diag_field('ocean_model', & + 'internal_heat_temp_tendency', diag%axesTL, Time, & + 'Temperature tendency (in 3D) due to internal (geothermal) sources', & + 'degC s-1', conversion=US%C_to_degC*US%s_to_T, v_extensive=.true.) + if (.not.useALEalgorithm) then + ! Do not offer this diagnostic if heating will be in place. + CS%id_internal_heat_h_tendency = register_diag_field('ocean_model', & + 'internal_heat_h_tendency', diag%axesTL, Time, & + 'Thickness tendency (in 3D) due to internal (geothermal) sources', & + trim(thickness_units)//' s-1', conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) + endif + +end subroutine geothermal_init + +!> Clean up and deallocate memory associated with the geothermal heating module. +subroutine geothermal_end(CS) + type(geothermal_CS), intent(inout) :: CS !< Geothermal heating control struct + if (allocated(CS%geo_heat)) deallocate(CS%geo_heat) +end subroutine geothermal_end + +!> \namespace mom_geothermal +!! +!! Geothermal heating can be added either in a layered isopycnal mode, in which the heating raises the density +!! of the layer to the target density of the layer above, and then moves the water into that layer, or in a +!! simple Eulerian mode, in which the bottommost GEOTHERMAL_THICKNESS are heated. Geothermal heating will also +!! provide a buoyant source of bottom TKE that can be used to further mix the near-bottom water. In cold fresh +!! water lakes where heating increases density, water should be moved into deeper layers, but this is not +!! implemented yet. + +end module MOM_geothermal diff --git a/parameterizations/vertical/MOM_internal_tide_input.F90 b/parameterizations/vertical/MOM_internal_tide_input.F90 new file mode 100644 index 0000000000..7280106125 --- /dev/null +++ b/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -0,0 +1,573 @@ +!> Calculates energy input to the internal tides +module MOM_int_tide_input + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : diag_ctrl, query_averaging_enabled +use MOM_diag_mediator, only : disable_averaging, enable_averages +use MOM_diag_mediator, only : safe_alloc_ptr, post_data, register_diag_field +use MOM_debugging, only : hchksum +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_file_parser, only : read_param +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_io, only : slasher, vardesc, MOM_read_data +use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom +use MOM_isopycnal_slopes, only : vert_fill_TS +use MOM_string_functions, only : extractWord +use MOM_time_manager, only : time_type, set_time, operator(+), operator(<=) +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs, EOS_domain + +implicit none ; private + +#include + +public set_int_tide_input, int_tide_input_init, int_tide_input_end +public get_input_TKE, get_barotropic_tidal_vel + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> This control structure holds parameters that regulate internal tide energy inputs. +type, public :: int_tide_input_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: debug !< If true, write verbose checksums for debugging. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + real :: TKE_itide_max !< Maximum Internal tide conversion + !! available to mix above the BBL [R Z3 T-3 ~> W m-2] + real :: kappa_fill !< Vertical diffusivity used to interpolate sensible values + !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + real, allocatable, dimension(:,:,:) :: TKE_itidal_coef + !< The time-invariant field that enters the TKE_itidal input calculation noting that the + !! stratification and perhaps density are time-varying [R Z4 H-1 T-2 ~> J m-2 or J m kg-1]. + real, allocatable, dimension(:,:,:) :: & + TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. + tideamp !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. + + character(len=200) :: inputdir !< The directory for input files. + + logical :: int_tide_source_test !< If true, apply an arbitrary generation site + !! for internal tide testing + type(time_type) :: time_max_source !< A time for use in testing internal tides + real :: int_tide_source_x !< X Location of generation site + !! for internal tide for testing [degrees_E] or [km] + real :: int_tide_source_y !< Y Location of generation site + !! for internal tide for testing [degrees_N] or [km] + integer :: int_tide_source_i !< I Location of generation site + integer :: int_tide_source_j !< J Location of generation site + logical :: int_tide_use_glob_ij !< Use global indices for generation site + integer :: nFreq = 0 !< The number of internal tide frequency bands + + + !>@{ Diagnostic IDs + integer, allocatable, dimension(:) :: id_TKE_itidal_itide + integer :: id_Nb = -1, id_N2_bot = -1 + !>@} +end type int_tide_input_CS + +!> This type is used to exchange fields related to the internal tides. +type, public :: int_tide_input_type + real, allocatable, dimension(:,:) :: & + h2, & !< The squared topographic roughness height [Z2 ~> m2]. + Nb, & !< The bottom stratification [T-1 ~> s-1]. + Rho_bot !< The bottom density or the Boussinesq reference density [R ~> kg m-3]. +end type int_tide_input_type + +contains + +!> Sets the model-state dependent internal tide energy sources. +subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to the + !! thermodynamic fields + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + type(int_tide_input_type), intent(inout) :: itide !< A structure containing fields related + !! to the internal tide sources. + real, intent(in) :: dt !< The time increment [T ~> s]. + type(int_tide_input_CS), pointer :: CS !< This module's control structure. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + N2_bot ! The bottom squared buoyancy frequency [T-2 ~> s-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + Rho_bot ! The average near-bottom density or the Boussinesq reference density [R ~> kg m-3]. + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + T_f, S_f ! The temperature and salinity in [C ~> degC] and [S ~> ppt] with the values in + ! the massless layers filled vertically by diffusion. + logical :: use_EOS ! If true, density is calculated from T & S using an + ! equation of state. + logical :: avg_enabled ! for testing internal tides (BDM) + type(time_type) :: time_end !< For use in testing internal tides (BDM) + + integer :: i, j, is, ie, js, je, nz, isd, ied, jsd, jed + integer :: i_global, j_global + integer :: fr + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (.not.associated(CS)) call MOM_error(FATAL,"set_diffusivity: "//& + "Module must be initialized before it is used.") + + if (.not.CS%initialized) call MOM_error(FATAL,"set_diffusivity: "//& + "Module must be initialized before it is used.") + + use_EOS = associated(tv%eqn_of_state) + + ! Smooth the properties through massless layers. + if (use_EOS) then + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, US, larger_h_denom=.true.) + endif + + call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot, Rho_bot) + + avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + !$OMP parallel do default(shared) + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie + itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) + CS%TKE_itidal_input(i,j,fr) = min(GV%Z_to_H*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), CS%TKE_itide_max) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie + itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) + itide%Rho_bot(i,j) = G%mask2dT(i,j) * Rho_bot(i,j) + CS%TKE_itidal_input(i,j,fr) = min((GV%RZ_to_H*Rho_bot(i,j)) * CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & + CS%TKE_itide_max) + enddo ; enddo ; enddo + endif + + if (CS%int_tide_source_test) then + CS%TKE_itidal_input(:,:,:) = 0.0 + if (time_end <= CS%time_max_source) then + if (CS%int_tide_use_glob_ij) then + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie + i_global = i + G%idg_offset + j_global = j + G%jdg_offset + if ((i_global == CS%int_tide_source_i) .and. (j_global == CS%int_tide_source_j)) then + CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + endif + enddo ; enddo ; enddo + else + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie + ! Input an arbitrary energy point source.id_ + if (((G%geoLonCu(I-1,j)-CS%int_tide_source_x) * (G%geoLonBu(I,j)-CS%int_tide_source_x) <= 0.0) .and. & + ((G%geoLatCv(i,J-1)-CS%int_tide_source_y) * (G%geoLatCv(i,j)-CS%int_tide_source_y) <= 0.0)) then + CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + endif + enddo ; enddo ; enddo + endif + endif + endif + + if (CS%debug) then + call hchksum(N2_bot,"N2_bot",G%HI,haloshift=0, scale=US%s_to_T**2) + call hchksum(CS%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & + scale=US%RZ3_T3_to_W_m2) + endif + + call enable_averages(dt, time_end, CS%diag) + + do fr=1,CS%nFreq + if (CS%id_TKE_itidal_itide(fr) > 0) call post_data(CS%id_TKE_itidal_itide(fr), & + CS%TKE_itidal_input(isd:ied,jsd:jed,fr), CS%diag) + enddo + if (CS%id_Nb > 0) call post_data(CS%id_Nb, itide%Nb, CS%diag) + if (CS%id_N2_bot > 0 ) call post_data(CS%id_N2_bot, N2_bot, CS%diag) + + call disable_averaging(CS%diag) + +end subroutine set_int_tide_input + +!> Estimates the near-bottom buoyancy frequency (N^2). +subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bot) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to the + !! thermodynamic fields + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T_f !< Temperature after vertical filtering to + !! smooth out the values in thin layers [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S_f !< Salinity after vertical filtering to + !! smooth out the values in thin layers [S ~> ppt]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h2 !< Bottom topographic roughness [Z2 ~> m2]. + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy frequency at the + !! ocean bottom [T-2 ~> s-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: rho_bot !< The average density near the ocean + !! bottom [R ~> kg m-3] + ! Local variables + real, dimension(SZI_(G),SZK_(GV)+1) :: & + pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. + dRho_int ! The unfiltered density differences across interfaces [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G)) :: & + Temp_int, & ! The temperature at each interface [C ~> degC] + Salin_int, & ! The salinity at each interface [S ~> ppt] + drho_bot, & ! The density difference at the bottom of a layer [R ~> kg m-3] + h_amp, & ! The amplitude of topographic roughness [Z ~> m]. + hb, & ! The thickness of the water column below the midpoint of a layer [H ~> m or kg m-2] + z_from_bot, & ! The distance of a layer center from the bottom [Z ~> m] + dRho_dT, & ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + + real :: dz_int ! The vertical extent of water associated with an interface [Z ~> m] + real :: G_Rho0 ! The gravitational acceleration, sometimes divided by the Boussinesq + ! density [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. + logical :: do_i(SZI_(G)), do_any + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / GV%H_to_RZ + EOSdom(:) = EOS_domain(G%HI) + + ! Find the (limited) density jump across each interface. + do i=is,ie + dRho_int(i,1) = 0.0 ; dRho_int(i,nz+1) = 0.0 + enddo + + !$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & + !$OMP h2,N2_bot,rho_bot,G_Rho0,EOSdom) & + !$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & + !$OMP dz,hb,dRho_bot,z_from_bot,do_i,h_amp,do_any,dz_int) & + !$OMP firstprivate(dRho_int) + do j=js,je + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + if (associated(tv%eqn_of_state)) then + if (associated(fluxes%p_surf)) then + do i=is,ie ; pres(i,1) = fluxes%p_surf(i,j) ; enddo + else + do i=is,ie ; pres(i,1) = 0.0 ; enddo + endif + do K=2,nz + do i=is,ie + pres(i,K) = pres(i,K-1) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) + Temp_Int(i) = 0.5 * (T_f(i,j,k) + T_f(i,j,k-1)) + Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) + enddo + call calculate_density_derivs(Temp_int, Salin_int, pres(:,K), dRho_dT(:), dRho_dS(:), & + tv%eqn_of_state, EOSdom) + do i=is,ie + dRho_int(i,K) = max(dRho_dT(i)*(T_f(i,j,k) - T_f(i,j,k-1)) + & + dRho_dS(i)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) + enddo + enddo + else + do K=2,nz ; do i=is,ie + dRho_int(i,K) = (GV%Rlay(k) - GV%Rlay(k-1)) + enddo ; enddo + endif + + ! Find the bottom boundary layer stratification. + do i=is,ie + hb(i) = 0.0 ; dRho_bot(i) = 0.0 + z_from_bot(i) = 0.5*dz(i,nz) + do_i(i) = (G%mask2dT(i,j) > 0.0) + h_amp(i) = sqrt(h2(i,j)) + enddo + + do k=nz,2,-1 + do_any = .false. + do i=is,ie ; if (do_i(i)) then + dz_int = 0.5*(dz(i,k) + dz(i,k-1)) + z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above + + hb(i) = hb(i) + 0.5*(h(i,j,k) + h(i,j,k-1)) + dRho_bot(i) = dRho_bot(i) + dRho_int(i,K) + + if (z_from_bot(i) > h_amp(i)) then + if (k>2) then + ! Always include at least one full layer. + hb(i) = hb(i) + 0.5*(h(i,j,k-1) + h(i,j,k-2)) + dRho_bot(i) = dRho_bot(i) + dRho_int(i,K-1) + endif + do_i(i) = .false. + else + do_any = .true. + endif + endif ; enddo + if (.not.do_any) exit + enddo + + do i=is,ie + if (hb(i) > 0.0) then + N2_bot(i,j) = (G_Rho0 * dRho_bot(i)) / hb(i) + else ; N2_bot(i,j) = 0.0 ; endif + enddo + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is,ie + rho_bot(i,j) = GV%Rho0 + enddo + else + ! Average the density over the envelope of the topography. + call find_rho_bottom(h, dz, pres, h_amp, tv, j, G, GV, US, Rho_bot(:,j)) + endif + enddo + +end subroutine find_N2_bottom + +!> Returns TKE_itidal_input +subroutine get_input_TKE(G, TKE_itidal_input, nFreq, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + real, dimension(SZI_(G),SZJ_(G),nFreq), & + intent(out) :: TKE_itidal_input !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + integer, intent(in) :: nFreq !< number of frequencies + type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control + !! structure for the internal tide input module. + integer :: i,j,fr + + do fr=1,nFreq ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + TKE_itidal_input(i,j,fr) = CS%TKE_itidal_input(i,j,fr) + enddo ; enddo ; enddo + +end subroutine get_input_TKE + +!> Returns barotropic tidal velocities +subroutine get_barotropic_tidal_vel(G, vel_btTide, nFreq, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + real, dimension(SZI_(G),SZJ_(G),nFreq), & + intent(out) :: vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. + integer, intent(in) :: nFreq !< number of frequencies + type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control + !! structure for the internal tide input module. + integer :: i,j,fr + + do fr=1,nFreq ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + vel_btTide(i,j,fr) = CS%tideamp(i,j,fr) + enddo ; enddo ; enddo + +end subroutine get_barotropic_tidal_vel + +!> Initializes the data related to the internal tide input module +subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(inout) :: diag !< structure used to regulate diagnostic output. + type(int_tide_input_CS), pointer :: CS !< This module's control structure, which is initialized here. + type(int_tide_input_type), pointer :: itide !< A structure containing fields related + !! to the internal tide sources. + ! Local variables + logical :: read_tideamp + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_int_tide_input" ! This module's name. + character(len=200) :: filename, tideamp_file, h2_file ! Input file names or paths + character(len=80) :: tideamp_var, rough_var ! Input file variable names + character(len=80) :: var_name + character(len=200) :: var_descript + character(len=200) :: tidefile_varnames + + real :: mask_itidal ! A multiplicative land mask, 0 or 1 [nondim] + real :: max_frac_rough ! The fraction relating the maximum topographic roughness + ! to the mean depth [nondim] + real :: utide ! constant tidal amplitude [L T-1 ~> m s-1] to be used if + ! tidal amplitude file is not present. + real :: kappa_h2_factor ! factor for the product of wavenumber * rms sgs height [nondim]. + real :: kappa_itides ! topographic wavenumber and non-dimensional scaling [L-1 ~> m-1] + real :: min_zbot_itides ! Minimum ocean depth for internal tide conversion [Z ~> m]. + integer :: tlen_days !< Time interval from start for adding wave source + !! for testing internal tides (BDM) + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + integer :: num_freq, fr + + if (associated(CS)) then + call MOM_error(WARNING, "int_tide_input_init called with an associated "// & + "control structure.") + return + endif + if (associated(itide)) then + call MOM_error(WARNING, "int_tide_input_init called with an associated "// & + "internal tide input type.") + return + endif + allocate(CS) + allocate(itide) + + CS%initialized = .true. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + CS%diag => diag + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") + CS%inputdir = slasher(CS%inputdir) + + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) + + call get_param(param_file, mdl, "MIN_ZBOT_ITIDES", min_zbot_itides, & + "Turn off internal tidal dissipation when the total "//& + "ocean depth is less than this value.", units="m", default=0.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_fill, & + "A diapycnal diffusivity that is used to interpolate "//& + "more sensible values of T & S into thin layers.", & + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) + + call get_param(param_file, mdl, "UTIDE", utide, & + "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & + units="m s-1", default=0.0, scale=US%m_s_to_L_T) + + call read_param(param_file, "INTERNAL_TIDE_FREQS", num_freq) + CS%nFreq= num_freq + + allocate(itide%Nb(isd:ied,jsd:jed), source=0.0) + allocate(itide%Rho_bot(isd:ied,jsd:jed), source=0.0) + allocate(itide%h2(isd:ied,jsd:jed), source=0.0) + allocate(CS%TKE_itidal_input(isd:ied,jsd:jed,num_freq), source=0.0) + allocate(CS%tideamp(isd:ied,jsd:jed,num_freq), source=utide) + allocate(CS%TKE_itidal_coef(isd:ied,jsd:jed, num_freq), source=0.0) + + call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & + "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& + "The default is 2pi/10 km, as in St.Laurent et al. 2002.", & + units="m-1", default=8.e-4*atan(1.0), scale=US%L_to_m) + + call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & + "A scaling factor for the roughness amplitude with "//& + "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) + call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & + "The maximum internal tide energy source available to mix "//& + "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & + units="W m-2", default=1.0e3, scale=US%W_m2_to_RZ3_T3) + + call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & + "If true, read a file (given by TIDEAMP_FILE) containing "//& + "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) + if (read_tideamp) then + call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & + "The path to the file containing the spatially varying "//& + "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") + filename = trim(CS%inputdir) // trim(tideamp_file) + call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) + + call read_param(param_file, "INTTIDE_AMP_VARNAMES", tidefile_varnames) + do fr=1,num_freq + tideamp_var = extractWord(tidefile_varnames,fr) + call MOM_read_data(filename, tideamp_var, CS%tideamp(:,:,fr), G%domain, scale=US%m_s_to_L_T) + enddo + + endif + + call get_param(param_file, mdl, "H2_FILE", h2_file, & + "The path to the file containing the sub-grid-scale "//& + "topographic roughness amplitude with INT_TIDE_DISSIPATION.", & + fail_if_missing=.true.) + filename = trim(CS%inputdir) // trim(h2_file) + call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) + call get_param(param_file, mdl, "ROUGHNESS_VARNAME", rough_var, & + "The name in the input file of the squared sub-grid-scale "//& + "topographic roughness amplitude variable.", default="h2") + call MOM_read_data(filename, rough_var, itide%h2, G%domain, scale=US%m_to_Z**2) + + call get_param(param_file, mdl, "FRACTIONAL_ROUGHNESS_MAX", max_frac_rough, & + "The maximum topographic roughness amplitude as a fraction of the mean depth, "//& + "or a negative value for no limitations on roughness.", & + units="nondim", default=0.1) + + ! The following parameters are used in testing the internal tide code. + call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_TEST", CS%int_tide_source_test, & + "If true, apply an arbitrary generation site for internal tide testing", & + default=.false.) + if (CS%int_tide_source_test)then + call get_param(param_file, mdl, "INTERNAL_TIDE_USE_GLOB_IJ", CS%int_tide_use_glob_ij, & + "Use global IJ for internal tide generation source test", default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_X", CS%int_tide_source_x, & + "X Location of generation site for internal tide", & + units=G%x_ax_unit_short, default=1.0, do_not_log=CS%int_tide_use_glob_ij) + call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_Y", CS%int_tide_source_y, & + "Y Location of generation site for internal tide", & + units=G%y_ax_unit_short, default=1.0, do_not_log=CS%int_tide_use_glob_ij) + call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_I", CS%int_tide_source_i, & + "I Location of generation site for internal tide", default=0, & + do_not_log=.not.CS%int_tide_use_glob_ij) + call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_J", CS%int_tide_source_j, & + "J Location of generation site for internal tide", default=0, & + do_not_log=.not.CS%int_tide_use_glob_ij) + call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_TLEN_DAYS", tlen_days, & + "Time interval from start of experiment for adding wave source", & + units="days", default=0) + CS%time_max_source = Time + set_time(0, days=tlen_days) + + if ((CS%int_tide_use_glob_ij) .and. ((CS%int_tide_source_x /= 1.) .or. (CS%int_tide_source_y /= 1.))) then + call MOM_error(FATAL, "MOM_internal_tide_input: "//& + "Internal tide source set to use (i,j) indices hence (x,y) geographical coords are meaningless.") + endif + if ((.not.CS%int_tide_use_glob_ij) .and. ((CS%int_tide_source_i /= 0) .or. (CS%int_tide_source_j /= 0))) then + call MOM_error(FATAL, "MOM_internal_tide_input: "//& + "Internal tide source set to use (x,y) geographical coords hence (i,j) indices are meaningless.") + endif + endif + + do fr=1,num_freq ; do j=js,je ; do i=is,ie + mask_itidal = 1.0 + if (G%bathyT(i,j) + G%Z_ref < min_zbot_itides) mask_itidal = 0.0 + + CS%tideamp(i,j,fr) = CS%tideamp(i,j,fr) * mask_itidal * G%mask2dT(i,j) + + ! Restrict rms topo to a fraction (often 10 percent) of the column depth. + if (max_frac_rough >= 0.0) & + itide%h2(i,j) = min((max_frac_rough*(G%bathyT(i,j)+G%Z_ref))**2, itide%h2(i,j)) + + ! Compute the fixed part of internal tidal forcing; units are [R Z4 H-1 T-2 ~> J m-2 or J m kg-1] here. + CS%TKE_itidal_coef(i,j,fr) = 0.5*US%L_to_Z*kappa_h2_factor * GV%H_to_RZ * & + kappa_itides * itide%h2(i,j) * CS%tideamp(i,j,fr)**2 + enddo ; enddo ; enddo + + + allocate( CS%id_TKE_itidal_itide(num_freq), source=-1) + + do fr=1,num_freq + write(var_name, '("TKE_itidal_itide_freq",i1)') fr + write(var_descript, '("Internal Tide Driven Turbulent Kinetic Energy in frequency ",i1)') fr + + CS%id_TKE_itidal_itide(fr) = register_diag_field('ocean_model',var_name,diag%axesT1,Time, & + var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + enddo + + CS%id_Nb = register_diag_field('ocean_model','Nb_itide',diag%axesT1,Time, & + 'Bottom Buoyancy Frequency', 's-1', conversion=US%s_to_T) + + CS%id_N2_bot = register_diag_field('ocean_model','N2_b_itide',diag%axesT1,Time, & + 'Bottom Buoyancy frequency squared', 's-2', conversion=US%s_to_T**2) + +end subroutine int_tide_input_init + +!> Deallocates any memory related to the internal tide input module. +subroutine int_tide_input_end(CS) + type(int_tide_input_CS), pointer :: CS !< This module's control structure, which is deallocated here. + + if (associated(CS)) deallocate(CS) + +end subroutine int_tide_input_end + +end module MOM_int_tide_input diff --git a/parameterizations/vertical/MOM_kappa_shear.F90 b/parameterizations/vertical/MOM_kappa_shear.F90 new file mode 100644 index 0000000000..8a1974d8ea --- /dev/null +++ b/parameterizations/vertical/MOM_kappa_shear.F90 @@ -0,0 +1,2063 @@ +!> Shear-dependent mixing following Jackson et al. 2008. +module MOM_kappa_shear + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_debugging, only : hchksum, Bchksum +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_specific_vol_derivs + +implicit none ; private + +#include + +public Calculate_kappa_shear, Calc_kappa_shear_vertex, kappa_shear_init +public kappa_shear_is_used, kappa_shear_at_vertex + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> This control structure holds the parameters that regulate shear mixing +type, public :: Kappa_shear_CS ; private + real :: RiNo_crit !< The critical shear Richardson number for + !! shear-entrainment [nondim]. The theoretical value is 0.25. + !! The values found by Jackson et al. are 0.25-0.35. + real :: Shearmix_rate !< A nondimensional rate scale for shear-driven + !! entrainment [nondim]. The value given by Jackson et al. + !! is 0.085-0.089. + real :: FRi_curvature !< A constant giving the curvature of the function + !! of the Richardson number that relates shear to + !! sources in the kappa equation [nondim]. + !! The values found by Jackson et al. are -0.97 - -0.89. + real :: C_N !< The coefficient for the decay of TKE due to + !! stratification (i.e. proportional to N*tke) [nondim]. + !! The values found by Jackson et al. are 0.24-0.28. + real :: C_S !< The coefficient for the decay of TKE due to + !! shear (i.e. proportional to |S|*tke) [nondim]. + !! The values found by Jackson et al. are 0.14-0.12. + real :: lambda !< The coefficient for the buoyancy length scale + !! in the kappa equation [nondim]. + !! The values found by Jackson et al. are 0.82-0.81. + real :: lambda2_N_S !< The square of the ratio of the coefficients of + !! the buoyancy and shear scales in the diffusivity + !! equation, 0 to eliminate the shear scale [nondim]. + real :: TKE_bg !< The background level of TKE [Z2 T-2 ~> m2 s-2]. + real :: kappa_0 !< The background diapycnal diffusivity [H Z T-1 ~> m2 s-1 or Pa s] + real :: kappa_seed !< A moderately large seed value of diapycnal diffusivity that + !! is used as a starting turbulent diffusivity in the iterations + !! to findind an energetically constrained solution for the + !! shear-driven diffusivity [H Z T-1 ~> m2 s-1 or Pa s] + real :: kappa_trunc !< Diffusivities smaller than this are rounded to 0 [H Z T-1 ~> m2 s-1 or Pa s] + real :: kappa_tol_err !< The fractional error in kappa that is tolerated [nondim]. + real :: Prandtl_turb !< Prandtl number used to convert Kd_shear into viscosity [nondim]. + integer :: nkml !< The number of layers in the mixed layer, as + !! treated in this routine. If the pieces of the + !! mixed layer are not to be treated collectively, + !! nkml is set to 1. + integer :: max_RiNo_it !< The maximum number of iterations that may be used + !! to estimate the instantaneous shear-driven mixing. + integer :: max_KS_it !< The maximum number of iterations that may be used + !! to estimate the time-averaged diffusivity. + logical :: dKdQ_iteration_bug !< If true. use an older, dimensionally inconsistent estimate of + !! the derivative of diffusivity with energy in the Newton's method + !! iteration. The bug causes undercorrections when dz > 1m. + logical :: KS_at_vertex !< If true, do the calculations of the shear-driven mixing + !! at the cell vertices (i.e., the vorticity points). + logical :: eliminate_massless !< If true, massless layers are merged with neighboring + !! massive layers in this calculation. + ! I can think of no good reason why this should be false. - RWH + real :: vel_underflow !< Velocity components smaller than vel_underflow + !! are set to 0 [L T-1 ~> m s-1]. + real :: kappa_src_max_chg !< The maximum permitted increase in the kappa source within an + !! iteration relative to the local source [nondim]. This must be + !! greater than 1. The lower limit for the permitted fractional + !! decrease is (1 - 0.5/kappa_src_max_chg). These limits could + !! perhaps be made dynamic with an improved iterative solver. + logical :: psurf_bug !< If true, do a simple average of the cell surface pressures to get a + !! surface pressure at the corner if VERTEX_SHEAR=True. Otherwise mask + !! out any land points in the average. + logical :: all_layer_TKE_bug !< If true, report back the latest estimate of TKE instead of the + !! time average TKE when there is mass in all layers. Otherwise always + !! report the time-averaged TKE, as is currently done when there + !! are some massless layers. + logical :: restrictive_tolerance_check !< If false, uses the less restrictive tolerance check to + !! determine if a timestep is acceptable for the KS_it outer iteration + !! loop, as the code was originally written. True uses the more + !! restrictive check. +! logical :: layer_stagger = .false. ! If true, do the calculations centered at + ! layers, rather than the interfaces. + logical :: debug = .false. !< If true, write verbose debugging messages. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + !>@{ Diagnostic IDs + integer :: id_Kd_shear = -1, id_TKE = -1 + !>@} +end type Kappa_shear_CS + +! integer :: id_clock_project, id_clock_KQ, id_clock_avg, id_clock_setup + +contains + +!> Subroutine for calculating shear-driven diffusivity and TKE in tracer columns +subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & + kv_io, dt, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u_in !< Initial zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: v_in !< Initial meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent fields + !! have NULL ptrs. + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] (or NULL). + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(inout) :: kappa_io !< The diapycnal diffusivity at each interface + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. Initially this + !! is the value from the previous timestep, which may + !! accelerate the iteration toward convergence. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(out) :: tke_io !< The turbulent kinetic energy per unit mass at + !! each interface (not layer!) [Z2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(inout) :: kv_io !< The vertical viscosity at each interface + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s]. This discards any + !! previous value (i.e. it is intent out) and + !! simply sets Kv = Prandtl * Kd_shear + real, intent(in) :: dt !< Time increment [T ~> s]. + type(Kappa_shear_CS), pointer :: CS !< The control structure returned by a previous + !! call to kappa_shear_init. + + ! Local variables + real, dimension(SZI_(G),SZK_(GV)) :: & + h_2d, & ! A 2-D version of h [H ~> m or kg m-2]. + dz_2d, & ! Vertical distance between interface heights [Z ~> m]. + u_2d, v_2d, & ! 2-D versions of u_in and v_in, converted to [L T-1 ~> m s-1]. + T_2d, S_2d, rho_2d ! 2-D versions of T [C ~> degC], S [S ~> ppt], and rho [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)+1) :: & + kappa_2d, & ! 2-D version of kappa_io [H Z T-1 ~> m2 s-1 or Pa s] + tke_2d ! 2-D version tke_io [Z2 T-2 ~> m2 s-2]. + real, dimension(SZK_(GV)) :: & + Idz, & ! The inverse of the thickness of the merged layers [H-1 ~> m2 kg-1]. + h_lay, & ! The layer thickness [H ~> m or kg m-2] + dz_lay, & ! The geometric layer thickness in height units [Z ~> m] + u0xdz, & ! The initial zonal velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1] + v0xdz, & ! The initial meridional velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1] + T0xdz, & ! The initial temperature times thickness [C H ~> degC m or degC kg m-2] or if + ! temperature is not a state variable, the density times thickness [R H ~> kg m-2 or kg2 m-3] + S0xdz ! The initial salinity times dz [S H ~> ppt m or ppt kg m-2]. + real, dimension(SZK_(GV)+1) :: & + kappa, & ! The shear-driven diapycnal diffusivity at an interface [H Z T-1 ~> m2 s-1 or Pa s] + tke, & ! The Turbulent Kinetic Energy per unit mass at an interface [Z2 T-2 ~> m2 s-2]. + kappa_avg, & ! The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] + tke_avg ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. + real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. + real :: surface_pres ! The top surface pressure [R L2 T-2 ~> Pa]. + + real :: dz_in_lay ! The running sum of the thickness in a layer [H ~> m or kg m-2] + real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1] + real :: dz_massless ! A layer thickness that is considered massless [H ~> m or kg m-2] + logical :: use_temperature ! If true, temperature and salinity have been + ! allocated and are being used as state variables. + + integer, dimension(SZK_(GV)+1) :: kc ! The index map between the original + ! interfaces and the interfaces with massless layers + ! merged into nearby massive layers. + real, dimension(SZK_(GV)+1) :: kf ! The fractional weight of interface kc+1 for + ! interpolating back to the original index space [nondim]. + integer :: is, ie, js, je, i, j, k, nz, nzc + + is = G%isc ; ie = G%iec; js = G%jsc ; je = G%jec ; nz = GV%ke + + use_temperature = associated(tv%T) + + k0dt = dt*CS%kappa_0 + dz_massless = 0.1*sqrt((US%Z_to_m*GV%m_to_H)*k0dt) + + !$OMP parallel do default(private) shared(js,je,is,ie,nz,h,u_in,v_in,use_temperature,tv,G,GV,US, & + !$OMP CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) + do j=js,je + + ! Convert layer thicknesses into geometric thickness in height units. + call thickness_to_dz(h, tv, dz_2d, j, G, GV) + + do k=1,nz ; do i=is,ie + h_2d(i,k) = h(i,j,k) + u_2d(i,k) = u_in(i,j,k) ; v_2d(i,k) = v_in(i,j,k) + enddo ; enddo + if (use_temperature) then ; do k=1,nz ; do i=is,ie + T_2d(i,k) = tv%T(i,j,k) ; S_2d(i,k) = tv%S(i,j,k) + enddo ; enddo ; else ; do k=1,nz ; do i=is,ie + rho_2d(i,k) = GV%Rlay(k) ! Could be tv%Rho(i,j,k) ? + enddo ; enddo ; endif + +!--------------------------------------- +! Work on each column. +!--------------------------------------- + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + ! call cpu_clock_begin(id_clock_setup) + + ! Store a transposed version of the initial arrays. + ! Any elimination of massless layers would occur here. + if (CS%eliminate_massless) then + nzc = 1 + do k=1,nz + ! Zero out the thicknesses of all layers, even if they are unused. + h_lay(k) = 0.0 ; dz_lay(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 + T0xdz(k) = 0.0 ; S0xdz(k) = 0.0 + + ! Add a new layer if this one has mass. +! if ((h_lay(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless)) nzc = nzc+1 + if ((k>CS%nkml) .and. (h_lay(nzc) > 0.0) .and. & + (h_2d(i,k) > dz_massless)) nzc = nzc+1 + + ! Only merge clusters of massless layers. +! if ((h_lay(nzc) > dz_massless) .or. & +! ((h_lay(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless))) nzc = nzc+1 + + kc(k) = nzc + h_lay(nzc) = h_lay(nzc) + h_2d(i,k) + dz_lay(nzc) = dz_lay(nzc) + dz_2d(i,k) + u0xdz(nzc) = u0xdz(nzc) + u_2d(i,k)*h_2d(i,k) + v0xdz(nzc) = v0xdz(nzc) + v_2d(i,k)*h_2d(i,k) + if (use_temperature) then + T0xdz(nzc) = T0xdz(nzc) + T_2d(i,k)*h_2d(i,k) + S0xdz(nzc) = S0xdz(nzc) + S_2d(i,k)*h_2d(i,k) + else + T0xdz(nzc) = T0xdz(nzc) + rho_2d(i,k)*h_2d(i,k) + S0xdz(nzc) = S0xdz(nzc) + rho_2d(i,k)*h_2d(i,k) + endif + enddo + kc(nz+1) = nzc+1 + + ! Set up Idz as the inverse of layer thicknesses. + do k=1,nzc ; Idz(k) = 1.0 / h_lay(k) ; enddo + + ! Now determine kf, the fractional weight of interface kc when + ! interpolating between interfaces kc and kc+1. + kf(1) = 0.0 ; dz_in_lay = h_2d(i,1) + do k=2,nz + if (kc(k) > kc(k-1)) then + kf(k) = 0.0 ; dz_in_lay = h_2d(i,k) + else + kf(k) = dz_in_lay*Idz(kc(k)) ; dz_in_lay = dz_in_lay + h_2d(i,k) + endif + enddo + kf(nz+1) = 0.0 + else + do k=1,nz + h_lay(k) = h_2d(i,k) + dz_lay(k) = dz_2d(i,k) + u0xdz(k) = u_2d(i,k)*h_lay(k) ; v0xdz(k) = v_2d(i,k)*h_lay(k) + enddo + if (use_temperature) then + do k=1,nz + T0xdz(k) = T_2d(i,k)*h_lay(k) ; S0xdz(k) = S_2d(i,k)*h_lay(k) + enddo + else + do k=1,nz + T0xdz(k) = rho_2d(i,k)*h_lay(k) ; S0xdz(k) = rho_2d(i,k)*h_lay(k) + enddo + endif + nzc = nz + do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo + endif + + f2 = 0.25 * ((G%CoriolisBu(I,j)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) + surface_pres = 0.0 ; if (associated(p_surf)) surface_pres = p_surf(i,j) + + ! ---------------------------------------------------- I_Ld2_1d, dz_Int_1d + + ! Set the initial guess for kappa, here defined at interfaces. + ! ---------------------------------------------------- + do K=1,nzc+1 ; kappa(K) = CS%kappa_seed ; enddo + + call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & + h_lay, dz_lay, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & + tke_avg, tv, CS, GV, US) + + ! call cpu_clock_begin(id_clock_setup) + ! Extrapolate from the vertically reduced grid back to the original layers. + if (nz == nzc) then + do K=1,nz+1 + kappa_2d(i,K) = kappa_avg(K) + if (CS%all_layer_TKE_bug) then + tke_2d(i,K) = tke(K) + else + tke_2d(i,K) = tke_avg(K) + endif + enddo + else + do K=1,nz+1 + if (kf(K) == 0.0) then + kappa_2d(i,K) = kappa_avg(kc(K)) + tke_2d(i,K) = tke_avg(kc(K)) + else + kappa_2d(i,K) = (1.0-kf(K)) * kappa_avg(kc(K)) + & + kf(K) * kappa_avg(kc(K)+1) + tke_2d(i,K) = (1.0-kf(K)) * tke_avg(kc(K)) + & + kf(K) * tke_avg(kc(K)+1) + endif + enddo + endif + ! call cpu_clock_end(id_clock_setup) + else ! Land points, still inside the i-loop. + do K=1,nz+1 + kappa_2d(i,K) = 0.0 ; tke_2d(i,K) = 0.0 + enddo + endif ; enddo ! i-loop + + do K=1,nz+1 ; do i=is,ie + kappa_io(i,j,K) = G%mask2dT(i,j) * kappa_2d(i,K) + tke_io(i,j,K) = G%mask2dT(i,j) * tke_2d(i,K) + kv_io(i,j,K) = ( G%mask2dT(i,j) * kappa_2d(i,K) ) * CS%Prandtl_turb + enddo ; enddo + + enddo ! end of j-loop + + if (CS%debug) then + call hchksum(kappa_io, "kappa", G%HI, scale=GV%HZ_T_to_m2_s) + call hchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + endif + + if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) + if (CS%id_TKE > 0) call post_data(CS%id_TKE, tke_io, CS%diag) + +end subroutine Calculate_kappa_shear + + +!> Subroutine for calculating shear-driven diffusivity and TKE in corner columns +subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_io, tke_io, & + kv_io, dt, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u_in !< Initial zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v_in !< Initial meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: T_in !< Layer potential temperatures [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: S_in !< Layer salinities [S ~> ppt] + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent fields + !! have NULL ptrs. + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] + !! (or NULL). + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(out) :: kappa_io !< The diapycnal diffusivity at each interface + !! (not layer!) [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & + intent(out) :: tke_io !< The turbulent kinetic energy per unit mass at + !! each interface (not layer!) [Z2 T-2 ~> m2 s-2]. + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & + intent(inout) :: kv_io !< The vertical viscosity at each interface + !! [H Z T-1 ~> m2 s-1 or Pa s]. + !! The previous value is used to initialize kappa + !! in the vertex columns as Kappa = Kv/Prandtl + !! to accelerate the iteration toward convergence. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(Kappa_shear_CS), pointer :: CS !< The control structure returned by a previous + !! call to kappa_shear_init. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + dz_3d ! Vertical distance between interface heights [Z ~> m]. + real, dimension(SZIB_(G),SZK_(GV)) :: & + h_2d, & ! A 2-D version of h [H ~> m or kg m-2]. + dz_2d, & ! Vertical distance between interface heights [Z ~> m]. + u_2d, v_2d, & ! 2-D versions of u_in and v_in, converted to [L T-1 ~> m s-1]. + T_2d, S_2d, rho_2d ! 2-D versions of T [C ~> degC], S [S ~> ppt], and rho [R ~> kg m-3]. + real, dimension(SZIB_(G),SZK_(GV)+1,2) :: & + kappa_2d ! Quasi 2-D versions of kappa_io [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(SZIB_(G),SZK_(GV)+1) :: & + tke_2d ! 2-D version tke_io [Z2 T-2 ~> m2 s-2]. + real, dimension(SZK_(GV)) :: & + Idz, & ! The inverse of the thickness of the merged layers [H-1 ~> m2 kg-1]. + h_lay, & ! The layer thickness [H ~> m or kg m-2] + dz_lay, & ! The geometric layer thickness in height units [Z ~> m] + u0xdz, & ! The initial zonal velocity times dz [L H T-1 ~> m2 s-1 or kg m-1 s-1]. + v0xdz, & ! The initial meridional velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1] + T0xdz, & ! The initial temperature times dz [C H ~> degC m or degC kg m-2] + S0xdz ! The initial salinity times dz [S H ~> ppt m or ppt kg m-2] + real, dimension(SZK_(GV)+1) :: & + kappa, & ! The shear-driven diapycnal diffusivity at an interface [H Z T-1 ~> m2 s-1 or Pa s] + tke, & ! The Turbulent Kinetic Energy per unit mass at an interface [Z2 T-2 ~> m2 s-2]. + kappa_avg, & ! The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] + tke_avg ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. + real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. + real :: surface_pres ! The top surface pressure [R L2 T-2 ~> Pa]. + + real :: dz_in_lay ! The running sum of the thickness in a layer [H ~> m or kg m-2] + real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1] + real :: dz_massless ! A layer thickness that is considered massless [H ~> m or kg m-2] + real :: I_hwt ! The inverse of the masked thickness weights [H-1 ~> m-1 or m2 kg-1]. + real :: I_Prandtl ! The inverse of the turbulent Prandtl number [nondim]. + logical :: use_temperature ! If true, temperature and salinity have been + ! allocated and are being used as state variables. + + integer, dimension(SZK_(GV)+1) :: kc ! The index map between the original + ! interfaces and the interfaces with massless layers + ! merged into nearby massive layers. + real, dimension(SZK_(GV)+1) :: kf ! The fractional weight of interface kc+1 for + ! interpolating back to the original index space [nondim]. + integer :: IsB, IeB, JsB, JeB, i, j, k, nz, nzc, J2, J2m1 + + ! Diagnostics that should be deleted? + isB = G%isc-1 ; ieB = G%iecB ; jsB = G%jsc-1 ; jeB = G%jecB ; nz = GV%ke + + use_temperature = associated(tv%T) + + k0dt = dt*CS%kappa_0 + dz_massless = 0.1*sqrt((US%Z_to_m*GV%m_to_H)*k0dt) + I_Prandtl = 0.0 ; if (CS%Prandtl_turb > 0.0) I_Prandtl = 1.0 / CS%Prandtl_turb + + ! Convert layer thicknesses into geometric thickness in height units. + call thickness_to_dz(h, tv, dz_3d, G, GV, US, halo_size=1) + + !$OMP parallel do default(private) shared(jsB,jeB,isB,ieB,nz,h,u_in,v_in,use_temperature,tv,G,GV, & + !$OMP US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io,I_Prandtl) + do J=JsB,JeB + J2 = mod(J,2)+1 ; J2m1 = 3-J2 ! = mod(J-1,2)+1 + + ! Interpolate the various quantities to the corners, using masks. + do k=1,nz ; do I=IsB,IeB + u_2d(I,k) = (u_in(I,j,k) * (G%mask2dCu(I,j) * (h(i,j,k) + h(i+1,j,k))) + & + u_in(I,j+1,k) * (G%mask2dCu(I,j+1) * (h(i,j+1,k) + h(i+1,j+1,k))) ) / & + ((G%mask2dCu(I,j) * (h(i,j,k) + h(i+1,j,k)) + & + G%mask2dCu(I,j+1) * (h(i,j+1,k) + h(i+1,j+1,k))) + GV%H_subroundoff) + v_2d(I,k) = (v_in(i,J,k) * (G%mask2dCv(i,J) * (h(i,j,k) + h(i,j+1,k))) + & + v_in(i+1,J,k) * (G%mask2dCv(i+1,J) * (h(i+1,j,k) + h(i+1,j+1,k))) ) / & + ((G%mask2dCv(i,J) * (h(i,j,k) + h(i,j+1,k)) + & + G%mask2dCv(i+1,J) * (h(i+1,j,k) + h(i+1,j+1,k))) + GV%H_subroundoff) + I_hwt = 1.0 / (((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k))) + & + GV%H_subroundoff) + if (use_temperature) then + T_2d(I,k) = ( ((G%mask2dT(i,j) * h(i,j,k)) * T_in(i,j,k) + & + (G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) * T_in(i+1,j+1,k)) + & + ((G%mask2dT(i+1,j) * h(i+1,j,k)) * T_in(i+1,j,k) + & + (G%mask2dT(i,j+1) * h(i,j+1,k)) * T_in(i,j+1,k)) ) * I_hwt + S_2d(I,k) = ( ((G%mask2dT(i,j) * h(i,j,k)) * S_in(i,j,k) + & + (G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) * S_in(i+1,j+1,k)) + & + ((G%mask2dT(i+1,j) * h(i+1,j,k)) * S_in(i+1,j,k) + & + (G%mask2dT(i,j+1) * h(i,j+1,k)) * S_in(i,j+1,k)) ) * I_hwt + endif + h_2d(I,k) = ((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k)) ) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) + dz_2d(I,k) = ((G%mask2dT(i,j) * dz_3d(i,j,k) + G%mask2dT(i+1,j+1) * dz_3d(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * dz_3d(i+1,j,k) + G%mask2dT(i,j+1) * dz_3d(i,j+1,k)) ) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) +! h_2d(I,k) = 0.25*((h(i,j,k) + h(i+1,j+1,k)) + (h(i+1,j,k) + h(i,j+1,k))) +! h_2d(I,k) = ((h(i,j,k)**2 + h(i+1,j+1,k)**2) + & +! (h(i+1,j,k)**2 + h(i,j+1,k)**2)) * I_hwt + enddo ; enddo + if (.not.use_temperature) then ; do k=1,nz ; do I=IsB,IeB + rho_2d(I,k) = GV%Rlay(k) + enddo ; enddo ; endif + +!--------------------------------------- +! Work on each column. +!--------------------------------------- + do I=IsB,IeB ; if ((G%mask2dCu(I,j) + G%mask2dCu(I,j+1)) + & + (G%mask2dCv(i,J) + G%mask2dCv(i+1,J)) > 0.0) then + ! call cpu_clock_begin(Id_clock_setup) + ! Store a transposed version of the initial arrays. + ! Any elimination of massless layers would occur here. + if (CS%eliminate_massless) then + nzc = 1 + do k=1,nz + ! Zero out the thicknesses of all layers, even if they are unused. + h_lay(k) = 0.0 ; dz_lay(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 + T0xdz(k) = 0.0 ; S0xdz(k) = 0.0 + + ! Add a new layer if this one has mass. +! if ((h_lay(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless)) nzc = nzc+1 + if ((k>CS%nkml) .and. (h_lay(nzc) > 0.0) .and. & + (h_2d(I,k) > dz_massless)) nzc = nzc+1 + + ! Only merge clusters of massless layers. +! if ((h_lay(nzc) > dz_massless) .or. & +! ((h_lay(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless))) nzc = nzc+1 + + kc(k) = nzc + h_lay(nzc) = h_lay(nzc) + h_2d(I,k) + dz_lay(nzc) = dz_lay(nzc) + dz_2d(I,k) + u0xdz(nzc) = u0xdz(nzc) + u_2d(I,k)*h_2d(I,k) + v0xdz(nzc) = v0xdz(nzc) + v_2d(I,k)*h_2d(I,k) + if (use_temperature) then + T0xdz(nzc) = T0xdz(nzc) + T_2d(I,k)*h_2d(I,k) + S0xdz(nzc) = S0xdz(nzc) + S_2d(I,k)*h_2d(I,k) + else + T0xdz(nzc) = T0xdz(nzc) + rho_2d(I,k)*h_2d(I,k) + S0xdz(nzc) = S0xdz(nzc) + rho_2d(I,k)*h_2d(I,k) + endif + enddo + kc(nz+1) = nzc+1 + + ! Set up Idz as the inverse of layer thicknesses. + do k=1,nzc ; Idz(k) = 1.0 / h_lay(k) ; enddo + + ! Now determine kf, the fractional weight of interface kc when + ! interpolating between interfaces kc and kc+1. + kf(1) = 0.0 ; dz_in_lay = h_2d(I,1) + do k=2,nz + if (kc(k) > kc(k-1)) then + kf(k) = 0.0 ; dz_in_lay = h_2d(I,k) + else + kf(k) = dz_in_lay*Idz(kc(k)) ; dz_in_lay = dz_in_lay + h_2d(I,k) + endif + enddo + kf(nz+1) = 0.0 + else + do k=1,nz + h_lay(k) = h_2d(I,k) + dz_lay(k) = dz_2d(I,k) + u0xdz(k) = u_2d(I,k)*h_lay(k) ; v0xdz(k) = v_2d(I,k)*h_lay(k) + enddo + if (use_temperature) then + do k=1,nz + T0xdz(k) = T_2d(I,k)*h_lay(k) ; S0xdz(k) = S_2d(I,k)*h_lay(k) + enddo + else + do k=1,nz + T0xdz(k) = rho_2d(I,k)*h_lay(k) ; S0xdz(k) = rho_2d(I,k)*h_lay(k) + enddo + endif + nzc = nz + do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo + endif + + f2 = G%CoriolisBu(I,J)**2 + surface_pres = 0.0 + if (associated(p_surf)) then + if (CS%psurf_bug) then + ! This is wrong because it is averaging values from land in some places. + surface_pres = 0.25 * ((p_surf(i,j) + p_surf(i+1,j+1)) + & + (p_surf(i+1,j) + p_surf(i,j+1))) + else + surface_pres = ((G%mask2dT(i,j) * p_surf(i,j) + G%mask2dT(i+1,j+1) * p_surf(i+1,j+1)) + & + (G%mask2dT(i+1,j) * p_surf(i+1,j) + G%mask2dT(i,j+1) * p_surf(i,j+1)) ) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) + endif + endif + + ! ---------------------------------------------------- + ! Set the initial guess for kappa, here defined at interfaces. + ! ---------------------------------------------------- + do K=1,nzc+1 ; kappa(K) = CS%kappa_seed ; enddo + + call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & + h_lay, dz_lay, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & + tke_avg, tv, CS, GV, US) + ! call cpu_clock_begin(Id_clock_setup) + ! Extrapolate from the vertically reduced grid back to the original layers. + if (nz == nzc) then + do K=1,nz+1 + kappa_2d(I,K,J2) = kappa_avg(K) + if (CS%all_layer_TKE_bug) then + tke_2d(i,K) = tke(K) + else + tke_2d(i,K) = tke_avg(K) + endif + enddo + else + do K=1,nz+1 + if (kf(K) == 0.0) then + kappa_2d(I,K,J2) = kappa_avg(kc(K)) + tke_2d(I,K) = tke_avg(kc(K)) + else + kappa_2d(I,K,J2) = (1.0-kf(K)) * kappa_avg(kc(K)) + kf(K) * kappa_avg(kc(K)+1) + tke_2d(I,K) = (1.0-kf(K)) * tke_avg(kc(K)) + kf(K) * tke_avg(kc(K)+1) + endif + enddo + endif + ! call cpu_clock_end(Id_clock_setup) + else ! Land points, still inside the i-loop. + do K=1,nz+1 + kappa_2d(I,K,J2) = 0.0 ; tke_2d(I,K) = 0.0 + enddo + endif ; enddo ! i-loop + + do K=1,nz+1 ; do I=IsB,IeB + tke_io(I,J,K) = G%mask2dBu(I,J) * tke_2d(I,K) + kv_io(I,J,K) = ( G%mask2dBu(I,J) * kappa_2d(I,K,J2) ) * CS%Prandtl_turb + enddo ; enddo + if (J>=G%jsc) then ; do K=1,nz+1 ; do i=G%isc,G%iec + ! Set the diffusivities in tracer columns from the values at vertices. + kappa_io(i,j,K) = G%mask2dT(i,j) * 0.25 * & + ((kappa_2d(I-1,K,J2m1) + kappa_2d(I,K,J2)) + & + (kappa_2d(I-1,K,J2) + kappa_2d(I,K,J2m1))) + enddo ; enddo ; endif + + enddo ! end of J-loop + + if (CS%debug) then + call hchksum(kappa_io, "kappa", G%HI, scale=GV%HZ_T_to_m2_s) + call Bchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + endif + + if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) + if (CS%id_TKE > 0) call post_data(CS%id_TKE, tke_io, CS%diag) + +end subroutine Calc_kappa_shear_vertex + + +!> This subroutine calculates shear-driven diffusivity and TKE in a single column +subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_lay, & + u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, tke_avg, tv, CS, GV, US) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), & + intent(inout) :: kappa !< The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(SZK_(GV)+1), & + intent(out) :: tke !< The Turbulent Kinetic Energy per unit mass at + !! an interface [Z2 T-2 ~> m2 s-2]. + integer, intent(in) :: nzc !< The number of active layers in the column. + real, intent(in) :: f2 !< The square of the Coriolis parameter [T-2 ~> s-2]. + real, intent(in) :: surface_pres !< The surface pressure [R L2 T-2 ~> Pa]. + real, dimension(SZK_(GV)), & + intent(in) :: hlay !< The layer thickness [H ~> m or kg m-2] + real, dimension(SZK_(GV)), & + intent(in) :: dz_lay !< The geometric layer thickness in height units [Z ~> m] + real, dimension(SZK_(GV)), & + intent(in) :: u0xdz !< The initial zonal velocity times hlay [H L T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)), & + intent(in) :: v0xdz !< The initial meridional velocity times the + !! layer thickness [H L T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)), & + intent(in) :: T0xdz !< The initial temperature times hlay [C H ~> degC m or degC kg m-2] + real, dimension(SZK_(GV)), & + intent(in) :: S0xdz !< The initial salinity times hlay [S H ~> ppt m or ppt kg m-2] + real, dimension(SZK_(GV)+1), & + intent(out) :: kappa_avg !< The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(SZK_(GV)+1), & + intent(out) :: tke_avg !< The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent fields + !! have NULL ptrs. + type(Kappa_shear_CS), pointer :: CS !< The control structure returned by a previous + !! call to kappa_shear_init. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real, dimension(nzc) :: & + u, & ! The zonal velocity after a timestep of mixing [L T-1 ~> m s-1]. + v, & ! The meridional velocity after a timestep of mixing [L T-1 ~> m s-1]. + Idz, & ! The inverse of the distance between TKE points [Z-1 ~> m-1]. + T, & ! The potential temperature after a timestep of mixing [C ~> degC]. + Sal, & ! The salinity after a timestep of mixing [S ~> ppt]. + u_test, v_test, & ! Temporary velocities [L T-1 ~> m s-1]. + T_test, S_test ! Temporary temperatures [C ~> degC] and salinities [S ~> ppt]. + + real, dimension(nzc+1) :: & + N2, & ! The squared buoyancy frequency at an interface [T-2 ~> s-2]. + h_Int, & ! The extent of a finite-volume space surrounding an interface, + ! as used in calculating kappa and TKE [H ~> m or kg m-2] + dz_Int, & ! The vertical distance with the space surrounding an interface, + ! as used in calculating kappa and TKE [Z ~> m] + dz_h_Int, & ! The ratio of the vertical distances to the thickness around an + ! interface [Z H-1 ~> nondim or m3 kg-1]. In non-Boussinesq mode + ! this is the specific volume, otherwise it is a scaling factor. + I_dz_int, & ! The inverse of the distance between velocity & density points + ! above and below an interface [Z-1 ~> m-1]. This is used to + ! calculate N2, shear and fluxes. + S2, & ! The squared shear at an interface [T-2 ~> s-2]. + a1, & ! a1 is the coupling between adjacent interfaces in the TKE, + ! velocity, and density equations [H ~> m or kg m-2] + c1, & ! c1 is used in the tridiagonal (and similar) solvers [nondim]. + k_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1] + kappa_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1] + kappa_out, & ! The kappa that results from the kappa equation [H Z T-1 ~> m2 s-1 or Pa s] + kappa_mid, & ! The average of the initial and predictor estimates of kappa [H Z T-1 ~> m2 s-1 or Pa s] + tke_pred, & ! The value of TKE from a predictor step [Z2 T-2 ~> m2 s-2]. + kappa_pred, & ! The value of kappa from a predictor step [H Z T-1 ~> m2 s-1 or Pa s] + pressure, & ! The pressure at an interface [R L2 T-2 ~> Pa]. + T_int, & ! The temperature interpolated to an interface [C ~> degC]. + Sal_int, & ! The salinity interpolated to an interface [S ~> ppt]. + dbuoy_dT, & ! The partial derivative of buoyancy with changes in temperature [Z T-2 C-1 ~> m s-2 degC-1] + dbuoy_dS, & ! The partial derivative of buoyancy with changes in salinity [Z T-2 S-1 ~> m s-2 ppt-1] + dSpV_dT, & ! The partial derivative of specific volume with changes in temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! The partial derivative of specific volume with changes in salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + rho_int, & ! The in situ density interpolated to an interface [R ~> kg m-3] + I_L2_bdry, & ! The inverse of the square of twice the harmonic mean + ! distance to the top and bottom boundaries [H-1 Z-1 ~> m-2 or m kg-1]. + K_Q, & ! Diffusivity divided by TKE [H T Z-1 ~> s or kg s m-3] + K_Q_tmp, & ! A temporary copy of diffusivity divided by TKE [H T Z-1 ~> s or kg s m-3] + local_src_avg, & ! The time-integral of the local source [nondim] + tol_min, & ! Minimum tolerated ksrc for the corrector step [T-1 ~> s-1]. + tol_max, & ! Maximum tolerated ksrc for the corrector step [T-1 ~> s-1]. + tol_chg, & ! The tolerated kappa change integrated over a timestep [nondim]. + dist_from_top, & ! The distance from the top surface [Z ~> m]. + h_from_top, & ! The total thickness above an interface [H ~> m or kg m-2] + local_src ! The sum of all sources of kappa, including kappa_src and + ! sources from the elliptic term [T-1 ~> s-1] + + real :: dist_from_bot ! The distance from the bottom surface [Z ~> m]. + real :: h_from_bot ! The total thickness below and interface [H ~> m or kg m-2] + real :: b1 ! The inverse of the pivot in the tridiagonal equations [H-1 ~> m-1 or m2 kg-1]. + real :: bd1 ! A term in the denominator of b1 [H ~> m or kg m-2]. + real :: d1 ! 1 - c1 in the tridiagonal equations [nondim] + real :: gR0 ! A conversion factor from H to pressure, Rho_0 times g in Boussinesq + ! mode, or just g when non-Boussinesq [R L2 T-2 H-1 ~> kg m-2 s-2 or m s-2]. + real :: g_R0 ! g_R0 is a rescaled version of g/Rho [Z R-1 T-2 ~> m4 kg-1 s-2]. + real :: Norm ! A factor that normalizes two weights to 1 [H-2 ~> m-2 or m4 kg-2]. + real :: tol_dksrc ! Tolerance for the change in the kappa source within an iteration + ! relative to the local source [nondim]. This must be greater than 1. + real :: tol2 ! The tolerance for the change in the kappa source within an iteration + ! relative to the average local source over previous iterations [nondim]. + real :: tol_dksrc_low ! The tolerance for the fractional decrease in ksrc + ! within an iteration [nondim]. 0 < tol_dksrc_low < 1. + real :: Ri_crit ! The critical shear Richardson number for shear- + ! driven mixing [nondim]. The theoretical value is 0.25. + real :: dt_rem ! The remaining time to advance the solution [T ~> s]. + real :: dt_now ! The time step used in the current iteration [T ~> s]. + real :: dt_wt ! The fractional weight of the current iteration [nondim]. + real :: dt_test ! A time-step that is being tested for whether it + ! gives acceptably small changes in k_src [T ~> s]. + real :: Idtt ! Idtt = 1 / dt_test [T-1 ~> s-1]. + real :: dt_inc ! An increment to dt_test that is being tested [T ~> s]. + real :: wt_a ! The fraction of a layer thickness identified with the interface + ! above a layer [nondim] + real :: wt_b ! The fraction of a layer thickness identified with the interface + ! below a layer [nondim] + real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1]. + logical :: valid_dt ! If true, all levels so far exhibit acceptably small changes in k_src. + logical :: use_temperature ! If true, temperature and salinity have been + ! allocated and are being used as state variables. + integer :: ks_kappa, ke_kappa ! The k-range with nonzero kappas. + integer :: dt_refinements ! The number of 2-fold refinements that will be used + ! to estimate the maximum permitted time step. I.e., + ! the resolution is 1/2^dt_refinements. + integer :: k, itt, itt_dt + + ! This calculation of N2 is for debugging only. + ! real, dimension(SZK_(GV)+1) :: & + ! N2_debug, & ! A version of N2 for debugging [T-2 ~> s-2] + + Ri_crit = CS%Rino_crit + gR0 = GV%H_to_RZ * GV%g_Earth + g_R0 = (US%L_to_Z**2 * GV%g_Earth) / GV%Rho0 + k0dt = dt*CS%kappa_0 + + tol_dksrc = CS%kappa_src_max_chg + if (tol_dksrc == 10.0) then + ! This is equivalent to the expression below, but avoids changes at roundoff for the default value. + tol_dksrc_low = 0.95 + else + tol_dksrc_low = (tol_dksrc - 0.5)/tol_dksrc + endif + tol2 = 2.0*CS%kappa_tol_err + dt_refinements = 5 ! Selected so that 1/2^dt_refinements < 1-tol_dksrc_low + use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. + + + ! Set up Idz as the inverse of layer thicknesses. + do k=1,nzc ; Idz(k) = 1.0 / dz_lay(k) ; enddo + ! Set up I_dz_int as the inverse of the distance between + ! adjacent layer centers. + I_dz_int(1) = 2.0 / dz_lay(1) + dist_from_top(1) = 0.0 ; h_from_top(1) = 0.0 + do K=2,nzc + I_dz_int(K) = 2.0 / (dz_lay(k-1) + dz_lay(k)) + dist_from_top(K) = dist_from_top(K-1) + dz_lay(k-1) + h_from_top(K) = h_from_top(K-1) + hlay(k-1) + enddo + I_dz_int(nzc+1) = 2.0 / dz_lay(nzc) + + ! Find the inverse of the squared distances from the boundaries. + dist_from_bot = 0.0 ; h_from_bot = 0.0 + do K=nzc,2,-1 + dist_from_bot = dist_from_bot + dz_lay(k) + h_from_bot = h_from_bot + hlay(k) + I_L2_bdry(K) = ((dist_from_top(K) + dist_from_bot) * (h_from_top(K) + h_from_bot)) / & + ((dist_from_top(K) * dist_from_bot) * (h_from_top(K) * h_from_bot)) + enddo + + ! Determine the velocities and thicknesses after eliminating massless + ! layers and applying a time-step of background diffusion. + if (nzc > 1) then + a1(2) = k0dt*I_dz_int(2) + b1 = 1.0 / (hlay(1) + a1(2)) + u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) + T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) + c1(2) = a1(2) * b1 ; d1 = hlay(1) * b1 ! = 1 - c1 + do k=2,nzc-1 + bd1 = hlay(k) + d1*a1(k) + a1(k+1) = k0dt*I_dz_int(k+1) + b1 = 1.0 / (bd1 + a1(k+1)) + u(k) = b1 * (u0xdz(k) + a1(k)*u(k-1)) + v(k) = b1 * (v0xdz(k) + a1(k)*v(k-1)) + T(k) = b1 * (T0xdz(k) + a1(k)*T(k-1)) + Sal(k) = b1 * (S0xdz(k) + a1(k)*Sal(k-1)) + c1(k+1) = a1(k+1) * b1 ; d1 = bd1 * b1 ! d1 = 1 - c1 + enddo + ! rho or T and S have insulating boundary conditions, u & v use no-slip + ! bottom boundary conditions (if kappa0 > 0). + ! For no-slip bottom boundary conditions + b1 = 1.0 / ((hlay(nzc) + d1*a1(nzc)) + k0dt*I_dz_int(nzc+1)) + u(nzc) = b1 * (u0xdz(nzc) + a1(nzc)*u(nzc-1)) + v(nzc) = b1 * (v0xdz(nzc) + a1(nzc)*v(nzc-1)) + ! For insulating boundary conditions + b1 = 1.0 / (hlay(nzc) + d1*a1(nzc)) + T(nzc) = b1 * (T0xdz(nzc) + a1(nzc)*T(nzc-1)) + Sal(nzc) = b1 * (S0xdz(nzc) + a1(nzc)*Sal(nzc-1)) + do k=nzc-1,1,-1 + u(k) = u(k) + c1(k+1)*u(k+1) ; v(k) = v(k) + c1(k+1)*v(k+1) + T(k) = T(k) + c1(k+1)*T(k+1) ; Sal(k) = Sal(k) + c1(k+1)*Sal(k+1) + enddo + else + ! This is correct, but probably unnecessary. + b1 = 1.0 / (hlay(1) + k0dt*I_dz_int(2)) + u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) + b1 = 1.0 / hlay(1) + T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) + endif + + ! This uses half the harmonic mean of thicknesses to provide two estimates + ! of the boundary between cells, and the inverse of the harmonic mean to + ! weight the two estimates. The net effect is that interfaces around thin + ! layers have thin cells, and the total thickness adds up properly. + ! The top- and bottom- interfaces have zero thickness, consistent with + ! adding additional zero thickness layers. + h_Int(1) = 0.0 ; h_Int(2) = hlay(1) + dz_Int(1) = 0.0 ; dz_Int(2) = dz_lay(1) + do K=2,nzc-1 + Norm = 1.0 / (hlay(k)*(hlay(k-1)+hlay(k+1)) + 2.0*hlay(k-1)*hlay(k+1)) + wt_a = ((hlay(k)+hlay(k+1)) * hlay(k-1)) * Norm + wt_b = ((hlay(k-1)+hlay(k)) * hlay(k+1)) * Norm + h_Int(K) = h_Int(K) + hlay(k) * wt_a + h_Int(K+1) = hlay(k) * wt_b + dz_Int(K) = dz_Int(K) + dz_lay(k) * wt_a + dz_Int(K+1) = dz_lay(k) * wt_b + enddo + h_Int(nzc) = h_Int(nzc) + hlay(nzc) ; h_Int(nzc+1) = 0.0 + dz_Int(nzc) = dz_Int(nzc) + dz_lay(nzc) ; dz_Int(nzc+1) = 0.0 + + if (GV%Boussinesq) then + do K=1,nzc+1 ; dz_h_Int(K) = GV%H_to_Z ; enddo + else + ! Find an effective average specific volume around an interface. + dz_h_Int(1:nzc+1) = 0.0 + if (hlay(1) > 0.0) dz_h_Int(1) = dz_lay(1) / hlay(1) + do K=2,nzc+1 + if (h_Int(K) > 0.0) then + dz_h_Int(K) = dz_Int(K) / h_Int(K) + else + dz_h_Int(K) = dz_h_Int(K-1) + endif + enddo + endif + + ! Calculate thermodynamic coefficients and an initial estimate of N2. + if (use_temperature) then + pressure(1) = surface_pres + do K=2,nzc + pressure(K) = pressure(K-1) + gR0*hlay(k-1) + T_int(K) = 0.5*(T(k-1) + T(k)) + Sal_int(K) = 0.5*(Sal(k-1) + Sal(k)) + enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, dbuoy_dS, & + tv%eqn_of_state, (/2,nzc/), scale=-g_R0 ) + else + ! These should perhaps be combined into a single call to calculate the thermal expansion + ! and haline contraction coefficients? + call calculate_specific_vol_derivs(T_int, Sal_int, pressure, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, (/2,nzc/) ) + call calculate_density(T_int, Sal_int, pressure, rho_int, tv%eqn_of_state, (/2,nzc/) ) + do K=2,nzc + dbuoy_dT(K) = (US%L_to_Z**2 * GV%g_Earth) * (rho_int(K) * dSpV_dT(K)) + dbuoy_dS(K) = (US%L_to_Z**2 * GV%g_Earth) * (rho_int(K) * dSpV_dS(K)) + enddo + endif + elseif (GV%Boussinesq .or. GV%semi_Boussinesq) then + do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo + else + do K=1,nzc+1 ; dbuoy_dS(K) = 0.0 ; enddo + dbuoy_dT(1) = -(US%L_to_Z**2 * GV%g_Earth) / GV%Rlay(1) + do K=2,nzc + dbuoy_dT(K) = -(US%L_to_Z**2 * GV%g_Earth) / (0.5*(GV%Rlay(k-1) + GV%Rlay(k))) + enddo + dbuoy_dT(nzc+1) = -(US%L_to_Z**2 * GV%g_Earth) / GV%Rlay(nzc) + endif + + ! N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 + ! do K=2,nzc + ! N2_debug(K) = max((dbuoy_dT(K) * (T0xdz(k-1)*Idz(k-1) - T0xdz(k)*Idz(k)) + & + ! dbuoy_dS(K) * (S0xdz(k-1)*Idz(k-1) - S0xdz(k)*Idz(k))) * & + ! I_dz_int(K), 0.0) + ! enddo + + ! This call just calculates N2 and S2. + call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, hlay, I_dz_int, dbuoy_dT, dbuoy_dS, & + CS%vel_underflow, u, v, T, Sal, N2, S2, GV, US) +! ---------------------------------------------------- +! Iterate +! ---------------------------------------------------- + dt_rem = dt + do K=1,nzc+1 + K_Q(K) = 0.0 + kappa_avg(K) = 0.0 ; tke_avg(K) = 0.0 + local_src_avg(K) = 0.0 + ! Use the grid spacings to scale errors in the source. + if ( h_Int(K) > 0.0 ) & + local_src_avg(K) = 0.1 * k0dt * I_dz_int(K) / h_Int(K) + enddo + +! call cpu_clock_end(id_clock_setup) + +! do itt=1,CS%max_RiNo_it + do itt=1,CS%max_KS_it + +! ---------------------------------------------------- +! Calculate new values of u, v, rho, N^2 and S. +! ---------------------------------------------------- + + ! call cpu_clock_begin(id_clock_KQ) + call find_kappa_tke(N2, S2, kappa, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & + nzc, CS, GV, US, K_Q, tke, kappa_out, kappa_src, local_src) + ! call cpu_clock_end(id_clock_KQ) + + ! call cpu_clock_begin(id_clock_avg) + ! Determine the range of non-zero values of kappa_out. + ks_kappa = GV%ke+1 ; ke_kappa = 0 + do K=2,nzc ; if (kappa_out(K) > 0.0) then + ks_kappa = K ; exit + endif ; enddo + do k=nzc,ks_kappa,-1 ; if (kappa_out(K) > 0.0) then + ke_kappa = K ; exit + endif ; enddo + if (ke_kappa == nzc) kappa_out(nzc+1) = 0.0 + ! call cpu_clock_end(id_clock_avg) + + ! Determine how long to use this value of kappa (dt_now). + + ! call cpu_clock_begin(id_clock_project) + if ((ke_kappa < ks_kappa) .or. (itt==CS%max_KS_it)) then + dt_now = dt_rem + else + ! Limit dt_now so that |k_src(k)-kappa_src(k)| < tol * local_src(k) + dt_test = dt_rem + do K=2,nzc + tol_max(K) = kappa_src(K) + tol_dksrc * local_src(K) + tol_min(K) = kappa_src(K) - tol_dksrc_low * local_src(K) + tol_chg(K) = tol2 * local_src_avg(K) + enddo + + do itt_dt=1,(CS%max_KS_it+1-itt)/2 + ! The maximum number of times that the time-step is halved in + ! seeking an acceptable timestep is reduced with each iteration, + ! so that as the maximum number of iterations is approached, the + ! whole remaining timestep is used. Typically, an acceptable + ! timestep is found long before the minimum is reached, so the + ! value of max_KS_it may be unimportant, especially if it is large + ! enough. + call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*dt_test, nzc, hlay, I_dz_int, & + dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, & + T_test, S_test, N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) + valid_dt = .true. + Idtt = 1.0 / dt_test + do K=max(ks_kappa-1,2),min(ke_kappa+1,nzc) + if (N2(K) < Ri_crit * S2(K)) then ! Equivalent to Ri < Ri_crit. + K_src(K) = (2.0 * CS%Shearmix_rate * sqrt(S2(K))) * & + ((Ri_crit*S2(K) - N2(K)) / (Ri_crit*S2(K) + CS%FRi_curvature*N2(K))) + if (CS%restrictive_tolerance_check) then + if ((K_src(K) > min(tol_max(K), kappa_src(K) + Idtt*tol_chg(K))) .or. & + (K_src(K) < max(tol_min(K), kappa_src(K) - Idtt*tol_chg(K)))) then + valid_dt = .false. ; exit + endif + else + if ((K_src(K) > max(tol_max(K), kappa_src(K) + Idtt*tol_chg(K))) .or. & + (K_src(K) < min(tol_min(K), kappa_src(K) - Idtt*tol_chg(K)))) then + valid_dt = .false. ; exit + endif + endif + else + if (0.0 < min(tol_min(K), kappa_src(K) - Idtt*tol_chg(K))) then + valid_dt = .false. ; k_src(K) = 0.0 ; exit + endif + endif + enddo + + if (valid_dt) exit + dt_test = 0.5*dt_test + enddo + if ((dt_test < dt_rem) .and. valid_dt) then + dt_inc = 0.5*dt_test + do itt_dt=1,dt_refinements + call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*(dt_test+dt_inc), nzc, hlay, & + I_dz_int, dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, T_test, S_test, & + N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) + valid_dt = .true. + Idtt = 1.0 / (dt_test+dt_inc) + do K=max(ks_kappa-1,2),min(ke_kappa+1,nzc) + if (N2(K) < Ri_crit * S2(K)) then ! Equivalent to Ri < Ri_crit. + K_src(K) = (2.0 * CS%Shearmix_rate * sqrt(S2(K))) * & + ((Ri_crit*S2(K) - N2(K)) / (Ri_crit*S2(K) + CS%FRi_curvature*N2(K))) + if ((K_src(K) > max(tol_max(K), kappa_src(K) + Idtt*tol_chg(K))) .or. & + (K_src(K) < min(tol_min(K), kappa_src(K) - Idtt*tol_chg(K)))) then + valid_dt = .false. ; exit + endif + else + if (0.0 < min(tol_min(K), kappa_src(K) - Idtt*tol_chg(K))) then + valid_dt = .false. ; k_src(K) = 0.0 ; exit + endif + endif + enddo + + if (valid_dt) dt_test = dt_test + dt_inc + dt_inc = 0.5*dt_inc + enddo + else + dt_inc = 0.0 + endif + + dt_now = min(dt_test*(1.0+CS%kappa_tol_err)+dt_inc, dt_rem) + do K=2,nzc + local_src_avg(K) = local_src_avg(K) + dt_now * local_src(K) + enddo + endif ! Are all the values of kappa_out 0? + ! call cpu_clock_end(id_clock_project) + + ! The state has already been projected forward. Now find new values of kappa. + + if (ke_kappa < ks_kappa) then + ! There is no mixing now, and will not be again. + ! call cpu_clock_begin(id_clock_avg) + dt_wt = dt_rem / dt ; dt_rem = 0.0 + do K=1,nzc+1 + kappa_mid(K) = 0.0 + ! This would be here but does nothing. + ! kappa_avg(K) = kappa_avg(K) + kappa_mid(K)*dt_wt + tke_avg(K) = tke_avg(K) + dt_wt*tke(K) + enddo + ! call cpu_clock_end(id_clock_avg) + else + ! call cpu_clock_begin(id_clock_project) + call calculate_projected_state(kappa_out, u, v, T, Sal, dt_now, nzc, hlay, I_dz_int, & + dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, & + T_test, S_test, N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) + ! call cpu_clock_end(id_clock_project) + + ! call cpu_clock_begin(id_clock_KQ) + do K=1,nzc+1 ; K_Q_tmp(K) = K_Q(K) ; enddo + call find_kappa_tke(N2, S2, kappa_out, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & + nzc, CS, GV, US, K_Q_tmp, tke_pred, kappa_pred) + ! call cpu_clock_end(id_clock_KQ) + + ks_kappa = GV%ke+1 ; ke_kappa = 0 + do K=1,nzc+1 + kappa_mid(K) = 0.5*(kappa_out(K) + kappa_pred(K)) + if ((kappa_mid(K) > 0.0) .and. (K 0.0) ke_kappa = K + enddo + + ! call cpu_clock_begin(id_clock_project) + call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, hlay, I_dz_int, & + dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, & + T_test, S_test, N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) + ! call cpu_clock_end(id_clock_project) + + ! call cpu_clock_begin(id_clock_KQ) + call find_kappa_tke(N2, S2, kappa_out, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & + nzc, CS, GV, US, K_Q, tke_pred, kappa_pred) + ! call cpu_clock_end(id_clock_KQ) + + ! call cpu_clock_begin(id_clock_avg) + dt_wt = dt_now / dt ; dt_rem = dt_rem - dt_now + do K=1,nzc+1 + kappa_mid(K) = 0.5*(kappa_out(K) + kappa_pred(K)) + kappa_avg(K) = kappa_avg(K) + kappa_mid(K)*dt_wt + tke_avg(K) = tke_avg(K) + dt_wt*0.5*(tke_pred(K) + tke(K)) + kappa(K) = kappa_pred(K) ! First guess for the next iteration. + enddo + ! call cpu_clock_end(id_clock_avg) + endif + + if (dt_rem > 0.0) then + ! Update the values of u, v, T, Sal, N2, and S2 for the next iteration. + ! call cpu_clock_begin(id_clock_project) + call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, hlay, I_dz_int, & + dbuoy_dT, dbuoy_dS, CS%vel_underflow, u, v, T, Sal, N2, S2, & + GV, US) + ! call cpu_clock_end(id_clock_project) + endif + + if (dt_rem <= 0.0) exit + + enddo ! end itt loop + +end subroutine kappa_shear_column + +!> This subroutine calculates the velocities, temperature and salinity that +!! the water column will have after mixing for dt with diffusivities kappa. It +!! may also calculate the projected buoyancy frequency and shear. +subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int, dbuoy_dT, dbuoy_dS, & + vel_under, u, v, T, Sal, N2, S2, GV, US, ks_int, ke_int) + integer, intent(in) :: nz !< The number of layers (after eliminating massless + !! layers?). + real, dimension(nz+1), intent(in) :: kappa !< The diapycnal diffusivity at interfaces, + !! [H Z T-1 ~> m2 s-1 or Pa s]. + real, dimension(nz), intent(in) :: u0 !< The initial zonal velocity [L T-1 ~> m s-1]. + real, dimension(nz), intent(in) :: v0 !< The initial meridional velocity [L T-1 ~> m s-1]. + real, dimension(nz), intent(in) :: T0 !< The initial temperature [C ~> degC]. + real, dimension(nz), intent(in) :: S0 !< The initial salinity [S ~> ppt]. + real, intent(in) :: dt !< The time step [T ~> s]. + real, dimension(nz), intent(in) :: dz !< The layer thicknesses [H ~> m or kg m-2] + real, dimension(nz+1), intent(in) :: I_dz_int !< The inverse of the distance between succesive + !! layer centers [Z-1 ~> m-1]. + real, dimension(nz+1), intent(in) :: dbuoy_dT !< The partial derivative of buoyancy with + !! temperature [Z T-2 C-1 ~> m s-2 degC-1]. + real, dimension(nz+1), intent(in) :: dbuoy_dS !< The partial derivative of buoyancy with + !! salinity [Z T-2 S-1 ~> m s-2 ppt-1]. + real, intent(in) :: vel_under !< Any velocities that are smaller in magnitude + !! than this value are set to 0 [L T-1 ~> m s-1]. + real, dimension(nz), intent(inout) :: u !< The zonal velocity after dt [L T-1 ~> m s-1]. + real, dimension(nz), intent(inout) :: v !< The meridional velocity after dt [L T-1 ~> m s-1]. + real, dimension(nz), intent(inout) :: T !< The temperature after dt [C ~> degC]. + real, dimension(nz), intent(inout) :: Sal !< The salinity after dt [S ~> ppt]. + real, dimension(nz+1), intent(inout) :: N2 !< The buoyancy frequency squared at interfaces [T-2 ~> s-2]. + real, dimension(nz+1), intent(inout) :: S2 !< The squared shear at interfaces [T-2 ~> s-2]. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, optional, intent(in) :: ks_int !< The topmost k-index with a non-zero diffusivity. + integer, optional, intent(in) :: ke_int !< The bottommost k-index with a non-zero + !! diffusivity. + + ! Local variables + real, dimension(nz+1) :: c1 ! A tridiagonal variable [nondim] + real :: a_a, a_b ! Tridiagonal coupling coefficients [H ~> m or kg m-2] + real :: b1, b1nz_0 ! Tridiagonal variables [H-1 ~> m-1 or m2 kg-1] + real :: bd1 ! A term in the denominator of b1 [H ~> m or kg m-2] + real :: d1 ! A tridiagonal variable [nondim] + integer :: k, ks, ke + + ks = 1 ; ke = nz + if (present(ks_int)) ks = max(ks_int-1,1) + if (present(ke_int)) ke = min(ke_int,nz) + + if (ks > ke) return + + if (dt > 0.0) then + a_b = dt*(kappa(ks+1)*I_dz_int(ks+1)) + b1 = 1.0 / (dz(ks) + a_b) + c1(ks+1) = a_b * b1 ; d1 = dz(ks) * b1 ! = 1 - c1 + + u(ks) = (b1 * dz(ks))*u0(ks) ; v(ks) = (b1 * dz(ks))*v0(ks) + T(ks) = (b1 * dz(ks))*T0(ks) ; Sal(ks) = (b1 * dz(ks))*S0(ks) + do K=ks+1,ke-1 + a_a = a_b + a_b = dt*(kappa(K+1)*I_dz_int(K+1)) + bd1 = dz(k) + d1*a_a + b1 = 1.0 / (bd1 + a_b) + c1(K+1) = a_b * b1 ; d1 = bd1 * b1 ! d1 = 1 - c1 + + u(k) = b1 * (dz(k)*u0(k) + a_a*u(k-1)) + v(k) = b1 * (dz(k)*v0(k) + a_a*v(k-1)) + T(k) = b1 * (dz(k)*T0(k) + a_a*T(k-1)) + Sal(k) = b1 * (dz(k)*S0(k) + a_a*Sal(k-1)) + enddo + ! T and S have insulating boundary conditions, u & v use no-slip + ! bottom boundary conditions at the solid bottom. + + ! For insulating boundary conditions or mixing simply stopping, use... + a_a = a_b + b1 = 1.0 / (dz(ke) + d1*a_a) + T(ke) = b1 * (dz(ke)*T0(ke) + a_a*T(ke-1)) + Sal(ke) = b1 * (dz(ke)*S0(ke) + a_a*Sal(ke-1)) + + ! There is no distinction between the effective boundary conditions for + ! tracers and velocities if the mixing is separated from the bottom, but if + ! the mixing goes all the way to the bottom, use no-slip BCs for velocities. + if (ke == nz) then + a_b = dt*(kappa(nz+1)*I_dz_int(nz+1)) + b1nz_0 = 1.0 / ((dz(nz) + d1*a_a) + a_b) + else + b1nz_0 = b1 + endif + u(ke) = b1nz_0 * (dz(ke)*u0(ke) + a_a*u(ke-1)) + v(ke) = b1nz_0 * (dz(ke)*v0(ke) + a_a*v(ke-1)) + if (abs(u(ke)) < vel_under) u(ke) = 0.0 + if (abs(v(ke)) < vel_under) v(ke) = 0.0 + + do k=ke-1,ks,-1 + u(k) = u(k) + c1(k+1)*u(k+1) + v(k) = v(k) + c1(k+1)*v(k+1) + if (abs(u(k)) < vel_under) u(k) = 0.0 + if (abs(v(k)) < vel_under) v(k) = 0.0 + T(k) = T(k) + c1(k+1)*T(k+1) + Sal(k) = Sal(k) + c1(k+1)*Sal(k+1) + enddo + else ! dt <= 0.0 + do k=1,nz + u(k) = u0(k) ; v(k) = v0(k) ; T(k) = T0(k) ; Sal(k) = S0(k) + if (abs(u(k)) < vel_under) u(k) = 0.0 + if (abs(v(k)) < vel_under) v(k) = 0.0 + enddo + endif + + ! Store the squared shear at interfaces + S2(1) = 0.0 ; S2(nz+1) = 0.0 + if (ks > 1) & + S2(ks) = ((u(ks)-u0(ks-1))**2 + (v(ks)-v0(ks-1))**2) * (US%L_to_Z*I_dz_int(ks))**2 + do K=ks+1,ke + S2(K) = ((u(k)-u(k-1))**2 + (v(k)-v(k-1))**2) * (US%L_to_Z*I_dz_int(K))**2 + enddo + if (ke 1) & + N2(ks) = max(0.0, I_dz_int(ks) * & + (dbuoy_dT(ks) * (T0(ks-1)-T(ks)) + dbuoy_dS(ks) * (S0(ks-1)-Sal(ks)))) + do K=ks+1,ke + N2(K) = max(0.0, I_dz_int(K) * & + (dbuoy_dT(K) * (T(k-1)-T(k)) + dbuoy_dS(K) * (Sal(k-1)-Sal(k)))) + enddo + if (ke This subroutine calculates new, consistent estimates of TKE and kappa. +subroutine find_kappa_tke(N2, S2, kappa_in, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & + nz, CS, GV, US, K_Q, tke, kappa, kappa_src, local_src) + integer, intent(in) :: nz !< The number of layers to work on. + real, dimension(nz+1), intent(in) :: N2 !< The buoyancy frequency squared at interfaces [T-2 ~> s-2]. + real, dimension(nz+1), intent(in) :: S2 !< The squared shear at interfaces [T-2 ~> s-2]. + real, dimension(nz+1), intent(in) :: kappa_in !< The initial guess at the diffusivity + !! [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(nz+1), intent(in) :: h_Int !< The thicknesses associated with interfaces + !! [H ~> m or kg m-2] + real, dimension(nz+1), intent(in) :: dz_Int !< The vertical distances around interfaces [Z ~> m] + real, dimension(nz+1), intent(in) :: dz_h_Int !< The ratio of the vertical distances to the + !! thickness around an interface [Z H-1 ~> nondim or m3 kg-1]. + !! In non-Boussinesq mode this is the specific volume. + real, dimension(nz+1), intent(in) :: I_L2_bdry !< The inverse of the squared distance to + !! boundaries [H-1 Z-1 ~> m-2 or m kg-1]. + real, dimension(nz), intent(in) :: Idz !< The inverse grid spacing of layers [Z-1 ~> m-1]. + real, intent(in) :: f2 !< The squared Coriolis parameter [T-2 ~> s-2]. + type(Kappa_shear_CS), pointer :: CS !< A pointer to this module's control structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(nz+1), intent(inout) :: K_Q !< The shear-driven diapycnal diffusivity divided by + !! the turbulent kinetic energy per unit mass at + !! interfaces [H T Z-1 ~> s or kg s m-3]. + real, dimension(nz+1), intent(out) :: tke !< The turbulent kinetic energy per unit mass at + !! interfaces [Z2 T-2 ~> m2 s-2]. + real, dimension(nz+1), intent(out) :: kappa !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(nz+1), optional, & + intent(out) :: kappa_src !< The source term for kappa [T-1 ~> s-1] + real, dimension(nz+1), optional, & + intent(out) :: local_src !< The sum of all local sources for kappa + !! [T-1 ~> s-1] + ! This subroutine calculates new, consistent estimates of TKE and kappa. + + ! Local variables + real, dimension(nz) :: & + aQ, & ! aQ is the coupling between adjacent interfaces in the TKE equations [H T-1 ~> m s-1 or kg m-2 s-1] + dQdz ! Half the partial derivative of TKE with depth [Z T-2 ~> m s-2]. + real, dimension(nz+1) :: & + dK, & ! The change in kappa [H Z T-1 ~> m2 s-1 or Pa s]. + dQ, & ! The change in TKE [Z2 T-2 ~> m2 s-2]. + cQ, cK, & ! cQ and cK are the upward influences in the tridiagonal and + ! hexadiagonal solvers for the TKE and kappa equations [nondim]. + I_Ld2, & ! 1/Ld^2, where Ld is the effective decay length scale for kappa [H-1 Z-1 ~> m-2 or m kg-1] + TKE_decay, & ! The local TKE decay rate [T-1 ~> s-1]. + k_src, & ! The source term in the kappa equation [T-1 ~> s-1]. + dQmdK, & ! With Newton's method the change in dQ(k-1) due to dK(k) [Z T H-1 ~> s or m3 s kg-1] + dKdQ, & ! With Newton's method the change in dK(k) due to dQ(k) [H Z-1 T-1 ~> s-1 or kg m-3 s-1] + e1 ! The fractional change in a layer TKE due to a change in the + ! TKE of the layer above when all the kappas below are 0 [nondim]. + ! e1 is nondimensional, and 0 < e1 < 1. + real :: tke_src ! The net source of TKE due to mixing against the shear and stratification + ! [Z2 T-3 ~> m2 s-3] or [H Z T-3 ~> m2 s-3 or kg m-1 s-3]. + ! (For convenience, a term involving the non-dissipation of q0 is also included here.) + real :: bQ ! The inverse of the pivot in the tridiagonal equations [T H-1 ~> s m-1 or m2 s kg-1] + real :: bK ! The inverse of the pivot in the tridiagonal equations [Z-1 ~> m-1]. + real :: bQd1 ! A term in the denominator of bQ [H T-1 ~> m s-1 or kg m-2 s-1] + real :: bKd1 ! A term in the denominator of bK [Z ~> m]. + real :: cQcomp, cKcomp ! 1 - cQ or 1 - cK in the tridiagonal equations [nondim]. + real :: c_s2 ! The coefficient for the decay of TKE due to + ! shear (i.e. proportional to |S|*tke) [nondim]. + real :: c_n2 ! The coefficient for the decay of TKE due to + ! stratification (i.e. proportional to N*tke) [nondim]. + real :: Ri_crit ! The critical shear Richardson number for shear- + ! driven mixing [nondim]. The theoretical value is 0.25. + real :: q0 ! The background level of TKE [Z2 T-2 ~> m2 s-2]. + real :: Ilambda2 ! 1.0 / CS%lambda**2 [nondim] + real :: TKE_min ! The minimum value of shear-driven TKE that can be + ! solved for [Z2 T-2 ~> m2 s-2]. + real :: kappa0 ! The background diapycnal diffusivity [H Z T-1 ~> m2 s-1 or Pa s] + real :: kappa_trunc ! Diffusivities smaller than this are rounded to 0 [H Z T-1 ~> m2 s-1 or Pa s] + + real :: eden1, eden2 ! Variables used in calculating e1 [H Z-2 ~> m-1 or kg m-4] + real :: I_eden ! The inverse of the denominator in e1 [Z2 H-1 ~> m or m4 kg-1] + real :: ome ! Variables used in calculating e1 [nondim] + real :: diffusive_src ! The diffusive source in the kappa equation [H T-1 ~> m s-1 or kg m-2 s-1] + real :: chg_by_k0 ! The value of k_src that leads to an increase of + ! kappa_0 if only the diffusive term is a sink [T-1 ~> s-1] + real :: h_dz_here ! The ratio of the thicknesses to the vertical distances around an interface + ! [H Z-1 ~> nondim or kg m-3]. In non-Boussinesq mode this is the density. + + real :: kappa_mean ! A mean value of kappa [H Z T-1 ~> m2 s-1 or Pa s] + real :: Newton_test ! The value of relative error that will cause the next + ! iteration to use Newton's method [nondim]. + ! Temporary variables used in the Newton's method iterations. + real :: decay_term_k ! The decay term in the diffusivity equation [Z-1 ~> m-1] + real :: decay_term_Q ! The decay term in the TKE equation - proportional to [H Z-1 T-1 ~> s-1 or kg m-3 s-1] + real :: I_Q ! The inverse of TKE [T2 Z-2 ~> s2 m-2] + real :: kap_src ! A source term in the kappa equation [H T-1 ~> m s-1 or kg m-2 s-1] + real :: v1 ! A temporary variable proportional to [H Z-1 T-1 ~> s-1 or kg m-3 s-1] + real :: v2 ! A temporary variable in [Z T-2 ~> m s-2] + real :: tol_err ! The tolerance for max_err that determines when to + ! stop iterating [nondim]. + real :: Newton_err ! The tolerance for max_err that determines when to + ! start using Newton's method [nondim]. Empirically, an initial + ! value of about 0.2 seems to be most efficient. + real, parameter :: roundoff = 1.0e-16 ! A negligible fractional change in TKE [nondim]. + ! This could be larger but performance gains are small. + + logical :: tke_noflux_bottom_BC = .false. ! Specify the boundary conditions + logical :: tke_noflux_top_BC = .false. ! that are applied to the TKE equations. + logical :: do_Newton ! If .true., use Newton's method for the next iteration. + logical :: abort_Newton ! If .true., an Newton's method has encountered a 0 + ! pivot, and should not have been used. + logical :: was_Newton ! The value of do_Newton before checking convergence. + logical :: within_tolerance ! If .true., all points are within tolerance to + ! enable this subroutine to return. + integer :: ks_src, ke_src ! The range indices that have nonzero k_src. + integer :: ks_kappa, ke_kappa, ke_tke ! The ranges of k-indices that are or + integer :: ks_kappa_prev, ke_kappa_prev ! were being worked on. + integer :: itt, k, k2 + + ! These variables are used only for debugging. + logical, parameter :: debug_soln = .false. + real :: K_err_lin ! The imbalance in the K equation [H T-1 ~> m s-1 or kg m-2 s-1] + real :: Q_err_lin ! The imbalance in the Q equation [H Z T-3 ~> m2 s-3 or kg m-1 s-3] + real, dimension(nz+1) :: & + I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [H-1 Z-1 ~> m-2 or m kg-1]. + kappa_prev, & ! The value of kappa at the start of the current iteration [H Z T-1 ~> m2 s-1 or Pa s] + TKE_prev ! The value of TKE at the start of the current iteration [Z2 T-2 ~> m2 s-2]. + + c_N2 = CS%C_N**2 ; c_S2 = CS%C_S**2 + q0 = CS%TKE_bg ; kappa0 = CS%kappa_0 + TKE_min = max(CS%TKE_bg, 1.0E-20*US%m_to_Z**2*US%T_to_s**2) + Ri_crit = CS%Rino_crit + Ilambda2 = 1.0 / CS%lambda**2 + kappa_trunc = CS%kappa_trunc + do_Newton = .false. ; abort_Newton = .false. + tol_err = CS%kappa_tol_err + Newton_err = 0.2 ! This initial value may be automatically reduced later. + + ks_kappa = 2 ; ke_kappa = nz ; ks_kappa_prev = 2 ; ke_kappa_prev = nz + + ke_src = 0 ; ks_src = nz+1 + do K=2,nz + if (N2(K) < Ri_crit * S2(K)) then ! Equivalent to Ri < Ri_crit. +! Ri = N2(K) / S2(K) +! k_src(K) = (2.0 * CS%Shearmix_rate * sqrt(S2(K))) * & +! ((Ri_crit - Ri) / (Ri_crit + CS%FRi_curvature*Ri)) + K_src(K) = (2.0 * CS%Shearmix_rate * sqrt(S2(K))) * & + ((Ri_crit*S2(K) - N2(K)) / (Ri_crit*S2(K) + CS%FRi_curvature*N2(K))) + ke_src = K + if (ks_src > k) ks_src = K + else + k_src(K) = 0.0 + endif + enddo + + ! If there is no source anywhere, return kappa(K) = 0. + if (ks_src > ke_src) then + do K=1,nz+1 + kappa(K) = 0.0 ; K_Q(K) = 0.0 ; tke(K) = TKE_min + enddo + if (present(kappa_src)) then ; do K=1,nz+1 ; kappa_src(K) = 0.0 ; enddo ; endif + if (present(local_src)) then ; do K=1,nz+1 ; local_src(K) = 0.0 ; enddo ; endif + return + endif + + do K=1,nz+1 + kappa(K) = kappa_in(K) +! TKE_decay(K) = c_n*sqrt(N2(K)) + c_s*sqrt(S2(K)) ! The expression in JHL. + TKE_decay(K) = sqrt(c_n2*N2(K) + c_s2*S2(K)) + if ((kappa(K) > 0.0) .and. (K_Q(K) > 0.0)) then + TKE(K) = kappa(K) / K_Q(K) ! Perhaps take the max with TKE_min + else + TKE(K) = TKE_min + endif + enddo + ! Apply boundary conditions to kappa. + kappa(1) = 0.0 ; kappa(nz+1) = 0.0 + + ! Calculate the term (e1) that allows changes in TKE to be calculated quickly + ! below the deepest nonzero value of kappa. If kappa = 0, below interface + ! k-1, the final changes in TKE are related by dQ(K+1) = e1(K+1)*dQ(K). + eden2 = kappa0 * Idz(nz) + if (tke_noflux_bottom_BC) then + eden1 = h_Int(nz+1)*TKE_decay(nz+1) + I_eden = 1.0 / (eden2 + eden1) + e1(nz+1) = eden2 * I_eden ; ome = eden1 * I_eden + else + e1(nz+1) = 0.0 ; ome = 1.0 + endif + do k=nz,2,-1 + eden1 = h_Int(K)*TKE_decay(K) + ome * eden2 + eden2 = kappa0 * Idz(k-1) + I_eden = 1.0 / (eden2 + eden1) + e1(K) = eden2 * I_eden ; ome = eden1 * I_eden ! = 1-e1 + enddo + e1(1) = 0.0 + + + ! Iterate here to convergence to within some tolerance of order tol_err. + do itt=1,CS%max_RiNo_it + + ! ---------------------------------------------------- + ! Calculate TKE + ! ---------------------------------------------------- + + if (debug_soln) then ; do K=1,nz+1 ; kappa_prev(K) = kappa(K) ; TKE_prev(K) = TKE(K) ; enddo ; endif + + if (.not.do_Newton) then + ! Use separate steps of the TKE and kappa equations, that are + ! explicit in the nonlinear source terms, implicit in a linearized + ! version of the nonlinear sink terms, and implicit in the linear + ! terms. + + ke_tke = max(ke_kappa,ke_kappa_prev)+1 + ! aQ is the coupling between adjacent interfaces [Z T-1 ~> m s-1]. + do k=1,min(ke_tke,nz) + aQ(k) = (0.5*(kappa(K)+kappa(K+1)) + kappa0) * Idz(k) + enddo + dQ(1) = -TKE(1) + if (tke_noflux_top_BC) then + tke_src = dz_h_Int(1)*kappa0*S2(1) + q0 * TKE_decay(1) ! Uses that kappa(1) = 0 + bQd1 = h_Int(1) * TKE_decay(1) + bQ = 1.0 / (bQd1 + aQ(1)) + tke(1) = bQ * (h_Int(1)*tke_src) + cQ(2) = aQ(1) * bQ ; cQcomp = bQd1 * bQ ! = 1 - cQ + else + tke(1) = q0 ; cQ(2) = 0.0 ; cQcomp = 1.0 + endif + do K=2,ke_tke-1 + dQ(K) = -TKE(K) + tke_src = dz_h_Int(K)*(kappa(K) + kappa0)*S2(K) + q0*TKE_decay(K) + bQd1 = h_Int(K)*(TKE_decay(K) + dz_h_Int(K)*N2(K)*K_Q(K)) + cQcomp*aQ(k-1) + bQ = 1.0 / (bQd1 + aQ(k)) + tke(K) = bQ * (h_Int(K)*tke_src + aQ(k-1)*tke(K-1)) + cQ(K+1) = aQ(k) * bQ ; cQcomp = bQd1 * bQ ! = 1 - cQ + enddo + if ((ke_tke == nz+1) .and. .not.(tke_noflux_bottom_BC)) then + tke(nz+1) = TKE_min + dQ(nz+1) = 0.0 + else + k = ke_tke + tke_src = dz_h_Int(K)*kappa0*S2(K) + q0*TKE_decay(K) ! Uses that kappa(ke_tke) = 0 + if (K == nz+1) then + dQ(K) = -TKE(K) + bQ = 1.0 / (h_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) + tke(K) = max(TKE_min, bQ * (h_Int(K)*tke_src + aQ(k-1)*tke(K-1))) + dQ(K) = tke(K) + dQ(K) + else + bQ = 1.0 / ((h_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) + aQ(k)) + cQ(K+1) = aQ(k) * bQ + ! Account for all changes deeper in the water column. + dQ(K) = -TKE(K) + tke(K) = max((bQ * (h_Int(K)*tke_src + aQ(k-1)*tke(K-1)) + & + cQ(K+1)*(tke(K+1) - e1(K+1)*tke(K))) / (1.0 - cQ(K+1)*e1(K+1)), TKE_min) + dQ(K) = tke(K) + dQ(K) + + ! Adjust TKE deeper in the water column in case ke_tke increases. + ! This might not be strictly necessary? + do K=ke_tke+1,nz+1 + dQ(K) = e1(K)*dQ(K-1) + tke(K) = max(tke(K) + dQ(K), TKE_min) + if (abs(dQ(K)) < roundoff*tke(K)) exit + enddo + do K2=K+1,nz + if (dQ(K2) == 0.0) exit + dQ(K2) = 0.0 + enddo + endif + endif + do K=ke_tke-1,1,-1 + tke(K) = max(tke(K) + cQ(K+1)*tke(K+1), TKE_min) + dQ(K) = tke(K) + dQ(K) + enddo + + ! ---------------------------------------------------- + ! Calculate kappa, here defined at interfaces. + ! ---------------------------------------------------- + + ke_kappa_prev = ke_kappa ; ks_kappa_prev = ks_kappa + + dK(1) = 0.0 ! kappa takes boundary values of 0. + cK(2) = 0.0 ; cKcomp = 1.0 + if (itt == 1) then ; do K=2,nz + I_Ld2(K) = dz_h_Int(K)*(N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) + enddo ; endif + do K=2,nz + dK(K) = -kappa(K) + if (itt>1) & + I_Ld2(K) = dz_h_Int(K)*(N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) + bKd1 = h_Int(K)*I_Ld2(K) + cKcomp*Idz(k-1) + bK = 1.0 / (bKd1 + Idz(k)) + + kappa(K) = bK * (Idz(k-1)*kappa(K-1) + h_Int(K) * K_src(K)) + cK(K+1) = Idz(k) * bK ; cKcomp = bKd1 * bK ! = 1 - cK(K+1) + + ! Neglect values that are smaller than kappa_trunc. + if (kappa(K) < cKcomp*kappa_trunc) then + kappa(K) = 0.0 + if (K > ke_src) then ; ke_kappa = k-1 ; K_Q(K) = 0.0 ; exit ; endif + elseif (kappa(K) < 2.0*cKcomp*kappa_trunc) then + kappa(K) = 2.0 * (kappa(K) - cKcomp*kappa_trunc) + endif + enddo + K_Q(ke_kappa) = kappa(ke_kappa) / tke(ke_kappa) + dK(ke_kappa) = dK(ke_kappa) + kappa(ke_kappa) + do K=ke_kappa+2,ke_kappa_prev + dK(K) = -kappa(K) ; kappa(K) = 0.0 ; K_Q(K) = 0.0 + enddo + do K=ke_kappa-1,2,-1 + kappa(K) = kappa(K) + cK(K+1)*kappa(K+1) + ! Neglect values that are smaller than kappa_trunc. + if (kappa(K) <= kappa_trunc) then + kappa(K) = 0.0 + if (K < ks_src) then ; ks_kappa = k+1 ; K_Q(K) = 0.0 ; exit ; endif + elseif (kappa(K) < 2.0*kappa_trunc) then + kappa(K) = 2.0 * (kappa(K) - kappa_trunc) + endif + + dK(K) = dK(K) + kappa(K) + K_Q(K) = kappa(K) / tke(K) + enddo + do K=ks_kappa_prev,ks_kappa-2 ; kappa(K) = 0.0 ; K_Q(K) = 0.0 ; enddo + + else ! do_Newton is .true. +! Once the solutions are close enough, use a Newton's method solver of the +! whole system to accelerate convergence. + ks_kappa_prev = ks_kappa ; ke_kappa_prev = ke_kappa ; ke_kappa = nz + ks_kappa = 2 + dK(1) = 0.0 ; cK(2) = 0.0 ; cKcomp = 1.0 ; dKdQ(1) = 0.0 + aQ(1) = (0.5*(kappa(1)+kappa(2))+kappa0) * Idz(1) + dQdz(1) = 0.5*(TKE(1) - TKE(2))*Idz(1) + if (tke_noflux_top_BC) then + tke_src = h_Int(1) * (kappa0*dz_h_Int(1)*S2(1) - (TKE(1) - q0)*TKE_decay(1)) - & + aQ(1) * (TKE(1) - TKE(2)) + + bQ = 1.0 / (aQ(1) + h_Int(1)*TKE_decay(1)) + cQ(2) = aQ(1) * bQ + cQcomp = (h_Int(1)*TKE_decay(1)) * bQ ! = 1 - cQ(2) + dQmdK(2) = -dQdz(1) * bQ + dQ(1) = bQ * tke_src + else + dQ(1) = 0.0 ; cQ(2) = 0.0 ; cQcomp = 1.0 ; dQmdK(2) = 0.0 + endif + do K=2,nz + I_Q = 1.0 / TKE(K) + I_Ld2(K) = (N2(K)*Ilambda2 + f2) * dz_h_Int(K)*I_Q + I_L2_bdry(K) + + kap_src = h_Int(K) * (K_src(K) - I_Ld2(K)*kappa(K)) + & + Idz(k-1)*(kappa(K-1)-kappa(K)) - Idz(k)*(kappa(K)-kappa(K+1)) + + ! Ensure that the pivot is always positive, and that 0 <= cK <= 1. + ! Otherwise do not use Newton's method. + decay_term_k = -Idz(k-1)*dQmdK(K)*dKdQ(K-1) + h_Int(K)*I_Ld2(K) + if (decay_term_k < 0.0) then ; abort_Newton = .true. ; exit ; endif + bK = 1.0 / (Idz(k) + Idz(k-1)*cKcomp + decay_term_k) + + cK(K+1) = bK * Idz(k) + cKcomp = bK * (Idz(k-1)*cKcomp + decay_term_k) ! = 1-cK(K+1) + if (CS%dKdQ_iteration_bug) then + dKdQ(K) = bK * (Idz(k-1)*dKdQ(K-1)*cQ(K) + & + US%m_to_Z*(N2(K)*Ilambda2 + f2) * I_Q**2 * kappa(K) ) + else + dKdQ(K) = bK * (Idz(k-1)*dKdQ(K-1)*cQ(K) + & + dz_Int(K)*(N2(K)*Ilambda2 + f2) * I_Q**2 * kappa(K) ) + endif + dK(K) = bK * (kap_src + Idz(k-1)*dK(K-1) + Idz(k-1)*dKdQ(K-1)*dQ(K-1)) + + ! Truncate away negligibly small values of kappa. + if (dK(K) <= cKcomp*(kappa_trunc - kappa(K))) then + dK(K) = -cKcomp*kappa(K) +! if (K > ke_src) then ; ke_kappa = k-1 ; K_Q(K) = 0.0 ; exit ; endif + elseif (dK(K) < cKcomp*(2.0*kappa_trunc - kappa(K))) then + dK(K) = 2.0 * dK(K) - cKcomp*(2.0*kappa_trunc - kappa(K)) + endif + + ! Solve for dQ(K)... + aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) + dQdz(k) = 0.5*(TKE(K) - TKE(K+1))*Idz(k) + tke_src = h_Int(K) * ((dz_h_Int(K) * ((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K))) - & + (TKE(k) - q0)*TKE_decay(k)) - & + (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) + v1 = aQ(k-1) + dQdz(k-1)*dKdQ(K-1) + v2 = (v1*dQmdK(K) + dQdz(k-1)*cK(K)) + & + ((dQdz(k-1) - dQdz(k)) + dz_Int(K)*(S2(K) - N2(K))) + + ! Ensure that the pivot is always positive, and that 0 <= cQ <= 1. + ! Otherwise do not use Newton's method. + decay_term_Q = h_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K) - v2*dKdQ(K) + if (decay_term_Q < 0.0) then ; abort_Newton = .true. ; exit ; endif + bQ = 1.0 / (aQ(k) + (cQcomp*aQ(k-1) + decay_term_Q)) + + cQ(K+1) = aQ(k) * bQ + cQcomp = (cQcomp*aQ(k-1) + decay_term_Q) * bQ + dQmdK(K+1) = (v2 * cK(K+1) - dQdz(k)) * bQ + + ! Ensure that TKE+dQ will not drop below 0.5*TKE. + dQ(K) = max(bQ * ((v1 * dQ(K-1) + dQdz(k-1)*dK(k-1)) + & + (v2 * dK(K) + tke_src)), cQcomp*(-0.5*TKE(K))) + + ! Check whether the next layer will be affected by any nonzero kappas. + if ((itt > 1) .and. (K > ke_src) .and. (dK(K) == 0.0) .and. & + ((kappa(K) + kappa(K+1)) == 0.0)) then + ! Could also do .and. (bQ*abs(tke_src) < roundoff*TKE(K)) then + ke_kappa = k-1 ; exit + endif + enddo + if ((ke_kappa == nz) .and. (.not. abort_Newton)) then + dK(nz+1) = 0.0 ; dKdQ(nz+1) = 0.0 + if (tke_noflux_bottom_BC) then + K = nz+1 + tke_src = h_Int(K) * (kappa0*dz_h_Int(K)*S2(K) - (TKE(K) - q0)*TKE_decay(K)) + & + aQ(k-1) * (TKE(K-1) - TKE(K)) + + v1 = aQ(k-1) + dQdz(k-1)*dKdQ(K-1) + decay_term_Q = max(0.0, h_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K)) + if (decay_term_Q < 0.0) then + abort_Newton = .true. + else + bQ = 1.0 / (aQ(k) + (cQcomp*aQ(k-1) + decay_term_Q)) + ! Ensure that TKE+dQ will not drop below 0.5*TKE. + dQ(K) = max(bQ * ((v1 * dQ(K-1) + dQdz(k-1)*dK(K-1)) + tke_src), -0.5*TKE(K)) + TKE(K) = max(TKE(K) + dQ(K), TKE_min) + endif + else + dQ(nz+1) = 0.0 + endif + elseif (.not. abort_Newton) then + ! Alter the first-guess determination of dQ(K). + dQ(ke_kappa+1) = dQ(ke_kappa+1) / (1.0 - cQ(ke_kappa+2)*e1(ke_kappa+2)) + TKE(ke_kappa+1) = max(TKE(ke_kappa+1) + dQ(ke_kappa+1), TKE_min) + do k=ke_kappa+2,nz+1 + if (debug_soln .and. (K < nz+1)) then + ! Ignore this source? + aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) + ! tke_src_norm = ((kappa0*dz_Int(K)*S2(K) - h_Int(K)*(TKE(K)-q0)*TKE_decay(K)) - & + ! (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) ) / & + ! (aQ(k) + (aQ(k-1) + h_Int(K)*TKE_decay(K))) + endif + dK(K) = 0.0 + ! Ensure that TKE+dQ will not drop below 0.5*TKE. + dQ(K) = max(e1(K)*dQ(K-1),-0.5*TKE(K)) + TKE(K) = max(TKE(K) + dQ(K), TKE_min) + if (abs(dQ(K)) < roundoff*TKE(K)) exit + enddo + if (debug_soln) then ; do K2=K+1,nz+1 ; dQ(K2) = 0.0 ; dK(K2) = 0.0 ; enddo ; endif + endif + if (.not. abort_Newton) then + do K=ke_kappa,2,-1 + ! Ensure that TKE+dQ will not drop below 0.5*TKE. + dQ(K) = max(dQ(K) + (cQ(K+1)*dQ(K+1) + dQmdK(K+1) * dK(K+1)), -0.5*TKE(K)) + TKE(K) = max(TKE(K) + dQ(K), TKE_min) + dK(K) = dK(K) + (cK(K+1)*dK(K+1) + dKdQ(K) * dQ(K)) + ! Truncate away negligibly small values of kappa. + if (dK(K) <= kappa_trunc - kappa(K)) then + dK(K) = -kappa(K) + kappa(K) = 0.0 + if ((K < ks_src) .and. (K+1 > ks_kappa)) ks_kappa = K+1 + elseif (dK(K) < 2.0*kappa_trunc - kappa(K)) then + dK(K) = 2.0*dK(K) - (2.0*kappa_trunc - kappa(K)) + kappa(K) = max(kappa(K) + dK(K), 0.0) ! The max is for paranoia. + if (K<=ks_kappa) ks_kappa = 2 + else + kappa(K) = kappa(K) + dK(K) + if (K<=ks_kappa) ks_kappa = 2 + endif + enddo + dQ(1) = max(dQ(1) + cQ(2)*dQ(2) + dQmdK(2) * dK(2), TKE_min - TKE(1)) + TKE(1) = max(TKE(1) + dQ(1), TKE_min) + dK(1) = 0.0 + endif + + ! Check these solutions for consistency. + ! The unit conversions here have not been carefully tested. + if (debug_soln) then ; do K=2,nz + ! In these equations, K_err_lin and Q_err_lin should be at round-off levels + ! compared with the dominant terms, perhaps, h_Int*I_Ld2*kappa and + ! h_Int*TKE_decay*TKE. The exception is where, either 1) the decay term has been + ! been increased to ensure a positive pivot, or 2) negative TKEs have been + ! truncated, or 3) small or negative kappas have been rounded toward 0. + I_Q = 1.0 / TKE(K) + I_Ld2_debug(K) = (N2(K)*Ilambda2 + f2) * dz_h_Int(K)*I_Q + I_L2_bdry(K) + + kap_src = h_Int(K) * (k_src(K) - I_Ld2(K)*kappa_prev(K)) + & + (Idz(k-1)*(kappa_prev(k-1)-kappa_prev(k)) - & + Idz(k)*(kappa_prev(k)-kappa_prev(k+1))) + K_err_lin = -Idz(k-1)*(dK(K-1)-dK(K)) + Idz(k)*(dK(K)-dK(K+1)) + & + h_Int(K)*I_Ld2_debug(K)*dK(K) - kap_src - & + dz_Int(K)*(N2(K)*Ilambda2 + f2)*I_Q**2*kappa_prev(K) * dQ(K) + + h_dz_here = 0.0 ; if (abs(dz_h_Int(K)) > 0.0) h_dz_here = 1.0 / dz_h_Int(K) + tke_src = h_Int(K) * ((kappa_prev(K) + kappa0)*S2(K) - & + kappa_prev(K)*N2(K) - (TKE_prev(K) - q0)*h_dz_here*TKE_decay(K)) - & + (aQ(k) * (TKE_prev(K) - TKE_prev(K+1)) - aQ(k-1) * (TKE_prev(K-1) - TKE_prev(K))) + Q_err_lin = tke_src + (aQ(k-1) * (dQ(K-1)-dQ(K)) - aQ(k) * (dQ(k)-dQ(k+1))) - & + 0.5*(TKE_prev(K)-TKE_prev(K+1))*Idz(k) * (dK(K) + dK(K+1)) - & + 0.5*(TKE_prev(K)-TKE_prev(K-1))*Idz(k-1)* (dK(K-1) + dK(K)) + & + dz_Int(K) * (dK(K) * (S2(K) - N2(K)) - dQ(K)*TKE_decay(K)) + enddo ; endif + + endif ! End of the Newton's method solver. + + ! Test kappa for convergence... + if ((tol_err < Newton_err) .and. (.not.abort_Newton)) then + ! A lower tolerance is used to switch to Newton's method than to switch back. + Newton_test = Newton_err ; if (do_Newton) Newton_test = 2.0*Newton_err + was_Newton = do_Newton + within_tolerance = .true. ; do_Newton = .true. + do K=min(ks_kappa,ks_kappa_prev),max(ke_kappa,ke_kappa_prev) + kappa_mean = kappa0 + (kappa(K) - 0.5*dK(K)) + if (abs(dK(K)) > Newton_test * kappa_mean) then + if (do_Newton) abort_Newton = .true. + within_tolerance = .false. ; do_Newton = .false. ; exit + elseif (abs(dK(K)) > tol_err * kappa_mean) then + within_tolerance = .false. ; if (.not.do_Newton) exit + endif + if (abs(dQ(K)) > Newton_test*(tke(K) - 0.5*dQ(K))) then + if (do_Newton) abort_Newton = .true. + do_Newton = .false. ; if (.not.within_tolerance) exit + endif + enddo + + else ! Newton's method will not be used again, so no need to check. + within_tolerance = .true. + do K=min(ks_kappa,ks_kappa_prev),max(ke_kappa,ke_kappa_prev) + if (abs(dK(K)) > tol_err * (kappa0 + (kappa(K) - 0.5*dK(K)))) then + within_tolerance = .false. ; exit + endif + enddo + endif + + if (abort_Newton) then + do_Newton = .false. ; abort_Newton = .false. + ! We went to Newton too quickly last time, so restrict the tolerance. + Newton_err = 0.5*Newton_err + ke_kappa_prev = nz + do K=2,nz ; K_Q(K) = kappa(K) / max(TKE(K), TKE_min) ; enddo + endif + + if (within_tolerance) exit + + enddo + + if (do_Newton) then ! K_Q needs to be calculated. + do K=1,ks_kappa-1 ; K_Q(K) = 0.0 ; enddo + do K=ks_kappa,ke_kappa ; K_Q(K) = kappa(K) / TKE(K) ; enddo + do K=ke_kappa+1,nz+1 ; K_Q(K) = 0.0 ; enddo + endif + + if (present(local_src)) then + local_src(1) = 0.0 ; local_src(nz+1) = 0.0 + do K=2,nz + diffusive_src = Idz(k-1)*(kappa(K-1)-kappa(K)) + Idz(k)*(kappa(K+1)-kappa(K)) + chg_by_k0 = kappa0 * ((Idz(k-1)+Idz(k)) / h_Int(K) + I_Ld2(K)) + if (diffusive_src <= 0.0) then + local_src(K) = K_src(K) + chg_by_k0 + else + local_src(K) = (K_src(K) + chg_by_k0) + diffusive_src / h_Int(K) + endif + enddo + endif + if (present(kappa_src)) then + kappa_src(1) = 0.0 ; kappa_src(nz+1) = 0.0 + do K=2,nz + kappa_src(K) = K_src(K) + enddo + endif + +end subroutine find_kappa_tke + +!> This subroutine initializes the parameters that regulate shear-driven mixing +function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic + !! output. + type(Kappa_shear_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + logical :: kappa_shear_init !< True if module is to be used, False otherwise + + ! Local variables + real :: KD_normal ! The KD of the main model, read here only as a parameter + ! for setting the default of KD_SMOOTH [Z2 T-1 ~> m2 s-1] + real :: kappa_0_default ! The default value for KD_KAPPA_SHEAR_0 [Z2 T-1 ~> m2 s-1] + logical :: merge_mixedlayer + logical :: debug_shear + logical :: just_read ! If true, this module is not used, so only read the parameters. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. + + if (associated(CS)) then + call MOM_error(WARNING, "kappa_shear_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ! The Jackson-Hallberg-Legg shear mixing parameterization uses the following + ! 6 nondimensional coefficients. That paper gives 3 best fit parameter sets. + ! Ri_Crit Rate FRi_Curv K_buoy TKE_N TKE_Shear + ! p1: 0.25 0.089 -0.97 0.82 0.24 0.14 + ! p2: 0.30 0.085 -0.94 0.86 0.26 0.13 + ! p3: 0.35 0.088 -0.89 0.81 0.28 0.12 + ! Future research will reveal how these should be modified to take + ! subgridscale inhomogeneity into account. + +! Set default, read and log parameters + call get_param(param_file, mdl, "USE_JACKSON_PARAM", kappa_shear_init, default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, & + "Parameterization of shear-driven turbulence following Jackson, Hallberg and Legg, JPO 2008", & + log_to_all=.true., debugging=kappa_shear_init, all_default=.not.kappa_shear_init) + call get_param(param_file, mdl, "USE_JACKSON_PARAM", kappa_shear_init, & + "If true, use the Jackson-Hallberg-Legg (JPO 2008) "//& + "shear mixing parameterization.", default=.false.) + just_read = .not.kappa_shear_init + call get_param(param_file, mdl, "VERTEX_SHEAR", CS%KS_at_vertex, & + "If true, do the calculations of the shear-driven mixing "//& + "at the cell vertices (i.e., the vorticity points).", & + default=.false., do_not_log=just_read) + call get_param(param_file, mdl, "RINO_CRIT", CS%RiNo_crit, & + "The critical Richardson number for shear mixing.", & + units="nondim", default=0.25, do_not_log=just_read) + call get_param(param_file, mdl, "SHEARMIX_RATE", CS%Shearmix_rate, & + "A nondimensional rate scale for shear-driven entrainment. "//& + "Jackson et al find values in the range of 0.085-0.089.", & + units="nondim", default=0.089, do_not_log=just_read) + call get_param(param_file, mdl, "MAX_RINO_IT", CS%max_RiNo_it, & + "The maximum number of iterations that may be used to "//& + "estimate the Richardson number driven mixing.", & + units="nondim", default=50, do_not_log=just_read) + call get_param(param_file, mdl, "KD", KD_normal, & + units="m2 s-1", scale=US%m2_s_to_Z2_T, default=0.0, do_not_log=.true.) + kappa_0_default = max(Kd_normal, 1.0e-7*US%m2_s_to_Z2_T) + call get_param(param_file, mdl, "KD_KAPPA_SHEAR_0", CS%kappa_0, & + "The background diffusivity that is used to smooth the "//& + "density and shear profiles before solving for the "//& + "diffusivities. The default is the greater of KD and 1e-7 m2 s-1.", & + units="m2 s-1", default=kappa_0_default*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T, & + do_not_log=just_read) + call get_param(param_file, mdl, "KD_SEED_KAPPA_SHEAR", CS%kappa_seed, & + "A moderately large seed value of diapycnal diffusivity that is used as a "//& + "starting turbulent diffusivity in the iterations to find an energetically "//& + "constrained solution for the shear-driven diffusivity.", & + units="m2 s-1", default=1.0, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "KD_TRUNC_KAPPA_SHEAR", CS%kappa_trunc, & + "The value of shear-driven diffusivity that is considered negligible "//& + "and is rounded down to 0. The default is 1% of KD_KAPPA_SHEAR_0.", & + units="m2 s-1", default=0.01*CS%kappa_0*GV%HZ_T_to_m2_s, scale=GV%m2_s_to_HZ_T, & + do_not_log=just_read) + call get_param(param_file, mdl, "FRI_CURVATURE", CS%FRi_curvature, & + "The nondimensional curvature of the function of the "//& + "Richardson number in the kappa source term in the "//& + "Jackson et al. scheme.", units="nondim", default=-0.97, do_not_log=just_read) + call get_param(param_file, mdl, "TKE_N_DECAY_CONST", CS%C_N, & + "The coefficient for the decay of TKE due to "//& + "stratification (i.e. proportional to N*tke). "//& + "The values found by Jackson et al. are 0.24-0.28.", & + units="nondim", default=0.24, do_not_log=just_read) +! call get_param(param_file, mdl, "LAYER_KAPPA_STAGGER", CS%layer_stagger, & +! default=.false., do_not_log=just_read) + call get_param(param_file, mdl, "TKE_SHEAR_DECAY_CONST", CS%C_S, & + "The coefficient for the decay of TKE due to shear (i.e. "//& + "proportional to |S|*tke). The values found by Jackson "//& + "et al. are 0.14-0.12.", units="nondim", default=0.14, do_not_log=just_read) + call get_param(param_file, mdl, "KAPPA_BUOY_SCALE_COEF", CS%lambda, & + "The coefficient for the buoyancy length scale in the "//& + "kappa equation. The values found by Jackson et al. are "//& + "in the range of 0.81-0.86.", units="nondim", default=0.82, do_not_log=just_read) + call get_param(param_file, mdl, "KAPPA_N_OVER_S_SCALE_COEF2", CS%lambda2_N_S, & + "The square of the ratio of the coefficients of the "//& + "buoyancy and shear scales in the diffusivity equation, "//& + "Set this to 0 (the default) to eliminate the shear scale. "//& + "This is only used if USE_JACKSON_PARAM is true.", & + units="nondim", default=0.0, do_not_log=just_read) + call get_param(param_file, mdl, "KAPPA_SHEAR_TOL_ERR", CS%kappa_tol_err, & + "The fractional error in kappa that is tolerated. "//& + "Iteration stops when changes between subsequent "//& + "iterations are smaller than this everywhere in a "//& + "column. The peak diffusivities usually converge most "//& + "rapidly, and have much smaller errors than this.", & + units="nondim", default=0.1, do_not_log=just_read) + call get_param(param_file, mdl, "TKE_BACKGROUND", CS%TKE_bg, & + "A background level of TKE used in the first iteration "//& + "of the kappa equation. TKE_BACKGROUND could be 0.", & + units="m2 s-2", default=0.0, scale=US%m_to_Z**2*US%T_to_s**2) + call get_param(param_file, mdl, "KAPPA_SHEAR_ELIM_MASSLESS", CS%eliminate_massless, & + "If true, massless layers are merged with neighboring "//& + "massive layers in this calculation. The default is "//& + "true and I can think of no good reason why it should "//& + "be false. This is only used if USE_JACKSON_PARAM is true.", & + default=.true., do_not_log=just_read) + call get_param(param_file, mdl, "MAX_KAPPA_SHEAR_IT", CS%max_KS_it, & + "The maximum number of iterations that may be used to "//& + "estimate the time-averaged diffusivity.", & + default=13, do_not_log=just_read) + call get_param(param_file, mdl, "PRANDTL_TURB", CS%Prandtl_turb, & + "The turbulent Prandtl number applied to shear instability.", & + units="nondim", default=1.0, do_not_log=.true.) + call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & + "A negligibly small velocity magnitude below which velocity components are set "//& + "to 0. A reasonable value might be 1e-30 m/s, which is less than an "//& + "Angstrom divided by the age of the universe.", & + units="m s-1", default=0.0, scale=US%m_s_to_L_T, do_not_log=just_read) + call get_param(param_file, mdl, "KAPPA_SHEAR_MAX_KAP_SRC_CHG", CS%kappa_src_max_chg, & + "The maximum permitted increase in the kappa source within an iteration relative "//& + "to the local source; this must be greater than 1. The lower limit for the "//& + "permitted fractional decrease is (1 - 0.5/kappa_src_max_chg). These limits "//& + "could perhaps be made dynamic with an improved iterative solver.", & + default=10.0, units="nondim", do_not_log=just_read) + + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true., do_not_log=just_read) + call get_param(param_file, mdl, "DEBUG_KAPPA_SHEAR", debug_shear, & + "If true, write debugging data for the kappa-shear code.", & + default=.false., debuggingParam=.true., do_not_log=.true.) + if (debug_shear) CS%debug = .true. + call get_param(param_file, mdl, "KAPPA_SHEAR_VERTEX_PSURF_BUG", CS%psurf_bug, & + "If true, do a simple average of the cell surface pressures to get a pressure "//& + "at the corner if VERTEX_SHEAR=True. Otherwise mask out any land points in "//& + "the average.", default=.false., do_not_log=(just_read .or. (.not.CS%KS_at_vertex))) + + call get_param(param_file, mdl, "KAPPA_SHEAR_ITER_BUG", CS%dKdQ_iteration_bug, & + "If true, use an older, dimensionally inconsistent estimate of the "//& + "derivative of diffusivity with energy in the Newton's method iteration. "//& + "The bug causes undercorrections when dz > 1 m.", default=.false., do_not_log=just_read) + call get_param(param_file, mdl, "KAPPA_SHEAR_ALL_LAYER_TKE_BUG", CS%all_layer_TKE_bug, & + "If true, report back the latest estimate of TKE instead of the time average "//& + "TKE when there is mass in all layers. Otherwise always report the time "//& + "averaged TKE, as is currently done when there are some massless layers.", & + default=.false., do_not_log=just_read) + call get_param(param_file, mdl, "USE_RESTRICTIVE_TOLERANCE_CHECK", CS%restrictive_tolerance_check, & + "If true, uses the more restrictive tolerance check to determine if a timestep "//& + "is acceptable for the KS_it outer iteration loop. False uses the original less "//& + "restrictive check.", default=.false., do_not_log=just_read) +! id_clock_KQ = cpu_clock_id('Ocean KS kappa_shear', grain=CLOCK_ROUTINE) +! id_clock_avg = cpu_clock_id('Ocean KS avg', grain=CLOCK_ROUTINE) +! id_clock_project = cpu_clock_id('Ocean KS project', grain=CLOCK_ROUTINE) +! id_clock_setup = cpu_clock_id('Ocean KS setup', grain=CLOCK_ROUTINE) + + CS%nkml = 1 + if (GV%nkml>0) then + call get_param(param_file, mdl, "KAPPA_SHEAR_MERGE_ML",merge_mixedlayer, & + "If true, combine the mixed layers together before solving the "//& + "kappa-shear equations.", default=.true., do_not_log=just_read) + if (merge_mixedlayer) CS%nkml = GV%nkml + endif + +! Forego remainder of initialization if not using this scheme + if (.not. kappa_shear_init) return + + CS%diag => diag + + CS%id_Kd_shear = register_diag_field('ocean_model','Kd_shear', diag%axesTi, Time, & + 'Shear-driven Diapycnal Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + CS%id_TKE = register_diag_field('ocean_model','TKE_shear', diag%axesTi, Time, & + 'Shear-driven Turbulent Kinetic Energy', 'm2 s-2', conversion=US%Z_to_m**2*US%s_to_T**2) + +end function kappa_shear_init + +!> This function indicates to other modules whether the Jackson et al shear mixing +!! parameterization will be used without needing to duplicate the log entry. +logical function kappa_shear_is_used(param_file) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + + ! Local variables + character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. + ! This function reads the parameter "USE_JACKSON_PARAM" and returns its value. + + call get_param(param_file, mdl, "USE_JACKSON_PARAM", kappa_shear_is_used, & + default=.false., do_not_log=.true.) +end function kappa_shear_is_used + +!> This function indicates to other modules whether the Jackson et al shear mixing parameterization +!! will be used at the vertices without needing to duplicate the log entry. It returns false if +!! the Jackson et al scheme is not used or if it is used via calculations at the tracer points. +logical function kappa_shear_at_vertex(param_file) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + + ! Local variables + character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. + logical :: do_kappa_shear + ! This function returns true only if the parameters "USE_JACKSON_PARAM" and "VERTEX_SHEAR" are both true. + + kappa_shear_at_vertex = .false. + + call get_param(param_file, mdl, "USE_JACKSON_PARAM", do_kappa_shear, & + default=.false., do_not_log=.true.) + if (do_Kappa_Shear) & + call get_param(param_file, mdl, "VERTEX_SHEAR", kappa_shear_at_vertex, & + "If true, do the calculations of the shear-driven mixing "//& + "at the cell vertices (i.e., the vorticity points).", & + default=.false., do_not_log=.true.) + +end function kappa_shear_at_vertex + +!> \namespace mom_kappa_shear +!! +!! By Laura Jackson and Robert Hallberg, 2006-2008 +!! +!! This file contains the subroutines that determine the diapycnal +!! diffusivity driven by resolved shears, as specified by the +!! parameterizations described in Jackson and Hallberg (JPO, 2008). +!! +!! The technique by which the 6 equations (for kappa, TKE, u, v, T, +!! and S) are solved simultaneously has been dramatically revised +!! from the previous version. The previous version was not converging +!! in some cases, especially near the surface mixed layer, while the +!! revised version does. The revised version solves for kappa and +!! TKE with shear and stratification fixed, then marches the density +!! and velocities forward with an adaptive (and aggressive) time step +!! in a predictor-corrector-corrector emulation of a trapezoidal +!! scheme. Run-time-settable parameters determine the tolerance to +!! which the kappa and TKE equations are solved and the minimum time +!! step that can be taken. + +end module MOM_kappa_shear diff --git a/parameterizations/vertical/MOM_opacity.F90 b/parameterizations/vertical/MOM_opacity.F90 new file mode 100644 index 0000000000..61a7a0c7d0 --- /dev/null +++ b/parameterizations/vertical/MOM_opacity.F90 @@ -0,0 +1,1182 @@ +!> Routines used to calculate the opacity of the ocean. +module MOM_opacity + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_ptr, post_data +use MOM_diag_mediator, only : query_averaging_enabled, register_diag_field +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_string_functions, only : uppercase +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public set_opacity, opacity_init, opacity_end, opacity_manizza, opacity_morel +public extract_optics_slice, extract_optics_fields, optics_nbands +public absorbRemainingSW, sumSWoverBands + +!> This type is used to store information about ocean optical properties +type, public :: optics_type + integer :: nbands !< The number of penetrating bands of SW radiation + + real, allocatable :: opacity_band(:,:,:,:) !< SW optical depth per unit thickness [Z-1 ~> m-1] + !! The number of radiation bands is most rapidly varying (first) index. + + real, allocatable :: sw_pen_band(:,:,:) !< shortwave radiation [Q R Z T-1 ~> W m-2] + !! at the surface in each of the nbands bands that penetrates beyond the surface. + !! The most rapidly varying dimension is the band. + + real, allocatable :: min_wavelength_band(:) + !< The minimum wavelength in each band of penetrating shortwave radiation [nm] + real, allocatable :: max_wavelength_band(:) + !< The maximum wavelength in each band of penetrating shortwave radiation [nm] + + real :: PenSW_flux_absorb !< A heat flux that is small enough to be completely absorbed in the next + !! sufficiently thick layer [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + real :: PenSW_absorb_Invlen !< The inverse of the thickness that is used to absorb the remaining + !! shortwave heat flux when it drops below PEN_SW_FLUX_ABSORB [H ~> m or kg m-2]. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the optics + !! calculations. Values below 20190101 recover the answers from the + !! end of 2018, while higher values use updated and more robust + !! forms of the same expressions. + +end type optics_type + +!> The control structure with parameters for the MOM_opacity module +type, public :: opacity_CS ; private + logical :: var_pen_sw !< If true, use one of the CHL_A schemes (specified by OPACITY_SCHEME) to + !! determine the e-folding depth of incoming shortwave radiation. + integer :: opacity_scheme !< An integer indicating which scheme should be used to translate + !! water properties into the opacity (i.e., the e-folding depth) and + !! (perhaps) the number of bands of penetrating shortwave radiation to use. + real :: pen_sw_scale !< The vertical absorption e-folding depth of the + !! penetrating shortwave radiation [Z ~> m]. + real :: pen_sw_scale_2nd !< The vertical absorption e-folding depth of the + !! (2nd) penetrating shortwave radiation [Z ~> m]. + real :: SW_1ST_EXP_RATIO !< Ratio for 1st exp decay in Two Exp decay opacity [nondim] + real :: pen_sw_frac !< The fraction of shortwave radiation that is + !! penetrating with a constant e-folding approach [nondim] + real :: blue_frac !< The fraction of the penetrating shortwave + !! radiation that is in the blue band [nondim]. + real :: opacity_land_value !< The value to use for opacity over land [Z-1 ~> m-1]. + !! The default is 10 m-1 - a value for muddy water. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + logical :: warning_issued !< A flag that is used to avoid repetitive warnings. + + !>@{ Diagnostic IDs + integer :: id_sw_pen = -1, id_sw_vis_pen = -1 + integer, allocatable :: id_opacity(:) + !>@} +end type opacity_CS + +!>@{ Coded integers to specify the opacity scheme +integer, parameter :: NO_SCHEME = 0, MANIZZA_05 = 1, MOREL_88 = 2, SINGLE_EXP = 3, DOUBLE_EXP = 4 +!>@} + +character*(10), parameter :: MANIZZA_05_STRING = "MANIZZA_05" !< String to specify the opacity scheme +character*(10), parameter :: MOREL_88_STRING = "MOREL_88" !< String to specify the opacity scheme +character*(10), parameter :: SINGLE_EXP_STRING = "SINGLE_EXP" !< String to specify the opacity scheme +character*(10), parameter :: DOUBLE_EXP_STRING = "DOUBLE_EXP" !< String to specify the opacity scheme + +contains + +!> This sets the opacity of sea water based based on one of several different schemes. +subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_nir_dif, & + G, GV, US, CS, chl_2d, chl_3d) + type(optics_type), intent(inout) :: optics !< An optics structure that has values + !! set based on the opacities. + real, dimension(:,:), pointer :: sw_total !< Total shortwave flux into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_vis_dir !< Visible, direct shortwave into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_vis_dif !< Visible, diffuse shortwave into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_nir_dir !< Near-IR, direct shortwave into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_nir_dif !< Near-IR, diffuse shortwave into the ocean [Q R Z T-1 ~> W m-2] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(opacity_CS) :: CS !< The control structure earlier set up by opacity_init. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: chl_2d !< Vertically uniform chlorophyll-A concentrations [mg m-3] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: chl_3d !< The chlorophyll-A concentrations of each layer [mg m-3] + + ! Local variables + integer :: i, j, k, n, is, ie, js, je, nz + real :: inv_sw_pen_scale ! The inverse of the e-folding scale [Z-1 ~> m-1]. + real :: Inv_nbands ! The inverse of the number of bands of penetrating + ! shortwave radiation [nondim] + real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! A 3-d temporary array for diagnosing opacity [Z-1 ~> m-1] + real :: Pen_SW_tot(SZI_(G),SZJ_(G)) ! The penetrating shortwave radiation + ! summed across all bands [Q R Z T-1 ~> W m-2]. + real :: op_diag_len ! A tiny lengthscale [Z ~> m] used to remap diagnostics of opacity + ! from op to 1/op_diag_len * tanh(op * op_diag_len) + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (present(chl_2d) .or. present(chl_3d)) then + ! The optical properties are based on chlorophyll concentrations. + call opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_nir_dif, & + G, GV, US, CS, chl_2d, chl_3d) + else ! Use sw e-folding scale set by MOM_input + if (optics%nbands <= 1) then ; Inv_nbands = 1.0 + else ; Inv_nbands = 1.0 / real(optics%nbands) ; endif + + ! Make sure there is no division by 0. + inv_sw_pen_scale = 1.0 / max(CS%pen_sw_scale, 0.1*GV%Angstrom_Z, & + GV%dZ_subroundoff) + if ( CS%Opacity_scheme == DOUBLE_EXP ) then + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do i=is,ie + optics%opacity_band(1,i,j,k) = inv_sw_pen_scale + optics%opacity_band(2,i,j,k) = 1.0 / max(CS%pen_sw_scale_2nd, & + 0.1*GV%Angstrom_Z, GV%dZ_subroundoff) + enddo ; enddo ; enddo + if (.not.associated(sw_total) .or. (CS%pen_SW_scale <= 0.0)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie ; do n=1,optics%nbands + optics%sw_pen_band(n,i,j) = 0.0 + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + optics%sw_pen_band(1,i,j) = (CS%SW_1st_EXP_RATIO) * sw_total(i,j) + optics%sw_pen_band(2,i,j) = (1.-CS%SW_1st_EXP_RATIO) * sw_total(i,j) + enddo ; enddo + endif + else + do k=1,nz ; do j=js,je ; do i=is,ie ; do n=1,optics%nbands + optics%opacity_band(n,i,j,k) = inv_sw_pen_scale + enddo ; enddo ; enddo ; enddo + if (.not.associated(sw_total) .or. (CS%pen_SW_scale <= 0.0)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie ; do n=1,optics%nbands + optics%sw_pen_band(n,i,j) = 0.0 + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie ; do n=1,optics%nbands + optics%sw_pen_band(n,i,j) = CS%pen_SW_frac * Inv_nbands * sw_total(i,j) + enddo ; enddo ; enddo + endif + endif + endif + + if (query_averaging_enabled(CS%diag)) then + if (CS%id_sw_pen > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + Pen_SW_tot(i,j) = 0.0 + do n=1,optics%nbands + Pen_SW_tot(i,j) = Pen_SW_tot(i,j) + optics%sw_pen_band(n,i,j) + enddo + enddo ; enddo + call post_data(CS%id_sw_pen, Pen_SW_tot, CS%diag) + endif + if (CS%id_sw_vis_pen > 0) then + if (CS%opacity_scheme == MANIZZA_05) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + Pen_SW_tot(i,j) = 0.0 + do n=1,min(optics%nbands,2) + Pen_SW_tot(i,j) = Pen_SW_tot(i,j) + optics%sw_pen_band(n,i,j) + enddo + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + Pen_SW_tot(i,j) = 0.0 + do n=1,optics%nbands + Pen_SW_tot(i,j) = Pen_SW_tot(i,j) + optics%sw_pen_band(n,i,j) + enddo + enddo ; enddo + endif + call post_data(CS%id_sw_vis_pen, Pen_SW_tot, CS%diag) + endif + do n=1,optics%nbands ; if (CS%id_opacity(n) > 0) then + op_diag_len = 1.0e-10*US%m_to_Z ! A minimal extinction depth to constrain the range of opacity [Z ~> m] + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do i=is,ie + ! Remap opacity (op) to 1/L * tanh(op * L) where L is one Angstrom. + ! This gives a nearly identical value when op << 1/L but allows one to + ! record the values even at reduced precision when opacity is huge (i.e. opaque). + tmp(i,j,k) = tanh(op_diag_len * optics%opacity_band(n,i,j,k)) / op_diag_len + enddo ; enddo ; enddo + call post_data(CS%id_opacity(n), tmp, CS%diag) + endif ; enddo + endif + +end subroutine set_opacity + + +!> This sets the "blue" band opacity based on chlorophyll A concentrations +!! The red portion is lumped into the net heating at the surface. +subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_nir_dif, & + G, GV, US, CS, chl_2d, chl_3d) + type(optics_type), intent(inout) :: optics !< An optics structure that has values + !! set based on the opacities. + real, dimension(:,:), pointer :: sw_total !< Total shortwave flux into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_vis_dir !< Visible, direct shortwave into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_vis_dif !< Visible, diffuse shortwave into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_nir_dir !< Near-IR, direct shortwave into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_nir_dif !< Near-IR, diffuse shortwave into the ocean [Q R Z T-1 ~> W m-2] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(opacity_CS) :: CS !< The control structure. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: chl_2d !< Vertically uniform chlorophyll-A concentrations [mg m-3] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: chl_3d !< A 3-d field of chlorophyll-A concentrations [mg m-3] + + real :: chl_data(SZI_(G),SZJ_(G)) ! The chlorophyll A concentrations in a layer [mg m-3]. + real :: Inv_nbands ! The inverse of the number of bands of penetrating + ! shortwave radiation [nondim] + real :: Inv_nbands_nir ! The inverse of the number of bands of penetrating + ! near-infrared radiation [nondim] + real :: SW_pen_tot ! The sum across the bands of the penetrating + ! shortwave radiation [Q R Z T-1 ~> W m-2]. + real :: SW_vis_tot ! The sum across the visible bands of shortwave + ! radiation [Q R Z T-1 ~> W m-2]. + real :: SW_nir_tot ! The sum across the near infrared bands of shortwave + ! radiation [Q R Z T-1 ~> W m-2]. + character(len=128) :: mesg + integer :: i, j, k, n, is, ie, js, je, nz, nbands + logical :: multiband_vis_input, multiband_nir_input, total_sw_input + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + +! In this model, the Morel (modified) and Manizza (modified) schemes +! use the "blue" band in the parameterizations to determine the e-folding +! depth of the incoming shortwave attenuation. The red portion is lumped +! into the net heating at the surface. +! +! Morel, A., Optical modeling of the upper ocean in relation to its biogenous +! matter content (case-i waters)., J. Geo. Res., {93}, 10,749--10,768, 1988. +! +! Manizza, M., C. L. Quere, A. Watson, and E. T. Buitenhuis, Bio-optical +! feedbacks among phytoplankton, upper ocean physics and sea-ice in a +! global model, Geophys. Res. Let., , L05,603, 2005. + + nbands = optics%nbands + + if (nbands <= 1) then ; Inv_nbands = 1.0 + else ; Inv_nbands = 1.0 / real(nbands) ; endif + + if (nbands <= 2) then ; Inv_nbands_nir = 0.0 + else ; Inv_nbands_nir = 1.0 / real(nbands - 2.0) ; endif + + if (.not.(associated(sw_total) .or. (associated(sw_vis_dir) .and. associated(sw_vis_dif) .and. & + associated(sw_nir_dir) .and. associated(sw_nir_dif)) )) then + if (.not.CS%warning_issued) then + call MOM_error(WARNING, & + "opacity_from_chl called without any shortwave flux arrays allocated.\n"//& + "Consider setting PEN_SW_NBANDS = 0 if no shortwave fluxes are being used.") + endif + CS%warning_issued = .true. + endif + + multiband_vis_input = (associated(sw_vis_dir) .and. associated(sw_vis_dif)) + multiband_nir_input = (associated(sw_nir_dir) .and. associated(sw_nir_dif)) + total_sw_input = associated(sw_total) + + chl_data(:,:) = 0.0 + 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.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) + call MOM_error(FATAL, "MOM_opacity opacity_from_chl: "//trim(mesg)) + endif + enddo ; enddo ; enddo + 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.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) + call MOM_error(FATAL, "MOM_opacity opacity_from_chl: "//trim(mesg)) + endif + enddo ; enddo + else + call MOM_error(FATAL, "Either chl_2d or chl_3d must be present in a call to opacity_form_chl.") + endif + + select case (CS%opacity_scheme) + case (MANIZZA_05) + !$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.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 + ! Follow Manizza 05 in assuming that 42% of SW is visible. + SW_vis_tot = 0.42 * sw_total(i,j) + endif + if (multiband_nir_input) then + SW_nir_tot = sw_nir_dir(i,j) + sw_nir_dif(i,j) + elseif (total_sw_input) then + SW_nir_tot = sw_total(i,j) - SW_vis_tot + endif + endif + + ! Band 1 is Manizza blue. + optics%sw_pen_band(1,i,j) = CS%blue_frac*sw_vis_tot + ! Band 2 (if used) is Manizza red. + if (nbands > 1) & + optics%sw_pen_band(2,i,j) = (1.0-CS%blue_frac)*sw_vis_tot + ! All remaining bands are NIR, for lack of something better to do. + do n=3,nbands + optics%sw_pen_band(n,i,j) = Inv_nbands_nir * sw_nir_tot + enddo + enddo ; enddo + case (MOREL_88) + !$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.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 + SW_pen_tot = SW_pen_frac_morel(chl_data(i,j)) * 0.5*sw_total(i,j) + endif + endif + + do n=1,nbands + optics%sw_pen_band(n,i,j) = Inv_nbands*sw_pen_tot + enddo + enddo ; enddo + case default + call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.") + end select + + !$OMP parallel do default(shared) firstprivate(chl_data) + do k=1,nz + if (present(chl_3d)) then + do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_3d(i,j,k) ; enddo ; enddo + endif + + select case (CS%opacity_scheme) + case (MANIZZA_05) + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) <= 0.5) then + do n=1,optics%nbands + optics%opacity_band(n,i,j,k) = CS%opacity_land_value + enddo + else + ! Band 1 is Manizza blue. + optics%opacity_band(1,i,j,k) = (0.0232 + 0.074*chl_data(i,j)**0.674) * US%Z_to_m + if (nbands >= 2) & ! Band 2 is Manizza red. + optics%opacity_band(2,i,j,k) = (0.225 + 0.037*chl_data(i,j)**0.629) * US%Z_to_m + ! All remaining bands are NIR, for lack of something better to do. + do n=3,nbands ; optics%opacity_band(n,i,j,k) = 2.86*US%Z_to_m ; enddo + endif + enddo ; enddo + 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.0) & + optics%opacity_band(1,i,j,k) = US%Z_to_m * opacity_morel(chl_data(i,j)) + + do n=2,optics%nbands + optics%opacity_band(n,i,j,k) = optics%opacity_band(1,i,j,k) + enddo + enddo ; enddo + + case default + call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.") + end select + enddo + + +end subroutine opacity_from_chl + +!> This sets the blue-wavelength opacity according to the scheme proposed by +!! Morel and Antoine (1994). +function opacity_morel(chl_data) + real, intent(in) :: chl_data !< The chlorophyll-A concentration in [mg m-3] + real :: opacity_morel !< The returned opacity [m-1] + + ! The following are coefficients for the optical model taken from Morel and + ! Antoine (1994). These coefficients represent a non uniform distribution of + ! chlorophyll-a through the water column. Other approaches may be more + ! appropriate when using an interactive ecosystem model that predicts + ! three-dimensional chl-a values. + real, dimension(6), parameter :: & + Z2_coef = (/7.925, -6.644, 3.662, -1.815, -0.218, 0.502/) ! Extinction length coefficients [m] + real :: Chl, Chl2 ! The log10 of chl_data (in mg m-3), and Chl^2 [nondim] + + Chl = log10(min(max(chl_data,0.02),60.0)) ; Chl2 = Chl*Chl + opacity_morel = 1.0 / ( (Z2_coef(1) + Z2_coef(2)*Chl) + Chl2 * & + ((Z2_coef(3) + Chl*Z2_coef(4)) + Chl2*(Z2_coef(5) + Chl*Z2_coef(6))) ) +end function + +!> This sets the penetrating shortwave fraction according to the scheme proposed by +!! Morel and Antoine (1994). +function SW_pen_frac_morel(chl_data) + real, intent(in) :: chl_data !< The chlorophyll-A concentration [mg m-3] + real :: SW_pen_frac_morel !< The returned penetrating shortwave fraction [nondim] + + ! The following are coefficients for the optical model taken from Morel and + ! Antoine (1994). These coefficients represent a non uniform distribution of + ! chlorophyll-a through the water column. Other approaches may be more + ! appropriate when using an interactive ecosystem model that predicts + ! three-dimensional chl-a values. + real :: Chl, Chl2 ! The log10 of chl_data in mg m-3, and Chl^2 [nondim] + real, dimension(6), parameter :: & + V1_coef = (/0.321, 0.008, 0.132, 0.038, -0.017, -0.007/) ! Penetrating fraction coefficients [nondim] + + Chl = log10(min(max(chl_data,0.02),60.0)) ; Chl2 = Chl*Chl + SW_pen_frac_morel = 1.0 - ( (V1_coef(1) + V1_coef(2)*Chl) + Chl2 * & + ((V1_coef(3) + Chl*V1_coef(4)) + Chl2*(V1_coef(5) + Chl*V1_coef(6))) ) +end function SW_pen_frac_morel + +!> This sets the blue-wavelength opacity according to the scheme proposed by +!! Manizza, M. et al, 2005. +function opacity_manizza(chl_data) + real, intent(in) :: chl_data !< The chlorophyll-A concentration [mg m-3] + real :: opacity_manizza !< The returned opacity [m-1] +! This sets the blue-wavelength opacity according to the scheme proposed by Manizza, M. et al, 2005. + + opacity_manizza = 0.0232 + 0.074*chl_data**0.674 +end function + +!> This subroutine returns a 2-d slice at constant j of fields from an optics_type, with the potential +!! for rescaling these fields. +subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_top, penSW_scale, SpV_avg) + type(optics_type), intent(in) :: optics !< An optics structure that has values of opacities + !! and shortwave fluxes. + integer, intent(in) :: j !< j-index to extract + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(max(optics%nbands,1),SZI_(G),SZK_(GV)), & + optional, intent(out) :: opacity !< The opacity in each band, i-point, and layer [Z-1 ~> m-1], + !! but with units that can be altered by opacity_scale + !! and the presence of SpV_avg to change this to other + !! units like [H-1 ~> m-1 or m2 kg-1] + real, optional, intent(in) :: opacity_scale !< A factor by which to rescale the opacity [nondim] or + !! [Z H-1 ~> 1 or m3 kg-1] + real, dimension(max(optics%nbands,1),SZI_(G)), & + optional, intent(out) :: penSW_top !< The shortwave radiation [Q R Z T-1 ~> W m-2] + !! at the surface in each of the nbands bands + !! that penetrates beyond the surface skin layer. + real, optional, intent(in) :: penSW_scale !< A factor by which to rescale the shortwave flux [nondim] + !! or other units. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: SpV_avg !< The layer-averaged specific volume [R-1 ~> m3 kg-1] + !! that is used along with opacity_scale in non-Boussinesq + !! cases to change the opacity from distance based units to + !! mass-based units + + ! Local variables + real :: scale_opacity ! A rescaling factor for opacity [nondim], or the same units as opacity_scale. + real :: scale_penSW ! A rescaling factor for the penetrating shortwave radiation [nondim] or the + ! same units as penSW_scale + integer :: i, is, ie, k, nz, n + is = G%isc ; ie = G%iec ; nz = GV%ke + + scale_opacity = 1.0 ; if (present(opacity_scale)) scale_opacity = opacity_scale + scale_penSW = 1.0 ; if (present(penSW_scale)) scale_penSW = penSW_scale + + if (present(opacity)) then + if (present(SpV_avg)) then + do k=1,nz ; do i=is,ie ; do n=1,optics%nbands + opacity(n,i,k) = (scale_opacity * SpV_avg(i,j,k)) * optics%opacity_band(n,i,j,k) + enddo ; enddo ; enddo + else + do k=1,nz ; do i=is,ie ; do n=1,optics%nbands + opacity(n,i,k) = scale_opacity * optics%opacity_band(n,i,j,k) + enddo ; enddo ; enddo + endif + endif + + if (present(penSW_top)) then ; do i=is,ie ; do n=1,optics%nbands + penSW_top(n,i) = scale_penSW * optics%sw_pen_band(n,i,j) + enddo ; enddo ; endif + +end subroutine extract_optics_slice + +!> Set arguments to fields from the optics type. +subroutine extract_optics_fields(optics, nbands) + type(optics_type), intent(in) :: optics !< An optics structure that has values of opacities + !! and shortwave fluxes. + integer, optional, intent(out) :: nbands !< The number of penetrating bands of SW radiation + + if (present(nbands)) nbands = optics%nbands + +end subroutine extract_optics_fields + +!> Return the number of bands of penetrating shortwave radiation. +function optics_nbands(optics) + type(optics_type), pointer :: optics !< An optics structure that has values of opacities + !! and shortwave fluxes. + integer :: optics_nbands !< The number of penetrating bands of SW radiation + + if (associated(optics)) then + optics_nbands = optics%nbands + else + optics_nbands = 0 + endif +end function optics_nbands + +!> Apply shortwave heating below the boundary layer (when running with the bulk mixed layer inherited +!! from GOLD) or throughout the water column. +!! +!! In addition, it causes all of the remaining SW radiation to be absorbed, provided that the total +!! water column thickness is greater than H_limit_fluxes. +!! For thinner water columns, the heating is scaled down proportionately, the assumption being that the +!! remaining heating (which is left in Pen_SW) should go into an (absent for now) ocean bottom sediment layer. +subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_limit_fluxes, & + adjustAbsorptionProfile, absorbAllSW, T, Pen_SW_bnd, & + eps, ksort, htot, Ttot, TKE, dSV_dT) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: nsw !< Number of bands of penetrating + !! shortwave radiation. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(max(1,nsw),SZI_(G),SZK_(GV)), intent(in) :: opacity_band !< Opacity in each band of penetrating + !! shortwave radiation [H-1 ~> m-1 or m2 kg-1]. + !! The indices are band, i, k. + type(optics_type), intent(in) :: optics !< An optics structure that has values of + !! opacities and shortwave fluxes. + integer, intent(in) :: j !< j-index to work on. + real, intent(in) :: dt !< Time step [T ~> s]. + real, intent(in) :: H_limit_fluxes !< If the total ocean depth is + !! less than this, they are scaled away + !! to avoid numerical instabilities + !! [H ~> m or kg m-2]. This would + !! not be necessary if a finite heat + !! capacity mud-layer were added. + logical, intent(in) :: adjustAbsorptionProfile !< If true, apply + !! heating above the layers in which it + !! should have occurred to get the + !! correct mean depth (and potential + !! energy change) of the shortwave that + !! should be absorbed by each layer. + logical, intent(in) :: absorbAllSW !< If true, apply heating above the + !! layers in which it should have occurred + !! to get the correct mean depth (and + !! potential energy change) of the + !! shortwave that should be absorbed by + !! each layer. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: T !< Layer potential/conservative + !! temperatures [C ~> degC] + real, dimension(max(1,nsw),SZI_(G)), intent(inout) :: Pen_SW_bnd !< Penetrating shortwave heating in + !! each band that hits the bottom and will + !! will be redistributed through the water + !! column [C H ~> degC m or degC kg m-2], + !! size nsw x SZI_(G). + real, dimension(SZI_(G),SZK_(GV)), optional, intent(in) :: eps !< Small thickness that must remain in + !! each layer, and which will not be + !! subject to heating [H ~> m or kg m-2] + integer, dimension(SZI_(G),SZK_(GV)), optional, intent(in) :: ksort !< Density-sorted k-indices. + real, dimension(SZI_(G)), optional, intent(in) :: htot !< Total mixed layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), optional, intent(inout) :: Ttot !< Depth integrated mixed layer + !! temperature [C H ~> degC m or degC kg m-2] + real, dimension(SZI_(G),SZK_(GV)), optional, intent(in) :: dSV_dT !< The partial derivative of specific volume + !! with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G),SZK_(GV)), optional, intent(inout) :: TKE !< The TKE sink from mixing the heating + !! throughout a layer [R Z3 T-2 ~> J m-2]. + + ! Local variables + real, dimension(SZI_(G),SZK_(GV)) :: & + T_chg_above ! A temperature change that will be applied to all the thick + ! layers above a given layer [C ~> degC]. This is only nonzero if + ! adjustAbsorptionProfile is true, in which case the net + ! change in the temperature of a layer is the sum of the + ! direct heating of that layer plus T_chg_above from all of + ! the layers below, plus any contribution from absorbing + ! radiation that hits the bottom. + real, dimension(SZI_(G)) :: & + h_heat, & ! The thickness of the water column that will be heated by + ! any remaining shortwave radiation [H ~> m or kg m-2]. + T_chg, & ! The temperature change of thick layers due to the remaining + ! shortwave radiation and contributions from T_chg_above [C ~> degC]. + Pen_SW_rem ! The sum across all wavelength bands of the penetrating shortwave + ! heating that hits the bottom and will be redistributed through + ! the water column [C H ~> degC m or degC kg m-2] + real :: SW_trans ! fraction of shortwave radiation that is not + ! absorbed in a layer [nondim] + real :: unabsorbed ! fraction of the shortwave radiation that + ! is not absorbed because the layers are too thin [nondim] + real :: Ih_limit ! inverse of the total depth at which the + ! surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] + real :: h_min_heat ! minimum thickness layer that should get heated [H ~> m or kg m-2] + real :: opt_depth ! optical depth of a layer [nondim] + real :: exp_OD ! exp(-opt_depth) [nondim] + real :: heat_bnd ! heating due to absorption in the current + ! layer by the current band, including any piece that + ! is moved upward [C H ~> degC m or degC kg m-2] + real :: SWa ! fraction of the absorbed shortwave that is + ! moved to layers above with adjustAbsorptionProfile [nondim] + real :: coSWa_frac ! The fraction of SWa that is actually moved upward [nondim] + real :: min_SW_heat ! A minimum remaining shortwave heating within a timestep that will be simply + ! absorbed in the next layer for computational efficiency, instead of + ! continuing to penetrate [C H ~> degC m or degC kg m-2]. + real :: I_Habs ! The inverse of the absorption length for a minimal flux [H-1 ~> m-1 or m2 kg-1] + real :: epsilon ! A small thickness that must remain in each + ! layer, and which will not be subject to heating [H ~> m or kg m-2] + real :: g_Hconv2 ! A conversion factor for use in the TKE calculation + ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. + logical :: SW_Remains ! If true, some column has shortwave radiation that + ! was not entirely absorbed. + logical :: TKE_calc ! If true, calculate the implications to the + ! TKE budget of the shortwave heating. + real :: C1_6, C1_60 ! Rational fractions [nondim] + integer :: is, ie, nz, i, k, ks, n + + if (nsw < 1) return + + SW_Remains = .false. + min_SW_heat = optics%PenSW_flux_absorb * dt + I_Habs = optics%PenSW_absorb_Invlen + + h_min_heat = 2.0*GV%Angstrom_H + GV%H_subroundoff + is = G%isc ; ie = G%iec ; nz = GV%ke + C1_6 = 1.0 / 6.0 ; C1_60 = 1.0 / 60.0 + + TKE_calc = (present(TKE) .and. present(dSV_dT)) + + if (optics%answer_date < 20190101) then + g_Hconv2 = (US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ) * GV%H_to_RZ + else + g_Hconv2 = US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ**2 + endif + + h_heat(:) = 0.0 + if (present(htot)) then ; do i=is,ie ; h_heat(i) = htot(i) ; enddo ; endif + + ! Apply penetrating SW radiation to remaining parts of layers. + ! Excessively thin layers are not heated to avoid runaway temps. + do ks=1,nz ; do i=is,ie + k = ks + if (present(ksort)) then + if (ksort(i,ks) <= 0) cycle + k = ksort(i,ks) + endif + epsilon = 0.0 ; if (present(eps)) epsilon = eps(i,k) + + T_chg_above(i,k) = 0.0 + + if (h(i,k) > 1.5*epsilon) then + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + ! SW_trans is the SW that is transmitted THROUGH the layer + opt_depth = h(i,k) * opacity_band(n,i,k) + exp_OD = exp(-opt_depth) + SW_trans = exp_OD + + ! Heating at a very small rate can be absorbed by a sufficiently thick layer or several + ! thin layers without further penetration. + if (optics%answer_date < 20190101) then + if (nsw*Pen_SW_bnd(n,i)*SW_trans < min_SW_heat*min(1.0, I_Habs*h(i,k)) ) SW_trans = 0.0 + elseif ((nsw*Pen_SW_bnd(n,i)*SW_trans < min_SW_heat) .and. (h(i,k) > h_min_heat)) then + if (nsw*Pen_SW_bnd(n,i) <= min_SW_heat * (I_Habs*(h(i,k) - h_min_heat))) then + SW_trans = 0.0 + else + SW_trans = min(SW_trans, & + 1.0 - (min_SW_heat*(I_Habs*(h(i,k) - h_min_heat))) / (nsw*Pen_SW_bnd(n,i))) + endif + endif + + Heat_bnd = Pen_SW_bnd(n,i) * (1.0 - SW_trans) + if (adjustAbsorptionProfile .and. (h_heat(i) > 0.0)) then + ! In this case, a fraction of the heating is applied to the + ! overlying water so that the mean pressure at which the shortwave + ! heating occurs is exactly what it would have been with a careful + ! pressure-weighted averaging of the exponential heating profile, + ! hence there should be no TKE budget requirements due to this + ! layer. Very clever, but this is also limited so that the + ! water above is not heated at a faster rate than the layer + ! actually being heated, i.e., SWA <= h_heat / (h_heat + h(i,k)) + ! and takes the energetics of the rest of the heating into account. + ! (-RWH, ~7 years later.) + if (opt_depth > 1e-5) then + SWa = ((opt_depth + (opt_depth + 2.0)*exp_OD) - 2.0) / & + ((opt_depth + opacity_band(n,i,k) * h_heat(i)) * & + (1.0 - exp_OD)) + else + ! Use Taylor series expansion of the expression above for a + ! more accurate form with very small layer optical depths. + SWa = h(i,k) * (opt_depth * (1.0 - opt_depth)) / & + ((h_heat(i) + h(i,k)) * (6.0 - 3.0*opt_depth)) + endif + coSWa_frac = 0.0 + if (SWa*(h_heat(i) + h(i,k)) > h_heat(i)) then + coSWa_frac = (SWa*(h_heat(i) + h(i,k)) - h_heat(i) ) / & + (SWa*(h_heat(i) + h(i,k))) + SWa = h_heat(i) / (h_heat(i) + h(i,k)) + endif + + T_chg_above(i,k) = T_chg_above(i,k) + (SWa * Heat_bnd) / h_heat(i) + T(i,k) = T(i,k) + ((1.0 - SWa) * Heat_bnd) / h(i,k) + else + coSWa_frac = 1.0 + T(i,k) = T(i,k) + Pen_SW_bnd(n,i) * (1.0 - SW_trans) / h(i,k) + endif + + if (TKE_calc) then + if (opt_depth > 1e-2) then + TKE(i,k) = TKE(i,k) - coSWa_frac*Heat_bnd*dSV_dT(i,k)* & + (0.5*h(i,k)*g_Hconv2) * & + (opt_depth*(1.0+exp_OD) - 2.0*(1.0-exp_OD)) / (opt_depth*(1.0-exp_OD)) + else + ! Use Taylor series-derived approximation to the above expression + ! that is well behaved and more accurate when opt_depth is small. + TKE(i,k) = TKE(i,k) - coSWa_frac*Heat_bnd*dSV_dT(i,k)* & + (0.5*h(i,k)*g_Hconv2) * & + (C1_6*opt_depth * (1.0 - C1_60*opt_depth**2)) + endif + endif + + Pen_SW_bnd(n,i) = Pen_SW_bnd(n,i) * SW_trans + endif ; enddo + endif + + ! Add to the accumulated thickness above that could be heated. + ! Only layers greater than h_min_heat thick should get heated. + if (h(i,k) >= 2.0*h_min_heat) then + h_heat(i) = h_heat(i) + h(i,k) + elseif (h(i,k) > h_min_heat) then + h_heat(i) = h_heat(i) + (2.0*h(i,k) - 2.0*h_min_heat) + endif + enddo ; enddo ! i & k loops + +! if (.not.absorbAllSW .and. .not.adjustAbsorptionProfile) return + + ! Unless modified, there is no temperature change due to fluxes from the bottom. + do i=is,ie ; T_chg(i) = 0.0 ; enddo + + if (absorbAllSW) then + ! If there is still shortwave radiation at this point, it could go into + ! the bottom (with a bottom mud model), or it could be redistributed back + ! through the water column. + do i=is,ie + Pen_SW_rem(i) = Pen_SW_bnd(1,i) + do n=2,nsw ; Pen_SW_rem(i) = Pen_SW_rem(i) + Pen_SW_bnd(n,i) ; enddo + enddo + do i=is,ie ; if (Pen_SW_rem(i) > 0.0) SW_Remains = .true. ; enddo + + Ih_limit = 1.0 / H_limit_fluxes + do i=is,ie ; if ((Pen_SW_rem(i) > 0.0) .and. (h_heat(i) > 0.0)) then + if (h_heat(i)*Ih_limit >= 1.0) then + T_chg(i) = Pen_SW_rem(i) / h_heat(i) ; unabsorbed = 0.0 + else + T_chg(i) = Pen_SW_rem(i) * Ih_limit + unabsorbed = 1.0 - h_heat(i)*Ih_limit + endif + do n=1,nsw ; Pen_SW_bnd(n,i) = unabsorbed * Pen_SW_bnd(n,i) ; enddo + endif ; enddo + endif ! absorbAllSW + + if (absorbAllSW .or. adjustAbsorptionProfile) then + do ks=nz,1,-1 ; do i=is,ie + k = ks + if (present(ksort)) then + if (ksort(i,ks) <= 0) cycle + k = ksort(i,ks) + endif + + if (T_chg(i) > 0.0) then + ! Only layers greater than h_min_heat thick should get heated. + if (h(i,k) >= 2.0*h_min_heat) then ; T(i,k) = T(i,k) + T_chg(i) + elseif (h(i,k) > h_min_heat) then + T(i,k) = T(i,k) + T_chg(i) * (2.0 - 2.0*h_min_heat/h(i,k)) + endif + endif + ! Increase the heating for layers above. + T_chg(i) = T_chg(i) + T_chg_above(i,k) + enddo ; enddo + if (present(htot) .and. present(Ttot)) then + do i=is,ie ; Ttot(i) = Ttot(i) + T_chg(i) * htot(i) ; enddo + endif + endif ! absorbAllSW .or. adjustAbsorptionProfile + +end subroutine absorbRemainingSW + + +!> This subroutine calculates the total shortwave heat flux integrated over +!! bands as a function of depth. This routine is only called for computing +!! buoyancy fluxes for use in KPP. This routine does not update the state. +subroutine sumSWoverBands(G, GV, US, h, dz, nsw, optics, j, dt, & + H_limit_fluxes, absorbAllSW, iPen_SW_bnd, netPen) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dz !< Layer vertical extent [Z ~> m]. + integer, intent(in) :: nsw !< The number of bands of penetrating shortwave + !! radiation, perhaps from optics_nbands(optics), + type(optics_type), intent(in) :: optics !< An optics structure that has values + !! set based on the opacities. + integer, intent(in) :: j !< j-index to work on. + real, intent(in) :: dt !< Time step [T ~> s]. + real, intent(in) :: H_limit_fluxes !< the total depth at which the + !! surface fluxes start to be limited to avoid + !! excessive heating of a thin ocean [H ~> m or kg m-2] + logical, intent(in) :: absorbAllSW !< If true, ensure that all shortwave + !! radiation is absorbed in the ocean water column. + real, dimension(max(nsw,1),SZI_(G)), intent(in) :: iPen_SW_bnd !< The incident penetrating shortwave + !! in each band at the sea surface; size nsw x SZI_(G) + !! [C H ~> degC m or degC kg m-2]. + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(inout) :: netPen !< Net penetrating shortwave heat flux at each + !! interface, summed across all bands + !! [C H ~> degC m or degC kg m-2]. + ! Local variables + real :: h_heat(SZI_(G)) ! thickness of the water column that receives + ! remaining shortwave radiation [H ~> m or kg m-2]. + real :: Pen_SW_rem(SZI_(G)) ! sum across all wavelength bands of the + ! penetrating shortwave heating that hits the bottom + ! and will be redistributed through the water column + ! [C H ~> degC m or degC kg m-2] + + real, dimension(max(nsw,1),SZI_(G)) :: Pen_SW_bnd ! The remaining penetrating shortwave radiation + ! in each band, initially iPen_SW_bnd [C H ~> degC m or degC kg m-2] + real :: SW_trans ! fraction of shortwave radiation not + ! absorbed in a layer [nondim] + real :: unabsorbed ! fraction of the shortwave radiation + ! not absorbed because the layers are too thin [nondim]. + real :: Ih_limit ! inverse of the total depth at which the + ! surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] + real :: min_SW_heat ! A minimum remaining shortwave heating within a timestep that will be simply + ! absorbed in the next layer for computational efficiency, instead of + ! continuing to penetrate [C H ~> degC m or degC kg m-2]. + real :: I_Habs ! The inverse of the absorption length for a minimal flux [H-1 ~> m-1 or m2 kg-1] + real :: h_min_heat ! minimum thickness layer that should get heated [H ~> m or kg m-2] + real :: opt_depth ! optical depth of a layer [nondim] + real :: exp_OD ! exp(-opt_depth) [nondim] + logical :: SW_Remains ! If true, some column has shortwave radiation that + ! was not entirely absorbed. + + integer :: is, ie, nz, i, k, n + SW_Remains = .false. + + I_Habs = 1e3*GV%H_to_m ! optics%PenSW_absorb_Invlen + + h_min_heat = 2.0*GV%Angstrom_H + GV%H_subroundoff + is = G%isc ; ie = G%iec ; nz = GV%ke + + if (nsw < 1) then + netPen(:,:) = 0.0 + return + endif + + pen_SW_bnd(:,:) = iPen_SW_bnd(:,:) + do i=is,ie ; h_heat(i) = 0.0 ; enddo + do i=is,ie + netPen(i,1) = 0. + do n=1,max(nsw,1) + netPen(i,1) = netPen(i,1) + pen_SW_bnd(n,i) ! Surface interface + enddo + enddo + + ! Apply penetrating SW radiation to remaining parts of layers. + ! Excessively thin layers are not heated to avoid runaway temps. + min_SW_heat = optics%PenSW_flux_absorb*dt ! Default of 2.5e-11*US%T_to_s*GV%m_to_H + do k=1,nz + + do i=is,ie + netPen(i,k+1) = 0. + + if (h(i,k) > 0.0) then + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + ! SW_trans is the SW that is transmitted THROUGH the layer + opt_depth = dz(i,k) * optics%opacity_band(n,i,j,k) + exp_OD = exp(-opt_depth) + SW_trans = exp_OD + + ! Heating at a very small rate can be absorbed by a sufficiently thick layer or several + ! thin layers without further penetration. + if (optics%answer_date < 20190101) then + if (nsw*Pen_SW_bnd(n,i)*SW_trans < min_SW_heat*min(1.0, I_Habs*h(i,k)) ) SW_trans = 0.0 + elseif ((nsw*Pen_SW_bnd(n,i)*SW_trans < min_SW_heat) .and. (h(i,k) > h_min_heat)) then + if (nsw*Pen_SW_bnd(n,i) <= min_SW_heat * (I_Habs*(h(i,k) - h_min_heat))) then + SW_trans = 0.0 + else + SW_trans = min(SW_trans, & + 1.0 - (min_SW_heat*(I_Habs*(h(i,k) - h_min_heat))) / (nsw*Pen_SW_bnd(n,i))) + endif + endif + + Pen_SW_bnd(n,i) = Pen_SW_bnd(n,i) * SW_trans + netPen(i,k+1) = netPen(i,k+1) + Pen_SW_bnd(n,i) + endif ; enddo + endif ! h(i,k) > 0.0 + + ! Add to the accumulated thickness above that could be heated. + ! Only layers greater than h_min_heat thick should get heated. + if (h(i,k) >= 2.0*h_min_heat) then + h_heat(i) = h_heat(i) + h(i,k) + elseif (h(i,k) > h_min_heat) then + h_heat(i) = h_heat(i) + (2.0*h(i,k) - 2.0*h_min_heat) + endif + enddo ! i loop + enddo ! k loop + + if (absorbAllSW) then + + ! If there is still shortwave radiation at this point, it could go into + ! the bottom (with a bottom mud model), or it could be redistributed back + ! through the water column. + do i=is,ie + Pen_SW_rem(i) = Pen_SW_bnd(1,i) + do n=2,nsw ; Pen_SW_rem(i) = Pen_SW_rem(i) + Pen_SW_bnd(n,i) ; enddo + enddo + do i=is,ie ; if (Pen_SW_rem(i) > 0.0) SW_Remains = .true. ; enddo + + Ih_limit = 1.0 / H_limit_fluxes + do i=is,ie ; if ((Pen_SW_rem(i) > 0.0) .and. (h_heat(i) > 0.0)) then + if (h_heat(i)*Ih_limit < 1.0) then + unabsorbed = 1.0 - h_heat(i)*Ih_limit + else + unabsorbed = 0.0 + endif + do n=1,nsw ; Pen_SW_bnd(n,i) = unabsorbed * Pen_SW_bnd(n,i) ; enddo + endif ; enddo + + endif ! absorbAllSW + +end subroutine sumSWoverBands + + + +!> This routine initializes the opacity module, including an optics_type. +subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) + type(time_type), target, intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< model vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic + !! output. + type(opacity_CS) :: CS !< Opacity control structure + type(optics_type) :: optics !< An optics structure that has parameters + !! set and arrays allocated here. + ! Local variables + character(len=200) :: tmpstr + character(len=40) :: mdl = "MOM_opacity" + character(len=40) :: bandnum, shortname + character(len=200) :: longname + character(len=40) :: scheme_string + ! This include declares and sets the variable "version". +# include "version_variable.h" + real :: PenSW_absorb_minthick ! A thickness that is used to absorb the remaining shortwave heat + ! flux when that flux drops below PEN_SW_FLUX_ABSORB [H ~> m or kg m-2] + real :: PenSW_minthick_dflt ! The default for PenSW_absorb_minthick [m] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags + integer :: isd, ied, jsd, jed, nz, n + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + + CS%diag => diag + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, '') + +! parameters for CHL_A routines + call get_param(param_file, mdl, "VAR_PEN_SW", CS%var_pen_sw, & + "If true, use one of the CHL_A schemes specified by "//& + "OPACITY_SCHEME to determine the e-folding depth of "//& + "incoming short wave radiation.", default=.false.) + + CS%opacity_scheme = NO_SCHEME ; scheme_string = '' + if (CS%var_pen_sw) then + call get_param(param_file, mdl, "OPACITY_SCHEME", tmpstr, & + "This character string specifies how chlorophyll "//& + "concentrations are translated into opacities. Currently "//& + "valid options include:\n"//& + " \t\t MANIZZA_05 - Use Manizza et al., GRL, 2005. \n"//& + " \t\t MOREL_88 - Use Morel, JGR, 1988.", & + default=MANIZZA_05_STRING) + if (len_trim(tmpstr) > 0) then + tmpstr = uppercase(tmpstr) + select case (tmpstr) + case (MANIZZA_05_STRING) + CS%opacity_scheme = MANIZZA_05 ; scheme_string = MANIZZA_05_STRING + case (MOREL_88_STRING) + CS%opacity_scheme = MOREL_88 ; scheme_string = MOREL_88_STRING + case default + call MOM_error(FATAL, "opacity_init: #DEFINE OPACITY_SCHEME "//& + trim(tmpstr) // "in input file is invalid.") + end select + call MOM_mesg('opacity_init: opacity scheme set to "'//trim(tmpstr)//'".', 5) + endif + if (CS%opacity_scheme == NO_SCHEME) then + call MOM_error(WARNING, "opacity_init: No scheme has successfully "//& + "been specified for the opacity. Using the default MANIZZA_05.") + CS%opacity_scheme = MANIZZA_05 ; scheme_string = MANIZZA_05_STRING + endif + + call get_param(param_file, mdl, "BLUE_FRAC_SW", CS%blue_frac, & + "The fraction of the penetrating shortwave radiation "//& + "that is in the blue band.", default=0.5, units="nondim") + else + call get_param(param_file, mdl, "EXP_OPACITY_SCHEME", tmpstr, & + "This character string specifies which exponential "//& + "opacity scheme to utilize. Currently "//& + "valid options include:\n"//& + " \t\t SINGLE_EXP - Single Exponent decay. \n"//& + " \t\t DOUBLE_EXP - Double Exponent decay.", & + default=Single_Exp_String)!New default for "else" above (non-Chl scheme) + if (len_trim(tmpstr) > 0) then + tmpstr = uppercase(tmpstr) + select case (tmpstr) + case (SINGLE_EXP_STRING) + CS%opacity_scheme = SINGLE_EXP ; scheme_string = SINGLE_EXP_STRING + case (DOUBLE_EXP_STRING) + CS%opacity_scheme = DOUBLE_EXP ; scheme_string = DOUBLE_EXP_STRING + end select + call MOM_mesg('opacity_init: opacity scheme set to "'//trim(tmpstr)//'".', 5) + endif + call get_param(param_file, mdl, "PEN_SW_SCALE", CS%pen_sw_scale, & + "The vertical absorption e-folding depth of the penetrating shortwave radiation.", & + units="m", default=0.0, scale=US%m_to_Z) + !BGR/ Added for opacity_scheme==double_exp read in 2nd exp-decay and fraction + if (CS%Opacity_scheme == DOUBLE_EXP ) then + call get_param(param_file, mdl, "PEN_SW_SCALE_2ND", CS%pen_sw_scale_2nd, & + "The (2nd) vertical absorption e-folding depth of the "//& + "penetrating shortwave radiation (use if SW_EXP_MODE==double.)", & + units="m", default=0.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "SW_1ST_EXP_RATIO", CS%sw_1st_exp_ratio, & + "The fraction of 1st vertical absorption e-folding depth "//& + "penetrating shortwave radiation if SW_EXP_MODE==double.",& + units="nondim", default=0.0) + elseif (CS%OPACITY_SCHEME == Single_Exp) then + !/Else disable 2nd_exp scheme + CS%pen_sw_scale_2nd = 0.0 + CS%sw_1st_exp_ratio = 1.0 + endif + call get_param(param_file, mdl, "PEN_SW_FRAC", CS%pen_sw_frac, & + "The fraction of the shortwave radiation that penetrates "//& + "below the surface.", units="nondim", default=0.0) + + endif + call get_param(param_file, mdl, "PEN_SW_NBANDS", optics%nbands, & + "The number of bands of penetrating shortwave radiation.", & + default=1) + if (CS%Opacity_scheme == DOUBLE_EXP ) then + if (optics%nbands /= 2) call MOM_error(FATAL, & + "set_opacity: \Cannot use a double_exp opacity scheme with nbands!=2.") + elseif (CS%Opacity_scheme == SINGLE_EXP ) then + if (optics%nbands /= 1) call MOM_error(FATAL, & + "set_opacity: \Cannot use a single_exp opacity scheme with nbands!=1.") + endif + + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "OPTICS_ANSWER_DATE", optics%answer_date, & + "The vintage of the order of arithmetic and expressions in the optics calculations. "//& + "Values below 20190101 recover the answers from the end of 2018, while "//& + "higher values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) optics%answer_date = max(optics%answer_date, 20230701) + + call get_param(param_file, mdl, "PEN_SW_FLUX_ABSORB", optics%PenSW_flux_absorb, & + "A minimum remaining shortwave heating rate that will be simply absorbed in "//& + "the next sufficiently thick layers for computational efficiency, instead of "//& + "continuing to penetrate. The default, 2.5e-11 degC m s-1, is about 1e-4 W m-2 "//& + "or 0.08 degC m century-1, but 0 is also a valid value.", & + default=2.5e-11, units="degC m s-1", scale=US%degC_to_C*GV%m_to_H*US%T_to_s) + + if (optics%answer_date < 20190101) then ; PenSW_minthick_dflt = 0.001 ; else ; PenSW_minthick_dflt = 1.0 ; endif + call get_param(param_file, mdl, "PEN_SW_ABSORB_MINTHICK", PenSW_absorb_minthick, & + "A thickness that is used to absorb the remaining penetrating shortwave heat "//& + "flux when it drops below PEN_SW_FLUX_ABSORB.", & + default=PenSW_minthick_dflt, units="m", scale=GV%m_to_H) + optics%PenSW_absorb_Invlen = 1.0 / (PenSW_absorb_minthick + GV%H_subroundoff) + + if (.not.allocated(optics%min_wavelength_band)) & + allocate(optics%min_wavelength_band(optics%nbands)) + if (.not.allocated(optics%max_wavelength_band)) & + allocate(optics%max_wavelength_band(optics%nbands)) + + if (CS%opacity_scheme == MANIZZA_05) then + optics%min_wavelength_band(1) =0 + optics%max_wavelength_band(1) =550 + if (optics%nbands >= 2) then + optics%min_wavelength_band(2)=550 + optics%max_wavelength_band(2)=700 + endif + if (optics%nbands > 2) then + do n=3,optics%nbands + optics%min_wavelength_band(n) =700 + optics%max_wavelength_band(n) =2800 + enddo + endif + endif + + call get_param(param_file, mdl, "OPACITY_LAND_VALUE", CS%opacity_land_value, & + "The value to use for opacity over land. The default is "//& + "10 m-1 - a value for muddy water.", units="m-1", default=10.0, scale=US%Z_to_m) + + CS%warning_issued = .false. + + if (.not.allocated(optics%opacity_band)) & + allocate(optics%opacity_band(optics%nbands,isd:ied,jsd:jed,nz), source=0.0) + if (.not.allocated(optics%sw_pen_band)) & + allocate(optics%sw_pen_band(optics%nbands,isd:ied,jsd:jed)) + allocate(CS%id_opacity(optics%nbands), source=-1) + + CS%id_sw_pen = register_diag_field('ocean_model', 'SW_pen', diag%axesT1, Time, & + 'Penetrating shortwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2) + CS%id_sw_vis_pen = register_diag_field('ocean_model', 'SW_vis_pen', diag%axesT1, Time, & + 'Visible penetrating shortwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2) + do n=1,optics%nbands + write(bandnum,'(i3)') n + shortname = 'opac_'//trim(adjustl(bandnum)) + longname = 'Opacity for shortwave radiation in band '//trim(adjustl(bandnum)) & + // ', saved as L^-1 tanh(Opacity * L) for L = 10^-10 m' + CS%id_opacity(n) = register_diag_field('ocean_model', shortname, diag%axesTL, Time, & + longname, 'm-1', conversion=US%m_to_Z) + enddo + +end subroutine opacity_init + + +subroutine opacity_end(CS, optics) + type(opacity_CS) :: CS !< Opacity control structure + type(optics_type) :: optics !< An optics type structure that should be deallocated. + + if (allocated(CS%id_opacity)) & + deallocate(CS%id_opacity) + if (allocated(optics%sw_pen_band)) & + deallocate(optics%sw_pen_band) + if (allocated(optics%opacity_band)) & + deallocate(optics%opacity_band) + if (allocated(optics%max_wavelength_band)) & + deallocate(optics%max_wavelength_band) + if (allocated(optics%min_wavelength_band)) & + deallocate(optics%min_wavelength_band) +end subroutine opacity_end + +!> \namespace mom_opacity +!! +!! opacity_from_chl: +!! In this routine, the Morel (modified) or Manizza (modified) +!! schemes use the "blue" band in the parameterizations to determine +!! the e-folding depth of the incoming shortwave attenuation. The red +!! portion is lumped into the net heating at the surface. +!! +!! Morel, A., 1988: Optical modeling of the upper ocean in relation +!! to its biogenous matter content (case-i waters)., J. Geo. Res., +!! 93, 10,749-10,768. +!! +!! Manizza, M., C. LeQuere, A. J. Watson, and E. T. Buitenhuis, 2005: +!! Bio-optical feedbacks among phytoplankton, upper ocean physics +!! and sea-ice in a global model, Geophys. Res. Let., 32, L05603, +!! doi:10.1029/2004GL020778. + +end module MOM_opacity diff --git a/parameterizations/vertical/MOM_regularize_layers.F90 b/parameterizations/vertical/MOM_regularize_layers.F90 new file mode 100644 index 0000000000..b00238f60c --- /dev/null +++ b/parameterizations/vertical/MOM_regularize_layers.F90 @@ -0,0 +1,794 @@ +!> Provides regularization of layers in isopycnal mode +module MOM_regularize_layers + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : time_type, diag_ctrl +use MOM_domains, only : pass_var +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, EOS_domain + +implicit none ; private + +#include + +public regularize_layers, regularize_layers_init + +!> This control structure holds parameters used by the MOM_regularize_layers module +type, public :: regularize_layers_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: regularize_surface_layers !< If true, vertically restructure the + !! near-surface layers when they have too much + !! lateral variations to allow for sensible lateral + !! barotropic transports. + logical :: reg_sfc_detrain !< If true, allow the buffer layers to detrain into the + !! interior as a part of the restructuring when + !! regularize_surface_layers is true + real :: density_match_tol !< A relative tolerance for how well the densities must match + !! with the target densities during detrainment when regularizing + !! the near-surface layers [nondim] + real :: sufficient_adjustment !< The fraction of the target entrainment of mass to the mixed + !! and buffer layers that is enough for one timestep when regularizing + !! the near-surface layers [nondim]. No more mass will be sought from + !! deeper layers in the interior after this fraction is exceeded. + real :: h_def_tol1 !< The value of the relative thickness deficit at + !! which to start modifying the structure, 0.5 by + !! default (or a thickness ratio of 5.83) [nondim]. + real :: h_def_tol2 !< The value of the relative thickness deficit at + !! which to the structure modification is in full + !! force, now 20% of the way from h_def_tol1 to 1 [nondim]. + real :: h_def_tol3 !< The value of the relative thickness deficit at which to start + !! detrainment from the buffer layers to the interior, now 30% of + !! the way from h_def_tol1 to 1 [nondim]. + real :: h_def_tol4 !< The value of the relative thickness deficit at which to do + !! detrainment from the buffer layers to the interior at full + !! force, now 50% of the way from h_def_tol1 to 1 [nondim]. + real :: Hmix_min !< The minimum mixed layer thickness [H ~> m or kg m-2]. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in this module's + !! calculations. Values below 20190101 recover the answers from the + !! end of 2018, while higher values use updated and more robust forms + !! of the same expressions. + logical :: debug !< If true, do more thorough checks for debugging purposes. + + integer :: id_def_rat = -1 !< A diagnostic ID +end type regularize_layers_CS + +!>@{ Clock IDs +!! \todo Should these be global? +integer :: id_clock_pass +!>@} + +contains + +!> This subroutine partially steps the bulk mixed layer model. +!! The following processes are executed, in the order listed. +subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent fields + !! have NULL pointers. + real, intent(in) :: dt !< Time increment [T ~> s]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ea !< The amount of fluid moved downward into a + !! layer; this should be increased due to mixed + !! layer detrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: eb !< The amount of fluid moved upward into a layer + !! this should be increased due to mixed layer + !! entrainment [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control structure + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_regularize_layers: "//& + "Module must be initialized before it is used.") + + if (CS%regularize_surface_layers) then + call pass_var(h, G%Domain, clock=id_clock_pass) + call regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) + endif + +end subroutine regularize_layers + +!> This subroutine ensures that there is a degree of horizontal smoothness +!! in the depths of the near-surface interfaces. +subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent fields + !! have NULL pointers. + real, intent(in) :: dt !< Time increment [T ~> s]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ea !< The amount of fluid moved downward into a + !! layer; this should be increased due to mixed + !! layer detrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: eb !< The amount of fluid moved upward into a layer + !! this should be increased due to mixed layer + !! entrainment [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control structure + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G)) :: & + def_rat_u ! The ratio of the thickness deficit to the minimum depth [nondim]. + real, dimension(SZI_(G),SZJB_(G)) :: & + def_rat_v ! The ratio of the thickness deficit to the minimum depth [nondim]. + real, dimension(SZI_(G),SZJ_(G)) :: & + def_rat_h ! The ratio of the thickness deficit to the minimum depth [nondim]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + e ! The interface depths [H ~> m or kg m-2], positive upward. + + real, dimension(SZI_(G),SZK_(GV)+1) :: & + e_filt, e_2d ! The interface depths [H ~> m or kg m-2], positive upward. + real, dimension(SZI_(G),SZK_(GV)) :: & + h_2d, & ! A 2-d version of h [H ~> m or kg m-2]. + T_2d, & ! A 2-d version of tv%T [C ~> degC]. + S_2d, & ! A 2-d version of tv%S [S ~> ppt]. + Rcv, & ! A 2-d version of the coordinate density [R ~> kg m-3]. + h_2d_init, & ! The initial value of h_2d [H ~> m or kg m-2]. + T_2d_init, & ! The initial value of T_2d [C ~> degC]. + S_2d_init, & ! The initial value of S_2d [S ~> ppt]. + d_eb, & ! The downward increase across a layer in the entrainment from + ! below [H ~> m or kg m-2]. The sign convention is that positive values of + ! d_eb correspond to a gain in mass by a layer by upward motion. + d_ea ! The upward increase across a layer in the entrainment from + ! above [H ~> m or kg m-2]. The sign convention is that positive values of + ! d_ea mean a net gain in mass by a layer from downward motion. + real, dimension(SZI_(G)) :: & + p_ref_cv, & ! Reference pressure for the potential density which defines + ! the coordinate variable, set to P_Ref [R L2 T-2 ~> Pa]. + Rcv_tol, & ! A tolerance, relative to the target density differences + ! between layers, for detraining into the interior [nondim]. + h_add_tgt, & ! The target for the thickness to add to the mixed layers [H ~> m or kg m-2] + h_add_tot, & ! The net thickness added to the mixed layers [H ~> m or kg m-2] + h_tot1, h_tot2, h_tot3, & ! Debugging diagnostics of total thicknesses [H ~> m or kg m-2] + Th_tot1, Th_tot2, Th_tot3, & ! Debugging diagnostics of integrated temperatures [C H ~> degC m or degC kg m-2] + Sh_tot1, Sh_tot2, Sh_tot3 ! Debugging diagnostics of integrated salinities [S H ~> ppt m or ppt kg m-2] + real, dimension(SZK_(GV)) :: & + h_prev_1d ! The previous thicknesses [H ~> m or kg m-2]. + real :: I_dtol ! The inverse of the tolerance changes [nondim]. + real :: I_dtol34 ! The inverse of the tolerance changes [nondim]. + real :: e_e, e_w, e_n, e_s ! Temporary interface heights [H ~> m or kg m-2]. + real :: wt ! The weight of the filtered interfaces in setting the targets [nondim]. + real :: scale ! A scaling factor [nondim]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real, dimension(SZK_(GV)+1) :: & + int_flux, & ! Mass flux across the interfaces [H ~> m or kg m-2] + int_Tflux, & ! Temperature flux across the interfaces [C H ~> degC m or degC kg m-2] + int_Sflux ! Salinity flux across the interfaces [S H ~> ppt m or ppt kg m-2] + real :: h_add ! The thickness to add to the layers above an interface [H ~> m or kg m-2] + real :: h_det_tot ! The total thickness detrained by the mixed layers [H ~> m or kg m-2] + real :: max_def_rat ! The maximum value of the ratio of the thickness deficit to the minimum depth [nondim] + real :: Rcv_min_det ! The lightest coordinate density that can detrain into a layer [R ~> kg m-3] + real :: Rcv_max_det ! The densest coordinate density that can detrain into a layer [R ~> kg m-3] + + real :: int_top, int_bot ! The interface depths above and below a layer [H ~> m or kg m-2], positive upward. + real :: h_predicted ! An updated thickness [H ~> m or kg m-2] + real :: h_prev ! The previous thickness [H ~> m or kg m-2] + real :: h_deficit ! The difference between the layer thickness and the value estimated from the + ! filtered interface depths [H ~> m or kg m-2] + + logical :: cols_left, ent_any, more_ent_i(SZI_(G)), ent_i(SZI_(G)) + logical :: det_any, det_i(SZI_(G)) + logical :: do_j(SZJ_(G)), do_i(SZI_(G)) + logical :: debug = .false. + logical :: fatal_error + character(len=256) :: mesg ! Message for error messages. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, nz, nkmb, nkml, k1, k2, k3, ks, nz_filt, kmax_d_ea + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_regularize_layers: "//& + "Module must be initialized before it is used.") + + if (GV%nkml<1) return + nkmb = GV%nk_rho_varies ; nkml = GV%nkml + if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, & + "MOM_regularize_layers: This module now requires the use of temperature and "//& + "an equation of state.") + + h_neglect = GV%H_subroundoff + debug = (debug .or. CS%debug) + + I_dtol = 1.0 / max(CS%h_def_tol2 - CS%h_def_tol1, 1e-40) + I_dtol34 = 1.0 / max(CS%h_def_tol4 - CS%h_def_tol3, 1e-40) + + p_ref_cv(:) = tv%P_Ref + EOSdom(:) = EOS_domain(G%HI) + + do j=js-1,je+1 ; do i=is-1,ie+1 + e(i,j,1) = 0.0 + enddo ; enddo + do K=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + e(i,j,K+1) = e(i,j,K) - h(i,j,k) + enddo ; enddo ; enddo + + call find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, h) + + ! Determine which columns are problematic + do j=js,je ; do_j(j) = .false. ; enddo + do j=js,je ; do i=is,ie + def_rat_h(i,j) = max(def_rat_u(I-1,j), def_rat_u(I,j), & + def_rat_v(i,J-1), def_rat_v(i,J)) + if (def_rat_h(i,j) > CS%h_def_tol1) do_j(j) = .true. + enddo ; enddo + + ! Now restructure the layers. + !$OMP parallel do default(private) shared(is,ie,js,je,nz,do_j,def_rat_h,CS,nkmb,G,GV,US, & + !$OMP e,I_dtol,h,tv,debug,h_neglect,p_ref_cv,ea, & + !$OMP eb,nkml,EOSdom) + do j=js,je ; if (do_j(j)) then + + do k=1,nz ; do i=is,ie ; d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 ; enddo ; enddo + kmax_d_ea = 0 + + max_def_rat = 0.0 + do i=is,ie + do_i(i) = def_rat_h(i,j) > CS%h_def_tol1 + if (def_rat_h(i,j) > max_def_rat) max_def_rat = def_rat_h(i,j) + enddo + nz_filt = nkmb+1 ; if (max_def_rat > CS%h_def_tol3) nz_filt = nz+1 + + ! Find a 2-D 1-2-1 filtered version of e to target. Area weights are + ! deliberately omitted here. This is slightly more complicated than a + ! simple filter so that the effects of topography are eliminated. + do K=1,nz_filt ; do i=is,ie ; if (do_i(i)) then + if (G%mask2dCu(I,j) <= 0.0) then ; e_e = e(i,j,K) ; else + e_e = max(e(i+1,j,K) + min(e(i,j,K) - e(i+1,j,nz+1), 0.0), & + e(i,j,nz+1) + (nz+1-k)*GV%Angstrom_H) + + endif + if (G%mask2dCu(I-1,j) <= 0.0) then ; e_w = e(i,j,K) ; else + e_w = max(e(i-1,j,K) + min(e(i,j,K) - e(i-1,j,nz+1), 0.0), & + e(i,j,nz+1) + (nz+1-k)*GV%Angstrom_H) + endif + if (G%mask2dCv(i,J) <= 0.0) then ; e_n = e(i,j,K) ; else + e_n = max(e(i,j+1,K) + min(e(i,j,K) - e(i,j+1,nz+1), 0.0), & + e(i,j,nz+1) + (nz+1-k)*GV%Angstrom_H) + endif + if (G%mask2dCv(i,J-1) <= 0.0) then ; e_s = e(i,j,K) ; else + e_s = max(e(i,j-1,K) + min(e(i,j,K) - e(i,j-1,nz+1), 0.0), & + e(i,j,nz+1) + (nz+1-k)*GV%Angstrom_H) + endif + + wt = max(0.0, min(1.0, I_dtol*(def_rat_h(i,j)-CS%h_def_tol1))) + + e_filt(i,k) = (1.0 - 0.5*wt) * e(i,j,K) + & + wt * 0.125 * ((e_e + e_w) + (e_n + e_s)) + e_2d(i,k) = e(i,j,K) + endif ; enddo ; enddo + do k=1,nz ; do i=is,ie + h_2d(i,k) = h(i,j,k) + T_2d(i,k) = tv%T(i,j,k) ; S_2d(i,k) = tv%S(i,j,k) + enddo ; enddo + + if (debug) then + do k=1,nz ; do i=is,ie ; if (do_i(i)) then + h_2d_init(i,k) = h(i,j,k) + T_2d_init(i,k) = tv%T(i,j,k) ; S_2d_init(i,k) = tv%S(i,j,k) + endif ; enddo ; enddo + endif + + ! First, try to entrain from the interior. + ent_any = .false. + do i=is,ie + more_ent_i(i) = .false. ; ent_i(i) = .false. + h_add_tgt(i) = 0.0 ; h_add_tot(i) = 0.0 + if (do_i(i) .and. (e_2d(i,nkmb+1) > e_filt(i,nkmb+1))) then + more_ent_i(i) = .true. ; ent_i(i) = .true. ; ent_any = .true. + h_add_tgt(i) = e_2d(i,nkmb+1) - e_filt(i,nkmb+1) + endif + enddo + + if (ent_any) then + do k=nkmb+1,nz + cols_left = .false. + do i=is,ie ; if (more_ent_i(i)) then + if (h_2d(i,k) - GV%Angstrom_H > h_neglect) then + if (e_2d(i,nkmb+1)-e_filt(i,nkmb+1) > h_2d(i,k) - GV%Angstrom_H) then + h_add = h_2d(i,k) - GV%Angstrom_H + h_2d(i,k) = GV%Angstrom_H + e_2d(i,nkmb+1) = e_2d(i,nkmb+1) - h_add + else + h_add = e_2d(i,nkmb+1) - e_filt(i,nkmb+1) + h_2d(i,k) = h_2d(i,k) - h_add + if (CS%answer_date < 20190101) then + e_2d(i,nkmb+1) = e_2d(i,nkmb+1) - h_add + else + e_2d(i,nkmb+1) = e_filt(i,nkmb+1) + endif + endif + d_eb(i,k-1) = d_eb(i,k-1) + h_add + h_add_tot(i) = h_add_tot(i) + h_add + h_prev = h_2d(i,nkmb) + h_2d(i,nkmb) = h_2d(i,nkmb) + h_add + + T_2d(i,nkmb) = (h_prev*T_2d(i,nkmb) + h_add*T_2d(i,k)) / h_2d(i,nkmb) + S_2d(i,nkmb) = (h_prev*S_2d(i,nkmb) + h_add*S_2d(i,k)) / h_2d(i,nkmb) + + if ((e_2d(i,nkmb+1) <= e_filt(i,nkmb+1)) .or. & + (h_add_tot(i) > CS%sufficient_adjustment*h_add_tgt(i))) then + more_ent_i(i) = .false. + else + cols_left = .true. + endif + else + cols_left = .true. + endif + endif ; enddo + if (.not.cols_left) exit + enddo + + ks = min(k-1,nz-1) + do k=ks,nkmb,-1 ; do i=is,ie ; if (ent_i(i)) then + d_eb(i,k) = d_eb(i,k) + d_eb(i,k+1) + endif ; enddo ; enddo + endif ! ent_any + + ! This is where code to detrain to the interior will go. + ! The buffer layers can only detrain water into layers when the buffer + ! layer potential density is between (c*Rlay(k-1) + (1-c)*Rlay(k)) and + ! (c*Rlay(k+1) + (1-c)*Rlay(k)), where 0.5 <= c < 1.0. + ! Do not detrain if the 2-layer deficit ratio is not significant. + ! Detrainment must be able to come from all mixed and buffer layers. + ! All water is moved out of the buffer layers below before moving from + ! a shallower layer (characteristics do not cross). + det_any = .false. + if ((max_def_rat > CS%h_def_tol3) .and. (CS%reg_sfc_detrain)) then + do i=is,ie + det_i(i) = .false. ; Rcv_tol(i) = 0.0 + if (do_i(i) .and. (e_2d(i,nkmb+1) < e_filt(i,nkmb+1)) .and. & + (def_rat_h(i,j) > CS%h_def_tol3)) then + det_i(i) = .true. ; det_any = .true. + ! The CS%density_match_tol default value of 0.6 gives 20% overlap in acceptable densities. + Rcv_tol(i) = CS%density_match_tol * min((def_rat_h(i,j) - CS%h_def_tol3), 1.0) + endif + enddo + endif + if (det_any) then + do k=1,nkmb + call calculate_density(T_2d(:,k), S_2d(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, EOSdom) + enddo + + do i=is,ie ; if (det_i(i)) then + k1 = nkmb ; k2 = nz + h_det_tot = 0.0 + do ! This loop is terminated by exits. + if (k1 <= 1) exit + if (k2 <= nkmb) exit + Rcv_min_det = (GV%Rlay(k2) + Rcv_tol(i)*(GV%Rlay(k2-1)-GV%Rlay(k2))) + if (k2 < nz) then + Rcv_max_det = (GV%Rlay(k2) + Rcv_tol(i)*(GV%Rlay(k2+1)-GV%Rlay(k2))) + else + Rcv_max_det = (GV%Rlay(nz) + Rcv_tol(i)*(GV%Rlay(nz)-GV%Rlay(nz-1))) + endif + if (Rcv(i,k1) > Rcv_max_det) & + exit ! All shallower interior layers are too light for detrainment. + + h_deficit = (e_filt(i,k2)-e_filt(i,k2+1)) - h_2d(i,k2) + if ((e_filt(i,k2) > e_2d(i,k1+1)) .and. (h_deficit > 0.0) .and. & + (Rcv(i,k1) < Rcv_max_det) .and. (Rcv(i,k1) > Rcv_min_det)) then + ! Detrainment will occur. + h_add = min(e_filt(i,k2) - e_2d(i,k2), h_deficit ) + if (h_add < h_2d(i,k1)) then + ! Only part of layer k1 detrains. + if (h_add > 0.0) then + h_prev = h_2d(i,k2) + h_2d(i,k2) = h_2d(i,k2) + h_add + e_2d(i,k2) = e_2d(i,k2+1) + h_2d(i,k2) + d_ea(i,k2) = d_ea(i,k2) + h_add + kmax_d_ea = max(kmax_d_ea, k2) + ! This is upwind. It should perhaps be higher order... + T_2d(i,k2) = (h_prev*T_2d(i,k2) + h_add*T_2d(i,k1)) / h_2d(i,k2) + S_2d(i,k2) = (h_prev*S_2d(i,k2) + h_add*S_2d(i,k1)) / h_2d(i,k2) + h_det_tot = h_det_tot + h_add + + h_2d(i,k1) = h_2d(i,k1) - h_add + do k3=k1,nkmb ; e_2d(i,k3+1) = e_2d(i,k3) - h_2d(i,k3) ; enddo + do k3=k1+1,nkmb ; d_ea(i,k3) = d_ea(i,k3) + h_add ; enddo + else + if (h_add < 0.0) & + call MOM_error(FATAL, "h_add is negative. Some logic is wrong.") + h_add = 0.0 ! This usually should not happen... + endif + + ! Move up to the next target layer. + k2 = k2-1 + if (k2>nkmb+1) e_2d(i,k2) = e_2d(i,k2) + h_det_tot + else + h_add = h_2d(i,k1) + h_prev = h_2d(i,k2) + h_2d(i,k2) = h_2d(i,k2) + h_add + e_2d(i,k2) = e_2d(i,k2+1) + h_2d(i,k2) + d_ea(i,k2) = d_ea(i,k2) + h_add + kmax_d_ea = max(kmax_d_ea, k2) + T_2d(i,k2) = (h_prev*T_2d(i,k2) + h_add*T_2d(i,k1)) / h_2d(i,k2) + S_2d(i,k2) = (h_prev*S_2d(i,k2) + h_add*S_2d(i,k1)) / h_2d(i,k2) + h_det_tot = h_det_tot + h_add + + h_2d(i,k1) = 0.0 + do k3=k1,nkmb ; e_2d(i,k3+1) = e_2d(i,k3) - h_2d(i,k3) ; enddo + do k3=k1+1,nkmb ; d_ea(i,k3) = d_ea(i,k3) + h_add ; enddo + + ! Move up to the next source layer. + k1 = k1-1 + endif + + else + ! Move up to the next target layer. + k2 = k2-1 + if (k2>nkmb+1) e_2d(i,k2) = e_2d(i,k2) + h_det_tot + endif + + enddo ! exit terminated loop. + endif ; enddo + do k=kmax_d_ea-1,nkmb+1,-1 ; do i=is,ie ; if (det_i(i)) then + d_ea(i,k) = d_ea(i,k) + d_ea(i,k+1) + endif ; enddo ; enddo + endif ! Detrainment to the interior. + if (debug) then + do i=is,ie ; h_tot3(i) = 0.0 ; Th_tot3(i) = 0.0 ; Sh_tot3(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie ; if (do_i(i)) then + h_tot3(i) = h_tot3(i) + h_2d(i,k) + Th_tot3(i) = Th_tot3(i) + h_2d(i,k) * T_2d(i,k) + Sh_tot3(i) = Sh_tot3(i) + h_2d(i,k) * S_2d(i,k) + endif ; enddo ; enddo + endif + + do i=is,ie ; if (do_i(i)) then + ! Rescale the interface targets so the depth at the bottom of the deepest + ! buffer layer matches. + scale = e_2d(i,nkmb+1) / e_filt(i,nkmb+1) + do k=2,nkmb+1 ; e_filt(i,k) = e_filt(i,k) * scale ; enddo + + ! Ensure that layer 1 only has water from layers 1 to nkml and rescale + ! the remaining layer thicknesses if necessary. + if (e_filt(i,2) < e_2d(i,nkml)) then + scale = (e_2d(i,nkml) - e_filt(i,nkmb+1)) / & + ((e_filt(i,2) - e_filt(i,nkmb+1)) + h_neglect) + do k=3,nkmb + e_filt(i,k) = e_filt(i,nkmb+1) + scale * (e_filt(i,k) - e_filt(i,nkmb+1)) + enddo + e_filt(i,2) = e_2d(i,nkml) + endif + + ! Map the water back into the layers. There are not mixed or buffer layers that are exceedingly + ! small compared to the others, so the code here is less prone to roundoff than elsewhere in MOM6. + k1 = 1 ; k2 = 1 + int_top = 0.0 + do k=1,nkmb+1 + int_flux(k) = 0.0 + int_Tflux(k) = 0.0 ; int_Sflux(k) = 0.0 + enddo + do k=1,2*nkmb + int_bot = max(e_2d(i,k1+1),e_filt(i,k2+1)) + h_add = int_top - int_bot + + if (k2 > k1) then + do k3=k1+1,k2 + d_ea(i,k3) = d_ea(i,k3) + h_add + int_flux(k3) = int_flux(k3) + h_add + int_Tflux(k3) = int_Tflux(k3) + h_add*T_2d(i,k1) + int_Sflux(k3) = int_Sflux(k3) + h_add*S_2d(i,k1) + enddo + elseif (k1 > k2) then + do k3=k2,k1-1 + d_eb(i,k3) = d_eb(i,k3) + h_add + int_flux(k3+1) = int_flux(k3+1) - h_add + int_Tflux(k3+1) = int_Tflux(k3+1) - h_add*T_2d(i,k1) + int_Sflux(k3+1) = int_Sflux(k3+1) - h_add*S_2d(i,k1) + enddo + endif + + if (int_bot <= e_filt(i,k2+1)) then + ! Increment the target layer. + k2 = k2 + 1 + elseif (int_bot <= e_2d(i,k1+1)) then + ! Increment the source layer. + k1 = k1 + 1 + else + call MOM_error(FATAL, & + "Regularize_surface: Could not increment target or source.") + endif + if ((k1 > nkmb) .or. (k2 > nkmb)) exit + int_top = int_bot + enddo + if (k2 < nkmb) & + call MOM_error(FATAL, "Regularize_surface: Did not assign fluid to layer nkmb.") + + ! Note that movement of water across the base of the bottommost buffer + ! layer has already been dealt with separately. + do k=1,nkmb ; h_prev_1d(k) = h_2d(i,k) ; enddo + h_2d(i,1) = h_2d(i,1) - int_flux(2) + do k=2,nkmb-1 + h_2d(i,k) = h_2d(i,k) + (int_flux(k) - int_flux(k+1)) + enddo + ! Note that movement of water across the base of the bottommost buffer + ! layer has already been dealt with separately. + h_2d(i,nkmb) = h_2d(i,nkmb) + int_flux(nkmb) + + T_2d(i,1) = (T_2d(i,1)*h_prev_1d(1) - int_Tflux(2)) / h_2d(i,1) + S_2d(i,1) = (S_2d(i,1)*h_prev_1d(1) - int_Sflux(2)) / h_2d(i,1) + do k=2,nkmb-1 + T_2d(i,k) = (T_2d(i,k)*h_prev_1d(k) + (int_Tflux(k) - int_Tflux(k+1))) / h_2d(i,k) + S_2d(i,k) = (S_2d(i,k)*h_prev_1d(k) + (int_Sflux(k) - int_Sflux(k+1))) / h_2d(i,k) + enddo + T_2d(i,nkmb) = (T_2d(i,nkmb)*h_prev_1d(nkmb) + int_Tflux(nkmb) ) / h_2d(i,nkmb) + S_2d(i,nkmb) = (S_2d(i,nkmb)*h_prev_1d(nkmb) + int_Sflux(nkmb) ) / h_2d(i,nkmb) + + endif ; enddo ! i-loop + + ! Copy the interior thicknesses and other fields back to the 3-d arrays. + do k=1,nz ; do i=is,ie ; if (do_i(i)) then + h(i,j,k) = h_2d(i,k) + tv%T(i,j,k) = T_2d(i,k) ; tv%S(i,j,k) = S_2d(i,k) + ea(i,j,k) = ea(i,j,k) + d_ea(i,k) + eb(i,j,k) = eb(i,j,k) + d_eb(i,k) + endif ; enddo ; enddo + + if (debug) then + do i=is,ie ; h_tot1(i) = 0.0 ; Th_tot1(i) = 0.0 ; Sh_tot1(i) = 0.0 ; enddo + do i=is,ie ; h_tot2(i) = 0.0 ; Th_tot2(i) = 0.0 ; Sh_tot2(i) = 0.0 ; enddo + + do k=1,nz ; do i=is,ie ; if (do_i(i)) then + h_tot1(i) = h_tot1(i) + h_2d_init(i,k) + h_tot2(i) = h_tot2(i) + h(i,j,k) + + Th_tot1(i) = Th_tot1(i) + h_2d_init(i,k) * T_2d_init(i,k) + Th_tot2(i) = Th_tot2(i) + h(i,j,k) * tv%T(i,j,k) + Sh_tot1(i) = Sh_tot1(i) + h_2d_init(i,k) * S_2d_init(i,k) + Sh_tot2(i) = Sh_tot2(i) + h(i,j,k) * tv%S(i,j,k) + if (h(i,j,k) < 0.0) & + call MOM_error(FATAL,"regularize_surface: Negative thicknesses.") + if (k==1) then ; h_predicted = h_2d_init(i,k) + (d_eb(i,k) - d_ea(i,k+1)) + elseif (k==nz) then ; h_predicted = h_2d_init(i,k) + (d_ea(i,k) - d_eb(i,k-1)) + else + h_predicted = h_2d_init(i,k) + ((d_ea(i,k) - d_eb(i,k-1)) + & + (d_eb(i,k) - d_ea(i,k+1))) + endif + if (abs(h(i,j,k) - h_predicted) > MAX(1e-9*abs(h_predicted),GV%Angstrom_H)) & + call MOM_error(FATAL, "regularize_surface: d_ea mismatch.") + endif ; enddo ; enddo + do i=is,ie ; if (do_i(i)) then + fatal_error = .false. + if (abs(h_tot1(i) - h_tot2(i)) > 1e-12*h_tot1(i)) then + write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4)') & + h_tot1(i), h_tot2(i), (h_tot1(i) - h_tot2(i)) + call MOM_error(WARNING, "regularize_surface: Mass non-conservation."//& + trim(mesg), .true.) + fatal_error = .true. + endif + if (abs(Th_tot1(i) - Th_tot2(i)) > 1e-12*abs(Th_tot1(i) + 10.0*US%degC_to_C*h_tot1(i))) then + write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4," int diff ",ES11.4)') & + Th_tot1(i), Th_tot2(i), (Th_tot1(i) - Th_tot2(i)), (Th_tot1(i) - Th_tot3(i)) + call MOM_error(WARNING, "regularize_surface: Heat non-conservation."//& + trim(mesg), .true.) + fatal_error = .true. + endif + if (abs(Sh_tot1(i) - Sh_tot2(i)) > 1e-12*abs(Sh_tot1(i) + 10.0*US%ppt_to_S*h_tot1(i))) then + write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4," int diff ",ES11.4)') & + Sh_tot1(i), Sh_tot2(i), (Sh_tot1(i) - Sh_tot2(i)), (Sh_tot1(i) - Sh_tot3(i)) + call MOM_error(WARNING, "regularize_surface: Salinity non-conservation."//& + trim(mesg), .true.) + fatal_error = .true. + endif + if (fatal_error) then + write(mesg,'("Error at lat/lon ",2(ES11.4))') G%geoLatT(i,j), G%geoLonT(i,j) + call MOM_error(FATAL, "regularize_surface: Terminating with fatal error. "//& + trim(mesg)) + endif + endif ; enddo + endif + + endif ; enddo ! j-loop. + + if (CS%id_def_rat > 0) call post_data(CS%id_def_rat, def_rat_h, CS%diag) + +end subroutine regularize_surface + +!> This subroutine determines the amount by which the harmonic mean +!! thickness at velocity points differ from the arithmetic means, relative to +!! the arithmetic means, after eliminating thickness variations that are +!! solely due to topography and aggregating all interior layers into one. +subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, h) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(in) :: e !< Interface depths [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G)), & + intent(out) :: def_rat_u !< The thickness deficit ratio at u points, + !! [nondim]. + real, dimension(SZI_(G),SZJB_(G)), & + intent(out) :: def_rat_v !< The thickness deficit ratio at v points, + !! [nondim]. + type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G)) :: & + h_def_u, & ! The vertically summed thickness deficits at u-points [H ~> m or kg m-2]. + h_norm_u ! The vertically summed arithmetic mean thickness by which + ! h_def_u is normalized [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G)) :: & + h_def_v, & ! The vertically summed thickness deficits at v-points [H ~> m or kg m-2]. + h_norm_v ! The vertically summed arithmetic mean thickness by which + ! h_def_v is normalized [H ~> m or kg m-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: Hmix_min ! A local copy of CS%Hmix_min [H ~> m or kg m-2]. + real :: h1, h2 ! Temporary thicknesses [H ~> m or kg m-2]. + integer :: i, j, k, is, ie, js, je, nz, nkmb + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + nkmb = GV%nk_rho_varies + h_neglect = GV%H_subroundoff + Hmix_min = CS%Hmix_min + + ! Determine which zonal faces are problematic. + do j=js,je ; do I=is-1,ie + ! Aggregate all water below the mixed and buffer layers for the purposes of + ! this diagnostic. + h1 = e(i,j,nkmb+1)-e(i,j,nz+1) ; h2 = e(i+1,j,nkmb+1)-e(i+1,j,nz+1) + if (e(i,j,nz+1) < e(i+1,j,nz+1)) then + if (h1 > h2) h1 = max(e(i,j,nkmb+1)-e(i+1,j,nz+1), h2) + elseif (e(i+1,j,nz+1) < e(i,j,nz+1)) then + if (h2 > h1) h2 = max(e(i+1,j,nkmb+1)-e(i,j,nz+1), h1) + endif + h_def_u(I,j) = 0.5*(h1-h2)**2 / ((h1 + h2) + h_neglect) + h_norm_u(I,j) = 0.5*(h1+h2) + enddo ; enddo + do k=1,nkmb ; do j=js,je ; do I=is-1,ie + h1 = h(i,j,k) ; h2 = h(i+1,j,k) + ! Thickness deficits can not arise simply because a layer's bottom is bounded + ! by the bathymetry. + if (e(i,j,K+1) < e(i+1,j,nz+1)) then + if (h1 > h2) h1 = max(e(i,j,K)-e(i+1,j,nz+1), h2) + elseif (e(i+1,j,K+1) < e(i,j,nz+1)) then + if (h2 > h1) h2 = max(e(i+1,j,K)-e(i,j,nz+1), h1) + endif + h_def_u(I,j) = h_def_u(I,j) + 0.5*(h1-h2)**2 / ((h1 + h2) + h_neglect) + h_norm_u(I,j) = h_norm_u(I,j) + 0.5*(h1+h2) + enddo ; enddo ; enddo + do j=js,je ; do I=is-1,ie + def_rat_u(I,j) = G%mask2dCu(I,j) * h_def_u(I,j) / & + (max(Hmix_min, h_norm_u(I,j)) + h_neglect) + enddo ; enddo + + ! Determine which meridional faces are problematic. + do J=js-1,je ; do i=is,ie + ! Aggregate all water below the mixed and buffer layers for the purposes of + ! this diagnostic. + h1 = e(i,j,nkmb+1)-e(i,j,nz+1) ; h2 = e(i,j+1,nkmb+1)-e(i,j+1,nz+1) + if (e(i,j,nz+1) < e(i,j+1,nz+1)) then + if (h1 > h2) h1 = max(e(i,j,nkmb+1)-e(i,j+1,nz+1), h2) + elseif (e(i,j+1,nz+1) < e(i,j,nz+1)) then + if (h2 > h1) h2 = max(e(i,j+1,nkmb+1)-e(i,j,nz+1), h1) + endif + h_def_v(i,J) = 0.5*(h1-h2)**2 / ((h1 + h2) + h_neglect) + h_norm_v(i,J) = 0.5*(h1+h2) + enddo ; enddo + do k=1,nkmb ; do J=js-1,je ; do i=is,ie + h1 = h(i,j,k) ; h2 = h(i,j+1,k) + ! Thickness deficits can not arise simply because a layer's bottom is bounded + ! by the bathymetry. + if (e(i,j,K+1) < e(i,j+1,nz+1)) then + if (h1 > h2) h1 = max(e(i,j,K)-e(i,j+1,nz+1), h2) + elseif (e(i,j+1,K+1) < e(i,j,nz+1)) then + if (h2 > h1) h2 = max(e(i,j+1,K)-e(i,j,nz+1), h1) + endif + h_def_v(i,J) = h_def_v(i,J) + 0.5*(h1-h2)**2 / ((h1 + h2) + h_neglect) + h_norm_v(i,J) = h_norm_v(i,J) + 0.5*(h1+h2) + enddo ; enddo ; enddo + do J=js-1,je ; do i=is,ie + def_rat_v(i,J) = G%mask2dCv(i,J) * h_def_v(i,J) / & + (max(Hmix_min, h_norm_v(i,J)) + h_neglect) + enddo ; enddo + +end subroutine find_deficit_ratios + +!> Initializes the regularize_layers control structure +subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) + type(time_type), target, intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure to parse for + !! run-time parameters. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(regularize_layers_CS), intent(inout) :: CS !< Regularize layer control structure + +# include "version_variable.h" + character(len=40) :: mdl = "MOM_regularize_layers" ! This module's name. + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags + logical :: just_read + integer :: isd, ied, jsd, jed + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + CS%initialized = .true. + + CS%diag => diag + CS%Time => Time + +! Set default, read and log parameters + call get_param(param_file, mdl, "REGULARIZE_SURFACE_LAYERS", CS%regularize_surface_layers, & + default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, "", all_default=.not.CS%regularize_surface_layers) + call get_param(param_file, mdl, "REGULARIZE_SURFACE_LAYERS", CS%regularize_surface_layers, & + "If defined, vertically restructure the near-surface "//& + "layers when they have too much lateral variations to "//& + "allow for sensible lateral barotropic transports.", & + default=.false.) + just_read = .not.CS%regularize_surface_layers + if (CS%regularize_surface_layers) then + call get_param(param_file, mdl, "REGULARIZE_SURFACE_DETRAIN", CS%reg_sfc_detrain, & + "If true, allow the buffer layers to detrain into the "//& + "interior as a part of the restructuring when "//& + "REGULARIZE_SURFACE_LAYERS is true.", default=.true., do_not_log=just_read) + call get_param(param_file, mdl, "REG_SFC_DENSE_MATCH_TOLERANCE", CS%density_match_tol, & + "A relative tolerance for how well the densities must match with the target "//& + "densities during detrainment when regularizing the near-surface layers. The "//& + "default of 0.6 gives 20% overlaps in density", & + units="nondim", default=0.6, do_not_log=just_read) + call get_param(param_file, mdl, "REG_SFC_SUFFICIENT_ADJ", CS%sufficient_adjustment, & + "The fraction of the target entrainment of mass to the mixed and buffer layers "//& + "that is enough for one timestep when regularizing the near-surface layers. "//& + "No more mass will be sought from deeper layers in the interior after this "//& + "fraction is exceeded.", units="nondim", default=0.6, do_not_log=just_read) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=just_read) + call get_param(param_file, mdl, "REGULARIZE_LAYERS_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the regularize "//& + "layers calculations. Values below 20190101 recover the answers from the "//& + "end of 2018, while higher values use updated and more robust forms of the "//& + "same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + endif + + call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & + "The minimum mixed layer depth if the mixed layer depth is determined "//& + "dynamically.", units="m", default=0.0, scale=GV%m_to_H, do_not_log=just_read) + call get_param(param_file, mdl, "REG_SFC_DEFICIT_TOLERANCE", CS%h_def_tol1, & + "The value of the relative thickness deficit at which "//& + "to start modifying the layer structure when "//& + "REGULARIZE_SURFACE_LAYERS is true.", units="nondim", & + default=0.5, do_not_log=just_read) + CS%h_def_tol2 = 0.2 + 0.8*CS%h_def_tol1 + CS%h_def_tol3 = 0.3 + 0.7*CS%h_def_tol1 + CS%h_def_tol4 = 0.5 + 0.5*CS%h_def_tol1 + + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) +! if (.not. CS%debug) & +! call get_param(param_file, mdl, "DEBUG_CONSERVATION", CS%debug, & +! "If true, monitor conservation and extrema.", default=.false., do_not_log=just_read) + + if (.not.CS%regularize_surface_layers) return + + CS%id_def_rat = register_diag_field('ocean_model', 'deficit_ratio', diag%axesT1, & + Time, 'Max face thickness deficit ratio', 'nondim') + + id_clock_pass = cpu_clock_id('(Ocean regularize_layers halo updates)', grain=CLOCK_ROUTINE) + +end subroutine regularize_layers_init + +end module MOM_regularize_layers diff --git a/parameterizations/vertical/MOM_set_diffusivity.F90 b/parameterizations/vertical/MOM_set_diffusivity.F90 new file mode 100644 index 0000000000..ef2e4ed5f6 --- /dev/null +++ b/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -0,0 +1,2437 @@ +!> Calculate vertical diffusivity from all mixing processes +module MOM_set_diffusivity + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_bkgnd_mixing, only : calculate_bkgnd_mixing, bkgnd_mixing_init, bkgnd_mixing_cs +use MOM_bkgnd_mixing, only : bkgnd_mixing_end +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_CVMix_ddiff, only : CVMix_ddiff_init, CVMix_ddiff_end, CVMix_ddiff_cs +use MOM_CVMix_ddiff, only : compute_ddiff_coeffs +use MOM_CVMix_shear, only : calculate_CVMix_shear, CVMix_shear_init, CVMix_shear_cs +use MOM_CVMix_shear, only : CVMix_shear_end +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_debugging, only : hchksum, uvchksum, Bchksum, hchksum_pair +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_error_handler, only : callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing, optics_type +use MOM_full_convection, only : full_convection +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom +use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss +use MOM_intrinsic_functions, only : invcosh +use MOM_io, only : slasher, MOM_read_data +use MOM_isopycnal_slopes, only : vert_fill_TS +use MOM_kappa_shear, only : calculate_kappa_shear, kappa_shear_init, Kappa_shear_CS +use MOM_kappa_shear, only : calc_kappa_shear_vertex, kappa_shear_at_vertex +use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, OBC_NONE +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S +use MOM_string_functions, only : uppercase +use MOM_tidal_mixing, only : tidal_mixing_CS, calculate_tidal_mixing, tidal_mixing_h_amp +use MOM_tidal_mixing, only : setup_tidal_diagnostics, post_tidal_diagnostics +use MOM_tidal_mixing, only : tidal_mixing_init, tidal_mixing_end +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d +use MOM_verticalGrid, only : verticalGrid_type +use user_change_diffusivity, only : user_change_diff, user_change_diff_init +use user_change_diffusivity, only : user_change_diff_end, user_change_diff_CS + +implicit none ; private + +#include + +public set_diffusivity +public set_BBL_TKE +public set_diffusivity_init +public set_diffusivity_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> This control structure contains parameters for MOM_set_diffusivity. +type, public :: set_diffusivity_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: debug !< If true, write verbose checksums for debugging. + + logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with + !! GV%nk_rho_varies variable density mixed & buffer layers. + real :: FluxRi_max !< The flux Richardson number where the stratification is + !! large enough that N2 > omega2 [nondim]. The full expression + !! for the Flux Richardson number is usually + !! FLUX_RI_MAX*N2/(N2+OMEGA2). The default is 0.2. + logical :: bottomdraglaw !< If true, the bottom stress is calculated with a + !! drag law c_drag*|u|*u. + logical :: BBL_mixing_as_max !< If true, take the maximum of the diffusivity + !! from the BBL mixing and the other diffusivities. + !! Otherwise, diffusivities from the BBL_mixing is added. + logical :: use_LOTW_BBL_diffusivity !< If true, use simpler/less precise, BBL diffusivity. + logical :: LOTW_BBL_use_omega !< If true, use simpler/less precise, BBL diffusivity. + real :: Von_Karm !< The von Karman constant as used in the BBL diffusivity calculation + !! [nondim]. See (http://en.wikipedia.org/wiki/Von_Karman_constant) + real :: BBL_effic !< efficiency with which the energy extracted + !! by bottom drag drives BBL diffusion [nondim] + real :: cdrag !< quadratic drag coefficient [nondim] + real :: dz_BBL_avg_min !< A minimal distance over which to average to determine the average + !! bottom boundary layer density [Z ~> m] + real :: IMax_decay !< Inverse of a maximum decay scale for + !! bottom-drag driven turbulence [H-1 ~> m-1 or m2 kg-1]. + real :: Kv !< The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s] + real :: Kd !< interior diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_min !< minimum diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_max !< maximum increment for diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + !! Set to a negative value to have no limit. + real :: Kd_add !< uniform diffusivity added everywhere without + !! filtering or scaling [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_smooth !< Vertical diffusivity used to interpolate more + !! sensible values of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostic output timing + + logical :: limit_dissipation !< If enabled, dissipation is limited to be larger + !! than the following: + real :: dissip_min !< Minimum dissipation [R Z2 T-3 ~> W m-3] + real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N [R Z2 T-3 ~> W m-3] + real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N [R Z2 T-2 ~> J m-3] + real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 [R Z2 T-1 ~> J s m-3] + real :: dissip_Kd_min !< Minimum Kd [H Z T-1 ~> m2 s-1 or kg m-1 s-1], with dissipation Rho0*Kd_min*N^2 + + real :: omega !< Earth's rotation frequency [T-1 ~> s-1] + logical :: ML_radiation !< allow a fraction of TKE available from wind work + !! to penetrate below mixed layer base with a vertical + !! decay scale determined by the minimum of + !! (1) The depth of the mixed layer, or + !! (2) An Ekman length scale. + !! Energy available to drive mixing below the mixed layer is + !! given by E = ML_RAD_COEFF*MSTAR*USTAR**3. Optionally, if + !! ML_rad_TKE_decay is true, this is further reduced by a factor + !! of exp(-h_ML*Idecay_len_TkE), where Idecay_len_TKE is + !! calculated the same way as in the mixed layer code. + !! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), + !! where N2 is the squared buoyancy frequency [T-2 ~> s-2] and OMEGA2 + !! is the rotation rate of the earth squared. + real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence radiated from + !! the base of the mixed layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: ML_rad_efold_coeff !< Coefficient to scale penetration depth [nondim] + real :: ML_rad_coeff !< Coefficient which scales MSTAR*USTAR^3 to obtain energy + !! available for mixing below mixed layer base [nondim] + logical :: ML_rad_bug !< If true use code with a bug that reduces the energy available + !! in the transition layer by a factor of the inverse of the energy + !! deposition lenthscale (in m). + logical :: ML_rad_TKE_decay !< If true, apply same exponential decay + !! to ML_rad as applied to the other surface + !! sources of TKE in the mixed layer code. + real :: ustar_min !< A minimum value of ustar to avoid numerical + !! problems [Z T-1 ~> m s-1]. If the value is small enough, + !! this parameter should not affect the solution. + real :: TKE_decay !< ratio of natural Ekman depth to TKE decay scale [nondim] + real :: mstar !< ratio of friction velocity cubed to + !! TKE input to the mixed layer [nondim] + logical :: ML_use_omega !< If true, use absolute rotation rate instead + !! of the vertical component of rotation when + !! setting the decay scale for mixed layer turbulence. + real :: ML_omega_frac !< When setting the decay scale for turbulence, use + !! this fraction [nondim] of the absolute rotation rate blended + !! with the local value of f, as f^2 ~= (1-of)*f^2 + of*4*omega^2. + logical :: user_change_diff !< If true, call user-defined code to change diffusivity. + logical :: useKappaShear !< If true, use the kappa_shear module to find the + !! shear-driven diapycnal diffusivity. + logical :: Vertex_Shear !< If true, do the calculations of the shear-driven mixing + !! at the cell vertices (i.e., the vorticity points). + logical :: use_CVMix_shear !< If true, use one of the CVMix modules to find + !! shear-driven diapycnal diffusivity. + logical :: double_diffusion !< If true, enable double-diffusive mixing using an old method. + logical :: use_CVMix_ddiff !< If true, enable double-diffusive mixing via CVMix. + logical :: use_tidal_mixing !< If true, activate tidal mixing diffusivity. + logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that + !! does not rely on a layer-formulation. + real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering [nondim] + real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kv_molecular !< Molecular viscosity for double diffusive convection [H Z T-1 ~> m2 s-1 or Pa s] + + integer :: answer_date !< The vintage of the order of arithmetic and expressions in this module's + !! calculations. Values below 20190101 recover the answers from the + !! end of 2018, while higher values use updated and more robust forms + !! of the same expressions. + + character(len=200) :: inputdir !< The directory in which input files are found + type(user_change_diff_CS), pointer :: user_change_diff_CSp => NULL() !< Control structure for a child module + type(Kappa_shear_CS), pointer :: kappaShear_CSp => NULL() !< Control structure for a child module + type(CVMix_shear_cs), pointer :: CVMix_shear_csp => NULL() !< Control structure for a child module + type(CVMix_ddiff_cs), pointer :: CVMix_ddiff_csp => NULL() !< Control structure for a child module + type(bkgnd_mixing_cs), pointer :: bkgnd_mixing_csp => NULL() !< Control structure for a child module + type(int_tide_CS), pointer :: int_tide_CSp => NULL() !< Control structure for a child module + type(tidal_mixing_cs) :: tidal_mixing !< Control structure for a child module + + !>@{ Diagnostic IDs + integer :: id_maxTKE = -1, id_TKE_to_Kd = -1, id_Kd_user = -1 + integer :: id_Kd_layer = -1, id_Kd_BBL = -1, id_N2 = -1 + integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 + integer :: id_Kd_bkgnd = -1, id_Kv_bkgnd = -1 + !>@} + +end type set_diffusivity_CS + +!> This structure has memory for used in calculating diagnostics of diffusivity +type diffusivity_diags + real, pointer, dimension(:,:,:) :: & + N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] + Kd_user => NULL(), & !< user-added diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] + maxTKE => NULL(), & !< energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] + Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or Pa s] + KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + drho_rat => NULL() !< The density difference ratio used in double diffusion [nondim]. + real, pointer, dimension(:,:,:) :: TKE_to_Kd => NULL() + !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between TKE + !! dissipated within a layer and Kd in that layer + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] + +end type diffusivity_diags + +!>@{ CPU time clocks +integer :: id_clock_kappaShear, id_clock_CVMix_ddiff +!>@} + +contains + +subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_int, & + G, GV, US, CS, Kd_lay, Kd_extra_T, Kd_extra_S) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u_h !< Zonal velocity interpolated to h points [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: v_h !< Meridional velocity interpolated to h points [L T-1 ~> m s-1]. + type(thermo_var_ptrs), intent(inout) :: tv !< Structure with pointers to thermodynamic + !! fields. Out is for tv%TempxPmE. + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + type(optics_type), pointer :: optics !< A structure describing the optical + !! properties of the ocean. + type(vertvisc_type), intent(inout) :: visc !< Structure containing vertical viscosities, bottom + !! boundary layer properties and related fields. + real, intent(in) :: dt !< Time increment [T ~> s]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(out) :: Kd_int !< Diapycnal diffusivity at each interface + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + type(set_diffusivity_CS), pointer :: CS !< Module control structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(out) :: Kd_extra_T !< The extra diffusivity at interfaces of + !! temperature due to double diffusion relative + !! to the diffusivity of density + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(out) :: Kd_extra_S !< The extra diffusivity at interfaces of + !! salinity due to double diffusion relative + !! to the diffusivity of density + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + ! local variables + real :: N2_bot(SZI_(G)) ! Bottom squared buoyancy frequency [T-2 ~> s-2] + real :: rho_bot(SZI_(G)) ! In situ near-bottom density [T-2 ~> s-2] + + type(diffusivity_diags) :: dd ! structure with arrays of available diags + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + T_f, S_f ! Temperature and salinity [C ~> degC] and [S ~> ppt] with properties in massless layers + ! filled vertically by diffusion or the properties after full convective adjustment. + + real, dimension(SZI_(G),SZK_(GV)) :: & + N2_lay, & !< Squared buoyancy frequency associated with layers [T-2 ~> s-2] + Kd_lay_2d, & !< The layer diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + dz, & !< Height change across layers [Z ~> m] + maxTKE, & !< Energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_to_Kd !< Conversion rate (~1.0 / (G_Earth + dRho_lay)) between + !< TKE dissipated within a layer and Kd in that layer + !< [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] + + real, dimension(SZI_(G),SZK_(GV)+1) :: & + N2_int, & !< squared buoyancy frequency associated at interfaces [T-2 ~> s-2] + Kd_int_2d, & !< The interface diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kv_bkgnd, & !< The background diffusion related interface viscosities [H Z T-1 ~> m2 s-1 or Pa s] + dRho_int, & !< Locally referenced potential density difference across interfaces [R ~> kg m-3] + KT_extra, & !< Double diffusion diffusivity of temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KS_extra !< Double diffusion diffusivity of salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + real :: dissip ! local variable for dissipation calculations [Z2 R T-3 ~> W m-3] + real :: Omega2 ! squared absolute rotation rate [T-2 ~> s-2] + + logical :: use_EOS ! If true, compute density from T/S using equation of state. + logical :: TKE_to_Kd_used ! If true, TKE_to_Kd and maxTKE need to be calculated. + integer :: kb(SZI_(G)) ! The index of the lightest layer denser than the + ! buffer layer, or -1 without a bulk mixed layer. + logical :: showCallTree ! If true, show the call tree. + + integer :: i, j, k, is, ie, js, je, nz, isd, ied, jsd, jed + + real :: kappa_dt_fill ! diffusivity times a timestep used to fill massless layers [H Z ~> m2 or kg m-1] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("set_diffusivity(), MOM_set_diffusivity.F90") + + if (.not.associated(CS)) call MOM_error(FATAL,"set_diffusivity: "//& + "Module must be initialized before it is used.") + + if (.not.CS%initialized) call MOM_error(FATAL,"set_diffusivity: "//& + "Module must be initialized before it is used.") + + if (CS%answer_date < 20190101) then + ! These hard-coded dimensional parameters are being replaced. + kappa_dt_fill = 1.e-3*GV%m2_s_to_HZ_T * 7200.*US%s_to_T + else + kappa_dt_fill = CS%Kd_smooth * dt + endif + Omega2 = CS%omega * CS%omega + + use_EOS = associated(tv%eqn_of_state) + + if ((CS%use_CVMix_ddiff .or. CS%double_diffusion) .and. & + .not.(present(Kd_extra_T) .and. present(Kd_extra_S))) & + call MOM_error(FATAL, "set_diffusivity: both Kd_extra_T and Kd_extra_S must be present "//& + "when USE_CVMIX_DDIFF or DOUBLE_DIFFUSION are true.") + + TKE_to_Kd_used = (CS%use_tidal_mixing .or. CS%ML_radiation .or. & + (CS%bottomdraglaw .and. .not.CS%use_LOTW_BBL_diffusivity)) + + ! Set Kd_lay, Kd_int and Kv_slow to constant values, mostly to fill the halos. + if (present(Kd_lay)) Kd_lay(:,:,:) = CS%Kd + Kd_int(:,:,:) = CS%Kd + if (present(Kd_extra_T)) Kd_extra_T(:,:,:) = 0.0 + if (present(Kd_extra_S)) Kd_extra_S(:,:,:) = 0.0 + if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = CS%Kv + + ! Set up arrays for diagnostics. + + if (CS%id_N2 > 0) allocate(dd%N2_3d(isd:ied,jsd:jed,nz+1), source=0.0) + if (CS%id_Kd_user > 0) allocate(dd%Kd_user(isd:ied,jsd:jed,nz+1), source=0.0) + if (CS%id_Kd_work > 0) allocate(dd%Kd_work(isd:ied,jsd:jed,nz), source=0.0) + if (CS%id_maxTKE > 0) allocate(dd%maxTKE(isd:ied,jsd:jed,nz), source=0.0) + if (CS%id_TKE_to_Kd > 0) allocate(dd%TKE_to_Kd(isd:ied,jsd:jed,nz), source=0.0) + if ((CS%double_diffusion) .and. (CS%id_KT_extra > 0)) & + allocate(dd%KT_extra(isd:ied,jsd:jed,nz+1), source=0.0) + if ((CS%double_diffusion) .and. (CS%id_KS_extra > 0)) & + allocate(dd%KS_extra(isd:ied,jsd:jed,nz+1), source=0.0) + if (CS%id_R_rho > 0) allocate(dd%drho_rat(isd:ied,jsd:jed,nz+1), source=0.0) + if (CS%id_Kd_BBL > 0) allocate(dd%Kd_BBL(isd:ied,jsd:jed,nz+1), source=0.0) + + if (CS%id_Kd_bkgnd > 0) allocate(dd%Kd_bkgnd(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kv_bkgnd > 0) allocate(dd%Kv_bkgnd(isd:ied,jsd:jed,nz+1), source=0.) + + ! set up arrays for tidal mixing diagnostics + if (CS%use_tidal_mixing) & + call setup_tidal_diagnostics(G, GV, CS%tidal_mixing) + + if (CS%useKappaShear) then + if (CS%debug) then + call hchksum_pair("before calc_KS [uv]_h", u_h, v_h, G%HI, scale=US%L_T_to_m_s) + endif + call cpu_clock_begin(id_clock_kappaShear) + if (CS%Vertex_shear) then + call full_convection(G, GV, US, h, tv, T_f, S_f, fluxes%p_surf, & + kappa_dt_fill, halo=1) + + call calc_kappa_shear_vertex(u, v, h, T_f, S_f, tv, fluxes%p_surf, visc%Kd_shear, & + visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) + if (associated(visc%Kv_shear)) visc%Kv_shear(:,:,:) = 0.0 ! needed for other parameterizations + if (CS%debug) then + call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) + call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu", G%HI, scale=GV%HZ_T_to_m2_s) + call Bchksum(visc%TKE_turb, "after calc_KS_vert visc%TKE_turb", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + endif + else + ! Changes: visc%Kd_shear ; Sets: visc%Kv_shear and visc%TKE_turb + call calculate_kappa_shear(u_h, v_h, h, tv, fluxes%p_surf, visc%Kd_shear, visc%TKE_turb, & + visc%Kv_shear, dt, G, GV, US, CS%kappaShear_CSp) + if (CS%debug) then + call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, scale=GV%HZ_T_to_m2_s) + call hchksum(visc%TKE_turb, "after calc_KS visc%TKE_turb", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + endif + endif + call cpu_clock_end(id_clock_kappaShear) + if (showCallTree) call callTree_waypoint("done with calculate_kappa_shear (set_diffusivity)") + elseif (CS%use_CVMix_shear) then + !NOTE{BGR}: this needs to be cleaned up. It works in 1D case, but has not been tested outside. + call calculate_CVMix_shear(u_h, v_h, h, tv, visc%Kd_shear, visc%Kv_shear, G, GV, US, CS%CVMix_shear_CSp) + if (CS%debug) then + call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear", G%HI, scale=GV%HZ_T_to_m2_s) + endif + elseif (associated(visc%Kv_shear)) then + visc%Kv_shear(:,:,:) = 0.0 ! needed if calculate_kappa_shear is not enabled + endif + + ! Smooth the properties through massless layers. + if (use_EOS) then + if (CS%debug) then + call hchksum(tv%T, "before vert_fill_TS tv%T", G%HI, scale=US%C_to_degC) + call hchksum(tv%S, "before vert_fill_TS tv%S", G%HI, scale=US%S_to_ppt) + call hchksum(h, "before vert_fill_TS h",G%HI, scale=GV%H_to_m) + endif + call vert_fill_TS(h, tv%T, tv%S, kappa_dt_fill, T_f, S_f, G, GV, US, larger_h_denom=.true.) + if (CS%debug) then + call hchksum(tv%T, "after vert_fill_TS tv%T", G%HI, scale=US%C_to_degC) + call hchksum(tv%S, "after vert_fill_TS tv%S", G%HI, scale=US%S_to_ppt) + call hchksum(h, "after vert_fill_TS h",G%HI, scale=GV%H_to_m) + endif + endif + + ! Calculate the diffusivities, Kd_lay and Kd_int, for each layer and interface. This would + ! be an appropriate place to add a depth-dependent parameterization or another explicit + ! parameterization of Kd. + + !$OMP parallel do default(shared) private(dRho_int,N2_lay,Kd_lay_2d,Kd_int_2d,Kv_bkgnd,N2_int,dz, & + !$OMP N2_bot,rho_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb) & + !$OMP if(.not. CS%use_CVMix_ddiff) + do j=js,je + + ! Set up variables related to the stratification. + call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot, rho_bot) + + if (associated(dd%N2_3d)) then + do K=1,nz+1 ; do i=is,ie ; dd%N2_3d(i,j,K) = N2_int(i,K) ; enddo ; enddo + endif + + ! Add background mixing + call calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay_2d, Kd_int_2d, Kv_bkgnd, j, G, GV, US, CS%bkgnd_mixing_csp) + ! Update Kv and 3-d diffusivity diagnostics. + if (associated(visc%Kv_slow)) then ; do K=1,nz+1 ; do i=is,ie + visc%Kv_slow(i,j,K) = visc%Kv_slow(i,j,K) + Kv_bkgnd(i,K) + enddo ; enddo ; endif + if (CS%id_Kv_bkgnd > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kv_bkgnd(i,j,K) = Kv_bkgnd(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_bkgnd > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_bkgnd(i,j,K) = Kd_int_2d(i,K) + enddo ; enddo ; endif + + ! Double-diffusion (old method) + if (CS%double_diffusion) then + call double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, KT_extra, KS_extra) + ! One of Kd_extra_T and Kd_extra_S is always 0. Kd_extra_S is positive for salt fingering. + ! Kd_extra_T is positive for double diffusive convection. + do K=2,nz ; do i=is,ie + if (KS_extra(i,K) > KT_extra(i,K)) then ! salt fingering + Kd_lay_2d(i,k-1) = Kd_lay_2d(i,k-1) + 0.5 * KT_extra(i,K) + Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * KT_extra(i,K) + Kd_extra_S(i,j,K) = KS_extra(i,K) - KT_extra(i,K) + Kd_extra_T(i,j,K) = 0.0 + elseif (KT_extra(i,K) > 0.0) then ! double-diffusive convection + Kd_lay_2d(i,k-1) = Kd_lay_2d(i,k-1) + 0.5 * KS_extra(i,K) + Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * KS_extra(i,K) + Kd_extra_T(i,j,K) = KT_extra(i,K) - KS_extra(i,K) + Kd_extra_S(i,j,K) = 0.0 + else ! There is no double diffusion at this interface. + Kd_extra_T(i,j,K) = 0.0 + Kd_extra_S(i,j,K) = 0.0 + endif + enddo ; enddo + if (associated(dd%KT_extra)) then ; do K=1,nz+1 ; do i=is,ie + dd%KT_extra(i,j,K) = KT_extra(i,K) + enddo ; enddo ; endif + + if (associated(dd%KS_extra)) then ; do K=1,nz+1 ; do i=is,ie + dd%KS_extra(i,j,K) = KS_extra(i,K) + enddo ; enddo ; endif + endif + + ! Apply double diffusion via CVMix + ! GMM, we need to pass HBL to compute_ddiff_coeffs, but it is not yet available. + if (CS%use_CVMix_ddiff) then + call cpu_clock_begin(id_clock_CVMix_ddiff) + if (associated(dd%drho_rat)) then + call compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_extra_T, Kd_extra_S, & + CS%CVMix_ddiff_csp, dd%drho_rat) + else + call compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_extra_T, Kd_extra_S, CS%CVMix_ddiff_csp) + endif + call cpu_clock_end(id_clock_CVMix_ddiff) + endif + + ! Calculate conversion ratios from TKE to layer diffusivities. + if (TKE_to_Kd_used) then + call find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, TKE_to_Kd, maxTKE, kb) + if (associated(dd%maxTKE)) then ; do k=1,nz ; do i=is,ie + dd%maxTKE(i,j,k) = maxTKE(i,k) + enddo ; enddo ; endif + if (associated(dd%TKE_to_Kd)) then ; do k=1,nz ; do i=is,ie + dd%TKE_to_Kd(i,j,k) = TKE_to_Kd(i,k) + enddo ; enddo ; endif + endif + + ! Add the input turbulent diffusivity. + if (CS%useKappaShear .or. CS%use_CVMix_shear) then + do K=2,nz ; do i=is,ie + Kd_int_2d(i,K) = visc%Kd_shear(i,j,K) + 0.5 * (Kd_lay_2d(i,k-1) + Kd_lay_2d(i,k)) + enddo ; enddo + do i=is,ie + Kd_int_2d(i,1) = visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. + Kd_int_2d(i,nz+1) = 0.0 + enddo + do k=1,nz ; do i=is,ie + Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * (visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) + enddo ; enddo + else + do i=is,ie + Kd_int_2d(i,1) = Kd_lay_2d(i,1) ; Kd_int_2d(i,nz+1) = 0.0 + enddo + do K=2,nz ; do i=is,ie + Kd_int_2d(i,K) = 0.5 * (Kd_lay_2d(i,k-1) + Kd_lay_2d(i,k)) + enddo ; enddo + endif + + if (CS%ML_radiation .or. CS%use_tidal_mixing .or. associated(dd%Kd_work)) then + call thickness_to_dz(h, tv, dz, j, G, GV) + endif + + ! Add the ML_Rad diffusivity. + if (CS%ML_radiation) then + call add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int_2d, G, GV, US, CS, TKE_to_Kd, Kd_lay_2d) + endif + + ! Add the Nikurashin and / or tidal bottom-driven mixing + if (CS%use_tidal_mixing) & + call calculate_tidal_mixing(dz, j, N2_bot, rho_bot, N2_lay, N2_int, TKE_to_Kd, & + maxTKE, G, GV, US, CS%tidal_mixing, & + CS%Kd_max, visc%Kv_slow, Kd_lay_2d, Kd_int_2d) + + ! This adds the diffusion sustained by the energy extracted from the flow by the bottom drag. + if (CS%bottomdraglaw .and. (CS%BBL_effic > 0.0)) then + if (CS%use_LOTW_BBL_diffusivity) then + call add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bot, Kd_int_2d, & + G, GV, US, CS, dd%Kd_BBL, Kd_lay_2d) + else + call add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & + maxTKE, kb, rho_bot, G, GV, US, CS, Kd_lay_2d, Kd_int_2d, dd%Kd_BBL) + endif + endif + + if (CS%limit_dissipation) then + ! This calculates the dissipation ONLY from Kd calculated in this routine + ! dissip has units of W/m3 (= kg/m3 * m2/s * 1/s2) + ! 1) a global constant, + ! 2) a dissipation proportional to N (aka Gargett) and + ! 3) dissipation corresponding to a (nearly) constant diffusivity. + do K=2,nz ; do i=is,ie + dissip = max( CS%dissip_min, & ! Const. floor on dissip. + CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_int(i,K)), & ! Floor aka Gargett + CS%dissip_N2 * N2_int(i,K)) ! Floor of Kd_min*rho0/F_Ri + Kd_int_2d(i,K) = max(Kd_int_2d(i,K) , & ! Apply floor to Kd + dissip * (CS%FluxRi_max / (GV%H_to_RZ * (N2_int(i,K) + Omega2)))) + enddo ; enddo + endif + + ! Optionally add a uniform diffusivity at the interfaces. + if (CS%Kd_add > 0.0) then ; do K=1,nz+1 ; do i=is,ie + Kd_int_2d(i,K) = Kd_int_2d(i,K) + CS%Kd_add + enddo ; enddo ; endif + + ! Copy the 2-d slices into the 3-d array that is exported. + do K=1,nz+1 ; do i=is,ie + Kd_int(i,j,K) = Kd_int_2d(i,K) + enddo ; enddo + + if (CS%limit_dissipation) then + ! This calculates the layer dissipation ONLY from Kd calculated in this routine + ! dissip has units of W/m3 (= kg/m3 * m2/s * 1/s2) + ! 1) a global constant, + ! 2) a dissipation proportional to N (aka Gargett) and + ! 3) dissipation corresponding to a (nearly) constant diffusivity. + do k=2,nz-1 ; do i=is,ie + dissip = max( CS%dissip_min, & ! Const. floor on dissip. + CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_lay(i,k)), & ! Floor aka Gargett + CS%dissip_N2 * N2_lay(i,k)) ! Floor of Kd_min*rho0/F_Ri + Kd_lay_2d(i,k) = max(Kd_lay_2d(i,k) , & ! Apply floor to Kd + dissip * (CS%FluxRi_max / (GV%H_to_RZ * (N2_lay(i,k) + Omega2)))) + enddo ; enddo + endif + + if (associated(dd%Kd_work)) then + do k=1,nz ; do i=is,ie + dd%Kd_Work(i,j,k) = GV%H_to_RZ * Kd_lay_2d(i,k) * N2_lay(i,k) * dz(i,k) ! Watt m-2 = kg s-3 + enddo ; enddo + endif + + ! Optionally add a uniform diffusivity to the layers. + if ((CS%Kd_add > 0.0) .and. (present(Kd_lay))) then + do k=1,nz ; do i=is,ie + Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + CS%Kd_add + enddo ; enddo + endif + + ! Copy the 2-d slices into the 3-d array that is exported; this was done above for Kd_int. + if (present(Kd_lay)) then ; do k=1,nz ; do i=is,ie + Kd_lay(i,j,k) = Kd_lay_2d(i,k) + enddo ; enddo ; endif + enddo ! j-loop + + if (CS%user_change_diff) then + call user_change_diff(h, tv, G, GV, US, CS%user_change_diff_CSp, Kd_lay, Kd_int, & + T_f, S_f, dd%Kd_user) + endif + + if (CS%debug) then + if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + + if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + + if (CS%use_CVMix_ddiff) then + call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + + if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) then + call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & + haloshift=0, symmetric=.true., scale=GV%HZ_T_to_m2_s, & + scalar_pair=.true.) + endif + + if (allocated(visc%bbl_thick_u) .and. allocated(visc%bbl_thick_v)) then + call uvchksum("BBL bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, & + G%HI, haloshift=0, symmetric=.true., scale=US%Z_to_m, & + scalar_pair=.true.) + endif + + if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) then + call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, & + symmetric=.true., scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) + endif + + endif + + ! post diagnostics + if (present(Kd_lay) .and. (CS%id_Kd_layer > 0)) call post_data(CS%id_Kd_layer, Kd_lay, CS%diag) + + ! background mixing + if (CS%id_Kd_bkgnd > 0) call post_data(CS%id_Kd_bkgnd, dd%Kd_bkgnd, CS%diag) + if (CS%id_Kv_bkgnd > 0) call post_data(CS%id_Kv_bkgnd, dd%Kv_bkgnd, CS%diag) + + ! tidal mixing + if (CS%use_tidal_mixing) & + call post_tidal_diagnostics(G, GV, h, CS%tidal_mixing) + + if (CS%id_N2 > 0) call post_data(CS%id_N2, dd%N2_3d, CS%diag) + if (CS%id_Kd_Work > 0) call post_data(CS%id_Kd_Work, dd%Kd_Work, CS%diag) + if (CS%id_maxTKE > 0) call post_data(CS%id_maxTKE, dd%maxTKE, CS%diag) + if (CS%id_TKE_to_Kd > 0) call post_data(CS%id_TKE_to_Kd, dd%TKE_to_Kd, CS%diag) + + if (CS%id_Kd_user > 0) call post_data(CS%id_Kd_user, dd%Kd_user, CS%diag) + + ! double diffusive mixing + if (CS%double_diffusion) then + if (CS%id_KT_extra > 0) call post_data(CS%id_KT_extra, dd%KT_extra, CS%diag) + if (CS%id_KS_extra > 0) call post_data(CS%id_KS_extra, dd%KS_extra, CS%diag) + elseif (CS%use_CVMix_ddiff) then + if (CS%id_KT_extra > 0) call post_data(CS%id_KT_extra, Kd_extra_T, CS%diag) + if (CS%id_KS_extra > 0) call post_data(CS%id_KS_extra, Kd_extra_S, CS%diag) + if (CS%id_R_rho > 0) call post_data(CS%id_R_rho, dd%drho_rat, CS%diag) + endif + if (CS%id_Kd_BBL > 0) call post_data(CS%id_Kd_BBL, dd%Kd_BBL, CS%diag) + + if (associated(dd%N2_3d)) deallocate(dd%N2_3d) + if (associated(dd%Kd_work)) deallocate(dd%Kd_work) + if (associated(dd%Kd_user)) deallocate(dd%Kd_user) + if (associated(dd%maxTKE)) deallocate(dd%maxTKE) + if (associated(dd%TKE_to_Kd)) deallocate(dd%TKE_to_Kd) + if (associated(dd%KT_extra)) deallocate(dd%KT_extra) + if (associated(dd%KS_extra)) deallocate(dd%KS_extra) + if (associated(dd%drho_rat)) deallocate(dd%drho_rat) + if (associated(dd%Kd_BBL)) deallocate(dd%Kd_BBL) + if (associated(dd%Kd_bkgnd)) deallocate(dd%Kd_bkgnd) + if (associated(dd%Kv_bkgnd)) deallocate(dd%Kv_bkgnd) + + if (showCallTree) call callTree_leave("set_diffusivity()") + +end subroutine set_diffusivity + +!> Convert turbulent kinetic energy to diffusivity +subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & + TKE_to_Kd, maxTKE, kb) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: dRho_int !< Change in locally referenced potential density + !! across each interface [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the + !! layers [T-2 ~> s-2]. + integer, intent(in) :: j !< j-index of row to work on + real, intent(in) :: dt !< Time increment [T ~> s]. + type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: TKE_to_Kd !< The conversion rate between the + !! TKE dissipated within a layer and the + !! diapycnal diffusivity within that layer, + !! usually (~Rho_0 / (G_Earth * dRho_lay)) + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: maxTKE !< The energy required to for a layer to entrain to its + !! maximum realizable thickness [H Z2 T-3 ~> m3 s-3 or W m-2] + integer, dimension(SZI_(G)), intent(out) :: kb !< Index of lightest layer denser than the buffer + !! layer, or -1 without a bulk mixed layer. + ! Local variables + real, dimension(SZI_(G),SZK_(GV)) :: & + ds_dsp1, & ! coordinate variable (sigma-2) difference across an + ! interface divided by the difference across the interface + ! below it [nondim] + dsp1_ds, & ! inverse coordinate variable (sigma-2) difference + ! across an interface times the difference across the + ! interface above it [nondim] + rho_0, & ! Layer potential densities relative to surface pressure [R ~> kg m-3] + dz, & ! Height change across layers [Z ~> m] + maxEnt ! maxEnt is the maximum value of entrainment from below (with + ! compensating entrainment from above to keep the layer + ! density from changing) that will not deplete all of the + ! layers above or below a layer within a timestep [H ~> m or kg m-2]. + real, dimension(SZI_(G)) :: & + htot, & ! total thickness above or below a layer, or the + ! integrated thickness in the BBL [H ~> m or kg m-2]. + mFkb, & ! total thickness in the mixed and buffer layers times ds_dsp1 [H ~> m or kg m-2] + p_ref, & ! array of tv%P_Ref pressures [R L2 T-2 ~> Pa] + Rcv_kmb, & ! coordinate density in the lowest buffer layer [R ~> kg m-3] + p_0 ! An array of 0 pressures [R L2 T-2 ~> Pa] + + real :: dh_max ! maximum amount of entrainment a layer could undergo before + ! entraining all fluid in the layers above or below [H ~> m or kg m-2] + real :: dRho_lay ! density change across a layer [R ~> kg m-3] + real :: Omega2 ! rotation rate squared [T-2 ~> s-2] + real :: grav ! Gravitational acceleration [Z T-1 ~> m s-2] + real :: G_Rho0 ! Gravitational acceleration divided by Boussinesq reference density + ! [Z R-1 T-2 ~> m4 s-2 kg-1] + real :: G_IRho0 ! Alternate calculation of G_Rho0 with thickness rescaling factors + ! [Z2 T-2 R-1 H-1 ~> m4 s-2 kg-1 or m7 kg-2 s-2] + real :: I_dt ! 1/dt [T-1 ~> s-1] + real :: dz_neglect ! A negligibly small height change [Z ~> m] + real :: hN2pO2 ! h (N^2 + Omega^2), in [Z T-2 ~> m s-2]. + logical :: do_i(SZI_(G)) + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, k, is, ie, nz, i_rem, kmb, kb_min + is = G%isc ; ie = G%iec ; nz = GV%ke + + I_dt = 1.0 / dt + Omega2 = CS%omega**2 + dz_neglect = GV%dZ_subroundoff + grav = (US%L_to_Z**2 * GV%g_Earth) + G_Rho0 = grav / GV%Rho0 + if (CS%answer_date < 20190101) then + G_IRho0 = grav * GV%H_to_Z**2 * GV%RZ_to_H + else + G_IRho0 = GV%H_to_Z*G_Rho0 + endif + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + ! Simple but coordinate-independent estimate of Kd/TKE + if (CS%simple_TKE_to_Kd) then + do k=1,nz ; do i=is,ie + hN2pO2 = dz(i,k) * (N2_lay(i,k) + Omega2) ! Units of Z T-2. + if (hN2pO2 > 0.) then + TKE_to_Kd(i,k) = 1.0 / hN2pO2 ! Units of T2 H-1. + else ; TKE_to_Kd(i,k) = 0. ; endif + ! The maximum TKE conversion we allow is really a statement + ! about the upper diffusivity we allow. Kd_max must be set. + maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of H Z2 T-3. + enddo ; enddo + kb(is:ie) = -1 ! kb should not be used by any code in non-layered mode -AJA + return + endif + + ! Determine kb - the index of the shallowest active interior layer. + if (CS%bulkmixedlayer) then + kmb = GV%nk_rho_varies + do i=is,ie ; p_0(i) = 0.0 ; p_ref(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) + do k=1,nz + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_0, rho_0(:,k), tv%eqn_of_state, EOSdom) + enddo + call calculate_density(tv%T(:,j,kmb), tv%S(:,j,kmb), p_ref, Rcv_kmb, tv%eqn_of_state, EOSdom) + + kb_min = kmb+1 + do i=is,ie + ! Determine the next denser layer than the buffer layer in the + ! coordinate density (sigma-2). + do k=kmb+1,nz-1 ; if (Rcv_kmb(i) <= GV%Rlay(k)) exit ; enddo + kb(i) = k + + ! Backtrack, in case there are massive layers above that are stable + ! in sigma-0. + do k=kb(i)-1,kmb+1,-1 + if (rho_0(i,kmb) > rho_0(i,k)) exit + if (h(i,j,k)>2.0*GV%Angstrom_H) kb(i) = k + enddo + enddo + + call set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) + else ! not bulkmixedlayer + kb_min = 2 ; kmb = 0 + do i=is,ie ; kb(i) = 1 ; enddo + call set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1) + endif + + ! Determine maxEnt - the maximum permitted entrainment from below by each + ! interior layer. + do k=2,nz-1 ; do i=is,ie + dsp1_ds(i,k) = 1.0 / ds_dsp1(i,k) + enddo ; enddo + do i=is,ie ; dsp1_ds(i,nz) = 0.0 ; enddo + + if (CS%bulkmixedlayer) then + kmb = GV%nk_rho_varies + do i=is,ie + htot(i) = h(i,j,kmb) + mFkb(i) = 0.0 + if (kb(i) < nz) mFkb(i) = ds_dsp1(i,kb(i)) * (h(i,j,kmb) - GV%Angstrom_H) + enddo + do k=1,kmb-1 ; do i=is,ie + htot(i) = htot(i) + h(i,j,k) + mFkb(i) = mFkb(i) + ds_dsp1(i,k+1)*(h(i,j,k) - GV%Angstrom_H) + enddo ; enddo + else + do i=is,i + maxEnt(i,1) = 0.0 ; htot(i) = h(i,j,1) - GV%Angstrom_H + enddo + endif + do k=kb_min,nz-1 ; do i=is,ie + if (k == kb(i)) then + maxEnt(i,kb(i)) = mFkb(i) + elseif (k > kb(i)) then + if (CS%answer_date < 20190101) then + maxEnt(i,k) = (1.0/dsp1_ds(i,k))*(maxEnt(i,k-1) + htot(i)) + else + maxEnt(i,k) = ds_dsp1(i,k)*(maxEnt(i,k-1) + htot(i)) + endif + htot(i) = htot(i) + (h(i,j,k) - GV%Angstrom_H) + endif + enddo ; enddo + + do i=is,ie + htot(i) = h(i,j,nz) - GV%Angstrom_H ; maxEnt(i,nz) = 0.0 + do_i(i) = (G%mask2dT(i,j) > 0.0) + enddo + do k=nz-1,kb_min,-1 + i_rem = 0 + do i=is,ie ; if (do_i(i)) then + if (k Calculate Brunt-Vaisala frequency, N^2. +subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & + N2_lay, N2_int, N2_bot, Rho_bot) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: T_f !< layer temperature with the values in massless layers + !! filled vertically by diffusion [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: S_f !< Layer salinities with values in massless + !! layers filled vertically by diffusion [S ~> ppt]. + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + integer, intent(in) :: j !< j-index of row to work on + type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(out) :: dRho_int !< Change in locally referenced potential density + !! across each interface [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(out) :: N2_int !< The squared buoyancy frequency at the interfaces [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(out) :: N2_lay !< The squared buoyancy frequency of the layers [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(out) :: N2_bot !< The near-bottom squared buoyancy frequency [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + + ! Local variables + real, dimension(SZI_(G),SZK_(GV)+1) :: & + pres, & ! pressure at each interface [R L2 T-2 ~> Pa] + dRho_int_unfilt, & ! unfiltered density differences across interfaces [R ~> kg m-3] + dRho_dT, & ! partial derivative of density wrt temp [R C-1 ~> kg m-3 degC-1] + dRho_dS ! partial derivative of density wrt saln [R S-1 ~> kg m-3 ppt-1] + real, dimension(SZI_(G),SZK_(GV)) :: & + dz ! Height change across layers [Z ~> m] + real, dimension(SZI_(G)) :: & + Temp_int, & ! temperature at each interface [C ~> degC] + Salin_int, & ! salinity at each interface [S ~> ppt] + drho_bot, & ! A density difference [R ~> kg m-3] + h_amp, & ! The topographic roughness amplitude [Z ~> m]. + dz_BBL_avg, & ! The distance over which to average to find the near-bottom density [Z ~> m] + hb, & ! The thickness of the bottom layer [H ~> m or kg m-2] + z_from_bot ! The height above the bottom [Z ~> m] + + real :: dz_int ! Vertical distance associated with an interface [Z ~> m] + real :: G_Rho0 ! Gravitational acceleration, perhaps divided by Boussinesq reference density, + ! times some unit conversion factors [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. + real :: H_neglect ! A negligibly small thickness [H ~> m or kg m-2] + + logical :: do_i(SZI_(G)), do_any + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, k, is, ie, nz + + is = G%isc ; ie = G%iec ; nz = GV%ke + G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%H_to_RZ + H_neglect = GV%H_subroundoff + + ! Find the (limited) density jump across each interface. + do i=is,ie + dRho_int(i,1) = 0.0 ; dRho_int(i,nz+1) = 0.0 + dRho_int_unfilt(i,1) = 0.0 ; dRho_int_unfilt(i,nz+1) = 0.0 + enddo + if (associated(tv%eqn_of_state)) then + if (associated(fluxes%p_surf)) then + do i=is,ie ; pres(i,1) = fluxes%p_surf(i,j) ; enddo + else + do i=is,ie ; pres(i,1) = 0.0 ; enddo + endif + EOSdom(:) = EOS_domain(G%HI) + do K=2,nz + do i=is,ie + pres(i,K) = pres(i,K-1) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) + Temp_Int(i) = 0.5 * (T_f(i,j,k) + T_f(i,j,k-1)) + Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) + enddo + call calculate_density_derivs(Temp_int, Salin_int, pres(:,K), dRho_dT(:,K), dRho_dS(:,K), & + tv%eqn_of_state, EOSdom) + do i=is,ie + dRho_int(i,K) = max(dRho_dT(i,K)*(T_f(i,j,k) - T_f(i,j,k-1)) + & + dRho_dS(i,K)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) + dRho_int_unfilt(i,K) = max(dRho_dT(i,K)*(tv%T(i,j,k) - tv%T(i,j,k-1)) + & + dRho_dS(i,K)*(tv%S(i,j,k) - tv%S(i,j,k-1)), 0.0) + enddo + enddo + else + do K=2,nz ; do i=is,ie + dRho_int(i,K) = GV%Rlay(k) - GV%Rlay(k-1) + enddo ; enddo + endif + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + ! Set the buoyancy frequencies. + do k=1,nz ; do i=is,ie + N2_lay(i,k) = G_Rho0 * 0.5*(dRho_int(i,K) + dRho_int(i,K+1)) / & + (h(i,j,k) + H_neglect) + enddo ; enddo + do i=is,ie ; N2_int(i,1) = 0.0 ; N2_int(i,nz+1) = 0.0 ; enddo + do K=2,nz ; do i=is,ie + N2_int(i,K) = G_Rho0 * dRho_int(i,K) / & + (0.5*(h(i,j,k-1) + h(i,j,k) + H_neglect)) + enddo ; enddo + + ! Find the bottom boundary layer stratification, and use this in the deepest layers. + do i=is,ie + hb(i) = 0.0 ; dRho_bot(i) = 0.0 ; h_amp(i) = 0.0 + z_from_bot(i) = 0.5*dz(i,nz) + do_i(i) = (G%mask2dT(i,j) > 0.0) + enddo + if (CS%use_tidal_mixing) call tidal_mixing_h_amp(h_amp, G, j, CS%tidal_mixing) + + do k=nz,2,-1 + do_any = .false. + do i=is,ie ; if (do_i(i)) then + dz_int = 0.5*(dz(i,k) + dz(i,k-1)) + z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above + + hb(i) = hb(i) + 0.5*(h(i,j,k) + h(i,j,k-1)) + drho_bot(i) = drho_bot(i) + dRho_int(i,K) + + if (z_from_bot(i) > h_amp(i)) then + if (k>2) then + ! Always include at least one full layer. + hb(i) = hb(i) + 0.5*(h(i,j,k-1) + h(i,j,k-2)) + drho_bot(i) = drho_bot(i) + dRho_int(i,K-1) + endif + do_i(i) = .false. + else + do_any = .true. + endif + endif ; enddo + if (.not.do_any) exit + enddo + + do i=is,ie + if (hb(i) > 0.0) then + N2_bot(i) = (G_Rho0 * drho_bot(i)) / hb(i) + else ; N2_bot(i) = 0.0 ; endif + z_from_bot(i) = 0.5*dz(i,nz) + do_i(i) = (G%mask2dT(i,j) > 0.0) + enddo + + do k=nz,2,-1 + do_any = .false. + do i=is,ie ; if (do_i(i)) then + dz_int = 0.5*(dz(i,k) + dz(i,k-1)) + z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above + + N2_int(i,K) = N2_bot(i) + if (k>2) N2_lay(i,k-1) = N2_bot(i) + + if (z_from_bot(i) > h_amp(i)) then + if (k>2) N2_int(i,K-1) = N2_bot(i) + do_i(i) = .false. + else + do_any = .true. + endif + endif ; enddo + if (.not.do_any) exit + enddo + + if (associated(tv%eqn_of_state)) then + do K=1,nz+1 ; do i=is,ie + dRho_int(i,K) = dRho_int_unfilt(i,K) + enddo ; enddo + endif + + ! Average over the larger of the envelope of the topography or a minimal distance. + do i=is,ie ; dz_BBL_avg(i) = max(h_amp(i), CS%dz_BBL_avg_min) ; enddo + call find_rho_bottom(h, dz, pres, dz_BBL_avg, tv, j, G, GV, US, Rho_bot) + +end subroutine find_N2 + +!> This subroutine sets the additional diffusivities of temperature and +!! salinity due to double diffusion, using the same functional form as is +!! used in MOM4.1, and taken from an NCAR technical note (REF?) that updates +!! what was in Large et al. (1994). All the coefficients here should probably +!! be made run-time variables rather than hard-coded constants. +!! +!! \todo Find reference for NCAR tech note above. +subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields; absent fields have NULL ptrs. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: T_f !< layer temperatures with the values in massless layers + !! filled vertically by diffusion [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: S_f !< Layer salinities with values in massless + !! layers filled vertically by diffusion [S ~> ppt]. + integer, intent(in) :: j !< Meridional index upon which to work. + type(set_diffusivity_CS), pointer :: CS !< Module control structure. + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(out) :: Kd_T_dd !< Interface double diffusion diapycnal + !! diffusivity for temp [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(out) :: Kd_S_dd !< Interface double diffusion diapycnal + !! diffusivity for saln [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + real, dimension(SZI_(G)) :: & + dRho_dT, & ! partial derivatives of density with respect to temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & ! partial derivatives of density with respect to salinity [R S-1 ~> kg m-3 ppt-1] + pres, & ! pressure at each interface [R L2 T-2 ~> Pa] + Temp_int, & ! temperature at interfaces [C ~> degC] + Salin_int ! Salinity at interfaces [S ~> ppt] + + real :: alpha_dT ! density difference between layers due to temp diffs [R ~> kg m-3] + real :: beta_dS ! density difference between layers due to saln diffs [R ~> kg m-3] + + real :: Rrho ! vertical density ratio [nondim] + real :: diff_dd ! factor for double-diffusion [nondim] + real :: Kd_dd ! The dominant double diffusive diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: prandtl ! flux ratio for diffusive convection regime [nondim] + + real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio [nondim] + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, k, is, ie, nz + is = G%isc ; ie = G%iec ; nz = GV%ke + + if (associated(tv%eqn_of_state)) then + do i=is,ie + pres(i) = 0.0 ; Kd_T_dd(i,1) = 0.0 ; Kd_S_dd(i,1) = 0.0 + Kd_T_dd(i,nz+1) = 0.0 ; Kd_S_dd(i,nz+1) = 0.0 + enddo + if (associated(tv%p_surf)) then ; do i=is,ie ; pres(i) = tv%p_surf(i,j) ; enddo ; endif + EOSdom(:) = EOS_domain(G%HI) + do K=2,nz + do i=is,ie + pres(i) = pres(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) + Temp_Int(i) = 0.5 * (T_f(i,j,k-1) + T_f(i,j,k)) + Salin_Int(i) = 0.5 * (S_f(i,j,k-1) + S_f(i,j,k)) + enddo + call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT, dRho_dS, & + tv%eqn_of_state, EOSdom) + + do i=is,ie + alpha_dT = -1.0*dRho_dT(i) * (T_f(i,j,k-1) - T_f(i,j,k)) + beta_dS = dRho_dS(i) * (S_f(i,j,k-1) - S_f(i,j,k)) + + if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then ! salt finger case + Rrho = min(alpha_dT / beta_dS, Rrho0) + diff_dd = 1.0 - ((RRho-1.0)/(RRho0-1.0)) + Kd_dd = CS%Max_salt_diff_salt_fingers * diff_dd*diff_dd*diff_dd + Kd_T_dd(i,K) = 0.7 * Kd_dd + Kd_S_dd(i,K) = Kd_dd + elseif ((alpha_dT < 0.) .and. (beta_dS < 0.) .and. (alpha_dT > beta_dS)) then ! diffusive convection + Rrho = alpha_dT / beta_dS + Kd_dd = CS%Kv_molecular * 0.909 * exp(4.6 * exp(-0.54 * (1/Rrho - 1))) + prandtl = 0.15*Rrho + if (Rrho > 0.5) prandtl = (1.85-0.85/Rrho)*Rrho + Kd_T_dd(i,K) = Kd_dd + Kd_S_dd(i,K) = prandtl * Kd_dd + else + Kd_T_dd(i,K) = 0.0 ; Kd_S_dd(i,K) = 0.0 + endif + enddo + enddo + endif + +end subroutine double_diffusion + +!> This routine adds diffusion sustained by flow energy extracted by bottom drag. +subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, & + kb, rho_bot, G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + type(vertvisc_type), intent(in) :: visc !< Structure containing vertical viscosities, bottom + !! boundary layer properties and related fields + integer, intent(in) :: j !< j-index of row to work on + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE + !! TKE dissipated within a layer and the + !! diapycnal diffusivity within that layer, + !! usually (~Rho_0 / (G_Earth * dRho_lay)) + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: maxTKE !< The energy required to for a layer to entrain to its + !! maximum-realizable thickness [H Z2 T-3 ~> m3 s-3 or W m-2] + integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer + !! layer, or -1 without a bulk mixed layer + real, dimension(SZI_(G)), intent(in) :: rho_bot !< In situ density averaged over a near-bottom + !! region [R ~> kg m-3] + type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers, + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces, + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + +! This routine adds diffusion sustained by flow energy extracted by bottom drag. + + real, dimension(SZK_(GV)+1) :: & + Rint ! coordinate density of an interface [R ~> kg m-3] + real, dimension(SZI_(G)) :: & + htot, & ! total thickness above or below a layer, or the + ! integrated thickness in the BBL [H ~> m or kg m-2]. + rho_htot, & ! running integral with depth of density [R H ~> kg m-2 or kg2 m-5] + gh_sum_top, & ! BBL value of g'h that can be supported by + ! the local ustar, times R0_g [R H ~> kg m-2 or kg2 m-5] + Rho_top, & ! density at top of the BBL [R ~> kg m-3] + TKE, & ! turbulent kinetic energy available to drive + ! bottom-boundary layer mixing in a layer [H Z2 T-3 ~> m3 s-3 or W m-2] + I2decay ! inverse of twice the TKE decay scale [H-1 ~> m-1 or m2 kg-1]. + + real :: TKE_to_layer ! TKE used to drive mixing in a layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_here ! TKE that goes into mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: dRl, dRbot ! temporaries holding density differences [R ~> kg m-3] + real :: cdrag_sqrt ! square root of the drag coefficient [nondim] + real :: ustar_h ! Ustar at a thickness point rescaled into thickness + ! flux units [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: absf ! average absolute Coriolis parameter around a thickness point [T-1 ~> s-1] + real :: R0_g ! Rho0 / G_Earth [R T2 H-1 ~> kg s2 m-4 or s2 m-1] + real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + logical :: Rayleigh_drag ! Set to true if Rayleigh drag velocities + ! defined in visc, on the assumption that this + ! extracted energy also drives diapycnal mixing. + + logical :: domore, do_i(SZI_(G)) + logical :: do_diag_Kd_BBL + + integer :: i, k, is, ie, nz, i_rem, kb_min + is = G%isc ; ie = G%iec ; nz = GV%ke + + do_diag_Kd_BBL = associated(Kd_BBL) + + if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic > 0.0))) return + + cdrag_sqrt = sqrt(CS%cdrag) + TKE_Ray = 0.0 ; Rayleigh_drag = .false. + if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. + + R0_g = GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth) + + do K=2,nz ; Rint(K) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo + + kb_min = max(GV%nk_rho_varies+1,2) + + ! The turbulence decay scale is 0.5*ustar/f from K&E & MOM_vertvisc.F90 + ! Any turbulence that makes it into the mixed layers is assumed + ! to be relatively small and is discarded. + do i=is,ie + ustar_h = visc%ustar_BBL(i,j) + if (associated(fluxes%ustar_tidal)) then + if (allocated(tv%SpV_avg)) then + ustar_h = ustar_h + GV%RZ_to_H*rho_bot(i) * fluxes%ustar_tidal(i,j) + else + ustar_h = ustar_h + GV%Z_to_H * fluxes%ustar_tidal(i,j) + endif + endif + absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) + if ((ustar_h > 0.0) .and. (absf > 0.5*CS%IMax_decay*ustar_h)) then + I2decay(i) = absf / ustar_h + else + ! The maximum decay scale should be something of order 200 m. + ! If ustar_h = 0, this is land so this value doesn't matter. + I2decay(i) = 0.5*CS%IMax_decay + endif + TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*h(i,j,nz)) ) * visc%TKE_BBL(i,j) + + if (associated(fluxes%TKE_tidal)) & + TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * GV%RZ_to_H * & + (CS%BBL_effic * exp(-I2decay(i)*h(i,j,nz))) + + ! Distribute the work over a BBL of depth 20^2 ustar^2 / g' following + ! Killworth & Edwards (1999) and Zilitikevich & Mironov (1996). + ! Rho_top is determined by finding the density where + ! integral(bottom, Z) (rho(z') - rho(Z)) dz' = rho_0 400 ustar^2 / g + + gh_sum_top(i) = R0_g * 400.0 * ustar_h**2 + + do_i(i) = (G%mask2dT(i,j) > 0.0) + htot(i) = h(i,j,nz) + rho_htot(i) = GV%Rlay(nz)*(h(i,j,nz)) + Rho_top(i) = GV%Rlay(1) + if (CS%bulkmixedlayer .and. do_i(i)) Rho_top(i) = GV%Rlay(kb(i)-1) + enddo + + do k=nz-1,2,-1 ; domore = .false. + do i=is,ie ; if (do_i(i)) then + htot(i) = htot(i) + h(i,j,k) + rho_htot(i) = rho_htot(i) + GV%Rlay(k)*(h(i,j,k)) + if (htot(i)*GV%Rlay(k-1) <= (rho_htot(i) - gh_sum_top(i))) then + ! The top of the mixing is in the interface atop the current layer. + Rho_top(i) = (rho_htot(i) - gh_sum_top(i)) / htot(i) + do_i(i) = .false. + elseif (k <= kb(i)) then ; do_i(i) = .false. + else ; domore = .true. ; endif + endif ; enddo + if (.not.domore) exit + enddo ! k-loop + + 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 + if (k 0.0) then + if (Rint(K) <= Rho_top(i)) then + TKE_to_layer = TKE(i) + else + dRl = Rint(K+1) - Rint(K) ; dRbot = Rint(K+1) - Rho_top(i) + TKE_to_layer = TKE(i) * dRl * & + (3.0*dRbot*(Rint(K) - Rho_top(i)) + dRl**2) / (dRbot**3) + endif + else ; TKE_to_layer = 0.0 ; endif + + ! TKE_Ray has been initialized to 0 above. + if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * & + ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & + G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & + (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & + G%areaCv(i,J) * visc%Ray_v(i,J,k) * v(i,J,k)**2)) + + if (TKE_to_layer + TKE_Ray > 0.0) then + if (CS%BBL_mixing_as_max) then + if (TKE_to_layer + TKE_Ray > maxTKE(i,k)) & + TKE_to_layer = maxTKE(i,k) - TKE_Ray + + TKE(i) = TKE(i) - TKE_to_layer + + if (Kd_lay(i,k) < (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k)) then + delta_Kd = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) - Kd_lay(i,k) + if ((CS%Kd_max >= 0.0) .and. (delta_Kd > CS%Kd_max)) then + delta_Kd = CS%Kd_max + Kd_lay(i,k) = Kd_lay(i,k) + delta_Kd + else + Kd_lay(i,k) = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) + endif + Kd_int(i,K) = Kd_int(i,K) + 0.5 * delta_Kd + Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * delta_Kd + if (do_diag_Kd_BBL) then + Kd_BBL(i,j,K) = Kd_BBL(i,j,K) + 0.5 * delta_Kd + Kd_BBL(i,j,K+1) = Kd_BBL(i,j,K+1) + 0.5 * delta_Kd + endif + endif + else + if (Kd_lay(i,k) >= maxTKE(i,k) * TKE_to_Kd(i,k)) then + TKE_here = 0.0 + TKE(i) = TKE(i) + TKE_Ray + elseif (Kd_lay(i,k) + (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) > & + maxTKE(i,k) * TKE_to_Kd(i,k)) then + TKE_here = ((TKE_to_layer + TKE_Ray) + Kd_lay(i,k) / TKE_to_Kd(i,k)) - maxTKE(i,k) + TKE(i) = (TKE(i) - TKE_here) + TKE_Ray + else + TKE_here = TKE_to_layer + TKE_Ray + TKE(i) = TKE(i) - TKE_to_layer + endif + if (TKE(i) < 0.0) TKE(i) = 0.0 ! This should be unnecessary? + + if (TKE_here > 0.0) then + delta_Kd = TKE_here * TKE_to_Kd(i,k) + if (CS%Kd_max >= 0.0) delta_Kd = min(delta_Kd, CS%Kd_max) + Kd_lay(i,k) = Kd_lay(i,k) + delta_Kd + Kd_int(i,K) = Kd_int(i,K) + 0.5 * delta_Kd + Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * delta_Kd + if (do_diag_Kd_BBL) then + Kd_BBL(i,j,K) = Kd_BBL(i,j,K) + 0.5 * delta_Kd + Kd_BBL(i,j,K+1) = Kd_BBL(i,j,K+1) + 0.5 * delta_Kd + endif + endif + endif + endif + + ! This may be risky - in the case that there are exactly zero + ! velocities at 4 neighboring points, but nonzero velocities + ! above the iterations would stop too soon. I don't see how this + ! could happen in practice. RWH + if ((TKE(i)<= 0.0) .and. (TKE_Ray == 0.0)) then + do_i(i) = .false. ; i_rem = i_rem - 1 + endif + + endif ; enddo + if (i_rem == 0) exit + enddo ! k-loop + +end subroutine add_drag_diffusivity + +!> Calculates a BBL diffusivity use a Prandtl number 1 diffusivity with a law of the +!! wall turbulent viscosity, up to a BBL height where the energy used for mixing has +!! consumed the mechanical TKE input. +subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bot, Kd_int, & + G, GV, US, CS, Kd_BBL, Kd_lay) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< u component of flow [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< v component of flow [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + type(forcing), intent(in) :: fluxes !< Surface fluxes structure + type(vertvisc_type), intent(in) :: visc !< Structure containing vertical viscosities, bottom + !! boundary layer properties and related fields. + integer, intent(in) :: j !< j-index of row to work on + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(in) :: N2_int !< Square of Brunt-Vaisala at interfaces [T-2 ~> s-2] + real, dimension(SZI_(G)), intent(in) :: rho_bot !< In situ density averaged over a near-bottom + !! region [R ~> kg m-3] + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(inout) :: Kd_int !< Interface net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZK_(GV)), & + optional, intent(inout) :: Kd_lay !< Layer net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + ! Local variables + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: TKE_column ! net TKE input into the column [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_consumed ! TKE used for mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: cdrag_sqrt ! square root of the drag coefficient [nondim] + real :: ustar ! value of ustar at a thickness point [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: ustar2 ! The square of ustar [H2 T-2 ~> m2 s-2 or kg2 m-4 s-2] + real :: absf ! average absolute value of Coriolis parameter around a thickness point [T-1 ~> s-1] + real :: dz_int ! Distance between the center of the layers around an interface [Z ~> m] + real :: z_bot ! Distance to interface K from bottom [Z ~> m] + real :: h_bot ! Total thickness between interface K and the bottom [H ~> m or kg m-2] + real :: D_minus_z ! Distance between interface k and the surface [Z ~> m] + real :: total_depth ! Total distance between the seafloor and the sea surface [Z ~> m] + real :: Idecay ! Inverse of decay scale used for "Joule heating" loss of TKE with + ! height [H-1 ~> m-1 or m2 kg-1]. + real :: Kd_wall ! Law of the wall diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_lower ! diffusivity for lower interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: ustar_D ! The extent of the water column times u* [H Z T-1 ~> m2 s-1 or Pa s]. + real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [T-2 ~> s-2] + logical :: Rayleigh_drag ! Set to true if there are Rayleigh drag velocities defined in visc, on + ! the assumption that this extracted energy also drives diapycnal mixing. + integer :: i, k + logical :: do_diag_Kd_BBL + + if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic > 0.0))) return + do_diag_Kd_BBL = associated(Kd_BBL) + + N2_min = 0. + if (CS%LOTW_BBL_use_omega) N2_min = CS%omega**2 + + ! Determine whether to add Rayleigh drag contribution to TKE + Rayleigh_drag = .false. + if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. + cdrag_sqrt = sqrt(CS%cdrag) + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + do i=G%isc,G%iec ! Developed in single-column mode + + ! Column-wise parameters. + absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) ! Non-zero on equator! + + ! u* at the bottom [H T-1 ~> m s-1 or kg m-2 s-1]. + ustar = visc%ustar_BBL(i,j) + ustar2 = ustar**2 + ! In add_drag_diffusivity(), fluxes%ustar_tidal is also added in. There is no + ! double-counting because the logic surrounding the calls to add_drag_diffusivity() + ! and add_LOTW_BBL_diffusivity() only calls one of the two routines. + if (associated(fluxes%ustar_tidal)) then + if (allocated(tv%SpV_avg)) then + ustar = ustar + GV%RZ_to_H*rho_bot(i) * fluxes%ustar_tidal(i,j) + else + ustar = ustar + GV%Z_to_H * fluxes%ustar_tidal(i,j) + endif + endif + + ! The maximum decay scale should be something of order 200 m. We use the smaller of u*/f and + ! (IMax_decay)^-1 as the decay scale. If ustar = 0, this is land so this value doesn't matter. + Idecay = CS%IMax_decay + if ((ustar > 0.0) .and. (absf > CS%IMax_decay * ustar)) Idecay = absf / ustar + + ! Energy input at the bottom [H Z2 T-3 ~> m3 s-3 or W m-2]. + ! (Note that visc%TKE_BBL is in [H Z2 T-3 ~> m3 s-3 or W m-2], set in set_BBL_TKE().) + ! I am still unsure about sqrt(cdrag) in this expressions - AJA + TKE_column = cdrag_sqrt * visc%TKE_BBL(i,j) + ! Add in tidal dissipation energy at the bottom [H Z2 T-3 ~> m3 s-3 or W m-2]. + ! Note that TKE_tidal is in [R Z3 T-3 ~> W m-2]. + if (associated(fluxes%TKE_tidal)) & + TKE_column = TKE_column + fluxes%TKE_tidal(i,j) * GV%RZ_to_H + TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. + + TKE_remaining = TKE_column + total_depth = ( sum(dz(i,:)) + GV%dz_subroundoff ) ! Total column thickness [Z ~> m]. + ustar_D = ustar * total_depth + h_bot = 0. + z_bot = 0. + Kd_lower = 0. ! Diffusivity on bottom boundary. + + ! Work upwards from the bottom, accumulating work used until it exceeds the available TKE input + ! at the bottom. + do K=GV%ke,2,-1 + dz_int = 0.5 * (dz(i,k-1) + dz(i,k)) + + ! Add in additional energy input from bottom-drag against slopes (sides) + if (Rayleigh_drag) TKE_remaining = TKE_remaining + & + 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * & + ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & + G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & + (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & + G%areaCv(i,J) * visc%Ray_v(i,J,k) * v(i,J,k)**2)) + + ! Exponentially decay TKE across the thickness of the layer. + ! This is energy loss in addition to work done as mixing, apparently to Joule heating. + TKE_remaining = exp(-Idecay*h(i,j,k)) * TKE_remaining + + z_bot = z_bot + dz(i,k) ! Distance between upper interface of layer and the bottom [Z ~> m]. + h_bot = h_bot + h(i,j,k) ! Thickness between upper interface of layer and the bottom [H ~> m or kg m-2]. + D_minus_z = max(total_depth - z_bot, 0.) ! Thickness above layer [H ~> m or kg m-2]. + + ! Diffusivity using law of the wall, limited by rotation, at height z [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + ! This calculation is at the upper interface of the layer + if ( ustar_D + absf * ( h_bot * D_minus_z ) == 0.) then + Kd_wall = 0. + else + Kd_wall = ((CS%von_karm * ustar2) * (z_bot * D_minus_z)) & + / (ustar_D + absf * (h_bot * D_minus_z)) + endif + + ! TKE associated with Kd_wall [H Z2 T-3 ~> m3 s-3 or W m-2]. + ! This calculation is for the volume spanning the interface. + TKE_Kd_wall = Kd_wall * dz_int * max(N2_int(i,K), N2_min) + + ! Now bound Kd such that the associated TKE is no greater than available TKE for mixing. + if (TKE_Kd_wall > 0.) then + TKE_consumed = min(TKE_Kd_wall, TKE_remaining) + Kd_wall = (TKE_consumed / TKE_Kd_wall) * Kd_wall ! Scale Kd so that only TKE_consumed is used. + else + ! Either N2=0 or dh = 0. + if (TKE_remaining > 0.) then + Kd_wall = CS%Kd_max + else + Kd_wall = 0. + endif + TKE_consumed = 0. + endif + + ! Now use up the appropriate about of TKE associated with the diffusivity chosen + TKE_remaining = TKE_remaining - TKE_consumed ! Note this will be non-negative + + ! Add this BBL diffusivity to the model net diffusivity. + Kd_int(i,K) = Kd_int(i,K) + Kd_wall + if (present(Kd_lay)) Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * (Kd_wall + Kd_lower) + Kd_lower = Kd_wall ! Store for next layer up. + if (do_diag_Kd_BBL) Kd_BBL(i,j,K) = Kd_wall + enddo ! k + enddo ! i + +end subroutine add_LOTW_BBL_diffusivity + +!> This routine adds effects of mixed layer radiation to the layer diffusivities. +subroutine add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Kd_lay) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< Height change across layers [Z ~> m] + type(forcing), intent(in) :: fluxes !< Surface fluxes structure + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + integer, intent(in) :: j !< The j-index to work on + real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE + !! TKE dissipated within a layer and the + !! diapycnal diffusivity witin that layer, + !! usually (~Rho_0 / (G_Earth * dRho_lay)) + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] + real, dimension(SZI_(G),SZK_(GV)), & + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + +! This routine adds effects of mixed layer radiation to the layer diffusivities. + + real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m] + real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [H Z2 T-3 ~> m3 s-3 or W m-2] + real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. + real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation + ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + real :: f_sq ! The square of the local Coriolis parameter or a related variable [T-2 ~> s-2]. + real :: h_ml_sq ! The square of the mixed layer thickness [Z2 ~> m2] + real :: u_star_H ! ustar converted to thickness based units [H T-1 ~> m s-1 or kg m-2 s-1] + real :: ustar_sq ! ustar squared [Z2 T-2 ~> m2 s-2] + real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation + ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: I_rho ! The inverse of the reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] + real :: C1_6 ! 1/6 [nondim] + real :: Omega2 ! rotation rate squared [T-2 ~> s-2]. + real :: z1 ! layer thickness times I_decay [nondim] + real :: I_decay_len2_TKE ! Squared inverse decay lengthscale for TKE from the bulk mixed + ! layer code [Z-2 ~> m-2] + real :: dz_neglect ! A negligibly small height change [Z ~> m] + + logical :: do_any, do_i(SZI_(G)) + integer :: i, k, is, ie, nz, kml + is = G%isc ; ie = G%iec ; nz = GV%ke + + Omega2 = CS%omega**2 + C1_6 = 1.0 / 6.0 + kml = GV%nkml + dz_neglect = GV%dz_subroundoff + I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 ! This is not used when fully non-Boussinesq. + + if (.not.CS%ML_radiation) return + + do i=is,ie ; h_ml(i) = 0.0 ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo + do k=1,kml ; do i=is,ie ; h_ml(i) = h_ml(i) + dz(i,k) ; enddo ; enddo + + do i=is,ie ; if (do_i(i)) then + if (CS%ML_omega_frac >= 1.0) then + f_sq = 4.0 * Omega2 + else + f_sq = 0.25 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) + if (CS%ML_omega_frac > 0.0) & + f_sq = CS%ML_omega_frac * 4.0 * Omega2 + (1.0 - CS%ML_omega_frac) * f_sq + endif + + ! Determine the energy flux out of the mixed layer and its vertical decay scale. + if (associated(fluxes%ustar) .and. (GV%Boussinesq .or. .not.associated(fluxes%tau_mag))) then + ustar_sq = max(fluxes%ustar(i,j), CS%ustar_min)**2 + u_star_H = GV%Z_to_H * fluxes%ustar(i,j) + elseif (allocated(tv%SpV_avg)) then + ustar_sq = max(US%L_to_Z*fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1), CS%ustar_min**2) + u_star_H = GV%RZ_to_H * sqrt(US%L_to_Z*fluxes%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + else ! This semi-Boussinesq form is mathematically equivalent to the Boussinesq version above. + ! Differs at roundoff: ustar_sq = max(fluxes%tau_mag(i,j) * I_rho, CS%ustar_min**2) + ustar_sq = max((sqrt(fluxes%tau_mag(i,j) * I_rho))**2, CS%ustar_min**2) + u_star_H = GV%RZ_to_H * sqrt(US%L_to_Z*fluxes%tau_mag(i,j) * GV%Rho0) + endif + TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * u_star_H) + I_decay_len2_TKE = CS%TKE_decay**2 * (f_sq / ustar_sq) + + if (CS%ML_rad_TKE_decay) & + TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-h_ml(i) * sqrt(I_decay_len2_TKE)) + + ! Calculate the inverse decay scale + h_ml_sq = (CS%ML_rad_efold_coeff * (h_ml(i)+dz_neglect))**2 + I_decay(i) = sqrt((I_decay_len2_TKE * h_ml_sq + 1.0) / h_ml_sq) + + ! Average the dissipation layer kml+1, using + ! a more accurate Taylor series approximations for very thin layers. + z1 = dz(i,kml+1) * I_decay(i) + if (z1 > 1e-5) then + Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) + else + Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (z1 * (1.0 - z1 * (0.5 - C1_6 * z1))) + endif + Kd_mlr_ml(i) = min(Kd_mlr, CS%ML_rad_kd_max) + TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) + endif ; enddo + + if (present(Kd_lay)) then + do k=1,kml+1 ; do i=is,ie ; if (do_i(i)) then + Kd_lay(i,k) = Kd_lay(i,k) + Kd_mlr_ml(i) + endif ; enddo ; enddo + endif + do K=2,kml+1 ; do i=is,ie ; if (do_i(i)) then + Kd_int(i,K) = Kd_int(i,K) + Kd_mlr_ml(i) + endif ; enddo ; enddo + if (kml<=nz-1) then ; do i=is,ie ; if (do_i(i)) then + Kd_int(i,Kml+2) = Kd_int(i,Kml+2) + 0.5 * Kd_mlr_ml(i) + endif ; enddo ; endif + + do k=kml+2,nz-1 + do_any = .false. + do i=is,ie ; if (do_i(i)) then + z1 = dz(i,k)*I_decay(i) + if (CS%ML_Rad_bug) then + ! These expressions are dimensionally inconsistent. -RWH + ! This is supposed to be the integrated energy deposited in the layer, + ! not the average over the layer as in these expressions. + if (z1 > 1e-5) then + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 + US%m_to_Z * ((1.0 - exp(-z1)) / dz(i,k)) ! Units of m-1 + else + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 + US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) ! Units of m-1 + endif + else + if (z1 > 1e-5) then + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (1.0 - exp(-z1)) + else + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (z1 * (1.0 - z1 * (0.5 - C1_6*z1))) + endif + endif + Kd_mlr = min(Kd_mlr, CS%ML_rad_kd_max) + if (present(Kd_lay)) then + Kd_lay(i,k) = Kd_lay(i,k) + Kd_mlr + endif + Kd_int(i,K) = Kd_int(i,K) + 0.5 * Kd_mlr + Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * Kd_mlr + + TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) + if (TKE_ml_flux(i) * I_decay(i) < 0.1 * CS%Kd_min * Omega2) then + do_i(i) = .false. + else ; do_any = .true. ; endif + endif ; enddo + if (.not.do_any) exit + enddo + +end subroutine add_MLrad_diffusivity + +!> This subroutine calculates several properties related to bottom +!! boundary layer turbulence. +subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure with pointers to thermodynamic fields + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + type(vertvisc_type), intent(inout) :: visc !< Structure containing vertical viscosities, bottom + !! boundary layer properties and related fields. + type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + + ! This subroutine calculates several properties related to bottom + ! boundary layer turbulence. + + real, dimension(SZI_(G)) :: & + htot ! Running sum of the depth in the BBL [Z ~> m]. + + real, dimension(SZIB_(G)) :: & + uhtot, & ! running integral of u in the BBL [Z L T-1 ~> m2 s-1] + ustar, & ! bottom boundary layer piston velocity [H T-1 ~> m s-1 or kg m-2 s-1]. + u2_bbl ! square of the mean zonal velocity in the BBL [L2 T-2 ~> m2 s-2] + + real :: vhtot(SZI_(G)) ! running integral of v in the BBL [Z L T-1 ~> m2 s-1] + + real, dimension(SZI_(G),SZJB_(G)) :: & + vstar, & ! ustar at at v-points [H T-1 ~> m s-1 or kg m-2 s-1]. + v2_bbl ! square of average meridional velocity in BBL [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + dz ! The vertical distance between interfaces around a layer [Z ~> m] + + real :: cdrag_sqrt ! Square root of the drag coefficient [nondim] + real :: hvel ! thickness at velocity points [Z ~> m] + + logical :: domore, do_i(SZI_(G)) + integer :: i, j, k, is, ie, js, je, nz + integer :: l_seg + logical :: local_open_u_BC, local_open_v_BC + logical :: has_obc + + local_open_u_BC = .false. + local_open_v_BC = .false. + if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) call MOM_error(FATAL,"set_BBL_TKE: "//& + "Module must be initialized before it is used.") + + if (.not.CS%initialized) call MOM_error(FATAL,"set_BBL_TKE: "//& + "Module must be initialized before it is used.") + + if (.not.CS%bottomdraglaw .or. (CS%BBL_effic<=0.0)) then + if (allocated(visc%ustar_BBL)) then + do j=js,je ; do i=is,ie ; visc%ustar_BBL(i,j) = 0.0 ; enddo ; enddo + endif + if (allocated(visc%TKE_BBL)) then + do j=js,je ; do i=is,ie ; visc%TKE_BBL(i,j) = 0.0 ; enddo ; enddo + endif + return + endif + + cdrag_sqrt = sqrt(CS%cdrag) + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + + !$OMP parallel default(shared) private(do_i,vhtot,htot,domore,hvel,uhtot,ustar,u2_bbl) + !$OMP do + do J=js-1,je + ! 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 + do_i(i) = .false. ; vstar(i,J) = 0.0 ; vhtot(i) = 0.0 ; htot(i) = 0.0 + enddo + if (allocated(visc%Kv_bbl_v)) then + do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) then + do_i(i) = .true. + vstar(i,J) = visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) + endif ; enddo + endif + !### What about terms from visc%Ray? + + do k=nz,1,-1 + domore = .false. + do i=is,ie ; if (do_i(i)) then + ! Determine if grid point is an OBC + has_obc = .false. + if (local_open_v_BC) then + l_seg = OBC%segnum_v(i,J) + if (l_seg /= OBC_NONE) then + has_obc = OBC%segment(l_seg)%open + endif + endif + + ! Compute h based on OBC state + if (has_obc) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + hvel = dz(i,j,k) + else + hvel = dz(i,j+1,k) + endif + else + hvel = 0.5*(dz(i,j,k) + dz(i,j+1,k)) + endif + + if ((htot(i) + hvel) >= visc%bbl_thick_v(i,J)) then + vhtot(i) = vhtot(i) + (visc%bbl_thick_v(i,J) - htot(i))*v(i,J,k) + htot(i) = visc%bbl_thick_v(i,J) + do_i(i) = .false. + else + vhtot(i) = vhtot(i) + hvel*v(i,J,k) + htot(i) = htot(i) + hvel + domore = .true. + endif + endif ; enddo + if (.not.domore) exit + enddo + do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (htot(i) > 0.0)) then + v2_bbl(i,J) = (vhtot(i)*vhtot(i)) / (htot(i)*htot(i)) + else + v2_bbl(i,J) = 0.0 + endif ; enddo + enddo + !$OMP do + do j=js,je + do I=is-1,ie + do_i(I) = .false. ; ustar(I) = 0.0 ; uhtot(I) = 0.0 ; htot(I) = 0.0 + enddo + if (allocated(visc%bbl_thick_u)) then + do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then + do_i(I) = .true. + ustar(I) = visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) + endif ; enddo + endif + + do k=nz,1,-1 ; domore = .false. + do I=is-1,ie ; if (do_i(I)) then + ! Determine if grid point is an OBC + has_obc = .false. + if (local_open_u_BC) then + l_seg = OBC%segnum_u(I,j) + if (l_seg /= OBC_NONE) then + has_obc = OBC%segment(l_seg)%open + endif + endif + + ! Compute h based on OBC state + if (has_obc) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + hvel = dz(i,j,k) + else ! OBC_DIRECTION_W + hvel = dz(i+1,j,k) + endif + else + hvel = 0.5*(dz(i,j,k) + dz(i+1,j,k)) + endif + + if ((htot(I) + hvel) >= visc%bbl_thick_u(I,j)) then + uhtot(I) = uhtot(I) + (visc%bbl_thick_u(I,j) - htot(I))*u(I,j,k) + htot(I) = visc%bbl_thick_u(I,j) + do_i(I) = .false. + else + uhtot(I) = uhtot(I) + hvel*u(I,j,k) + htot(I) = htot(I) + hvel + domore = .true. + endif + endif ; enddo + if (.not.domore) exit + enddo + do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (htot(i) > 0.0)) then + u2_bbl(I) = (uhtot(I)*uhtot(I)) / (htot(I)*htot(I)) + else + u2_bbl(I) = 0.0 + endif ; enddo + + do i=is,ie + visc%ustar_BBL(i,j) = sqrt(0.5*G%IareaT(i,j) * & + ((G%areaCu(I-1,j)*(ustar(I-1)*ustar(I-1)) + & + G%areaCu(I,j)*(ustar(I)*ustar(I))) + & + (G%areaCv(i,J-1)*(vstar(i,J-1)*vstar(i,J-1)) + & + G%areaCv(i,J)*(vstar(i,J)*vstar(i,J))) ) ) + visc%TKE_BBL(i,j) = US%L_to_Z**2 * & + (((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1)) + & + G%areaCu(I,j) * (ustar(I)*u2_bbl(I))) + & + (G%areaCv(i,J-1)*(vstar(i,J-1)*v2_bbl(i,J-1)) + & + G%areaCv(i,J) * (vstar(i,J)*v2_bbl(i,J))) )*G%IareaT(i,j)) + enddo + enddo + !$OMP end parallel + +end subroutine set_BBL_TKE + +subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields; absent + !! fields have NULL ptrs. + integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer + !! layer, or -1 without a bulk mixed layer. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(set_diffusivity_CS), pointer :: CS !< Control structure returned by previous + !! call to diabatic_entrain_init. + integer, intent(in) :: j !< Meridional index upon which to work. + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: ds_dsp1 !< Coordinate variable (sigma-2) + !! difference across an interface divided by + !! the difference across the interface below + !! it [nondim] + real, dimension(SZI_(G),SZK_(GV)), & + optional, intent(in) :: rho_0 !< Layer potential densities relative to + !! surface press [R ~> kg m-3]. + + ! Local variables + real :: g_R0 ! g_R0 is a rescaled version of g/Rho [L2 Z-1 R-1 T-2 ~> m4 kg-1 s-2] + real :: eps, tmp ! nondimensional temporary variables [nondim] + real :: a(SZK_(GV)), a_0(SZK_(GV)) ! nondimensional temporary variables [nondim] + real :: p_ref(SZI_(G)) ! an array of tv%P_Ref pressures [R L2 T-2 ~> Pa] + real :: Rcv(SZI_(G),SZK_(GV)) ! coordinate density in the mixed and buffer layers [R ~> kg m-3] + real :: I_Drho ! The inverse of the coordinate density difference between + ! layers [R-1 ~> m3 kg-1] + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, k, k3, is, ie, nz, kmb + is = G%isc ; ie = G%iec ; nz = GV%ke + + do k=2,nz-1 + if (GV%g_prime(k+1) /= 0.0) then + if (GV%Boussinesq .or. GV%Semi_Boussinesq) then + do i=is,ie + ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) + enddo + else ! Use a mathematically equivalent form that avoids any dependency on RHO_0. + do i=is,ie + ds_dsp1(i,k) = (GV%Rlay(k) - GV%Rlay(k-1)) / (GV%Rlay(k+1) - GV%Rlay(k)) + enddo + endif + else + do i=is,ie + ds_dsp1(i,k) = 1. + enddo + endif + enddo + + if (CS%bulkmixedlayer) then + g_R0 = GV%g_Earth / (GV%Rho0) + kmb = GV%nk_rho_varies + eps = 0.1 + do i=is,ie ; p_ref(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) + do k=1,kmb + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), tv%eqn_of_state, EOSdom) + enddo + do i=is,ie + if (kb(i) <= nz-1) then +! Set up appropriately limited ratios of the reduced gravities of the +! interfaces above and below the buffer layer and the next denser layer. + k = kb(i) + + if (GV%Boussinesq .or. GV%Semi_Boussinesq) then + I_Drho = g_R0 / GV%g_prime(k+1) + else + I_Drho = 1.0 / (GV%Rlay(k+1) - GV%Rlay(k)) + endif + ! The indexing convention for a is appropriate for the interfaces. + do k3=1,kmb + a(k3+1) = (GV%Rlay(k) - Rcv(i,k3)) * I_Drho + enddo + if ((present(rho_0)) .and. (a(kmb+1) < 2.0*eps*ds_dsp1(i,k))) then +! If the buffer layer nearly matches the density of the layer below in the +! coordinate variable (sigma-2), use the sigma-0-based density ratio if it is +! greater (and stable). + if ((rho_0(i,k) > rho_0(i,kmb)) .and. & + (rho_0(i,k+1) > rho_0(i,k))) then + I_Drho = 1.0 / (rho_0(i,k+1)-rho_0(i,k)) + a_0(kmb+1) = min((rho_0(i,k)-rho_0(i,kmb)) * I_Drho, ds_dsp1(i,k)) + if (a_0(kmb+1) > a(kmb+1)) then + do k3=2,kmb + a_0(k3) = a_0(kmb+1) + (rho_0(i,kmb)-rho_0(i,k3-1)) * I_Drho + enddo + if (a(kmb+1) <= eps*ds_dsp1(i,k)) then + do k3=2,kmb+1 ; a(k3) = a_0(k3) ; enddo + else +! Alternative... tmp = 0.5*(1.0 - cos(PI*(a(K2+1)/(eps*ds_dsp1(i,k)) - 1.0)) ) + tmp = a(kmb+1)/(eps*ds_dsp1(i,k)) - 1.0 + do k3=2,kmb+1 ; a(k3) = tmp*a(k3) + (1.0-tmp)*a_0(k3) ; enddo + endif + endif + endif + endif + + ds_dsp1(i,k) = MAX(a(kmb+1),1e-5) + + do k3=2,kmb +! ds_dsp1(i,k3) = MAX(a(k3),1e-5) + ! Deliberately treat convective instabilities of the upper mixed + ! and buffer layers with respect to the deepest buffer layer as + ! though they don't exist. They will be eliminated by the upcoming + ! call to the mixedlayer code anyway. + ! The indexing convention is appropriate for the interfaces. + ds_dsp1(i,k3) = MAX(a(k3),ds_dsp1(i,k)) + enddo + endif ! (kb(i) <= nz-1) + enddo ! I-loop. + endif ! bulkmixedlayer + +end subroutine set_density_ratios + +subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_CSp, halo_TS, & + double_diffuse, physical_OBL_scheme) + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(diag_ctrl), target, intent(inout) :: diag !< A structure used to regulate diagnostic output. + type(set_diffusivity_CS), pointer :: CS !< pointer set to point to the module control + !! structure. + type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure + integer, intent(out) :: halo_TS !< The halo size of tracer points that must be + !! valid for the calculations in set_diffusivity. + logical, intent(out) :: double_diffuse !< This indicates whether some version + !! of double diffusion is being used. + logical, intent(in) :: physical_OBL_scheme !< If true, a physically based + !! parameterization (like KPP or ePBL or a bulk mixed + !! layer) is used outside of set_diffusivity to + !! specify the mixing that occurs in the ocean's + !! surface boundary layer. + + ! Local variables + real :: decay_length ! The maximum decay scale for the BBL diffusion [H ~> m or kg m-2] + logical :: ML_use_omega + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_set_diffusivity" ! This module's name. + real :: vonKar ! The von Karman constant as used for mixed layer viscosity [nondim] + real :: Kd_z ! The background diapycnal diffusivity in [Z2 T-1 ~> m2 s-1] for use + ! in setting the default for other diffusivities. + real :: omega_frac_dflt ! The default value for the fraction of the absolute rotation rate + ! that is used in place of the absolute value of the local Coriolis + ! parameter in the denominator of some expressions [nondim] + logical :: Bryan_Lewis_diffusivity ! If true, the background diapycnal diffusivity uses + ! the Bryan-Lewis (1979) style tanh profile. + logical :: use_regridding ! If true, use the ALE algorithm rather than layered + ! isopycnal or stacked shallow water mode. + logical :: TKE_to_Kd_used ! If true, TKE_to_Kd and maxTKE need to be calculated. + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + if (associated(CS)) then + call MOM_error(WARNING, "diabatic_entrain_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + CS%initialized = .true. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + CS%diag => diag + if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp + + ! These default values always need to be set. + CS%BBL_mixing_as_max = .true. + CS%cdrag = 0.003 ; CS%BBL_effic = 0.0 + CS%bulkmixedlayer = (GV%nkml > 0) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") + CS%inputdir = slasher(CS%inputdir) + call get_param(param_file, mdl, "FLUX_RI_MAX", CS%FluxRi_max, & + "The flux Richardson number where the stratification is "//& + "large enough that N2 > omega2. The full expression for "//& + "the Flux Richardson number is usually "//& + "FLUX_RI_MAX*N2/(N2+OMEGA2).", units="nondim", default=0.2) + call get_param(param_file, mdl, "OMEGA", CS%omega, & + "The rotation rate of the earth.", units="s-1", default=7.2921e-5, scale=US%T_to_s) + + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "SET_DIFF_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the set diffusivity "//& + "calculations. Values below 20190101 recover the answers from the end of 2018, "//& + "while higher values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + + ! CS%use_tidal_mixing is set to True if an internal tidal dissipation scheme is to be used. + CS%use_tidal_mixing = tidal_mixing_init(Time, G, GV, US, param_file, & + CS%int_tide_CSp, diag, CS%tidal_mixing) + + call get_param(param_file, mdl, "ML_RADIATION", CS%ML_radiation, & + "If true, allow a fraction of TKE available from wind "//& + "work to penetrate below the base of the mixed layer "//& + "with a vertical decay scale determined by the minimum "//& + "of: (1) The depth of the mixed layer, (2) an Ekman "//& + "length scale.", default=.false.) + if (CS%ML_radiation) then + ! This give a minimum decay scale that is typically much less than Angstrom. + CS%ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + GV%dZ_subroundoff) + + call get_param(param_file, mdl, "ML_RAD_EFOLD_COEFF", CS%ML_rad_efold_coeff, & + "A coefficient that is used to scale the penetration "//& + "depth for turbulence below the base of the mixed layer. "//& + "This is only used if ML_RADIATION is true.", units="nondim", default=0.2) + call get_param(param_file, mdl, "ML_RAD_BUG", CS%ML_rad_bug, & + "If true use code with a bug that reduces the energy available "//& + "in the transition layer by a factor of the inverse of the energy "//& + "deposition lenthscale (in m).", default=.false.) + call get_param(param_file, mdl, "ML_RAD_KD_MAX", CS%ML_rad_kd_max, & + "The maximum diapycnal diffusivity due to turbulence "//& + "radiated from the base of the mixed layer. "//& + "This is only used if ML_RADIATION is true.", & + units="m2 s-1", default=1.0e-3, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "ML_RAD_COEFF", CS%ML_rad_coeff, & + "The coefficient which scales MSTAR*USTAR^3 to obtain "//& + "the energy available for mixing below the base of the "//& + "mixed layer. This is only used if ML_RADIATION is true.", & + units="nondim", default=0.2) + call get_param(param_file, mdl, "ML_RAD_APPLY_TKE_DECAY", CS%ML_rad_TKE_decay, & + "If true, apply the same exponential decay to ML_rad as "//& + "is applied to the other surface sources of TKE in the "//& + "mixed layer code. This is only used if ML_RADIATION is true.", default=.true.) + call get_param(param_file, mdl, "MSTAR", CS%mstar, & + "The ratio of the friction velocity cubed to the TKE "//& + "input to the mixed layer.", units="nondim", default=1.2) + call get_param(param_file, mdl, "TKE_DECAY", CS%TKE_decay, & + "The ratio of the natural Ekman depth to the TKE decay scale.", & + units="nondim", default=2.5) + call get_param(param_file, mdl, "ML_USE_OMEGA", ML_use_omega, & + "If true, use the absolute rotation rate instead of the "//& + "vertical component of rotation when setting the decay "//& + "scale for turbulence.", default=.false., do_not_log=.true.) + omega_frac_dflt = 0.0 + if (ML_use_omega) then + call MOM_error(WARNING, "ML_USE_OMEGA is depricated; use ML_OMEGA_FRAC=1.0 instead.") + omega_frac_dflt = 1.0 + endif + call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%ML_omega_frac, & + "When setting the decay scale for turbulence, use this "//& + "fraction of the absolute rotation rate blended with the "//& + "local value of f, as sqrt((1-of)*f^2 + of*4*omega^2).", & + units="nondim", default=omega_frac_dflt) + endif + + call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & + "If true, the bottom stress is calculated with a drag "//& + "law of the form c_drag*|u|*u. The velocity magnitude "//& + "may be an assumed value or it may be based on the actual "//& + "velocity in the bottommost HBBL, depending on LINEAR_DRAG.", default=.true.) + if (CS%bottomdraglaw) then + call get_param(param_file, mdl, "CDRAG", CS%cdrag, & + "The drag coefficient relating the magnitude of the "//& + "velocity field to the bottom stress. CDRAG is only used "//& + "if BOTTOMDRAGLAW is true.", units="nondim", default=0.003) + call get_param(param_file, mdl, "BBL_EFFIC", CS%BBL_effic, & + "The efficiency with which the energy extracted by "//& + "bottom drag drives BBL diffusion. This is only "//& + "used if BOTTOMDRAGLAW is true.", units="nondim", default=0.20) + call get_param(param_file, mdl, "BBL_MIXING_MAX_DECAY", decay_length, & + "The maximum decay scale for the BBL diffusion, or 0 to allow the mixing "//& + "to penetrate as far as stratification and rotation permit. The default "//& + "for now is 200 m. This is only used if BOTTOMDRAGLAW is true.", & + units="m", default=200.0, scale=GV%m_to_H) + + CS%IMax_decay = 0.0 + if (decay_length > 0.0) CS%IMax_decay = 1.0/decay_length + call get_param(param_file, mdl, "BBL_MIXING_AS_MAX", CS%BBL_mixing_as_max, & + "If true, take the maximum of the diffusivity from the "//& + "BBL mixing and the other diffusivities. Otherwise, "//& + "diffusivity from the BBL_mixing is simply added.", & + default=.true.) + call get_param(param_file, mdl, "USE_LOTW_BBL_DIFFUSIVITY", CS%use_LOTW_BBL_diffusivity, & + "If true, uses a simple, imprecise but non-coordinate dependent, model "//& + "of BBL mixing diffusivity based on Law of the Wall. Otherwise, uses "//& + "the original BBL scheme.", default=.false.) + if (CS%use_LOTW_BBL_diffusivity) then + call get_param(param_file, mdl, "LOTW_BBL_USE_OMEGA", CS%LOTW_BBL_use_omega, & + "If true, use the maximum of Omega and N for the TKE to diffusion "//& + "calculation. Otherwise, N is N.", default=.true.) + call get_param(param_file, mdl, 'VON_KARMAN_CONST', vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) + call get_param(param_file, mdl, 'VON_KARMAN_BBL', CS%von_Karm, & + 'The value the von Karman constant as used in calculating the BBL diffusivity.', & + units='nondim', default=vonKar) + endif + else + CS%use_LOTW_BBL_diffusivity = .false. ! This parameterization depends on a u* from viscous BBL + endif + CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & + 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + + call get_param(param_file, mdl, "DZ_BBL_AVG_MIN", CS%dz_BBL_avg_min, & + "A minimal distance over which to average to determine the average bottom "//& + "boundary layer density.", units="m", default=0.0, scale=US%m_to_Z) + + TKE_to_Kd_used = (CS%use_tidal_mixing .or. CS%ML_radiation .or. & + (CS%bottomdraglaw .and. .not.CS%use_LOTW_BBL_diffusivity)) + call get_param(param_file, mdl, "SIMPLE_TKE_TO_KD", CS%simple_TKE_to_Kd, & + "If true, uses a simple estimate of Kd/TKE that will "//& + "work for arbitrary vertical coordinates. If false, "//& + "calculates Kd/TKE and bounds based on exact energetics "//& + "for an isopycnal layer-formulation.", & + default=.false., do_not_log=.not.TKE_to_Kd_used) + + ! set parameters related to the background mixing + call bkgnd_mixing_init(Time, G, GV, US, param_file, CS%diag, CS%bkgnd_mixing_csp, physical_OBL_scheme) + + call get_param(param_file, mdl, "KV", CS%Kv, & + "The background kinematic viscosity in the interior. "//& + "The molecular value, ~1e-6 m2 s-1, may be used.", & + units="m2 s-1", scale=GV%m2_s_to_HZ_T, fail_if_missing=.true.) + + call get_param(param_file, mdl, "KD", Kd_z, & + "The background diapycnal diffusivity of density in the "//& + "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& + "may be used.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) + CS%Kd = (GV%m2_s_to_HZ_T*US%Z2_T_to_m2_s) * Kd_z + call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & + "The minimum diapycnal diffusivity.", & + units="m2 s-1", default=0.01*Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & + "The maximum permitted increment for the diapycnal "//& + "diffusivity from TKE-based parameterizations, or a negative "//& + "value for no limit.", units="m2 s-1", default=-1.0, scale=GV%m2_s_to_HZ_T) + if (CS%simple_TKE_to_Kd) then + if (CS%Kd_max<=0.) call MOM_error(FATAL, & + "set_diffusivity_init: To use SIMPLE_TKE_TO_KD, KD_MAX must be set to >0.") + call get_param(param_file, mdl, "USE_REGRIDDING", use_regridding, & + do_not_log=.true., default=.false.) + if (use_regridding) call MOM_error(WARNING, & + "set_diffusivity_init: SIMPLE_TKE_TO_KD can not be used reliably with USE_REGRIDDING.") + endif + + call get_param(param_file, mdl, "KD_ADD", CS%Kd_add, & + "A uniform diapycnal diffusivity that is added "//& + "everywhere without any filtering or scaling.", & + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T) + if (CS%use_LOTW_BBL_diffusivity .and. CS%Kd_max<=0.) call MOM_error(FATAL, & + "set_diffusivity_init: KD_MAX must be set (positive) when "// & + "USE_LOTW_BBL_DIFFUSIVITY=True.") + call get_param(param_file, mdl, "KD_SMOOTH", CS%Kd_smooth, & + "A diapycnal diffusivity that is used to interpolate "//& + "more sensible values of T & S into thin layers.", & + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) + + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + + call get_param(param_file, mdl, "USER_CHANGE_DIFFUSIVITY", CS%user_change_diff, & + "If true, call user-defined code to change the diffusivity.", default=.false.) + + call get_param(param_file, mdl, "DISSIPATION_MIN", CS%dissip_min, & + "The minimum dissipation by which to determine a lower "//& + "bound of Kd (a floor).", & + units="W m-3", default=0.0, scale=US%W_m2_to_RZ3_T3*US%Z_to_m) + call get_param(param_file, mdl, "DISSIPATION_N0", CS%dissip_N0, & + "The intercept when N=0 of the N-dependent expression "//& + "used to set a minimum dissipation by which to determine "//& + "a lower bound of Kd (a floor): A in eps_min = A + B*N.", & + units="W m-3", default=0.0, scale=US%W_m2_to_RZ3_T3*US%Z_to_m) + call get_param(param_file, mdl, "DISSIPATION_N1", CS%dissip_N1, & + "The coefficient multiplying N, following Gargett, used to "//& + "set a minimum dissipation by which to determine a lower "//& + "bound of Kd (a floor): B in eps_min = A + B*N", & + units="J m-3", default=0.0, scale=US%W_m2_to_RZ3_T3*US%Z_to_m*US%s_to_T) + call get_param(param_file, mdl, "DISSIPATION_KD_MIN", CS%dissip_Kd_min, & + "The minimum vertical diffusivity applied as a floor.", & + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T) + + CS%limit_dissipation = (CS%dissip_min>0.) .or. (CS%dissip_N1>0.) .or. & + (CS%dissip_N0>0.) .or. (CS%dissip_Kd_min>0.) + CS%dissip_N2 = 0.0 + if (CS%FluxRi_max > 0.0) & + CS%dissip_N2 = CS%dissip_Kd_min * GV%H_to_RZ / CS%FluxRi_max + + CS%id_Kd_bkgnd = register_diag_field('ocean_model', 'Kd_bkgnd', diag%axesTi, Time, & + 'Background diffusivity added by MOM_bkgnd_mixing module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kv_bkgnd = register_diag_field('ocean_model', 'Kv_bkgnd', diag%axesTi, Time, & + 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + + CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & + 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + + if (CS%use_tidal_mixing) then + CS%id_Kd_Work = register_diag_field('ocean_model', 'Kd_Work', diag%axesTL, Time, & + 'Work done by Diapycnal Mixing', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_maxTKE = register_diag_field('ocean_model', 'maxTKE', diag%axesTL, Time, & + 'Maximum layer TKE', 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) + CS%id_TKE_to_Kd = register_diag_field('ocean_model', 'TKE_to_Kd', diag%axesTL, Time, & + 'Convert TKE to Kd', 's2 m', conversion=GV%HZ_T_to_m2_s*(GV%m_to_H*US%m_to_Z**2*US%T_to_s**3)) + CS%id_N2 = register_diag_field('ocean_model', 'N2', diag%axesTi, Time, & + 'Buoyancy frequency squared', 's-2', conversion=US%s_to_T**2, cmor_field_name='obvfsq', & + cmor_long_name='Square of seawater buoyancy frequency', & + cmor_standard_name='square_of_brunt_vaisala_frequency_in_sea_water') + endif + + if (CS%user_change_diff) & + CS%id_Kd_user = register_diag_field('ocean_model', 'Kd_user', diag%axesTi, Time, & + 'User-specified Extra Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + + call get_param(param_file, mdl, "DOUBLE_DIFFUSION", CS%double_diffusion, & + "If true, increase diffusivites for temperature or salinity based on the "//& + "double-diffusive parameterization described in Large et al. (1994).", & + default=.false.) + + if (CS%double_diffusion) then + call get_param(param_file, mdl, "MAX_RRHO_SALT_FINGERS", CS%Max_Rrho_salt_fingers, & + "Maximum density ratio for salt fingering regime.", & + default=2.55, units="nondim") + call get_param(param_file, mdl, "MAX_SALT_DIFF_SALT_FINGERS", CS%Max_salt_diff_salt_fingers, & + "Maximum salt diffusivity for salt fingering regime.", & + default=1.e-4, units="m2 s-1", scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "KV_MOLECULAR", CS%Kv_molecular, & + "Molecular viscosity for calculation of fluxes under double-diffusive "//& + "convection.", default=1.5e-6, units="m2 s-1", scale=GV%m2_s_to_HZ_T) + ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. + endif ! old double-diffusion + + if (CS%user_change_diff) then + call user_change_diff_init(Time, G, GV, US, param_file, diag, CS%user_change_diff_CSp) + endif + + call get_param(param_file, mdl, "BRYAN_LEWIS_DIFFUSIVITY", Bryan_Lewis_diffusivity, & + "If true, use a Bryan & Lewis (JGR 1979) like tanh "//& + "profile of background diapycnal diffusivity with depth. "//& + "This is done via CVMix.", default=.false., do_not_log=.true.) + if (CS%use_tidal_mixing .and. Bryan_Lewis_diffusivity) & + call MOM_error(FATAL,"MOM_Set_Diffusivity: "// & + "Bryan-Lewis and internal tidal dissipation are both enabled. Choose one.") + + CS%useKappaShear = kappa_shear_init(Time, G, GV, US, param_file, CS%diag, CS%kappaShear_CSp) + CS%Vertex_Shear = kappa_shear_at_vertex(param_file) + + if (CS%useKappaShear) & + id_clock_kappaShear = cpu_clock_id('(Ocean kappa_shear)', grain=CLOCK_MODULE) + + ! CVMix shear-driven mixing + CS%use_CVMix_shear = CVMix_shear_init(Time, G, GV, US, param_file, CS%diag, CS%CVMix_shear_csp) + + ! CVMix double diffusion mixing + CS%use_CVMix_ddiff = CVMix_ddiff_init(Time, G, GV, US, param_file, CS%diag, CS%CVMix_ddiff_csp) + if (CS%use_CVMix_ddiff) & + id_clock_CVMix_ddiff = cpu_clock_id('(Double diffusion via CVMix)', grain=CLOCK_MODULE) + + if (CS%double_diffusion .and. CS%use_CVMix_ddiff) then + call MOM_error(FATAL, 'set_diffusivity_init: '// & + 'Multiple double-diffusion options selected (DOUBLE_DIFFUSION and'//& + 'USE_CVMIX_DDIFF), please disable all but one option to proceed.') + endif + + if (CS%double_diffusion .or. CS%use_CVMix_ddiff) then + CS%id_KT_extra = register_diag_field('ocean_model', 'KT_extra', diag%axesTi, Time, & + 'Double-diffusive diffusivity for temperature', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + CS%id_KS_extra = register_diag_field('ocean_model', 'KS_extra', diag%axesTi, Time, & + 'Double-diffusive diffusivity for salinity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + endif + if (CS%use_CVMix_ddiff) then + CS%id_R_rho = register_diag_field('ocean_model', 'R_rho', diag%axesTi, Time, & + 'Double-diffusion density ratio', 'nondim') + endif + + halo_TS = 0 + if (CS%Vertex_Shear) halo_TS = 1 + + double_diffuse = (CS%double_diffusion .or. CS%use_CVMix_ddiff) + +end subroutine set_diffusivity_init + +!> Clear pointers and deallocate memory +subroutine set_diffusivity_end(CS) + type(set_diffusivity_CS), intent(inout) :: CS !< Control structure for this module + + call bkgnd_mixing_end(CS%bkgnd_mixing_csp) + + if (CS%use_tidal_mixing) & + call tidal_mixing_end(CS%tidal_mixing) + + if (CS%user_change_diff) call user_change_diff_end(CS%user_change_diff_CSp) + + if (associated(CS%CVMix_ddiff_CSp)) deallocate(CS%CVMix_ddiff_CSp) + + if (CS%use_CVMix_shear) then + call CVMix_shear_end(CS%CVMix_shear_CSp) + deallocate(CS%CVMix_shear_CSp) + endif + + ! NOTE: CS%kappaShear_CSp is always allocated, even if unused + deallocate(CS%kappaShear_CSp) +end subroutine set_diffusivity_end + +end module MOM_set_diffusivity diff --git a/parameterizations/vertical/MOM_set_viscosity.F90 b/parameterizations/vertical/MOM_set_viscosity.F90 new file mode 100644 index 0000000000..e601fdf2f7 --- /dev/null +++ b/parameterizations/vertical/MOM_set_viscosity.F90 @@ -0,0 +1,3169 @@ +!> Calculates various values related to the bottom boundary layer, such as the viscosity and +!! thickness of the BBL (set_viscous_BBL). +module MOM_set_visc + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_ALE, only : ALE_CS, ALE_remap_velocities, ALE_remap_interface_vals, ALE_remap_vertex_vals +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_cvmix_conv, only : cvmix_conv_is_used +use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used +use MOM_cvmix_shear, only : cvmix_shear_is_used +use MOM_debugging, only : uvchksum, hchksum +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_domains, only : pass_var, CORNER +use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_specific_vol_derivs +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing, mech_forcing, find_ustar +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_intrinsic_functions, only : cuberoot +use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc +use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex +use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, OBC_NONE, OBC_DIRECTION_E +use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S +use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : register_restart_field_as_obsolete, register_restart_pair +use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public set_viscous_BBL, set_viscous_ML, set_visc_init, set_visc_end +public set_visc_register_restarts, set_u_at_v, set_v_at_u +public remap_vertvisc_aux_vars + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure for MOM_set_visc +type, public :: set_visc_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2]. + !! Runtime parameter `HBBL`. + real :: dz_bbl !< The static bottom boundary layer thickness in height units [Z ~> m]. + !! Runtime parameter `HBBL`. + real :: cdrag !< The quadratic drag coefficient [nondim]. + !! Runtime parameter `CDRAG`. + real :: c_Smag !< The Laplacian Smagorinsky coefficient for + !! calculating the drag in channels [nondim]. + real :: drag_bg_vel !< An assumed unresolved background velocity for + !! calculating the bottom drag [L T-1 ~> m s-1]. + !! Runtime parameter `DRAG_BG_VEL`. + real :: BBL_thick_min !< The minimum bottom boundary layer thickness [Z ~> m]. + !! This might be Kv / (cdrag * drag_bg_vel) to give + !! Kv as the minimum near-bottom viscosity. + real :: Htbl_shelf !< A nominal thickness of the surface boundary layer for use + !! in calculating the near-surface velocity [H ~> m or kg m-2]. + real :: Htbl_shelf_min !< The minimum surface boundary layer thickness [Z ~> m]. + real :: KV_BBL_min !< The minimum viscosity in the bottom boundary layer [H Z T-1 ~> m2 s-1 or Pa s] + real :: KV_TBL_min !< The minimum viscosity in the top boundary layer [H Z T-1 ~> m2 s-1 or Pa s] + logical :: bottomdraglaw !< If true, the bottom stress is calculated with a + !! drag law c_drag*|u|*u. The velocity magnitude + !! may be an assumed value or it may be based on the + !! actual velocity in the bottommost `HBBL`, depending + !! on whether linear_drag is true. + !! Runtime parameter `BOTTOMDRAGLAW`. + logical :: body_force_drag !< If true, the bottom stress is imposed as an explicit body force + !! applied over a fixed distance from the bottom, rather than as an + !! implicit calculation based on an enhanced near-bottom viscosity. + logical :: BBL_use_EOS !< If true, use the equation of state in determining + !! the properties of the bottom boundary layer. + logical :: linear_drag !< If true, the drag law is cdrag*`DRAG_BG_VEL`*u. + !! Runtime parameter `LINEAR_DRAG`. + logical :: Channel_drag !< If true, the drag is exerted directly on each layer + !! according to what fraction of the bottom they overlie. + real :: Chan_drag_max_vol !< The maximum bottom boundary layer volume within which the + !! channel drag is applied, normalized by the full cell area, + !! or a negative value to apply no maximum [Z ~> m]. + logical :: correct_BBL_bounds !< If true, uses the correct bounds on the BBL thickness and + !! viscosity so that the bottom layer feels the intended drag. + logical :: RiNo_mix !< If true, use Richardson number dependent mixing. + logical :: dynamic_viscous_ML !< If true, use a bulk Richardson number criterion to + !! determine the mixed layer thickness for viscosity. + real :: bulk_Ri_ML !< The bulk mixed layer used to determine the + !! thickness of the viscous mixed layer [nondim] + real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. + real :: ustar_min !< A minimum value of ustar to avoid numerical + !! problems [H T-1 ~> m s-1 or kg m-2 s-1]. If the value is + !! small enough, this should not affect the solution. + real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE + !! decay scale [nondim] + real :: omega_frac !< When setting the decay scale for turbulence, use this + !! fraction of the absolute rotation rate blended with the local + !! value of f, as sqrt((1-of)*f^2 + of*4*omega^2) [nondim] + logical :: concave_trigonometric_L !< If true, use trigonometric expressions to determine the + !! fractional open interface lengths for concave topography. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the set + !! viscosity calculations. Values below 20190101 recover the answers + !! from the end of 2018, while higher values use updated and more robust + !! forms of the same expressions. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: BBL_use_tidal_bg !< If true, use a tidal background amplitude for the bottom velocity + !! when computing the bottom stress. + character(len=200) :: inputdir !< The directory for input files. + type(ocean_OBC_type), pointer :: OBC => NULL() !< Open boundaries control structure + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + ! Allocatable data arrays + real, allocatable, dimension(:,:) :: tideamp !< RMS tidal amplitude at h points [Z T-1 ~> m s-1] + ! Diagnostic arrays + real, allocatable, dimension(:,:) :: bbl_u !< BBL mean U current [L T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: bbl_v !< BBL mean V current [L T-1 ~> m s-1] + !>@{ Diagnostics handles + integer :: id_bbl_thick_u = -1, id_kv_bbl_u = -1, id_bbl_u = -1 + integer :: id_bbl_thick_v = -1, id_kv_bbl_v = -1, id_bbl_v = -1 + integer :: id_Ray_u = -1, id_Ray_v = -1 + integer :: id_nkml_visc_u = -1, id_nkml_visc_v = -1 + !>@} +end type set_visc_CS + +contains + +!> Calculates the thickness of the bottom boundary layer and the viscosity within that layer. +subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent fields + !! have NULL pointers. + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and + !! related fields. + type(set_visc_CS), intent(inout) :: CS !< The control structure returned by a previous + !! call to set_visc_init. + type(porous_barrier_type),intent(in) :: pbv !< porous barrier fractional cell metrics + + ! Local variables + real, dimension(SZIB_(G)) :: & + ustar, & ! The bottom friction velocity [H T-1 ~> m s-1 or kg m-2 s-1]. + T_EOS, & ! The temperature used to calculate the partial derivatives + ! of density with T and S [C ~> degC]. + S_EOS, & ! The salinity used to calculate the partial derivatives + ! of density with T and S [S ~> ppt]. + dR_dT, & ! Partial derivative of the density in the bottom boundary + ! layer with temperature [R C-1 ~> kg m-3 degC-1]. + dR_dS, & ! Partial derivative of the density in the bottom boundary + ! layer with salinity [R S-1 ~> kg m-3 ppt-1]. + press, & ! The pressure at which dR_dT and dR_dS are evaluated [R L2 T-2 ~> Pa]. + umag_avg, & ! The average magnitude of velocities in the bottom boundary layer [L T-1 ~> m s-1]. + h_bbl_drag, & ! The thickness over which to apply drag as a body force [H ~> m or kg m-2]. + dz_bbl_drag ! The vertical height over which to apply drag as a body force [Z ~> m]. + real :: htot ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. + real :: dztot ! Distance from the bottom up to some point [Z ~> m]. + real :: htot_vel ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. + real :: dztot_vel ! Distance from the bottom up to some point [Z ~> m]. + + real :: Rhtot ! Running sum of thicknesses times the layer potential + ! densities [H R ~> kg m-2 or kg2 m-5]. + real, dimension(SZIB_(G),SZJ_(G)) :: & + D_u, & ! Bottom depth linearly interpolated to u points [Z ~> m]. + mask_u ! A mask that disables any contributions from u points that + ! are land or past open boundary conditions [nondim], 0 or 1. + real, dimension(SZI_(G),SZJB_(G)) :: & + D_v, & ! Bottom depth linearly interpolated to v points [Z ~> m]. + mask_v ! A mask that disables any contributions from v points that + ! are land or past open boundary conditions [nondim], 0 or 1. + real, dimension(SZIB_(G),SZK_(GV)) :: & + h_at_vel, & ! Layer thickness at a velocity point, using an upwind-biased + ! second order accurate estimate based on the previous velocity + ! direction [H ~> m or kg m-2]. + h_vel, & ! Arithmetic mean of the layer thicknesses adjacent to a + ! velocity point [H ~> m or kg m-2]. + dz_at_vel, & ! Vertical extent of a layer, using an upwind-biased + ! second order accurate estimate based on the previous velocity + ! direction [Z ~> m]. + dz_vel, & ! Arithmetic mean of the difference in across the layers adjacent + ! to a velocity point [Z ~> m]. + T_vel, & ! Arithmetic mean of the layer temperatures adjacent to a + ! velocity point [C ~> degC]. + S_vel, & ! Arithmetic mean of the layer salinities adjacent to a + ! velocity point [S ~> ppt]. + SpV_vel, & ! Arithmetic mean of the layer averaged specific volumes adjacent to a + ! velocity point [R-1 ~> kg m-3]. + Rml_vel ! Arithmetic mean of the layer coordinate densities adjacent + ! to a velocity point [R ~> kg m-3]. + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + + real :: h_vel_pos ! The arithmetic mean thickness at a velocity point + ! plus H_neglect to avoid 0 values [H ~> m or kg m-2]. + real :: ustarsq ! 400 times the square of ustar, times + ! Rho0 divided by G_Earth and the conversion + ! from m to thickness units [H R ~> kg m-2 or kg2 m-5]. + real :: cdrag_sqrt ! Square root of the drag coefficient [nondim]. + real :: cdrag_sqrt_H ! Square root of the drag coefficient, times a unit conversion factor + ! from lateral lengths to layer thicknesses [H L-1 ~> nondim or kg m-3]. + real :: cdrag_sqrt_H_RL ! Square root of the drag coefficient, times a unit conversion factor from + ! density times lateral lengths to layer thicknesses [H L-1 R-1 ~> m3 kg-1 or nondim] + real :: cdrag_L_to_H ! The drag coefficient times conversion factors from lateral + ! distance to thickness units [H L-1 ~> nondim or kg m-3] + real :: cdrag_RL_to_H ! The drag coefficient times conversion factors from density times lateral + ! distance to thickness units [H L-1 R-1 ~> m3 kg-1 or nondim] + real :: cdrag_conv ! The drag coefficient times a combination of static conversion factors and in + ! situ density or Boussinesq reference density [H L-1 ~> nondim or kg m-3] + real :: oldfn ! The integrated energy required to + ! entrain up to the bottom of the layer, + ! divided by G_Earth [H R ~> kg m-2 or kg2 m-5]. + real :: Dfn ! The increment in oldfn for entraining + ! the layer [H R ~> kg m-2 or kg2 m-5]. + real :: frac_used ! The fraction of the present layer that contributes to Dh and Ddz [nondim] + real :: Dh ! The increment in layer thickness from + ! the present layer [H ~> m or kg m-2]. + real :: Ddz ! The increment in height change from the present layer [Z ~> m]. + real :: bbl_thick ! The thickness of the bottom boundary layer [Z ~> m]. + real :: BBL_thick_max ! A huge upper bound on the boundary layer thickness [Z ~> m]. + real :: kv_bbl ! The bottom boundary layer viscosity [H Z T-1 ~> m2 s-1 or Pa s] + real :: C2f ! C2f = 2*f at velocity points [T-1 ~> s-1]. + + real :: U_bg_sq ! The square of an assumed background + ! velocity, for calculating the mean + ! magnitude near the bottom for use in the + ! quadratic bottom drag [L2 T-2 ~> m2 s-2]. + real :: hwtot ! Sum of the thicknesses used to calculate + ! the near-bottom velocity magnitude [H ~> m or kg m-2]. + real :: I_hwtot ! The Adcroft reciprocal of hwtot [H-1 ~> m-1 or m2 kg-1]. + real :: dzwtot ! The vertical extent of the region used to calculate + ! the near-bottom velocity magnitude [Z ~> m]. + real :: hutot ! Running sum of thicknesses times the velocity + ! magnitudes [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: Thtot ! Running sum of thickness times temperature [C H ~> degC m or degC kg m-2]. + real :: Shtot ! Running sum of thickness times salinity [S H ~> ppt m or ppt kg m-2]. + real :: SpV_htot ! Running sum of thickness times specific volume [R-1 H ~> m4 kg-1 or m] + real :: hweight ! The thickness of a layer that is within Hbbl + ! of the bottom [H ~> m or kg m-2]. + real :: dzweight ! The counterpart of hweight in height units [Z ~> m]. + real :: v_at_u, u_at_v ! v at a u point or vice versa [L T-1 ~> m s-1]. + real :: Rho0x400_G ! 400*Rho0/G_Earth, times unit conversion factors + ! [R T2 H-1 ~> kg s2 m-4 or s2 m-1]. + ! The 400 is a constant proposed by Killworth and Edwards, 1999. + real, dimension(SZI_(G),SZJ_(G),max(GV%nk_rho_varies,1)) :: & + Rml ! The mixed layer coordinate density [R ~> kg m-3]. + real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate + ! density [R L2 T-2 ~> Pa] (usually set to 2e7 Pa = 2000 dbar). + + real :: D_vel ! The bottom depth at a velocity point [Z ~> m]. + real :: Dp, Dm ! The depths at the edges of a velocity cell [Z ~> m]. + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + real :: Vol_bbl_chan ! The volume of the bottom boundary layer as used in the channel + ! drag parameterization, normalized by the full horizontal area + ! of the velocity cell [Z ~> m]. + real :: vol_below(SZK_(GV)+1) ! The volume below each interface, normalized by the full + ! horizontal area of a velocity cell [Z ~> m]. + real :: L(SZK_(GV)+1) ! The fraction of the full cell width that is open at + ! the depth of each interface [nondim]. + ! The next 9 variables are only used for debugging. + real :: L_trig(SZK_(GV)+1) ! The fraction of the full cell width that is open at + ! the depth of each interface from trigonometric expressions [nondim]. + real :: vol_err_trig(SZK_(GV)+1) ! The error in the volume below based on L_trig [Z ~> m] + real :: vol_err_iter(SZK_(GV)+1) ! The error in the volume below based on L_iter [Z ~> m] + real :: norm_err_trig(SZK_(GV)+1) ! vol_err_trig normalized by vol_below [nondim] + real :: norm_err_iter(SZK_(GV)+1) ! vol_err_iter normalized by vol_below [nondim] + real :: dL_trig_itt(SZK_(GV)+1) ! The difference between estimates of the fraction of the full cell + ! width that is open at the depth of each interface [nondim]. + real :: max_dL_trig_itt ! The largest difference between L and L_trig, for debugging [nondim] + real :: max_norm_err_trig ! The largest magnitude value of norm_err_trig in a column [nondim] + real :: max_norm_err_iter ! The largest magnitude value of norm_err_iter in a column [nondim] + + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + real :: ustH ! ustar converted to units of H T-1 [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: root ! A temporary variable [H T-1 ~> m s-1 or kg m-2 s-1]. + + real :: Cell_width ! The transverse width of the velocity cell [L ~> m]. + real :: Rayleigh ! A factor that is multiplied by the layer's velocity magnitude + ! to give the Rayleigh drag velocity, times a lateral distance to + ! thickness conversion factor [H L-1 ~> nondim or kg m-3]. + real :: gam ! The ratio of the change in the open interface width + ! to the open interface width atop a cell [nondim]. + real :: BBL_frac ! The fraction of a layer's drag that goes into the + ! viscous bottom boundary layer [nondim]. + real :: BBL_visc_frac ! The fraction of all the drag that is expressed as + ! a viscous bottom boundary layer [nondim]. + real :: h_bbl_fr ! The fraction of the bottom boundary layer in a layer [nondim]. + real :: h_sum ! The sum of the thicknesses of the layers below the one being + ! worked on [H ~> m or kg m-2]. + real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0, C1_12 = 1.0/12.0 ! Rational constants [nondim] + real :: tmp ! A temporary variable, sometimes in [Z ~> m] + logical :: use_BBL_EOS, do_i(SZIB_(G)) + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m, n, K2, nkmb, nkml + type(ocean_OBC_type), pointer :: OBC => NULL() + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%isc-1 ; Ieq = G%IecB ; Jsq = G%jsc-1 ; Jeq = G%JecB + nkmb = GV%nk_rho_varies ; nkml = GV%nkml + h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff + + Rho0x400_G = 400.0*(GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth)) + + if (.not.CS%initialized) call MOM_error(FATAL,"MOM_set_viscosity(BBL): "//& + "Module must be initialized before it is used.") + + if (.not.CS%bottomdraglaw) return + + if (CS%debug) then + call uvchksum("Start set_viscous_BBL [uv]", u, v, G%HI, haloshift=1, scale=US%L_T_to_m_s) + call hchksum(h,"Start set_viscous_BBL h", G%HI, haloshift=1, scale=GV%H_to_m) + if (associated(tv%T)) call hchksum(tv%T, "Start set_viscous_BBL T", G%HI, haloshift=1, scale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Start set_viscous_BBL S", G%HI, haloshift=1, scale=US%S_to_ppt) + if (allocated(tv%SpV_avg)) & + call hchksum(tv%SpV_avg, "Start set_viscous_BBL SpV_avg", G%HI, haloshift=1, scale=US%kg_m3_to_R) + if (allocated(tv%SpV_avg)) call hchksum(tv%SpV_avg, "Cornerless SpV_avg", G%HI, & + haloshift=1, omit_corners=.true., scale=US%kg_m3_to_R) + if (associated(tv%T)) call hchksum(tv%T, "Cornerless T", G%HI, haloshift=1, omit_corners=.true., scale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Cornerless S", G%HI, haloshift=1, omit_corners=.true., scale=US%S_to_ppt) + endif + + use_BBL_EOS = associated(tv%eqn_of_state) .and. CS%BBL_use_EOS + OBC => CS%OBC + + U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel + cdrag_sqrt = sqrt(CS%cdrag) + cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H + cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H + cdrag_L_to_H = CS%cdrag * US%L_to_m * GV%m_to_H + cdrag_RL_to_H = CS%cdrag * US%L_to_Z * GV%RZ_to_H + BBL_thick_max = G%Rad_Earth_L * US%L_to_Z + K2 = max(nkmb+1, 2) + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + +! With a linear drag law, the friction velocity is already known. +! if (CS%linear_drag) ustar(:) = cdrag_sqrt_H*CS%drag_bg_vel + + if ((nkml>0) .and. .not.use_BBL_EOS) then + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo + !$OMP parallel do default(shared) + do k=1,nkmb ; do j=Jsq,Jeq+1 + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rml(:,j,k), tv%eqn_of_state, & + EOSdom) + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is-1,ie+1 + D_v(i,J) = 0.5*(G%bathyT(i,j) + G%bathyT(i,j+1)) + G%Z_ref + mask_v(i,J) = G%mask2dCv(i,J) + enddo ; enddo + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do I=is-1,ie + D_u(I,j) = 0.5*(G%bathyT(i,j) + G%bathyT(i+1,j)) + G%Z_ref + mask_u(I,j) = G%mask2dCu(I,j) + enddo ; enddo + + if (associated(OBC)) then ; do n=1,OBC%number_of_segments + if (.not. OBC%segment(n)%on_pe) cycle + ! Use a one-sided projection of bottom depths at OBC points. + I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB + if (OBC%segment(n)%is_N_or_S .and. (J >= js-1) .and. (J <= je)) then + do i = max(is-1,OBC%segment(n)%HI%isd), min(ie+1,OBC%segment(n)%HI%ied) + if (OBC%segment(n)%direction == OBC_DIRECTION_N) D_v(i,J) = G%bathyT(i,j) + G%Z_ref + if (OBC%segment(n)%direction == OBC_DIRECTION_S) D_v(i,J) = G%bathyT(i,j+1) + G%Z_ref + enddo + elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= ie)) then + do j = max(js-1,OBC%segment(n)%HI%jsd), min(je+1,OBC%segment(n)%HI%jed) + if (OBC%segment(n)%direction == OBC_DIRECTION_E) D_u(I,j) = G%bathyT(i,j) + G%Z_ref + if (OBC%segment(n)%direction == OBC_DIRECTION_W) D_u(I,j) = G%bathyT(i+1,j) + G%Z_ref + enddo + endif + enddo ; endif + if (associated(OBC)) then ; do n=1,OBC%number_of_segments + ! Now project bottom depths across cell-corner points in the OBCs. The two + ! projections have to occur in sequence and can not be combined easily. + if (.not. OBC%segment(n)%on_pe) cycle + ! Use a one-sided projection of bottom depths at OBC points. + I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB + if (OBC%segment(n)%is_N_or_S .and. (J >= js-1) .and. (J <= je)) then + do I = max(is-1,OBC%segment(n)%HI%IsdB), min(ie,OBC%segment(n)%HI%IedB) + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + D_u(I,j+1) = D_u(I,j) ; mask_u(I,j+1) = 0.0 + elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then + D_u(I,j) = D_u(I,j+1) ; mask_u(I,j) = 0.0 + endif + enddo + elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= ie)) then + do J = max(js-1,OBC%segment(n)%HI%JsdB), min(je,OBC%segment(n)%HI%JedB) + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + D_v(i+1,J) = D_v(i,J) ; mask_v(i+1,J) = 0.0 + elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then + D_v(i,J) = D_v(i+1,J) ; mask_v(i,J) = 0.0 + endif + enddo + endif + enddo ; endif + + if (.not.use_BBL_EOS) Rml_vel(:,:) = 0.0 + + if (allocated(visc%Ray_u)) visc%Ray_u(:,:,:) = 0.0 + if (allocated(visc%Ray_v)) visc%Ray_v(:,:,:) = 0.0 + + !$OMP parallel do default(private) shared(u,v,h,dz,tv,visc,G,GV,US,CS,Rml,nz,nkmb,nkml,K2, & + !$OMP Isq,Ieq,Jsq,Jeq,h_neglect,dz_neglect,Rho0x400_G, & + !$OMP U_bg_sq,cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL, & + !$OMP cdrag_L_to_H,cdrag_RL_to_H,use_BBL_EOS,BBL_thick_max, & + !$OMP OBC,D_u,D_v,mask_u,mask_v,pbv) + do j=Jsq,Jeq ; do m=1,2 + + if (m==1) then + ! m=1 refers to u-points + if (j 0.0) + enddo + else + ! m=2 refers to v-points + is = G%isc ; ie = G%iec + do i=is,ie + do_i(i) = (G%mask2dCv(i,J) > 0.0) + enddo + endif + + ! Calculate thickness at velocity points (u or v depending on value of m). + ! Also interpolate the ML density or T/S properties. + if (m==1) then ! u-points + do k=1,nz ; do I=is,ie + if (do_i(I)) then + if (u(I,j,k) * (h(i+1,j,k) - h(i,j,k)) >= 0) then + ! If the flow is from thin to thick then bias towards the thinner thickness + h_at_vel(I,k) = 2.0*h(i,j,k)*h(i+1,j,k) / & + (h(i,j,k) + h(i+1,j,k) + h_neglect) + dz_at_vel(I,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / & + (dz(i,j,k) + dz(i+1,j,k) + dz_neglect) + else + ! If the flow is from thick to thin then use the simple average thickness + h_at_vel(I,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_at_vel(I,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k)) + endif + endif + h_vel(I,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_vel(I,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k)) + enddo ; enddo + if (use_BBL_EOS) then ; do k=1,nz ; do I=is,ie + ! Perhaps these should be thickness weighted. + T_vel(I,k) = 0.5 * (tv%T(i,j,k) + tv%T(i+1,j,k)) + S_vel(I,k) = 0.5 * (tv%S(i,j,k) + tv%S(i+1,j,k)) + enddo ; enddo ; else ; do k=1,nkmb ; do I=is,ie + Rml_vel(I,k) = 0.5 * (Rml(i,j,k) + Rml(i+1,j,k)) + enddo ; enddo ; endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz ; do I=is,ie + SpV_vel(I,k) = 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + enddo ; enddo ; endif + else ! v-points + do k=1,nz ; do i=is,ie + if (do_i(i)) then + if (v(i,J,k) * (h(i,j+1,k) - h(i,j,k)) >= 0) then + ! If the flow is from thin to thick then bias towards the thinner thickness + h_at_vel(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / & + (h(i,j,k) + h(i,j+1,k) + h_neglect) + dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / & + (dz(i,j,k) + dz(i,j+1,k) + dz_neglect) + else + ! If the flow is from thick to thin then use the simple average thickness + h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k)) + endif + endif + h_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k)) + enddo ; enddo + if (use_BBL_EOS) then ; do k=1,nz ; do i=is,ie + ! Perhaps these should be thickness weighted. + T_vel(i,k) = 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k)) + S_vel(i,k) = 0.5 * (tv%S(i,j,k) + tv%S(i,j+1,k)) + enddo ; enddo ; else ; do k=1,nkmb ; do i=is,ie + Rml_vel(i,k) = 0.5 * (Rml(i,j,k) + Rml(i,j+1,k)) + enddo ; enddo ; endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz ; do i=is,ie + SpV_vel(i,k) = 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + enddo ; enddo ; endif + endif + + if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then + ! Apply a zero gradient projection of thickness across OBC points. + if (m==1) then + do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do k=1,nz + h_at_vel(I,k) = h(i,j,k) ; h_vel(I,k) = h(i,j,k) + dz_at_vel(I,k) = dz(i,j,k) ; dz_vel(I,k) = dz(i,j,k) + enddo + if (use_BBL_EOS) then + do k=1,nz + T_vel(I,k) = tv%T(i,j,k) ; S_vel(I,k) = tv%S(i,j,k) + enddo + else + do k=1,nkmb + Rml_vel(I,k) = Rml(i,j,k) + enddo + endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(I,k) = tv%SpV_avg(i,j,k) + enddo ; endif + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + do k=1,nz + h_at_vel(I,k) = h(i+1,j,k) ; h_vel(I,k) = h(i+1,j,k) + dz_at_vel(I,k) = dz(i+1,j,k) ; dz_vel(I,k) = dz(i+1,j,k) + enddo + if (use_BBL_EOS) then + do k=1,nz + T_vel(I,k) = tv%T(i+1,j,k) ; S_vel(I,k) = tv%S(i+1,j,k) + enddo + else + do k=1,nkmb + Rml_vel(I,k) = Rml(i+1,j,k) + enddo + endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(I,k) = tv%SpV_avg(i+1,j,k) + enddo ; endif + endif + endif ; enddo + else + do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do k=1,nz + h_at_vel(i,k) = h(i,j,k) ; h_vel(i,k) = h(i,j,k) + dz_at_vel(i,k) = dz(i,j,k) ; dz_vel(i,k) = dz(i,j,k) + enddo + if (use_BBL_EOS) then + do k=1,nz + T_vel(i,k) = tv%T(i,j,k) ; S_vel(i,k) = tv%S(i,j,k) + enddo + else + do k=1,nkmb + Rml_vel(i,k) = Rml(i,j,k) + enddo + endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(i,k) = tv%SpV_avg(i,j,k) + enddo ; endif + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + do k=1,nz + h_at_vel(i,k) = h(i,j+1,k) ; h_vel(i,k) = h(i,j+1,k) + dz_at_vel(i,k) = dz(i,j+1,k) ; dz_vel(i,k) = dz(i,j+1,k) + enddo + if (use_BBL_EOS) then + do k=1,nz + T_vel(i,k) = tv%T(i,j+1,k) ; S_vel(i,k) = tv%S(i,j+1,k) + enddo + else + do k=1,nkmb + Rml_vel(i,k) = Rml(i,j+1,k) + enddo + endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(i,k) = tv%SpV_avg(i,j+1,k) + enddo ; endif + endif + endif ; enddo + endif + endif ; endif + + if (use_BBL_EOS .or. CS%body_force_drag .or. .not.CS%linear_drag) then + ! Calculate the mean velocity magnitude over the bottommost CS%Hbbl of + ! the water column for determining the quadratic bottom drag. + ! Used in ustar(i) + do i=is,ie ; if (do_i(i)) then + htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 + dztot_vel = 0.0 ; dzwtot = 0.0 + Thtot = 0.0 ; Shtot = 0.0 ; SpV_htot = 0.0 + do k=nz,1,-1 + + if (htot_vel>=CS%Hbbl) exit ! terminate the k loop + + hweight = MIN(CS%Hbbl - htot_vel, h_at_vel(i,k)) + if (hweight < 1.5*GV%Angstrom_H + h_neglect) cycle + dzweight = MIN(CS%dz_bbl - dztot_vel, dz_at_vel(i,k)) + + htot_vel = htot_vel + h_at_vel(i,k) + hwtot = hwtot + hweight + dztot_vel = dztot_vel + dz_at_vel(i,k) + dzwtot = dzwtot + dzweight + + if ((.not.CS%linear_drag) .and. (hweight >= 0.0)) then ; if (m==1) then + v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) + if (CS%BBL_use_tidal_bg) then + U_bg_sq = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i+1,j)*(CS%tideamp(i+1,j)*CS%tideamp(i+1,j)) ) + endif + hutot = hutot + hweight * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + U_bg_sq) + else + u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC) + if (CS%BBL_use_tidal_bg) then + U_bg_sq = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i,j+1)*(CS%tideamp(i,j+1)*CS%tideamp(i,j+1)) ) + endif + hutot = hutot + hweight * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + U_bg_sq) + endif ; endif + + if (use_BBL_EOS .and. (hweight >= 0.0)) then + Thtot = Thtot + hweight * T_vel(i,k) + Shtot = Shtot + hweight * S_vel(i,k) + endif + if (allocated(tv%SpV_avg) .and. (hweight >= 0.0)) then + SpV_htot = SpV_htot + hweight * SpV_vel(i,k) + endif + enddo ! end of k loop + + ! Find the Adcroft reciprocal of the total thickness weights + I_hwtot = 0.0 ; if (hwtot > 0.0) I_hwtot = 1.0 / hwtot + + ! Set u* based on u*^2 = Cdrag u_bbl^2 + if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then + ustar(i) = cdrag_sqrt_H * CS%drag_bg_vel + elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then + ustar(i) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot) + elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag) + ustar(i) = cdrag_sqrt_H_RL * hutot / SpV_htot + else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg)) + ustar(i) = cdrag_sqrt_H * hutot / hwtot + endif + + umag_avg(i) = hutot * I_hwtot + h_bbl_drag(i) = hwtot + dz_bbl_drag(i) = dzwtot + + if (use_BBL_EOS) then ; if (hwtot > 0.0) then + T_EOS(i) = Thtot/hwtot ; S_EOS(i) = Shtot/hwtot + else + T_EOS(i) = 0.0 ; S_EOS(i) = 0.0 + endif ; endif + + ! Diagnostic BBL flow speed at u- and v-points. + if (CS%id_bbl_u>0 .and. m==1) then + if (hwtot > 0.0) CS%bbl_u(I,j) = hutot/hwtot + elseif (CS%id_bbl_v>0 .and. m==2) then + if (hwtot > 0.0) CS%bbl_v(i,J) = hutot/hwtot + endif + + endif ; enddo + else + do i=is,ie ; ustar(i) = cdrag_sqrt_H*CS%drag_bg_vel ; enddo + endif ! Not linear_drag + + if (use_BBL_EOS) then + if (associated(tv%p_surf)) then + if (m==1) then ; do i=is,ie ; press(I) = 0.5*(tv%p_surf(i,j) + tv%p_surf(i+1,j)) ; enddo + else ; do i=is,ie ; press(i) = 0.5*(tv%p_surf(i,j) + tv%p_surf(i,j+1)) ; enddo ; endif + else + do i=is,ie ; press(i) = 0.0 ; enddo + endif + do i=is,ie ; if (.not.do_i(i)) then ; T_EOS(i) = 0.0 ; S_EOS(i) = 0.0 ; endif ; enddo + do k=1,nz ; do i=is,ie + press(i) = press(i) + (GV%H_to_RZ*GV%g_Earth) * h_vel(i,k) + enddo ; enddo + call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, tv%eqn_of_state, & + (/is-G%IsdB+1,ie-G%IsdB+1/) ) + endif + + ! Find a BBL thickness given by equation 2.20 of Killworth and Edwards, 1999: + ! ( f h / Cn u* )^2 + ( N h / Ci u* ) = 1 + ! where Cn=0.5 and Ci=20 (constants suggested by Zilitinkevich and Mironov, 1996). + ! Eq. 2.20 can be expressed in terms of boundary layer thicknesses limited by + ! rotation (h_f) and stratification (h_N): + ! ( h / h_f )^2 + ( h / h_N ) = 1 + ! When stratification dominates h_N< kg m-2 or kg2 m-5] + htot = 0.0 + dztot = 0.0 + + ! Calculate the thickness of a stratification limited BBL ignoring rotation: + ! h_N = Ci u* / N (limit of KW99 eq. 2.20 for |f|->0) + ! For layer mode, N^2 = g'/h. Since (Ci u*)^2 = (h_N N)^2 = h_N g' then + ! h_N = (Ci u*)^2 / g' (KW99, eq, 2.22) + ! Starting from the bottom, integrate the stratification upward until h_N N balances Ci u* + ! or in layer mode + ! h_N Delta rho ~ (Ci u*)^2 rho0 / g + ! where the rhs is stored in variable ustarsq. + ! The method was described in Stephens and Hallberg 2000 (unpublished and lost manuscript). + if (use_BBL_EOS) then + Thtot = 0.0 ; Shtot = 0.0 ; oldfn = 0.0 + do k=nz,2,-1 + if (h_at_vel(i,k) <= 0.0) cycle + + ! Delta rho * h_bbl assuming everything below is homogenized + oldfn = dR_dT(i)*(Thtot - T_vel(i,k)*htot) + & + dR_dS(i)*(Shtot - S_vel(i,k)*htot) + if (oldfn >= ustarsq) exit + + ! Local Delta rho * h_bbl at interface + Dfn = (dR_dT(i)*(T_vel(i,k) - T_vel(i,k-1)) + & + dR_dS(i)*(S_vel(i,k) - S_vel(i,k-1))) * & + (h_at_vel(i,k) + htot) + + if ((oldfn + Dfn) <= ustarsq) then + ! Use whole layer + Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) + else + ! Use only part of the layer + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used + endif + + ! Increment total BBL thickness and cumulative T and S + htot = htot + Dh + dztot = dztot + Ddz + Thtot = Thtot + T_vel(i,k)*Dh ; Shtot = Shtot + S_vel(i,k)*Dh + enddo + if ((oldfn < ustarsq) .and. h_at_vel(i,1) > 0.0) then + ! Layer 1 might be part of the BBL. + if (dR_dT(i) * (Thtot - T_vel(i,1)*htot) + & + dR_dS(i) * (Shtot - S_vel(i,1)*htot) < ustarsq) then + htot = htot + h_at_vel(i,1) + dztot = dztot + dz_at_vel(i,1) + endif + endif ! Examination of layer 1. + else ! Use Rlay and/or the coordinate density as density variables. + Rhtot = 0.0 + do k=nz,K2,-1 + oldfn = Rhtot - GV%Rlay(k)*htot + Dfn = (GV%Rlay(k) - GV%Rlay(k-1))*(h_at_vel(i,k)+htot) + + if (oldfn >= ustarsq) then + cycle + elseif ((oldfn + Dfn) <= ustarsq) then + Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) + else + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used + endif + + htot = htot + Dh + dztot = dztot + Ddz + Rhtot = Rhtot + GV%Rlay(k)*Dh + enddo + if (nkml>0) then + do k=nkmb,2,-1 + oldfn = Rhtot - Rml_vel(i,k)*htot + Dfn = (Rml_vel(i,k) - Rml_vel(i,k-1)) * (h_at_vel(i,k)+htot) + + if (oldfn >= ustarsq) then + cycle + elseif ((oldfn + Dfn) <= ustarsq) then + Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) + else + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used + endif + + htot = htot + Dh + dztot = dztot + Ddz + Rhtot = Rhtot + Rml_vel(i,k)*Dh + enddo + if (Rhtot - Rml_vel(i,1)*htot < ustarsq) then + htot = htot + h_at_vel(i,1) + dztot = dztot + dz_at_vel(i,1) + endif + else + if (Rhtot - GV%Rlay(1)*htot < ustarsq) then + htot = htot + h_at_vel(i,1) + dztot = dztot + dz_at_vel(i,1) + endif + endif + endif ! use_BBL_EOS + + ! Value of 2*f at u- or v-points. + if (m==1) then ; C2f = G%CoriolisBu(I,J-1) + G%CoriolisBu(I,J) + else ; C2f = G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J) ; endif + + ! The thickness of a rotation limited BBL ignoring stratification is + ! h_f ~ Cn u* / f (limit of KW99 eq. 2.20 for N->0). + ! The buoyancy limit of BBL thickness (h_N) is already in the variable htot from above. + ! Substituting x = h_N/h into KW99 eq. 2.20 yields the quadratic + ! x^2 - x = (h_N / h_f)^2 + ! for which the positive root is + ! xp = 1/2 + sqrt( 1/4 + (h_N/h_f)^2 ) + ! and thus h_bbl = h_N / xp . Since h_f = Cn u*/f and Cn=0.5 + ! xp = 1/2 + sqrt( 1/4 + (2 f h_N/u*)^2 ) + ! To avoid dividing by zero if u*=0 then + ! xp u* = 1/2 u* + sqrt( 1/4 u*^2 + (2 f h_N)^2 ) + if (CS%cdrag * U_bg_sq <= 0.0) then + ! This avoids NaNs and overflows, and could be used in all cases, + ! but is not bitwise identical to the current code. + ustH = ustar(i) ; root = sqrt(0.25*ustH**2 + (htot*C2f)**2) + if (dztot*ustH <= (CS%BBL_thick_min+dz_neglect) * (0.5*ustH + root)) then + bbl_thick = CS%BBL_thick_min + else + ! The following expression reads + ! h_bbl = h_N u* / ( 1/2 u* + sqrt( 1/4 u*^2 + ( 2 f h_N )^2 ) ) + ! which is h_bbl = h_N u*/(xp u*) as described above. + bbl_thick = (dztot * ustH) / (0.5*ustH + root) + endif + else + ! The following expression reads + ! h_bbl = h_N / ( 1/2 + sqrt( 1/4 + ( 2 f h_N / u* )^2 ) ) + ! which is h_bbl = h_N/xp as described above. + bbl_thick = dztot / (0.5 + sqrt(0.25 + htot*htot*C2f*C2f / (ustar(i)*ustar(i)) ) ) + + if (bbl_thick < CS%BBL_thick_min) bbl_thick = CS%BBL_thick_min + endif + + ! Store the normalized bottom boundary layer volume. + if (CS%Channel_drag) Vol_bbl_chan = bbl_thick + + ! If there is Richardson number dependent mixing, that determines + ! the vertical extent of the bottom boundary layer, and there is no + ! need to set that scale here. In fact, viscously reducing the + ! shears over an excessively large region reduces the efficacy of + ! the Richardson number dependent mixing. + ! In other words, if using RiNo_mix then CS%dz_bbl acts as an upper bound on + ! bbl_thick. + if ((bbl_thick > 0.5*CS%dz_bbl) .and. (CS%RiNo_mix)) bbl_thick = 0.5*CS%dz_bbl + + ! If drag is a body force, bbl_thick is HBBL + if (CS%body_force_drag) bbl_thick = dz_bbl_drag(i) + + if (CS%Channel_drag) then + + vol_below(nz+1) = 0.0 + do K=nz,1,-1 + vol_below(K) = vol_below(K+1) + dz_vel(i,k) + enddo + + !### The harmonic mean edge depths here are not invariant to offsets! + if (m==1) then + D_vel = D_u(I,j) + tmp = G%mask2dCu(I,j+1) * D_u(I,j+1) + Dp = 2.0 * D_vel * tmp / (D_vel + tmp) + tmp = G%mask2dCu(I,j-1) * D_u(I,j-1) + Dm = 2.0 * D_vel * tmp / (D_vel + tmp) + else + D_vel = D_v(i,J) + tmp = G%mask2dCv(i+1,J) * D_v(i+1,J) + Dp = 2.0 * D_vel * tmp / (D_vel + tmp) + tmp = G%mask2dCv(i-1,J) * D_v(i-1,J) + Dm = 2.0 * D_vel * tmp / (D_vel + tmp) + endif + if (Dm > Dp) then ; tmp = Dp ; Dp = Dm ; Dm = tmp ; endif + crv = 3.0*(Dp + Dm - 2.0*D_vel) + slope = Dp - Dm + + ! If the curvature is small enough, there is no reason not to assume + ! a uniformly sloping or flat bottom. + if (abs(crv) < 1e-2*(slope + CS%BBL_thick_min)) crv = 0.0 + + ! Determine the normalized open length (L) at each interface. + if (crv == 0.0) then + call find_L_open_uniform_slope(vol_below, Dp, Dm, L, GV) + elseif (crv > 0.0) then + if (CS%concave_trigonometric_L) then + call find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L, GV) + else + call find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV) + if (CS%debug) then + ! The tests in this block reveal that the iterative and trigonometric solutions are + ! mathematically equivalent, but in some cases the iterative solution is consistent + ! at roundoff, but that the trigonmetric solutions have errors that can be several + ! orders of magnitude larger in some cases. + call find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L_trig, GV) + call test_L_open_concave(vol_below, D_vel, Dp, Dm, L_trig, vol_err_trig, GV) + call test_L_open_concave(vol_below, D_vel, Dp, Dm, L, vol_err_iter, GV) + max_dL_trig_itt = 0.0 ; max_norm_err_trig = 0.0 ; max_norm_err_iter = 0.0 + norm_err_trig(:) = 0.0 ; norm_err_iter(:) = 0.0 + do K=1,nz+1 + dL_trig_itt(K) = L_trig(K) - L(K) + if (abs(dL_trig_itt(K)) > abs(max_dL_trig_itt)) max_dL_trig_itt = dL_trig_itt(K) + norm_err_trig(K) = vol_err_trig(K) / (vol_below(K) + dz_neglect) + norm_err_iter(K) = vol_err_iter(K) / (vol_below(K) + dz_neglect) + if (abs(norm_err_trig(K)) > abs(max_norm_err_trig)) max_norm_err_trig = norm_err_trig(K) + if (abs(norm_err_iter(K)) > abs(max_norm_err_iter)) max_norm_err_iter = norm_err_iter(K) + enddo + if (abs(max_dL_trig_itt) > 1.0e-13) & + K = nz+1 ! This is here only to use as a break point for a debugger. + if (abs(max_norm_err_trig) > 1.0e-13) & + K = nz+1 ! This is here only to use as a break point for a debugger. + if (abs(max_norm_err_iter) > 1.0e-13) & + K = nz+1 ! This is here only to use as a break point for a debugger. + endif + endif + else ! crv < 0.0 + call find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS) + endif ! end of crv<0 cases. + + ! Determine the Rayleigh drag contributions. + + ! The drag within the bottommost Vol_bbl_chan is applied as a part of an enhanced bottom + ! viscosity, while above this the drag is applied directly to the layers in question as a + ! Rayleigh drag term. + + ! Restrict the volume over which the channel drag is applied from the previously determined value. + if (CS%Chan_drag_max_vol >= 0.0) Vol_bbl_chan = min(Vol_bbl_chan, CS%Chan_drag_max_vol) + + BBL_visc_frac = 0.0 + do K=nz,1,-1 + !modify L(K) for porous barrier parameterization + if (m==1) then ; L(K) = L(K)*pbv%por_layer_widthU(I,j,K) + else ; L(K) = L(K)*pbv%por_layer_widthV(i,J,K); endif + + ! Determine the drag contributing to the bottom boundary layer + ! and the Rayleigh drag that acts on each layer. + if (L(K) > L(K+1)) then + if (vol_below(K+1) < Vol_bbl_chan) then + BBL_frac = (1.0-vol_below(K+1)/Vol_bbl_chan)**2 + BBL_visc_frac = BBL_visc_frac + BBL_frac*(L(K) - L(K+1)) + else + BBL_frac = 0.0 + endif + + if (allocated(tv%SpV_avg)) then + cdrag_conv = cdrag_RL_to_H / SpV_vel(i,k) + else + cdrag_conv = cdrag_L_to_H + endif + + h_vel_pos = h_vel(i,k) + h_neglect + if (m==1) then ; Cell_width = G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k) + else ; Cell_width = G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k) ; endif + gam = 1.0 - L(K+1)/L(K) + Rayleigh = cdrag_conv * (L(K)-L(K+1)) * (1.0-BBL_frac) * & + (12.0*CS%c_Smag*h_vel_pos) / (12.0*CS%c_Smag*h_vel_pos + & + cdrag_conv * gam*(1.0-gam)*(1.0-1.5*gam) * L(K)**2 * Cell_width) + else ! This layer feels no drag. + Rayleigh = 0.0 + endif + + if (m==1) then + if (Rayleigh > 0.0) then + v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) + visc%Ray_u(I,j,k) = Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + U_bg_sq) + else ; visc%Ray_u(I,j,k) = 0.0 ; endif + else + if (Rayleigh > 0.0) then + u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC) + visc%Ray_v(i,J,k) = Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + U_bg_sq) + else ; visc%Ray_v(i,J,k) = 0.0 ; endif + endif + + enddo ! k loop to determine visc%Ray_[uv]. + + ! Set the near-bottom viscosity to a value which will give + ! the correct stress when the shear occurs over bbl_thick. + ! See next block for explanation. + if (CS%correct_BBL_bounds .and. & + cdrag_sqrt*ustar(i)*bbl_thick*BBL_visc_frac <= CS%Kv_BBL_min) then + ! If the bottom stress implies less viscosity than Kv_BBL_min then + ! set kv_bbl to the bound and recompute bbl_thick to be consistent + ! but with a ridiculously large upper bound on thickness (for Cd u*=0) + kv_bbl = CS%Kv_BBL_min + if ((cdrag_sqrt*ustar(i))*BBL_visc_frac*BBL_thick_max > kv_bbl) then + bbl_thick = kv_bbl / ( (cdrag_sqrt*ustar(i)) * BBL_visc_frac ) + else + bbl_thick = BBL_thick_max + endif + else + kv_bbl = (cdrag_sqrt*ustar(i)) * bbl_thick*BBL_visc_frac + endif + + else ! Not Channel_drag. + ! Set the near-bottom viscosity to a value which will give + ! the correct stress when the shear occurs over bbl_thick. + ! - The bottom stress is tau_b = Cdrag * u_bbl^2 + ! - u_bbl was calculated by averaging flow over CS%Hbbl + ! (and includes unresolved tidal components) + ! - u_bbl is embedded in u* since u*^2 = Cdrag u_bbl^2 + ! - The average shear in the BBL is du/dz = 2 * u_bbl / h_bbl + ! (which assumes a linear profile, hence the "2") + ! - bbl_thick was bounded to <= 0.5 * CS%dz_bbl + ! - The viscous stress kv_bbl du/dz should balance tau_b + ! Cdrag u_bbl^2 = kv_bbl du/dz + ! = 2 kv_bbl u_bbl + ! so + ! kv_bbl = 0.5 h_bbl Cdrag u_bbl + ! = 0.5 h_bbl sqrt(Cdrag) u* + if (CS%correct_BBL_bounds .and. & + cdrag_sqrt*ustar(i)*bbl_thick <= CS%Kv_BBL_min) then + ! If the bottom stress implies less viscosity than Kv_BBL_min then + ! set kv_bbl to the bound and recompute bbl_thick to be consistent + ! but with a ridiculously large upper bound on thickness (for Cd u*=0) + kv_bbl = CS%Kv_BBL_min + if ((cdrag_sqrt*ustar(i))*BBL_thick_max > kv_bbl) then + bbl_thick = kv_bbl / ( cdrag_sqrt*ustar(i) ) + else + bbl_thick = BBL_thick_max + endif + else + kv_bbl = (cdrag_sqrt*ustar(i)) * bbl_thick + endif + endif + + if (CS%body_force_drag) then ; if (h_bbl_drag(i) > 0.0) then + ! Increment the Rayleigh drag as a way introduce the bottom drag as a body force. + h_sum = 0.0 + I_hwtot = 1.0 / h_bbl_drag(i) + do k=nz,1,-1 + h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot + if (allocated(tv%SpV_avg)) then + cdrag_conv = cdrag_RL_to_H / SpV_vel(i,k) + else + cdrag_conv = cdrag_L_to_H + endif + if (m==1) then + visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + (cdrag_conv * umag_avg(I)) * h_bbl_fr + else + visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + (cdrag_conv * umag_avg(i)) * h_bbl_fr + endif + h_sum = h_sum + h_at_vel(i,k) + if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone. + enddo + ! Do not enhance the near-bottom viscosity in this case. + Kv_bbl = CS%Kv_BBL_min + endif ; endif + + kv_bbl = max(CS%Kv_BBL_min, kv_bbl) + if (m==1) then + visc%bbl_thick_u(I,j) = bbl_thick + if (allocated(visc%Kv_bbl_u)) visc%Kv_bbl_u(I,j) = kv_bbl + else + visc%bbl_thick_v(i,J) = bbl_thick + if (allocated(visc%Kv_bbl_v)) visc%Kv_bbl_v(i,J) = kv_bbl + endif + endif ; enddo ! end of i loop + enddo ; enddo ! end of m & j loops + +! Offer diagnostics for averaging + if (CS%id_bbl_thick_u > 0) & + call post_data(CS%id_bbl_thick_u, visc%bbl_thick_u, CS%diag) + if (CS%id_kv_bbl_u > 0) & + call post_data(CS%id_kv_bbl_u, visc%kv_bbl_u, CS%diag) + if (CS%id_bbl_u > 0) & + call post_data(CS%id_bbl_u, CS%bbl_u, CS%diag) + if (CS%id_bbl_thick_v > 0) & + call post_data(CS%id_bbl_thick_v, visc%bbl_thick_v, CS%diag) + if (CS%id_kv_bbl_v > 0) & + call post_data(CS%id_kv_bbl_v, visc%kv_bbl_v, CS%diag) + if (CS%id_bbl_v > 0) & + call post_data(CS%id_bbl_v, CS%bbl_v, CS%diag) + if (CS%id_Ray_u > 0) & + call post_data(CS%id_Ray_u, visc%Ray_u, CS%diag) + if (CS%id_Ray_v > 0) & + call post_data(CS%id_Ray_v, visc%Ray_v, CS%diag) + + if (CS%debug) then + if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) & + call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, & + scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) + if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) & + call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & + haloshift=0, scale=GV%HZ_T_to_m2_s, scalar_pair=.true.) + if (allocated(visc%bbl_thick_u) .and. allocated(visc%bbl_thick_v)) & + call uvchksum("bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, & + G%HI, haloshift=0, scale=US%Z_to_m, scalar_pair=.true.) + endif + +end subroutine set_viscous_BBL + +!> Determine the normalized open length of each interface, given the edge depths and normalized +!! volumes below each interface. +subroutine find_L_open_uniform_slope(vol_below, Dp, Dm, L, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + + ! Local variables + real :: slope ! The absolute value of the bottom depth slope across a cell times the cell width [Z ~> m]. + real :: I_slope ! The inverse of the normalized slope [Z-1 ~> m-1] + real :: Vol_open ! The cell volume above which it is open [Z ~> m]. + integer :: K, nz + + nz = GV%ke + + slope = abs(Dp - Dm) + if (slope == 0.0) then + L(1:nz) = 1.0 ; L(nz+1) = 0.0 + else + Vol_open = 0.5*slope + I_slope = 1.0 / slope + + L(nz+1) = 0.0 + do K=nz,1,-1 + if (vol_below(K) >= Vol_open) then ; L(K) = 1.0 + else + ! With a uniformly sloping bottom, the calculation of L(K) is the solution of a simple quadratic equation. + L(K) = sqrt(2.0*vol_below(K)*I_slope) + endif + enddo + endif + +end subroutine find_L_open_uniform_slope + +!> Determine the normalized open length of each interface for concave bathymetry (from the ocean perspective) +!! using trigonometric expressions. In this case there can be two separate open regions. +subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: D_vel !< The average bottom depth at a velocity point [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + + ! Local variables + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + ! The following "volumes" have units of vertical heights because they are normalized + ! by the full horizontal area of a velocity cell. + real :: Vol_open ! The cell volume above which the face is fully is open [Z ~> m]. + real :: Vol_2_reg ! The cell volume above which there are two separate + ! open areas that must be integrated [Z ~> m]. + real :: C24_crv ! 24/crv [Z-1 ~> m-1]. + real :: apb_4a, ax2_3apb ! Various nondimensional ratios of crv and slope [nondim]. + real :: a2x48_apb3, Iapb ! Combinations of crv (a) and slope (b) [Z-1 ~> m-1] + real :: L0 ! A linear estimate of L appropriate for tiny volumes [nondim]. + real :: slope_crv ! The slope divided by the curvature [nondim] + real :: tmp_val_m1_to_p1 ! A temporary variable [nondim] + real, parameter :: C1_3 = 1.0/3.0, C1_12 = 1.0/12.0 ! Rational constants [nondim] + real, parameter :: C2pi_3 = 8.0*atan(1.0)/3.0 ! An irrational constant, 2/3 pi. [nondim] + integer :: K, nz + + nz = GV%ke + + ! Each cell extends from x=-1/2 to 1/2, and has a topography + ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + slope = Dp - Dm + + ! Calculate the volume above which the entire cell is open and the volume at which the + ! equation that is solved for L changes because there are two separate open regions. + if (slope >= crv) then + Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open + else + slope_crv = slope / crv + Vol_open = 0.25*slope*slope_crv + C1_12*crv + Vol_2_reg = 0.5*slope_crv**2 * (crv - C1_3*slope) + endif + ! Define some combinations of crv & slope for later use. + C24_crv = 24.0/crv ; Iapb = 1.0/(crv+slope) + apb_4a = (slope+crv)/(4.0*crv) ; a2x48_apb3 = (48.0*(crv*crv))*(Iapb**3) + ax2_3apb = 2.0*C1_3*crv*Iapb + + L(nz+1) = 0.0 + ! Determine the normalized open length (L) at each interface. + do K=nz,1,-1 + if (vol_below(K) >= Vol_open) then ! The whole cell is open. + L(K) = 1.0 + elseif (vol_below(K) < Vol_2_reg) then + ! In this case, there is a contiguous open region and + ! vol_below(K) = 0.5*L^2*(slope + crv/3*(3-4L)). + if (a2x48_apb3*vol_below(K) < 1e-8) then ! Could be 1e-7? + ! There is a very good approximation here for massless layers. + L0 = sqrt(2.0*vol_below(K)*Iapb) ; L(K) = L0*(1.0 + ax2_3apb*L0) + else + L(K) = apb_4a * (1.0 - & + 2.0 * cos(C1_3*acos(a2x48_apb3*vol_below(K) - 1.0) - C2pi_3)) + endif + ! To check the answers. + ! Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + else ! There are two separate open regions. + ! vol_below(K) = slope^2/4crv + crv/12 - (crv/12)*(1-L)^2*(1+2L) + ! At the deepest volume, L = slope/crv, at the top L = 1. + ! L(K) = 0.5 - cos(C1_3*acos(1.0 - C24_crv*(Vol_open - vol_below(K))) - C2pi_3) + tmp_val_m1_to_p1 = 1.0 - C24_crv*(Vol_open - vol_below(K)) + tmp_val_m1_to_p1 = max(-1., min(1., tmp_val_m1_to_p1)) + L(K) = 0.5 - cos(C1_3*acos(tmp_val_m1_to_p1) - C2pi_3) + ! To check the answers. + ! Vol_err = Vol_open - 0.25*crv_3*(1.0+2.0*L(K)) * (1.0-L(K))**2 - vol_below(K) + endif + enddo ! k loop to determine L(K) in the concave case + +end subroutine find_L_open_concave_trigonometric + + + +!> Determine the normalized open length of each interface for concave bathymetry (from the ocean perspective) using +!! iterative methods to solve the relevant cubic equations. In this case there can be two separate open regions. +subroutine find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: D_vel !< The average bottom depth at a velocity point [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + + ! Local variables + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + + ! The following "volumes" have units of vertical heights because they are normalized + ! by the full horizontal area of a velocity cell. + real :: Vol_open ! The cell volume above which the face is fully is open [Z ~> m]. + real :: Vol_2_reg ! The cell volume above which there are two separate + ! open areas that must be integrated [Z ~> m]. + real :: L_2_reg ! The value of L when vol_below is Vol_2_reg [nondim] + real :: vol_inflect_1 ! The volume at which there is an inflection point in the expression + ! relating L to vol_err when there is a single open region [Z ~> m] + real :: vol_inflect_2 ! The volume at which there is an inflection point in the expression + ! relating L to vol_err when there are two open regions [Z ~> m] + + real :: L_inflect_1 ! The value of L that sits at an inflection point in the expression + ! relating L to vol_err when there is a single open region [nondim] + real :: L_inflect_2 ! The value of L that sits at an inflection point in the expression + ! relating L to vol_err when there is are two open regions [nondim] + real :: L_max, L_min ! Maximum and minimum bounds on the solution for L for an interface [nondim] + real :: vol_err ! The difference between the volume below an interface for a given value + ! of L and the target value [Z ~> m] + real :: dVol_dL ! The partial derivative of the volume below with L [Z ~> m] + real :: vol_err_max ! The value of vol_err when L is L_max [Z ~> m] + + ! The following combinations of slope and crv are reused across layers, and hence are pre-calculated + ! for efficiency. All are non-negative. + real :: Icrvpslope ! The inverse of the sum of crv and slope [Z-1 ~> m-1] + real :: slope_crv ! The slope divided by the curvature [nondim] + ! These are only used if the slope exceeds or matches the curvature. + real :: smc ! The slope minus the curvature [Z ~> m] + real :: C3c_m_s ! 3 times the curvature minus the slope [Z ~> m] + real :: I_3c_m_s ! The inverse of 3 times the curvature minus the slope [Z-1 ~> m-1] + ! These are only used if the curvature exceeds the slope. + real :: C4_crv ! The inverse of a quarter of the curvature [Z-1 ~> m-1] + real :: sxcms_c ! The slope times the difference between the curvature and slope + ! divided by the curvature [Z ~> m] + real :: slope2_4crv ! A quarter of the slope squared divided by the curvature [Z ~> m] + real :: I_3s_m_c ! The inverse of 3 times the slope minus the curvature [Z-1 ~> m-1] + real :: C3s_m_c ! 3 times the slope minus the curvature [Z ~> m] + + real, parameter :: C1_3 = 1.0 / 3.0, C1_12 = 1.0 / 12.0 ! Rational constants [nondim] + integer :: K, nz, itt + integer, parameter :: max_itt = 10 + + nz = GV%ke + + ! Each cell extends from x=-1/2 to 1/2, and has a topography + ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. + + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + slope = Dp - Dm + + ! Calculate the volume above which the entire cell is open and the volume at which the + ! equation that is solved for L changes because there are two separate open regions. + if (slope >= crv) then + Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open + L_2_reg = 1.0 + if (crv + slope >= 4.0*crv) then + L_inflect_1 = 1.0 ; Vol_inflect_1 = Vol_open + else + slope_crv = slope / crv + L_inflect_1 = 0.25 + 0.25*slope_crv + vol_inflect_1 = 0.25*C1_12 * ((slope_crv + 1.0)**2 * (slope + crv)) + endif + ! Precalculate some combinations of crv & slope for later use. + smc = slope - crv + C3c_m_s = 3.0*crv - slope + if (C3c_m_s > 2.0*smc) I_3c_m_s = 1.0 / C3c_m_s + else + slope_crv = slope / crv + Vol_open = 0.25*slope*slope_crv + C1_12*crv + Vol_2_reg = 0.5*slope_crv**2 * (crv - C1_3*slope) + L_2_reg = slope_crv + + ! The inflection point is useful to know because below the inflection point + ! Newton's method converges monotonically from above and conversely above it. + ! These are the inflection point values of L and vol_below with a single open segment. + vol_inflect_1 = 0.25*C1_12 * ((slope_crv + 1.0)**2 * (slope + crv)) + L_inflect_1 = 0.25 + 0.25*slope_crv + ! These are the inflection point values of L and vol_below when there are two open segments. + ! Vol_inflect_2 = Vol_open - 0.125 * crv_3, which is equivalent to: + vol_inflect_2 = 0.25*slope*slope_crv + 0.125*crv_3 + L_inflect_2 = 0.5 + ! Precalculate some combinations of crv & slope for later use. + C4_crv = 4.0 / crv + slope2_4crv = 0.25 * slope * slope_crv + sxcms_c = slope_crv*(crv - slope) + C3s_m_c = 3.0*slope - crv + if (C3s_m_c > 2.0*sxcms_c) I_3s_m_c = 1.0 / C3s_m_c + endif + ! Define some combinations of crv & slope for later use. + Icrvpslope = 1.0 / (crv+slope) + + L(nz+1) = 0.0 + ! Determine the normalized open length (L) at each interface. + do K=nz,1,-1 + if (vol_below(K) >= Vol_open) then ! The whole cell is open. + L(K) = 1.0 + elseif (vol_below(K) < Vol_2_reg) then + ! In this case, there is a single contiguous open region from x=1/2-L to 1/2. + ! Changing the horizontal variable in the expression from D(x) to D(L) gives: + ! x(L) = 1/2 - L + ! D(L) = crv*(0.5 - L)^2 + slope*(0.5 - L) + D_vel - crv/12 + ! D(L) = crv*L^2 - crv*L + crv/4 + slope*(1/2 - L) + D_vel - crv/12 + ! D(L) = crv*L^2 - (slope+crv)*L + slope/2 + D_vel + crv/6 + ! D(0) = slope/2 + D_vel + crv/6 = (Dp - Dm)/2 + D_vel + (Dp + Dm - 2*D_vel)/2 = Dp + ! D(1) = crv - slope - crv + slope/2 + Dvel + crv/6 = D_vel - slope/2 + crv/6 = Dm + ! + ! vol_below = integral(y = 0 to L) D(y) dy - L * D(L) + ! = crv/3*L^3 - (slope+crv)/2*L^2 + (slope/2 + D_vel + crv/6)*L - + ! (crv*L^2 - (slope+crv)*L + slope/2 + D_vel + crv/6) * L + ! = -2/3 * crv * L^3 + 1/2 * (slope+crv) * L^2 + ! vol_below(K) = 0.5*L(K)**2*(slope + crv_3*(3-4*L(K))) + ! L(K) is between L(K+1) and slope_crv. + L_max = min(L_2_reg, 1.0) + if (vol_below(K) <= vol_inflect_1) L_max = min(L_max, L_inflect_1) + + L_min = L(K+1) + if (vol_below(K) >= vol_inflect_1) L_min = max(L_min, L_inflect_1) + + ! Ignoring the cubic term gives an under-estimate but is very accurate for near bottom + ! layers, so use this as a potential floor. + if (2.0*vol_below(K)*Icrvpslope > L_min**2) L_min = sqrt(2.0*vol_below(K)*Icrvpslope) + + ! Start with L_min in most cases. + L(k) = L_min + + if (vol_below(K) <= vol_inflect_1) then + ! Starting with L_min below L_inflect_1, only the first overshooting iteration of Newton's + ! method needs bounding. + L(k) = L_min + vol_err = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + ! If vol_err is 0 or positive (perhaps due to roundoff in L(K+1)), L_min is already the best solution. + if (vol_err < 0.0) then + dVol_dL = L(K) * (slope + crv*(1.0 - 2.0*L(k))) + if (L(K)*dVol_dL > vol_err + L_max*dVol_dL) then + L(K) = L_max + else + L(K) = L(K) - (vol_err / dVol_dL) + endif + + ! Subsequent iterations of Newton's method do not need bounds. + do itt=1,max_itt + vol_err = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + dVol_dL = L(K) * (slope + crv*(1.0 - 2.0*L(k))) + if (abs(vol_err) < max(1.0e-15*L(K), 1.0e-25)*dVol_dL) exit + L(K) = L(K) - (vol_err / dVol_dL) + enddo + endif + else ! (vol_below(K) > vol_inflect_1) + ! Iteration from below converges monotonically, but we need to deal with the case where we are + ! close to the peak of the topography and Newton's method mimics the convergence of bisection. + + ! Evaluate the error when L(K) = L_min as a possible first guess. + L(k) = L_min + vol_err = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + ! If vol_err is 0 or positive (perhaps due to roundoff in L(K+1)), L_min is already the best solution. + if (vol_err < 0.0) then + + ! These two upper estimates deal with the possibility that this point may be near + ! the upper extrema, where the error term might be approximately parabolic and + ! Newton's method would converge slowly like simple bisection. + if (slope < crv) then + ! if ((L_2_reg - L_min)*(3.0*slope - crv) > 2.0*slope_crv*(crv-slope)) then + if ((L_2_reg - L_min)*C3s_m_c > 2.0*sxcms_c) then + ! There is a decent upper estimate of L from the approximate quadratic equation found + ! by examining the error expressions at L ~= L_2_reg and ignoring the cubic term. + L_max = (slope_crv*(2.0*slope) - sqrt(sxcms_c**2 + & + 2.0*C3s_m_c*(Vol_2_reg - vol_below(K))) ) * I_3s_m_c + ! The line above is equivalent to: + ! L_max = (slope_crv*(2.0*slope) - sqrt(slope_crv**2*(crv-slope)**2 + & + ! 2.0*(3.0*slope - crv)*(Vol_2_reg - vol_below(K))) ) / & + ! (3.0*slope - crv) + else + L_max = slope_crv + endif + else ! (slope >= crv) + if ((1.0 - L_min)*C3c_m_s > 2.0*smc) then + ! There is a decent upper estimate of L from the approximate quadratic equation found + ! by examining the error expressions at L ~= 1 and ignoring the cubic term. + L_max = ( 2.0*crv - sqrt(smc**2 + 2.0*C3c_m_s * (Vol_open - vol_below(K))) ) * I_3c_m_s + ! The line above is equivalent to: + ! L_max = ( 2.0*crv - sqrt((slope - crv)**2 + 2.0*(3.0*crv - slope) * (Vol_open - vol_below(K))) ) / & + ! (3.0*crv - slope) + else + L_max = 1.0 + endif + endif + Vol_err_max = 0.5*L_max**2 * (slope + crv*(1.0 - 4.0*C1_3*L_max)) - vol_below(K) + ! if (Vol_err_max < 0.0) call MOM_error(FATAL, & + ! "Vol_err_max should never be negative in find_L_open_concave_iterative.") + if ((Vol_err_max < abs(Vol_err)) .and. (L_max < 1.0)) then + ! Start with 1 bounded Newton's method step from L_max + dVol_dL = L_max * (slope + crv*(1.0 - 2.0*L_max)) + L(K) = max(L_min, L_max - (vol_err_max / dVol_dL) ) + ! else ! Could use the fact that Vol_err is known to take an iteration? + endif + + ! Subsequent iterations of Newton's method do not need bounds. + do itt=1,max_itt + vol_err = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + dVol_dL = L(K) * (slope + crv*(1.0 - 2.0*L(k))) + if (abs(vol_err) < max(1.0e-15*L(K), 1.0e-25)*dVol_dL) exit + L(K) = L(K) - (vol_err / dVol_dL) + enddo + endif + + endif + + ! To check the answers. + ! Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + else ! There are two separate open regions. + ! vol_below(K) = slope^2/(4*crv) + crv/12 - (crv/12)*(1-L)^2*(1+2L) + ! At the deepest volume, L = slope/crv, at the top L = 1. + + ! To check the answers. + ! Vol_err = Vol_open - 0.25*crv_3*(1.0+2.0*L(K)) * (1.0-L(K))**2 - vol_below(K) + ! or equivalently: + ! Vol_err = Vol_open - 0.25*crv_3*(3.0-2.0*(1.0-L(K))) * (1.0-L(K))**2 - vol_below(K) + ! ! Note that: Vol_open = 0.25*slope*slope_crv + C1_12*crv + ! Vol_err = 0.25*slope*slope_crv + 0.25*crv_3*( 1.0 - (1.0 + 2.0*L(K)) * (1.0-L(K))**2 ) - vol_below(K) + ! Vol_err = 0.25*crv_3*L(K)**2*( 3.0 - 2.0*L(K) ) + 0.25*slope*slope_crv - vol_below(K) + + ! Derivation of the L_max limit below: + ! Vol_open - vol_below(K) = 0.25*crv_3*(3.0-2.0*(1.0-L(K))) * (1.0-L(K))**2 + ! (3.0-2.0*(1.0-L(K))) * (1.0-L(K))**2 = (Vol_open - vol_below(K)) / (0.25*crv_3) + ! When 1-L(K) << 1: + ! 3.0 * (1.0-L_max)**2 = (Vol_open - vol_below(K)) / (0.25*crv_3) + ! (1.0-L_max)**2 = (Vol_open - vol_below(K)) / (0.25*crv) + + ! Derivation of the L_min limit below: + ! Vol_err = 0.25*crv_3*L(K)**2*( 3.0 - 2.0*L(K) ) + 0.25*slope*slope_crv - vol_below(K) + ! crv*L(K)**2*( 1.0 - 2.0*C1_3*L(K) ) = 4.0*vol_below(K) - slope*slope_crv + ! When L(K) << 1: + ! crv*L_min**2 = 4.0*vol_below(K) - slope*slope_crv + ! L_min = sqrt((4.0*vol_below(K) - slope*slope_crv)/crv) + ! Noting that L(K) >= slope_crv, when L(K)-slope_crv << 1: + ! (crv + 2.0*C1_3*slope)*L_min**2 = 4.0*vol_below(K) - slope*slope_crv + ! L_min = sqrt((4.0*vol_below(K) - slope*slope_crv)/(crv + 2.0*C1_3*slope)) + + if (vol_below(K) <= Vol_inflect_2) then + ! Newton's Method would converge monotonically from above, but overshoot from below. + L_min = max(L(K+1), L_2_reg) ! L_2_reg = slope_crv + ! This under-estimate of L(K) is accurate for L ~= slope_crv: + if ((4.0*vol_below(K) - slope*slope_crv) > (crv + 2.0*C1_3*slope)*L_min**2) & + L_min = max(L_min, sqrt((4.0*vol_below(K) - slope*slope_crv) / (crv + 2.0*C1_3*slope))) + L_max = 0.5 ! = L_inflect_2 + + ! Starting with L_min below L_inflect_2, only the first overshooting iteration of Newton's + ! method needs bounding. + L(k) = L_min + Vol_err = crv_3*L(K)**2*( 0.75 - 0.5*L(K) ) + (slope2_4crv - vol_below(K)) + + ! If vol_err is 0 or positive (perhaps due to roundoff in L(K+1)), L_min is already the best solution. + if (vol_err < 0.0) then + dVol_dL = 0.5*crv * (L(K) * (1.0 - L(K))) + if (L(K)*dVol_dL >= vol_err + L_max*dVol_dL) then + L(K) = L_max + else + L(K) = L(K) - (vol_err / dVol_dL) + endif + ! Subsequent iterations of Newton's method do not need bounds. + do itt=1,max_itt + Vol_err = crv_3 * (L(K)**2 * (0.75 - 0.5*L(K))) + (slope2_4crv - vol_below(K)) + dVol_dL = 0.5*crv * (L(K)*(1.0 - L(K))) + if (abs(vol_err) < max(1.0e-15*L(K), 1.0e-25)*dVol_dL) exit + L(K) = L(K) - (vol_err / dVol_dL) + enddo + endif + else ! (vol_below(K) > Vol_inflect_2) + ! Newton's Method would converge monotonically from below, but overshoots from above, and + ! we may need to deal with the case where we are close to the peak of the topography. + L_min = max(L(K+1), 0.5) + L(k) = L_min + + Vol_err = crv_3 * (L(K)**2 * ( 0.75 - 0.5*L(K))) + (slope2_4crv - vol_below(K)) + ! If vol_err is 0 or positive (perhaps due to roundoff in L(K+1)), L(k) is already the best solution. + if (Vol_err < 0.0) then + ! This over-estimate of L(K) is accurate for L ~= 1: + L_max = 1.0 - sqrt( (Vol_open - vol_below(K)) * C4_crv ) + Vol_err_max = crv_3 * (L_max**2 * ( 0.75 - 0.5*L_max)) + (slope2_4crv - vol_below(K)) + ! if (Vol_err_max < 0.0) call MOM_error(FATAL, & + ! "Vol_err_max should never be negative in find_L_open_concave_iterative.") + if ((Vol_err_max < abs(Vol_err)) .and. (L_max < 1.0)) then + ! Start with 1 bounded Newton's method step from L_max + dVol_dL = 0.5*crv * (L_max * (1.0 - L_max)) + L(K) = max(L_min, L_max - (vol_err_max / dVol_dL) ) + ! else ! Could use the fact that Vol_err is known to take an iteration? + endif + + ! Subsequent iterations of Newton's method do not need bounds. + do itt=1,max_itt + Vol_err = crv_3 * (L(K)**2 * ( 0.75 - 0.5*L(K))) + (slope2_4crv - vol_below(K)) + dVol_dL = 0.5*crv * (L(K) * (1.0 - L(K))) + if (abs(vol_err) < max(1.0e-15*L(K), 1.0e-25)*dVol_dL) exit + L(K) = L(K) - (vol_err / dVol_dL) + enddo + endif + endif + + endif + enddo ! k loop to determine L(K) in the concave case + +end subroutine find_L_open_concave_iterative + + + +!> Test the validity the normalized open lengths of each interface for concave bathymetry (from the ocean perspective) +!! by evaluating and returing the relevant cubic equations. +subroutine test_L_open_concave(vol_below, D_vel, Dp, Dm, L, vol_err, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: D_vel !< The average bottom depth at a velocity point [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(in) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + real, dimension(SZK_(GV)+1), intent(out) :: vol_err !< The difference between vol_below and the + !! value obtained from using L in the cubic equation [Z ~> m] + + ! Local variables + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + + ! The following "volumes" have units of vertical heights because they are normalized + ! by the full horizontal area of a velocity cell. + real :: Vol_open ! The cell volume above which the face is fully is open [Z ~> m]. + real :: Vol_2_reg ! The cell volume above which there are two separate + ! open areas that must be integrated [Z ~> m]. + real :: L_2_reg ! The value of L when vol_below is Vol_2_reg [nondim] + + ! The following combinations of slope and crv are reused across layers, and hence are pre-calculated + ! for efficiency. All are non-negative. + real :: slope_crv ! The slope divided by the curvature [nondim] + ! These are only used if the curvature exceeds the slope. + real :: slope2_4crv ! A quarter of the slope squared divided by the curvature [Z ~> m] + + real, parameter :: C1_3 = 1.0 / 3.0, C1_12 = 1.0 / 12.0 ! Rational constants [nondim] + integer :: K, nz + + nz = GV%ke + + ! Each cell extends from x=-1/2 to 1/2, and has a topography + ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. + + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + slope = Dp - Dm + + ! Calculate the volume above which the entire cell is open and the volume at which the + ! equation that is solved for L changes because there are two separate open regions. + if (slope >= crv) then + Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open + L_2_reg = 1.0 + if (crv + slope >= 4.0*crv) then + slope_crv = 1.0 + else + slope_crv = slope / crv + endif + else + slope_crv = slope / crv + Vol_open = 0.25*slope*slope_crv + C1_12*crv + Vol_2_reg = 0.5*slope_crv**2 * (crv - C1_3*slope) + L_2_reg = slope_crv + endif + slope2_4crv = 0.25 * slope * slope_crv + + ! Determine the volume error based on the normalized open length (L) at each interface. + Vol_err(nz+1) = 0.0 + do K=nz,1,-1 + if (L(K) >= 1.0) then + Vol_err(K) = max(Vol_open - vol_below(K), 0.0) + elseif (L(K) <= L_2_reg) then + vol_err(K) = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + else ! There are two separate open regions. + Vol_err(K) = crv_3 * (L(K)**2 * ( 0.75 - 0.5*L(K))) + (slope2_4crv - vol_below(K)) + endif + enddo ! k loop to determine L(K) in the concave case + +end subroutine test_L_open_concave + + +!> Determine the normalized open length of each interface for convex bathymetry (from the ocean +!! perspective) using Newton's method iterations. In this case there is a single open region +!! with the minimum depth at one edge of the cell. +subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: D_vel !< The average bottom depth at a velocity point [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(set_visc_CS), intent(in) :: CS !< The control structure returned by a previous + !! call to set_visc_init. + + ! Local variables + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + ! All of the following "volumes" have units of vertical heights because they are normalized + ! by the full horizontal area of a velocity cell. + real :: Vol_err ! The error in the volume with the latest estimate of + ! L, or the error for the interface below [Z ~> m]. + real :: Vol_quit ! The volume error below which to quit iterating [Z ~> m]. + real :: Vol_tol ! A volume error tolerance [Z ~> m]. + real :: Vol_open ! The cell volume above which the face is fully open [Z ~> m]. + real :: Vol_direct ! With less than Vol_direct [Z ~> m], there is a direct + ! solution of a cubic equation for L. + real :: Vol_err_max ! The volume error for the upper bound on the correct value for L [Z ~> m] + real :: Vol_err_min ! The volume error for the lower bound on the correct value for L [Z ~> m] + real :: Vol_0 ! A deeper volume with known width L0 [Z ~> m]. + real :: dVol ! vol - Vol_0 [Z ~> m]. + real :: dV_dL2 ! The partial derivative of volume with L squared + ! evaluated at L=L0 [Z ~> m]. + real :: L_direct ! The value of L above volume Vol_direct [nondim]. + real :: L_max, L_min ! Upper and lower bounds on the correct value for L [nondim]. + real :: L0 ! The value of L above volume Vol_0 [nondim]. + real :: Iapb, Ibma_2 ! Combinations of crv (a) and slope (b) [Z-1 ~> m-1] + real :: C24_crv ! 24/crv [Z-1 ~> m-1]. + real :: curv_tol ! Numerator of curvature cubed, used to estimate + ! accuracy of a single L(:) Newton iteration [Z5 ~> m5] + real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0 ! Rational constants [nondim] + logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration + integer :: K, nz, itt, maxitt=20 + + nz = GV%ke + + ! Each cell extends from x=-1/2 to 1/2, and has a topography + ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + slope = Dp - Dm + + ! Calculate the volume above which the entire cell is open and the volume at which the + ! equation that is solved for L changes because there is a direct solution. + Vol_open = D_vel - Dm + if (slope >= -crv) then + Iapb = 1.0e30*US%Z_to_m ; if (slope+crv /= 0.0) Iapb = 1.0/(crv+slope) + Vol_direct = 0.0 ; L_direct = 0.0 ; C24_crv = 0.0 + else + C24_crv = 24.0/crv ; Iapb = 1.0/(crv+slope) + L_direct = 1.0 + slope/crv ! L_direct < 1 because crv < 0 + Vol_direct = -C1_6*crv*L_direct**3 + endif + Ibma_2 = 2.0 / (slope - crv) + + if (CS%answer_date < 20190101) Vol_quit = (0.9*GV%Angstrom_Z + GV%dZ_subroundoff) + + L(nz+1) = 0.0 ; Vol_err = 0.0 + ! Determine the normalized open length (L) at each interface. + do K=nz,1,-1 + if (vol_below(K) >= Vol_open) then + L(K) = 1.0 + elseif (vol_below(K) <= Vol_direct) then + ! Both edges of the cell are bounded by walls. + ! if (CS%answer_date < 20240101)) then + L(K) = (-0.25*C24_crv*vol_below(K))**C1_3 + ! else + ! L(K) = cuberoot(-0.25*C24_crv*vol_below(K)) + ! endif + else + ! x_R is at 1/2 but x_L is in the interior & L is found by iteratively solving + ! vol_below(K) = 0.5*L^2*(slope + crv/3*(3-4L)) + + ! Vol_err = 0.5*(L(K+1)*L(K+1))*(slope + crv_3*(3.0-4.0*L(K+1))) - vol_below(K+1) + ! Change to ... + ! if (min(vol_below(K+1) + Vol_err, vol_below(K)) <= Vol_direct) then ? + if (vol_below(K+1) + Vol_err <= Vol_direct) then + L0 = L_direct ; Vol_0 = Vol_direct + else + L0 = L(K+1) ; Vol_0 = vol_below(K+1) + Vol_err + ! Change to Vol_0 = min(vol_below(K+1) + Vol_err, vol_below(K)) ? + endif + + ! Try a relatively simple solution that usually works well + ! for massless layers. + dV_dL2 = 0.5*(slope+crv) - crv*L0 ; dVol = (vol_below(K)-Vol_0) + ! dV_dL2 = 0.5*(slope+crv) - crv*L0 ; dVol = max(vol_below(K)-Vol_0, 0.0) + + use_L0 = .false. + do_one_L_iter = .false. + if (CS%answer_date < 20190101) then + curv_tol = GV%Angstrom_Z*dV_dL2**2 & + * (0.25 * dV_dL2 * GV%Angstrom_Z - crv * L0 * dVol) + do_one_L_iter = (crv * crv * dVol**3) < curv_tol + else + ! The following code is more robust when GV%Angstrom_H=0, but + ! it changes answers. + use_L0 = (dVol <= 0.) + + Vol_tol = max(0.5 * GV%Angstrom_Z + GV%dZ_subroundoff, 1e-14 * vol_below(K)) + Vol_quit = max(0.9 * GV%Angstrom_Z + GV%dZ_subroundoff, 1e-14 * vol_below(K)) + + curv_tol = Vol_tol * dV_dL2**2 & + * (dV_dL2 * Vol_tol - 2.0 * crv * L0 * dVol) + do_one_L_iter = (crv * crv * dVol**3) < curv_tol + endif + + if (use_L0) then + L(K) = L0 + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + elseif (do_one_L_iter) then + ! One iteration of Newton's method should give an estimate + ! that is accurate to within Vol_tol. + L(K) = sqrt(L0*L0 + dVol / dV_dL2) + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + else + if (dV_dL2*(1.0-L0*L0) < dVol + & + dV_dL2 * (Vol_open - vol_below(K))*Ibma_2) then + L_max = sqrt(1.0 - (Vol_open - vol_below(K))*Ibma_2) + else + L_max = sqrt(L0*L0 + dVol / dV_dL2) + endif + L_min = sqrt(L0*L0 + dVol / (0.5*(slope+crv) - crv*L_max)) + + Vol_err_min = 0.5*(L_min**2)*(slope + crv_3*(3.0-4.0*L_min)) - vol_below(K) + Vol_err_max = 0.5*(L_max**2)*(slope + crv_3*(3.0-4.0*L_max)) - vol_below(K) + ! if ((abs(Vol_err_min) <= Vol_quit) .or. (Vol_err_min >= Vol_err_max)) then + if (abs(Vol_err_min) <= Vol_quit) then + L(K) = L_min ; Vol_err = Vol_err_min + else + L(K) = sqrt((L_min**2*Vol_err_max - L_max**2*Vol_err_min) / & + (Vol_err_max - Vol_err_min)) + do itt=1,maxitt + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + if (abs(Vol_err) <= Vol_quit) exit + ! Take a Newton's method iteration. This equation has proven + ! robust enough not to need bracketing. + L(K) = L(K) - Vol_err / (L(K)* (slope + crv - 2.0*crv*L(K))) + ! This would be a Newton's method iteration for L^2: + ! L(K) = sqrt(L(K)*L(K) - Vol_err / (0.5*(slope+crv) - crv*L(K))) + enddo + endif ! end of iterative solver + endif ! end of 1-boundary alternatives. + endif ! end of 0, 1- and 2- boundary cases. + enddo ! k loop to determine L(K) in the convex case + +end subroutine find_L_open_convex + +!> This subroutine finds a thickness-weighted value of v at the u-points. +function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + integer, intent(in) :: i !< The i-index of the u-location to work on. + integer, intent(in) :: j !< The j-index of the u-location to work on. + integer, intent(in) :: k !< The k-index of the u-location to work on. + real, dimension(SZI_(G),SZJB_(G)),& + intent(in) :: mask2dCv !< A multiplicative mask of the v-points [nondim] + type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure + real :: set_v_at_u !< The return value of v at u points points in the + !! same units as u, i.e. [L T-1 ~> m s-1] or other units. + + ! This subroutine finds a thickness-weighted value of v at the u-points. + real :: hwt(0:1,-1:0) ! Masked weights used to average u onto v [H ~> m or kg m-2]. + real :: hwt_tot ! The sum of the masked thicknesses [H ~> m or kg m-2]. + integer :: i0, j0, i1, j1 + + do j0 = -1,0 ; do i0 = 0,1 ; i1 = i+i0 ; J1 = J+j0 + hwt(i0,j0) = (h(i1,j1,k) + h(i1,j1+1,k)) * mask2dCv(i1,J1) + enddo ; enddo + + if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then + do j0 = -1,0 ; do i0 = 0,1 ; if ((OBC%segnum_v(i+i0,J+j0) /= OBC_NONE)) then + i1 = i+i0 ; J1 = J+j0 + if (OBC%segment(OBC%segnum_v(i1,j1))%direction == OBC_DIRECTION_N) then + hwt(i0,j0) = 2.0 * h(i1,j1,k) * mask2dCv(i1,J1) + elseif (OBC%segment(OBC%segnum_v(i1,J1))%direction == OBC_DIRECTION_S) then + hwt(i0,j0) = 2.0 * h(i1,J1+1,k) * mask2dCv(i1,J1) + endif + endif ; enddo ; enddo + endif ; endif + + hwt_tot = (hwt(0,-1) + hwt(1,0)) + (hwt(1,-1) + hwt(0,0)) + set_v_at_u = 0.0 + if (hwt_tot > 0.0) set_v_at_u = & + ((hwt(0,0) * v(i,J,k) + hwt(1,-1) * v(i+1,J-1,k)) + & + (hwt(1,0) * v(i+1,J,k) + hwt(0,-1) * v(i,J-1,k))) / hwt_tot + +end function set_v_at_u + +!> This subroutine finds a thickness-weighted value of u at the v-points. +function set_u_at_v(u, h, G, GV, i, j, k, mask2dCu, OBC) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1] or other units. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + integer, intent(in) :: i !< The i-index of the u-location to work on. + integer, intent(in) :: j !< The j-index of the u-location to work on. + integer, intent(in) :: k !< The k-index of the u-location to work on. + real, dimension(SZIB_(G),SZJ_(G)), & + intent(in) :: mask2dCu !< A multiplicative mask of the u-points [nondim] + type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure + real :: set_u_at_v !< The return value of u at v points in the + !! same units as u, i.e. [L T-1 ~> m s-1] or other units. + + ! This subroutine finds a thickness-weighted value of u at the v-points. + real :: hwt(-1:0,0:1) ! Masked weights used to average u onto v [H ~> m or kg m-2]. + real :: hwt_tot ! The sum of the masked thicknesses [H ~> m or kg m-2]. + integer :: i0, j0, i1, j1 + + do j0 = 0,1 ; do i0 = -1,0 ; I1 = I+i0 ; j1 = j+j0 + hwt(i0,j0) = (h(i1,j1,k) + h(i1+1,j1,k)) * mask2dCu(I1,j1) + enddo ; enddo + + if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then + do j0 = 0,1 ; do i0 = -1,0 ; if ((OBC%segnum_u(I+i0,j+j0) /= OBC_NONE)) then + I1 = I+i0 ; j1 = j+j0 + if (OBC%segment(OBC%segnum_u(I1,j1))%direction == OBC_DIRECTION_E) then + hwt(i0,j0) = 2.0 * h(I1,j1,k) * mask2dCu(I1,j1) + elseif (OBC%segment(OBC%segnum_u(I1,j1))%direction == OBC_DIRECTION_W) then + hwt(i0,j0) = 2.0 * h(I1+1,j1,k) * mask2dCu(I1,j1) + endif + endif ; enddo ; enddo + endif ; endif + + hwt_tot = (hwt(-1,0) + hwt(0,1)) + (hwt(0,0) + hwt(-1,1)) + set_u_at_v = 0.0 + if (hwt_tot > 0.0) set_u_at_v = & + ((hwt(0,0) * u(I,j,k) + hwt(-1,1) * u(I-1,j+1,k)) + & + (hwt(-1,0) * u(I-1,j,k) + hwt(0,1) * u(I,j+1,k))) / hwt_tot + +end function set_u_at_v + +!> Calculates the thickness of the surface boundary layer for applying an elevated viscosity. +!! +!! A bulk Richardson criterion or the thickness of the topmost NKML layers (with a bulk mixed layer) +!! are currently used. The thicknesses are given in terms of fractional layers, so that this +!! thickness will move as the thickness of the topmost layers change. +subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields. Absent fields have + !! NULL pointers. + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and + !! related fields. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(set_visc_CS), intent(inout) :: CS !< The control structure returned by a previous + !! call to set_visc_init. + + ! Local variables + real, dimension(SZIB_(G)) :: & + htot, & ! The total thickness of the layers that are within the + ! surface mixed layer [H ~> m or kg m-2]. + dztot, & ! The distance from the surface to the bottom of the layers that are + ! within the surface mixed layer [Z ~> m] + Thtot, & ! The integrated temperature of layers that are within the + ! surface mixed layer [H C ~> m degC or kg degC m-2]. + Shtot, & ! The integrated salt of layers that are within the + ! surface mixed layer [H S ~> m ppt or kg ppt m-2]. + SpV_htot, & ! Running sum of thickness times specific volume [R-1 H ~> m4 kg-1 or m] + Rhtot, & ! The integrated density of layers that are within the surface mixed layer + ! [H R ~> kg m-2 or kg2 m-5]. Rhtot is only used if no + ! equation of state is used. + uhtot, & ! The depth integrated zonal velocity within the surface + ! mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + vhtot, & ! The depth integrated meridional velocity within the surface + ! mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + Idecay_len_TKE, & ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. + dR_dT, & ! Partial derivative of the density at the base of layer nkml + ! (roughly the base of the mixed layer) with temperature [R C-1 ~> kg m-3 degC-1]. + dR_dS, & ! Partial derivative of the density at the base of layer nkml + ! (roughly the base of the mixed layer) with salinity [R S-1 ~> kg m-3 ppt-1]. + dSpV_dT, & ! Partial derivative of the specific volume at the base of layer nkml + ! (roughly the base of the mixed layer) with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. + dSpV_dS, & ! Partial derivative of the specific volume at the base of layer nkml + ! (roughly the base of the mixed layer) with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + ustar, & ! The surface friction velocity under ice shelves [H T-1 ~> m s-1 or kg m-2 s-1]. + press, & ! The pressure at which dR_dT and dR_dS are evaluated [R L2 T-2 ~> Pa]. + T_EOS, & ! The potential temperature at which dR_dT and dR_dS are evaluated [C ~> degC] + S_EOS ! The salinity at which dR_dT and dR_dS are evaluated [S ~> ppt]. + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G)) :: & + mask_u ! A mask that disables any contributions from u points that + ! are land or past open boundary conditions [nondim], 0 or 1. + real, dimension(SZI_(G),SZJB_(G)) :: & + mask_v ! A mask that disables any contributions from v points that + ! are land or past open boundary conditions [nondim], 0 or 1. + real :: U_star_2d(SZI_(G),SZJ_(G)) ! The wind friction velocity in thickness-based units, + ! calculated using the Boussinesq reference density or the time-evolving + ! surface density in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] + real :: h_at_vel(SZIB_(G),SZK_(GV))! Layer thickness at velocity points, + ! using an upwind-biased second order accurate estimate based + ! on the previous velocity direction [H ~> m or kg m-2]. + real :: dz_at_vel(SZIB_(G),SZK_(GV)) ! Vertical extent of a layer at velocity points, + ! using an upwind-biased second order accurate estimate based + ! on the previous velocity direction [Z ~> m]. + integer :: k_massive(SZIB_(G)) ! The k-index of the deepest layer yet found + ! that has more than h_tiny thickness and will be in the + ! viscous mixed layer. + real :: Uh2 ! The squared magnitude of the difference between the velocity + ! integrated through the mixed layer and the velocity of the + ! interior layer layer times the depth of the mixed layer + ! [H2 L2 T-2 ~> m4 s-2 or kg2 m-2 s-2]. + real :: htot_vel ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. + real :: hwtot ! Sum of the thicknesses used to calculate + ! the near-bottom velocity magnitude [H ~> m or kg m-2]. + real :: hutot ! Running sum of thicknesses times the velocity + ! magnitudes [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: hweight ! The thickness of a layer that is within Hbbl + ! of the bottom [H ~> m or kg m-2]. + real :: tbl_thick ! The thickness of the top boundary layer [Z ~> m]. + + real :: hlay ! The layer thickness at velocity points [H ~> m or kg m-2]. + real :: I_2hlay ! 1 / 2*hlay [H-1 ~> m-1 or m2 kg-1]. + real :: T_lay ! The layer temperature at velocity points [C ~> degC]. + real :: S_lay ! The layer salinity at velocity points [S ~> ppt]. + real :: Rlay ! The layer potential density at velocity points [R ~> kg m-3]. + real :: Rlb ! The potential density of the layer below [R ~> kg m-3]. + real :: v_at_u ! The meridional velocity at a zonal velocity point [L T-1 ~> m s-1]. + real :: u_at_v ! The zonal velocity at a meridional velocity point [L T-1 ~> m s-1]. + real :: gHprime ! The mixed-layer internal gravity wave speed squared, based + ! on the mixed layer thickness and density difference across + ! the base of the mixed layer [L2 T-2 ~> m2 s-2]. + real :: RiBulk ! The bulk Richardson number below which water is in the + ! viscous mixed layer, including reduction for turbulent decay [nondim] + real :: dt_Rho0 ! The time step divided by the conversion from the layer + ! thickness to layer mass [T H Z-1 R-1 ~> s m3 kg-1 or s]. + real :: g_H_Rho0 ! The gravitational acceleration times the conversion from H to m divided + ! by the mean density [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + real :: ustarsq ! 400 times the square of ustar, times + ! Rho0 divided by G_Earth and the conversion + ! from m to thickness units [H R ~> kg m-2 or kg2 m-5]. + real :: cdrag_sqrt ! Square root of the drag coefficient [nondim]. + real :: cdrag_sqrt_H ! Square root of the drag coefficient, times a unit conversion + ! factor from lateral lengths to layer thicknesses [H L-1 ~> nondim or kg m-3]. + real :: cdrag_sqrt_H_RL ! Square root of the drag coefficient, times a unit conversion factor from + ! density times lateral lengths to layer thicknesses [H L-1 R-1 ~> m3 kg-1 or nondim] + real :: oldfn ! The integrated energy required to + ! entrain up to the bottom of the layer, + ! divided by G_Earth [H R ~> kg m-2 or kg2 m-5]. + real :: Dfn ! The increment in oldfn for entraining + ! the layer [H R ~> kg m-2 or kg2 m-5]. + real :: frac_used ! The fraction of the present layer that contributes to Dh and Ddz [nondim] + real :: Dh ! The increment in layer thickness from the present layer [H ~> m or kg m-2]. + real :: Ddz ! The increment in height change from the present layer [Z ~> m]. + real :: U_bg_sq ! The square of an assumed background velocity, for + ! calculating the mean magnitude near the top for use in + ! the quadratic surface drag [L2 T-2 ~> m2 s-2]. + real :: h_tiny ! A very small thickness [H ~> m or kg m-2]. Layers that are less than + ! h_tiny can not be the deepest in the viscous mixed layer. + real :: absf ! The absolute value of f averaged to velocity points [T-1 ~> s-1]. + real :: U_star ! The friction velocity at velocity points [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + real :: Rho0x400_G ! 400*Rho0/G_Earth, times unit conversion factors + ! [R T2 H-1 ~> kg s2 m-4 or s2 m-1]. + ! The 400 is a constant proposed by Killworth and Edwards, 1999. + real :: ustar1 ! ustar [H T-1 ~> m s-1 or kg m-2 s-1] + real :: h2f2 ! (h*2*f)^2 [H2 T-2 ~> m2 s-2 or kg2 m-4 s-2] + logical :: use_EOS, do_any, do_any_shelf, do_i(SZIB_(G)) + logical :: nonBous_ML ! If true, use the non-Boussinesq form of some energy and + ! stratification calculations. + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, K2, nkmb, nkml, n + type(ocean_OBC_type), pointer :: OBC => NULL() + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%isc-1 ; Ieq = G%IecB ; Jsq = G%jsc-1 ; Jeq = G%JecB + nkmb = GV%nk_rho_varies ; nkml = GV%nkml + + if (.not.CS%initialized) call MOM_error(FATAL,"MOM_set_viscosity(visc_ML): "//& + "Module must be initialized before it is used.") + + if (.not.(CS%dynamic_viscous_ML .or. associated(forces%frac_shelf_u) .or. & + associated(forces%frac_shelf_v)) ) return + + Rho0x400_G = 400.0*(GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth)) + U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel + cdrag_sqrt = sqrt(CS%cdrag) + cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H + cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H + + OBC => CS%OBC + use_EOS = associated(tv%eqn_of_state) + nonBous_ML = allocated(tv%SpV_avg) + dt_Rho0 = dt / GV%H_to_RZ + h_neglect = GV%H_subroundoff + h_tiny = 2.0*GV%Angstrom_H + h_neglect + dz_neglect = GV%dZ_subroundoff + g_H_Rho0 = (GV%g_Earth*GV%H_to_Z) / (GV%Rho0) + + if (associated(forces%frac_shelf_u) .neqv. associated(forces%frac_shelf_v)) & + call MOM_error(FATAL, "set_viscous_ML: one of forces%frac_shelf_u and "//& + "forces%frac_shelf_v is associated, but the other is not.") + + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1, H_T_units=.true.) + + if (associated(forces%frac_shelf_u)) then + ! This configuration has ice shelves, and the appropriate variables need to be + ! allocated. If the arrays have already been allocated, these calls do nothing. + if (.not.allocated(visc%taux_shelf)) & + allocate(visc%taux_shelf(G%IsdB:G%IedB, G%jsd:G%jed), source=0.0) + if (.not.allocated(visc%tauy_shelf)) & + allocate(visc%tauy_shelf(G%isd:G%ied, G%JsdB:G%JedB), source=0.0) + if (.not.allocated(visc%tbl_thick_shelf_u)) & + allocate(visc%tbl_thick_shelf_u(G%IsdB:G%IedB, G%jsd:G%jed), source=0.0) + if (.not.allocated(visc%tbl_thick_shelf_v)) & + allocate(visc%tbl_thick_shelf_v(G%isd:G%ied, G%JsdB:G%JedB), source=0.0) + if (.not.allocated(visc%kv_tbl_shelf_u)) & + allocate(visc%kv_tbl_shelf_u(G%IsdB:G%IedB, G%jsd:G%jed), source=0.0) + if (.not.allocated(visc%kv_tbl_shelf_v)) & + allocate(visc%kv_tbl_shelf_v(G%isd:G%ied, G%JsdB:G%JedB), source=0.0) + + ! With a linear drag law under shelves, the friction velocity is already known. +! if (CS%linear_drag) ustar(:) = cdrag_sqrt_H*CS%drag_bg_vel + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + endif + + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is-1,ie+1 + mask_v(i,J) = G%mask2dCv(i,J) + enddo ; enddo + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do I=is-1,ie + mask_u(I,j) = G%mask2dCu(I,j) + enddo ; enddo + + if (associated(OBC)) then ; do n=1,OBC%number_of_segments + ! Now project bottom depths across cell-corner points in the OBCs. The two + ! projections have to occur in sequence and can not be combined easily. + if (.not. OBC%segment(n)%on_pe) cycle + ! Use a one-sided projection of bottom depths at OBC points. + I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB + if (OBC%segment(n)%is_N_or_S .and. (J >= js-1) .and. (J <= je)) then + do I = max(is-1,OBC%segment(n)%HI%IsdB), min(ie,OBC%segment(n)%HI%IedB) + if (OBC%segment(n)%direction == OBC_DIRECTION_N) mask_u(I,j+1) = 0.0 + if (OBC%segment(n)%direction == OBC_DIRECTION_S) mask_u(I,j) = 0.0 + enddo + elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= je)) then + do J = max(js-1,OBC%segment(n)%HI%JsdB), min(je,OBC%segment(n)%HI%JedB) + if (OBC%segment(n)%direction == OBC_DIRECTION_E) mask_v(i+1,J) = 0.0 + if (OBC%segment(n)%direction == OBC_DIRECTION_W) mask_v(i,J) = 0.0 + enddo + endif + enddo ; endif + + !$OMP parallel do default(private) shared(u,v,h,dz,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP nonBous_ML,h_neglect,dz_neglect,h_tiny,g_H_Rho0, & + !$OMP js,je,OBC,Isq,Ieq,nz,nkml,U_star_2d,U_bg_sq,mask_v, & + !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL,Rho0x400_G) + do j=js,je ! u-point loop + if (CS%dynamic_viscous_ML) then + do_any = .false. + do I=Isq,Ieq + htot(I) = 0.0 + if (G%mask2dCu(I,j) < 0.5) then + do_i(I) = .false. ; visc%nkml_visc_u(I,j) = nkml + else + do_i(I) = .true. ; do_any = .true. + k_massive(I) = nkml + Thtot(I) = 0.0 ; Shtot(I) = 0.0 ; Rhtot(i) = 0.0 + uhtot(I) = dt_Rho0 * forces%taux(I,j) + vhtot(I) = 0.25 * dt_Rho0 * ((forces%tauy(i,J) + forces%tauy(i+1,J-1)) + & + (forces%tauy(i,J-1) + forces%tauy(i+1,J))) + + if (CS%omega_frac >= 1.0) then ; absf = 2.0*CS%omega ; else + absf = 0.5*(abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I,J-1))) + if (CS%omega_frac > 0.0) & + absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) + endif + U_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) + Idecay_len_TKE(I) = (absf / U_star) * CS%TKE_decay + endif + enddo + + if (do_any) then ; do k=1,nz + if (k > nkml) then + do_any = .false. + if (use_EOS .and. (k==nkml+1)) then + ! Find dRho/dT and dRho_dS. + do I=Isq,Ieq + press(I) = (GV%H_to_RZ*GV%g_Earth) * htot(I) + if (associated(tv%p_surf)) press(I) = press(I) + 0.5*(tv%p_surf(i,j)+tv%p_surf(i+1,j)) + k2 = max(1,nkml) + I_2hlay = 1.0 / (h(i,j,k2) + h(i+1,j,k2) + h_neglect) + T_EOS(I) = (h(i,j,k2)*tv%T(i,j,k2) + h(i+1,j,k2)*tv%T(i+1,j,k2)) * I_2hlay + S_EOS(I) = (h(i,j,k2)*tv%S(i,j,k2) + h(i+1,j,k2)*tv%S(i+1,j,k2)) * I_2hlay + enddo + call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, tv%eqn_of_state, & + (/Isq-G%IsdB+1,Ieq-G%IsdB+1/) ) + if (nonBous_ML) then + call calculate_specific_vol_derivs(T_EOS, S_EOS, press, dSpV_dT, dSpV_dS, tv%eqn_of_state, & + (/Isq-G%IsdB+1,Ieq-G%IsdB+1/) ) + endif + endif + + do I=Isq,Ieq ; if (do_i(I)) then + + hlay = 0.5*(h(i,j,k) + h(i+1,j,k)) + if (hlay > h_tiny) then ! Only consider non-vanished layers. + I_2hlay = 1.0 / (h(i,j,k) + h(i+1,j,k)) + v_at_u = 0.5 * (h(i,j,k) * (v(i,J,k) + v(i,J-1,k)) + & + h(i+1,j,k) * (v(i+1,J,k) + v(i+1,J-1,k))) * I_2hlay + Uh2 = ((uhtot(I) - htot(I)*u(I,j,k))**2 + (vhtot(I) - htot(I)*v_at_u)**2) + + if (use_EOS) then + T_lay = (h(i,j,k)*tv%T(i,j,k) + h(i+1,j,k)*tv%T(i+1,j,k)) * I_2hlay + S_lay = (h(i,j,k)*tv%S(i,j,k) + h(i+1,j,k)*tv%S(i+1,j,k)) * I_2hlay + if (nonBous_ML) then + gHprime = (GV%g_Earth * GV%H_to_RZ) * (dSpV_dT(I) * (Thtot(I) - T_lay*htot(I)) + & + dSpV_dS(I) * (Shtot(I) - S_lay*htot(I))) + else + gHprime = g_H_Rho0 * (dR_dT(I) * (T_lay*htot(I) - Thtot(I)) + & + dR_dS(I) * (S_lay*htot(I) - Shtot(I))) + endif + else + gHprime = g_H_Rho0 * (GV%Rlay(k)*htot(I) - Rhtot(I)) + endif + + if (gHprime > 0.0) then + RiBulk = CS%bulk_Ri_ML * exp(-htot(I) * Idecay_len_TKE(I)) + if (RiBulk * Uh2 <= (htot(I)**2) * gHprime) then + visc%nkml_visc_u(I,j) = real(k_massive(I)) + do_i(I) = .false. + elseif (RiBulk * Uh2 <= (htot(I) + hlay)**2 * gHprime) then + visc%nkml_visc_u(I,j) = real(k-1) + & + ( sqrt(RiBulk * Uh2 / gHprime) - htot(I) ) / hlay + do_i(I) = .false. + endif + endif + k_massive(I) = k + endif ! hlay > h_tiny + + if (do_i(I)) do_any = .true. + endif ; enddo + + if (.not.do_any) exit ! All columns are done. + endif + + do I=Isq,Ieq ; if (do_i(I)) then + htot(I) = htot(I) + 0.5 * (h(i,j,k) + h(i+1,j,k)) + uhtot(I) = uhtot(I) + 0.5 * (h(i,j,k) + h(i+1,j,k)) * u(I,j,k) + vhtot(I) = vhtot(I) + 0.25 * (h(i,j,k) * (v(i,J,k) + v(i,J-1,k)) + & + h(i+1,j,k) * (v(i+1,J,k) + v(i+1,J-1,k))) + if (use_EOS) then + Thtot(I) = Thtot(I) + 0.5 * (h(i,j,k)*tv%T(i,j,k) + h(i+1,j,k)*tv%T(i+1,j,k)) + Shtot(I) = Shtot(I) + 0.5 * (h(i,j,k)*tv%S(i,j,k) + h(i+1,j,k)*tv%S(i+1,j,k)) + else + Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i+1,j,k)) * GV%Rlay(k) + endif + endif ; enddo + enddo ; endif + + if (do_any) then ; do I=Isq,Ieq ; if (do_i(I)) then + visc%nkml_visc_u(I,j) = k_massive(I) + endif ; enddo ; endif + endif ! dynamic_viscous_ML + + do_any_shelf = .false. + if (associated(forces%frac_shelf_u)) then + do I=Isq,Ieq + if (forces%frac_shelf_u(I,j)*G%mask2dCu(I,j) == 0.0) then + do_i(I) = .false. + visc%tbl_thick_shelf_u(I,j) = 0.0 ; visc%kv_tbl_shelf_u(I,j) = 0.0 + else + do_i(I) = .true. ; do_any_shelf = .true. + endif + enddo + endif + + if (do_any_shelf) then + do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) then + if (u(I,j,k) * (h(i+1,j,k) - h(i,j,k)) >= 0) then + h_at_vel(i,k) = 2.0*h(i,j,k)*h(i+1,j,k) / & + (h(i,j,k) + h(i+1,j,k) + h_neglect) + dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / & + (dz(i,j,k) + dz(i+1,j,k) + dz_neglect) + else + h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k)) + endif + else + h_at_vel(I,k) = 0.0 + dz_at_vel(I,k) = 0.0 + ustar(I) = 0.0 + endif ; enddo ; enddo + + do I=Isq,Ieq ; if (do_i(I)) then + htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 + Thtot(I) = 0.0 ; Shtot(I) = 0.0 ; SpV_htot(I) = 0.0 + if (use_EOS .or. .not.CS%linear_drag) then ; do k=1,nz + if (htot_vel>=CS%Htbl_shelf) exit ! terminate the k loop + hweight = MIN(CS%Htbl_shelf - htot_vel, h_at_vel(i,k)) + if (hweight <= 1.5*GV%Angstrom_H + h_neglect) cycle + + htot_vel = htot_vel + h_at_vel(i,k) + hwtot = hwtot + hweight + + if (.not.CS%linear_drag) then + v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) + hutot = hutot + hweight * sqrt(u(I,j,k)**2 + v_at_u**2 + U_bg_sq) + endif + if (use_EOS) then + Thtot(I) = Thtot(I) + hweight * 0.5 * (tv%T(i,j,k) + tv%T(i+1,j,k)) + Shtot(I) = Shtot(I) + hweight * 0.5 * (tv%S(i,j,k) + tv%S(i+1,j,k)) + endif + if (allocated(tv%SpV_avg)) then + SpV_htot(I) = SpV_htot(I) + hweight * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + endif + enddo ; endif + + if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then + ustar(I) = cdrag_sqrt_H * CS%drag_bg_vel + elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then + ustar(I) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot(I)) + elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag) + ustar(I) = cdrag_sqrt_H_RL * hutot / SpV_htot(I) + else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg)) + ustar(I) = cdrag_sqrt_H * hutot / hwtot + endif + + if (use_EOS) then ; if (hwtot > 0.0) then + T_EOS(I) = Thtot(I)/hwtot ; S_EOS(I) = Shtot(I)/hwtot + else + T_EOS(I) = 0.0 ; S_EOS(I) = 0.0 + endif ; endif + ! if (allocated(tv%SpV_avg)) SpV_av(I) = SpVhtot(I) / hwtot + endif ; enddo ! I-loop + + if (use_EOS) then + call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), dR_dT, dR_dS, & + tv%eqn_of_state, (/Isq-G%IsdB+1,Ieq-G%IsdB+1/) ) + endif + + do I=Isq,Ieq ; if (do_i(I)) then + ! The 400.0 in this expression is the square of a constant proposed + ! by Killworth and Edwards, 1999, in equation (2.20). + ustarsq = Rho0x400_G * ustar(i)**2 + htot(i) = 0.0 ; dztot(i) = 0.0 + if (use_EOS) then + Thtot(i) = 0.0 ; Shtot(i) = 0.0 + do k=1,nz-1 + if (h_at_vel(i,k) <= 0.0) cycle + T_Lay = 0.5 * (tv%T(i,j,k) + tv%T(i+1,j,k)) + S_Lay = 0.5 * (tv%S(i,j,k) + tv%S(i+1,j,k)) + oldfn = dR_dT(i)*(T_Lay*htot(i) - Thtot(i)) + dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) + if (oldfn >= ustarsq) exit + + Dfn = (dR_dT(i)*(0.5*(tv%T(i,j,k+1)+tv%T(i+1,j,k+1)) - T_Lay) + & + dR_dS(i)*(0.5*(tv%S(i,j,k+1)+tv%S(i+1,j,k+1)) - S_Lay)) * & + (h_at_vel(i,k)+htot(i)) + if ((oldfn + Dfn) <= ustarsq) then + Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) + else + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used + endif + + htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz + Thtot(i) = Thtot(i) + T_Lay*Dh ; Shtot(i) = Shtot(i) + S_Lay*Dh + enddo + if ((oldfn < ustarsq) .and. (h_at_vel(i,nz) > 0.0)) then + T_Lay = 0.5*(tv%T(i,j,nz) + tv%T(i+1,j,nz)) + S_Lay = 0.5*(tv%S(i,j,nz) + tv%S(i+1,j,nz)) + if (dR_dT(i)*(T_Lay*htot(i) - Thtot(i)) + & + dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) then + htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif + endif ! Examination of layer nz. + else ! Use Rlay as the density variable. + Rhtot = 0.0 + do k=1,nz-1 + Rlay = GV%Rlay(k) ; Rlb = GV%Rlay(k+1) + + oldfn = Rlay*htot(i) - Rhtot(i) + if (oldfn >= ustarsq) exit + + Dfn = (Rlb - Rlay)*(h_at_vel(i,k)+htot(i)) + if ((oldfn + Dfn) <= ustarsq) then + Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) + else + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used + endif + + htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz + Rhtot(i) = Rhtot(i) + Rlay*Dh + enddo + if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) then + htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif + endif ! use_EOS + + ! visc%tbl_thick_shelf_u(I,j) = max(CS%Htbl_shelf_min, & + ! dztot(I) / (0.5 + sqrt(0.25 + & + ! (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)))**2 / & + ! (ustar(i))**2 )) ) + ustar1 = ustar(i) + h2f2 = (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)) + h_neglect*CS%omega)**2 + tbl_thick = max(CS%Htbl_shelf_min, & + ( dztot(I)*ustar(i) ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) + visc%tbl_thick_shelf_u(I,j) = tbl_thick + visc%Kv_tbl_shelf_u(I,j) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar1*tbl_thick) + endif ; enddo ! I-loop + endif ! do_any_shelf + + enddo ! j-loop at u-points + + !$OMP parallel do default(private) shared(u,v,h,dz,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP nonBous_ML,h_neglect,dz_neglect,h_tiny,g_H_Rho0, & + !$OMP is,ie,OBC,Jsq,Jeq,nz,nkml,U_bg_sq,U_star_2d,mask_u, & + !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL,Rho0x400_G) + do J=Jsq,Jeq ! v-point loop + if (CS%dynamic_viscous_ML) then + do_any = .false. + do i=is,ie + htot(i) = 0.0 + if (G%mask2dCv(i,J) < 0.5) then + do_i(i) = .false. ; visc%nkml_visc_v(i,J) = nkml + else + do_i(i) = .true. ; do_any = .true. + k_massive(i) = nkml + Thtot(i) = 0.0 ; Shtot(i) = 0.0 ; Rhtot(i) = 0.0 + vhtot(i) = dt_Rho0 * forces%tauy(i,J) + uhtot(i) = 0.25 * dt_Rho0 * ((forces%taux(I,j) + forces%taux(I-1,j+1)) + & + (forces%taux(I-1,j) + forces%taux(I,j+1))) + + if (CS%omega_frac >= 1.0) then ; absf = 2.0*CS%omega ; else + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + if (CS%omega_frac > 0.0) & + absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) + endif + + U_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) + Idecay_len_TKE(i) = (absf / U_star) * CS%TKE_decay + + endif + enddo + + if (do_any) then ; do k=1,nz + if (k > nkml) then + do_any = .false. + if (use_EOS .and. (k==nkml+1)) then + ! Find dRho/dT and dRho_dS. + do i=is,ie + press(i) = (GV%H_to_RZ * GV%g_Earth) * htot(i) + if (associated(tv%p_surf)) press(i) = press(i) + 0.5*(tv%p_surf(i,j)+tv%p_surf(i,j+1)) + k2 = max(1,nkml) + I_2hlay = 1.0 / (h(i,j,k2) + h(i,j+1,k2) + h_neglect) + T_EOS(i) = (h(i,j,k2)*tv%T(i,j,k2) + h(i,j+1,k2)*tv%T(i,j+1,k2)) * I_2hlay + S_EOS(i) = (h(i,j,k2)*tv%S(i,j,k2) + h(i,j+1,k2)*tv%S(i,j+1,k2)) * I_2hlay + enddo + call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & + tv%eqn_of_state, (/is-G%IsdB+1,ie-G%IsdB+1/) ) + if (nonBous_ML) then + call calculate_specific_vol_derivs(T_EOS, S_EOS, press, dSpV_dT, dSpV_dS, tv%eqn_of_state, & + (/is-G%IsdB+1,ie-G%IsdB+1/) ) + endif + endif + + do i=is,ie ; if (do_i(i)) then + + hlay = 0.5*(h(i,j,k) + h(i,j+1,k)) + if (hlay > h_tiny) then ! Only consider non-vanished layers. + I_2hlay = 1.0 / (h(i,j,k) + h(i,j+1,k)) + u_at_v = 0.5 * (h(i,j,k) * (u(I-1,j,k) + u(I,j,k)) + & + h(i,j+1,k) * (u(I-1,j+1,k) + u(I,j+1,k))) * I_2hlay + Uh2 = ((uhtot(I) - htot(I)*u_at_v)**2 + (vhtot(I) - htot(I)*v(i,J,k))**2) + + if (use_EOS) then + T_lay = (h(i,j,k)*tv%T(i,j,k) + h(i,j+1,k)*tv%T(i,j+1,k)) * I_2hlay + S_lay = (h(i,j,k)*tv%S(i,j,k) + h(i,j+1,k)*tv%S(i,j+1,k)) * I_2hlay + if (nonBous_ML) then + gHprime = (GV%g_Earth * GV%H_to_RZ) * (dSpV_dT(i) * (Thtot(i) - T_lay*htot(i)) + & + dSpV_dS(i) * (Shtot(i) - S_lay*htot(i))) + else + gHprime = g_H_Rho0 * (dR_dT(i) * (T_lay*htot(i) - Thtot(i)) + & + dR_dS(i) * (S_lay*htot(i) - Shtot(i))) + endif + else + gHprime = g_H_Rho0 * (GV%Rlay(k)*htot(i) - Rhtot(i)) + endif + + if (gHprime > 0.0) then + RiBulk = CS%bulk_Ri_ML * exp(-htot(i) * Idecay_len_TKE(i)) + if (RiBulk * Uh2 <= htot(i)**2 * gHprime) then + visc%nkml_visc_v(i,J) = real(k_massive(i)) + do_i(i) = .false. + elseif (RiBulk * Uh2 <= (htot(i) + hlay)**2 * gHprime) then + visc%nkml_visc_v(i,J) = real(k-1) + & + ( sqrt(RiBulk * Uh2 / gHprime) - htot(i) ) / hlay + do_i(i) = .false. + endif + endif + k_massive(i) = k + endif ! hlay > h_tiny + + if (do_i(i)) do_any = .true. + endif ; enddo + + if (.not.do_any) exit ! All columns are done. + endif + + do i=is,ie ; if (do_i(i)) then + htot(i) = htot(i) + 0.5 * (h(i,J,k) + h(i,j+1,k)) + vhtot(i) = vhtot(i) + 0.5 * (h(i,j,k) + h(i,j+1,k)) * v(i,J,k) + uhtot(i) = uhtot(i) + 0.25 * (h(i,j,k) * (u(I-1,j,k) + u(I,j,k)) + & + h(i,j+1,k) * (u(I-1,j+1,k) + u(I,j+1,k))) + if (use_EOS) then + Thtot(i) = Thtot(i) + 0.5 * (h(i,j,k)*tv%T(i,j,k) + h(i,j+1,k)*tv%T(i,j+1,k)) + Shtot(i) = Shtot(i) + 0.5 * (h(i,j,k)*tv%S(i,j,k) + h(i,j+1,k)*tv%S(i,j+1,k)) + else + Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i,j+1,k)) * GV%Rlay(k) + endif + endif ; enddo + enddo ; endif + + if (do_any) then ; do i=is,ie ; if (do_i(i)) then + visc%nkml_visc_v(i,J) = k_massive(i) + endif ; enddo ; endif + endif ! dynamic_viscous_ML + + do_any_shelf = .false. + if (associated(forces%frac_shelf_v)) then + do i=is,ie + if (forces%frac_shelf_v(i,J)*G%mask2dCv(i,J) == 0.0) then + do_i(i) = .false. + visc%tbl_thick_shelf_v(i,J) = 0.0 ; visc%kv_tbl_shelf_v(i,J) = 0.0 + else + do_i(i) = .true. ; do_any_shelf = .true. + endif + enddo + endif + + if (do_any_shelf) then + do k=1,nz ; do i=is,ie ; if (do_i(i)) then + if (v(i,J,k) * (h(i,j+1,k) - h(i,j,k)) >= 0) then + h_at_vel(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / & + (h(i,j,k) + h(i,j+1,k) + h_neglect) + dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / & + (dz(i,j,k) + dz(i,j+1,k) + dz_neglect) + else + h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k)) + endif + else + h_at_vel(I,k) = 0.0 + dz_at_vel(I,k) = 0.0 + ustar(i) = 0.0 + endif ; enddo ; enddo + + do i=is,ie ; if (do_i(i)) then + htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 + Thtot(i) = 0.0 ; Shtot(i) = 0.0 ; SpV_htot(i) = 0.0 + if (use_EOS .or. .not.CS%linear_drag) then ; do k=1,nz + if (htot_vel>=CS%Htbl_shelf) exit ! terminate the k loop + hweight = MIN(CS%Htbl_shelf - htot_vel, h_at_vel(i,k)) + if (hweight <= 1.5*GV%Angstrom_H + h_neglect) cycle + + htot_vel = htot_vel + h_at_vel(i,k) + hwtot = hwtot + hweight + + if (.not.CS%linear_drag) then + u_at_v = set_u_at_v(u, h, G, GV, i, J, k, mask_u, OBC) + hutot = hutot + hweight * sqrt(v(i,J,k)**2 + u_at_v**2 + U_bg_sq) + endif + if (use_EOS) then + Thtot(i) = Thtot(i) + hweight * 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k)) + Shtot(i) = Shtot(i) + hweight * 0.5 * (tv%S(i,j,k) + tv%S(i,j+1,k)) + endif + if (allocated(tv%SpV_avg)) then + SpV_htot(i) = SpV_htot(i) + hweight * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + endif + enddo ; endif + + if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then + ustar(i) = cdrag_sqrt_H * CS%drag_bg_vel + elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then + ustar(i) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot(i)) + elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag) + ustar(i) = cdrag_sqrt_H_RL * hutot / SpV_htot(i) + else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg)) + ustar(i) = cdrag_sqrt_H * hutot / hwtot + endif + + if (use_EOS) then ; if (hwtot > 0.0) then + T_EOS(i) = Thtot(i)/hwtot ; S_EOS(i) = Shtot(i)/hwtot + else + T_EOS(i) = 0.0 ; S_EOS(i) = 0.0 + endif ; endif + endif ; enddo ! I-loop + + if (use_EOS) then + call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), dR_dT, dR_dS, & + tv%eqn_of_state, (/is-G%IsdB+1,ie-G%IsdB+1/) ) + endif + + do i=is,ie ; if (do_i(i)) then + ! The 400.0 in this expression is the square of a constant proposed + ! by Killworth and Edwards, 1999, in equation (2.20). + ustarsq = Rho0x400_G * ustar(i)**2 + htot(i) = 0.0 + dztot(i) = 0.0 + if (use_EOS) then + Thtot(i) = 0.0 ; Shtot(i) = 0.0 + do k=1,nz-1 + if (h_at_vel(i,k) <= 0.0) cycle + T_Lay = 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k)) + S_Lay = 0.5 * (tv%S(i,j,k) + tv%S(i,j+1,k)) + oldfn = dR_dT(i)*(T_Lay*htot(i) - Thtot(i)) + dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) + if (oldfn >= ustarsq) exit + + Dfn = (dR_dT(i)*(0.5*(tv%T(i,j,k+1)+tv%T(i,j+1,k+1)) - T_Lay) + & + dR_dS(i)*(0.5*(tv%S(i,j,k+1)+tv%S(i,j+1,k+1)) - S_Lay)) * & + (h_at_vel(i,k)+htot(i)) + if ((oldfn + Dfn) <= ustarsq) then + Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) + else + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used + endif + + htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz + Thtot(i) = Thtot(i) + T_Lay*Dh ; Shtot(i) = Shtot(i) + S_Lay*Dh + enddo + if ((oldfn < ustarsq) .and. (h_at_vel(i,nz) > 0.0)) then + T_Lay = 0.5*(tv%T(i,j,nz) + tv%T(i,j+1,nz)) + S_Lay = 0.5*(tv%S(i,j,nz) + tv%S(i,j+1,nz)) + if (dR_dT(i)*(T_Lay*htot(i) - Thtot(i)) + & + dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) then + htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif + endif ! Examination of layer nz. + else ! Use Rlay as the density variable. + Rhtot = 0.0 + do k=1,nz-1 + Rlay = GV%Rlay(k) ; Rlb = GV%Rlay(k+1) + + oldfn = Rlay*htot(i) - Rhtot(i) + if (oldfn >= ustarsq) exit + + Dfn = (Rlb - Rlay)*(h_at_vel(i,k)+htot(i)) + if ((oldfn + Dfn) <= ustarsq) then + Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) + else + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used + endif + + htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz + Rhtot = Rhtot + Rlay*Dh + enddo + if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) then + htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif + endif ! use_EOS + + ! visc%tbl_thick_shelf_v(i,J) = max(CS%Htbl_shelf_min, & + ! dztot(i) / (0.5 + sqrt(0.25 + & + ! (htot(i)*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))**2 / & + ! (ustar(i))**2 )) ) + ustar1 = ustar(i) + h2f2 = (htot(i)*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)) + h_neglect*CS%omega)**2 + tbl_thick = max(CS%Htbl_shelf_min, & + ( dztot(i)*ustar(i) ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) + visc%tbl_thick_shelf_v(i,J) = tbl_thick + visc%Kv_tbl_shelf_v(i,J) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar1*tbl_thick) + + endif ; enddo ! i-loop + endif ! do_any_shelf + + enddo ! J-loop at v-points + + if (CS%debug) then + if (allocated(visc%nkml_visc_u) .and. allocated(visc%nkml_visc_v)) & + call uvchksum("nkml_visc_[uv]", visc%nkml_visc_u, visc%nkml_visc_v, & + G%HI, haloshift=0, scalar_pair=.true.) + endif + if (CS%id_nkml_visc_u > 0) call post_data(CS%id_nkml_visc_u, visc%nkml_visc_u, CS%diag) + if (CS%id_nkml_visc_v > 0) call post_data(CS%id_nkml_visc_v, visc%nkml_visc_v, CS%diag) + +end subroutine set_viscous_ML + +!> Register any fields associated with the vertvisc_type. +subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_CS, use_ice_shelf) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical + !! viscosities and related fields. + !! Allocated here. + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + logical, intent(in) :: use_ice_shelf !< if true, register tau_shelf restarts + ! Local variables + logical :: use_kappa_shear, KS_at_vertex + logical :: adiabatic, useKPP, useEPBL + logical :: use_CVMix_shear, MLE_use_PBL_MLD, MLE_use_Bodner, use_CVMix_conv + integer :: isd, ied, jsd, jed, nz + real :: hfreeze !< If hfreeze > 0 [Z ~> m], melt potential will be computed. + character(len=16) :: Kv_units, Kd_units + character(len=40) :: mdl = "MOM_set_visc" ! This module's name. + type(vardesc) :: u_desc, v_desc + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & + do_not_log=.true.) + + use_kappa_shear = .false. ; KS_at_vertex = .false. ; use_CVMix_shear = .false. + useKPP = .false. ; useEPBL = .false. ; use_CVMix_conv = .false. + + if (.not.adiabatic) then + use_kappa_shear = kappa_shear_is_used(param_file) + KS_at_vertex = kappa_shear_at_vertex(param_file) + use_CVMix_shear = CVMix_shear_is_used(param_file) + use_CVMix_conv = CVMix_conv_is_used(param_file) + call get_param(param_file, mdl, "USE_KPP", useKPP, & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& + "to calculate diffusivities and non-local transport in the OBL.", & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "ENERGETICS_SFC_PBL", useEPBL, & + "If true, use an implied energetics planetary boundary "//& + "layer scheme to determine the diffusivity and viscosity "//& + "in the surface boundary layer.", default=.false., do_not_log=.true.) + endif + + if (GV%Boussinesq) then + Kv_units = "m2 s-1" ; Kd_units = "m2 s-1" + else + Kv_units = "Pa s" ; Kd_units = "kg m-1 s-1" + endif + + if (use_kappa_shear .or. useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv) then + call safe_alloc_ptr(visc%Kd_shear, isd, ied, jsd, jed, nz+1) + call register_restart_field(visc%Kd_shear, "Kd_shear", .false., restart_CS, & + "Shear-driven turbulent diffusivity at interfaces", & + units=Kd_units, conversion=GV%HZ_T_to_MKS, z_grid='i') + endif + if (useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv .or. & + (use_kappa_shear .and. .not.KS_at_vertex )) then + call safe_alloc_ptr(visc%Kv_shear, isd, ied, jsd, jed, nz+1) + call register_restart_field(visc%Kv_shear, "Kv_shear", .false., restart_CS, & + "Shear-driven turbulent viscosity at interfaces", & + units=Kv_units, conversion=GV%HZ_T_to_MKS, z_grid='i') + endif + if (use_kappa_shear .and. KS_at_vertex) then + call safe_alloc_ptr(visc%TKE_turb, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) + call safe_alloc_ptr(visc%Kv_shear_Bu, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) + call register_restart_field(visc%Kv_shear_Bu, "Kv_shear_Bu", .false., restart_CS, & + "Shear-driven turbulent viscosity at vertex interfaces", & + units=Kv_units, conversion=GV%HZ_T_to_MKS, hor_grid="Bu", z_grid='i') + elseif (use_kappa_shear) then + call safe_alloc_ptr(visc%TKE_turb, isd, ied, jsd, jed, nz+1) + endif + + if (useKPP) then + ! MOM_bkgnd_mixing uses Kv_slow when KPP is defined. + call safe_alloc_ptr(visc%Kv_slow, isd, ied, jsd, jed, nz+1) + endif + + ! visc%MLD is used to communicate the state of the (e)PBL or KPP to the rest of the model + call get_param(param_file, mdl, "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & + default=.false., do_not_log=.true.) + ! visc%MLD needs to be allocated when melt potential is computed (HFREEZE>0) + call get_param(param_file, mdl, "HFREEZE", hfreeze, & + units="m", default=-1.0, scale=US%m_to_Z, do_not_log=.true.) + + if (hfreeze >= 0.0 .or. MLE_use_PBL_MLD) then + call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) + endif + + if (MLE_use_PBL_MLD) then + call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & + "Instantaneous active mixing layer depth", units="m", conversion=US%Z_to_m) + endif + + ! visc%sfc_buoy_flx is used to communicate the state of the (e)PBL or KPP to the rest of the model + call get_param(param_file, mdl, "MLE%USE_BODNER23", MLE_use_Bodner, & + default=.false., do_not_log=.true.) + if (MLE_use_PBL_MLD .or. MLE_use_Bodner) then + call safe_alloc_ptr(visc%sfc_buoy_flx, isd, ied, jsd, jed) + call register_restart_field(visc%sfc_buoy_flx, "SFC_BFLX", .false., restart_CS, & + "Instantaneous surface buoyancy flux", "m2 s-3", & + conversion=US%Z_to_m**2*US%s_to_T**3) + endif + + if (use_ice_shelf) then + if (.not.allocated(visc%taux_shelf)) & + allocate(visc%taux_shelf(G%IsdB:G%IedB, G%jsd:G%jed), source=0.0) + if (.not.allocated(visc%tauy_shelf)) & + allocate(visc%tauy_shelf(G%isd:G%ied, G%JsdB:G%JedB), source=0.0) + u_desc = var_desc("u_taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & + hor_grid='Cu',z_grid='1') + v_desc = var_desc("v_tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & + hor_grid='Cv',z_grid='1') + call register_restart_pair(visc%taux_shelf, visc%tauy_shelf, u_desc, v_desc, & + .false., restart_CS, conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + endif + +end subroutine set_visc_register_restarts + +!> This subroutine does remapping for the auxiliary restart variables in a vertvisc_type +!! that are used across timesteps +subroutine remap_vertvisc_aux_vars(G, GV, visc, h_old, h_new, ALE_CSp, OBC) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical + !! viscosities and related fields. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Thickness of source grid [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Thickness of destination grid [H ~> m or kg m-2] + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure to use when remapping + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + + if (associated(visc%Kd_shear)) then + call ALE_remap_interface_vals(ALE_CSp, G, GV, h_old, h_new, visc%Kd_shear) + endif + + if (associated(visc%Kv_shear)) then + call ALE_remap_interface_vals(ALE_CSp, G, GV, h_old, h_new, visc%Kv_shear) + endif + + if (associated(visc%Kv_shear_Bu)) then + call ALE_remap_vertex_vals(ALE_CSp, G, GV, h_old, h_new, visc%Kv_shear_Bu) + endif + +end subroutine remap_vertvisc_aux_vars + +!> Initializes the MOM_set_visc control structure +subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS, OBC) + type(time_type), target, intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic + !! output. + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and + !! related fields. + type(set_visc_CS), intent(inout) :: CS !< Vertical viscosity control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure + + ! Local variables + real :: Csmag_chan_dflt ! The default value for SMAG_CONST_CHANNEL [nondim] + real :: smag_const1 ! The default value for the Smagorinsky Laplacian coefficient [nondim] + real :: TKE_decay_dflt ! The default value of a coefficient scaling the vertical decay + ! rate of TKE [nondim] + real :: bulk_Ri_ML_dflt ! The default bulk Richardson number for a bulk mixed layer [nondim] + real :: Kv_background ! The background kinematic viscosity in the interior [Z2 T-1 ~> m2 s-1] + real :: omega_frac_dflt ! The default value for the fraction of the absolute rotation rate that + ! is used in place of the absolute value of the local Coriolis + ! parameter in the denominator of some expressions [nondim] + real :: Chan_max_thick_dflt ! The default value for CHANNEL_DRAG_MAX_THICK [Z ~> m] + + integer :: i, j, k, is, ie, js, je + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: adiabatic, use_omega, MLE_use_PBL_MLD + logical :: use_KPP + logical :: use_regridding ! If true, use the ALE algorithm rather than layered + ! isopycnal or stacked shallow water mode. + logical :: use_temperature ! If true, temperature and salinity are used as state variables. + logical :: use_EOS ! If true, density calculated from T & S using an equation of state. + character(len=200) :: filename, tideamp_file ! Input file names or paths + character(len=80) :: tideamp_var ! Input file variable names + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_set_visc" ! This module's name. + + CS%initialized = .true. + CS%OBC => OBC + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + CS%diag => diag + + ! Set default, read and log parameters + call log_version(param_file, mdl, version, "") + CS%RiNo_mix = .false. + call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") + CS%inputdir = slasher(CS%inputdir) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "SET_VISC_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the set viscosity "//& + "calculations. Values below 20190101 recover the answers from the end of 2018, "//& + "while higher values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & + "If true, the bottom stress is calculated with a drag "//& + "law of the form c_drag*|u|*u. The velocity magnitude "//& + "may be an assumed value or it may be based on the "//& + "actual velocity in the bottommost HBBL, depending on "//& + "LINEAR_DRAG.", default=.true.) + call get_param(param_file, mdl, "DRAG_AS_BODY_FORCE", CS%body_force_drag, & + "If true, the bottom stress is imposed as an explicit body force "//& + "applied over a fixed distance from the bottom, rather than as an "//& + "implicit calculation based on an enhanced near-bottom viscosity. "//& + "The thickness of the bottom boundary layer is HBBL.", & + default=.false., do_not_log=.not.CS%bottomdraglaw) + call get_param(param_file, mdl, "CHANNEL_DRAG", CS%Channel_drag, & + "If true, the bottom drag is exerted directly on each "//& + "layer proportional to the fraction of the bottom it "//& + "overlies.", default=.false.) + call get_param(param_file, mdl, "LINEAR_DRAG", CS%linear_drag, & + "If LINEAR_DRAG and BOTTOMDRAGLAW are defined the drag "//& + "law is cdrag*DRAG_BG_VEL*u.", default=.false.) + call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & + do_not_log=.true.) + if (adiabatic) then + call log_param(param_file, mdl, "ADIABATIC",adiabatic, & + "There are no diapycnal mass fluxes if ADIABATIC is true. "//& + "This assumes that KD = 0.0 and that there is no buoyancy forcing, "//& + "but makes the model faster by eliminating subroutine calls.", default=.false.) + endif + + if (.not.adiabatic) then + CS%RiNo_mix = kappa_shear_is_used(param_file) + endif + + call get_param(param_file, mdl, "PRANDTL_TURB", visc%Prandtl_turb, & + "The turbulent Prandtl number applied to shear "//& + "instability.", units="nondim", default=1.0) + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) + + call get_param(param_file, mdl, "DYNAMIC_VISCOUS_ML", CS%dynamic_viscous_ML, & + "If true, use a bulk Richardson number criterion to "//& + "determine the mixed layer thickness for viscosity.", & + default=.false.) + if (CS%dynamic_viscous_ML) then + call get_param(param_file, mdl, "BULK_RI_ML", bulk_Ri_ML_dflt, units="nondim", default=0.0) + call get_param(param_file, mdl, "BULK_RI_ML_VISC", CS%bulk_Ri_ML, & + "The efficiency with which mean kinetic energy released by mechanically "//& + "forced entrainment of the mixed layer is converted to turbulent "//& + "kinetic energy. By default, BULK_RI_ML_VISC = BULK_RI_ML or 0.", & + units="nondim", default=bulk_Ri_ML_dflt) + call get_param(param_file, mdl, "TKE_DECAY", TKE_decay_dflt, units="nondim", default=0.0) + call get_param(param_file, mdl, "TKE_DECAY_VISC", CS%TKE_decay, & + "TKE_DECAY_VISC relates the vertical rate of decay of "//& + "the TKE available for mechanical entrainment to the "//& + "natural Ekman depth for use in calculating the dynamic "//& + "mixed layer viscosity. By default, TKE_DECAY_VISC = TKE_DECAY or 0.", & + units="nondim", default=TKE_decay_dflt) + call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & + "If true, use the absolute rotation rate instead of the "//& + "vertical component of rotation when setting the decay "//& + "scale for turbulence.", default=.false., do_not_log=.true.) + omega_frac_dflt = 0.0 + if (use_omega) then + call MOM_error(WARNING, "ML_USE_OMEGA is deprecated; use ML_OMEGA_FRAC=1.0 instead.") + omega_frac_dflt = 1.0 + endif + call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%omega_frac, & + "When setting the decay scale for turbulence, use this "//& + "fraction of the absolute rotation rate blended with the "//& + "local value of f, as sqrt((1-of)*f^2 + of*4*omega^2).", & + units="nondim", default=omega_frac_dflt) + call get_param(param_file, mdl, "OMEGA", CS%omega, & + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) + ! This give a minimum decay scale that is typically much less than Angstrom. + CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_H + GV%H_subroundoff) + else + call get_param(param_file, mdl, "OMEGA", CS%omega, & + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) + endif + + call get_param(param_file, mdl, "HBBL", CS%dz_bbl, & + "The thickness of a bottom boundary layer with a viscosity increased by "//& + "KV_EXTRA_BBL if BOTTOMDRAGLAW is not defined, or the thickness over which "//& + "near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is "//& + "defined but LINEAR_DRAG is not.", & + units="m", scale=US%m_to_Z, fail_if_missing=.true.) ! Rescaled later + if (CS%bottomdraglaw) then + call get_param(param_file, mdl, "CDRAG", CS%cdrag, & + "CDRAG is the drag coefficient relating the magnitude of "//& + "the velocity field to the bottom stress. CDRAG is only "//& + "used if BOTTOMDRAGLAW is defined.", units="nondim", default=0.003) + call get_param(param_file, mdl, "BBL_USE_TIDAL_BG", CS%BBL_use_tidal_bg, & + "Flag to use the tidal RMS amplitude in place of constant "//& + "background velocity for computing u* in the BBL. "//& + "This flag is only used when BOTTOMDRAGLAW is true and "//& + "LINEAR_DRAG is false.", default=.false.) + if (CS%BBL_use_tidal_bg) then + call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & + "The path to the file containing the spatially varying "//& + "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") + call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & + "The name of the tidal amplitude variable in the input file.", & + default="tideamp") + else + call get_param(param_file, mdl, "DRAG_BG_VEL", CS%drag_bg_vel, & + "DRAG_BG_VEL is either the assumed bottom velocity (with "//& + "LINEAR_DRAG) or an unresolved velocity that is "//& + "combined with the resolved velocity to estimate the "//& + "velocity magnitude. DRAG_BG_VEL is only used when "//& + "BOTTOMDRAGLAW is defined.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) + endif + call get_param(param_file, mdl, "USE_REGRIDDING", use_regridding, & + do_not_log=.true., default=.false. ) + call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "USE_EOS", use_EOS, & + default=use_temperature, do_not_log=.true.) + call get_param(param_file, mdl, "BBL_USE_EOS", CS%BBL_use_EOS, & + "If true, use the equation of state in determining the properties of the "//& + "bottom boundary layer. Otherwise use the layer target potential densities. "//& + "The default of this parameter is the value of USE_EOS.", & + default=use_EOS, do_not_log=.not.use_temperature) + if (use_regridding .and. (.not. CS%BBL_use_EOS)) & + call MOM_error(FATAL,"When using MOM6 in ALE mode it is required to set BBL_USE_EOS to True.") + endif + call get_param(param_file, mdl, "BBL_THICK_MIN", CS%BBL_thick_min, & + "The minimum bottom boundary layer thickness that can be "//& + "used with BOTTOMDRAGLAW. This might be "//& + "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& + "near-bottom viscosity.", units="m", default=0.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "HTBL_SHELF_MIN", CS%Htbl_shelf_min, & + "The minimum top boundary layer thickness that can be "//& + "used with BOTTOMDRAGLAW. This might be "//& + "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& + "near-top viscosity.", units="m", default=US%Z_to_m*CS%BBL_thick_min, scale=US%m_to_Z) + call get_param(param_file, mdl, "HTBL_SHELF", CS%Htbl_shelf, & + "The thickness over which near-surface velocities are "//& + "averaged for the drag law under an ice shelf. By "//& + "default this is the same as HBBL", & + units="m", default=US%Z_to_m*CS%dz_bbl, scale=GV%m_to_H) + + call get_param(param_file, mdl, "KV", Kv_background, & + "The background kinematic viscosity in the interior. "//& + "The molecular value, ~1e-6 m2 s-1, may be used.", & + units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) + + call get_param(param_file, mdl, "USE_KPP", use_KPP, & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& + "to calculate diffusivities and non-local transport in the OBL.", & + do_not_log=.true., default=.false.) + + call get_param(param_file, mdl, "KV_BBL_MIN", CS%KV_BBL_min, & + "The minimum viscosities in the bottom boundary layer.", & + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "KV_TBL_MIN", CS%KV_TBL_min, & + "The minimum viscosities in the top boundary layer.", & + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "CORRECT_BBL_BOUNDS", CS%correct_BBL_bounds, & + "If true, uses the correct bounds on the BBL thickness and "//& + "viscosity so that the bottom layer feels the intended drag.", & + default=.false.) + + if (CS%Channel_drag) then + call get_param(param_file, mdl, "SMAG_LAP_CONST", smag_const1, units="nondim", default=-1.0) + + cSmag_chan_dflt = 0.15 + if (smag_const1 >= 0.0) cSmag_chan_dflt = smag_const1 + + call get_param(param_file, mdl, "SMAG_CONST_CHANNEL", CS%c_Smag, & + "The nondimensional Laplacian Smagorinsky constant used "//& + "in calculating the channel drag if it is enabled. The "//& + "default is to use the same value as SMAG_LAP_CONST if "//& + "it is defined, or 0.15 if it is not. The value used is "//& + "also 0.15 if the specified value is negative.", & + units="nondim", default=cSmag_chan_dflt, do_not_log=.not.CS%Channel_drag) + if (CS%c_Smag < 0.0) CS%c_Smag = 0.15 + + call get_param(param_file, mdl, "TRIG_CHANNEL_DRAG_WIDTHS", CS%concave_trigonometric_L, & + "If true, use trigonometric expressions to determine the fractional open "//& + "interface lengths for concave topography.", & + default=.true., do_not_log=.not.CS%Channel_drag) + endif + + Chan_max_thick_dflt = -1.0*US%m_to_Z + if (CS%RiNo_mix) Chan_max_thick_dflt = 0.5*CS%dz_bbl + if (CS%body_force_drag) Chan_max_thick_dflt = CS%dz_bbl + call get_param(param_file, mdl, "CHANNEL_DRAG_MAX_BBL_THICK", CS%Chan_drag_max_vol, & + "The maximum bottom boundary layer thickness over which the channel drag is "//& + "exerted, or a negative value for no fixed limit, instead basing the BBL "//& + "thickness on the bottom stress, rotation and stratification. The default is "//& + "proportional to HBBL if USE_JACKSON_PARAM or DRAG_AS_BODY_FORCE is true.", & + units="m", default=US%Z_to_m*Chan_max_thick_dflt, scale=US%m_to_Z, & + do_not_log=.not.CS%Channel_drag) + + call get_param(param_file, mdl, "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & + default=.false., do_not_log=.true.) + + CS%Hbbl = CS%dz_bbl * (US%Z_to_m * GV%m_to_H) ! Rescaled for use in expressions in thickness units. + + if (CS%RiNo_mix .and. kappa_shear_at_vertex(param_file)) then + ! This is necessary for reproducibility across restarts in non-symmetric mode. + call pass_var(visc%Kv_shear_Bu, G%Domain, position=CORNER, complete=.true.) + endif + + if (CS%bottomdraglaw) then + allocate(visc%bbl_thick_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(visc%bbl_thick_v(isd:ied,JsdB:JedB), source=0.0) + allocate(visc%kv_bbl_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(visc%kv_bbl_v(isd:ied,JsdB:JedB), source=0.0) + allocate(visc%ustar_bbl(isd:ied,jsd:jed), source=0.0) + allocate(visc%TKE_bbl(isd:ied,jsd:jed), source=0.0) + + CS%id_bbl_thick_u = register_diag_field('ocean_model', 'bbl_thick_u', & + diag%axesCu1, Time, 'BBL thickness at u points', 'm', conversion=US%Z_to_m) + CS%id_kv_bbl_u = register_diag_field('ocean_model', 'kv_bbl_u', diag%axesCu1, & + Time, 'BBL viscosity at u points', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + CS%id_bbl_u = register_diag_field('ocean_model', 'bbl_u', diag%axesCu1, & + Time, 'BBL mean u current', 'm s-1', conversion=US%L_T_to_m_s) + if (CS%id_bbl_u>0) then + allocate(CS%bbl_u(IsdB:IedB,jsd:jed), source=0.0) + endif + CS%id_bbl_thick_v = register_diag_field('ocean_model', 'bbl_thick_v', & + diag%axesCv1, Time, 'BBL thickness at v points', 'm', conversion=US%Z_to_m) + CS%id_kv_bbl_v = register_diag_field('ocean_model', 'kv_bbl_v', diag%axesCv1, & + Time, 'BBL viscosity at v points', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + CS%id_bbl_v = register_diag_field('ocean_model', 'bbl_v', diag%axesCv1, & + Time, 'BBL mean v current', 'm s-1', conversion=US%L_T_to_m_s) + if (CS%id_bbl_v>0) then + allocate(CS%bbl_v(isd:ied,JsdB:JedB), source=0.0) + endif + if (CS%BBL_use_tidal_bg) then + allocate(CS%tideamp(isd:ied,jsd:jed), source=0.0) + filename = trim(CS%inputdir) // trim(tideamp_file) + call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) + call MOM_read_data(filename, tideamp_var, CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) + call pass_var(CS%tideamp,G%domain) + endif + endif + if (CS%Channel_drag .or. CS%body_force_drag) then + allocate(visc%Ray_u(IsdB:IedB,jsd:jed,nz), source=0.0) + allocate(visc%Ray_v(isd:ied,JsdB:JedB,nz), source=0.0) + CS%id_Ray_u = register_diag_field('ocean_model', 'Rayleigh_u', diag%axesCuL, & + Time, 'Rayleigh drag velocity at u points', 'm s-1', conversion=GV%H_to_m*US%s_to_T) + CS%id_Ray_v = register_diag_field('ocean_model', 'Rayleigh_v', diag%axesCvL, & + Time, 'Rayleigh drag velocity at v points', 'm s-1', conversion=GV%H_to_m*US%s_to_T) + endif + + + if (CS%dynamic_viscous_ML) then + allocate(visc%nkml_visc_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(visc%nkml_visc_v(isd:ied,JsdB:JedB), source=0.0) + CS%id_nkml_visc_u = register_diag_field('ocean_model', 'nkml_visc_u', & + diag%axesCu1, Time, 'Number of layers in viscous mixed layer at u points', 'nondim') + CS%id_nkml_visc_v = register_diag_field('ocean_model', 'nkml_visc_v', & + diag%axesCv1, Time, 'Number of layers in viscous mixed layer at v points', 'nondim') + endif + + call register_restart_field_as_obsolete('Kd_turb','Kd_shear', restart_CS) + call register_restart_field_as_obsolete('Kv_turb','Kv_shear', restart_CS) + +end subroutine set_visc_init + +!> This subroutine dellocates any memory in the set_visc control structure. +subroutine set_visc_end(visc, CS) + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and + !! related fields. Elements are deallocated here. + type(set_visc_CS), intent(inout) :: CS !< The control structure returned by a previous + !! call to set_visc_init. + + if (allocated(visc%bbl_thick_u)) deallocate(visc%bbl_thick_u) + if (allocated(visc%bbl_thick_v)) deallocate(visc%bbl_thick_v) + if (allocated(visc%kv_bbl_u)) deallocate(visc%kv_bbl_u) + if (allocated(visc%kv_bbl_v)) deallocate(visc%kv_bbl_v) + if (allocated(CS%bbl_u)) deallocate(CS%bbl_u) + if (allocated(CS%bbl_v)) deallocate(CS%bbl_v) + if (allocated(visc%Ray_u)) deallocate(visc%Ray_u) + if (allocated(visc%Ray_v)) deallocate(visc%Ray_v) + if (allocated(visc%nkml_visc_u)) deallocate(visc%nkml_visc_u) + if (allocated(visc%nkml_visc_v)) deallocate(visc%nkml_visc_v) + if (associated(visc%Kd_shear)) deallocate(visc%Kd_shear) + if (associated(visc%Kv_slow)) deallocate(visc%Kv_slow) + if (associated(visc%TKE_turb)) deallocate(visc%TKE_turb) + if (associated(visc%Kv_shear)) deallocate(visc%Kv_shear) + if (associated(visc%Kv_shear_Bu)) deallocate(visc%Kv_shear_Bu) + if (allocated(visc%ustar_bbl)) deallocate(visc%ustar_bbl) + if (allocated(visc%TKE_bbl)) deallocate(visc%TKE_bbl) + if (allocated(visc%taux_shelf)) deallocate(visc%taux_shelf) + if (allocated(visc%tauy_shelf)) deallocate(visc%tauy_shelf) + if (allocated(visc%tbl_thick_shelf_u)) deallocate(visc%tbl_thick_shelf_u) + if (allocated(visc%tbl_thick_shelf_v)) deallocate(visc%tbl_thick_shelf_v) + if (allocated(visc%kv_tbl_shelf_u)) deallocate(visc%kv_tbl_shelf_u) + if (allocated(visc%kv_tbl_shelf_v)) deallocate(visc%kv_tbl_shelf_v) +end subroutine set_visc_end + +!> \namespace mom_set_visc +!! +!! This would also be the module in which other viscous quantities that are flow-independent might be set. +!! This information is transmitted to other modules via a vertvisc type structure. +!! +!! The same code is used for the two velocity components, by indirectly referencing the velocities and +!! defining a handful of direction-specific defined variables. + +end module MOM_set_visc diff --git a/parameterizations/vertical/MOM_sponge.F90 b/parameterizations/vertical/MOM_sponge.F90 new file mode 100644 index 0000000000..4bdf610a24 --- /dev/null +++ b/parameterizations/vertical/MOM_sponge.F90 @@ -0,0 +1,672 @@ +!> Implements sponge regions in isopycnal mode +module MOM_sponge + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : sum_across_PEs +use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, NOTE, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_spatial_means, only : global_i_mean +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +! Planned extension: Support for time varying sponge targets. + +implicit none ; private + +#include + +public set_up_sponge_field, set_up_sponge_ML_density +public initialize_sponge, apply_sponge, sponge_end, init_sponge_diags + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> A structure for creating arrays of pointers to 3D arrays +type, public :: p3d + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array [various] +end type p3d +!> A structure for creating arrays of pointers to 2D arrays +type, public :: p2d + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array [various] +end type p2d + +!> This control structure holds memory and parameters for the MOM_sponge module +type, public :: sponge_CS ; private + logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with + !! nkml sublayers and nkbl buffer layer. + integer :: nz !< The total number of layers. + integer :: num_col !< The number of sponge points within the computational domain. + integer :: fldno = 0 !< The number of fields which have already been + !! registered by calls to set_up_sponge_field + integer, pointer :: col_i(:) => NULL() !< Array of the i-indicies of each of the columns being damped. + integer, pointer :: col_j(:) => NULL() !< Array of the j-indicies of each of the columns being damped. + real, pointer :: Iresttime_col(:) => NULL() !< The inverse restoring time of each column [T-1 ~> s-1]. + real, pointer :: Rcv_ml_ref(:) => NULL() !< The value toward which the mixed layer + !! coordinate-density is being damped [R ~> kg m-3]. + real, pointer :: Ref_eta(:,:) => NULL() !< The value toward which the interface + !! heights are being damped [Z ~> m]. + type(p3d) :: var(MAX_FIELDS_) !< Pointers to the fields that are being damped. + type(p2d) :: Ref_val(MAX_FIELDS_) !< The values to which the fields are damped. + + logical :: do_i_mean_sponge !< If true, apply sponges to the i-mean fields. + real, pointer :: Iresttime_im(:) => NULL() !< The inverse restoring time of + !! each row for i-mean sponges [T-1 ~> s-1]. + real, pointer :: Rcv_ml_ref_im(:) => NULL() !! The value toward which the i-mean + !< mixed layer coordinate-density is being damped [R ~> kg m-3]. + real, pointer :: Ref_eta_im(:,:) => NULL() !< The value toward which the i-mean + !! interface heights are being damped [Z ~> m]. + type(p2d) :: Ref_val_im(MAX_FIELDS_) !< The values toward which the i-means of + !! fields are damped. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + integer :: id_w_sponge = -1 !< A diagnostic ID +end type sponge_CS + +contains + +!> This subroutine determines the number of points which are within sponges in +!! this computational domain. Only points that have positive values of +!! Iresttime and which mask2dT indicates are ocean points are included in the +!! sponges. It also stores the target interface heights. +subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & + Iresttime_i_mean, int_height_i_mean) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(in) :: int_height !< The interface heights to damp back toward [Z ~> m]. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + real, dimension(SZJ_(G)), & + optional, intent(in) :: Iresttime_i_mean !< The inverse of the restoring time for + !! the zonal mean properties [T-1 ~> s-1]. + real, dimension(SZJ_(G),SZK_(GV)+1), & + optional, intent(in) :: int_height_i_mean !< The interface heights toward which to + !! damp the zonal mean heights [Z ~> m]. + + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_sponge" ! This module's name. + logical :: use_sponge + integer :: i, j, k, col, total_sponge_cols + + if (associated(CS)) then + call MOM_error(WARNING, "initialize_sponge called with an associated "// & + "control structure.") + return + endif + +! Set default, read and log parameters + call log_version(param_file, mdl, version) + call get_param(param_file, mdl, "SPONGE", use_sponge, & + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified from MOM_initialization.F90.", default=.false.) + + if (.not.use_sponge) return + allocate(CS) + + if (present(Iresttime_i_mean) .neqv. present(int_height_i_mean)) & + call MOM_error(FATAL, "initialize_sponge: The optional arguments \n"//& + "Iresttime_i_mean and int_height_i_mean must both be present \n"//& + "if either one is.") + + CS%do_i_mean_sponge = present(Iresttime_i_mean) + + CS%nz = GV%ke + + ! CS%bulkmixedlayer may be set later via a call to set_up_sponge_ML_density. + CS%bulkmixedlayer = .false. + + 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.0)) & + CS%num_col = CS%num_col + 1 + enddo ; enddo + + if (CS%num_col > 0) then + + allocate(CS%Iresttime_col(CS%num_col), source=0.0) + allocate(CS%col_i(CS%num_col), source=0) + allocate(CS%col_j(CS%num_col), source=0) + + 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.0)) then + CS%col_i(col) = i ; CS%col_j(col) = j + CS%Iresttime_col(col) = Iresttime(i,j) + col = col +1 + endif + enddo ; enddo + + allocate(CS%Ref_eta(CS%nz+1,CS%num_col)) + do col=1,CS%num_col ; do K=1,CS%nz+1 + CS%Ref_eta(K,col) = int_height(CS%col_i(col),CS%col_j(col),K) + enddo ; enddo + + endif + + if (CS%do_i_mean_sponge) then + allocate(CS%Iresttime_im(G%jsd:G%jed), source=0.0) + allocate(CS%Ref_eta_im(G%jsd:G%jed,GV%ke+1), source=0.0) + + do j=G%jsc,G%jec + CS%Iresttime_im(j) = Iresttime_i_mean(j) + enddo + do K=1,CS%nz+1 ; do j=G%jsc,G%jec + CS%Ref_eta_im(j,K) = int_height_i_mean(j,K) + enddo ; enddo + endif + + total_sponge_cols = CS%num_col + call sum_across_PEs(total_sponge_cols) + + call log_param(param_file, mdl, "!Total sponge columns", total_sponge_cols, & + "The total number of columns where sponges are applied.") + +end subroutine initialize_sponge + +!> This subroutine sets up diagnostics for the sponges. It is separate +!! from initialize_sponge because it requires fields that are not readily +!! available where initialize_sponge is called. +subroutine init_sponge_diags(Time, G, GV, US, diag, CS) + type(time_type), target, intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic output + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that + !! is set by a previous call to initialize_sponge. + + if (.not.associated(CS)) return + + CS%diag => diag + CS%id_w_sponge = register_diag_field('ocean_model', 'w_sponge', diag%axesTi, & + Time, 'The diapycnal motion due to the sponges', 'm s-1', conversion=GV%H_to_m*US%s_to_T) + +end subroutine init_sponge_diags + +!> This subroutine stores the reference profile for the variable whose +!! address is given by f_ptr. nlay is the number of layers in this variable. +subroutine set_up_sponge_field(sp_val, f_ptr, G, GV, nlay, CS, sp_val_i_mean) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: sp_val !< The reference profiles of the quantity being registered [various] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + target, intent(in) :: f_ptr !< a pointer to the field which will be damped [various] + integer, intent(in) :: nlay !< the number of layers in this quantity + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that + !! is set by a previous call to initialize_sponge. + real, dimension(SZJ_(G),SZK_(GV)),& + optional, intent(in) :: sp_val_i_mean !< The i-mean reference value for + !! this field with i-mean sponges [various] + + integer :: j, k, col + character(len=256) :: mesg ! String for error messages + + if (.not.associated(CS)) return + + CS%fldno = CS%fldno + 1 + + if (CS%fldno > MAX_FIELDS_) then + write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & + &the number of fields to be damped in the call to & + &initialize_sponge." )') CS%fldno + call MOM_error(FATAL,"set_up_sponge_field: "//mesg) + endif + + allocate(CS%Ref_val(CS%fldno)%p(CS%nz,CS%num_col), source=0.0) + do col=1,CS%num_col + do k=1,nlay + CS%Ref_val(CS%fldno)%p(k,col) = sp_val(CS%col_i(col),CS%col_j(col),k) + enddo + do k=nlay+1,CS%nz + CS%Ref_val(CS%fldno)%p(k,col) = 0.0 + enddo + enddo + + CS%var(CS%fldno)%p => f_ptr + + if (nlay/=CS%nz) then + write(mesg,'("Danger: Sponge reference fields require nz (",I3,") layers.& + & A field with ",I3," layers was passed to set_up_sponge_field.")') & + CS%nz, nlay + if (is_root_pe()) call MOM_error(WARNING, "set_up_sponge_field: "//mesg) + endif + + if (CS%do_i_mean_sponge) then + if (.not.present(sp_val_i_mean)) call MOM_error(FATAL, & + "set_up_sponge_field: sp_val_i_mean must be present with i-mean sponges.") + + allocate(CS%Ref_val_im(CS%fldno)%p(G%jsd:G%jed,CS%nz), source=0.0) + do k=1,CS%nz ; do j=G%jsc,G%jec + CS%Ref_val_im(CS%fldno)%p(j,k) = sp_val_i_mean(j,k) + enddo ; enddo + endif + +end subroutine set_up_sponge_field + + +!> This subroutine stores the reference value for mixed layer density. It is handled differently +!! from other values because it is only used in determining which layers can be inflated. +subroutine set_up_sponge_ML_density(sp_val, G, CS, sp_val_i_mean) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: sp_val !< The reference values of the mixed layer density [R ~> kg m-3] + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that is + !! set by a previous call to initialize_sponge. + ! The contents of this structure are intent(inout) here. + real, dimension(SZJ_(G)), & + optional, intent(in) :: sp_val_i_mean !< the reference values of the zonal mean mixed + !! layer density [R ~> kg m-3], for use if Iresttime_i_mean > 0. + + integer :: j, col + + if (.not.associated(CS)) return + + if (associated(CS%Rcv_ml_ref)) then + call MOM_error(FATAL, "set_up_sponge_ML_density appears to have been "//& + "called twice.") + endif + + CS%bulkmixedlayer = .true. + allocate(CS%Rcv_ml_ref(CS%num_col), source=0.0) + do col=1,CS%num_col + CS%Rcv_ml_ref(col) = sp_val(CS%col_i(col),CS%col_j(col)) + enddo + + if (CS%do_i_mean_sponge) then + if (.not.present(sp_val_i_mean)) call MOM_error(FATAL, & + "set_up_sponge_field: sp_val_i_mean must be present with i-mean sponges.") + + allocate(CS%Rcv_ml_ref_im(G%jsd:G%jed), source=0.0) + do j=G%jsc,G%jec + CS%Rcv_ml_ref_im(j) = sp_val_i_mean(j) + enddo + endif + +end subroutine set_up_sponge_ML_density + +!> This subroutine applies damping to the layers thicknesses, mixed layer buoyancy, and a variety of +!! tracers for every column where there is damping. +subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ea !< An array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: eb !< An array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module + !! that is set by a previous call to initialize_sponge. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(inout) :: Rcv_ml !< The coordinate density of the mixed layer [R ~> kg m-3]. + + ! Local variables + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: & + w_int, & ! Water moved upward across an interface within a timestep, + ! [H ~> m or kg m-2]. + e_D ! Interface heights that are dilated to have a value of 0 + ! at the surface [Z ~> m]. + real, dimension(SZI_(G), SZJ_(G)) :: & + eta_anom, & ! Anomalies in the interface height, relative to the i-mean + ! target value [Z ~> m]. + fld_anom ! Anomalies in a tracer concentration, relative to the + ! i-mean target value [various] + real, dimension(SZJ_(G), SZK_(GV)+1) :: & + eta_mean_anom ! The i-mean interface height anomalies [Z ~> m]. + real, allocatable, dimension(:,:,:) :: & + fld_mean_anom ! The i-mean tracer concentration anomalies [various] + real, dimension(SZI_(G), SZK_(GV)+1) :: & + h_above, & ! The total thickness above an interface [H ~> m or kg m-2]. + h_below ! The total thickness below an interface [H ~> m or kg m-2]. + real, dimension(SZI_(G)) :: & + dilate ! A nondimensional factor by which to dilate layers to + ! give 0 at the surface [nondim]. + + real :: e(SZK_(GV)+1) ! The interface heights [Z ~> m], usually negative. + real :: dz_to_h(SZK_(GV)+1) ! Factors used to convert interface height movement + ! to thickness fluxes [H Z-1 ~> nondim or kg m-3] + real :: e0 ! The height of the free surface [Z ~> m]. + real :: e_str ! A nondimensional amount by which the reference + ! profile must be stretched for the free surfaces + ! heights in the two profiles to agree [nondim]. + real :: w_mean ! The vertical displacement of water moving upward through an + ! interface within 1 timestep [Z ~> m]. + real :: w ! The thickness of water moving upward through an + ! interface within 1 timestep [H ~> m or kg m-2]. + real :: wm ! wm is w if w is negative and 0 otherwise [H ~> m or kg m-2]. + real :: wb ! w at the interface below a layer [H ~> m or kg m-2]. + real :: wpb ! wpb is wb if wb is positive and 0 otherwise [H ~> m or kg m-2]. + real :: ea_k ! Water entrained from above within a timestep [H ~> m or kg m-2] + real :: eb_k ! Water entrained from below within a timestep [H ~> m or kg m-2] + real :: damp ! The timestep times the local damping coefficient [nondim]. + real :: I1pdamp ! I1pdamp is 1/(1 + damp). [nondim] + real :: damp_1pdamp ! damp_1pdamp is damp/(1 + damp). [nondim] + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + integer :: c, m, nkmb, i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + if (CS%bulkmixedlayer) nkmb = GV%nk_rho_varies + if (CS%bulkmixedlayer .and. (.not.present(Rcv_ml))) & + call MOM_error(FATAL, "Rml must be provided to apply_sponge when using "//& + "a bulk mixed layer.") + + if ((CS%id_w_sponge > 0) .or. CS%do_i_mean_sponge) then + do k=1,nz+1 ; do j=js,je ; do i=is,ie + w_int(i,j,K) = 0.0 + enddo ; enddo ; enddo + endif + + if (CS%do_i_mean_sponge) then + ! Apply forcing to restore the zonal-mean properties to prescribed values. + + if (CS%bulkmixedlayer) call MOM_error(FATAL, "apply_sponge is not yet set up to "//& + "work properly with i-mean sponges and a bulk mixed layer.") + + do j=js,je ; do i=is,ie ; e_D(i,j,nz+1) = -G%bathyT(i,j) ; enddo ; enddo + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + e_D(i,j,K) = e_D(i,j,K+1) + GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo ; enddo ; enddo + else + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + e_D(i,j,K) = e_D(i,j,K+1) + h(i,j,k)*GV%H_to_Z + enddo ; enddo ; enddo + endif + do j=js,je + do i=is,ie + dilate(i) = (G%bathyT(i,j) + G%Z_ref) / (e_D(i,j,1) + G%bathyT(i,j)) + enddo + do k=1,nz+1 ; do i=is,ie + e_D(i,j,K) = dilate(i) * (e_D(i,j,K) + G%bathyT(i,j)) - (G%bathyT(i,j) + G%Z_ref) + enddo ; enddo + enddo + + do k=2,nz + do j=js,je ; do i=is,ie + eta_anom(i,j) = e_D(i,j,k) - CS%Ref_eta_im(j,k) + if (CS%Ref_eta_im(j,K) < -(G%bathyT(i,j) + G%Z_ref)) eta_anom(i,j) = 0.0 + enddo ; enddo + call global_i_mean(eta_anom(:,:), eta_mean_anom(:,K), G, tmp_scale=US%Z_to_m) + enddo + + if (CS%fldno > 0) allocate(fld_mean_anom(G%isd:G%ied,nz,CS%fldno)) + do m=1,CS%fldno + do j=js,je ; do i=is,ie + fld_anom(i,j) = CS%var(m)%p(i,j,k) - CS%Ref_val_im(m)%p(j,k) + enddo ; enddo + call global_i_mean(fld_anom(:,:), fld_mean_anom(:,k,m), G, h(:,:,k)) + enddo + + do j=js,je ; if (CS%Iresttime_im(j) > 0.0) then + damp = dt * CS%Iresttime_im(j) ; damp_1pdamp = damp / (1.0 + damp) + + do i=is,ie + h_above(i,1) = 0.0 ; h_below(i,nz+1) = 0.0 + enddo + do K=nz,1,-1 ; do i=is,ie + h_below(i,K) = h_below(i,K+1) + max(h(i,j,k)-GV%Angstrom_H, 0.0) + enddo ; enddo + do K=2,nz+1 ; do i=is,ie + h_above(i,K) = h_above(i,K-1) + max(h(i,j,k-1)-GV%Angstrom_H, 0.0) + enddo ; enddo + + ! In both blocks below, w is positive for an upward (lightward) flux of mass, + ! resulting in the downward movement of an interface. + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do K=2,nz + w_mean = damp_1pdamp * eta_mean_anom(j,K) + do i=is,ie + w = w_mean * 2.0*GV%RZ_to_H / (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) + if (w > 0.0) then + w_int(i,j,K) = min(w, h_below(i,K)) + eb(i,j,k-1) = eb(i,j,k-1) + w_int(i,j,K) + else + w_int(i,j,K) = max(w, -h_above(i,K)) + ea(i,j,k) = ea(i,j,k) - w_int(i,j,K) + endif + enddo + enddo + else + do K=2,nz + w = damp_1pdamp * eta_mean_anom(j,K) * GV%Z_to_H + if (w > 0.0) then + do i=is,ie + w_int(i,j,K) = min(w, h_below(i,K)) + eb(i,j,k-1) = eb(i,j,k-1) + w_int(i,j,K) + enddo + else + do i=is,ie + w_int(i,j,K) = max(w, -h_above(i,K)) + ea(i,j,k) = ea(i,j,k) - w_int(i,j,K) + enddo + endif + enddo + endif + do k=1,nz ; do i=is,ie + ea_k = max(0.0, -w_int(i,j,K)) + eb_k = max(0.0, w_int(i,j,K+1)) + do m=1,CS%fldno + CS%var(m)%p(i,j,k) = (h(i,j,k)*CS%var(m)%p(i,j,k) + & + CS%Ref_val_im(m)%p(j,k) * (ea_k + eb_k)) / & + (h(i,j,k) + (ea_k + eb_k)) - & + damp_1pdamp * fld_mean_anom(j,k,m) + enddo + + h(i,j,k) = max(h(i,j,k) + (w_int(i,j,K+1) - w_int(i,j,K)), & + min(h(i,j,k), GV%Angstrom_H)) + enddo ; enddo + endif ; enddo + + if (CS%fldno > 0) deallocate(fld_mean_anom) + + endif + + do c=1,CS%num_col + i = CS%col_i(c) ; j = CS%col_j(c) + damp = dt * CS%Iresttime_col(c) + + e(1) = 0.0 ; e0 = 0.0 + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do K=1,nz + e(K+1) = e(K) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo + dz_to_h(1) = GV%RZ_to_H / tv%SpV_avg(i,j,1) + do K=2,nz + dz_to_h(K) = 2.0*GV%RZ_to_H / (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) + enddo + else + do K=1,nz + e(K+1) = e(K) - h(i,j,k)*GV%H_to_Z + dz_to_h(K) = GV%Z_to_H + enddo + endif + e_str = e(nz+1) / CS%Ref_eta(nz+1,c) + + if ( CS%bulkmixedlayer ) then + I1pdamp = 1.0 / (1.0 + damp) + if (associated(CS%Rcv_ml_ref)) & + Rcv_ml(i,j) = I1pdamp * (Rcv_ml(i,j) + CS%Rcv_ml_ref(c)*damp) + do k=1,nkmb + do m=1,CS%fldno + CS%var(m)%p(i,j,k) = I1pdamp * & + (CS%var(m)%p(i,j,k) + CS%Ref_val(m)%p(k,c)*damp) + enddo + enddo + + wpb = 0.0; wb = 0.0 + do k=nz,nkmb+1,-1 + if (GV%Rlay(k) > Rcv_ml(i,j)) then + w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*dz_to_h(K), & + ((wb + h(i,j,k)) - GV%Angstrom_H)) + wm = 0.5*(w-ABS(w)) + do m=1,CS%fldno + CS%var(m)%p(i,j,k) = (h(i,j,k)*CS%var(m)%p(i,j,k) + & + CS%Ref_val(m)%p(k,c)*(damp*h(i,j,k) + (wpb - wm))) / & + (h(i,j,k)*(1.0 + damp) + (wpb - wm)) + enddo + else + do m=1,CS%fldno + CS%var(m)%p(i,j,k) = I1pdamp * & + (CS%var(m)%p(i,j,k) + CS%Ref_val(m)%p(k,c)*damp) + enddo + w = wb + (h(i,j,k) - GV%Angstrom_H) + wm = 0.5*(w-ABS(w)) + endif + eb(i,j,k) = eb(i,j,k) + wpb + ea(i,j,k) = ea(i,j,k) - wm + h(i,j,k) = h(i,j,k) + (wb - w) + wb = w + wpb = w - wm + enddo + + if (wb < 0) then + do k=nkmb,1,-1 + w = MIN((wb + (h(i,j,k) - GV%Angstrom_H)),0.0) + h(i,j,k) = h(i,j,k) + (wb - w) + ea(i,j,k) = ea(i,j,k) - w + wb = w + enddo + else + w = wb + do k=GV%nkml,nkmb + eb(i,j,k) = eb(i,j,k) + w + enddo + + k = GV%nkml + h(i,j,k) = h(i,j,k) + w + do m=1,CS%fldno + CS%var(m)%p(i,j,k) = (CS%var(m)%p(i,j,k)*h(i,j,k) + & + CS%Ref_val(m)%p(k,c)*w) / (h(i,j,k) + w) + enddo + endif + + do k=1,nkmb + do m=1,CS%fldno + CS%var(m)%p(i,j,k) = I1pdamp * & + (CS%var(m)%p(i,j,k) + CS%Ref_val(m)%p(GV%nkml,c)*damp) + enddo + enddo + + else ! not BULKMIXEDLAYER + + wpb = 0.0 + wb = 0.0 + do k=nz,1,-1 + w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*dz_to_h(K), & + ((wb + h(i,j,k)) - GV%Angstrom_H)) + wm = 0.5*(w - ABS(w)) + do m=1,CS%fldno + CS%var(m)%p(i,j,k) = (h(i,j,k)*CS%var(m)%p(i,j,k) + & + CS%Ref_val(m)%p(k,c) * (damp*h(i,j,k) + (wpb - wm))) / & + (h(i,j,k)*(1.0 + damp) + (wpb - wm)) + enddo + eb(i,j,k) = eb(i,j,k) + wpb + ea(i,j,k) = ea(i,j,k) - wm + h(i,j,k) = h(i,j,k) + (wb - w) + wb = w + wpb = w - wm + enddo + + endif ! end BULKMIXEDLAYER + enddo ! end of c loop + + if (associated(CS%diag)) then ; if (query_averaging_enabled(CS%diag)) then + if (CS%id_w_sponge > 0) then + Idt = 1.0 / dt + do k=1,nz+1 ; do j=js,je ; do i=is,ie + w_int(i,j,K) = w_int(i,j,K) * Idt ! Scale values by clobbering array since it is local + enddo ; enddo ; enddo + call post_data(CS%id_w_sponge, w_int(:,:,:), CS%diag) + endif + endif ; endif + +end subroutine apply_sponge + +!> This call deallocates any memory in the sponge control structure. +subroutine sponge_end(CS) + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module + !! that is set by a previous call to initialize_sponge. + integer :: m + + if (.not.associated(CS)) return + + if (associated(CS%col_i)) deallocate(CS%col_i) + if (associated(CS%col_j)) deallocate(CS%col_j) + + if (associated(CS%Iresttime_col)) deallocate(CS%Iresttime_col) + if (associated(CS%Rcv_ml_ref)) deallocate(CS%Rcv_ml_ref) + if (associated(CS%Ref_eta)) deallocate(CS%Ref_eta) + + if (associated(CS%Iresttime_im)) deallocate(CS%Iresttime_im) + if (associated(CS%Rcv_ml_ref_im)) deallocate(CS%Rcv_ml_ref_im) + if (associated(CS%Ref_eta_im)) deallocate(CS%Ref_eta_im) + + do m=1,CS%fldno + if (associated(CS%Ref_val(CS%fldno)%p)) deallocate(CS%Ref_val(CS%fldno)%p) + if (associated(CS%Ref_val_im(CS%fldno)%p)) & + deallocate(CS%Ref_val_im(CS%fldno)%p) + enddo + + deallocate(CS) + +end subroutine sponge_end + +!> \namespace mom_sponge +!! +!! By Robert Hallberg, March 1999-June 2000 +!! +!! This program contains the subroutines that implement sponge +!! regions, in which the stratification and water mass properties +!! are damped toward some profiles. There are three externally +!! callable subroutines in this file. +!! +!! initialize_sponge determines the mapping from the model +!! variables into the arrays of damped columns. This remapping is +!! done for efficiency and to conserve memory. Only columns which +!! have positive inverse damping times and which are deeper than a +!! supplied depth are placed in sponges. The inverse damping +!! time is also stored in this subroutine, and memory is allocated +!! for all of the reference profiles which will subsequently be +!! provided through calls to set_up_sponge_field. The first two +!! arguments are a two-dimensional array containing the damping +!! rates, and the interface heights to damp towards. +!! +!! set_up_sponge_field is called to provide a reference profile +!! and the location of the field that will be damped back toward +!! that reference profile. A third argument, the number of layers +!! in the field is also provided, but this should always be nz. +!! +!! Apply_sponge damps all of the fields that have been registered +!! with set_up_sponge_field toward their reference profiles. The +!! four arguments are the thickness to be damped, the amount of time +!! over which the damping occurs, and arrays to which the movement +!! of fluid into a layer from above and below will be added. The +!! effect on momentum of the sponge may be accounted for later using +!! the movement of water recorded in these later arrays. + +end module MOM_sponge diff --git a/parameterizations/vertical/MOM_tidal_mixing.F90 b/parameterizations/vertical/MOM_tidal_mixing.F90 new file mode 100644 index 0000000000..31f90cdcb1 --- /dev/null +++ b/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -0,0 +1,1725 @@ +!> Interface to vertical tidal mixing schemes including CVMix tidal mixing. +module MOM_tidal_mixing + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field +use MOM_diag_mediator, only : safe_alloc_ptr, post_data +use MOM_debugging, only : hchksum +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : slasher, MOM_read_data, field_size +use MOM_io, only : read_netCDF_data +use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_string_functions, only : uppercase, lowercase +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, p3d +use MOM_verticalGrid, only : verticalGrid_type +use CVMix_tidal, only : CVMix_init_tidal, CVMix_compute_Simmons_invariant +use CVMix_tidal, only : CVMix_coeffs_tidal, CVMix_tidal_params_type +use CVMix_tidal, only : CVMix_compute_Schmittner_invariant, CVMix_compute_SchmittnerCoeff +use CVMix_tidal, only : CVMix_coeffs_tidal_schmittner +use CVMix_kinds_and_types, only : CVMix_global_params_type +use CVMix_put_get, only : CVMix_put + +implicit none ; private + +#include + +public tidal_mixing_init +public setup_tidal_diagnostics +public calculate_tidal_mixing +public post_tidal_diagnostics +public tidal_mixing_h_amp +public tidal_mixing_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Containers for tidal mixing diagnostics +type, public :: tidal_mixing_diags ; private + real, allocatable :: Kd_itidal(:,:,:) !< internal tide diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, allocatable :: Fl_itidal(:,:,:) !< vertical flux of tidal turbulent dissipation + !! [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable :: Kd_Niku(:,:,:) !< lee-wave diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, allocatable :: Kd_Niku_work(:,:,:) !< layer integrated work by lee-wave driven mixing [R Z3 T-3 ~> W m-2] + real, allocatable :: Kd_Itidal_Work(:,:,:) !< layer integrated work by int tide driven mixing [R Z3 T-3 ~> W m-2] + real, allocatable :: Kd_Lowmode_Work(:,:,:) !< layer integrated work by low mode driven mixing [R Z3 T-3 ~> W m-2] + real, allocatable :: N2_int(:,:,:) !< Buoyancy frequency squared at interfaces [T-2 ~> s-2] + real, allocatable :: vert_dep_3d(:,:,:) !< The 3-d mixing energy deposition vertical fraction [nondim]? + real, allocatable :: Schmittner_coeff_3d(:,:,:) !< The coefficient in the Schmittner et al mixing scheme [nondim] + real, allocatable :: tidal_qe_md(:,:,:) !< Input tidal energy dissipated locally, + !! interpolated to model vertical coordinate [R Z3 T-3 ~> W m-2] + real, allocatable :: Kd_lowmode(:,:,:) !< internal tide diffusivity at interfaces + !! due to propagating low modes [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, allocatable :: Fl_lowmode(:,:,:) !< vertical flux of tidal turbulent + !! dissipation due to propagating low modes [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable :: TKE_itidal_used(:,:) !< internal tide TKE input at ocean bottom [R Z3 T-3 ~> W m-2] + real, allocatable :: N2_bot(:,:) !< bottom squared buoyancy frequency [T-2 ~> s-2] + real, allocatable :: N2_meanz(:,:) !< vertically averaged buoyancy frequency [T-2 ~> s-2] + real, allocatable :: Polzin_decay_scale_scaled(:,:) !< Vertical scale of decay for tidal dissipation [Z ~> m] + real, allocatable :: Polzin_decay_scale(:,:) !< Vertical decay scale for tidal dissipation with Polzin [Z ~> m] + real, allocatable :: Simmons_coeff_2d(:,:) !< The Simmons et al mixing coefficient [nondim] +end type + +!> Control structure with parameters for the tidal mixing module. +type, public :: tidal_mixing_cs ; private + logical :: debug = .true. !< If true, do more extensive debugging checks. This is hard-coded. + + ! Parameters + logical :: int_tide_dissipation = .false. !< Internal tide conversion (from barotropic) + !! with the schemes of St Laurent et al (2002) & Simmons et al (2004) + + integer :: Int_tide_profile !< A coded integer indicating the vertical profile + !! for dissipation of the internal waves. Schemes that are + !! currently encoded are St Laurent et al (2002) and Polzin (2009). + logical :: Lee_wave_dissipation = .false. !< Enable lee-wave driven mixing, following + !! Nikurashin (2010), with a vertical energy + !! deposition profile specified by Lee_wave_profile to be + !! St Laurent et al (2002) or Simmons et al (2004) scheme + + integer :: Lee_wave_profile !< A coded integer indicating the vertical profile + !! for dissipation of the lee waves. Schemes that are + !! currently encoded are St Laurent et al (2002) and + !! Polzin (2009). + real :: Int_tide_decay_scale !< decay scale for internal wave TKE [Z ~> m] + + real :: Mu_itides !< efficiency for conversion of dissipation + !! to potential energy [nondim] + + real :: Gamma_itides !< fraction of local dissipation [nondim] + + real :: Gamma_lee !< fraction of local dissipation for lee waves + !! (Nikurashin's energy input) [nondim] + real :: Decay_scale_factor_lee !< Scaling factor for the decay scale of lee + !! wave energy dissipation [nondim] + + real :: min_zbot_itides !< minimum depth for internal tide conversion [Z ~> m]. + logical :: Lowmode_itidal_dissipation = .false. !< If true, consider mixing due to breaking low + !! modes that have been remotely generated using an internal tidal + !! dissipation scheme to specify the vertical profile of the energy + !! input to drive diapycnal mixing, along the lines of St. Laurent + !! et al. (2002) and Simmons et al. (2004). + + real :: Nu_Polzin !< The non-dimensional constant used in Polzin form of + !! the vertical scale of decay of tidal dissipation [nondim] + + real :: Nbotref_Polzin !< Reference value for the buoyancy frequency at the + !! ocean bottom used in Polzin formulation of the + !! vertical scale of decay of tidal dissipation [T-1 ~> s-1] + real :: Polzin_decay_scale_factor !< Scaling factor for the decay length scale + !! of the tidal dissipation profile in Polzin [nondim] + real :: Polzin_decay_scale_max_factor !< The decay length scale of tidal dissipation + !! profile in Polzin formulation should not exceed + !! Polzin_decay_scale_max_factor * depth of the ocean [nondim]. + real :: Polzin_min_decay_scale !< minimum decay scale of the tidal dissipation + !! profile in Polzin formulation [Z ~> m] + + real :: TKE_itide_max !< maximum internal tide conversion [R Z3 T-3 ~> W m-2] + !! available to mix above the BBL + + real :: utide !< constant tidal amplitude [Z T-1 ~> m s-1] if READ_TIDEAMP is false. + real :: kappa_itides !< topographic wavenumber and non-dimensional scaling [Z-1 ~> m-1]. + real :: kappa_h2_factor !< factor for the product of wavenumber * rms sgs height [nondim] + character(len=200) :: inputdir !< The directory in which to find input files + + logical :: use_CVMix_tidal = .false. !< true if CVMix is to be used for determining + !! diffusivity due to tidal mixing + + real :: min_thickness !< Minimum thickness allowed [Z ~> m] + + ! CVMix-specific parameters + integer :: CVMix_tidal_scheme = -1 !< 1 for Simmons, 2 for Schmittner + type(CVMix_tidal_params_type) :: CVMix_tidal_params !< A CVMix-specific type with parameters for tidal mixing + type(CVMix_global_params_type) :: CVMix_glb_params !< CVMix-specific for Prandtl number only + real :: tidal_max_coef !< CVMix-specific maximum allowable tidal + !! diffusivity. [Z2 T-1 ~> m2 s-1] + real :: tidal_diss_lim_tc !< CVMix-specific dissipation limit depth for + !! tidal-energy-constituent data [Z ~> m]. + type(remapping_CS) :: remap_CS !< The control structure for remapping + integer :: remap_answer_date !< The vintage of the order of arithmetic and expressions to use + !! for remapping. Values below 20190101 recover the remapping + !! answers from 2018, while higher values use more robust + !! forms of the same remapping expressions. + integer :: tidal_answer_date !< The vintage of the order of arithmetic and expressions in the tidal + !! mixing calculations. Values below 20190101 recover the answers + !! from the end of 2018, while higher values use updated and more robust + !! forms of the same expressions. + + type(int_tide_CS), pointer :: int_tide_CSp=> NULL() !< Control structure for a child module + + ! Data containers + real, allocatable :: TKE_Niku(:,:) !< Lee wave driven Turbulent Kinetic Energy input + !! [R Z3 T-3 ~> W m-2] + real, allocatable :: TKE_itidal(:,:) !< The internal Turbulent Kinetic Energy input divided by + !! the bottom stratification and in non-Boussinesq mode by + !! the near-bottom density [R Z4 H-1 T-2 ~> J m-2 or J m kg-1] + real, allocatable :: Nb(:,:) !< The near bottom buoyancy frequency [T-1 ~> s-1]. + real, allocatable :: mask_itidal(:,:) !< A mask of where internal tide energy is input [nondim] + real, allocatable :: h2(:,:) !< Squared bottom depth variance [Z2 ~> m2]. + real, allocatable :: tideamp(:,:) !< RMS tidal amplitude [Z T-1 ~> m s-1] + real, allocatable :: h_src(:) !< tidal constituent input layer thickness [m] + real, allocatable :: tidal_qe_2d(:,:) !< Tidal energy input times the local dissipation + !! fraction, q*E(x,y), with the CVMix implementation + !! of Jayne et al tidal mixing [R Z3 T-3 ~> W m-2]. + !! TODO: make this E(x,y) only + real, allocatable :: tidal_qe_3d_in(:,:,:) !< q*E(x,y,z) with the Schmittner parameterization [R Z3 T-3 ~> W m-2] + + + ! Diagnostics + type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostic output timing + type(tidal_mixing_diags) :: dd !< Tidal mixing diagnostic arrays + + !>@{ Diagnostic identifiers + integer :: id_TKE_itidal = -1 + integer :: id_TKE_leewave = -1 + integer :: id_Kd_itidal = -1 + integer :: id_Kd_Niku = -1 + integer :: id_Kd_lowmode = -1 + integer :: id_Kd_Itidal_Work = -1 + integer :: id_Kd_Niku_Work = -1 + integer :: id_Kd_Lowmode_Work = -1 + integer :: id_Nb = -1 + integer :: id_N2_bot = -1 + integer :: id_N2_meanz = -1 + integer :: id_Fl_itidal = -1 + integer :: id_Fl_lowmode = -1 + integer :: id_Polzin_decay_scale = -1 + integer :: id_Polzin_decay_scale_scaled = -1 + integer :: id_N2_int = -1 + integer :: id_Simmons_coeff = -1 + integer :: id_Schmittner_coeff = -1 + integer :: id_tidal_qe_md = -1 + integer :: id_vert_dep = -1 + !>@} + +end type tidal_mixing_cs + +!>@{ Coded parmameters for specifying mixing schemes +character*(20), parameter :: STLAURENT_PROFILE_STRING = "STLAURENT_02" +character*(20), parameter :: POLZIN_PROFILE_STRING = "POLZIN_09" +integer, parameter :: STLAURENT_02 = 1 +integer, parameter :: POLZIN_09 = 2 +character*(20), parameter :: SIMMONS_SCHEME_STRING = "SIMMONS" +character*(20), parameter :: SCHMITTNER_SCHEME_STRING = "SCHMITTNER" +integer, parameter :: SIMMONS = 1 +integer, parameter :: SCHMITTNER = 2 +!>@} + +contains + +!> Initializes internal tidal dissipation scheme for diapycnal mixing +logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, diag, CS) + type(time_type), intent(in) :: Time !< The current time. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle + type(int_tide_CS), pointer :: int_tide_CSp !< A pointer to the internal tides control structure + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. + type(tidal_mixing_cs), intent(inout) :: CS !< This module's control structure. + + ! Local variables + logical :: use_CVMix_tidal + logical :: int_tide_dissipation + logical :: read_tideamp + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + character(len=20) :: tmpstr, int_tide_profile_str + character(len=20) :: CVMix_tidal_scheme_str, tidal_energy_type + character(len=200) :: filename, h2_file, Niku_TKE_input_file ! Input file names + character(len=200) :: tideamp_file ! Input file names or paths + character(len=80) :: tideamp_var, rough_var, TKE_input_var ! Input file variable names + real :: hamp ! The magnitude of the sub-gridscale bottom depth variance [Z ~> m] + real :: utide ! The RMS tidal amplitude [Z T-1 ~> m s-1] + real :: max_frac_rough ! A limit on the depth variance as a fraction of the total depth [nondim] + real :: prandtl_tidal ! Prandtl number used by CVMix tidal mixing schemes to convert vertical + ! diffusivities into viscosities [nondim] + real :: Niku_scale ! local variable for scaling the Nikurashin TKE flux data [nondim] + integer :: i, j, is, ie, js, je + integer :: isd, ied, jsd, jed + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_tidal_mixing" !< This module's name. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + ! Read parameters + ! NOTE: These are read twice because logfile output is streamed and we want + ! to preserve the ordering of module header before parameters. + call get_param(param_file, mdl, "USE_CVMix_TIDAL", use_CVMix_tidal, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", int_tide_dissipation, & + default=use_CVMix_tidal, do_not_log=.true.) + call log_version(param_file, mdl, version, & + "Vertical Tidal Mixing Parameterization", & + all_default=.not.(use_CVMix_tidal .or. int_tide_dissipation)) + + call get_param(param_file, mdl, "USE_CVMix_TIDAL", use_CVMix_tidal, & + "If true, turns on tidal mixing via CVMix", & + default=.false.) + call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", int_tide_dissipation, & + "If true, use an internal tidal dissipation scheme to "//& + "drive diapycnal mixing, along the lines of St. Laurent "//& + "et al. (2002) and Simmons et al. (2004).", default=use_CVMix_tidal) + + ! return if tidal mixing is inactive + tidal_mixing_init = int_tide_dissipation + if (.not. tidal_mixing_init) return + + CS%debug = CS%debug.and.is_root_pe() + CS%diag => diag + if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp + CS%use_CVmix_tidal = use_CVmix_tidal + CS%int_tide_dissipation = int_tide_dissipation + + call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".",do_not_log=.true.) + CS%inputdir = slasher(CS%inputdir) + + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "TIDAL_MIXING_ANSWER_DATE", CS%tidal_answer_date, & + "The vintage of the order of arithmetic and expressions in the tidal mixing "//& + "calculations. Values below 20190101 recover the answers from the end of 2018, "//& + "while higher values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%tidal_answer_date = max(CS%tidal_answer_date, 20230701) + + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) + + if (CS%int_tide_dissipation) then + + ! Read in CVMix tidal scheme if CVMix tidal mixing is on + if (CS%use_CVMix_tidal) then + call get_param(param_file, mdl, "CVMIX_TIDAL_SCHEME", CVMix_tidal_scheme_str, & + "CVMIX_TIDAL_SCHEME selects the CVMix tidal mixing "//& + "scheme with INT_TIDE_DISSIPATION. Valid values are:\n"//& + "\t SIMMONS - Use the Simmons et al (2004) tidal \n"//& + "\t mixing scheme.\n"//& + "\t SCHMITTNER - Use the Schmittner et al (2014) tidal \n"//& + "\t mixing scheme.", & + default=SIMMONS_SCHEME_STRING) + CVMix_tidal_scheme_str = uppercase(CVMix_tidal_scheme_str) + + select case (CVMix_tidal_scheme_str) + case (SIMMONS_SCHEME_STRING) ; CS%CVMix_tidal_scheme = SIMMONS + case (SCHMITTNER_SCHEME_STRING) ; CS%CVMix_tidal_scheme = SCHMITTNER + case default + call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & + "#define CVMIX_TIDAL_SCHEME "//trim(CVMix_tidal_scheme_str)//" found in input file.") + end select + endif ! CS%use_CVMix_tidal + + ! Read in vertical profile of tidal energy dissipation + if ( CS%CVMix_tidal_scheme == SCHMITTNER .or. .not. CS%use_CVMix_tidal) then + call get_param(param_file, mdl, "INT_TIDE_PROFILE", int_tide_profile_str, & + "INT_TIDE_PROFILE selects the vertical profile of energy "//& + "dissipation with INT_TIDE_DISSIPATION. Valid values are:\n"//& + "\t STLAURENT_02 - Use the St. Laurent et al exponential \n"//& + "\t decay profile.\n"//& + "\t POLZIN_09 - Use the Polzin WKB-stretched algebraic \n"//& + "\t decay profile.", & + default=STLAURENT_PROFILE_STRING) + int_tide_profile_str = uppercase(int_tide_profile_str) + + select case (int_tide_profile_str) + case (STLAURENT_PROFILE_STRING) ; CS%int_tide_profile = STLAURENT_02 + case (POLZIN_PROFILE_STRING) ; CS%int_tide_profile = POLZIN_09 + case default + call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & + "#define INT_TIDE_PROFILE "//trim(int_tide_profile_str)//" found in input file.") + end select + endif + + elseif (CS%use_CVMix_tidal) then + call MOM_error(FATAL, "tidal_mixing_init: Cannot set INT_TIDE_DISSIPATION to False "// & + "when USE_CVMix_TIDAL is set to True.") + endif + + call get_param(param_file, mdl, "LEE_WAVE_DISSIPATION", CS%Lee_wave_dissipation, & + "If true, use an lee wave driven dissipation scheme to "//& + "drive diapycnal mixing, along the lines of Nikurashin "//& + "(2010) and using the St. Laurent et al. (2002) "//& + "and Simmons et al. (2004) vertical profile", default=.false.) + if (CS%lee_wave_dissipation) then + if (CS%use_CVMix_tidal) then + call MOM_error(FATAL, "tidal_mixing_init: Lee wave driven dissipation scheme cannot "// & + "be used when CVMix tidal mixing scheme is active.") + endif + call get_param(param_file, mdl, "LEE_WAVE_PROFILE", tmpstr, & + "LEE_WAVE_PROFILE selects the vertical profile of energy "//& + "dissipation with LEE_WAVE_DISSIPATION. Valid values are:\n"//& + "\t STLAURENT_02 - Use the St. Laurent et al exponential \n"//& + "\t decay profile.\n"//& + "\t POLZIN_09 - Use the Polzin WKB-stretched algebraic \n"//& + "\t decay profile.", & + default=STLAURENT_PROFILE_STRING) + tmpstr = uppercase(tmpstr) + select case (tmpstr) + case (STLAURENT_PROFILE_STRING) ; CS%lee_wave_profile = STLAURENT_02 + case (POLZIN_PROFILE_STRING) ; CS%lee_wave_profile = POLZIN_09 + case default + call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & + "#define LEE_WAVE_PROFILE "//trim(tmpstr)//" found in input file.") + end select + endif + + call get_param(param_file, mdl, "INT_TIDE_LOWMODE_DISSIPATION", CS%Lowmode_itidal_dissipation, & + "If true, consider mixing due to breaking low modes that "//& + "have been remotely generated; as with itidal drag on the "//& + "barotropic tide, use an internal tidal dissipation scheme to "//& + "drive diapycnal mixing, along the lines of St. Laurent "//& + "et al. (2002) and Simmons et al. (2004).", default=.false.) + + if ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09)) .or. & + (CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09))) then + if (CS%use_CVMix_tidal) then + call MOM_error(FATAL, "tidal_mixing_init: Polzin scheme cannot "// & + "be used when CVMix tidal mixing scheme is active.") + endif + call get_param(param_file, mdl, "NU_POLZIN", CS%Nu_Polzin, & + "When the Polzin decay profile is used, this is a "//& + "non-dimensional constant in the expression for the "//& + "vertical scale of decay for the tidal energy dissipation.", & + units="nondim", default=0.0697) + call get_param(param_file, mdl, "NBOTREF_POLZIN", CS%Nbotref_Polzin, & + "When the Polzin decay profile is used, this is the "//& + "reference value of the buoyancy frequency at the ocean "//& + "bottom in the Polzin formulation for the vertical "//& + "scale of decay for the tidal energy dissipation.", & + units="s-1", default=9.61e-4, scale=US%T_to_s) + call get_param(param_file, mdl, "POLZIN_DECAY_SCALE_FACTOR", & + CS%Polzin_decay_scale_factor, & + "When the Polzin decay profile is used, this is a "//& + "scale factor for the vertical scale of decay of the tidal "//& + "energy dissipation.", default=1.0, units="nondim") + call get_param(param_file, mdl, "POLZIN_SCALE_MAX_FACTOR", & + CS%Polzin_decay_scale_max_factor, & + "When the Polzin decay profile is used, this is a factor "//& + "to limit the vertical scale of decay of the tidal "//& + "energy dissipation to POLZIN_DECAY_SCALE_MAX_FACTOR "//& + "times the depth of the ocean.", units="nondim", default=1.0) + call get_param(param_file, mdl, "POLZIN_MIN_DECAY_SCALE", CS%Polzin_min_decay_scale, & + "When the Polzin decay profile is used, this is the "//& + "minimum vertical decay scale for the vertical profile\n"//& + "of internal tide dissipation with the Polzin (2009) formulation", & + units="m", default=0.0, scale=US%m_to_Z) + endif + + if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation) then + call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE", CS%Int_tide_decay_scale, & + "The decay scale away from the bottom for tidal TKE with "//& + "the new coding when INT_TIDE_DISSIPATION is used.", & + units="m", default=500.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "MU_ITIDES", CS%Mu_itides, & + "A dimensionless turbulent mixing efficiency used with "//& + "INT_TIDE_DISSIPATION, often 0.2.", units="nondim", default=0.2) + call get_param(param_file, mdl, "GAMMA_ITIDES", CS%Gamma_itides, & + "The fraction of the internal tidal energy that is "//& + "dissipated locally with INT_TIDE_DISSIPATION. "//& + "THIS NAME COULD BE BETTER.", & + units="nondim", default=0.3333) + call get_param(param_file, mdl, "MIN_ZBOT_ITIDES", CS%min_zbot_itides, & + "Turn off internal tidal dissipation when the total "//& + "ocean depth is less than this value.", units="m", default=0.0, scale=US%m_to_Z) + endif + + if ( (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation) .and. & + .not. CS%use_CVMix_tidal) then + + allocate(CS%Nb(isd:ied,jsd:jed), source=0.) + allocate(CS%h2(isd:ied,jsd:jed), source=0.) + allocate(CS%TKE_itidal(isd:ied,jsd:jed), source=0.) + allocate(CS%mask_itidal(isd:ied,jsd:jed), source=1.) + + call get_param(param_file, mdl, "KAPPA_ITIDES", CS%kappa_itides, & + "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& + "The default is 2pi/10 km, as in St.Laurent et al. 2002.", & + units="m-1", default=8.e-4*atan(1.0), scale=US%Z_to_m) + + call get_param(param_file, mdl, "UTIDE", CS%utide, & + "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & + units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) + allocate(CS%tideamp(is:ie,js:je), source=CS%utide) + + call get_param(param_file, mdl, "KAPPA_H2_FACTOR", CS%kappa_h2_factor, & + "A scaling factor for the roughness amplitude with "//& + "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) + call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & + "The maximum internal tide energy source available to mix "//& + "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & + units="W m-2", default=1.0e3, scale=US%W_m2_to_RZ3_T3) + + call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & + "If true, read a file (given by TIDEAMP_FILE) containing "//& + "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) + if (read_tideamp) then + if (CS%use_CVMix_tidal) then + call MOM_error(FATAL, "tidal_mixing_init: Tidal amplitude files are "// & + "not compatible with CVMix tidal mixing. ") + endif + call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & + "The path to the file containing the spatially varying "//& + "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") + filename = trim(CS%inputdir) // trim(tideamp_file) + call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) + call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & + "The name of the tidal amplitude variable in the input file.", & + default="tideamp") + ! NOTE: There are certain cases where FMS is unable to read this file, so + ! we use read_netCDF_data in place of MOM_read_data. + call read_netCDF_data(filename, tideamp_var, CS%tideamp, G%domain, & + rescale=US%m_to_Z*US%T_to_s) + endif + + call get_param(param_file, mdl, "H2_FILE", h2_file, & + "The path to the file containing the sub-grid-scale "//& + "topographic roughness amplitude with INT_TIDE_DISSIPATION.", & + fail_if_missing=(.not.CS%use_CVMix_tidal)) + filename = trim(CS%inputdir) // trim(h2_file) + call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) + call get_param(param_file, mdl, "ROUGHNESS_VARNAME", rough_var, & + "The name in the input file of the squared sub-grid-scale "//& + "topographic roughness amplitude variable.", default="h2") + ! NOTE: There are certain cases where FMS is unable to read this file, so + ! we use read_netCDF_data in place of MOM_read_data. + call read_netCDF_data(filename, rough_var, CS%h2, G%domain, & + rescale=US%m_to_Z**2) + + call get_param(param_file, mdl, "FRACTIONAL_ROUGHNESS_MAX", max_frac_rough, & + "The maximum topographic roughness amplitude as a fraction of the mean depth, "//& + "or a negative value for no limitations on roughness.", & + units="nondim", default=0.1) + + do j=js,je ; do i=is,ie + if (G%bathyT(i,j)+G%Z_ref < CS%min_zbot_itides) CS%mask_itidal(i,j) = 0.0 + CS%tideamp(i,j) = CS%tideamp(i,j) * CS%mask_itidal(i,j) * G%mask2dT(i,j) + + ! Restrict rms topo to a fraction (often 10 percent) of the column depth. + if ((CS%tidal_answer_date < 20190101) .and. (max_frac_rough >= 0.0)) then + hamp = min(max_frac_rough*(G%bathyT(i,j)+G%Z_ref), sqrt(CS%h2(i,j))) + CS%h2(i,j) = hamp*hamp + else + if (max_frac_rough >= 0.0) & + CS%h2(i,j) = min((max_frac_rough*(G%bathyT(i,j)+G%Z_ref))**2, CS%h2(i,j)) + endif + + utide = CS%tideamp(i,j) + ! Compute the fixed part of internal tidal forcing. + ! The units here are [R Z4 H-1 T-2 ~> J m-2 or m3 s-2] here. (Note that J m-2 = kg s-2.) + CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * GV%H_to_RZ * & + CS%kappa_itides * CS%h2(i,j) * utide*utide + enddo ; enddo + + endif + + if (CS%Lee_wave_dissipation) then + + call get_param(param_file, mdl, "NIKURASHIN_TKE_INPUT_FILE", Niku_TKE_input_file, & + "The path to the file containing the TKE input from lee "//& + "wave driven mixing. Used with LEE_WAVE_DISSIPATION.", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "NIKURASHIN_SCALE", Niku_scale, & + "A non-dimensional factor by which to scale the lee-wave "//& + "driven TKE input. Used with LEE_WAVE_DISSIPATION.", & + units="nondim", default=1.0) + + filename = trim(CS%inputdir) // trim(Niku_TKE_input_file) + call log_param(param_file, mdl, "INPUTDIR/NIKURASHIN_TKE_INPUT_FILE", filename) + call get_param(param_file, mdl, "TKE_INPUT_VAR", TKE_input_var, & + "The name in the input file of the turbulent kinetic energy input variable.", & + default="TKE_input") + allocate(CS%TKE_Niku(is:ie,js:je), source=0.) + + call MOM_read_data(filename, TKE_input_var, CS%TKE_Niku, G%domain, timelevel=1, & ! ??? timelevel -aja + scale=Niku_scale*US%W_m2_to_RZ3_T3) + + call get_param(param_file, mdl, "GAMMA_NIKURASHIN",CS%Gamma_lee, & + "The fraction of the lee wave energy that is dissipated "//& + "locally with LEE_WAVE_DISSIPATION.", units="nondim", default=0.3333) + call get_param(param_file, mdl, "DECAY_SCALE_FACTOR_LEE",CS%Decay_scale_factor_lee, & + "Scaling for the vertical decay scale of the local "//& + "dissipation of lee wave dissipation.", units="nondim", default=1.0) + else + CS%Decay_scale_factor_lee = -9.e99 ! This should never be used if CS%Lee_wave_dissipation = False + endif + + ! Configure CVMix + if (CS%use_CVMix_tidal) then + + ! Read in CVMix params + !call openParameterBlock(param_file,'CVMix_TIDAL') + call get_param(param_file, mdl, "TIDAL_MAX_COEF", CS%tidal_max_coef, & + "largest acceptable value for tidal diffusivity", & + units="m^2/s", default=50e-4, scale=US%m2_s_to_Z2_T) ! the default is 50e-4 in CVMix, 100e-4 in POP. + call get_param(param_file, mdl, "TIDAL_DISS_LIM_TC", CS%tidal_diss_lim_tc, & + "Min allowable depth for dissipation for tidal-energy-constituent data. "//& + "No dissipation contribution is applied above TIDAL_DISS_LIM_TC.", & + units="m", default=0.0, scale=US%m_to_Z) + call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, & + units="m", default=0.001, scale=US%m_to_Z, do_not_log=.True.) + call get_param(param_file, mdl, "PRANDTL_TIDAL", prandtl_tidal, & + "Prandtl number used by CVMix tidal mixing schemes "//& + "to convert vertical diffusivities into viscosities.", & + units="nondim", default=1.0, do_not_log=.true.) + call CVMix_put(CS%CVMix_glb_params, 'Prandtl', prandtl_tidal) + + call get_param(param_file, mdl, "TIDAL_ENERGY_TYPE",tidal_energy_type, & + "The type of input tidal energy flux dataset. Valid values are"//& + "\t Jayne\n"//& + "\t ER03 \n",& + fail_if_missing=.true.) + ! Check whether tidal energy input format and CVMix tidal mixing scheme are consistent + if ( .not. ( & + (uppercase(tidal_energy_type(1:4)) == 'JAYN' .and. CS%CVMix_tidal_scheme == SIMMONS).or. & + (uppercase(tidal_energy_type(1:4)) == 'ER03' .and. CS%CVMix_tidal_scheme == SCHMITTNER) ) )then + call MOM_error(FATAL, "tidal_mixing_init: Tidal energy file type ("//& + trim(tidal_energy_type)//") is incompatible with CVMix tidal "//& + " mixing scheme: "//trim(CVMix_tidal_scheme_str) ) + endif + CVMix_tidal_scheme_str = lowercase(CVMix_tidal_scheme_str) + + ! Set up CVMix + call CVMix_init_tidal(CVmix_tidal_params_user = CS%CVMix_tidal_params, & + mix_scheme = CVMix_tidal_scheme_str, & + efficiency = CS%Mu_itides, & + vertical_decay_scale = CS%int_tide_decay_scale*US%Z_to_m, & + max_coefficient = CS%tidal_max_coef*US%Z2_T_to_m2_s, & + local_mixing_frac = CS%Gamma_itides, & + depth_cutoff = CS%min_zbot_itides*US%Z_to_m) + + call read_tidal_energy(G, US, tidal_energy_type, param_file, CS) + + !call closeParameterBlock(param_file) + + endif ! CVMix on + + ! Register Diagnostics fields + + if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. & + CS%Lowmode_itidal_dissipation) then + + CS%id_Kd_itidal = register_diag_field('ocean_model','Kd_itides',diag%axesTi,Time, & + 'Internal Tide Driven Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + + if (CS%use_CVMix_tidal) then + CS%id_N2_int = register_diag_field('ocean_model','N2_int',diag%axesTi,Time, & + 'Bouyancy frequency squared, at interfaces', 's-2', conversion=US%s_to_T**2) + !> TODO: add units + if (CS%CVMix_tidal_scheme .eq. SIMMONS) then + CS%id_Simmons_coeff = register_diag_field('ocean_model','Simmons_coeff',diag%axesT1,Time, & + 'time-invariant portion of the tidal mixing coefficient using the Simmons', '') + else if (CS%CVMix_tidal_scheme .eq. SCHMITTNER) then + CS%id_Schmittner_coeff = register_diag_field('ocean_model','Schmittner_coeff',diag%axesTL,Time, & + 'time-invariant portion of the tidal mixing coefficient using the Schmittner', '') + CS%id_tidal_qe_md = register_diag_field('ocean_model','tidal_qe_md',diag%axesTL,Time, & + 'input tidal energy dissipated locally interpolated to model vertical coordinates', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + endif + CS%id_vert_dep = register_diag_field('ocean_model','vert_dep',diag%axesTi,Time, & + 'vertical deposition function needed for Simmons et al tidal mixing', '') + else + CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal',diag%axesT1,Time, & + 'Internal Tide Driven Turbulent Kinetic Energy', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_Nb = register_diag_field('ocean_model','Nb',diag%axesT1,Time, & + 'Bottom Buoyancy Frequency', 's-1', conversion=US%s_to_T) + + CS%id_Kd_lowmode = register_diag_field('ocean_model','Kd_lowmode',diag%axesTi,Time, & + 'Internal Tide Driven Diffusivity (from propagating low modes)', & + 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + + CS%id_Fl_itidal = register_diag_field('ocean_model','Fl_itides',diag%axesTi,Time, & + 'Vertical flux of tidal turbulent dissipation', & + 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) + + CS%id_Fl_lowmode = register_diag_field('ocean_model','Fl_lowmode',diag%axesTi,Time, & + 'Vertical flux of tidal turbulent dissipation (from propagating low modes)', & + 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) + + CS%id_Polzin_decay_scale = register_diag_field('ocean_model','Polzin_decay_scale', diag%axesT1, Time, & + 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme', & + units='m', conversion=US%Z_to_m) + + CS%id_Polzin_decay_scale_scaled = register_diag_field('ocean_model', & + 'Polzin_decay_scale_scaled', diag%axesT1, Time, & + 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme, '// & + 'scaled by N2_bot/N2_meanz', units='m', conversion=US%Z_to_m) + + CS%id_N2_bot = register_diag_field('ocean_model','N2_b',diag%axesT1,Time, & + 'Bottom Buoyancy frequency squared', 's-2', conversion=US%s_to_T**2) + + CS%id_N2_meanz = register_diag_field('ocean_model','N2_meanz', diag%axesT1, Time, & + 'Buoyancy frequency squared averaged over the water column', 's-2', conversion=US%s_to_T**2) + + CS%id_Kd_Itidal_Work = register_diag_field('ocean_model','Kd_Itidal_Work',diag%axesTL,Time, & + 'Work done by Internal Tide Diapycnal Mixing', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + + CS%id_Kd_Niku_Work = register_diag_field('ocean_model','Kd_Nikurashin_Work',diag%axesTL,Time, & + 'Work done by Nikurashin Lee Wave Drag Scheme', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + + CS%id_Kd_Lowmode_Work = register_diag_field('ocean_model','Kd_Lowmode_Work',diag%axesTL,Time, & + 'Work done by Internal Tide Diapycnal Mixing (low modes)', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + + if (CS%Lee_wave_dissipation) then + CS%id_TKE_leewave = register_diag_field('ocean_model','TKE_leewave',diag%axesT1,Time, & + 'Lee wave Driven Turbulent Kinetic Energy', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_Kd_Niku = register_diag_field('ocean_model','Kd_Nikurashin',diag%axesTi,Time, & + 'Lee Wave Driven Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + endif + endif ! S%use_CVMix_tidal + endif + +end function tidal_mixing_init + + +!> Depending on whether or not CVMix is active, calls the associated subroutine to compute internal +!! tidal dissipation and to add the effect of internal-tide-driven mixing to the layer or interface +!! diffusivities. +subroutine calculate_tidal_mixing(dz, j, N2_bot, Rho_bot, N2_lay, N2_int, TKE_to_Kd, max_TKE, & + G, GV, US, CS, Kd_max, Kv, Kd_lay, Kd_int) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] + integer, intent(in) :: j !< The j-index to work on + real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy + !! frequency [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(in) :: Rho_bot !< The near-bottom in situ density [R ~> kg m-3] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the + !! layers [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy frequency at the + !! interfaces [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE + !! dissipated within a layer and the + !! diapycnal diffusivity within that layer, + !! usually (~Rho_0 / (G_Earth * dRho_lay)) + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required for a layer to + !! entrain to its maximum realizable + !! thickness [H Z2 T-3 ~> m3 s-3 or W m-2] + type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module + real, intent(in) :: Kd_max !< The maximum increment for diapycnal + !! diffusivity due to TKE-based processes, + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + !! Set this to a negative value to have no limit. + real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(SZI_(G),SZK_(GV)), & + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZK_(GV)+1), & + optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then + if (CS%use_CVMix_tidal) then + call calculate_CVMix_tidal(dz, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) + else + call add_int_tide_diffusivity(dz, j, N2_bot, Rho_bot, N2_lay, TKE_to_Kd, max_TKE, & + G, GV, US, CS, Kd_max, Kd_lay, Kd_int) + endif + endif +end subroutine calculate_tidal_mixing + + +!> Calls the CVMix routines to compute tidal dissipation and to add the effect of internal-tide-driven +!! mixing to the interface diffusivities. +subroutine calculate_CVMix_tidal(dz, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tidal_mixing_cs), intent(inout) :: CS !< This module's control structure. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] + integer, intent(in) :: j !< The j-index to work on + real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy + !! frequency at the interfaces [T-2 ~> s-2]. + real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(SZI_(G),SZK_(GV)), & + optional, intent(inout) :: Kd_lay!< The diapycnal diffusivity in the layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), & + optional, intent(inout) :: Kd_int!< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + ! Local variables + real, dimension(SZK_(GV)+1) :: Kd_tidal ! tidal diffusivity [m2 s-1] + real, dimension(SZK_(GV)+1) :: Kv_tidal ! tidal viscosity [m2 s-1] + real, dimension(SZK_(GV)+1) :: vert_dep ! vertical deposition [nondim] + real, dimension(SZK_(GV)+1) :: iFaceHeight ! Height of interfaces [m] + real, dimension(SZK_(GV)+1) :: SchmittnerSocn ! A larger value of the Schmittner coefficint to + ! use in the Southern Ocean [nondim]. If this is smaller + ! than Schmittner_coeff, that standard value is used. + real, dimension(SZK_(GV)) :: cellHeight ! Height of cell centers [m] + real, dimension(SZK_(GV)) :: tidal_qe_md ! Tidal dissipation energy interpolated from 3d input + ! to model coordinates [R Z3 T-3 ~> W m-2] + real, dimension(SZK_(GV)+1) :: N2_int_i ! De-scaled interface buoyancy frequency [s-2] + real, dimension(SZK_(GV)) :: Schmittner_coeff ! A coefficient in the Schmittner et al (2014) mixing + ! parameterization [nondim] + real, dimension(SZK_(GV)) :: h_m ! Cell thickness [m] + real, allocatable, dimension(:,:) :: exp_hab_zetar ! A badly documented array that appears to be + ! related to the distribution of tidal mixing energy, with unusual array + ! extents that are not explained, that is set and used by the CVMix + ! tidal mixing schemes, perhaps in [m3 kg-1]? + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] + real :: Simmons_coeff ! A coefficient in the Simmons et al (2004) mixing parameterization [nondim] + + integer :: i, k, is, ie + real, parameter :: rho_fw = 1000.0 ! fresh water density [kg m-3] + ! TODO: when coupled, get this from CESM (SHR_CONST_RHOFW) + + is = G%isc ; ie = G%iec + + select case (CS%CVMix_tidal_scheme) + case (SIMMONS) + do i=is,ie + + if (G%mask2dT(i,j)<1) cycle + + iFaceHeight = 0.0 ! BBL is all relative to the surface + hcorr = 0.0 + ! Compute cell center depth and cell bottom in meters (negative values in the ocean) + do k=1,GV%ke + dh = dz(i,k) ! Nominal thickness to use for increment, in the units of heights + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh + iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh + enddo + + call CVMix_compute_Simmons_invariant( nlev = GV%ke, & + energy_flux = US%RZ3_T3_to_W_m2*CS%tidal_qe_2d(i,j), & + rho = rho_fw, & + SimmonsCoeff = Simmons_coeff, & + VertDep = vert_dep, & + zw = iFaceHeight, & + zt = cellHeight, & + CVMix_tidal_params_user = CS%CVMix_tidal_params) + + ! Since we pass tidal_qe_2d=(CS%Gamma_itides)*tidal_energy_flux_2d, and not tidal_energy_flux_2d in + ! above subroutine call, we divide Simmons_coeff by CS%Gamma_itides as a corrective step: + ! TODO: (CS%Gamma_itides)*tidal_energy_flux_2d is unnecessary, directly use tidal_energy_flux_2d + Simmons_coeff = Simmons_coeff / CS%Gamma_itides + + + ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable + do K=1,GV%ke+1 + N2_int_i(K) = US%s_to_T**2 * N2_int(i,K) + enddo + + call CVMix_coeffs_tidal( Mdiff_out = Kv_tidal, & + Tdiff_out = Kd_tidal, & + Nsqr = N2_int_i, & + OceanDepth = -iFaceHeight(GV%ke+1),& + SimmonsCoeff = Simmons_coeff, & + vert_dep = vert_dep, & + nlev = GV%ke, & + max_nlev = GV%ke, & + CVMix_params = CS%CVMix_glb_params, & + CVMix_tidal_params_user = CS%CVMix_tidal_params) + + ! Update diffusivity + if (present(Kd_lay)) then + do k=1,GV%ke + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * GV%m2_s_to_HZ_T * (Kd_tidal(k) + Kd_tidal(k+1)) + enddo + endif + if (present(Kd_int)) then + do K=1,GV%ke+1 + Kd_int(i,K) = Kd_int(i,K) + GV%m2_s_to_HZ_T * Kd_tidal(K) + enddo + endif + ! Update viscosity with the proper unit conversion. + if (associated(Kv)) then + do K=1,GV%ke+1 + Kv(i,j,K) = Kv(i,j,K) + GV%m2_s_to_HZ_T * Kv_tidal(K) ! Rescale from m2 s-1 to H Z T-1. + enddo + endif + + ! diagnostics + if (allocated(CS%dd%Kd_itidal)) then + CS%dd%Kd_itidal(i,j,:) = GV%m2_s_to_HZ_T * Kd_tidal(:) + endif + if (allocated(CS%dd%N2_int)) then + CS%dd%N2_int(i,j,:) = N2_int(i,:) + endif + if (allocated(CS%dd%Simmons_coeff_2d)) then + CS%dd%Simmons_coeff_2d(i,j) = Simmons_coeff + endif + if (allocated(CS%dd%vert_dep_3d)) then + CS%dd%vert_dep_3d(i,j,:) = vert_dep(:) + endif + + enddo ! i=is,ie + + case (SCHMITTNER) + + ! TODO: correct exp_hab_zetar shapes in CVMix_compute_Schmittner_invariant + ! and CVMix_compute_SchmittnerCoeff low subroutines + + allocate(exp_hab_zetar(GV%ke+1,GV%ke+1)) + + do i=is,ie + + if (G%mask2dT(i,j)<1) cycle + + iFaceHeight(:) = 0.0 ! BBL is all relative to the surface + hcorr = 0.0 + ! Compute heights at cell center and interfaces, and rescale layer thicknesses + do k=1,GV%ke + h_m(k) = dz(i,k)*US%Z_to_m ! Rescale thicknesses to m for use by CVmix. + dh = dz(i,k) ! Nominal thickness to use for increment, in the units of heights + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh + iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh + enddo + + SchmittnerSocn = 0.0 ! TODO: compute this + + ! form the time-invariant part of Schmittner coefficient term + call CVMix_compute_Schmittner_invariant(nlev = GV%ke, & + VertDep = vert_dep, & + efficiency = CS%Mu_itides, & + rho = rho_fw, & + exp_hab_zetar = exp_hab_zetar, & + zw = iFaceHeight, & + CVmix_tidal_params_user = CS%CVMix_tidal_params) + !TODO: in above call, there is no need to pass efficiency, since it gets + ! passed via CVMix_init_tidal and stored in CVMix_tidal_params. Change + ! CVMix API to prevent this redundancy. + + ! remap from input z coordinate to model coordinate: + tidal_qe_md(:) = 0.0 + call remapping_core_h(CS%remap_cs, size(CS%h_src), CS%h_src, CS%tidal_qe_3d_in(i,j,:), & + GV%ke, h_m, tidal_qe_md, GV%H_subroundoff, GV%H_subroundoff) + + ! form the Schmittner coefficient that is based on 3D q*E, which is formed from + ! summing q_i*TidalConstituent_i over the number of constituents. + call CVMix_compute_SchmittnerCoeff( nlev = GV%ke, & + energy_flux = US%RZ3_T3_to_W_m2*tidal_qe_md(:), & + SchmittnerCoeff = Schmittner_coeff, & + exp_hab_zetar = exp_hab_zetar, & + CVmix_tidal_params_user = CS%CVMix_tidal_params) + + ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable + do k=1,GV%ke+1 + N2_int_i(k) = US%s_to_T**2 * N2_int(i,k) + enddo + + call CVMix_coeffs_tidal_schmittner( Mdiff_out = Kv_tidal, & + Tdiff_out = Kd_tidal, & + Nsqr = N2_int_i, & + OceanDepth = -iFaceHeight(GV%ke+1), & + nlev = GV%ke, & + max_nlev = GV%ke, & + SchmittnerCoeff = Schmittner_coeff, & + SchmittnerSouthernOcean = SchmittnerSocn, & + CVmix_params = CS%CVMix_glb_params, & + CVmix_tidal_params_user = CS%CVMix_tidal_params) + + ! Update diffusivity + if (present(Kd_lay)) then + do k=1,GV%ke + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * GV%m2_s_to_HZ_T * (Kd_tidal(k) + Kd_tidal(k+1)) + enddo + endif + if (present(Kd_int)) then + do K=1,GV%ke+1 + Kd_int(i,K) = Kd_int(i,K) + (GV%m2_s_to_HZ_T * Kd_tidal(K)) + enddo + endif + + ! Update viscosity + if (associated(Kv)) then + do K=1,GV%ke+1 + Kv(i,j,K) = Kv(i,j,K) + GV%m2_s_to_HZ_T * Kv_tidal(K) ! Rescale from m2 s-1 to H Z T-1. + enddo + endif + + ! diagnostics + if (allocated(CS%dd%Kd_itidal)) then + CS%dd%Kd_itidal(i,j,:) = GV%m2_s_to_HZ_T*Kd_tidal(:) + endif + if (allocated(CS%dd%N2_int)) then + CS%dd%N2_int(i,j,:) = N2_int(i,:) + endif + if (allocated(CS%dd%Schmittner_coeff_3d)) then + CS%dd%Schmittner_coeff_3d(i,j,:) = Schmittner_coeff(:) + endif + if (allocated(CS%dd%tidal_qe_md)) then + CS%dd%tidal_qe_md(i,j,:) = tidal_qe_md(:) + endif + if (allocated(CS%dd%vert_dep_3d)) then + CS%dd%vert_dep_3d(i,j,:) = vert_dep(:) + endif + enddo ! i=is,ie + + deallocate(exp_hab_zetar) + + case default + call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & + "#define CVMIX_TIDAL_SCHEME found in input file.") + end select + +end subroutine calculate_CVMix_tidal + + +!> This subroutine adds the effect of internal-tide-driven mixing to the layer diffusivities. +!! The mechanisms considered are (1) local dissipation of internal waves generated by the +!! barotropic flow ("itidal"), (2) local dissipation of internal waves generated by the propagating +!! low modes (rays) of the internal tide ("lowmode"), and (3) local dissipation of internal lee waves. +!! Will eventually need to add diffusivity due to other wave-breaking processes (e.g. Bottom friction, +!! Froude-number-depending breaking, PSI, etc.). +subroutine add_int_tide_diffusivity(dz, j, N2_bot, Rho_bot, N2_lay, TKE_to_Kd, max_TKE, & + G, GV, US, CS, Kd_max, Kd_lay, Kd_int) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] + integer, intent(in) :: j !< The j-index to work on + real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy frequency + !! frequency [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(in) :: Rho_bot !< The near-bottom in situ density [R ~> kg m-3] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the + !! layers [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE + !! dissipated within a layer and the + !! diapycnal diffusivity within that layer, + !! usually (~Rho_0 / (G_Earth * dRho_lay)) + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required for a layer + !! to entrain to its maximum realizable + !! thickness [H Z2 T-3 ~> m3 s-3 or W m-2] + type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module + real, intent(in) :: Kd_max !< The maximum increment for diapycnal + !! diffusivity due to TKE-based processes + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + !! Set this to a negative value to have no limit. + real, dimension(SZI_(G),SZK_(GV)), & + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), & + optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + + ! local + + real, dimension(SZI_(G)) :: & + dztot, & ! Vertical distance between the top and bottom of the ocean [Z ~> m] + dztot_WKB, & ! WKB scaled distance from top to bottom [Z ~> m] + TKE_itidal_bot, & ! internal tide TKE at ocean bottom [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [H Z2 T-3 ~> m3 s-3 or W m-2] + Inv_int, & ! inverse of TKE decay for int tide over the depth of the ocean [nondim] + Inv_int_lee, & ! inverse of TKE decay for lee waves over the depth of the ocean [nondim] + Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] + z0_Polzin, & ! TKE decay scale in Polzin formulation [Z ~> m] + z0_Polzin_scaled, & ! TKE decay scale in Polzin formulation [Z ~> m]. + ! multiplied by N2_bot/N2_meanz to be coherent with the WKB scaled z + ! z*=int(N2/N2_bot) * N2_bot/N2_meanz = int(N2/N2_meanz) + ! z0_Polzin_scaled = z0_Polzin * N2_bot/N2_meanz + N2_meanz, & ! vertically averaged squared buoyancy frequency [T-2 ~> s-2] for WKB scaling + TKE_itidal_rem, & ! remaining internal tide TKE (from barotropic source) [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_Niku_rem, & ! remaining lee-wave TKE [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_lowmode_rem, & ! remaining internal tide TKE (from propagating low mode source) [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_frac_top, & ! fraction of bottom TKE that should appear at top of a layer [nondim] + TKE_frac_top_lee, & ! fraction of bottom TKE that should appear at top of a layer [nondim] + TKE_frac_top_lowmode, & + ! fraction of bottom TKE that should appear at top of a layer [nondim] + z_from_bot, & ! distance from bottom [Z ~> m] + z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m] + + real :: Kd_add ! Diffusivity to add in a layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: frac_used ! fraction of TKE that can be used in a layer [nondim] + real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1] + real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1] + real :: z0Ps_num ! The numerator of the unlimited z0_Polzin_scaled [Z T-3 ~> m s-3] + real :: z0Ps_denom ! The denominator of the unlimited z0_Polzin_scaled [T-3 ~> s-3]. + real :: z0_psl ! temporary variable [Z ~> m] + real :: TKE_lowmode_tot ! TKE from all low modes [R Z3 T-3 ~> W m-2] + + logical :: use_Polzin, use_Simmons + integer :: i, k, is, ie, nz + + is = G%isc ; ie = G%iec ; nz = GV%ke + + if (.not.(CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation)) return + + do i=is,ie ; dztot(i) = 0.0 ; Inv_int(i) = 0.0 ; Inv_int_lee(i) = 0.0 ; Inv_int_low(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + dztot(i) = dztot(i) + dz(i,k) + enddo ; enddo + + use_Polzin = ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09)) .or. & + (CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09)) .or. & + (CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09))) + use_Simmons = ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == STLAURENT_02)) .or. & + (CS%lee_wave_dissipation .and. (CS%lee_wave_profile == STLAURENT_02)) .or. & + (CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == STLAURENT_02))) + + ! Calculate parameters for vertical structure of dissipation + ! Simmons: + if ( use_Simmons ) then + Izeta = 1.0 / max(CS%Int_tide_decay_scale, GV%dz_subroundoff) + Izeta_lee = 1.0 / max(CS%Int_tide_decay_scale*CS%Decay_scale_factor_lee, GV%dz_subroundoff) + do i=is,ie + CS%Nb(i,j) = sqrt(N2_bot(i)) + if (allocated(CS%dd%N2_bot)) & + CS%dd%N2_bot(i,j) = N2_bot(i) + if ( CS%Int_tide_dissipation ) then + if (Izeta*dztot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. + Inv_int(i) = 1.0 / (1.0 - exp(-Izeta*dztot(i))) + endif + endif + if ( CS%Lee_wave_dissipation ) then + if (Izeta_lee*dztot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. + Inv_int_lee(i) = 1.0 / (1.0 - exp(-Izeta_lee*dztot(i))) + endif + endif + if ( CS%Lowmode_itidal_dissipation) then + if (Izeta*dztot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. + Inv_int_low(i) = 1.0 / (1.0 - exp(-Izeta*dztot(i))) + endif + endif + z_from_bot(i) = dz(i,nz) + enddo + endif ! Simmons + + ! Polzin: + if ( use_Polzin ) then + ! WKB scaling of the vertical coordinate + do i=is,ie ; N2_meanz(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + N2_meanz(i) = N2_meanz(i) + N2_lay(i,k) * dz(i,k) + enddo ; enddo + do i=is,ie + N2_meanz(i) = N2_meanz(i) / (dztot(i) + GV%dz_subroundoff) + if (allocated(CS%dd%N2_meanz)) & + CS%dd%N2_meanz(i,j) = N2_meanz(i) + enddo + + ! WKB scaled z*(z=H) z* at the surface using the modified Polzin WKB scaling + do i=is,ie ; dztot_WKB(i) = dztot(i) ; enddo +! do i=is,ie ; dztot_WKB(i) = 0.0 ; enddo +! do k=1,nz ; do i=is,ie +! dztot_WKB(i) = dztot_WKB(i) + dz(i,k) * N2_lay(i,k) / N2_meanz(i) +! enddo ; enddo + ! dztot_WKB(i) = dztot(i) ! Nearly equivalent and simpler + + do i=is,ie + CS%Nb(i,j) = sqrt(N2_bot(i)) + if (CS%tidal_answer_date < 20190101) then + if ((CS%tideamp(i,j) > 0.0) .and. & + (CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j)**3 > 1.0e-14*US%T_to_s**3) ) then + z0_Polzin(i) = CS%Polzin_decay_scale_factor * CS%Nu_Polzin * & + CS%Nbotref_Polzin**2 * CS%tideamp(i,j) / & + ( CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j)**3 ) + if (z0_Polzin(i) < CS%Polzin_min_decay_scale) & + z0_Polzin(i) = CS%Polzin_min_decay_scale + if (N2_meanz(i) > 1.0e-14*US%T_to_s**2 ) then + z0_Polzin_scaled(i) = z0_Polzin(i)*CS%Nb(i,j)**2 / N2_meanz(i) + else + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + endif + if (z0_Polzin_scaled(i) > (CS%Polzin_decay_scale_max_factor * dztot(i)) ) & + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + else + z0_Polzin(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + endif + else + z0Ps_num = (CS%Polzin_decay_scale_factor * CS%Nu_Polzin * CS%Nbotref_Polzin**2) * CS%tideamp(i,j) + z0Ps_denom = ( CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j) * N2_meanz(i) ) + if ((CS%tideamp(i,j) > 0.0) .and. & + (z0Ps_num < z0Ps_denom * CS%Polzin_decay_scale_max_factor * dztot(i))) then + z0_Polzin_scaled(i) = z0Ps_num / z0Ps_denom + + if (abs(N2_meanz(i) * z0_Polzin_scaled(i)) < & + CS%Nb(i,j)**2 * (CS%Polzin_decay_scale_max_factor * dztot(i))) then + z0_Polzin(i) = z0_Polzin_scaled(i) * (N2_meanz(i) / CS%Nb(i,j)**2) + else + z0_Polzin(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + endif + else + z0_Polzin(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + endif + endif + + if (allocated(CS%dd%Polzin_decay_scale)) & + CS%dd%Polzin_decay_scale(i,j) = z0_Polzin(i) + if (allocated(CS%dd%Polzin_decay_scale_scaled)) & + CS%dd%Polzin_decay_scale_scaled(i,j) = z0_Polzin_scaled(i) + if (allocated(CS%dd%N2_bot)) & + CS%dd%N2_bot(i,j) = CS%Nb(i,j)*CS%Nb(i,j) + + if (CS%tidal_answer_date < 20190101) then + ! These expressions use dimensional constants to avoid NaN values. + if ( CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then + if (dztot_WKB(i) > 1.0e-14*US%m_to_Z) & + Inv_int(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 + endif + if ( CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09) ) then + if (dztot_WKB(i) > 1.0e-14*US%m_to_Z) & + Inv_int_lee(i) = ( z0_Polzin_scaled(i)*CS%Decay_scale_factor_lee / dztot_WKB(i) ) + 1.0 + endif + if ( CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then + if (dztot_WKB(i) > 1.0e-14*US%m_to_Z) & + Inv_int_low(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 + endif + else + ! These expressions give values of Inv_int < 10^14 using a variant of Adcroft's reciprocal rule. + Inv_int(i) = 0.0 ; Inv_int_lee(i) = 0.0 ; Inv_int_low(i) = 0.0 + if ( CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then + if (z0_Polzin_scaled(i) < 1.0e14 * dztot_WKB(i)) & + Inv_int(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 + endif + if ( CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09) ) then + if (z0_Polzin_scaled(i) < 1.0e14 * dztot_WKB(i)) & + Inv_int_lee(i) = ( z0_Polzin_scaled(i)*CS%Decay_scale_factor_lee / dztot_WKB(i) ) + 1.0 + endif + if ( CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then + if (z0_Polzin_scaled(i) < 1.0e14 * dztot_WKB(i)) & + Inv_int_low(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 + endif + endif + + z_from_bot(i) = dz(i,nz) + ! Use the new formulation for WKB scaling. N2 is referenced to its vertical mean. + if (CS%tidal_answer_date < 20190101) then + if (N2_meanz(i) > 1.0e-14*US%T_to_s**2 ) then + z_from_bot_WKB(i) = dz(i,nz) * N2_lay(i,nz) / N2_meanz(i) + else ; z_from_bot_WKB(i) = 0 ; endif + else + if (dz(i,nz) * N2_lay(i,nz) < N2_meanz(i) * (1.0e14 * dztot_WKB(i))) then + z_from_bot_WKB(i) = dz(i,nz) * N2_lay(i,nz) / N2_meanz(i) + else ; z_from_bot_WKB(i) = 0 ; endif + endif + enddo + endif ! Polzin + + ! Calculate/get dissipation values at bottom + ! Both Polzin and Simmons: + do i=is,ie + ! Dissipation of locally trapped internal tide (non-propagating high modes) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + TKE_itidal_bot(i) = min(GV%Z_to_H*CS%TKE_itidal(i,j)*CS%Nb(i,j), CS%TKE_itide_max) + else + TKE_itidal_bot(i) = min(GV%RZ_to_H*Rho_bot(i) * (CS%TKE_itidal(i,j)*CS%Nb(i,j)), & + CS%TKE_itide_max) + endif + if (allocated(CS%dd%TKE_itidal_used)) & + CS%dd%TKE_itidal_used(i,j) = TKE_itidal_bot(i) + TKE_itidal_bot(i) = (GV%RZ_to_H * CS%Mu_itides * CS%Gamma_itides) * TKE_itidal_bot(i) + ! Dissipation of locally trapped lee waves + TKE_Niku_bot(i) = 0.0 + if (CS%Lee_wave_dissipation) then + TKE_Niku_bot(i) = (GV%RZ_to_H * CS%Mu_itides * CS%Gamma_lee) * CS%TKE_Niku(i,j) + endif + ! Dissipation of propagating internal tide (baroclinic low modes; rays) (BDM) + TKE_lowmode_tot = 0.0 + TKE_lowmode_bot(i) = 0.0 + if (CS%Lowmode_itidal_dissipation) then + ! get loss rate due to wave drag on low modes (already multiplied by q) + call get_lowmode_loss(i,j,G,CS%int_tide_CSp,"WaveDrag",TKE_lowmode_tot) + TKE_lowmode_bot(i) = CS%Mu_itides * GV%RZ_to_H * TKE_lowmode_tot + endif + ! Vertical energy flux at bottom + TKE_itidal_rem(i) = Inv_int(i) * TKE_itidal_bot(i) + TKE_Niku_rem(i) = Inv_int_lee(i) * TKE_Niku_bot(i) + TKE_lowmode_rem(i) = Inv_int_low(i) * TKE_lowmode_bot(i) + + if (allocated(CS%dd%Fl_itidal)) & + CS%dd%Fl_itidal(i,j,nz) = TKE_itidal_rem(i) !why is this here? BDM + enddo + + ! Estimate the work that would be done by mixing in each layer. + ! Simmons: + if ( use_Simmons ) then + do k=nz-1,2,-1 ; do i=is,ie + if (max_TKE(i,k) <= 0.0) cycle + z_from_bot(i) = z_from_bot(i) + dz(i,k) + + ! Fraction of bottom flux predicted to reach top of this layer + TKE_frac_top(i) = Inv_int(i) * exp(-Izeta * z_from_bot(i)) + TKE_frac_top_lee(i) = Inv_int_lee(i) * exp(-Izeta_lee * z_from_bot(i)) + TKE_frac_top_lowmode(i) = Inv_int_low(i) * exp(-Izeta * z_from_bot(i)) + + ! Actual influx at bottom of layer minus predicted outflux at top of layer to give + ! predicted power expended + TKE_itide_lay = TKE_itidal_rem(i) - TKE_itidal_bot(i) * TKE_frac_top(i) + TKE_Niku_lay = TKE_Niku_rem(i) - TKE_Niku_bot(i) * TKE_frac_top_lee(i) + TKE_lowmode_lay = TKE_lowmode_rem(i) - TKE_lowmode_bot(i)* TKE_frac_top_lowmode(i) + + ! Actual power expended may be less than predicted if stratification is weak; adjust + if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > max_TKE(i,k)) then + frac_used = (max_TKE(i,k)) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + TKE_itide_lay = frac_used * TKE_itide_lay + TKE_Niku_lay = frac_used * TKE_Niku_lay + TKE_lowmode_lay = frac_used * TKE_lowmode_lay + endif + + ! Calculate vertical flux available to bottom of layer above + TKE_itidal_rem(i) = TKE_itidal_rem(i) - TKE_itide_lay + TKE_Niku_rem(i) = TKE_Niku_rem(i) - TKE_Niku_lay + TKE_lowmode_rem(i) = TKE_lowmode_rem(i) - TKE_lowmode_lay + + ! Convert power to diffusivity + Kd_add = TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + + if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) + if (present(Kd_lay)) then + Kd_lay(i,k) = Kd_lay(i,k) + Kd_add + endif + + if (present(Kd_int)) then + Kd_int(i,K) = Kd_int(i,K) + 0.5 * Kd_add + Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * Kd_add + endif + + ! diagnostics + if (allocated(CS%dd%Kd_itidal)) then + ! If at layers, CS%dd%Kd_itidal is just TKE_to_Kd(i,k) * TKE_itide_lay + ! The following sets the interface diagnostics. + Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay + if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) + if (k>1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add + if (k= 0.0) Kd_add = min(Kd_add, Kd_max) + if (k>1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add + if (k= 0.0) Kd_add = min(Kd_add, Kd_max) + if (k>1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add + if (k 1.0e-14*US%T_to_s**2 ) then + z_from_bot_WKB(i) = z_from_bot_WKB(i) + dz(i,k) * N2_lay(i,k) / N2_meanz(i) + else ; z_from_bot_WKB(i) = 0 ; endif + else + if (dz(i,k) * N2_lay(i,k) < (1.0e14 * dztot_WKB(i)) * N2_meanz(i)) then + z_from_bot_WKB(i) = z_from_bot_WKB(i) + dz(i,k) * N2_lay(i,k) / N2_meanz(i) + endif + endif + + ! Fraction of bottom flux predicted to reach top of this layer + TKE_frac_top(i) = ( Inv_int(i) * z0_Polzin_scaled(i) ) / & + ( z0_Polzin_scaled(i) + z_from_bot_WKB(i) ) + z0_psl = z0_Polzin_scaled(i)*CS%Decay_scale_factor_lee + TKE_frac_top_lee(i) = (Inv_int_lee(i) * z0_psl) / (z0_psl + z_from_bot_WKB(i)) + TKE_frac_top_lowmode(i) = ( Inv_int_low(i) * z0_Polzin_scaled(i) ) / & + ( z0_Polzin_scaled(i) + z_from_bot_WKB(i) ) + + ! Actual influx at bottom of layer minus predicted outflux at top of layer to give + ! predicted power expended + TKE_itide_lay = TKE_itidal_rem(i) - TKE_itidal_bot(i) *TKE_frac_top(i) + TKE_Niku_lay = TKE_Niku_rem(i) - TKE_Niku_bot(i) * TKE_frac_top_lee(i) + TKE_lowmode_lay = TKE_lowmode_rem(i) - TKE_lowmode_bot(i)*TKE_frac_top_lowmode(i) + + ! Actual power expended may be less than predicted if stratification is weak; adjust + if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > max_TKE(i,k)) then + frac_used = max_TKE(i,k) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + TKE_itide_lay = frac_used * TKE_itide_lay + TKE_Niku_lay = frac_used * TKE_Niku_lay + TKE_lowmode_lay = frac_used * TKE_lowmode_lay + endif + + ! Calculate vertical flux available to bottom of layer above + TKE_itidal_rem(i) = TKE_itidal_rem(i) - TKE_itide_lay + TKE_Niku_rem(i) = TKE_Niku_rem(i) - TKE_Niku_lay + TKE_lowmode_rem(i) = TKE_lowmode_rem(i) - TKE_lowmode_lay + + ! Convert power to diffusivity + Kd_add = TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + + if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) + if (present(Kd_lay)) then + Kd_lay(i,k) = Kd_lay(i,k) + Kd_add + endif + + if (present(Kd_int)) then + Kd_int(i,K) = Kd_int(i,K) + 0.5 * Kd_add + Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * Kd_add + endif + + ! diagnostics + if (allocated(CS%dd%Kd_itidal)) then + ! If at layers, this is just CS%dd%Kd_itidal(i,j,K) = TKE_to_Kd(i,k) * TKE_itide_lay + ! The following sets the interface diagnostics. + Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay + if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) + if (k>1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add + if (k= 0.0) Kd_add = min(Kd_add, Kd_max) + if (k>1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add + if (k= 0.0) Kd_add = min(Kd_add, Kd_max) + if (k>1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add + if (k Sets up diagnostics arrays for tidal mixing. +subroutine setup_tidal_diagnostics(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module + + ! local + integer :: isd, ied, jsd, jed, nz + + isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed; nz = GV%ke + + if ((CS%id_Kd_itidal > 0) .or. (CS%id_Kd_Itidal_work > 0)) & + allocate(CS%dd%Kd_itidal(isd:ied,jsd:jed,nz+1), source=0.0) + if ((CS%id_Kd_lowmode > 0) .or. (CS%id_Kd_lowmode_work > 0)) & + allocate(CS%dd%Kd_lowmode(isd:ied,jsd:jed,nz+1), source=0.0) + if (CS%id_Fl_itidal > 0) allocate(CS%dd%Fl_itidal(isd:ied,jsd:jed,nz+1), source=0.0) + if (CS%id_Fl_lowmode > 0) allocate(CS%dd%Fl_lowmode(isd:ied,jsd:jed,nz+1), source=0.0) + if (CS%id_Polzin_decay_scale > 0) allocate(CS%dd%Polzin_decay_scale(isd:ied,jsd:jed), source=0.0) + if (CS%id_N2_bot > 0) allocate(CS%dd%N2_bot(isd:ied,jsd:jed), source=0.0) + if (CS%id_N2_meanz > 0) allocate(CS%dd%N2_meanz(isd:ied,jsd:jed), source=0.0) + if (CS%id_Polzin_decay_scale_scaled > 0) & + allocate(CS%dd%Polzin_decay_scale_scaled(isd:ied,jsd:jed), source=0.0) + if ((CS%id_Kd_Niku > 0) .or. (CS%id_Kd_Niku_work > 0)) & + allocate(CS%dd%Kd_Niku(isd:ied,jsd:jed,nz+1), source=0.0) + if (CS%id_Kd_Niku_work > 0) allocate(CS%dd%Kd_Niku_work(isd:ied,jsd:jed,nz), source=0.0) + if (CS%id_Kd_Itidal_work > 0) allocate(CS%dd%Kd_Itidal_work(isd:ied,jsd:jed,nz), source=0.0) + if (CS%id_Kd_Lowmode_Work > 0) allocate(CS%dd%Kd_Lowmode_Work(isd:ied,jsd:jed,nz), source=0.0) + if (CS%id_TKE_itidal > 0) allocate(CS%dd%TKE_Itidal_used(isd:ied,jsd:jed), source=0.) + ! additional diags for CVMix + if (CS%id_N2_int > 0) allocate(CS%dd%N2_int(isd:ied,jsd:jed,nz+1), source=0.0) + if (CS%id_Simmons_coeff > 0) then + if (CS%CVMix_tidal_scheme /= SIMMONS) then + call MOM_error(FATAL, "setup_tidal_diagnostics: Simmons_coeff diagnostics is available "//& + "only when CVMix_tidal_scheme is Simmons") + endif + allocate(CS%dd%Simmons_coeff_2d(isd:ied,jsd:jed), source=0.0) + endif + if (CS%id_vert_dep > 0) allocate(CS%dd%vert_dep_3d(isd:ied,jsd:jed,nz+1), source=0.0) + if (CS%id_Schmittner_coeff > 0) then + if (CS%CVMix_tidal_scheme /= SCHMITTNER) then + call MOM_error(FATAL, "setup_tidal_diagnostics: Schmittner_coeff diagnostics is available "//& + "only when CVMix_tidal_scheme is Schmittner.") + endif + allocate(CS%dd%Schmittner_coeff_3d(isd:ied,jsd:jed,nz), source=0.0) + endif + if (CS%id_tidal_qe_md > 0) then + if (CS%CVMix_tidal_scheme /= SCHMITTNER) then + call MOM_error(FATAL, "setup_tidal_diagnostics: tidal_qe_md diagnostics is available "//& + "only when CVMix_tidal_scheme is Schmittner.") + endif + allocate(CS%dd%tidal_qe_md(isd:ied,jsd:jed,nz), source=0.0) + endif +end subroutine setup_tidal_diagnostics + +!> This subroutine offers up diagnostics of the tidal mixing. +subroutine post_tidal_diagnostics(G, GV, h ,CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module + + if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then + if (CS%id_TKE_itidal > 0) call post_data(CS%id_TKE_itidal, CS%dd%TKE_itidal_used, CS%diag) + if (CS%id_TKE_leewave > 0) call post_data(CS%id_TKE_leewave, CS%TKE_Niku, CS%diag) + if (CS%id_Nb > 0) call post_data(CS%id_Nb, CS%Nb, CS%diag) + if (CS%id_N2_bot > 0) call post_data(CS%id_N2_bot, CS%dd%N2_bot, CS%diag) + if (CS%id_N2_meanz > 0) call post_data(CS%id_N2_meanz,CS%dd%N2_meanz,CS%diag) + + if (CS%id_Fl_itidal > 0) call post_data(CS%id_Fl_itidal, CS%dd%Fl_itidal, CS%diag) + if (CS%id_Kd_itidal > 0) call post_data(CS%id_Kd_itidal, CS%dd%Kd_itidal, CS%diag) + if (CS%id_Kd_Niku > 0) call post_data(CS%id_Kd_Niku, CS%dd%Kd_Niku, CS%diag) + if (CS%id_Kd_lowmode> 0) call post_data(CS%id_Kd_lowmode, CS%dd%Kd_lowmode, CS%diag) + if (CS%id_Fl_lowmode> 0) call post_data(CS%id_Fl_lowmode, CS%dd%Fl_lowmode, CS%diag) + + if (CS%id_N2_int> 0) call post_data(CS%id_N2_int, CS%dd%N2_int, CS%diag) + if (CS%id_vert_dep> 0) call post_data(CS%id_vert_dep, CS%dd%vert_dep_3d, CS%diag) + if (CS%id_Simmons_coeff> 0) call post_data(CS%id_Simmons_coeff, CS%dd%Simmons_coeff_2d, CS%diag) + if (CS%id_Schmittner_coeff> 0) call post_data(CS%id_Schmittner_coeff, CS%dd%Schmittner_coeff_3d, CS%diag) + if (CS%id_tidal_qe_md> 0) call post_data(CS%id_tidal_qe_md, CS%dd%tidal_qe_md, CS%diag) + + if (CS%id_Kd_Itidal_Work > 0) & + call post_data(CS%id_Kd_Itidal_Work, CS%dd%Kd_Itidal_Work, CS%diag) + if (CS%id_Kd_Niku_Work > 0) call post_data(CS%id_Kd_Niku_Work, CS%dd%Kd_Niku_Work, CS%diag) + if (CS%id_Kd_Lowmode_Work > 0) & + call post_data(CS%id_Kd_Lowmode_Work, CS%dd%Kd_Lowmode_Work, CS%diag) + + if (CS%id_Polzin_decay_scale > 0 ) & + call post_data(CS%id_Polzin_decay_scale, CS%dd%Polzin_decay_scale, CS%diag) + if (CS%id_Polzin_decay_scale_scaled > 0 ) & + call post_data(CS%id_Polzin_decay_scale_scaled, CS%dd%Polzin_decay_scale_scaled, CS%diag) + endif + + if (allocated(CS%dd%Kd_itidal)) deallocate(CS%dd%Kd_itidal) + if (allocated(CS%dd%Kd_lowmode)) deallocate(CS%dd%Kd_lowmode) + if (allocated(CS%dd%Fl_itidal)) deallocate(CS%dd%Fl_itidal) + if (allocated(CS%dd%Fl_lowmode)) deallocate(CS%dd%Fl_lowmode) + if (allocated(CS%dd%Polzin_decay_scale)) deallocate(CS%dd%Polzin_decay_scale) + if (allocated(CS%dd%Polzin_decay_scale_scaled)) deallocate(CS%dd%Polzin_decay_scale_scaled) + if (allocated(CS%dd%N2_bot)) deallocate(CS%dd%N2_bot) + if (allocated(CS%dd%N2_meanz)) deallocate(CS%dd%N2_meanz) + if (allocated(CS%dd%Kd_Niku)) deallocate(CS%dd%Kd_Niku) + if (allocated(CS%dd%Kd_Niku_work)) deallocate(CS%dd%Kd_Niku_work) + if (allocated(CS%dd%Kd_Itidal_Work)) deallocate(CS%dd%Kd_Itidal_Work) + if (allocated(CS%dd%Kd_Lowmode_Work)) deallocate(CS%dd%Kd_Lowmode_Work) + if (allocated(CS%dd%TKE_itidal_used)) deallocate(CS%dd%TKE_itidal_used) + if (allocated(CS%dd%N2_int)) deallocate(CS%dd%N2_int) + if (allocated(CS%dd%vert_dep_3d)) deallocate(CS%dd%vert_dep_3d) + if (allocated(CS%dd%Simmons_coeff_2d)) deallocate(CS%dd%Simmons_coeff_2d) + if (allocated(CS%dd%Schmittner_coeff_3d)) deallocate(CS%dd%Schmittner_coeff_3d) + if (allocated(CS%dd%tidal_qe_md)) deallocate(CS%dd%tidal_qe_md) +end subroutine post_tidal_diagnostics + +!> This subroutine returns a zonal slice of the topographic roughness amplitudes +subroutine tidal_mixing_h_amp(h_amp, G, j, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G)), intent(out) :: h_amp !< The topographic roughness amplitude [Z ~> m] + integer, intent(in) :: j !< j-index of the row to work on + type(tidal_mixing_cs), intent(in) :: CS !< The control structure for this module + + integer :: i + + h_amp(:) = 0.0 + if ( CS%Int_tide_dissipation .and. .not. CS%use_CVMix_tidal ) then + do i=G%isc,G%iec + h_amp(i) = sqrt(CS%h2(i,j)) + enddo + endif + +end subroutine tidal_mixing_h_amp + +! TODO: move this subroutine to MOM_internal_tide_input module (?) +!> This subroutine read tidal energy inputs from a file. +subroutine read_tidal_energy(G, US, tidal_energy_type, param_file, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + character(len=20), intent(in) :: tidal_energy_type !< The type of tidal energy inputs to read + type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle + type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module + + ! local variables + character(len=200) :: tidal_energy_file ! Input file names or paths + character(len=200) :: tidal_input_var ! Input file variable name + character(len=40) :: mdl = "MOM_tidal_mixing" !< This module's name. + integer :: i, j, isd, ied, jsd, jed + real, allocatable, dimension(:,:) :: & + tidal_energy_flux_2d ! Input tidal energy flux at T-grid points [R Z3 T-3 ~> W m-2] + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + call get_param(param_file, mdl, "TIDAL_ENERGY_FILE", tidal_energy_file, & + "The path to the file containing tidal energy dissipation. "//& + "Used with CVMix tidal mixing schemes.", fail_if_missing=.true.) + tidal_energy_file = trim(CS%inputdir) // trim(tidal_energy_file) + + select case (uppercase(tidal_energy_type(1:4))) + case ('JAYN') ! Jayne 2009 + if (.not. allocated(CS%tidal_qe_2d)) allocate(CS%tidal_qe_2d(isd:ied,jsd:jed)) + allocate(tidal_energy_flux_2d(isd:ied,jsd:jed)) + call get_param(param_file, mdl, "TIDAL_DISSIPATION_VAR", tidal_input_var, & + "The name in the input file of the tidal energy source for mixing.", & + default="wave_dissipation") + call MOM_read_data(tidal_energy_file, tidal_input_var, tidal_energy_flux_2d, G%domain, scale=US%W_m2_to_RZ3_T3) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + CS%tidal_qe_2d(i,j) = CS%Gamma_itides * tidal_energy_flux_2d(i,j) + enddo ; enddo + deallocate(tidal_energy_flux_2d) + case ('ER03') ! Egbert & Ray 2003 + call read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) + case default + call MOM_error(FATAL, "read_tidal_energy: Unknown tidal energy file type.") + end select + +end subroutine read_tidal_energy + +!> This subroutine reads tidal input energy from a file by constituent. +subroutine read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + character(len=200), intent(in) :: tidal_energy_file !< The file from which to read tidal energy inputs + type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle + type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module + + ! local variables + real, parameter :: C1_3 = 1.0/3.0 ! A rational constant [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: & + tidal_qk1, & ! qk1 coefficient used in Schmittner & Egbert [nondim] + tidal_qo1 ! qo1 coefficient used in Schmittner & Egbert [nondim] + real, allocatable, dimension(:) :: & + z_t, & ! depth from surface to midpoint of input layer [Z ~> m] + z_w ! depth from surface to top of input layer [Z ~> m] + real, allocatable, dimension(:,:,:) :: & + tc_m2, & ! input lunar semidiurnal tidal energy flux [R Z3 T-3 ~> W m-2] + tc_s2, & ! input solar semidiurnal tidal energy flux [R Z3 T-3 ~> W m-2] + tc_k1, & ! input lunar diurnal tidal energy flux [R Z3 T-3 ~> W m-2] + tc_o1 ! input lunar diurnal tidal energy flux [R Z3 T-3 ~> W m-2] + integer, dimension(4) :: nz_in + integer :: k, is, ie, js, je, isd, ied, jsd, jed, i, j + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + ! get number of input levels: + call field_size(tidal_energy_file, 'z_t', nz_in) + + ! allocate local variables + allocate(z_t(nz_in(1)), z_w(nz_in(1)) ) + allocate(tc_m2(isd:ied,jsd:jed,nz_in(1)), & + tc_s2(isd:ied,jsd:jed,nz_in(1)), & + tc_k1(isd:ied,jsd:jed,nz_in(1)), & + tc_o1(isd:ied,jsd:jed,nz_in(1)) ) + + ! allocate CS variables associated with 3d tidal energy dissipation + if (.not. allocated(CS%tidal_qe_3d_in)) allocate(CS%tidal_qe_3d_in(isd:ied,jsd:jed,nz_in(1))) + if (.not. allocated(CS%h_src)) allocate(CS%h_src(nz_in(1))) + + ! read in tidal constituents + call MOM_read_data(tidal_energy_file, 'M2', tc_m2, G%domain, scale=US%W_m2_to_RZ3_T3) + call MOM_read_data(tidal_energy_file, 'S2', tc_s2, G%domain, scale=US%W_m2_to_RZ3_T3) + call MOM_read_data(tidal_energy_file, 'K1', tc_k1, G%domain, scale=US%W_m2_to_RZ3_T3) + call MOM_read_data(tidal_energy_file, 'O1', tc_o1, G%domain, scale=US%W_m2_to_RZ3_T3) + ! Note the hard-coded assumption that z_t and z_w in the file are in centimeters. + call MOM_read_data(tidal_energy_file, 'z_t', z_t, scale=0.01*US%m_to_Z) + call MOM_read_data(tidal_energy_file, 'z_w', z_w, scale=0.01*US%m_to_Z) + + do j=js,je ; do i=is,ie + if (abs(G%geoLatT(i,j)) < 30.0) then + tidal_qk1(i,j) = C1_3 + tidal_qo1(i,j) = C1_3 + else + tidal_qk1(i,j) = 1.0 + tidal_qo1(i,j) = 1.0 + endif + enddo ; enddo + + CS%tidal_qe_3d_in(:,:,:) = 0.0 + do k=1,nz_in(1) + ! Store the input cell thickness in m for use with CVmix. + CS%h_src(k) = US%Z_to_m*(z_t(k)-z_w(k))*2.0 + ! form tidal_qe_3d_in from weighted tidal constituents + do j=js,je ; do i=is,ie + if ((z_t(k) <= G%bathyT(i,j) + G%Z_ref) .and. (z_w(k) > CS%tidal_diss_lim_tc)) & + CS%tidal_qe_3d_in(i,j,k) = C1_3*tc_m2(i,j,k) + C1_3*tc_s2(i,j,k) + & + tidal_qk1(i,j)*tc_k1(i,j,k) + tidal_qo1(i,j)*tc_o1(i,j,k) + enddo ; enddo + enddo + + ! test if qE is positive + if (any(CS%tidal_qe_3d_in<0.0)) then + call MOM_error(FATAL, "read_tidal_constituents: Negative tidal_qe_3d_in terms.") + endif + + !! collapse 3D q*E to 2D q*E + !CS%tidal_qe_2d(:,:) = 0.0 + !do k=1,nz_in(1) ; do j=js,je ; do i=is,ie + ! if (z_t(k) <= G%bathyT(i,j) + G%Z_ref) & + ! CS%tidal_qe_2d(i,j) = CS%tidal_qe_2d(i,j) + CS%tidal_qe_3d_in(i,j,k) + !enddo ; enddo ; enddo + + ! initialize input remapping: + call initialize_remapping(CS%remap_cs, remapping_scheme="PLM", & + boundary_extrapolation=.false., check_remapping=CS%debug, & + answer_date=CS%remap_answer_date) + + deallocate(tc_m2) + deallocate(tc_s2) + deallocate(tc_k1) + deallocate(tc_o1) + deallocate(z_t) + deallocate(z_w) + +end subroutine read_tidal_constituents + +!> Deallocate fields +subroutine tidal_mixing_end(CS) + type(tidal_mixing_cs), intent(inout) :: CS !< This module's control structure, which + !! will be deallocated in this routine. + + ! TODO: deallocate all the dynamically allocated members here ... + if (allocated(CS%tidal_qe_2d)) deallocate(CS%tidal_qe_2d) + if (allocated(CS%tidal_qe_3d_in)) deallocate(CS%tidal_qe_3d_in) + if (allocated(CS%h_src)) deallocate(CS%h_src) +end subroutine tidal_mixing_end + +end module MOM_tidal_mixing diff --git a/parameterizations/vertical/MOM_vert_friction.F90 b/parameterizations/vertical/MOM_vert_friction.F90 new file mode 100644 index 0000000000..ead2cf00cf --- /dev/null +++ b/parameterizations/vertical/MOM_vert_friction.F90 @@ -0,0 +1,3200 @@ +!> Implements vertical viscosity (vertvisc) +module MOM_vert_friction + +! This file is part of MOM6. See LICENSE.md for the license. +use MOM_domains, only : pass_var, To_All, Omit_corners +use MOM_domains, only : pass_vector, Scalar_Pair +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : post_product_u, post_product_sum_u +use MOM_diag_mediator, only : post_product_v, post_product_sum_v +use MOM_diag_mediator, only : diag_ctrl, query_averaging_enabled +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : To_North, To_East +use MOM_debugging, only : uvchksum, hchksum +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : mech_forcing, find_ustar +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : MOM_read_data, slasher +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_E +use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S +use MOM_PointAccel, only : write_u_accel, write_v_accel, PointAccel_init +use MOM_PointAccel, only : PointAccel_CS +use MOM_time_manager, only : time_type, time_type_to_real, operator(-) +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type +use MOM_variables, only : cont_diag_ptrs, accel_diag_ptrs +use MOM_variables, only : ocean_internal_state +use MOM_verticalGrid, only : verticalGrid_type +use MOM_wave_interface, only : wave_parameters_CS +use MOM_set_visc, only : set_v_at_u, set_u_at_v +use MOM_lateral_mixing_coeffs, only : VarMix_CS + +implicit none ; private + +#include + +public vertvisc, vertvisc_remnant, vertvisc_coef +public vertvisc_limit_vel, vertvisc_init, vertvisc_end +public updateCFLtruncationValue +public vertFPmix + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> The control structure with parameters and memory for the MOM_vert_friction module +type, public :: vertvisc_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + real :: Hmix !< The mixed layer thickness [Z ~> m]. + real :: Hmix_stress !< The mixed layer thickness over which the wind + !! stress is applied with direct_stress [H ~> m or kg m-2]. + real :: Kvml_invZ2 !< The extra vertical viscosity scale in [H Z T-1 ~> m2 s-1 or Pa s] in a + !! surface mixed layer with a characteristic thickness given by Hmix, + !! and scaling proportional to (Hmix/z)^2, where z is the distance + !! from the surface; this can get very large with thin layers. + real :: Kv !< The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s]. + real :: Hbbl !< The static bottom boundary layer thickness [Z ~> m]. + real :: Hbbl_gl90 !< The static bottom boundary layer thickness used for GL90 [Z ~> m]. + real :: Kv_extra_bbl !< An extra vertical viscosity in the bottom boundary layer of thickness + !! Hbbl when there is not a bottom drag law in use [H Z T-1 ~> m2 s-1 or Pa s]. + real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] + + logical :: use_GL90_in_SSW !< If true, use the GL90 parameterization in stacked shallow water mode (SSW). + !! The calculation of the GL90 viscosity coefficient uses the fact that in SSW + !! we simply have 1/N^2 = h/g^prime, where g^prime is the reduced gravity. + !! This identity does not generalize to non-SSW setups. + logical :: use_GL90_N2 !< If true, use GL90 vertical viscosity coefficient that is depth-independent; + !! this corresponds to a kappa_GM that scales as N^2 with depth. + real :: kappa_gl90 !< The scalar diffusivity used in the GL90 vertical viscosity scheme + !! [L2 H Z-1 T-1 ~> m2 s-1 or Pa s] + logical :: read_kappa_gl90 !< If true, read a file containing the spatially varying kappa_gl90 + real :: alpha_gl90 !< Coefficient used to compute a depth-independent GL90 vertical + !! viscosity via Kv_gl90 = alpha_gl90 * f^2. Note that the implied + !! Kv_gl90 corresponds to a kappa_gl90 that scales as N^2 with depth. + !! [H Z T ~> m2 s or kg s m-1] + real :: maxvel !< Velocity components greater than maxvel are truncated [L T-1 ~> m s-1]. + real :: vel_underflow !< Velocity components smaller than vel_underflow + !! are set to 0 [L T-1 ~> m s-1]. + logical :: CFL_based_trunc !< If true, base truncations on CFL numbers, not + !! absolute velocities. + real :: CFL_trunc !< Velocity components will be truncated when they + !! are large enough that the corresponding CFL number + !! exceeds this value [nondim]. + real :: CFL_report !< The value of the CFL number that will cause the + !! accelerations to be reported [nondim]. CFL_report + !! will often equal CFL_trunc. + real :: truncRampTime !< The time-scale over which to ramp up the value of + !! CFL_trunc from CFL_truncS to CFL_truncE [T ~> s] + real :: CFL_truncS !< The start value of CFL_trunc [nondim] + real :: CFL_truncE !< The end/target value of CFL_trunc [nondim] + logical :: CFLrampingIsActivated = .false. !< True if the ramping has been initialized + type(time_type) :: rampStartTime !< The time at which the ramping of CFL_trunc starts + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) :: & + a_u !< The u-drag coefficient across an interface [H T-1 ~> m s-1 or Pa s m-1] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) :: & + a_u_gl90 !< The u-drag coefficient associated with GL90 across an interface [H T-1 ~> m s-1 or Pa s m-1] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & + h_u !< The effective layer thickness at u-points [H ~> m or kg m-2]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) :: & + a_v !< The v-drag coefficient across an interface [H T-1 ~> m s-1 or Pa s m-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) :: & + a_v_gl90 !< The v-drag coefficient associated with GL90 across an interface [H T-1 ~> m s-1 or Pa s m-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & + h_v !< The effective layer thickness at v-points [H ~> m or kg m-2]. + real, pointer, dimension(:,:) :: a1_shelf_u => NULL() !< The u-momentum coupling coefficient under + !! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. Retained to determine stress under shelves. + real, pointer, dimension(:,:) :: a1_shelf_v => NULL() !< The v-momentum coupling coefficient under + !! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. Retained to determine stress under shelves. + + logical :: split !< If true, use the split time stepping scheme. + logical :: bottomdraglaw !< If true, the bottom stress is calculated with a + !! drag law c_drag*|u|*u. The velocity magnitude + !! may be an assumed value or it may be based on the + !! actual velocity in the bottommost HBBL, depending + !! on whether linear_drag is true. + logical :: harmonic_visc !< If true, the harmonic mean thicknesses are used + !! to calculate the viscous coupling between layers + !! except near the bottom. Otherwise the arithmetic + !! mean thickness is used except near the bottom. + real :: harm_BL_val !< A scale to determine when water is in the boundary + !! layers based solely on harmonic mean thicknesses + !! for the purpose of determining the extent to which + !! the thicknesses used in the viscosities are upwinded [nondim]. + logical :: direct_stress !< If true, the wind stress is distributed over the topmost Hmix_stress + !! of fluid, and an added mixed layer viscosity or a physically based + !! boundary layer turbulence parameterization is not needed for stability. + logical :: dynamic_viscous_ML !< If true, use the results from a dynamic + !! calculation, perhaps based on a bulk Richardson + !! number criterion, to determine the mixed layer + !! thickness for viscosity. + logical :: fixed_LOTW_ML !< If true, use a Law-of-the-wall prescription for the mixed layer + !! viscosity within a boundary layer that is the lesser of Hmix and the + !! total depth of the ocean in a column. + logical :: apply_LOTW_floor !< If true, use a Law-of-the-wall prescription to set a lower bound + !! on the viscous coupling between layers within the surface boundary + !! layer, based the distance of interfaces from the surface. This only + !! acts when there are large changes in the thicknesses of successive + !! layers or when the viscosity is set externally and the wind stress + !! has subsequently increased. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the viscous + !! calculations. Values below 20190101 recover the answers from the end + !! of 2018, while higher values use expressions that do not use an + !! arbitrary and hard-coded maximum viscous coupling coefficient between + !! layers. In non-Boussinesq cases, values below 20230601 recover a + !! form of the viscosity within the mixed layer that breaks up the + !! magnitude of the wind stress with BULKMIXEDLAYER, DYNAMIC_VISCOUS_ML + !! or FIXED_DEPTH_LOTW_ML, but not LOTW_VISCOUS_ML_FLOOR. + logical :: debug !< If true, write verbose checksums for debugging purposes. + integer :: nkml !< The number of layers in the mixed layer. + integer, pointer :: ntrunc !< The number of times the velocity has been + !! truncated since the last call to write_energy. + character(len=200) :: u_trunc_file !< The complete path to a file in which a column of + !! u-accelerations are written if velocity truncations occur. + character(len=200) :: v_trunc_file !< The complete path to a file in which a column of + !! v-accelerations are written if velocity truncations occur. + logical :: StokesMixing !< If true, do Stokes drift mixing via the Lagrangian current + !! (Eulerian plus Stokes drift). False by default and set + !! via STOKES_MIXING_COMBINED. + + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. + real, allocatable, dimension(:,:) :: kappa_gl90_2d !< 2D kappa_gl90 at h-points [L2 H Z-1 T-1 ~> m2 s-1 or Pa s] + + !>@{ Diagnostic identifiers + integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_du_dt_visc_gl90 = -1, id_dv_dt_visc_gl90 = -1 + integer :: id_GLwork = -1 + integer :: id_au_vv = -1, id_av_vv = -1, id_au_gl90_vv = -1, id_av_gl90_vv = -1 + integer :: id_du_dt_str = -1, id_dv_dt_str = -1 + integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 + integer :: id_FPw2x = -1 !W id_FPhbl_u = -1, id_FPhbl_v = -1 + integer :: id_tauFP_u = -1, id_tauFP_v = -1 !W, id_FPtau2x_u = -1, id_FPtau2x_v = -1 + integer :: id_FPtau2s_u = -1, id_FPtau2s_v = -1, id_FPtau2w_u = -1, id_FPtau2w_v = -1 + integer :: id_taux_bot = -1, id_tauy_bot = -1 + integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 + integer :: id_Kv_gl90_u = -1, id_Kv_gl90_v = -1 + ! integer :: id_hf_du_dt_visc = -1, id_hf_dv_dt_visc = -1 + integer :: id_h_du_dt_visc = -1, id_h_dv_dt_visc = -1 + integer :: id_hf_du_dt_visc_2d = -1, id_hf_dv_dt_visc_2d = -1 + integer :: id_h_du_dt_str = -1, id_h_dv_dt_str = -1 + integer :: id_du_dt_str_visc_rem = -1, id_dv_dt_str_visc_rem = -1 + !>@} + + type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() !< A pointer to the control structure + !! for recording accelerations leading to velocity truncations + + type(group_pass_type) :: pass_KE_uv !< A handle used for group halo passes +end type vertvisc_CS + +contains + +!> Add nonlocal stress increments to u^n (uold) and v^n (vold) using ui and vi. +subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ui !< Zonal velocity after vertvisc [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vi !< Meridional velocity after vertvisc [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uold !< Old Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vold !< Old Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: hbl_h !< boundary layer depth [H ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + + ! local variables + real, dimension(SZIB_(G),SZJ_(G)) :: hbl_u !< boundary layer depth at u-pts [H ~> m] + real, dimension(SZI_(G),SZJB_(G)) :: hbl_v !< boundary layer depth at v-pts [H ~> m] + integer, dimension(SZIB_(G),SZJ_(G)) :: kbl_u !< index of the BLD at u-pts [nondim] + integer, dimension(SZI_(G),SZJB_(G)) :: kbl_v !< index of the BLD at v-pts [nondim] + real, dimension(SZIB_(G),SZJ_(G)) :: ustar2_u !< ustar squared at u-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G)) :: ustar2_v !< ustar squared at v-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G)) :: taux_u !< zonal wind stress at u-pts [R L Z T-2 ~> Pa] + real, dimension(SZI_(G),SZJB_(G)) :: tauy_v !< meridional wind stress at v-pts [R L Z T-2 ~> Pa] + !real, dimension(SZIB_(G),SZJ_(G)) :: omega_w2x_u !< angle between wind and x-axis at u-pts [rad] + !real, dimension(SZI_(G),SZJB_(G)) :: omega_w2x_v !< angle between wind and y-axis at v-pts [rad] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tau_u !< kinematic zonal mtm flux at u-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tau_v !< kinematic mer. mtm flux at v-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauxDG_u !< downgradient zonal mtm flux at u-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauyDG_u !< downgradient meri mtm flux at u-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauxDG_v !< downgradient zonal mtm flux at v-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauyDG_v !< downgradient meri mtm flux at v-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2s_u !< angle between mtm flux and vert shear at u-pts [rad] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2s_v !< angle between mtm flux and vert shear at v-pts [rad] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2w_u !< angle between mtm flux and wind at u-pts [rad] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2w_v !< angle between mtm flux and wind at v-pts [rad] + + real :: pi, Cemp_CG, tmp, cos_tmp, sin_tmp, omega_tmp !< constants and dummy variables + real :: du, dv, depth, sigma, Wind_x, Wind_y !< intermediate variables + real :: taux, tauy, tauxDG, tauyDG, tauxDGup, tauyDGup, ustar2, tauh !< intermediate variables + real :: tauNLup, tauNLdn, tauNL_CG, tauNL_DG, tauNL_X, tauNL_Y, tau_MAG !< intermediate variables + real :: omega_w2s, omega_tau2s, omega_s2x, omega_tau2x, omega_tau2w, omega_s2w !< intermediate angles + integer :: kblmin, kbld, kp1, k, nz !< vertical indices + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq ! horizontal indices + + is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke + + pi = 4. * atan2(1.,1.) + Cemp_CG = 3.6 + kblmin = 1 + taux_u(:,:) = 0. + tauy_v(:,:) = 0. + + do j = js,je + do I = Isq,Ieq + taux_u(I,j) = forces%taux(I,j) / GV%H_to_RZ !W rho0=1035. + enddo + enddo + + do J = Jsq,Jeq + do i = is,ie + tauy_v(i,J) = forces%tauy(i,J) / GV%H_to_RZ + enddo + enddo + + call pass_var( hbl_h ,G%Domain, halo=1 ) + call pass_vector(taux_u , tauy_v, G%Domain, To_All ) + ustar2_u(:,:) = 0. + ustar2_v(:,:) = 0. + hbl_u(:,:) = 0. + hbl_v(:,:) = 0. + kbl_u(:,:) = 0 + kbl_v(:,:) = 0 + !omega_w2x_u(:,:) = 0.0 + !omega_w2x_v(:,:) = 0.0 + tauxDG_u(:,:,:) = 0.0 + tauyDG_v(:,:,:) = 0.0 + do j = js,je + do I = Isq,Ieq + if( (G%mask2dCu(I,j) > 0.5) ) then + tmp = MAX (1.0 ,(G%mask2dT(i,j) + G%mask2dT(i+1,j) ) ) + hbl_u(I,j) = (G%mask2dT(i,j)* hbl_h(i,j) + G%mask2dT(i+1,j) * hbl_h(i+1,j)) /tmp + tmp = MAX(1.0, (G%mask2dCv(i,j) + G%mask2dCv(i,j-1) + G%mask2dCv(i+1,j) + G%mask2dCv(i+1,j-1) ) ) + tauy = ( G%mask2dCv(i ,j )*tauy_v(i ,j ) + G%mask2dCv(i ,j-1)*tauy_v(i ,j-1) & + + G%mask2dCv(i+1,j )*tauy_v(i+1,j ) + G%mask2dCv(i+1,j-1)*tauy_v(i+1,j-1) ) / tmp + ustar2_u(I,j) = sqrt( taux_u(I,j)*taux_u(I,j) + tauy*tauy ) + !omega_w2x_u(I,j) = atan2( tauy , taux_u(I,j) ) + tauxDG_u(I,j,1) = taux_u(I,j) + depth = 0.0 + do k = 1, nz + depth = depth + CS%h_u(I,j,k) + if( (depth >= hbl_u(I,j)) .and. (kbl_u(I,j) == 0 ) .and. (k > (kblmin-1)) ) then + kbl_u(I,j) = k + hbl_u(I,j) = depth + endif + enddo + endif + enddo + enddo + do J = Jsq,Jeq + do i = is,ie + if( (G%mask2dCv(i,J) > 0.5) ) then + tmp = max( 1.0 ,(G%mask2dT(i,j) + G%mask2dT(i,j+1))) + hbl_v(i,J) = (G%mask2dT(i,j) * hbl_h(i,J) + G%mask2dT(i,j+1) * hbl_h(i,j+1)) /tmp + tmp = max(1.0, (G%mask2dCu(i,j) + G%mask2dCu(i,j+1) + G%mask2dCu(i-1,j) + G%mask2dCu(i-1,j+1))) + taux = ( G%mask2dCu(i ,j) * taux_u(i ,j) + G%mask2dCu(i ,j+1) * taux_u(i ,j+1) & + + G%mask2dCu(i-1,j) * taux_u(i-1,j) + G%mask2dCu(i-1,j+1) * taux_u(i-1,j+1)) / tmp + ustar2_v(i,J) = sqrt(tauy_v(i,J)*tauy_v(i,J) + taux*taux) + !omega_w2x_v(i,J) = atan2( tauy_v(i,J), taux ) + tauyDG_v(i,J,1) = tauy_v(i,J) + depth = 0.0 + do k = 1, nz + depth = depth + CS%h_v(i,J,k) + if( (depth >= hbl_v(i,J)) .and. (kbl_v(i,J) == 0) .and. (k > (kblmin-1))) then + kbl_v(i,J) = k + hbl_v(i,J) = depth + endif + enddo + endif + enddo + enddo + + if (CS%debug) then + call uvchksum("surface tau[xy]_[uv] ", taux_u, tauy_v, G%HI, haloshift=1, scalar_pair=.true.) + call uvchksum("ustar2", ustar2_u, ustar2_v, G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum(" hbl", hbl_u , hbl_v , G%HI, haloshift=0, scalar_pair=.true.) + endif + + ! Compute downgradient stresses + do k = 1, nz + kp1 = min( k+1 , nz) + do j = js ,je + do I = Isq , Ieq + tauxDG_u(I,j,k+1) = CS%a_u(I,j,kp1) * (ui(I,j,k) - ui(I,j,kp1)) + enddo + enddo + do J = Jsq , Jeq + do i = is , ie + tauyDG_v(i,J,k+1) = CS%a_v(i,J,kp1) * (vi(i,J,k) - vi(i,J,kp1)) + enddo + enddo + enddo + + call pass_vector(tauxDG_u, tauyDG_v , G%Domain, To_All) + call pass_vector(ui,vi, G%Domain, To_All) + tauxDG_v(:,:,:) = 0. + tauyDG_u(:,:,:) = 0. + + ! Thickness weighted interpolations + do k = 1, nz + ! v to u points + do j = js , je + do I = Isq, Ieq + tauyDG_u(I,j,k) = set_v_at_u(tauyDG_v, h, G, GV, I, j, k, G%mask2dCv, OBC) + enddo + enddo + ! u to v points + do J = Jsq, Jeq + do i = is, ie + tauxDG_v(i,J,k) = set_u_at_v(tauxDG_u, h, G, GV, i, J, k, G%mask2dCu, OBC) + enddo + enddo + enddo + if (CS%debug) then + call uvchksum(" tauyDG_u tauxDG_v",tauyDG_u,tauxDG_v, G%HI, haloshift=0, scalar_pair=.true.) + endif + + ! compute angles, tau2x_[u,v], tau2w_[u,v], tau2s_[u,v], s2w_[u,v] and stress mag tau_[u,v] + omega_tau2w_u(:,:,:) = 0.0 + omega_tau2w_v(:,:,:) = 0.0 + omega_tau2s_u(:,:,:) = 0.0 + omega_tau2s_v(:,:,:) = 0.0 + tau_u(:,:,:) = 0.0 + tau_v(:,:,:) = 0.0 + + ! stress magnitude tau_[uv] & direction Omega_tau2(w,s,x)_[uv] + do j = js,je + do I = Isq,Ieq + if( (G%mask2dCu(I,j) > 0.5) ) then + ! SURFACE + tauyDG_u(I,j,1) = ustar2_u(I,j) !* cos(omega_w2x_u(I,j)) + tau_u(I,j,1) = ustar2_u(I,j) + Omega_tau2w_u(I,j,1) = 0.0 + Omega_tau2s_u(I,j,1) = 0.0 + + do k=1,nz + kp1 = MIN(k+1 , nz) + tau_u(I,j,k+1) = sqrt( tauxDG_u(I,j,k+1)*tauxDG_u(I,j,k+1) + tauyDG_u(I,j,k+1)*tauyDG_u(I,j,k+1)) + Omega_tau2x = atan2( tauyDG_u(I,j,k+1) , tauxDG_u(I,j,k+1) ) + omega_tmp = Omega_tau2x !- omega_w2x_u(I,j) + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + Omega_tau2w_u(I,j,k+1) = omega_tmp + Omega_tau2s_u(I,j,k+1) = 0.0 + enddo + endif + enddo + enddo + do J = Jsq, Jeq + do i = is, ie + if( (G%mask2dCv(i,J) > 0.5) ) then + ! SURFACE + tauxDG_v(i,J,1) = ustar2_v(i,J) !* sin(omega_w2x_v(i,J)) + tau_v(i,J,1) = ustar2_v(i,J) + Omega_tau2w_v(i,J,1) = 0.0 + Omega_tau2s_v(i,J,1) = 0.0 + + do k=1,nz-1 + kp1 = MIN(k+1 , nz) + tau_v(i,J,k+1) = sqrt ( tauxDG_v(i,J,k+1)*tauxDG_v(i,J,k+1) + tauyDG_v(i,J,k+1)*tauyDG_v(i,J,k+1) ) + omega_tau2x = atan2( tauyDG_v(i,J,k+1) , tauxDG_v(i,J,k+1) ) + omega_tmp = omega_tau2x !- omega_w2x_v(i,J) + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + Omega_tau2w_v(i,J,k+1) = omega_tmp + Omega_tau2s_v(i,J,k+1) = 0.0 + enddo + endif + enddo + enddo + + ! Parameterized stress orientation from the wind at interfaces (tau2x) + ! and centers (tau2x) OVERWRITE to kbl-interface above hbl + do j = js,je + do I = Isq,Ieq + if( (G%mask2dCu(I,j) > 0.5) ) then + kbld = min( (kbl_u(I,j)) , (nz-2) ) + if ( tau_u(I,j,kbld+2) > tau_u(I,j,kbld+1) ) kbld = kbld + 1 + + tauh = tau_u(I,j,kbld+1) + GV%H_subroundoff + ! surface boundary conditions + depth = 0. + tauNLup = 0.0 + do k=1, kbld + depth = depth + CS%h_u(I,j,k) + sigma = min( 1.0 , depth / hbl_u(i,j) ) + + ! linear stress mag + tau_MAG = (ustar2_u(I,j) * (1.-sigma) ) + (tauh * sigma ) + cos_tmp = tauxDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) + sin_tmp = tauyDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) + + ! rotate to wind coordinates + Wind_x = ustar2_u(I,j) !* cos(omega_w2x_u(I,j)) + Wind_y = ustar2_u(I,j) !* sin(omega_w2x_u(I,j)) + tauNL_DG = (Wind_x * cos_tmp + Wind_y * sin_tmp) + tauNL_CG = (Wind_y * cos_tmp - Wind_x * sin_tmp) + omega_w2s = atan2(tauNL_CG, tauNL_DG) + omega_s2w = 0.0-omega_w2s + tauNL_CG = Cemp_CG * G_sig(sigma) * tauNL_CG + tau_MAG = max(tau_MAG, tauNL_CG) + tauNL_DG = sqrt(tau_MAG*tau_MAG - tauNL_CG*tauNL_CG) - tau_u(I,j,k+1) + + ! back to x,y coordinates + tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp) + tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp) + tauNLdn = tauNL_X + + ! nonlocal increment and update to uold + du = (tauNLup - tauNLdn) * (dt/CS%h_u(I,j,k) + GV%H_subroundoff) + ui(I,j,k) = uold(I,j,k) + du + uold(I,j,k) = du + tauNLup = tauNLdn + + ! diagnostics + Omega_tau2s_u(I,j,k+1) = atan2(tauNL_CG , (tau_u(I,j,k+1)+tauNL_DG)) + tau_u(I,j,k+1) = sqrt((tauxDG_u(I,j,k+1) + tauNL_X)**2 + (tauyDG_u(I,j,k+1) + tauNL_Y)**2) + omega_tau2x = atan2((tauyDG_u(I,j,k+1) + tauNL_Y), (tauxDG_u(I,j,k+1) + tauNL_X)) + omega_tau2w = omega_tau2x !- omega_w2x_u(I,j) + if (omega_tau2w >= pi ) omega_tau2w = omega_tau2w - 2.*pi + if (omega_tau2w <= (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi + Omega_tau2w_u(I,j,k+1) = omega_tau2w + enddo + do k= kbld+1, nz + ui(I,j,k) = uold(I,j,k) + uold(I,j,k) = 0.0 + enddo + endif + enddo + enddo + + ! v-point dv increment + do J = Jsq,Jeq + do i = is,ie + if( (G%mask2dCv(i,J) > 0.5) ) then + kbld = min((kbl_v(i,J)), (nz-2)) + if (tau_v(i,J,kbld+2) > tau_v(i,J,kbld+1)) kbld = kbld + 1 + tauh = tau_v(i,J,kbld+1) + + !surface boundary conditions + depth = 0. + tauNLup = 0.0 + do k=1, kbld + depth = depth + CS%h_v(i,J,k) + sigma = min(1.0, depth/ hbl_v(I,J)) + + ! linear stress + tau_MAG = (ustar2_v(i,J) * (1.-sigma)) + (tauh * sigma) + cos_tmp = tauxDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) + sin_tmp = tauyDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) + + ! rotate into wind coordinate + Wind_x = ustar2_v(i,J) !* cos(omega_w2x_v(i,J)) + Wind_y = ustar2_v(i,J) !* sin(omega_w2x_v(i,J)) + tauNL_DG = (Wind_x * cos_tmp + Wind_y * sin_tmp) + tauNL_CG = (Wind_y * cos_tmp - Wind_x * sin_tmp) + omega_w2s = atan2(tauNL_CG , tauNL_DG) + omega_s2w = 0.0 - omega_w2s + tauNL_CG = Cemp_CG * G_sig(sigma) * tauNL_CG + tau_MAG = max( tau_MAG , tauNL_CG ) + tauNL_DG = 0.0 - tau_v(i,J,k+1) + sqrt(tau_MAG*tau_MAG - tauNL_CG*tauNL_CG) + + ! back to x,y coordinate + tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp) + tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp) + tauNLdn = tauNL_Y + dv = (tauNLup - tauNLdn) * (dt/(CS%h_v(i,J,k)) ) + vi(i,J,k) = vold(i,J,k) + dv + vold(i,J,k) = dv + tauNLup = tauNLdn + + ! diagnostics + Omega_tau2s_v(i,J,k+1) = atan2(tauNL_CG, tau_v(i,J,k+1) + tauNL_DG) + tau_v(i,J,k+1) = sqrt((tauxDG_v(i,J,k+1) + tauNL_X)**2 + (tauyDG_v(i,J,k+1) + tauNL_Y)**2) + !omega_tau2x = atan2((tauyDG_v(i,J,k+1) + tauNL_Y) , (tauxDG_v(i,J,k+1) + tauNL_X)) + !omega_tau2w = omega_tau2x - omega_w2x_v(i,J) + if (omega_tau2w > pi) omega_tau2w = omega_tau2w - 2.*pi + if (omega_tau2w .le. (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi + Omega_tau2w_v(i,J,k+1) = omega_tau2w + enddo + + do k= kbld+1, nz + vi(i,J,k) = vold(i,J,k) + vold(i,J,k) = 0.0 + enddo + endif + enddo + enddo + + if (CS%debug) then + call uvchksum("FP-tau_[uv] ", tau_u, tau_v, G%HI, haloshift=0, scalar_pair=.true.) + endif + + if (CS%id_tauFP_u > 0) call post_data(CS%id_tauFP_u, tau_u, CS%diag) + if (CS%id_tauFP_v > 0) call post_data(CS%id_tauFP_v, tau_v, CS%diag) + if (CS%id_FPtau2s_u > 0) call post_data(CS%id_FPtau2s_u, omega_tau2s_u, CS%diag) + if (CS%id_FPtau2s_v > 0) call post_data(CS%id_FPtau2s_v, omega_tau2s_v, CS%diag) + if (CS%id_FPtau2w_u > 0) call post_data(CS%id_FPtau2w_u, omega_tau2w_u, CS%diag) + if (CS%id_FPtau2w_v > 0) call post_data(CS%id_FPtau2w_v, omega_tau2w_v, CS%diag) + !if (CS%id_FPw2x > 0) call post_data(CS%id_FPw2x, forces%omega_w2x , CS%diag) + +end subroutine vertFPmix + +!> Returns the empirical shape-function given sigma. +real function G_sig(sigma) + real , intent(in) :: sigma !< non-dimensional normalized boundary layer depth [m] + + ! local variables + real :: p1, c2, c3 !< parameters used to fit and match empirycal shape-functions. + + ! parabola + p1 = 0.287 + ! cubic function + c2 = 1.74392 + c3 = 2.58538 + G_sig = min( p1 * (1.-sigma)*(1.-sigma) , sigma * (1. + sigma * (c2*sigma - c3) ) ) +end function G_sig + +!> Compute coupling coefficient associated with vertical viscosity parameterization as in Greatbatch and Lamb +!! (1990), hereafter referred to as the GL90 vertical viscosity parameterization. This vertical viscosity scheme +!! redistributes momentum in the vertical, and is the equivalent of the Gent & McWilliams (1990) parameterization, +!! but in a TWA (thickness-weighted averaged) set of equations. The vertical viscosity coefficient nu is computed +!! from kappa_GM via thermal wind balance, and the following relation: +!! nu = kappa_GM * f^2 / N^2. +!! In the following subroutine kappa_GM is assumed either (a) constant or (b) horizontally varying. In both cases, +!! (a) and (b), one can additionally impose an EBT structure in the vertical for kappa_GM. +!! A third possible formulation of nu is depth-independent: +!! nu = f^2 * alpha +!! The latter formulation would be equivalent to a kappa_GM that varies as N^2 with depth. +!! The vertical viscosity del_z ( nu del_z u) is applied to the momentum equation with stress-free boundary +!! conditions at the top and bottom. +!! +!! In SSW mode, we have 1/N^2 = h/g'. The coupling coefficient is therefore equal to +!! a_cpl_gl90 = nu / h = kappa_GM * f^2 / g' +!! or +!! a_cpl_gl90 = nu / h = f^2 * alpha / h + +subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, VarMix, work_on_u) + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: hvel !< Distance between interfaces + !! at velocity points [Z ~> m] + logical, dimension(SZIB_(G)), intent(in) :: do_i !< If true, determine coupling coefficient + !! for a column + real, dimension(SZIB_(G),SZK_(GV)+1), intent(in) :: z_i !< Estimate of interface heights above the + !! bottom, normalized by the GL90 bottom + !! boundary layer thickness [nondim] + real, dimension(SZIB_(G),SZK_(GV)+1), intent(inout) :: a_cpl_gl90 !< Coupling coefficient associated + !! with GL90 across interfaces; is not + !! included in a_cpl [H T-1 ~> m s-1 or Pa s m-1]. + integer, intent(in) :: j !< j-index to find coupling coefficient for + type(vertvisc_cs), pointer :: CS !< Vertical viscosity control structure + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients + logical, intent(in) :: work_on_u !< If true, u-points are being calculated, + !! otherwise they are v-points. + + ! local variables + logical :: kdgl90_use_ebt_struct + integer :: i, k, is, ie, nz, Isq, Ieq + real :: f2 !< Squared Coriolis parameter at a velocity grid point [T-2 ~> s-2]. + real :: h_neglect ! A vertical distance that is so small it is usually lost in roundoff error + ! and can be neglected [Z ~> m]. + real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] + real :: z2 ! The distance from the bottom, normalized by Hbbl_gl90 [nondim] + + is = G%isc ; ie = G%iec + Isq = G%IscB ; Ieq = G%IecB + nz = GV%ke + + h_neglect = GV%dZ_subroundoff + kdgl90_use_ebt_struct = .false. + if (VarMix%use_variable_mixing) then + kdgl90_use_ebt_struct = VarMix%kdgl90_use_ebt_struct + endif + + if (work_on_u) then + ! compute coupling coefficient at u-points + do I=Isq,Ieq; if (do_i(I)) then + f2 = 0.25 * (G%CoriolisBu(I,J-1) + G%CoriolisBu(I,J))**2 + do K=2,nz + if (CS%use_GL90_N2) then + a_cpl_gl90(I,K) = 2.0 * f2 * CS%alpha_gl90 / (hvel(I,k) + hvel(I,k-1) + h_neglect) + else + if (CS%read_kappa_gl90) then + a_cpl_gl90(I,K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i+1,j)) / GV%g_prime(K) + else + a_cpl_gl90(I,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) + endif + if (kdgl90_use_ebt_struct) then + a_cpl_gl90(I,K) = a_cpl_gl90(I,K) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + endif + endif + ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, + ! going from 1 at the bottom to 0 in the interior. + z2 = z_i(I,k) + botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) + a_cpl_gl90(I,K) = a_cpl_gl90(I,K) * (1 - botfn) + enddo + endif; enddo + else + ! compute viscosities at v-points + do i=is,ie; if (do_i(i)) then + f2 = 0.25 * (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J))**2 + do K=2,nz + if (CS%use_GL90_N2) then + a_cpl_gl90(i,K) = 2.0 * f2 * CS%alpha_gl90 / (hvel(i,k) + hvel(i,k-1) + h_neglect) + else + if (CS%read_kappa_gl90) then + a_cpl_gl90(i,K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i,j+1)) / GV%g_prime(K) + else + a_cpl_gl90(i,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) + endif + if (kdgl90_use_ebt_struct) then + a_cpl_gl90(i,K) = a_cpl_gl90(i,K) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + endif + endif + ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, + ! going from 1 at the bottom to 0 in the interior. + z2 = z_i(i,k) + botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) + a_cpl_gl90(i,K) = a_cpl_gl90(i,K) * (1 - botfn) + enddo + endif; enddo + endif + +end subroutine find_coupling_coef_gl90 + +!> Perform a fully implicit vertical diffusion +!! of momentum. Stress top and bottom boundary conditions are used. +!! +!! This is solving the tridiagonal system +!! \f[ \left(h_k + a_{k + 1/2} + a_{k - 1/2} + r_k\right) u_k^{n+1} +!! = h_k u_k^n + a_{k + 1/2} u_{k+1}^{n+1} + a_{k - 1/2} u_{k-1}^{n+1} \f] +!! where \f$a_{k + 1/2} = \Delta t \nu_{k + 1/2} / h_{k + 1/2}\f$ +!! is the interfacial coupling thickness per time step, +!! encompassing background viscosity as well as contributions from +!! enhanced mixed and bottom layer viscosities. +!! $r_k$ is a Rayleigh drag term due to channel drag. +!! There is an additional stress term on the right-hand side +!! if DIRECT_STRESS is true, applied to the surface layer. + +subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & + taux_bot, tauy_bot, Waves) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(vertvisc_type), intent(inout) :: visc !< Viscosities and bottom drag + real, intent(in) :: dt !< Time increment [T ~> s] + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + type(accel_diag_ptrs), intent(inout) :: ADp !< Accelerations in the momentum + !! equations for diagnostics + type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation terms + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(out) :: taux_bot !< Zonal bottom stress from ocean to + !! rock [R L Z T-2 ~> Pa] + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(out) :: tauy_bot !< Meridional bottom stress from ocean to + !! rock [R L Z T-2 ~> Pa] + type(wave_parameters_CS), & + optional, pointer :: Waves !< Container for wave/Stokes information + + ! Fields from forces used in this subroutine: + ! taux: Zonal wind stress [R L Z T-2 ~> Pa]. + ! tauy: Meridional wind stress [R L Z T-2 ~> Pa]. + + ! Local variables + + real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. + real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. + real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + + real :: Hmix ! The mixed layer thickness over which stress + ! is applied with direct_stress [H ~> m or kg m-2]. + real :: I_Hmix ! The inverse of Hmix [H-1 ~> m-1 or m2 kg-1]. + real :: Idt ! The inverse of the time step [T-1 ~> s-1]. + real :: dt_Rho0 ! The time step divided by the mean density [T H Z-1 R-1 ~> s m3 kg-1 or s]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + + real :: stress ! The surface stress times the time step, divided + ! by the density [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: accel_underflow ! An acceleration magnitude that is so small that values that are less + ! than this are diagnosed as 0 [L T-2 ~> m s-2]. + real :: zDS, h_a ! Temporary thickness variables used with direct_stress [H ~> m or kg m-2] + real :: hfr ! Temporary ratio of thicknesses used with direct_stress [nondim] + real :: surface_stress(SZIB_(G))! The same as stress, unless the wind stress + ! stress is applied as a body force [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real, allocatable, dimension(:,:,:) :: KE_term ! A term in the kinetic energy budget + ! [H L2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:,:) :: KE_u ! The area integral of a KE term in a layer at u-points + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + real, allocatable, dimension(:,:,:) :: KE_v ! The area integral of a KE term in a layer at v-points + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + + logical :: do_i(SZIB_(G)) + logical :: DoStokesMixing + + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n + is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke + + if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & + "Module must be initialized before it is used.") + + if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & + "Module must be initialized before it is used.") + + if (CS%id_GLwork > 0) then + allocate(KE_u(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.0) + allocate(KE_v(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.0) + allocate(KE_term(G%isd:G%ied,G%jsd:G%jed,GV%ke), source=0.0) + if (.not.G%symmetric) & + call create_group_pass(CS%pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) + endif + + if (CS%direct_stress) then + Hmix = CS%Hmix_stress + I_Hmix = 1.0 / Hmix + endif + dt_Rho0 = dt / GV%H_to_RZ + h_neglect = GV%H_subroundoff + Idt = 1.0 / dt + + accel_underflow = CS%vel_underflow * Idt + + !Check if Stokes mixing allowed if requested (present and associated) + DoStokesMixing=.false. + if (CS%StokesMixing) then + if (present(Waves)) DoStokesMixing = associated(Waves) + if (.not. DoStokesMixing) & + call MOM_error(FATAL,"Stokes Mixing called without allocated"//& + "Waves Control Structure") + endif + + do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo + + ! Update the zonal velocity component using a modification of a standard + ! tridagonal solver. + + !$OMP parallel do default(shared) firstprivate(Ray) & + !$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.0) ; enddo + + ! When mixing down Eulerian current + Stokes drift add before calling solver + if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) + enddo ; enddo ; endif + + if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq + ADp%du_dt_visc(I,j,k) = u(I,j,k) + enddo ; enddo ; endif + if (associated(ADp%du_dt_visc_gl90)) then ; do k=1,nz ; do I=Isq,Ieq + ADp%du_dt_visc_gl90(I,j,k) = u(I,j,k) + enddo ; enddo ; endif + if (associated(ADp%du_dt_str)) then ; do k=1,nz ; do I=Isq,Ieq + ADp%du_dt_str(I,j,k) = 0.0 + enddo ; enddo ; endif + + ! One option is to have the wind stress applied as a body force + ! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, + ! the wind stress is applied as a stress boundary condition. + if (CS%direct_stress) then + do I=Isq,Ieq ; if (do_i(I)) then + surface_stress(I) = 0.0 + zDS = 0.0 + stress = dt_Rho0 * forces%taux(I,j) + do k=1,nz + h_a = 0.5 * (h(i,j,k) + h(i+1,j,k)) + h_neglect + hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a + u(I,j,k) = u(I,j,k) + I_Hmix * hfr * stress + if (associated(ADp%du_dt_str)) ADp%du_dt_str(i,J,k) = (I_Hmix * hfr * stress) * Idt + zDS = zDS + h_a ; if (zDS >= Hmix) exit + enddo + endif ; enddo ! end of i loop + else ; do I=Isq,Ieq + surface_stress(I) = dt_Rho0 * (G%mask2dCu(I,j)*forces%taux(I,j)) + enddo ; endif ! direct_stress + + if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq + Ray(I,k) = visc%Ray_u(I,j,k) + enddo ; enddo ; endif + + ! perform forward elimination on the tridiagonal system + ! + ! denote the diagonal of the system as b_k, the subdiagonal as a_k + ! and the superdiagonal as c_k. The right-hand side terms are d_k. + ! + ! ignoring the Rayleigh drag contribution, + ! we have a_k = -dt * a_u(k) + ! b_k = h_u(k) + dt * (a_u(k) + a_u(k+1)) + ! c_k = -dt * a_u(k+1) + ! + ! for forward elimination, we want to: + ! calculate c'_k = - c_k / (b_k + a_k c'_(k-1)) + ! and d'_k = (d_k - a_k d'_(k-1)) / (b_k + a_k c'_(k-1)) + ! where c'_1 = c_1/b_1 and d'_1 = d_1/b_1 + ! + ! This form is mathematically equivalent to Thomas' tridiagonal matrix algorithm, but it + ! does not suffer from the acute sensitivity to truncation errors of the Thomas algorithm + ! because it involves no subtraction, as discussed by Schopf & Loughe, MWR, 1995. + ! + ! b1 is the denominator term 1 / (b_k + a_k c'_(k-1)) + ! b_denom_1 is (b_k + a_k + c_k) - a_k(1 - c'_(k-1)) + ! = (b_k + c_k + c'_(k-1)) + ! this is done so that d1 = b1 * b_denom_1 = 1 - c'_(k-1) + ! c1(k) is -c'_(k - 1) + ! and the right-hand-side is destructively updated to be d'_k + ! + do I=Isq,Ieq ; if (do_i(I)) then + b_denom_1 = CS%h_u(I,j,1) + dt * (Ray(I,1) + CS%a_u(I,j,1)) + b1(I) = 1.0 / (b_denom_1 + dt*CS%a_u(I,j,2)) + d1(I) = b_denom_1 * b1(I) + u(I,j,1) = b1(I) * (CS%h_u(I,j,1) * u(I,j,1) + surface_stress(I)) + if (associated(ADp%du_dt_str)) & + ADp%du_dt_str(I,j,1) = b1(I) * (CS%h_u(I,j,1) * ADp%du_dt_str(I,j,1) + surface_stress(I)*Idt) + endif ; enddo + do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then + c1(I,k) = dt * CS%a_u(I,j,K) * b1(I) + b_denom_1 = CS%h_u(I,j,k) + dt * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) + b1(I) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) + d1(I) = b_denom_1 * b1(I) + u(I,j,k) = (CS%h_u(I,j,k) * u(I,j,k) + & + dt * CS%a_u(I,j,K) * u(I,j,k-1)) * b1(I) + if (associated(ADp%du_dt_str)) & + ADp%du_dt_str(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_str(I,j,k) + & + dt * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1(I) + endif ; enddo ; enddo + + ! back substitute to solve for the new velocities + ! u_k = d'_k - c'_k x_(k+1) + do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then + u(I,j,k) = u(I,j,k) + c1(I,k+1) * u(I,j,k+1) + endif ; enddo ; enddo ! i and k loops + + if (associated(ADp%du_dt_str)) then + do i=is,ie ; if (abs(ADp%du_dt_str(I,j,nz)) < accel_underflow) ADp%du_dt_str(I,j,nz) = 0.0 ; enddo + do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then + ADp%du_dt_str(I,j,k) = ADp%du_dt_str(I,j,k) + c1(I,k+1) * ADp%du_dt_str(I,j,k+1) + if (abs(ADp%du_dt_str(I,j,k)) < accel_underflow) ADp%du_dt_str(I,j,k) = 0.0 + endif ; enddo ; enddo + endif + + ! compute vertical velocity tendency that arises from GL90 viscosity; + ! follow tridiagonal solve method as above; to avoid corrupting u, + ! use ADp%du_dt_visc_gl90 as a placeholder for updated u (due to GL90) until last do loop + if ((CS%id_du_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + if (associated(ADp%du_dt_visc_gl90)) then + do I=Isq,Ieq ; if (do_i(I)) then + b_denom_1 = CS%h_u(I,j,1) ! CS%a_u_gl90(I,j,1) is zero + b1(I) = 1.0 / (b_denom_1 + dt*CS%a_u_gl90(I,j,2)) + d1(I) = b_denom_1 * b1(I) + ADp%du_dt_visc_gl90(I,j,1) = b1(I) * (CS%h_u(I,j,1) * ADp%du_dt_visc_gl90(I,j,1)) + endif ; enddo + do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then + c1(I,k) = dt * CS%a_u_gl90(I,j,K) * b1(I) + b_denom_1 = CS%h_u(I,j,k) + dt * (CS%a_u_gl90(I,j,K)*d1(I)) + b1(I) = 1.0 / (b_denom_1 + dt * CS%a_u_gl90(I,j,K+1)) + d1(I) = b_denom_1 * b1(I) + ADp%du_dt_visc_gl90(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_visc_gl90(I,j,k) + & + dt * CS%a_u_gl90(I,j,K) * ADp%du_dt_visc_gl90(I,j,k-1)) * b1(I) + endif ; enddo ; enddo + ! back substitute to solve for new velocities, held by ADp%du_dt_visc_gl90 + do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then + ADp%du_dt_visc_gl90(I,j,k) = ADp%du_dt_visc_gl90(I,j,k) + c1(I,k+1) * ADp%du_dt_visc_gl90(I,j,k+1) + endif ; enddo ; enddo ! i and k loops + do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) then + ! now fill ADp%du_dt_visc_gl90(I,j,k) with actual velocity tendency due to GL90; + ! note that on RHS: ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k) + ! and ADp%du_dt_visc_gl90(I,j,k) the updated velocity due to GL90 + ADp%du_dt_visc_gl90(I,j,k) = (ADp%du_dt_visc_gl90(I,j,k) - ADp%du_dt_visc(I,j,k))*Idt + if (abs(ADp%du_dt_visc_gl90(I,j,k)) < accel_underflow) ADp%du_dt_visc_gl90(I,j,k) = 0.0 + endif ; enddo ; enddo ; + ! to compute energetics, we need to multiply by u*h, where u is original velocity before + ! velocity update; note that ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k) + if (CS%id_GLwork > 0) then + do k=1,nz; do I=Isq,Ieq ; if (do_i(I)) then + KE_u(I,j,k) = ADp%du_dt_visc(I,j,k) * CS%h_u(I,j,k) * G%areaCu(I,j) * ADp%du_dt_visc_gl90(I,j,k) + endif ; enddo ; enddo + endif + endif + endif + + if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq + ADp%du_dt_visc(I,j,k) = (u(I,j,k) - ADp%du_dt_visc(I,j,k))*Idt + if (abs(ADp%du_dt_visc(I,j,k)) < accel_underflow) ADp%du_dt_visc(I,j,k) = 0.0 + enddo ; enddo ; endif + + if (allocated(visc%taux_shelf)) then ; do I=Isq,Ieq + visc%taux_shelf(I,j) = -GV%H_to_RZ*CS%a1_shelf_u(I,j)*u(I,j,1) ! - u_shelf? + enddo ; endif + + if (PRESENT(taux_bot)) then + do I=Isq,Ieq + taux_bot(I,j) = GV%H_to_RZ * (u(I,j,nz)*CS%a_u(I,j,nz+1)) + enddo + if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq + taux_bot(I,j) = taux_bot(I,j) + GV%H_to_RZ * (Ray(I,k)*u(I,j,k)) + enddo ; enddo ; endif + endif + + ! When mixing down Eulerian current + Stokes drift subtract after calling solver + if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) + enddo ; enddo ; endif + + enddo ! end u-component j loop + + ! Now work on the meridional velocity component. + + !$OMP parallel do default(shared) firstprivate(Ray) & + !$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.0) ; enddo + + ! When mixing down Eulerian current + Stokes drift add before calling solver + if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie + if (do_i(i)) v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) + enddo ; enddo ; endif + + if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie + ADp%dv_dt_visc(i,J,k) = v(i,J,k) + enddo ; enddo ; endif + if (associated(ADp%dv_dt_visc_gl90)) then ; do k=1,nz ; do i=is,ie + ADp%dv_dt_visc_gl90(i,J,k) = v(i,J,k) + enddo ; enddo ; endif + if (associated(ADp%dv_dt_str)) then ; do k=1,nz ; do i=is,ie + ADp%dv_dt_str(i,J,k) = 0.0 + enddo ; enddo ; endif + + ! One option is to have the wind stress applied as a body force + ! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, + ! the wind stress is applied as a stress boundary condition. + if (CS%direct_stress) then + do i=is,ie ; if (do_i(i)) then + surface_stress(i) = 0.0 + zDS = 0.0 + stress = dt_Rho0 * forces%tauy(i,J) + do k=1,nz + h_a = 0.5 * (h(i,J,k) + h(i,J+1,k)) + h_neglect + hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a + v(i,J,k) = v(i,J,k) + I_Hmix * hfr * stress + if (associated(ADp%dv_dt_str)) ADp%dv_dt_str(i,J,k) = (I_Hmix * hfr * stress) * Idt + zDS = zDS + h_a ; if (zDS >= Hmix) exit + enddo + endif ; enddo ! end of i loop + else ; do i=is,ie + surface_stress(i) = dt_Rho0 * (G%mask2dCv(i,J)*forces%tauy(i,J)) + enddo ; endif ! direct_stress + + if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie + Ray(i,k) = visc%Ray_v(i,J,k) + enddo ; enddo ; endif + + do i=is,ie ; if (do_i(i)) then + b_denom_1 = CS%h_v(i,J,1) + dt * (Ray(i,1) + CS%a_v(i,J,1)) + b1(i) = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) + d1(i) = b_denom_1 * b1(i) + v(i,J,1) = b1(i) * (CS%h_v(i,J,1) * v(i,J,1) + surface_stress(i)) + if (associated(ADp%dv_dt_str)) & + ADp%dv_dt_str(i,J,1) = b1(i) * (CS%h_v(i,J,1) * ADp%dv_dt_str(i,J,1) + surface_stress(i)*Idt) + endif ; enddo + do k=2,nz ; do i=is,ie ; if (do_i(i)) then + c1(i,k) = dt * CS%a_v(i,J,K) * b1(i) + b_denom_1 = CS%h_v(i,J,k) + dt * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) + b1(i) = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) + d1(i) = b_denom_1 * b1(i) + v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt * CS%a_v(i,J,K) * v(i,J,k-1)) * b1(i) + if (associated(ADp%dv_dt_str)) & + ADp%dv_dt_str(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_str(i,J,k) + & + dt * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1(i) + endif ; enddo ; enddo + do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then + v(i,J,k) = v(i,J,k) + c1(i,k+1) * v(i,J,k+1) + endif ; enddo ; enddo ! i and k loops + + if (associated(ADp%dv_dt_str)) then + do i=is,ie ; if (abs(ADp%dv_dt_str(i,J,nz)) < accel_underflow) ADp%dv_dt_str(i,J,nz) = 0.0 ; enddo + do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then + ADp%dv_dt_str(i,J,k) = ADp%dv_dt_str(i,J,k) + c1(i,k+1) * ADp%dv_dt_str(i,J,k+1) + if (abs(ADp%dv_dt_str(i,J,k)) < accel_underflow) ADp%dv_dt_str(i,J,k) = 0.0 + endif ; enddo ; enddo + endif + + ! compute vertical velocity tendency that arises from GL90 viscosity; + ! follow tridiagonal solve method as above; to avoid corrupting v, + ! use ADp%dv_dt_visc_gl90 as a placeholder for updated u (due to GL90) until last do loop + if ((CS%id_dv_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + if (associated(ADp%dv_dt_visc_gl90)) then + do i=is,ie ; if (do_i(i)) then + b_denom_1 = CS%h_v(i,J,1) ! CS%a_v_gl90(i,J,1) is zero + b1(i) = 1.0 / (b_denom_1 + dt*CS%a_v_gl90(i,J,2)) + d1(i) = b_denom_1 * b1(i) + ADp%dv_dt_visc_gl90(I,J,1) = b1(i) * (CS%h_v(i,J,1) * ADp%dv_dt_visc_gl90(i,J,1)) + endif ; enddo + do k=2,nz ; do i=is,ie ; if (do_i(i)) then + c1(i,k) = dt * CS%a_v_gl90(i,J,K) * b1(i) + b_denom_1 = CS%h_v(i,J,k) + dt * (CS%a_v_gl90(i,J,K)*d1(i)) + b1(i) = 1.0 / (b_denom_1 + dt * CS%a_v_gl90(i,J,K+1)) + d1(i) = b_denom_1 * b1(i) + ADp%dv_dt_visc_gl90(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_visc_gl90(i,J,k) + & + dt * CS%a_v_gl90(i,J,K) * ADp%dv_dt_visc_gl90(i,J,k-1)) * b1(i) + endif ; enddo ; enddo + ! back substitute to solve for new velocities, held by ADp%dv_dt_visc_gl90 + do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then + ADp%dv_dt_visc_gl90(i,J,k) = ADp%dv_dt_visc_gl90(i,J,k) + c1(i,k+1) * ADp%dv_dt_visc_gl90(i,J,k+1) + endif ; enddo ; enddo ! i and k loops + do k=1,nz ; do i=is,ie ; if (do_i(i)) then + ! now fill ADp%dv_dt_visc_gl90(i,J,k) with actual velocity tendency due to GL90; + ! note that on RHS: ADp%dv_dt_visc(i,J,k) holds the original velocity value v(i,J,k) + ! and ADp%dv_dt_visc_gl90(i,J,k) the updated velocity due to GL90 + ADp%dv_dt_visc_gl90(i,J,k) = (ADp%dv_dt_visc_gl90(i,J,k) - ADp%dv_dt_visc(i,J,k))*Idt + if (abs(ADp%dv_dt_visc_gl90(i,J,k)) < accel_underflow) ADp%dv_dt_visc_gl90(i,J,k) = 0.0 + endif ; enddo ; enddo ; + ! to compute energetics, we need to multiply by v*h, where u is original velocity before + ! velocity update; note that ADp%dv_dt_visc(I,j,k) holds the original velocity value v(i,J,k) + if (CS%id_GLwork > 0) then + do k=1,nz ; do i=is,ie ; if (do_i(i)) then + ! note that on RHS: ADp%dv_dt_visc(I,j,k) holds the original velocity value v(I,j,k) + KE_v(I,j,k) = ADp%dv_dt_visc(i,J,k) * CS%h_v(i,J,k) * G%areaCv(i,J) * ADp%dv_dt_visc_gl90(i,J,k) + endif ; enddo ; enddo + endif + endif + endif + + if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie + ADp%dv_dt_visc(i,J,k) = (v(i,J,k) - ADp%dv_dt_visc(i,J,k))*Idt + if (abs(ADp%dv_dt_visc(i,J,k)) < accel_underflow) ADp%dv_dt_visc(i,J,k) = 0.0 + enddo ; enddo ; endif + + if (allocated(visc%tauy_shelf)) then ; do i=is,ie + visc%tauy_shelf(i,J) = -GV%H_to_RZ*CS%a1_shelf_v(i,J)*v(i,J,1) ! - v_shelf? + enddo ; endif + + if (present(tauy_bot)) then + do i=is,ie + tauy_bot(i,J) = GV%H_to_RZ * (v(i,J,nz)*CS%a_v(i,J,nz+1)) + enddo + if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie + tauy_bot(i,J) = tauy_bot(i,J) + GV%H_to_RZ * (Ray(i,k)*v(i,J,k)) + enddo ; enddo ; endif + endif + + ! When mixing down Eulerian current + Stokes drift subtract after calling solver + if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie + if (do_i(i)) v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) + enddo ; enddo ; endif + + enddo ! end of v-component J loop + + ! Calculate the KE source from GL90 vertical viscosity [H L2 T-3 ~> m3 s-3]. + ! We do the KE-rate calculation here (rather than in MOM_diagnostics) to ensure + ! a sign-definite term. MOM_diagnostics does not have access to the velocities + ! and thicknesses used in the vertical solver, but rather uses a time-mean + ! barotropic transport [uv]h. + if (CS%id_GLwork > 0) then + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do k=1,nz + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * (KE_u(I,j,k) + KE_u(I-1,j,k) + KE_v(i,J,k) + KE_v(i,J-1,k)) + enddo ; enddo + enddo + call post_data(CS%id_GLwork, KE_term, CS%diag) + endif + + call vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS) + + ! Here the velocities associated with open boundary conditions are applied. + if (associated(OBC)) then + do n=1,OBC%number_of_segments + if (OBC%segment(n)%specified) then + if (OBC%segment(n)%is_N_or_S) then + J = OBC%segment(n)%HI%JsdB + do k=1,nz ; do i=OBC%segment(n)%HI%isd,OBC%segment(n)%HI%ied + v(i,J,k) = OBC%segment(n)%normal_vel(i,J,k) + enddo ; enddo + elseif (OBC%segment(n)%is_E_or_W) then + I = OBC%segment(n)%HI%IsdB + do k=1,nz ; do j=OBC%segment(n)%HI%jsd,OBC%segment(n)%HI%jed + u(I,j,k) = OBC%segment(n)%normal_vel(I,j,k) + enddo ; enddo + endif + endif + enddo + endif + + ! Offer diagnostic fields for averaging. + if (query_averaging_enabled(CS%diag)) then + if (CS%id_du_dt_visc > 0) & + call post_data(CS%id_du_dt_visc, ADp%du_dt_visc, CS%diag) + if (CS%id_du_dt_visc_gl90 > 0) & + call post_data(CS%id_du_dt_visc_gl90, ADp%du_dt_visc_gl90, CS%diag) + if (CS%id_dv_dt_visc > 0) & + call post_data(CS%id_dv_dt_visc, ADp%dv_dt_visc, CS%diag) + if (CS%id_dv_dt_visc_gl90 > 0) & + call post_data(CS%id_dv_dt_visc_gl90, ADp%dv_dt_visc_gl90, CS%diag) + if (present(taux_bot) .and. (CS%id_taux_bot > 0)) & + call post_data(CS%id_taux_bot, taux_bot, CS%diag) + if (present(tauy_bot) .and. (CS%id_tauy_bot > 0)) & + call post_data(CS%id_tauy_bot, tauy_bot, CS%diag) + if (CS%id_du_dt_str > 0) & + call post_data(CS%id_du_dt_str, ADp%du_dt_str, CS%diag) + if (CS%id_dv_dt_str > 0) & + call post_data(CS%id_dv_dt_str, ADp%dv_dt_str, CS%diag) + + if (associated(ADp%du_dt_visc) .and. associated(ADp%du_dt_visc)) then + ! Diagnostics of the fractional thicknesses times momentum budget terms + ! 3D diagnostics of hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option. + ! The code is retained for debugging purposes in the future. + !if (CS%id_hf_du_dt_visc > 0) & + ! call post_product_u(CS%id_hf_du_dt_visc, ADp%du_dt_visc, ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_dv_dt_visc > 0) & + ! call post_product_v(CS%id_hf_dv_dt_visc, ADp%dv_dt_visc, ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for thickness-weighted vertically averaged viscous accelerations + if (CS%id_hf_du_dt_visc_2d > 0) & + call post_product_sum_u(CS%id_hf_du_dt_visc_2d, ADp%du_dt_visc, ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_dv_dt_visc_2d > 0) & + call post_product_sum_v(CS%id_hf_dv_dt_visc_2d, ADp%dv_dt_visc, ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for thickness x viscous accelerations + if (CS%id_h_du_dt_visc > 0) call post_product_u(CS%id_h_du_dt_visc, ADp%du_dt_visc, ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_dv_dt_visc > 0) call post_product_v(CS%id_h_dv_dt_visc, ADp%dv_dt_visc, ADp%diag_hv, G, nz, CS%diag) + endif + + if (associated(ADp%du_dt_str) .and. associated(ADp%dv_dt_str)) then + ! Diagnostics for thickness x wind stress accelerations + if (CS%id_h_du_dt_str > 0) call post_product_u(CS%id_h_du_dt_str, ADp%du_dt_str, ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_dv_dt_str > 0) call post_product_v(CS%id_h_dv_dt_str, ADp%dv_dt_str, ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics for wind stress accelerations multiplied by visc_rem_[uv], + if (CS%id_du_dt_str_visc_rem > 0) & + call post_product_u(CS%id_du_dt_str_visc_rem, ADp%du_dt_str, ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_dv_dt_str_visc_rem > 0) & + call post_product_v(CS%id_dv_dt_str_visc_rem, ADp%dv_dt_str, ADp%visc_rem_v, G, nz, CS%diag) + endif + endif + +end subroutine vertvisc + +!> Calculate the fraction of momentum originally in a layer that remains in the water column +!! after a time-step of viscosity, equivalently the fraction of a time-step's worth of +!! barotropic acceleration that a layer experiences after viscosity is applied. +subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: visc_rem_u !< Fraction of a time-step's worth of a + !! barotropic acceleration that a layer experiences after + !! viscosity is applied in the zonal direction [nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: visc_rem_v !< Fraction of a time-step's worth of a + !! barotropic acceleration that a layer experiences after + !! viscosity is applied in the meridional direction [nondim] + real, intent(in) :: dt !< Time increment [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + + ! Local variables + + real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. + real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. + real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + logical :: do_i(SZIB_(G)) + + integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz + is = G%isc ; ie = G%iec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke + + if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & + "Module must be initialized before it is used.") + + if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(remant): "// & + "Module must be initialized before it is used.") + + do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo + + ! Find the zonal viscous remnant using a modification of a standard tridagonal solver. + !$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.0) ; enddo + + if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq + Ray(I,k) = visc%Ray_u(I,j,k) + enddo ; enddo ; endif + + do I=Isq,Ieq ; if (do_i(I)) then + b_denom_1 = CS%h_u(I,j,1) + dt * (Ray(I,1) + CS%a_u(I,j,1)) + b1(I) = 1.0 / (b_denom_1 + dt*CS%a_u(I,j,2)) + d1(I) = b_denom_1 * b1(I) + visc_rem_u(I,j,1) = b1(I) * CS%h_u(I,j,1) + endif ; enddo + do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then + c1(I,k) = dt * CS%a_u(I,j,K)*b1(I) + b_denom_1 = CS%h_u(I,j,k) + dt * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) + b1(I) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) + d1(I) = b_denom_1 * b1(I) + visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1(I) + endif ; enddo ; enddo + do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then + visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + c1(I,k+1)*visc_rem_u(I,j,k+1) + + endif ; enddo ; enddo ! i and k loops + + enddo ! end u-component j loop + + ! 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.0) ; enddo + + if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie + Ray(i,k) = visc%Ray_v(i,J,k) + enddo ; enddo ; endif + + do i=is,ie ; if (do_i(i)) then + b_denom_1 = CS%h_v(i,J,1) + dt * (Ray(i,1) + CS%a_v(i,J,1)) + b1(i) = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) + d1(i) = b_denom_1 * b1(i) + visc_rem_v(i,J,1) = b1(i) * CS%h_v(i,J,1) + endif ; enddo + do k=2,nz ; do i=is,ie ; if (do_i(i)) then + c1(i,k) = dt * CS%a_v(i,J,K)*b1(i) + b_denom_1 = CS%h_v(i,J,k) + dt * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) + b1(i) = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) + d1(i) = b_denom_1 * b1(i) + visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1(i) + endif ; enddo ; enddo + do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then + visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + c1(i,k+1)*visc_rem_v(i,J,k+1) + endif ; enddo ; enddo ! i and k loops + enddo ! end of v-component J loop + + if (CS%debug) then + call uvchksum("visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, & + scalar_pair=.true.) + endif + +end subroutine vertvisc_remnant + + +!> Calculate the coupling coefficients (CS%a_u, CS%a_v, CS%a_u_gl90, CS%a_v_gl90) +!! and effective layer thicknesses (CS%h_u and CS%h_v) for later use in the +!! applying the implicit vertical viscosity via vertvisc(). +subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, VarMix) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Vertical distance across layers [Z ~> m] + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields. + real, intent(in) :: dt !< Time increment [T ~> s] + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients + ! Field from forces used in this subroutine: + ! ustar: the friction velocity [Z T-1 ~> m s-1], used here as the mixing + ! velocity in the mixed layer if NKML > 1 in a bulk mixed layer. + + ! Local variables + + real, dimension(SZIB_(G),SZK_(GV)) :: & + h_harm, & ! Harmonic mean of the thicknesses around a velocity grid point, + ! given by 2*(h+ * h-)/(h+ + h-) [H ~> m or kg m-2]. + h_arith, & ! The arithmetic mean thickness [H ~> m or kg m-2]. + h_delta, & ! The lateral difference of thickness [H ~> m or kg m-2]. + hvel, & ! hvel is the thickness used at a velocity grid point [H ~> m or kg m-2]. + hvel_shelf, & ! The equivalent of hvel under shelves [H ~> m or kg m-2]. + dz_harm, & ! Harmonic mean of the vertical distances around a velocity grid point, + ! given by 2*(h+ * h-)/(h+ + h-) [Z ~> m]. + dz_arith, & ! The arithmetic mean of the vertical distances around a velocity grid point [Z ~> m] + dz_vel, & ! The vertical distance between interfaces used at a velocity grid point [Z ~> m]. + dz_vel_shelf ! The equivalent of dz_vel under shelves [Z ~> m]. + real, dimension(SZIB_(G),SZK_(GV)+1) :: & + a_cpl, & ! The drag coefficients across interfaces [H T-1 ~> m s-1 or Pa s m-1]. a_cpl times + ! the velocity difference gives the stress across an interface. + a_cpl_gl90, & ! The drag coefficients across interfaces associated with GL90 [H T-1 ~> m s-1 or Pa s m-1]. + ! a_cpl_gl90 times the velocity difference gives the GL90 stress across an interface. + ! a_cpl_gl90 is part of a_cpl. + a_shelf, & ! The drag coefficients across interfaces in water columns under + ! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. + z_i, & ! An estimate of each interface's height above the bottom, + ! normalized by the bottom boundary layer thickness [nondim] + z_i_gl90 ! An estimate of each interface's height above the bottom, + ! normalized by the GL90 bottom boundary layer thickness [nondim] + real, dimension(SZIB_(G)) :: & + kv_bbl, & ! The bottom boundary layer viscosity [H Z T-1 ~> m2 s-1 or Pa s]. + bbl_thick, & ! The bottom boundary layer thickness [Z ~> m]. + I_Hbbl, & ! The inverse of the bottom boundary layer thickness [Z-1 ~> m-1]. + I_Hbbl_gl90, &! The inverse of the bottom boundary layer thickness used for the GL90 scheme + ! [Z-1 ~> m-1]. + I_HTbl, & ! The inverse of the top boundary layer thickness [Z-1 ~> m-1]. + zcol1, & ! The height of the interfaces to the south of a v-point [Z ~> m]. + zcol2, & ! The height of the interfaces to the north of a v-point [Z ~> m]. + Ztop_min, & ! The deeper of the two adjacent surface heights [Z ~> m]. + Dmin, & ! The shallower of the two adjacent bottom depths [Z ~> m]. + zh, & ! An estimate of the interface's distance from the bottom + ! based on harmonic mean thicknesses [Z ~> m]. + h_ml ! The mixed layer depth [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)) :: & + Ustar_2d ! The wind friction velocity, calculated using the Boussinesq reference density or + ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: hML_u ! Diagnostic of the mixed layer depth at u points [Z ~> m]. + real, allocatable, dimension(:,:) :: hML_v ! Diagnostic of the mixed layer depth at v points [Z ~> m]. + real, allocatable, dimension(:,:,:) :: Kv_u ! Total vertical viscosity at u-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_v ! Total vertical viscosity at v-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_gl90_u ! GL90 vertical viscosity at u-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_gl90_v ! GL90 vertical viscosity at v-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real :: zcol(SZI_(G)) ! The height of an interface at h-points [Z ~> m]. + real :: botfn ! A function which goes from 1 at the bottom to 0 much more + ! than Hbbl into the interior [nondim]. + real :: topfn ! A function which goes from 1 at the top to 0 much more + ! than Htbl into the interior [nondim]. + real :: z2 ! The distance from the bottom, normalized by Hbbl [nondim] + real :: z2_wt ! A nondimensional (0-1) weight used when calculating z2 [nondim]. + real :: z_clear ! The clearance of an interface above the surrounding topography [Z ~> m]. + real :: a_cpl_max ! The maximum drag coefficient across interfaces, set so that it will be + ! representable as a 32-bit float in MKS units [H T-1 ~> m s-1 or Pa s m-1] + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + + real :: I_valBL ! The inverse of a scaling factor determining when water is + ! still within the boundary layer, as determined by the sum + ! of the harmonic mean thicknesses [nondim]. + logical, dimension(SZIB_(G)) :: do_i, do_i_shelf + logical :: do_any_shelf + integer, dimension(SZIB_(G)) :: & + zi_dir ! A trinary logical array indicating which thicknesses to use for + ! finding z_clear. + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke + + if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(coef): "// & + "Module must be initialized before it is used.") + + if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(coef): "// & + "Module must be initialized before it is used.") + + h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff + a_cpl_max = 1.0e37 * GV%m_to_H * US%T_to_s + I_Hbbl(:) = 1.0 / (CS%Hbbl + dz_neglect) + if (CS%use_GL90_in_SSW) then + I_Hbbl_gl90(:) = 1.0 / (CS%Hbbl_gl90 + dz_neglect) + endif + I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val + + if (CS%id_Kv_u > 0) allocate(Kv_u(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.0) + + if (CS%id_Kv_v > 0) allocate(Kv_v(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.0) + + if (CS%id_Kv_gl90_u > 0) allocate(Kv_gl90_u(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.0) + + if (CS%id_Kv_gl90_v > 0) allocate(Kv_gl90_v(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.0) + + if (CS%debug .or. (CS%id_hML_u > 0)) allocate(hML_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0.0) + if (CS%debug .or. (CS%id_hML_v > 0)) allocate(hML_v(G%isd:G%ied,G%JsdB:G%JedB), source=0.0) + + if ((allocated(visc%taux_shelf) .or. associated(forces%frac_shelf_u)) .and. & + .not.associated(CS%a1_shelf_u)) then + allocate(CS%a1_shelf_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0.0) + endif + if ((allocated(visc%tauy_shelf) .or. associated(forces%frac_shelf_v)) .and. & + .not.associated(CS%a1_shelf_v)) then + allocate(CS%a1_shelf_v(G%isd:G%ied,G%JsdB:G%JedB), source=0.0) + endif + + call find_ustar(forces, tv, Ustar_2d, G, GV, US, halo=1) + + !$OMP parallel do default(private) shared(G,GV,US,CS,tv,visc,OBC,Isq,Ieq,nz,u,h,dz,forces, & + !$OMP Ustar_2d,h_neglect,dz_neglect,dt,I_valBL,hML_u,Kv_u, & + !$OMP a_cpl_max,I_Hbbl_gl90,Kv_gl90_u) & + !$OMP firstprivate(I_Hbbl) + do j=G%Jsc,G%Jec + do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo + + if (CS%bottomdraglaw) then ; do I=Isq,Ieq + kv_bbl(I) = visc%Kv_bbl_u(I,j) + bbl_thick(I) = visc%bbl_thick_u(I,j) + dz_neglect + if (do_i(I)) I_Hbbl(I) = 1.0 / bbl_thick(I) + enddo ; endif + + do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) then + h_harm(I,k) = 2.0*h(i,j,k)*h(i+1,j,k) / (h(i,j,k)+h(i+1,j,k)+h_neglect) + h_arith(I,k) = 0.5*(h(i+1,j,k)+h(i,j,k)) + h_delta(I,k) = h(i+1,j,k) - h(i,j,k) + dz_harm(I,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / (dz(i,j,k)+dz(i+1,j,k)+dz_neglect) + dz_arith(I,k) = 0.5*(dz(i+1,j,k)+dz(i,j,k)) + endif ; enddo ; enddo + do I=Isq,Ieq + Dmin(I) = min(G%bathyT(i,j), G%bathyT(i+1,j)) + zi_dir(I) = 0 + enddo + + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then + do I=Isq,Ieq ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do k=1,nz + h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(I,k) = 0. + dz_harm(I,k) = dz(i,j,k) ; dz_arith(I,k) = dz(i,j,k) + enddo + Dmin(I) = G%bathyT(i,j) + zi_dir(I) = -1 + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + do k=1,nz + h_harm(I,k) = h(i+1,j,k) ; h_arith(I,k) = h(i+1,j,k) ; h_delta(I,k) = 0. + dz_harm(I,k) = dz(i+1,j,k) ; dz_arith(I,k) = dz(i+1,j,k) + enddo + Dmin(I) = G%bathyT(i+1,j) + zi_dir(I) = 1 + endif + endif ; enddo + endif ; endif + +! The following block calculates the thicknesses at velocity +! grid points for the vertical viscosity (hvel and dz_vel). Near the +! bottom an upwind biased thickness is used to control the effect +! of spurious Montgomery potential gradients at the bottom where +! nearly massless layers layers ride over the topography. + if (CS%harmonic_visc) then + do I=Isq,Ieq ; z_i(I,nz+1) = 0.0 ; enddo + do k=nz,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then + hvel(I,k) = h_harm(I,k) + dz_vel(I,k) = dz_harm(I,k) + if (u(I,j,k) * h_delta(I,k) < 0) then + z2 = z_i(I,k+1) ; botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) + hvel(I,k) = (1.0-botfn)*h_harm(I,k) + botfn*h_arith(I,k) + dz_vel(I,k) = (1.0-botfn)*dz_harm(I,k) + botfn*dz_arith(I,k) + endif + z_i(I,k) = z_i(I,k+1) + dz_harm(I,k)*I_Hbbl(I) + endif ; enddo ; enddo ! i & k loops + else ! Not harmonic_visc + do I=Isq,Ieq ; zh(I) = 0.0 ; z_i(I,nz+1) = 0.0 ; enddo + do i=Isq,Ieq+1 ; zcol(i) = -G%bathyT(i,j) ; enddo + do k=nz,1,-1 + do i=Isq,Ieq+1 ; zcol(i) = zcol(i) + dz(i,j,k) ; enddo + do I=Isq,Ieq ; if (do_i(I)) then + zh(I) = zh(I) + dz_harm(I,k) + + z_clear = max(zcol(i),zcol(i+1)) + Dmin(I) + if (zi_dir(I) < 0) z_clear = zcol(i) + Dmin(I) + if (zi_dir(I) > 0) z_clear = zcol(i+1) + Dmin(I) + + z_i(I,k) = max(zh(I), z_clear) * I_Hbbl(I) + + hvel(I,k) = h_arith(I,k) + dz_vel(I,k) = dz_arith(I,k) + if (u(I,j,k) * h_delta(I,k) > 0) then + if (zh(I) * I_Hbbl(I) < CS%harm_BL_val) then + hvel(I,k) = h_harm(I,k) + dz_vel(I,k) = dz_harm(I,k) + else + z2_wt = 1.0 ; if (zh(I) * I_Hbbl(I) < 2.0*CS%harm_BL_val) & + z2_wt = max(0.0, min(1.0, zh(I) * I_Hbbl(I) * I_valBL - 1.0)) + z2 = z2_wt * (max(zh(I), z_clear) * I_Hbbl(I)) + botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) + hvel(I,k) = (1.0-botfn)*h_arith(I,k) + botfn*h_harm(I,k) + dz_vel(I,k) = (1.0-botfn)*dz_arith(I,k) + botfn*dz_harm(I,k) + endif + endif + + endif ; enddo ! i loop + enddo ! k loop + endif + + call find_coupling_coef(a_cpl, dz_vel, do_i, dz_harm, bbl_thick, kv_bbl, z_i, h_ml, & + dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.true., OBC=OBC) + a_cpl_gl90(:,:) = 0.0 + if (CS%use_GL90_in_SSW) then + ! The following block calculates the normalized height above the GL90 + ! BBL (z_i_gl90), using a harmonic mean between layer thicknesses. For the + ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the GL90 + ! coupling coefficient is zeroed out within Hbbl_gl90, to ensure that + ! no momentum gets fluxed into vanished layers. The scheme is not + ! sensitive to the exact value of Hbbl_gl90, as long as it is in a + ! reasonable range (~1-20 m): large enough to capture vanished layers + ! over topography, small enough to not contaminate the interior. + do I=Isq,Ieq ; z_i_gl90(I,nz+1) = 0.0 ; enddo + do k=nz,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then + z_i_gl90(I,k) = z_i_gl90(I,k+1) + dz_harm(I,k)*I_Hbbl_gl90(I) + endif ; enddo ; enddo ! i & k loops + call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.true.) + endif + + if (allocated(hML_u)) then + do i=isq,ieq ; if (do_i(i)) then ; hML_u(I,j) = h_ml(I) ; endif ; enddo + endif + + do_any_shelf = .false. + if (associated(forces%frac_shelf_u)) then + do I=Isq,Ieq + CS%a1_shelf_u(I,j) = 0.0 + do_i_shelf(I) = (do_i(I) .and. forces%frac_shelf_u(I,j) > 0.0) + if (do_i_shelf(I)) do_any_shelf = .true. + enddo + if (do_any_shelf) then + if (CS%harmonic_visc) then + do k=1,nz ; do I=Isq,Ieq + hvel_shelf(I,k) = hvel(I,k) ; dz_vel_shelf(I,k) = dz_vel(I,k) + enddo ; enddo + else ! Find upwind-biased thickness near the surface. + ! Perhaps this needs to be done more carefully, via find_eta. + do I=Isq,Ieq ; if (do_i_shelf(I)) then + zh(I) = 0.0 ; Ztop_min(I) = min(zcol(i), zcol(i+1)) + I_HTbl(I) = 1.0 / (visc%tbl_thick_shelf_u(I,j) + dz_neglect) + endif ; enddo + do k=1,nz + do i=Isq,Ieq+1 ; zcol(i) = zcol(i) - dz(i,j,k) ; enddo + do I=Isq,Ieq ; if (do_i_shelf(I)) then + zh(I) = zh(I) + dz_harm(I,k) + + hvel_shelf(I,k) = hvel(I,k) ; dz_vel_shelf(I,k) = dz_vel(I,k) + if (u(I,j,k) * h_delta(I,k) > 0) then + if (zh(I) * I_HTbl(I) < CS%harm_BL_val) then + hvel_shelf(I,k) = min(hvel(I,k), h_harm(I,k)) + dz_vel_shelf(I,k) = min(dz_vel(I,k), dz_harm(I,k)) + else + z2_wt = 1.0 ; if (zh(I) * I_HTbl(I) < 2.0*CS%harm_BL_val) & + z2_wt = max(0.0, min(1.0, zh(I) * I_HTbl(I) * I_valBL - 1.0)) + z2 = z2_wt * (max(zh(I), Ztop_min(I) - min(zcol(i),zcol(i+1))) * I_HTbl(I)) + topfn = 1.0 / (1.0 + 0.09*z2**6) + hvel_shelf(I,k) = min(hvel(I,k), (1.0-topfn)*h_arith(I,k) + topfn*h_harm(I,k)) + dz_vel_shelf(I,k) = min(dz_vel(I,k), (1.0-topfn)*dz_arith(I,k) + topfn*dz_harm(I,k)) + endif + endif + endif ; enddo + enddo + endif + call find_coupling_coef(a_shelf, dz_vel_shelf, do_i_shelf, dz_harm, bbl_thick, & + kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, Ustar_2d, tv, & + work_on_u=.true., OBC=OBC, shelf=.true.) + do I=Isq,Ieq ; if (do_i_shelf(I)) CS%a1_shelf_u(I,j) = a_shelf(I,1) ; enddo + endif + endif + + if (do_any_shelf) then + do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i_shelf(I)) then + CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(I,K) + & + (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) + a_cpl_gl90(I,K)) +! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH +! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(I,K), a_cpl(I,K)) + & +! (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) + elseif (do_i(I)) then + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K) + a_cpl_gl90(I,K)) + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,K)) + endif ; enddo ; enddo + do k=1,nz ; do I=Isq,Ieq ; if (do_i_shelf(I)) then + ! Should we instead take the inverse of the average of the inverses? + CS%h_u(I,j,k) = forces%frac_shelf_u(I,j) * hvel_shelf(I,k) + & + (1.0-forces%frac_shelf_u(I,j)) * hvel(I,k) + h_neglect + elseif (do_i(I)) then + CS%h_u(I,j,k) = hvel(I,k) + h_neglect + endif ; enddo ; enddo + else + do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) then + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K) + a_cpl_gl90(I,K)) + endif; enddo ; enddo + do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) then + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,K)) + endif; enddo ; enddo + do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) + h_neglect ; enddo ; enddo + endif + + ! Diagnose total Kv at u-points + if (CS%id_Kv_u > 0) then + do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) Kv_u(I,j,k) = 0.5 * (CS%a_u(I,j,K)+CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) + enddo ; enddo + endif + ! Diagnose GL90 Kv at u-points + if (CS%id_Kv_gl90_u > 0) then + do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) Kv_gl90_u(I,j,k) = 0.5 * (CS%a_u_gl90(I,j,K)+CS%a_u_gl90(I,j,K+1)) * CS%h_u(I,j,k) + enddo ; enddo + endif + enddo + + + ! Now work on v-points. + !$OMP parallel do default(private) shared(G,GV,US,CS,tv,OBC,visc,is,ie,Jsq,Jeq,nz,v,h,dz,forces, & + !$OMP Ustar_2d,h_neglect,dz_neglect,dt,I_valBL,hML_v,Kv_v, & + !$OMP a_cpl_max,I_Hbbl_gl90,Kv_gl90_v) & + !$OMP firstprivate(I_Hbbl) + do J=Jsq,Jeq + do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo + + if (CS%bottomdraglaw) then ; do i=is,ie + kv_bbl(i) = visc%Kv_bbl_v(i,J) + bbl_thick(i) = visc%bbl_thick_v(i,J) + dz_neglect + if (do_i(i)) I_Hbbl(i) = 1.0 / bbl_thick(i) + enddo ; endif + + do k=1,nz ; do i=is,ie ; if (do_i(i)) then + h_harm(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / (h(i,j,k)+h(i,j+1,k)+h_neglect) + h_arith(i,k) = 0.5*(h(i,j+1,k)+h(i,j,k)) + h_delta(i,k) = h(i,j+1,k) - h(i,j,k) + dz_harm(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / (dz(i,j,k)+dz(i,j+1,k)+dz_neglect) + dz_arith(i,k) = 0.5*(dz(i,j+1,k)+dz(i,j,k)) + endif ; enddo ; enddo + do i=is,ie + Dmin(i) = min(G%bathyT(i,j), G%bathyT(i,j+1)) + zi_dir(i) = 0 + enddo + + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then + do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do k=1,nz + h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(i,k) = 0. + dz_harm(I,k) = dz(i,j,k) ; dz_arith(I,k) = dz(i,j,k) + enddo + Dmin(I) = G%bathyT(i,j) + zi_dir(I) = -1 + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + do k=1,nz + h_harm(i,k) = h(i,j+1,k) ; h_arith(i,k) = h(i,j+1,k) ; h_delta(i,k) = 0. + dz_harm(i,k) = dz(i,j+1,k) ; dz_arith(i,k) = dz(i,j+1,k) + enddo + Dmin(i) = G%bathyT(i,j+1) + zi_dir(i) = 1 + endif + endif ; enddo + endif ; endif + +! The following block calculates the thicknesses at velocity +! grid points for the vertical viscosity (hvel). Near the +! bottom an upwind biased thickness is used to control the effect +! of spurious Montgomery potential gradients at the bottom where +! nearly massless layers layers ride over the topography. + if (CS%harmonic_visc) then + do i=is,ie ; z_i(i,nz+1) = 0.0 ; enddo + + do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then + hvel(i,k) = h_harm(i,k) + dz_vel(i,k) = dz_harm(i,k) + if (v(i,J,k) * h_delta(i,k) < 0) then + z2 = z_i(i,k+1) ; botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) + hvel(i,k) = (1.0-botfn)*h_harm(i,k) + botfn*h_arith(i,k) + dz_vel(i,k) = (1.0-botfn)*dz_harm(i,k) + botfn*dz_arith(i,k) + endif + z_i(i,k) = z_i(i,k+1) + dz_harm(i,k)*I_Hbbl(i) + endif ; enddo ; enddo ! i & k loops + else ! Not harmonic_visc + do i=is,ie + zh(i) = 0.0 ; z_i(i,nz+1) = 0.0 + zcol1(i) = -G%bathyT(i,j) + zcol2(i) = -G%bathyT(i,j+1) + enddo + do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then + zh(i) = zh(i) + dz_harm(i,k) + zcol1(i) = zcol1(i) + dz(i,j,k) ; zcol2(i) = zcol2(i) + dz(i,j+1,k) + + z_clear = max(zcol1(i),zcol2(i)) + Dmin(i) + if (zi_dir(i) < 0) z_clear = zcol1(i) + Dmin(I) + if (zi_dir(i) > 0) z_clear = zcol2(i) + Dmin(I) + + z_i(I,k) = max(zh(i), z_clear) * I_Hbbl(i) + + hvel(i,k) = h_arith(i,k) + dz_vel(i,k) = dz_arith(i,k) + if (v(i,J,k) * h_delta(i,k) > 0) then + if (zh(i) * I_Hbbl(i) < CS%harm_BL_val) then + hvel(i,k) = h_harm(i,k) + dz_vel(i,k) = dz_harm(i,k) + else + z2_wt = 1.0 ; if (zh(i) * I_Hbbl(i) < 2.0*CS%harm_BL_val) & + z2_wt = max(0.0, min(1.0, zh(i) * I_Hbbl(i) * I_valBL - 1.0)) + z2 = z2_wt * (max(zh(i), max(zcol1(i),zcol2(i)) + Dmin(i)) * I_Hbbl(i)) + botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) + hvel(i,k) = (1.0-botfn)*h_arith(i,k) + botfn*h_harm(i,k) + dz_vel(i,k) = (1.0-botfn)*dz_arith(i,k) + botfn*dz_harm(i,k) + endif + endif + + endif ; enddo ; enddo ! i & k loops + endif + + call find_coupling_coef(a_cpl, dz_vel, do_i, dz_harm, bbl_thick, kv_bbl, z_i, h_ml, & + dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.false., OBC=OBC) + a_cpl_gl90(:,:) = 0.0 + if (CS%use_GL90_in_SSW) then + ! The following block calculates the normalized height above the GL90 + ! BBL (z_i_gl90), using a harmonic mean between layer thicknesses. For the + ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the GL90 + ! coupling coefficient is zeroed out within Hbbl_gl90, to ensure that + ! no momentum gets fluxed into vanished layers. The scheme is not + ! sensitive to the exact value of Hbbl_gl90, as long as it is in a + ! reasonable range (~1-20 m): large enough to capture vanished layers + ! over topography, small enough to not contaminate the interior. + do i=is,ie ; z_i_gl90(i,nz+1) = 0.0 ; enddo + + do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then + z_i_gl90(i,k) = z_i_gl90(i,k+1) + dz_harm(i,k)*I_Hbbl_gl90(i) + endif ; enddo ; enddo ! i & k loops + + call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.false.) + endif + + if ( allocated(hML_v)) then + do i=is,ie ; if (do_i(i)) then ; hML_v(i,J) = h_ml(i) ; endif ; enddo + endif + do_any_shelf = .false. + if (associated(forces%frac_shelf_v)) then + do i=is,ie + CS%a1_shelf_v(i,J) = 0.0 + do_i_shelf(i) = (do_i(i) .and. forces%frac_shelf_v(i,J) > 0.0) + if (do_i_shelf(I)) do_any_shelf = .true. + enddo + if (do_any_shelf) then + if (CS%harmonic_visc) then + do k=1,nz ; do i=is,ie + hvel_shelf(i,k) = hvel(i,k) ; dz_vel_shelf(i,k) = dz_vel(i,k) + enddo ; enddo + else ! Find upwind-biased thickness near the surface. + ! Perhaps this needs to be done more carefully, via find_eta. + do i=is,ie ; if (do_i_shelf(i)) then + zh(i) = 0.0 ; Ztop_min(I) = min(zcol1(i), zcol2(i)) + I_HTbl(i) = 1.0 / (visc%tbl_thick_shelf_v(i,J) + dz_neglect) + endif ; enddo + do k=1,nz + do i=is,ie ; if (do_i_shelf(i)) then + zcol1(i) = zcol1(i) - dz(i,j,k) ; zcol2(i) = zcol2(i) - dz(i,j+1,k) + zh(i) = zh(i) + dz_harm(i,k) + + hvel_shelf(i,k) = hvel(i,k) ; dz_vel_shelf(i,k) = dz_vel(i,k) + if (v(i,J,k) * h_delta(i,k) > 0) then + if (zh(i) * I_HTbl(i) < CS%harm_BL_val) then + hvel_shelf(i,k) = min(hvel(i,k), h_harm(i,k)) + dz_vel_shelf(i,k) = min(dz_vel(i,k), dz_harm(i,k)) + else + z2_wt = 1.0 ; if (zh(i) * I_HTbl(i) < 2.0*CS%harm_BL_val) & + z2_wt = max(0.0, min(1.0, zh(i) * I_HTbl(i) * I_valBL - 1.0)) + z2 = z2_wt * (max(zh(i), Ztop_min(i) - min(zcol1(i),zcol2(i))) * I_HTbl(i)) + topfn = 1.0 / (1.0 + 0.09*z2**6) + hvel_shelf(i,k) = min(hvel(i,k), (1.0-topfn)*h_arith(i,k) + topfn*h_harm(i,k)) + dz_vel_shelf(i,k) = min(dz_vel(i,k), (1.0-topfn)*dz_arith(i,k) + topfn*dz_harm(i,k)) + endif + endif + endif ; enddo + enddo + endif + call find_coupling_coef(a_shelf, dz_vel_shelf, do_i_shelf, dz_harm, bbl_thick, & + kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, Ustar_2d, tv, & + work_on_u=.false., OBC=OBC, shelf=.true.) + do i=is,ie ; if (do_i_shelf(i)) CS%a1_shelf_v(i,J) = a_shelf(i,1) ; enddo + endif + endif + + if (do_any_shelf) then + do K=1,nz+1 ; do i=is,ie ; if (do_i_shelf(i)) then + CS%a_v(i,J,K) = min(a_cpl_max, (forces%frac_shelf_v(i,J) * a_shelf(i,k) + & + (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) + a_cpl_gl90(i,K)) +! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH +! CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * max(a_shelf(i,K), a_cpl(i,K)) + & + ! (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) + elseif (do_i(i)) then + CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K) + a_cpl_gl90(i,K)) + CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,K)) + endif ; enddo ; enddo + do k=1,nz ; do i=is,ie ; if (do_i_shelf(i)) then + ! Should we instead take the inverse of the average of the inverses? + CS%h_v(i,J,k) = forces%frac_shelf_v(i,J) * hvel_shelf(i,k) + & + (1.0-forces%frac_shelf_v(i,J)) * hvel(i,k) + h_neglect + elseif (do_i(i)) then + CS%h_v(i,J,k) = hvel(i,k) + h_neglect + endif ; enddo ; enddo + else + do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) then + CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K) + a_cpl_gl90(i,K)) + endif ; enddo ; enddo + do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) then + CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,K)) + endif ; enddo ; enddo + do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) + h_neglect ; enddo ; enddo + endif + + ! Diagnose total Kv at v-points + if (CS%id_Kv_v > 0) then + do k=1,nz ; do i=is,ie + if (do_i(I)) Kv_v(i,J,k) = 0.5 * (CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) + enddo ; enddo + endif + ! Diagnose GL90 Kv at v-points + if (CS%id_Kv_gl90_v > 0) then + do k=1,nz ; do i=is,ie + if (do_i(I)) Kv_gl90_v(i,J,k) = 0.5 * (CS%a_v_gl90(i,J,K)+CS%a_v_gl90(i,J,K+1)) * CS%h_v(i,J,k) + enddo ; enddo + endif + enddo ! end of v-point j loop + + if (CS%debug) then + call uvchksum("vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, & + scale=GV%H_to_m, scalar_pair=.true.) + call uvchksum("vertvisc_coef a_[uv]", CS%a_u, CS%a_v, G%HI, haloshift=0, & + scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) + if (allocated(hML_u) .and. allocated(hML_v)) & + call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, G%HI, & + haloshift=0, scale=US%Z_to_m, scalar_pair=.true.) + endif + +! Offer diagnostic fields for averaging. + if (query_averaging_enabled(CS%diag)) then + if (associated(visc%Kv_slow) .and. (CS%id_Kv_slow > 0)) & + call post_data(CS%id_Kv_slow, visc%Kv_slow, CS%diag) + if (CS%id_Kv_u > 0) call post_data(CS%id_Kv_u, Kv_u, CS%diag) + if (CS%id_Kv_v > 0) call post_data(CS%id_Kv_v, Kv_v, CS%diag) + if (CS%id_Kv_gl90_u > 0) call post_data(CS%id_Kv_gl90_u, Kv_gl90_u, CS%diag) + if (CS%id_Kv_gl90_v > 0) call post_data(CS%id_Kv_gl90_v, Kv_gl90_v, CS%diag) + if (CS%id_au_vv > 0) call post_data(CS%id_au_vv, CS%a_u, CS%diag) + if (CS%id_av_vv > 0) call post_data(CS%id_av_vv, CS%a_v, CS%diag) + if (CS%id_au_gl90_vv > 0) call post_data(CS%id_au_gl90_vv, CS%a_u_gl90, CS%diag) + if (CS%id_av_gl90_vv > 0) call post_data(CS%id_av_gl90_vv, CS%a_v_gl90, CS%diag) + if (CS%id_h_u > 0) call post_data(CS%id_h_u, CS%h_u, CS%diag) + if (CS%id_h_v > 0) call post_data(CS%id_h_v, CS%h_v, CS%diag) + if (CS%id_hML_u > 0) call post_data(CS%id_hML_u, hML_u, CS%diag) + if (CS%id_hML_v > 0) call post_data(CS%id_hML_v, hML_v, CS%diag) + endif + + if (allocated(hML_u)) deallocate(hML_u) + if (allocated(hML_v)) deallocate(hML_v) + +end subroutine vertvisc_coef + +!> Calculate the 'coupling coefficient' (a_cpl) at the interfaces. +!! If BOTTOMDRAGLAW is defined, the minimum of Hbbl and half the adjacent +!! layer thicknesses are used to calculate a_cpl near the bottom. +subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & + dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u, OBC, shelf) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZK_(GV)+1), & + intent(out) :: a_cpl !< Coupling coefficient across interfaces [H T-1 ~> m s-1 or Pa s m-1] + real, dimension(SZIB_(G),SZK_(GV)), & + intent(in) :: hvel !< Distance between interfaces at velocity points [Z ~> m] + logical, dimension(SZIB_(G)), & + intent(in) :: do_i !< If true, determine coupling coefficient for a column + real, dimension(SZIB_(G),SZK_(GV)), & + intent(in) :: h_harm !< Harmonic mean of thicknesses around a velocity + !! grid point [Z ~> m] + real, dimension(SZIB_(G)), intent(in) :: bbl_thick !< Bottom boundary layer thickness [Z ~> m] + real, dimension(SZIB_(G)), intent(in) :: kv_bbl !< Bottom boundary layer viscosity, exclusive of + !! any depth-dependent contributions from + !! visc%Kv_shear [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(SZIB_(G),SZK_(GV)+1), & + intent(in) :: z_i !< Estimate of interface heights above the bottom, + !! normalized by the bottom boundary layer thickness [nondim] + real, dimension(SZIB_(G)), intent(out) :: h_ml !< Mixed layer depth [Z ~> m] + integer, intent(in) :: j !< j-index to find coupling coefficient for + real, intent(in) :: dt !< Time increment [T ~> s] + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(vertvisc_type), intent(in) :: visc !< Structure containing viscosities and bottom drag + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: Ustar_2d !< The wind friction velocity, calculated using + !! the Boussinesq reference density or the + !! time-evolving surface density in non-Boussinesq + !! mode [Z T-1 ~> m s-1] + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields. + logical, intent(in) :: work_on_u !< If true, u-points are being calculated, + !! otherwise they are v-points + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + logical, optional, intent(in) :: shelf !< If present and true, use a surface boundary + !! condition appropriate for an ice shelf. + + ! Local variables + + real, dimension(SZIB_(G)) :: & + u_star, & ! ustar at a velocity point [Z T-1 ~> m s-1] + tau_mag, & ! The magnitude of the wind stress at a velocity point including gustiness [H Z T-2 ~> m2 s-2 or Pa] + absf, & ! The average of the neighboring absolute values of f [T-1 ~> s-1]. + rho_av1, & ! The harmonic mean surface layer density at velocity points [R ~> kg m-3] + z_t, & ! The distance from the top, sometimes normalized + ! by Hmix, [Z ~> m] or [nondim]. + kv_TBL, & ! The viscosity in a top boundary layer under ice [H Z T-1 ~> m2 s-1 or Pa s] + tbl_thick ! The thickness of the top boundary layer [Z ~> m] + real, dimension(SZIB_(G),SZK_(GV)+1) :: & + Kv_tot, & ! The total viscosity at an interface [H Z T-1 ~> m2 s-1 or Pa s] + Kv_add ! A viscosity to add [H Z T-1 ~> m2 s-1 or Pa s] + integer, dimension(SZIB_(G)) :: & + nk_in_ml ! The index of the deepest interface in the mixed layer. + real :: h_shear ! The distance over which shears occur [Z ~> m]. + real :: dhc ! The distance between the center of adjacent layers [Z ~> m]. + real :: visc_ml ! The mixed layer viscosity [H Z T-1 ~> m2 s-1 or Pa s]. + real :: tau_scale ! A scaling factor for the interpolated wind stress magnitude [H R-1 L-1 ~> m3 kg-1 or nondim] + real :: I_Hmix ! The inverse of the mixed layer thickness [Z-1 ~> m-1]. + real :: a_ml ! The layer coupling coefficient across an interface in + ! the mixed layer [H T-1 ~> m s-1 or Pa s m-1]. + real :: a_floor ! A lower bound on the layer coupling coefficient across an interface in + ! the mixed layer [H T-1 ~> m s-1 or Pa s m-1]. + real :: I_amax ! The inverse of the maximum coupling coefficient [T H-1 ~> s m-1 or s m2 kg-1]. + real :: temp1 ! A temporary variable [Z2 ~> m2] + real :: ustar2_denom ! A temporary variable in the surface boundary layer turbulence + ! calculations [H Z-1 T-1 ~> s-1 or kg m-3 s-1] + real :: h_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + real :: z2 ! A copy of z_i [nondim] + real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] + real :: topfn ! A function that is 1 at the top and small far from it [nondim] + real :: kv_top ! A viscosity associated with the top boundary layer [H Z T-1 ~> m2 s-1 or Pa s] + logical :: do_shelf, do_OBCs, can_exit + integer :: i, k, is, ie, max_nk + integer :: nz + + a_cpl(:,:) = 0.0 + Kv_tot(:,:) = 0.0 + + if (work_on_u) then ; is = G%IscB ; ie = G%IecB + else ; is = G%isc ; ie = G%iec ; endif + nz = GV%ke + h_neglect = GV%dZ_subroundoff + + tau_scale = US%L_to_Z * GV%RZ_to_H + + if (CS%answer_date < 20190101) then + ! The maximum coupling coefficient was originally introduced to avoid + ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 + ! sets the maximum coupling coefficient increment to 1e10 m per timestep. + I_amax = (1.0e-10*GV%H_to_m) * dt + else + I_amax = 0.0 + endif + + do_shelf = .false. ; if (present(shelf)) do_shelf = shelf + do_OBCs = .false. + if (associated(OBC)) then ; do_OBCS = (OBC%number_of_segments > 0) ; endif + h_ml(:) = 0.0 + + ! This top boundary condition is appropriate when the wind stress is determined + ! externally and does not change within a timestep due to the surface velocity. + do i=is,ie ; Kv_tot(i,1) = 0.0 ; enddo + do K=2,nz+1 ; do i=is,ie + Kv_tot(i,K) = CS%Kv + enddo ; enddo + + if ((CS%Kvml_invZ2 > 0.0) .and. .not.do_shelf) then + ! This is an older (vintage ~1997) way to prevent wind stresses from driving very + ! large flows in nearly massless near-surface layers when there is not a physically- + ! based surface boundary layer parameterization. It does not have a plausible + ! physical basis, and probably should not be used. + I_Hmix = 1.0 / (CS%Hmix + h_neglect) + do i=is,ie ; z_t(i) = h_neglect*I_Hmix ; enddo + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + z_t(i) = z_t(i) + h_harm(i,k-1)*I_Hmix + Kv_tot(i,K) = CS%Kv + CS%Kvml_invZ2 / ((z_t(i)*z_t(i)) * & + (1.0 + 0.09*z_t(i)*z_t(i)*z_t(i)*z_t(i)*z_t(i)*z_t(i))) + endif ; enddo ; enddo + endif + + if (associated(visc%Kv_shear)) then + ! Add in viscosities that are determined by physical processes that are handled in + ! other modules, and which do not respond immediately to the changing layer thicknesses. + ! These processes may include shear-driven mixing or contributions from some boundary + ! layer turbulence schemes. Other viscosity contributions that respond to the evolving + ! layer thicknesses or the surface wind stresses are added later. + if (work_on_u) then + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) + endif ; enddo ; enddo + if (do_OBCs) then + do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i+1,j,k) ; enddo + endif + endif ; enddo + endif + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + Kv_tot(i,K) = Kv_tot(i,K) + Kv_add(i,K) + endif ; enddo ; enddo + else + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) + endif ; enddo ; enddo + if (do_OBCs) then + do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j+1,k) ; enddo + endif + endif ; enddo + endif + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + Kv_tot(i,K) = Kv_tot(i,K) + Kv_add(i,K) + endif ; enddo ; enddo + endif + endif + + if (associated(visc%Kv_shear_Bu)) then + ! This is similar to what was done above, but for contributions coming from the corner + ! (vorticity) points. Because OBCs run through the faces and corners there is no need + ! to further modify these viscosities here to take OBCs into account. + if (work_on_u) then + do K=2,nz ; do I=Is,Ie ; If (do_i(I)) then + Kv_tot(I,K) = Kv_tot(I,K) + 0.5*(visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) + endif ; enddo ; enddo + else + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + Kv_tot(i,K) = Kv_tot(i,K) + 0.5*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) + endif ; enddo ; enddo + endif + endif + + ! Set the viscous coupling coefficients, excluding surface mixed layer contributions + ! for now, but including viscous bottom drag, working up from the bottom. + if (CS%bottomdraglaw) then + do i=is,ie ; if (do_i(i)) then + dhc = hvel(i,nz)*0.5 + ! These expressions assume that Kv_tot(i,nz+1) = CS%Kv, consistent with + ! the suppression of turbulent mixing by the presence of a solid boundary. + if (dhc < bbl_thick(i)) then + a_cpl(i,nz+1) = kv_bbl(i) / ((dhc+h_neglect) + I_amax*kv_bbl(i)) + else + a_cpl(i,nz+1) = kv_bbl(i) / ((bbl_thick(i)+h_neglect) + I_amax*kv_bbl(i)) + endif + endif ; enddo + do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then + ! botfn determines when a point is within the influence of the bottom + ! boundary layer, going from 1 at the bottom to 0 in the interior. + z2 = z_i(i,k) + botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) + + Kv_tot(i,K) = Kv_tot(i,K) + (kv_bbl(i) - CS%Kv)*botfn + dhc = 0.5*(hvel(i,k) + hvel(i,k-1)) + if (dhc > bbl_thick(i)) then + h_shear = ((1.0 - botfn) * dhc + botfn*bbl_thick(i)) + h_neglect + else + h_shear = dhc + h_neglect + endif + + ! Calculate the coupling coefficients from the viscosities. + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + (I_amax * Kv_tot(i,K))) + endif ; enddo ; enddo ! i & k loops + elseif (abs(CS%Kv_extra_bbl) > 0.0) then + ! There is a simple enhancement of the near-bottom viscosities, but no adjustment + ! of the viscous coupling length scales to give a particular bottom stress. + do i=is,ie ; if (do_i(i)) then + a_cpl(i,nz+1) = (Kv_tot(i,nz+1) + CS%Kv_extra_bbl) / & + ((0.5*hvel(i,nz)+h_neglect) + I_amax*(Kv_tot(i,nz+1)+CS%Kv_extra_bbl)) + endif ; enddo + do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then + ! botfn determines when a point is within the influence of the bottom + ! boundary layer, going from 1 at the bottom to 0 in the interior. + z2 = z_i(i,k) + botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) + + Kv_tot(i,K) = Kv_tot(i,K) + CS%Kv_extra_bbl*botfn + h_shear = 0.5*(hvel(i,k) + hvel(i,k-1) + h_neglect) + + ! Calculate the coupling coefficients from the viscosities. + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) + endif ; enddo ; enddo ! i & k loops + else + ! Any near-bottom viscous enhancements were already incorporated into Kv_tot, and there is + ! no adjustment of the viscous coupling length scales to give a particular bottom stress. + do i=is,ie ; if (do_i(i)) then + a_cpl(i,nz+1) = Kv_tot(i,nz+1) / ((0.5*hvel(i,nz)+h_neglect) + I_amax*Kv_tot(i,nz+1)) + endif ; enddo + do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then + h_shear = 0.5*(hvel(i,k) + hvel(i,k-1) + h_neglect) + ! Calculate the coupling coefficients from the viscosities. + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) + endif ; enddo ; enddo ! i & k loops + endif + + ! Add surface intensified viscous coupling, either as a no-slip boundary condition under a + ! rigid ice-shelf, or due to wind-stress driven surface boundary layer mixing that has not + ! already been added via visc%Kv_shear. + if (do_shelf) then + ! Set the coefficients to include the no-slip surface stress. + do i=is,ie ; if (do_i(i)) then + if (work_on_u) then + kv_TBL(i) = visc%Kv_tbl_shelf_u(I,j) + tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) + h_neglect + else + kv_TBL(i) = visc%Kv_tbl_shelf_v(i,J) + tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) + h_neglect + endif + z_t(i) = 0.0 + + ! If a_cpl(i,1) were not already 0, it would be added here. + if (0.5*hvel(i,1) > tbl_thick(i)) then + a_cpl(i,1) = kv_TBL(i) / (tbl_thick(i) + I_amax*kv_TBL(i)) + else + a_cpl(i,1) = kv_TBL(i) / ((0.5*hvel(i,1)+h_neglect) + I_amax*kv_TBL(i)) + endif + endif ; enddo + + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + z_t(i) = z_t(i) + hvel(i,k-1) / tbl_thick(i) + topfn = 1.0 / (1.0 + 0.09 * z_t(i)**6) + + dhc = 0.5*(hvel(i,k)+hvel(i,k-1)) + if (dhc > tbl_thick(i)) then + h_shear = ((1.0 - topfn) * dhc + topfn*tbl_thick(i)) + h_neglect + else + h_shear = dhc + h_neglect + endif + + kv_top = topfn * kv_TBL(i) + a_cpl(i,K) = a_cpl(i,K) + kv_top / (h_shear + I_amax*kv_top) + endif ; enddo ; enddo + + elseif (CS%dynamic_viscous_ML .or. (GV%nkml>0) .or. CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then + + ! Find the friction velocity and the absolute value of the Coriolis parameter at this point. + u_star(:) = 0.0 ! Zero out the friction velocity on land points. + tau_mag(:) = 0.0 ! Zero out the friction velocity on land points. + + if (allocated(tv%SpV_avg)) then + rho_av1(:) = 0.0 + if (work_on_u) then + do I=is,ie ; if (do_i(I)) then + u_star(I) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j)) + rho_av1(I) = 2.0 / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i+1,j,1)) + absf(I) = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + endif ; enddo + if (do_OBCs) then ; do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + u_star(I) = Ustar_2d(i,j) + rho_av1(I) = 1.0 / tv%SpV_avg(i,j,1) + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + u_star(I) = Ustar_2d(i+1,j) + rho_av1(I) = 1.0 / tv%SpV_avg(i+1,j,1) + endif + endif ; enddo ; endif + else ! Work on v-points + do i=is,ie ; if (do_i(i)) then + u_star(i) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1)) + rho_av1(i) = 2.0 / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i,j+1,1)) + absf(i) = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + endif ; enddo + if (do_OBCs) then ; do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + u_star(i) = Ustar_2d(i,j) + rho_av1(i) = 1.0 / tv%SpV_avg(i,j,1) + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + u_star(i) = Ustar_2d(i,j+1) + rho_av1(i) = 1.0 / tv%SpV_avg(i,j+1,1) + endif + endif ; enddo ; endif + endif + do I=is,ie + tau_mag(I) = GV%RZ_to_H*rho_av1(i) * u_star(I)**2 + enddo + else ! (.not.allocated(tv%SpV_avg)) + if (work_on_u) then + do I=is,ie ; if (do_i(I)) then + u_star(I) = 0.5*(Ustar_2d(i,j) + Ustar_2d(i+1,j)) + absf(I) = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + endif ; enddo + if (do_OBCs) then ; do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) & + u_star(I) = Ustar_2d(i,j) + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) & + u_star(I) = Ustar_2d(i+1,j) + endif ; enddo ; endif + else + do i=is,ie ; if (do_i(i)) then + u_star(i) = 0.5*(Ustar_2d(i,j) + Ustar_2d(i,j+1)) + absf(i) = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + endif ; enddo + if (do_OBCs) then ; do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) & + u_star(i) = Ustar_2d(i,j) + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) & + u_star(i) = Ustar_2d(i,j+1) + endif ; enddo ; endif + endif + do I=is,ie + tau_mag(I) = GV%Z_to_H*u_star(I)**2 + enddo + endif + + ! Determine the thickness of the surface ocean boundary layer and its extent in index space. + nk_in_ml(:) = 0 + if (CS%dynamic_viscous_ML) then + ! The fractional number of layers that are within the viscous boundary layer were + ! previously stored in visc%nkml_visc_[uv]. + h_ml(:) = h_neglect + max_nk = 0 + if (work_on_u) then + do i=is,ie ; if (do_i(i)) then + nk_in_ml(I) = ceiling(visc%nkml_visc_u(I,j)) + max_nk = max(max_nk, nk_in_ml(I)) + endif ; enddo + do k=1,max_nk ; do i=is,ie ; if (do_i(i)) then + if (k <= visc%nkml_visc_u(I,j)) then ! This layer is all in the ML. + h_ml(i) = h_ml(i) + hvel(i,k) + elseif (k < visc%nkml_visc_u(I,j) + 1.0) then ! Part of this layer is in the ML. + h_ml(i) = h_ml(i) + ((visc%nkml_visc_u(I,j) + 1.0) - k) * hvel(i,k) + endif + endif ; enddo ; enddo + else + do i=is,ie ; if (do_i(i)) then + nk_in_ml(i) = ceiling(visc%nkml_visc_v(i,J)) + max_nk = max(max_nk, nk_in_ml(i)) + endif ; enddo + do k=1,max_nk ; do i=is,ie ; if (do_i(i)) then + if (k <= visc%nkml_visc_v(i,J)) then ! This layer is all in the ML. + h_ml(i) = h_ml(i) + hvel(i,k) + elseif (k < visc%nkml_visc_v(i,J) + 1.0) then ! Part of this layer is in the ML. + h_ml(i) = h_ml(i) + ((visc%nkml_visc_v(i,J) + 1.0) - k) * hvel(i,k) + endif + endif ; enddo ; enddo + endif + + elseif (GV%nkml>0) then + ! This is a simple application of a refined-bulk mixed layer with GV%nkml sublayers. + max_nk = GV%nkml + do i=is,ie ; if (do_i(i)) then + nk_in_ml(i) = GV%nkml + endif ; enddo + + h_ml(:) = h_neglect + do k=1,GV%nkml ; do i=is,ie ; if (do_i(i)) then + h_ml(i) = h_ml(i) + hvel(i,k) + endif ; enddo ; enddo + elseif (CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then + ! Determine which interfaces are within CS%Hmix of the surface, and set the viscous + ! boundary layer thickness to the the smaller of CS%Hmix and the depth of the ocean. + h_ml(:) = 0.0 + do k=1,nz + can_exit = .true. + do i=is,ie ; if (do_i(i) .and. (h_ml(i) < CS%Hmix)) then + nk_in_ml(i) = k + if (h_ml(i) + hvel(i,k) < CS%Hmix) then + h_ml(i) = h_ml(i) + hvel(i,k) + can_exit = .false. ! Part of the next deeper layer is also in the mixed layer. + else + h_ml(i) = CS%Hmix + endif + endif ; enddo + if (can_exit) exit ! All remaining layers in this row are below the mixed layer depth. + enddo + max_nk = 0 + do i=is,ie ; max_nk = max(max_nk, nk_in_ml(i)) ; enddo + endif + + ! Avoid working on land or on columns where the viscous coupling could not be increased. + do i=is,ie ; if ((u_star(i)<=0.0) .or. (.not.do_i(i))) nk_in_ml(i) = 0 ; enddo + + ! Set the viscous coupling at the interfaces as the larger of what was previously + ! set and the contributions from the surface boundary layer. + z_t(:) = 0.0 + if (CS%apply_LOTW_floor .and. & + (CS%dynamic_viscous_ML .or. (GV%nkml>0) .or. CS%fixed_LOTW_ML)) then + do K=2,max_nk ; do i=is,ie ; if (k <= nk_in_ml(i)) then + z_t(i) = z_t(i) + hvel(i,k-1) + + ! The viscosity in visc_ml is set to go to 0 at the mixed layer top and bottom + ! (in a log-layer) and be further limited by rotation to give the natural Ekman length. + temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) + if (GV%Boussinesq) then + ustar2_denom = (CS%vonKar * GV%Z_to_H*u_star(i)**2) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + else + ustar2_denom = (CS%vonKar * tau_mag(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + endif + visc_ml = temp1 * ustar2_denom + ! Set the viscous coupling based on the model's vertical resolution. The omission of + ! the I_amax factor here is consistent with answer dates above 20190101. + a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect)) + + ! As a floor on the viscous coupling, assume that the length scale in the denominator can + ! not be larger than the distance from the surface, consistent with a logarithmic velocity + ! profile. This is consistent with visc_ml, but cancels out common factors of z_t. + a_floor = (h_ml(i) - z_t(i)) * ustar2_denom + + ! Choose the largest estimate of a_cpl. + a_cpl(i,K) = max(a_cpl(i,K), a_ml, a_floor) + ! An option could be added to change this to: a_cpl(i,K) = max(a_cpl(i,K) + a_ml, a_floor) + endif ; enddo ; enddo + elseif (CS%apply_LOTW_floor) then + do K=2,max_nk ; do i=is,ie ; if (k <= nk_in_ml(i)) then + z_t(i) = z_t(i) + hvel(i,k-1) + + temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) + if (GV%Boussinesq) then + ustar2_denom = (CS%vonKar * GV%Z_to_H*u_star(i)**2) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + else + ustar2_denom = (CS%vonKar * tau_mag(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + endif + + ! As a floor on the viscous coupling, assume that the length scale in the denominator can not + ! be larger than the distance from the surface, consistent with a logarithmic velocity profile. + a_cpl(i,K) = max(a_cpl(i,K), (h_ml(i) - z_t(i)) * ustar2_denom) + endif ; enddo ; enddo + else + do K=2,max_nk ; do i=is,ie ; if (k <= nk_in_ml(i)) then + z_t(i) = z_t(i) + hvel(i,k-1) + + temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) + ! This viscosity is set to go to 0 at the mixed layer top and bottom (in a log-layer) + ! and be further limited by rotation to give the natural Ekman length. + ! The following expressions are mathematically equivalent. + if (GV%Boussinesq .or. (CS%answer_date < 20230601)) then + visc_ml = u_star(i) * CS%vonKar * (GV%Z_to_H*temp1*u_star(i)) / & + (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + else + visc_ml = CS%vonKar * (temp1*tau_mag(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + endif + a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect) + 0.5*I_amax*visc_ml) + + ! Choose the largest estimate of a_cpl, but these could be changed to be additive. + a_cpl(i,K) = max(a_cpl(i,K), a_ml) + ! An option could be added to change this to: a_cpl(i,K) = a_cpl(i,K) + a_ml + endif ; enddo ; enddo + endif + endif + +end subroutine find_coupling_coef + +!> Velocity components which exceed a threshold for physically reasonable values +!! are truncated. Optionally, any column with excessive velocities may be sent +!! to a diagnostic reporting subroutine. +subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(accel_diag_ptrs), intent(in) :: ADp !< Acceleration diagnostic pointers + type(cont_diag_ptrs), intent(in) :: CDp !< Continuity diagnostic pointers + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag + real, intent(in) :: dt !< Time increment [T ~> s] + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + + ! Local variables + + real :: maxvel ! Velocities components greater than maxvel are truncated [L T-1 ~> m s-1] + real :: truncvel ! The speed to which velocity components greater than maxvel are set [L T-1 ~> m s-1] + real :: CFL ! The local CFL number [nondim] + real :: H_report ! A thickness below which not to report truncations [H ~> m or kg m-2] + real :: vel_report(SZIB_(G),SZJB_(G)) ! The velocity to report [L T-1 ~> m s-1] + real :: u_old(SZIB_(G),SZJ_(G),SZK_(GV)) ! The previous u-velocity [L T-1 ~> m s-1] + real :: v_old(SZI_(G),SZJB_(G),SZK_(GV)) ! The previous v-velocity [L T-1 ~> m s-1] + logical :: trunc_any, dowrite(SZIB_(G),SZJB_(G)) + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + 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 + + maxvel = CS%maxvel + truncvel = 0.9*maxvel + H_report = 6.0 * GV%Angstrom_H + + if (len_trim(CS%u_trunc_file) > 0) then + !$OMP parallel do default(shared) private(trunc_any,CFL) + do j=js,je + trunc_any = .false. + do I=Isq,Ieq ; dowrite(I,j) = .false. ; enddo + if (CS%CFL_based_trunc) then + do I=Isq,Ieq ; vel_report(i,j) = 3.0e8*US%m_s_to_L_T ; enddo ! Speed of light default. + do k=1,nz ; do I=Isq,Ieq + if (abs(u(I,j,k)) < CS%vel_underflow) u(I,j,k) = 0.0 + if (u(I,j,k) < 0.0) then + CFL = (-u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) + else + CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) + endif + if (CFL > CS%CFL_trunc) trunc_any = .true. + if (CFL > CS%CFL_report) then + dowrite(I,j) = .true. + vel_report(I,j) = MIN(vel_report(I,j), abs(u(I,j,k))) + endif + enddo ; enddo + else + do I=Isq,Ieq; vel_report(I,j) = maxvel; enddo + do k=1,nz ; do I=Isq,Ieq + if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 + elseif (abs(u(I,j,k)) > maxvel) then + dowrite(I,j) = .true. ; trunc_any = .true. + endif + enddo ; enddo + endif + + do I=Isq,Ieq ; if (dowrite(I,j)) then + u_old(I,j,:) = u(I,j,:) + endif ; enddo + + if (trunc_any) then ; if (CS%CFL_based_trunc) then + do k=1,nz ; do I=Isq,Ieq + if ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then + u(I,j,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) + if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then + u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) + if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + endif + enddo ; enddo + else + do k=1,nz ; do I=Isq,Ieq ; if (abs(u(I,j,k)) > maxvel) then + u(I,j,k) = SIGN(truncvel,u(I,j,k)) + if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + endif ; enddo ; enddo + endif ; endif + enddo ! j-loop + else ! Do not report accelerations leading to large velocities. + if (CS%CFL_based_trunc) then + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 + elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then + u(I,j,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) + if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then + u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) + if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + endif + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 + elseif (abs(u(I,j,k)) > maxvel) then + u(I,j,k) = SIGN(truncvel, u(I,j,k)) + if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + endif + enddo ; enddo ; enddo + endif + endif + + if (len_trim(CS%u_trunc_file) > 0) then + do j=js,je ; do I=Isq,Ieq ; if (dowrite(I,j)) then + ! Call a diagnostic reporting subroutines are called if unphysically large values are found. + call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & + vel_report(I,j), forces%taux(I,j), a=CS%a_u, hv=CS%h_u) + endif ; enddo ; enddo + endif + + if (len_trim(CS%v_trunc_file) > 0) then + !$OMP parallel do default(shared) private(trunc_any,CFL) + do J=Jsq,Jeq + trunc_any = .false. + do i=is,ie ; dowrite(i,J) = .false. ; enddo + if (CS%CFL_based_trunc) then + do i=is,ie ; vel_report(i,J) = 3.0e8*US%m_s_to_L_T ; enddo ! Speed of light default. + do k=1,nz ; do i=is,ie + if (abs(v(i,J,k)) < CS%vel_underflow) v(i,J,k) = 0.0 + if (v(i,J,k) < 0.0) then + CFL = (-v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) + else + CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) + endif + if (CFL > CS%CFL_trunc) trunc_any = .true. + if (CFL > CS%CFL_report) then + dowrite(i,J) = .true. + vel_report(i,J) = MIN(vel_report(i,J), abs(v(i,J,k))) + endif + enddo ; enddo + else + do i=is,ie ; vel_report(i,J) = maxvel ; enddo + do k=1,nz ; do i=is,ie + if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0 + elseif (abs(v(i,J,k)) > maxvel) then + dowrite(i,J) = .true. ; trunc_any = .true. + endif + enddo ; enddo + endif + + do i=is,ie ; if (dowrite(i,J)) then + v_old(i,J,:) = v(i,J,:) + endif ; enddo + + if (trunc_any) then ; if (CS%CFL_based_trunc) then + do k=1,nz ; do i=is,ie + if ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then + v(i,J,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) + if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then + v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) + if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + endif + enddo ; enddo + else + do k=1,nz ; do i=is,ie ; if (abs(v(i,J,k)) > maxvel) then + v(i,J,k) = SIGN(truncvel,v(i,J,k)) + if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + endif ; enddo ; enddo + endif ; endif + enddo ! J-loop + else ! Do not report accelerations leading to large velocities. + if (CS%CFL_based_trunc) then + !$OMP parallel do default(shared) + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0 + elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then + v(i,J,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) + if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then + v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) + if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + endif + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0 + elseif (abs(v(i,J,k)) > maxvel) then + v(i,J,k) = SIGN(truncvel, v(i,J,k)) + if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + endif + enddo ; enddo ; enddo + endif + endif + + if (len_trim(CS%v_trunc_file) > 0) then + do J=Jsq,Jeq ; do i=is,ie ; if (dowrite(i,J)) then + ! Call a diagnostic reporting subroutines are called if unphysically large values are found. + call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & + vel_report(i,J), forces%tauy(i,J), a=CS%a_v, hv=CS%h_v) + endif ; enddo ; enddo + endif + +end subroutine vertvisc_limit_vel + +!> Initialize the vertical friction module +subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & + ntrunc, CS) + type(ocean_internal_state), & + target, intent(in) :: MIS !< The "MOM Internal State", a set of pointers + !! to the fields and accelerations that make + !! up the ocean's physical state + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< File to parse for parameters + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostic control structure + type(accel_diag_ptrs), intent(inout) :: ADp !< Acceleration diagnostic pointers + type(directories), intent(in) :: dirs !< Relevant directory paths + integer, target, intent(inout) :: ntrunc !< Number of velocity truncations + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + + ! Local variables + + real :: Kv_BBL ! A viscosity in the bottom boundary layer with a simple scheme [H Z T-1 ~> m2 s-1 or Pa s] + real :: Kv_back_z ! A background kinematic viscosity [Z2 T-1 ~> m2 s-1] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz + character(len=200) :: kappa_gl90_file, inputdir, kdgl90_varname + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_vert_friction" ! This module's name. + character(len=40) :: thickness_units + real :: Kv_mks ! KVML in MKS + + if (associated(CS)) then + call MOM_error(WARNING, "vertvisc_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + CS%initialized = .true. + + if (GV%Boussinesq) then; thickness_units = "m" + else; thickness_units = "kg m-2"; endif + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + CS%diag => diag ; CS%ntrunc => ntrunc ; ntrunc = 0 + +! Default, read and log parameters + call log_version(param_file, mdl, version, "", log_to_all=.true., debugging=.true.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "VERT_FRICTION_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the viscous "//& + "calculations. Values below 20190101 recover the answers from the end of 2018, "//& + "while higher values use expressions that do not use an arbitrary hard-coded "//& + "maximum viscous coupling coefficient between layers. Values below 20230601 "//& + "recover a form of the viscosity within the mixed layer that breaks up the "//& + "magnitude of the wind stress in some non-Boussinesq cases.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + + call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & + "If true, the bottom stress is calculated with a drag "//& + "law of the form c_drag*|u|*u. The velocity magnitude "//& + "may be an assumed value or it may be based on the "//& + "actual velocity in the bottommost HBBL, depending on "//& + "LINEAR_DRAG.", default=.true.) + call get_param(param_file, mdl, "DIRECT_STRESS", CS%direct_stress, & + "If true, the wind stress is distributed over the topmost HMIX_STRESS of fluid "//& + "(like in HYCOM), and an added mixed layer viscosity or a physically based "//& + "boundary layer turbulence parameterization is not needed for stability.", & + default=.false.) + call get_param(param_file, mdl, "DYNAMIC_VISCOUS_ML", CS%dynamic_viscous_ML, & + "If true, use a bulk Richardson number criterion to "//& + "determine the mixed layer thickness for viscosity.", & + default=.false.) + call get_param(param_file, mdl, "FIXED_DEPTH_LOTW_ML", CS%fixed_LOTW_ML, & + "If true, use a Law-of-the-wall prescription for the mixed layer viscosity "//& + "within a boundary layer that is the lesser of HMIX_FIXED and the total "//& + "depth of the ocean in a column.", default=.false.) + call get_param(param_file, mdl, "LOTW_VISCOUS_ML_FLOOR", CS%apply_LOTW_floor, & + "If true, use a Law-of-the-wall prescription to set a lower bound on the "//& + "viscous coupling between layers within the surface boundary layer, based "//& + "the distance of interfaces from the surface. This only acts when there "//& + "are large changes in the thicknesses of successive layers or when the "//& + "viscosity is set externally and the wind stress has subsequently increased.", & + default=.false.) + call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) + call get_param(param_file, mdl, "U_TRUNC_FILE", CS%u_trunc_file, & + "The absolute path to a file into which the accelerations "//& + "leading to zonal velocity truncations are written. "//& + "Undefine this for efficiency if this diagnostic is not needed.", & + default=" ", debuggingParam=.true.) + call get_param(param_file, mdl, "V_TRUNC_FILE", CS%v_trunc_file, & + "The absolute path to a file into which the accelerations "//& + "leading to meridional velocity truncations are written. "//& + "Undefine this for efficiency if this diagnostic is not needed.", & + default=" ", debuggingParam=.true.) + call get_param(param_file, mdl, "HARMONIC_VISC", CS%harmonic_visc, & + "If true, use the harmonic mean thicknesses for "//& + "calculating the vertical viscosity.", default=.false.) + call get_param(param_file, mdl, "HARMONIC_BL_SCALE", CS%harm_BL_val, & + "A scale to determine when water is in the boundary "//& + "layers based solely on harmonic mean thicknesses for "//& + "the purpose of determining the extent to which the "//& + "thicknesses used in the viscosities are upwinded.", & + default=0.0, units="nondim") + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) + + if (GV%nkml < 1) then + call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & + "The prescribed depth over which the near-surface viscosity and "//& + "diffusivity are elevated when the bulk mixed layer is not used.", & + units="m", scale=US%m_to_Z, fail_if_missing=.true.) + endif + if (CS%direct_stress) then + if (GV%nkml < 1) then + call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & + "The depth over which the wind stress is applied if DIRECT_STRESS is true.", & + units="m", default=US%Z_to_m*CS%Hmix, scale=GV%m_to_H) + else + call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & + "The depth over which the wind stress is applied if DIRECT_STRESS is true.", & + units="m", fail_if_missing=.true., scale=GV%m_to_H) + endif + if (CS%Hmix_stress <= 0.0) call MOM_error(FATAL, "vertvisc_init: " // & + "HMIX_STRESS must be set to a positive value if DIRECT_STRESS is true.") + endif + call get_param(param_file, mdl, "KV", Kv_back_z, & + "The background kinematic viscosity in the interior. "//& + "The molecular value, ~1e-6 m2 s-1, may be used.", & + units="m2 s-1", fail_if_missing=.true., scale=US%m2_s_to_Z2_T) + ! Convert input kinematic viscosity to dynamic viscosity when non-Boussinesq. + CS%Kv = (US%Z2_T_to_m2_s*GV%m2_s_to_HZ_T) * Kv_back_z + + call get_param(param_file, mdl, "USE_GL90_IN_SSW", CS%use_GL90_in_SSW, & + "If true, use simpler method to calculate 1/N^2 in GL90 vertical "// & + "viscosity coefficient. This method is valid in stacked shallow water mode.", & + default=.false.) + call get_param(param_file, mdl, "KD_GL90", CS%kappa_gl90, & + "The scalar diffusivity used in GL90 vertical viscosity scheme.", & + units="m2 s-1", default=0.0, scale=US%m_to_L*US%Z_to_L*GV%m_to_H*US%T_to_s, & + do_not_log=.not.CS%use_GL90_in_SSW) + call get_param(param_file, mdl, "READ_KD_GL90", CS%read_kappa_gl90, & + "If true, read a file (given by KD_GL90_FILE) containing the "//& + "spatially varying diffusivity KD_GL90 used in the GL90 scheme.", default=.false., & + do_not_log=.not.CS%use_GL90_in_SSW) + if (CS%read_kappa_gl90) then + if (CS%kappa_gl90 > 0) then + call MOM_error(FATAL, "MOM_vert_friction.F90, vertvisc_init: KD_GL90 > 0 "// & + "is not compatible with READ_KD_GL90 = .TRUE. ") + endif + call get_param(param_file, mdl, "INPUTDIR", inputdir, & + "The directory in which all input files are found.", & + default=".", do_not_log=.true.) + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "KD_GL90_FILE", kappa_gl90_file, & + "The file containing the spatially varying diffusivity used in the "// & + "GL90 scheme.", default="kd_gl90.nc", do_not_log=.not.CS%use_GL90_in_SSW) + call get_param(param_file, mdl, "KD_GL90_VARIABLE", kdgl90_varname, & + "The name of the GL90 diffusivity variable to read "//& + "from KD_GL90_FILE.", default="kd_gl90", do_not_log=.not.CS%use_GL90_in_SSW) + kappa_gl90_file = trim(inputdir) // trim(kappa_gl90_file) + + allocate(CS%kappa_gl90_2d(G%isd:G%ied, G%jsd:G%jed), source=0.0) + call MOM_read_data(kappa_gl90_file, kdgl90_varname, CS%kappa_gl90_2d(:,:), G%domain, & + scale=US%m_to_L*US%Z_to_L*GV%m_to_H*US%T_to_s) + call pass_var(CS%kappa_gl90_2d, G%domain) + endif + call get_param(param_file, mdl, "USE_GL90_N2", CS%use_GL90_N2, & + "If true, use GL90 vertical viscosity coefficient that is depth-independent; "// & + "this corresponds to a kappa_GM that scales as N^2 with depth.", & + default=.false., do_not_log=.not.CS%use_GL90_in_SSW) + if (CS%use_GL90_N2) then + if (.not. CS%use_GL90_in_SSW) call MOM_error(FATAL, & + "MOM_vert_friction.F90, vertvisc_init: "//& + "When USE_GL90_N2=True, USE_GL90_in_SSW must also be True.") + if (CS%kappa_gl90 > 0) then + call MOM_error(FATAL, "MOM_vert_friction.F90, vertvisc_init: KD_GL90 > 0 "// & + "is not compatible with USE_GL90_N2 = .TRUE. ") + endif + if (CS%read_kappa_gl90) call MOM_error(FATAL, & + "MOM_vert_friction.F90, vertvisc_init: "//& + "READ_KD_GL90 = .TRUE. is not compatible with USE_GL90_N2 = .TRUE.") + call get_param(param_file, mdl, "alpha_GL90", CS%alpha_gl90, & + "Coefficient used to compute a depth-independent GL90 vertical "//& + "viscosity via Kv_GL90 = alpha_GL90 * f2. Is only used "// & + "if USE_GL90_N2 is true. Note that the implied Kv_GL90 "// & + "corresponds to a KD_GL90 that scales as N^2 with depth.", & + units="m2 s", default=0.0, scale=GV%m_to_H*US%m_to_Z*US%s_to_T, & + do_not_log=.not.CS%use_GL90_in_SSW) + endif + call get_param(param_file, mdl, "HBBL_GL90", CS%Hbbl_gl90, & + "The thickness of the GL90 bottom boundary layer, "//& + "which defines the range over which the GL90 coupling "//& + "coefficient is zeroed out, in order to avoid fluxing "//& + "momentum into vanished layers over steep topography.", & + units="m", default=5.0, scale=US%m_to_Z, do_not_log=.not.CS%use_GL90_in_SSW) + + CS%Kvml_invZ2 = 0.0 + if (GV%nkml < 1) then + call get_param(param_file, mdl, "KVML", Kv_mks, & + "The scale for an extra kinematic viscosity in the mixed layer", & + units="m2 s-1", default=-1.0, do_not_log=.true.) + if (Kv_mks >= 0.0) then + call MOM_error(WARNING, "KVML is a deprecated parameter. Use KV_ML_INVZ2 instead.") + else + Kv_mks = 0.0 + endif + call get_param(param_file, mdl, "KV_ML_INVZ2", CS%Kvml_invZ2, & + "An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, "//& + "with the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the "//& + "distance from the surface, to allow for finite wind stresses to be "//& + "transmitted through infinitesimally thin surface layers. This is an "//& + "older option for numerical convenience without a strong physical basis, "//& + "and its use is now discouraged.", & + units="m2 s-1", default=Kv_mks, scale=GV%m2_s_to_HZ_T) + endif + + if (.not.CS%bottomdraglaw) then + call get_param(param_file, mdl, "KV_EXTRA_BBL", CS%Kv_extra_bbl, & + "An extra kinematic viscosity in the benthic boundary layer. "//& + "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) + if (CS%Kv_extra_bbl == 0.0) then + call get_param(param_file, mdl, "KVBBL", Kv_BBL, & + "An extra kinematic viscosity in the benthic boundary layer. "//& + "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_back_z, scale=GV%m2_s_to_HZ_T, & + do_not_log=.true.) + if (abs(Kv_BBL - CS%Kv) > 1.0e-15*abs(CS%Kv)) then + call MOM_error(WARNING, "KVBBL is a deprecated parameter. Use KV_EXTRA_BBL instead.") + CS%Kv_extra_bbl = Kv_BBL - CS%Kv + endif + endif + call log_param(param_file, mdl, "KV_EXTRA_BBL", CS%Kv_extra_bbl, & + "An extra kinematic viscosity in the benthic boundary layer. "//& + "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & + units="m2 s-1", default=0.0, unscale=GV%HZ_T_to_m2_s) + endif + call get_param(param_file, mdl, "HBBL", CS%Hbbl, & + "The thickness of a bottom boundary layer with a viscosity increased by "//& + "KV_EXTRA_BBL if BOTTOMDRAGLAW is not defined, or the thickness over which "//& + "near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is "//& + "defined but LINEAR_DRAG is not.", & + units="m", fail_if_missing=.true., scale=US%m_to_Z) + call get_param(param_file, mdl, "MAXVEL", CS%maxvel, & + "The maximum velocity allowed before the velocity components are truncated.", & + units="m s-1", default=3.0e8, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "CFL_BASED_TRUNCATIONS", CS%CFL_based_trunc, & + "If true, base truncations on the CFL number, and not an absolute speed.", & + default=.true.) + call get_param(param_file, mdl, "CFL_TRUNCATE", CS%CFL_trunc, & + "The value of the CFL number that will cause velocity "//& + "components to be truncated; instability can occur past 0.5.", & + units="nondim", default=0.5) + call get_param(param_file, mdl, "CFL_REPORT", CS%CFL_report, & + "The value of the CFL number that causes accelerations "//& + "to be reported; the default is CFL_TRUNCATE.", & + units="nondim", default=CS%CFL_trunc) + call get_param(param_file, mdl, "CFL_TRUNCATE_RAMP_TIME", CS%truncRampTime, & + "The time over which the CFL truncation value is ramped "//& + "up at the beginning of the run.", & + units="s", default=0., scale=US%s_to_T) + CS%CFL_truncE = CS%CFL_trunc + call get_param(param_file, mdl, "CFL_TRUNCATE_START", CS%CFL_truncS, & + "The start value of the truncation CFL number used when "//& + "ramping up CFL_TRUNC.", & + units="nondim", default=0.) + call get_param(param_file, mdl, "STOKES_MIXING_COMBINED", CS%StokesMixing, & + "Flag to use Stokes drift Mixing via the Lagrangian "//& + " current (Eulerian plus Stokes drift). "//& + " Still needs work and testing, so not recommended for use.",& + default=.false.) + !BGR 04/04/2018{ + ! StokesMixing is required for MOM6 for some Langmuir mixing parameterization. + ! The code used here has not been developed for vanishing layers or in + ! conjunction with any bottom friction. Therefore, the following line is + ! added so this functionality cannot be used without user intervention in + ! the code. This will prevent general use of this functionality until proper + ! care is given to the previously mentioned issues. Comment out the following + ! MOM_error to use, but do so at your own risk and with these points in mind. + !} + if (CS%StokesMixing) then + call MOM_error(FATAL, "Stokes mixing requires user intervention in the code.\n"//& + " Model now exiting. See MOM_vert_friction.F90 for \n"//& + " details (search 'BGR 04/04/2018' to locate comment).") + endif + call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & + "A negligibly small velocity magnitude below which velocity "//& + "components are set to 0. A reasonable value might be "//& + "1e-30 m/s, which is less than an Angstrom divided by "//& + "the age of the universe.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) + + ALLOC_(CS%a_u(IsdB:IedB,jsd:jed,nz+1)) ; CS%a_u(:,:,:) = 0.0 + ALLOC_(CS%a_u_gl90(IsdB:IedB,jsd:jed,nz+1)) ; CS%a_u_gl90(:,:,:) = 0.0 + ALLOC_(CS%h_u(IsdB:IedB,jsd:jed,nz)) ; CS%h_u(:,:,:) = 0.0 + ALLOC_(CS%a_v(isd:ied,JsdB:JedB,nz+1)) ; CS%a_v(:,:,:) = 0.0 + ALLOC_(CS%a_v_gl90(isd:ied,JsdB:JedB,nz+1)) ; CS%a_v_gl90(:,:,:) = 0.0 + ALLOC_(CS%h_v(isd:ied,JsdB:JedB,nz)) ; CS%h_v(:,:,:) = 0.0 + + CS%id_Kv_slow = register_diag_field('ocean_model', 'Kv_slow', diag%axesTi, Time, & + 'Slow varying vertical viscosity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + + CS%id_Kv_u = register_diag_field('ocean_model', 'Kv_u', diag%axesCuL, Time, & + 'Total vertical viscosity at u-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) + + CS%id_Kv_v = register_diag_field('ocean_model', 'Kv_v', diag%axesCvL, Time, & + 'Total vertical viscosity at v-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) + + CS%id_Kv_gl90_u = register_diag_field('ocean_model', 'Kv_gl90_u', diag%axesCuL, Time, & + 'GL90 vertical viscosity at u-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) + + CS%id_Kv_gl90_v = register_diag_field('ocean_model', 'Kv_gl90_v', diag%axesCvL, Time, & + 'GL90 vertical viscosity at v-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) + + CS%id_au_vv = register_diag_field('ocean_model', 'au_visc', diag%axesCui, Time, & + 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) + + CS%id_av_vv = register_diag_field('ocean_model', 'av_visc', diag%axesCvi, Time, & + 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) + + CS%id_au_gl90_vv = register_diag_field('ocean_model', 'au_gl90_visc', diag%axesCui, Time, & + 'Zonal Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) + + CS%id_av_gl90_vv = register_diag_field('ocean_model', 'av_gl90_visc', diag%axesCvi, Time, & + 'Meridional Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) + + CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & + 'Thickness at Zonal Velocity Points for Viscosity', & + thickness_units, conversion=GV%H_to_MKS) + ! Alternately, to always give this variable in 'm' use the following line instead: + ! 'm', conversion=GV%H_to_m) + + CS%id_h_v = register_diag_field('ocean_model', 'Hv_visc', diag%axesCvL, Time, & + 'Thickness at Meridional Velocity Points for Viscosity', & + thickness_units, conversion=GV%H_to_MKS) + + CS%id_hML_u = register_diag_field('ocean_model', 'HMLu_visc', diag%axesCu1, Time, & + 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', & + thickness_units, conversion=US%Z_to_m) + + CS%id_hML_v = register_diag_field('ocean_model', 'HMLv_visc', diag%axesCv1, Time, & + 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', & + thickness_units, conversion=US%Z_to_m) + + CS%id_FPw2x = register_diag_field('ocean_model', 'FPw2x', diag%axesT1, Time, & + 'Wind direction from x-axis','radians') + CS%id_tauFP_u = register_diag_field('ocean_model', 'tauFP_u', diag%axesCui, Time, & + 'Stress Mag Profile (u-points)', 'm2 s-2') + CS%id_tauFP_v = register_diag_field('ocean_model', 'tauFP_v', diag%axesCvi, Time, & + 'Stress Mag Profile (v-points)', 'm2 s-2') + CS%id_FPtau2s_u = register_diag_field('ocean_model', 'FPtau2s_u', diag%axesCui, Time, & + 'stress from shear direction (u-points)', 'radians ') + CS%id_FPtau2s_v = register_diag_field('ocean_model', 'FPtau2s_v', diag%axesCvi, Time, & + 'stress from shear direction (v-points)', 'radians') + CS%id_FPtau2w_u = register_diag_field('ocean_model', 'FPtau2w_u', diag%axesCui, Time, & + 'stress from wind direction (u-points)', 'radians') + CS%id_FPtau2w_v = register_diag_field('ocean_model', 'FPtau2w_v', diag%axesCvi, Time, & + 'stress from wind direction (v-points)', 'radians') + + CS%id_du_dt_visc = register_diag_field('ocean_model', 'du_dt_visc', diag%axesCuL, Time, & + 'Zonal Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_du_dt_visc > 0) call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + CS%id_dv_dt_visc = register_diag_field('ocean_model', 'dv_dt_visc', diag%axesCvL, Time, & + 'Meridional Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_dv_dt_visc > 0) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + CS%id_GLwork = register_diag_field('ocean_model', 'GLwork', diag%axesTL, Time, & + 'Sign-definite Kinetic Energy Source from GL90 Vertical Viscosity', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_du_dt_visc_gl90 = register_diag_field('ocean_model', 'du_dt_visc_gl90', diag%axesCuL, Time, & + 'Zonal Acceleration from GL90 Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + if ((CS%id_du_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + call safe_alloc_ptr(ADp%du_dt_visc_gl90,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + endif + CS%id_dv_dt_visc_gl90 = register_diag_field('ocean_model', 'dv_dt_visc_gl90', diag%axesCvL, Time, & + 'Meridional Acceleration from GL90 Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + if ((CS%id_dv_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + call safe_alloc_ptr(ADp%dv_dt_visc_gl90,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + endif + CS%id_du_dt_str = register_diag_field('ocean_model', 'du_dt_str', diag%axesCuL, Time, & + 'Zonal Acceleration from Surface Wind Stresses', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_du_dt_str > 0) call safe_alloc_ptr(ADp%du_dt_str,IsdB,IedB,jsd,jed,nz) + CS%id_dv_dt_str = register_diag_field('ocean_model', 'dv_dt_str', diag%axesCvL, Time, & + 'Meridional Acceleration from Surface Wind Stresses', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_dv_dt_str > 0) call safe_alloc_ptr(ADp%dv_dt_str,isd,ied,JsdB,JedB,nz) + + CS%id_taux_bot = register_diag_field('ocean_model', 'taux_bot', diag%axesCu1, & + Time, 'Zonal Bottom Stress from Ocean to Earth', & + 'Pa', conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) + CS%id_tauy_bot = register_diag_field('ocean_model', 'tauy_bot', diag%axesCv1, & + Time, 'Meridional Bottom Stress from Ocean to Earth', & + 'Pa', conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) + + !CS%id_hf_du_dt_visc = register_diag_field('ocean_model', 'hf_du_dt_visc', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_du_dt_visc > 0) then + ! call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_dv_dt_visc = register_diag_field('ocean_model', 'hf_dv_dt_visc', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_dv_dt_visc > 0) then + ! call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + !endif + + CS%id_hf_du_dt_visc_2d = register_diag_field('ocean_model', 'hf_du_dt_visc_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_du_dt_visc_2d > 0) then + call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_dv_dt_visc_2d = register_diag_field('ocean_model', 'hf_dv_dt_visc_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_dv_dt_visc_2d > 0) then + call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + endif + + CS%id_h_du_dt_visc = register_diag_field('ocean_model', 'h_du_dt_visc', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Horizontal Viscosity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_du_dt_visc > 0) then + call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_h_dv_dt_visc = register_diag_field('ocean_model', 'h_dv_dt_visc', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Horizontal Viscosity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_dv_dt_visc > 0) then + call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%diag_hv,isd,ied,JsdB,JedB,nz) + endif + + CS%id_h_du_dt_str = register_diag_field('ocean_model', 'h_du_dt_str', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Surface Wind Stresses', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_du_dt_str > 0) then + call safe_alloc_ptr(ADp%du_dt_str,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_h_dv_dt_str = register_diag_field('ocean_model', 'h_dv_dt_str', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Surface Wind Stresses', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_dv_dt_str > 0) then + call safe_alloc_ptr(ADp%dv_dt_str,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%diag_hv,isd,ied,JsdB,JedB,nz) + endif + + CS%id_du_dt_str_visc_rem = register_diag_field('ocean_model', 'du_dt_str_visc_rem', diag%axesCuL, Time, & + 'Zonal Acceleration from Surface Wind Stresses multiplied by viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_du_dt_str_visc_rem > 0) then + call safe_alloc_ptr(ADp%du_dt_str,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_dv_dt_str_visc_rem = register_diag_field('ocean_model', 'dv_dt_str_visc_rem', diag%axesCvL, Time, & + 'Meridional Acceleration from Surface Wind Stresses multiplied by viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_dv_dt_str_visc_rem > 0) then + call safe_alloc_ptr(ADp%dv_dt_str,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + endif + + if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) & + call PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS%PointAccel_CSp) + +end subroutine vertvisc_init + +!> Update the CFL truncation value as a function of time. +!! If called with the optional argument activate=.true., record the +!! value of Time as the beginning of the ramp period. +subroutine updateCFLtruncationValue(Time, CS, US, activate) + type(time_type), target, intent(in) :: Time !< Current model time + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, optional, intent(in) :: activate !< Specify whether to record the value of + !! Time as the beginning of the ramp period + + ! Local variables + real :: deltaTime ! The time since CS%rampStartTime [T ~> s], which may be negative. + real :: wghtA ! The relative weight of the final value [nondim] + character(len=12) :: msg + + if (CS%truncRampTime==0.) return ! This indicates to ramping is turned off + + ! We use the optional argument to indicate this Time should be recorded as the + ! beginning of the ramp-up period. + if (present(activate)) then + if (activate) then + CS%rampStartTime = Time ! Record the current time + CS%CFLrampingIsActivated = .true. + endif + endif + if (.not.CS%CFLrampingIsActivated) return + deltaTime = max( 0., US%s_to_T*time_type_to_real( Time - CS%rampStartTime ) ) + if (deltaTime >= CS%truncRampTime) then + CS%CFL_trunc = CS%CFL_truncE + CS%truncRampTime = 0. ! This turns off ramping after this call + else + wghtA = min( 1., deltaTime / CS%truncRampTime ) ! Linear profile in time + !wghtA = wghtA*wghtA ! Convert linear profile to parabolic profile in time + !wghtA = wghtA*wghtA*(3. - 2.*wghtA) ! Convert linear profile to cosine profile + wghtA = 1. - ( (1. - wghtA)**2 ) ! Convert linear profile to inverted parabolic profile + CS%CFL_trunc = CS%CFL_truncS + wghtA * ( CS%CFL_truncE - CS%CFL_truncS ) + endif + write(msg(1:12),'(es12.3)') CS%CFL_trunc + call MOM_error(NOTE, "MOM_vert_friction: updateCFLtruncationValue set CFL"// & + " limit to "//trim(msg)) +end subroutine updateCFLtruncationValue + +!> Clean up and deallocate the vertical friction module +subroutine vertvisc_end(CS) + type(vertvisc_CS), intent(inout) :: CS !< Vertical viscosity control structure that + !! will be deallocated in this subroutine. + + if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) & + deallocate(CS%PointAccel_CSp) + + DEALLOC_(CS%a_u) ; DEALLOC_(CS%h_u) + DEALLOC_(CS%a_v) ; DEALLOC_(CS%h_v) + if (associated(CS%a1_shelf_u)) deallocate(CS%a1_shelf_u) + if (associated(CS%a1_shelf_v)) deallocate(CS%a1_shelf_v) + if (allocated(CS%kappa_gl90_2d)) deallocate(CS%kappa_gl90_2d) +end subroutine vertvisc_end + +!> \namespace mom_vert_friction +!! \author Robert Hallberg +!! \date April 1994 - October 2006 +!! +!! The vertical diffusion of momentum is fully implicit. This is +!! necessary to allow for vanishingly small layers. The coupling +!! is based on the distance between the centers of adjacent layers, +!! except where a layer is close to the bottom compared with a +!! bottom boundary layer thickness when a bottom drag law is used. +!! A stress top b.c. and a no slip bottom b.c. are used. There +!! is no limit on the time step for vertvisc. +!! +!! Near the bottom, the horizontal thickness interpolation scheme +!! changes to an upwind biased estimate to control the effect of +!! spurious Montgomery potential gradients at the bottom where +!! nearly massless layers layers ride over the topography. Within a +!! few boundary layer depths of the bottom, the harmonic mean +!! thickness (i.e. (2 h+ h-) / (h+ + h-) ) is used if the velocity +!! is from the thinner side and the arithmetic mean thickness +!! (i.e. (h+ + h-)/2) is used if the velocity is from the thicker +!! side. Both of these thickness estimates are second order +!! accurate. Above this the arithmetic mean thickness is used. +!! +!! In addition, vertvisc truncates any velocity component that +!! exceeds maxvel to truncvel. This basically keeps instabilities +!! spatially localized. The number of times the velocity is +!! truncated is reported each time the energies are saved, and if +!! exceeds CS%Maxtrunc the model will stop itself and change the time +!! to a large value. This has proven very useful in (1) diagnosing +!! model failures and (2) letting the model settle down to a +!! meaningful integration from a poorly specified initial condition. +!! +!! The same code is used for the two velocity components, by +!! indirectly referencing the velocities and defining a handful of +!! direction-specific defined variables. +!! +!! Macros written all in capital letters are defined in MOM_memory.h. +!! +!! A small fragment of the grid is shown below: +!! \verbatim +!! j+1 x ^ x ^ x At x: q +!! j+1 > o > o > At ^: v, frhatv, tauy +!! j x ^ x ^ x At >: u, frhatu, taux +!! j > o > o > At o: h +!! j-1 x ^ x ^ x +!! i-1 i i+1 At x & ^: +!! i i+1 At > & o: +!! \endverbatim +!! +!! The boundaries always run through q grid points (x). +end module MOM_vert_friction diff --git a/parameterizations/vertical/_BML.dox b/parameterizations/vertical/_BML.dox new file mode 100644 index 0000000000..2786a26851 --- /dev/null +++ b/parameterizations/vertical/_BML.dox @@ -0,0 +1,49 @@ +/*! \page BML Bulk Surface Mixed Layer + +This bulk surface mixed layer scheme was designed to be used with a +purely isopycnal model. Following \cite niiler1977, \cite oberhuber1993, +and Hallberg (\cite muller2003) the TKE budget is used to construct a +time-evolving homogeneous mixed layer. A buffer layer sits between +the mixed layer and the interior ocean to mediate between the two. + + The following processes are executed, in the order listed. + +\li 1. Undergo convective adjustment into mixed layer. +\li 2. Apply surface heating and cooling. +\li 3. Starting from the top, entrain whatever fluid the TKE budget + permits. Penetrating shortwave radiation is also applied at + this point. +\li 4. If there is any unentrained fluid that was formerly in the + mixed layer, detrain this fluid into the buffer layer. This + is equivalent to the mixed layer detraining to the Monin- + Obukhov depth. +\li 5. Divide the fluid in the mixed layer evenly into CS\%nkml pieces. +\li 6. Split the buffer layer if appropriate. + +Layers 1 to nkml are the mixed layer, nkml+1 to nkml+nkbl are the +buffer layers. The results of this subroutine are mathematically +identical if there are multiple pieces of the mixed layer with +the same density or if there is just a single layer. There is no +stability limit on the time step. + +The key parameters for the mixed layer are found in the control structure. +These include mstar, nstar, nstar2, pen\_SW\_frac, pen\_SW\_scale, and TKE\_decay. +For the \cite oberhuber1993 and \cite kraus1967 mixed layers, the values of these are: + + + +
Model variables used in the bulk mixed layer
Symbol Value in Oberhuber (1993) Value in Kraus-Turner (1967) +
pen\_SW\_frac 0.42 0.0 +
pen\_SW\_scale 15.0 m 0.0 m +
mstar 1.25 1.25 +
nstar 1 0.4 +
TKE\_decay 2.5 0.0 +
conv\_decay 0.5 0.0 +
+ +TKE\_decay is \f$1/\kappa\f$ in eq. 28 of \cite oberhuber1993, while +conv\_decay is \f$1/\mu\f$. Conv\_decay has been eliminated in favor of +the well-calibrated form for the efficiency of penetrating convection +from \cite wang2003. + +*/ diff --git a/parameterizations/vertical/_CVMix_KPP.dox b/parameterizations/vertical/_CVMix_KPP.dox new file mode 100644 index 0000000000..72c166c284 --- /dev/null +++ b/parameterizations/vertical/_CVMix_KPP.dox @@ -0,0 +1,57 @@ +/*! \page CVMix_KPP The K-Profile Parameterization + + The K-Profile Parameterization (KPP) of \cite large1994 is + implemented via the Community Vertical Mixing package, [CVMix](http://cvmix.github.io/), + which is called directly by this module. + + The formulation and implementation of KPP is described in great detail in the + [CVMix manual](https://github.com/CVMix/CVMix-description/raw/master/cvmix.pdf) (written by our own Steve Griffies). + + \section section_KPP_nutshell KPP in a nutshell + + Large et al., \cite large1994, decompose the parameterized boundary layer turbulent flux of a scalar, \f$ s \f$, as + \f[ \overline{w^\prime s^\prime} = -K \partial_z s + K \gamma_s(\sigma), \f] + where \f$ \sigma = -z/h \f$ is a non-dimensional coordinate within the boundary layer of depth \f$ h \f$. + \f$ K \f$ is the eddy diffusivity and is a function of position within the boundary layer as well as a + function of the surface forcing: + \f[ K = h w_s(\sigma) G(\sigma) . \f] + Here, \f$ w_s \f$ is the vertical velocity scale of the boundary layer turbulence and \f$ G(\sigma) \f$ is + a "shape function" which is described later. + The last term is the "non-local transport" which involves a function \f$ \gamma_s(\sigma) \f$ that is matched + to the forcing but is not actually needed in the final implementation. + Instead, the entire non-local transport term can be equivalently written + \f[ K \gamma_s(\sigma) = C_s G(\sigma) Q_s \f] + where \f$ Q_s \f$ is the surface flux of \f$ s \f$ and \f$ C_s \f$ is a constant. + The vertical structure of the redistribution (non-local) term is solely due to the shape function, + \f$ G(\sigma) \f$. + In our implementation of KPP, we allow the shape functions used for \f$ K \f$ and for the non-local transport + to be chosen independently. + + [google_thread_NLT]: https://groups.google.com/forum/#!msg/CVMix-dev/i6rF-eHOtKI/Ti8BeyksrhAJ + "Extreme values of non-local transport" + + The particular shape function most widely used in the atmospheric community is + \f[ G(\sigma) = \sigma (1-\sigma)^2 \f] + which satisfies the boundary conditions + \f$ G(0) = 0 \f$, + \f$ G(1) = 0 \f$, + \f$ G^\prime(0) = 1 \f$, and + \f$ G^\prime(1) = 0 \f$. + Large et al, 1994, alter the function so as to match interior diffusivities but we have found that this leads + to inconsistencies within the formulation (see google groups thread + [Extreme values of non-local transport][google_thread_NLT]). + Instead, we use either the above form, or even simpler forms that use alternative upper boundary conditions. + + The KPP boundary layer depth is a function of the bulk Richardson number, Rib. + But to compute Rib, we need the boundary layer depth. To address this circular + logic, we compute Rib for each vertical cell in a column, assuming the BL depth + equals to the depth of the given grid cell. Once we have a vertical array of Rib(k), + we then call the OBLdepth routine from CVMix to compute the actual + OBLdepth. We optionally then "correct" the OBLdepth by cycling through once more, + this time knowing the OBLdepth from the first pass. This "correction" step is not + used by NCAR. It has been found in idealized MOM6 tests to not be necessary. + +\sa +kpp_calculate(), kpp_applynonlocaltransport() + +*/ diff --git a/parameterizations/vertical/_EPBL.dox b/parameterizations/vertical/_EPBL.dox new file mode 100644 index 0000000000..d531c9ad9a --- /dev/null +++ b/parameterizations/vertical/_EPBL.dox @@ -0,0 +1,254 @@ +/*! \page EPBL Energetically-constrained Planetary Boundary Layer + +We here describe a scheme for modeling the ocean surface boundary layer +(OSBL) suitable for use in global climate models. It builds on the ideas in +\ref BML, bringing in some of the ideas from \ref subsection_kappa_shear, to +make an energetically consistent boundary layer suitable for use with +a generalized vertical coordinate. Unlike in \ref BML, variables are +allowed to have vertical structure within the boundary layer. The downward +turbulent flux of buoyant water by OSBL turbulence converts mechanical +energy into potential energy as it mixes with less buoyant water at the +base of the OSBL. As described in \cite reichl2018, we focus on OSBL +parameterizations that constrain this integrated potential energy +conversion due to turbulent mixing. + +The leading-order mean OSBL equation for arbitrary scalar \f$\phi\f$ is: + +\f[ + \frac{\partial \overline{\phi}}{\partial t} = - \frac{\partial}{\partial z} + \overline{w^\prime \phi^\prime} + \nu_\phi \frac{\partial^2 \overline{\phi}}{\partial z^2} +\f] + +where the symbols are as follows: + + + +
Symbols used in TKE equation
Symbol Meaning +
\f$u_i\f$ horizontal components of the velocity +
\f$\phi\f$ arbitrary scalar (tracer) quantity +
\f$w\f$ vertical component of the velocity +
\f$\overline{w}\f$ ensemble average \f$w\f$ +
\f$w^\prime\f$ fluctuations from \f$\overline{w}\f$ +
\f$k\f$ turbulent kinetic energy (TKE) +
\f$K_M\f$ turbulent mixing coefficient for momentum +
\f$K_\phi\f$ turbulent mixing coefficient for \f$\phi\f$ +
\f$\sigma_k\f$ turbulent Schmidt number +
\f$b\f$ buoyancy +
\f$\epsilon\f$ buoyancy turbulent dissipation rate +
+ +This equation describes the evolution of mean quantity \f$\overline{\phi}\f$ +due to vertical processes, including the often negligible molecular +mixing. We would like to parameterize the vertical mixing since we won't be +resolving all the relevant time and space scales. + +We use the Boussinesq hypothesis for turbulence closure. This approximates +the Reynolds stress terms using an eddy viscosity (eddy diffusivity for +turbulent scalar fluxes): + +\f[ + \overline{u_i^\prime w^\prime} = - K_M \frac{\partial \overline{u_i}}{\partial z} , +\f] + +Similarly, the eddy diffusivity is used to parameterize turbulent scalar fluxes as: + +\f[ + \overline{\phi^\prime w^\prime} = - K_\phi \frac{\partial \overline{\phi}}{\partial z} , +\f] + +The parameters needed to close the system of equations are then reduced to the turbulent +mixing coefficients, \f$K_\phi\f$ and \f$K_M\f$. + +We start with an equation for the turbulent kinetic energy (TKE): + +\f[ + \frac{\partial k}{\partial t} = \frac{\partial}{\partial z} \left( \frac{K_M}{\sigma_k} + \frac{\partial k}{\partial z} \right) - \overline{u_i^\prime w^\prime} \frac{\partial \overline{u_i}} + {\partial z} + \overline{w^\prime b^\prime} - \epsilon +\f] + +Terms in this equation represent TKE storage (LHS), TKE flux convergence, +shear production, buoyancy production, and dissipation. + +\section section_WMBL Well-mixed Boundary Layers (WMBL) + +Assuming steady state and other parameterizations, integrating vertically +over the surface boundary layer, \cite reichl2018 obtains the form: + +\f[ + \frac{1}{2} H_{bl} w_e \Delta b = m_\ast u_\ast^3 - n_\ast \frac{H_{bl}}{2} + B(H_{bl}) , +\f] + +with the following variables: + + + +
Symbols used in integrated TKE equation
Symbol Meaning +
\f$H_{bl}\f$ boundary layer thickness +
\f$w_e\f$ entrainment velocity +
\f$\Delta b\f$ change in buoyancy at base of mixed layer +
\f$m_\ast\f$ sum of mechanical coefficients +
\f$u_\ast\f$ friction velocity (\f$u_\ast = (|\tau| / \rho_0)^{1/2}\f$) +
\f$\tau\f$ wind stress +
\f$n_\ast\f$ convective proportionality coefficient +
1 for stabilizing surface buoyancy flux, less otherwise +
\f$B(H_{bl})\f$ surface buoyancy flux +
+ +\section section_ePBL Energetics-based Planetary Boundary Layer + +Once again, the goal is to formulate a surface mixing scheme to find the +turbulent eddy diffusivity (and viscosity) in a way that is suitable for use +in a global climate model, using long timesteps and large grid spacing. +After evaluating a well-mixed boundary layer (WMBL), the shear mixing of +\cite jackson2008 (JHL, \ref subsection_kappa_shear), as well as a more complete +boundary layer scheme, it was decided to combine a number of these ideas +into a new scheme: + +\f[ + K(z) = F_x(K_{ePBL}(z), K_{JHL}(z), K_n(z)) +\f] + +where \f$F_x\f$ is some unknown function of a new \f$K_{ePBL}\f$, +\f$K_{JHL}\f$, the diffusivity due to shear as determined by +\cite jackson2008, and \f$K_n\f$, the diffusivity from other ideas. +We start by specifying the form of \f$K_{ePBL}\f$ as being: + +\f[ + K_{ePBL}(z) = C_K w_t l , +\f] + +where \f$w_t\f$ is a turbulent velocity scale, \f$C_K\f$ is a coefficient, and +\f$l\f$ is a length scale. + +\subsection subsection_lengthscale Turbulent length scale + +We propose a form for the length scale as follows: + +\f[ + l = (z_0 + |z|) \times \max \left[ \frac{l_b}{H_{bl}} , \left( + \frac{H_{bl} - |z|}{H_{bl}} \right)^\gamma \, \right] , +\f] + +where we have the following variables: + + + +
Symbols used in ePBL length scale
Symbol Meaning +
\f$H_{bl}\f$ boundary layer thickness +
\f$z_0\f$ roughness length +
\f$\gamma\f$ coefficient, 2 is as in KPP, \cite large1994 +
\f$l_b\f$ bottom length scale +
+ +\subsection subsection_velocityscale Turbulent velocity scale + +We do not predict the TKE prognostically and therefore approximate the vertical TKE +profile to estimate \f$w_t\f$. An estimate for the mechanical contribution to the velocity +scale follows the standard two-equation approach. In one and two-equation second-order +\f$K\f$ parameterizations the boundary condition for the TKE is typically employed as a +flux boundary condition. + +\f[ + K \left. \frac{\partial k}{\partial z} \right|_{z=0} = c_\mu^0 u_\ast^3 . +\f] + +The profile of \f$k\f$ decays in the vertical from \f$k \propto (c_\mu^0)^{2/3} +u_\ast^2\f$ toward the base of the OSBL. Here we assume a similar relationship to estimate +the mechanical contribution to the TKE profile. The value of \f$w_t\f$ due to mechanical +sources, \f$v_\ast\f$, is estimate as \f$v_\ast (z=0) \propto (c_\mu^0)^{1/3} u_\ast\f$ at +the surface. Since we only parameterize OSBL turbulent mixing due to surface forcing, the +value of the velocity scale is assumed to decay moving away from the surface. For +simplicity we employ a linear decay in depth: + +\f[ + v_\ast (z) = (c_\mu^0)^{1/3} u_\ast \left( 1 - a \cdot \min \left[ 1, + \frac{|z|}{H_{bl}} \right] \right) , +\f] + +where \f$1 > a > 0\f$ has the effect of making \f$v_\ast(z=H_{bl}) > 0\f$. +Making the constant coefficient \f$a\f$ close to one has the effect of reducing the mixing +rate near the base of the boundary layer, thus producing a more diffuse entrainment +region. Making \f$a\f$ close to zero has the effect of increasing the mixing at the base +of the boundary layer, producing a more 'step-like' entrainment region. + +An estimate for the buoyancy contribution is found utilizing the convective velocity +scale: + +\f[ + w_\ast (z) = C_{w_\ast} \left( \int_z^0 \overline{w^\prime b^\prime} dz \right)^{1/3} , +\f] + +where \f$C_{w_\ast}\f$ is a non-dimensional empirical coefficient. Convection in one and +two-equation closure causes a TKE profile that peaks below the surface. The quantity +\f$\overline{w^\prime b^\prime}\f$ is solved for in ePBL as \f$KN^2\f$. + +These choices for the convective and mechanical components of the velocity scale in the +OSBL are then added together to get an estimate for the total turbulent velocity scale: + +\f[ + w_t (z) = w_\ast (z) + v_\ast (z) . +\f] + +The value of \f$a\f$ is arbitrarily chosen to be 0.95 here. + +\subsection subsection_ePBL_summary Summarizing the ePBL implementation + +The ePBL mixing coefficient is found by multiplying a velocity scale +(\ref subsection_velocityscale) by a length scale (\ref subsection_lengthscale). The +precise value of the coefficient \f$C_K\f$ used does not significantly alter the +prescribed potential energy change constraint. A reasonable value is \f$C_K \approx 0.55\f$ to +be consistent with other approaches (e.g. \cite umlauf2005). + +The boundary layer thickness (\f$H_{bl}\f$) within ePBL is based on +the depth where the energy requirement for turbulent mixing of density +exceeds the available energy (\ref section_WMBL). \f$H_{bl}\f$ is +determined by the energetic constraint imposed using the value of +\f$m_\ast\f$ and \f$n_\ast\f$. An iterative solver is required because +\f$m_\ast\f$ and the mixing length are dependent on \f$H_{bl}\f$. + +We use a constant value for convectively driven TKE of \f$n_\ast = 0.066\f$. The +parameterizations for \f$m_\ast\f$ are formulated specifically for the regimes where +\f$K_{JHL}\f$ is sensitive to model numerics \f$(|f| \Delta t \approx +1)\f$ (\cite reichl2018). + +\subsection subsection_ePBL_JHL Combining ePBL and JHL mixing coefficients + +We now address the combination of the ePBL mixing coefficient and the JHL mixing +coefficient. The function \f$F_x\f$ above cannot be the linear sum of \f$K_{ePBL}\f$ and +\f$K_{JHL}\f$. One reason this sum is not valid is because the JHL mixing coefficient is +determined by resolved current shear, including that driven by the surface wind. The +wind-driven current is also included in the ePBL mixing coefficient formulation. An +alternative approach is therefore needed to avoid double counting. + +\f$K_{ePBL}\f$ is not used at the equator as scalings are only investigated when \f$|f| > +0\f$. The solution we employ is to use the maximum mixing coefficient of the two +contributions, + +\f[ + K (z) = \max (K_{ePBL} (z), K_{JHL} (z)), +\f] + +where \f$m_\ast\f$ (and hence \f$K_{ePBL}\f$) is constrained to be small as \f$|f| +\rightarrow 0\f$. This form uses the JHL mixing coefficient when the ePBL coefficient is +small. + +This approach is reasonable when the wind-driven mixing dominates, since both JHL and ePBL +give a similar solution when deployed optimally. One weakness of this approach is the +tropical region, where the shear-driven ePBL \f$m_\ast\f$ coefficient is not formulated. +The JHL parameterization is skillful to simulate this mixing, but does not include the +contribution of convection. The convective portion of \f$K_{ePBL}\f$ should be combined +with \f$K_{JHL}\f$ in the equatorial region when shear and convection occur together. +Future research is warranted. + +Finally, one should note that the mixing coefficient here (\f$K\f$) is used for both +diffusivity and viscosity, implying a turbulent Prandtl number of 1.0. + +\subsection subsection_Langmuir Langmuir circulation + +While only briefly alluded to in \cite reichl2018, the MOM6 code implementing ePBL does +support the option to add a Langmuir parameterization. There are in fact two options, both +adjusting \f$m_\ast\f$. + +*/ diff --git a/parameterizations/vertical/_Frazil.dox b/parameterizations/vertical/_Frazil.dox new file mode 100644 index 0000000000..06321231a3 --- /dev/null +++ b/parameterizations/vertical/_Frazil.dox @@ -0,0 +1,33 @@ +/*! \page Frazil_Ice Frazil Ice Formation + +\section section_frazil Frazil Ice Formation + +Frazil ice forms in the model when the in situ temperature drops below +the local freezing point, taking into account the in situ salinity and +pressure. Starting at the bottom and working up through the water column, +if the water is below freezing, set it to freezing and add the heat +required to the heat deficit. If the water above is warmer than freezing, +use that heat to take away the heat deficit and to cool the water. If +you get all the way to the surface with a heat deficit, that quantity +is passed to the ice model as a heat flux it will need to provide to +the ocean. + +The local freezing point code is provided by the equation of state being +used by MOM6. See \ref section_TFREEZE for the MOM6 options. + +The salinity is adjusted only at the surface when frazil ice is +formed. This happens when the ice model creates ice with the heat deficit, +taking salt out of the surface waters. We inherit this behavior from +older versions of MOM, but the effect of not adjusting the in situ +salinity is thought to be small. + +Note that versions simply whisking all the heat deficit to the surface +without checking for warm water above tended to produce rapidly-melting +ice floes in warm waters. This was deemed unphysical and was corrected. + +A similar process that we are also omitting is the formation of salt +crystals when the salinity becomes too high. The salt crystals should +form and sink, leaving a layer on the bed that will be diluted when the +salinity drops again. This process can be seen in a lake in Death Valley. + +*/ diff --git a/parameterizations/vertical/_V_diffusivity.dox b/parameterizations/vertical/_V_diffusivity.dox new file mode 100644 index 0000000000..df1ce50e27 --- /dev/null +++ b/parameterizations/vertical/_V_diffusivity.dox @@ -0,0 +1,590 @@ +/*! \page Internal_Vert_Mixing Internal Vertical Mixing + +Sets the interior vertical diffusion of scalars due to the following processes: + +-# Shear-driven mixing (\ref section_Shear): \cite jackson2008 or KPP interior; +-# Background mixing (\ref section_Background): via CVMix (Bryan-Lewis profile), + the scheme described by \cite harrison2008, or that in \cite danabasoglu2012. +-# Double-diffusion (\ref section_Double_Diff): old method or new method via CVMix; +-# Tidal mixing: many options available, see \ref section_Internal_Tidal_Mixing. + +In addition, the MOM_set_diffusivity has the option to set the interior vertical +viscosity associated with processes 1,2 and 4 listed above, which is stored in +visc\%Kv\_slow. Vertical viscosity due to shear-driven mixing is passed via +visc\%Kv\_shear + +The resulting diffusivity, \f$K_d\f$, is the sum of all the contributions +unless you set BBL_MIXING_AS_MAX to True, in which case the maximum of +all the contributions is used. + +In addition, \f$K_d\f$ is multiplied by the term: + +\f[ + \frac{N^2}{N^2 + \Omega^2} +\f] + +where \f$N\f$ is the buoyancy frequency and \f$\Omega\f$ is the angular velocity +of the Earth. This allows the buoyancy fluxes to tend to zero in regions +of very weak stratification, allowing a no-flux bottom boundary condition +to be satisfied. + +\section section_Shear Shear-driven Mixing + +Below the surface mixed layer, there are places in the world's oceans +where shear mixing is known to take place. This shear-driven mixing can +be represented in MOM6 through either CVMix or the parameterization of +\cite jackson2008. + +\subsection subsection_CVMix_shear Shear-driven mixing in CVMix + +The community vertical mixing (CVMix) code contains options for shear +mixing from either \cite large1994 or from \cite pacanowski1981. In MOM6, +CVMix is included via a git submodule which loads the external CVMix +package. The shear mixing routine in CVMix was developed to reproduce the +observed mixing of the equatorial undercurrent in the Pacific. + +We first compute the gradient Richardson number \f$\mbox{Ri} = N^2 / S^2\f$, +where \f$S\f$ is the vertical shear (\f$S = ||\bf{u}_z ||\f$) and \f$N\f$ +is the buoyancy frequency (\f$N^2 = -g \rho_z / \rho_0\f$). The +parameterization of \cite large1994 is as follows, where the diffusivity \f$\kappa\f$ +is given by + +\f[ + \kappa = \kappa_0 \left[ 1 - \min \left( 1, \frac{\mbox{Ri}}{\mbox{Ri}_c} \right) + ^2 \right] ^3 , +\f] + +with \f$\kappa_0 = 5 \times 10^{-3}\, \mbox{m}^2 \,\mbox{s}^{-1}\f$ and \f$\mbox{Ri}_c = 0.7\f$. + +One can instead select the \cite pacanowski1981 scheme within CVMix. Unlike +the \cite large1994 scheme, they propose that the vertical shear +viscosity \f$\nu_{\mbox{shear}}\f$ be different from the vertical shear +diffusivity \f$\kappa_{\mbox{shear}}\f$. For gravitationally stable +profiles (i.e., \f$N^2 > 0\f$), they chose + +\f[ + \nu_{\mbox{shear}} = \frac{\nu_0}{(1 + a \mbox{Ri})^n} +\f] + +\f[ + \kappa_{\mbox{shear}} = \frac{\nu_0}{(1 + a \mbox{Ri})^{n+1}} +\f] + +where \f$\nu_0\f$, \f$a\f$ and \f$n\f$ are adjustable parameters. Common settings are \f$a = 5\f$ +and \f$n = 2\f$. + +For both CVMix shear mixing schemes, the mixing coefficients are set to +a large value for gravitationally unstable profiles. + +\subsection subsection_kappa_shear Shear-driven mixing in Jackson + +While the above parameterization works well enough in the equatorial +Pacific, another place one can expect shear-mixing to matter is +in overflows of dense water. \cite jackson2008 proposes a new shear +parameterization with the goal of working in both the equatorial undercurrent +and for overflows, also to have smooth transitions between unstable and +stable regions. Their scheme looks like: + +\f{eqnarray} + \frac{\partial^2 \kappa}{\partial z^2} - \frac{\kappa}{L^2_d} &= - 2 SF(\mbox{Ri}) . + \label{eq:Jackson_10} +\f} + +This is similar to the locally constant stratification limit of +\cite turner1986, but with the addition of a decay length scale +\f$L_d = \lambda L_b\f$. Here \f$L_b = Q^{1/2} / N\f$ is the buoyancy +length scale where \f$Q\f$ is the turbulent kinetic energy (TKE) per +unit mass, and \f$\lambda\f$ is a nondimensional constant. The function +\f$F(\mbox{Ri})\f$ is a function of the Richardson number that remains +to be determined. As in \cite turner1986, there must be a critical +value of \f$\mbox{Ri}\f$ above which \f$F(\mbox{Ri}) = 0\f$. +For better agreement with observations in a law-of-the-wall configuration, +we modify \f$L_d\f$ to be \f$\min (\lambda L_b, L_z)\f$, where \f$L_z\f$ +is the distance to the nearest solid boundary. This can be understood by +considering \f$L_d\f$ to be the size of the largest turbulent eddies, +whether they are constrained by the stratification (through \f$L_b\f$) +or through the geometry (through \f$L_z\f$). + +There are two length scales: the width of the low Richardson number region +as in \cite turner1986, and the buoyancy length scale, which is the +length scale over which the TKE is affected by the stratification (see +\cite jackson2008 for more details). In particular, the inclusion of a +decay length scale means that the diffusivity decays exponentially away +from the mixing region with a length scale of \f$L_d\f$. This is important +since turbulent eddies generated in the low \f$\mbox{Ri}\f$ layer can +be vertically self-advected and mix nearby regions. This method yields +a smoother diffusivity than that in \cite hallberg2000, especially in +areas where the Richardson number is noisy. + +This parameterization predicts the turbulent eddy diffusivity in terms +of the vertical profiles of velocity and density, providing that the +TKE is known. To complete the parameterization we use a TKE \f$Q\f$ +budget such as that used in second-order turbulence closure models +(\cite umlauf2005). We make a few additional assumptions, however, +and use the simplified form + +\f{eqnarray} + \frac{\partial}{\partial z} \left[ (\kappa + \nu_0) \frac{\partial Q} + {\partial z} \right] + \kappa (S^2 - N^2) - Q(c_N N + c_S S) &= 0. + \label{eq:Jackson_11} +\f} + +The system is therefore in balance between a vertical diffusion of +TKE caused by both the eddy and molecular viscosity \f$(\nu_0)\f$, +the production of TKE by shear, a sink due to stratification, and the +dissipation. Note that we are assuming a Prandtl number of 1, although a +parameterization for the Prandtl number could be added. We have assumed +that the TKE reaches a quasi-steady state faster than the flow is evolving +and faster than it can be affected by mean-flow advection so that \f$DQ/Dt = +0\f$. Since this parameterization is meant to be used in climate models +with low horizontal resolution and large time steps compared to the +mixing time scales, this is a reasonable assumption. The most tenuous +assumption is in the form of the dissipation \f$\epsilon = Q(C_N N + +c_S S)\f$ (where \f$c_N\f$ and \f$c_S\f$ are to be determined), +which is assumed to be dependent on the buoyancy frequency (through loss +of energy to internal waves) and the velocity shear (through the energy +cascade to smaller scales). + +We can rewrite \eqref{eq:Jackson_10} as the steady "transport" equation +for the turbulent diffusivity (i.e., with \f$D\kappa/Dt = 0\f$), + +\f[ + \frac{\partial}{\partial z} \left( \kappa \frac{\partial \kappa}{\partial z} + \right) + 2\kappa SF(\mbox{Ri}) - \left( \frac{\kappa}{L_d} \right)^2 - + \left( \frac{\partial \kappa}{\partial z} \right) ^2 = 0 . +\f] + +The first term on the left can be regarded as a vertical transport of +diffusivity, the second term as a source, and the final two as sinks. +This equation with \eqref{eq:Jackson_11} are simple enough to solve quickly +using an iterative technique. + +We also need boundary conditions for \eqref{eq:Jackson_10} +and \eqref{eq:Jackson_11}. For the turbulent diffusivity we use +\f$\kappa = 0\f$ since our diffusivity is numerically defined on +layer interfaces. This ensures that there is no turbulent flux across +boundaries. For the TKE we use boundary conditions of \f$Q = Q_0\f$ where +\f$Q_0\f$ is a constant value of TKE, used to prevent a singularity +in \eqref{eq:Jackson_10}, that is chosen to be small enough to not +influence results. Note that the value of \f$\kappa\f$ calculated here +reflects shear-driven turbulent mixing only; the total diffusivity would +be this value plus any diffusivities due to other turbulent processes +or a background value. + +Based on \cite turner1986, we choose \f$F(\mbox{Ri})\f$ of the form + +\f[ + F(\mbox{Ri}) = F_0 \left( \frac{1 - \mbox{Ri} / \mbox{Ri}_c} + {1 + \alpha \mbox{Ri} / \mbox{Ri}_c} \right) , +\f] + +where \f$\alpha\f$ is the curvature parameter. This table shows the default +values of the relevant parameters: + + + +
Shear mixing parameters
Parameter Default value MOM6 parameter +
\f$\mbox{Ri}_c\f$ 0.25 RINO_CRIT +
\f$\nu_0\f$ \f$1.5 \times 10^{-5}\f$ KD_KAPPA_SHEAR_0 +
\f$F_0\f$ 0.089 SHEARMIX_RATE +
\f$\alpha\f$ -0.97 FRI_CURVATURE +
\f$\lambda\f$ 0.82 KAPPA_BUOY_SCALE_COEF +
\f$c_N\f$ 0.24 TKE_N_DECAY_CONST +
\f$c_S\f$ 0.14 TKE_SHEAR_DECAY_CONST +
+ +These can all be adjusted at run time, plus some other parameters such as the maximum number of iterations +to perform. + +\section section_Background Background Mixing + +There are three choices for the vertical background mixing: that in +CVMix (\cite bryan1979), that in \cite harrison2008, and that in +\cite danabasoglu2012. + +\subsection subsection_bryan_lewis CVMix background mixing + +The background vertical mixing in \cite bryan1979 is of the form: + +\f[ + \kappa = C_1 + C_2 \mbox{atan} [ C_3 ( |z| - C_4 )] +\f] + +where the constants are runtime parameters as shown here: + + + +
Bryan Lewis parameters
Parameter Units MOM6 parameter +
\f$C_1\f$ m2 s-1 BRYAN_LEWIS_C1 +
\f$C_2\f$ m2 s-1 BRYAN_LEWIS_C2 +
\f$C_3\f$ m-1 BRYAN_LEWIS_C3 +
\f$C_4\f$ m BRYAN_LEWIS_C4 +
+ +\subsection subsection_henyey Henyey IGW background mixing + +\cite harrison2008 choose a vertical background mixing with a latitudinal +dependence based on \cite henyey1986. Specifically, theory predicts +a minimum in mixing due to wave-wave interactions at the equator and +observations support that theory. In this option, the surface background +diffusivity is + +\f[ + \kappa_s (\phi) = \max \left[ 10^{-7}, \kappa_0 \left| \frac{f}{f_{30}} \right| + \frac{ \cosh^{-1} (1/f) }{ \cosh^{-1} (1/f_{30})} \right] , +\f] + +where \f$f_{30}\f$ is the Coriolis frequency at \f$30^\circ\f$ latitude. The two-dimensional equation for +the diffusivity is + +\f[ + \kappa(\phi, z) = \kappa_s + \Gamma \mbox{atan} \left( \frac{H_t}{\delta_t} \right) + + \Gamma \mbox{atan} \left( \frac{z - H_t}{\delta_t} \right) , +\f] +\f[ + \Gamma = \frac{(\kappa_d - \kappa_s) }{\left[ 0.5 \pi + \mbox{atan} \left( \frac{H_t}{\delta_t} \right) + \right] }, +\f] + +where \f$H_t = 2500\, \mbox{m}\f$, \f$\delta_t = 222\, \mbox{m}\f$, and +\f$\kappa_d\f$ is the deep ocean diffusivity of \f$10^{-4}\, \mbox{m}^2 +\, \mbox{s}^{-1}\f$. Note that this is the vertical structure described +in \cite harrison2008, but that isn't what is in the MOM6 code. Instead, the surface +value is propagated down, with the assumption that the tidal mixing parameterization +will provide the deep mixing: \ref section_Internal_Tidal_Mixing. + +\subsection subsection_danabasoglu_back Danabasoglu background mixing + +The shape of the \cite danabasoglu2012 background mixing has a uniform background value, with a dip +at the equator and a bump at \f$\pm 30^{\circ}\f$ degrees latitude. The form is shown in this figure + +\image html background_varying.png "Form of the vertically uniform background mixing in Danabasoglu [2012]. The values are symmetric about the equator." +\imagelatex{background_varying.png,Form of the vertically uniform background mixing in \cite danabasoglu2012. The values are symmetric about the equator.,\includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true]} + +Some parameters of this curve are set in the input file, some are hard-coded in calculate_bkgnd_mixing. + +\section section_Double_Diff Double Diffusion + +From \cite large1994, \cite griffies2015a, double-diffusive mixing +can occur when the vertical gradient of density is stable but the +vertical gradient of either salinity or temperature is unstable in its +contribution to density. The key stratification parameter for double +diffusive processes is + +\f[ + R_\rho = \frac{\alpha}{\beta} \left( \frac{\partial \Theta / \partial z}{\partial S / + \partial z} \right) , +\f] + +where the thermal expansion coefficient is given by + +\f[ + \alpha = - \frac{1}{\rho} \left( \frac{\partial \rho}{\partial \Theta} \right) , +\f] + +and the haline contraction coefficient is + +\f[ + \beta = \frac{1}{\rho} \left( \frac{\partial \rho}{\partial S} \right) . +\f] + +Note that the effects from double diffusive processes on viscosity are not well known and +are ignored in MOM6. + +In MOM6, there are two choices for the implementation of double +diffusion. The older DOUBLE_DIFFUSION option, with reference to an +unknown tech report from NCAR, aims to match the scheme used in MOM4, an update on +\cite large1994. The newer option is to call the routines from CVMix (USE_CVMIX_DDIFF). + +There are two regimes of double diffusive processes, salt fingering and diffusive +convective, with differing parameterizations in the two regimes. + +\subsection subsection_salt_finger Salt fingering regime + +The salt fingering regime occurs when salinity is destabilizing the water column (salty, +above fresh water) and when the stratification parameter \f$R_\rho\f$ is within a +particular range: + +\f[ + \frac{\partial S}{\partial z} > 0 +\f] +\f[ + 1 < R_\rho < R_\rho^0. +\f] + +The value of the cutoff \f$R_\rho\f$ is 1.9 in the old code, 2.55 in CVMix. + +The form of the diffusivity for both is + +\f{eqnarray}{ + \kappa_d =& \kappa_d^0 \left[ 1 - \left( \frac{R_\rho - 1}{R_\rho^0 - 1} \right) + \right]^3 & \mbox{for } 1 < R_\rho < R_\rho^0 \\ + \kappa_d =& 0 & \mbox{otherwise.} +\f} + +The default values of \f$\kappa_d^0\f$ are + +\f{eqnarray}{ + \kappa_d^0 =& 1 \times 10^{-4} & \mbox{for salinity and other tracers} \\ + \kappa_d^0 =& 0.7 \times 10^{-4} & \mbox{for temperature.} +\f} + +Note that the form in \cite large1994 is slightly different. + +\subsection subsection_diffusive_convective Diffusive convective regime + +Both implementations of the diffusive convective double diffusion have the same form +(\cite large1994) and are active when + +\f[ + \frac{\partial \Theta}{\partial z} < 0 +\f] +\f[ + 0 < R_\rho < 1. +\f] + +For temperature, the vertical diffusivity is given by + +\f[ + \kappa_d = \nu_\mbox{molecular} \times 0.909 \exp \left( 4.6 \exp \left[ -.54 + \left( R_\rho^{-1} - 1 \right) \right] \right) , +\f] + +where + +\f[ + \nu_\mbox{molecular} = 1.5 \times 10^{-6} \mbox{m}^2 \mbox{s}^{-1} +\f] + +is the molecular viscosity of water. Multiplying the diffusivity by the Prandtl number +\f$Pr\f$ + +\f{eqnarray}{ + Pr = \left\{ \begin{matrix} (1.85 - 0.85 R_\rho^{-1} ) R_\rho & 0.5 \leq R_\rho < 1 \\ + 0.15 R_\rho & R_\rho < 0.5 , \end{matrix} \right. +\f} + +gives the diffusivity for salinity and other tracers. + +\section section_Internal_Tidal_Mixing Internal Tidal Mixing + +Two parameterizations of vertical mixing due to internal tides are +available with the option INT_TIDE_DISSIPATION. The first is that of +\cite st_laurent2002 while the second is that of \cite polzin2009. Choose +between them with the INT_TIDE_PROFILE option. There are other relevant +parameters which can be seen in MOM_parameter_doc.all once the main tidal +dissipation switch is turned on. + +\subsection subsection_st_laurent St Laurent et al. + +The estimated turbulent dissipation rate of +internal tide energy \f$\epsilon\f$ is: + +\f[ + \epsilon = \frac{q E(x,y)}{\rho} F(z). +\f] + +where \f$\rho\f$ is the reference density of seawater, \f$E(x,y)\f$ is +the energy flux per unit area transferred from barotropic to baroclinic +tides, \f$q\f$ is the fraction of the internal-tide energy dissipated +locally, and \f$F(z)\f$ is the vertical structure of the dissipation. +This \f$q\f$ is estimated to be roughly 0.3 based on observations. The +term \f$E(x,y)\f$ is given by \cite st_laurent2002 as: + +\f[ + E(x,y) \simeq \frac{1}{2} \rho N_b \kappa h^2 \langle U^2 \rangle +\f] + +where \f$\rho\f$ is the reference density of seawater, \f$N_b\f$ is +the buoyancy frequency along the seafloor, and \f$(\kappa, h)\f$ are +the wavenumber and amplitude scales for the topographic roughness, and +\f$\langle U^2 \rangle\f$ is the barotropic tide variance. It is assumed +that the model will read in topographic roughness squared \f$h^2\f$ +from a file (the variable must be named "h2"). + +To convert from energy dissipation to vertical diffusion \f$K_d\f$, +the simple estimate is: + +\f[ + K_d \approx \frac{\Gamma q E(x,y) F(z)}{\rho N^2} +\f] + +where \f$\Gamma\f$ is the mixing efficiency, generally set to 0.2 +and \f$F(z)\f$ is a vertical structure function with exponential decay +from the bottom: + +\f[ + F(z) = \frac{e^{-(H+z)/\zeta}}{\zeta (1 - e^{H/\zeta}}. +\f] + +Here, \f$\zeta\f$ is a vertical decay scale with a default of 500 meters. +One change in MOM6 from the St. Laurent scheme is to use this form of \f$\Gamma\f$: + +\f[ + \Gamma = 0.2 \frac{N^2}{N^2 + \Omega^2} +\f] + +instead of \f$\Gamma = 0.2\f$, where \f$\Omega\f$ is the angular velocity +of the Earth. This allows the buoyancy fluxes to tend to zero in regions +of very weak stratification, allowing a no-flux bottom boundary condition +to be satisfied. + +\subsection subsection_polzin Polzin + +The vertical diffusion profile of \cite polzin2009 is a WKB-stretched +algebraic decay profile. It is based on a radiation balance equation, +which links the dissipation profile associated with internal breaking to +the finescale internal wave shear producing that dissipation. The vertical +profile of internal-tide driven energy dissipation can then vary in time +and space, and evolve in a changing climate (\cite melet2012). \cite melet2012 +describes how the Polzin scheme is implemented in MOM6, +copied here. + +The parameterization of \cite polzin2009 links the energy dissipation +profile to the finescale internal wave shear producing that +dissipation, using an idealized vertical wavenumber energy spectrum +to identify analytic solutions to a radiation balance equation +(\cite polzin2004). These solutions yield a dissipation profile +\f$\epsilon(z)\f$: + +\f[ + \epsilon = \frac{\epsilon_0}{[1 + (z/z_p)]^2}, +\f] + +where the magnitude \f$\epsilon_0\f$ and scale height \f$z_p\f$ can be expressed in terms of the +spectral amplitude and bandwidth of the idealized vertical wavenumber energy spectrum in uniform +stratification (\cite polzin2009). + +To take into account the nonuniform stratification, \cite polzin2009 applied a buoyancy scaling +using the Wentzel-Kramers-Brillouin (WKB) approximation. As a result, the vertical wavenumber of a +wave packet varies in proportion to the buoyancy frequency \f$N\f$, which in turn implies an +additional transport of energy to smaller scales, and thus a possible enhanced mixing in regions of +strong stratification. Such effects can be described by buoyancy scaling the vertical coordinate +\f$z\f$ as + +\f[ + z^{\ast}(z) = \int_{0}^{z} \left[ \frac{N^2 (z^\prime )}{N_b^2} \right] dz^{\prime} , +\f] + +with \f$z^\prime\f$ being positive upward relative to the bottom of the ocean. The turbulent +dissipation rate then becomes + +\f[ + \epsilon = \frac{\epsilon_0}{[1 + (z^{\ast} /z_p)]^2} \frac{N^2(z)}{N_b^2} . +\f] + +The spectral amplitude and bandwidth of the idealized vertical wavenumber +energy spectrum are identified after WKB scaling using a quasi-linear +spectral model of internal-tide generation that incorporates horizontal +advection of the barotropic tide into the momentum equation (\cite bell1975). +As a result, Polzin's formulation leads to an expression for +the spatially and temporally varying dissipation of internal tide energy +at the bottom \f$\epsilon_0\f$, and the vertical scale of decay for the +dissipation of internal tide energy \f$z_p\f$. + +\subsubsection subsection_energy_conserving Energy-conserving form + +To satisfy energy conservation (the integral of the vertical structure for the turbulent dissipation +over depth should be unity), the dissipation is rewritten as + +\f[ + \epsilon = \frac{\epsilon_0 z_p}{1 + (z^\ast/z_p)]^2} \frac{N^2(z)}{N^2_b} \left[ + \frac{1}{z^{\ast(z=H)}} + \frac{1}{z_p} \right] . +\f] + +In the MOM6 implementation, we use the \cite st_laurent2002 template for the vertical flux of energy +at the ocean floor, so that in both formulations: + +\f[ + \int_{0}^{H} \epsilon (z) dz = \frac{qE}{\rho} . +\f] + +Whereas \cite polzin2009 assumed that the total dissipation was locally in balance with the +barotropic to baroclinic energy conversion rate \f$(q=1)\f$, here we use the \cite simmons2004 value +of \f$q=1/3\f$ to retain as much consistency as possible between both parameterizations. + +\subsubsection subsection_vertical_decay_scale Vertical decay-scale reformulation + +We follow the \cite polzin2009 prescription for the vertical scale of +decay for the dissipation of internal-tide energy. However, we assume +that the topographic power law, denoted as \f$\nu\f$ in \cite polzin2009, +is equal to 1 (instead of 0.9) and we reformulated the expression of +\f$z_p\f$ to put it in a more readable form: + +\f[ + z_p = \frac{z_p^\mbox{ref} (\kappa^\mbox{ref})^2 (h^\mbox{ref})^2 (N_b^\mbox{ref})^3} {U^\mbox{ref}} + \frac{U}{h^2 \kappa^2 N_b^3} . +\f] + +The superscript ref refers to reference values of the various parameters, as given by +observations from the Brazil basin. Therefore, the above can be rewritten as + +\f[ + z_p = \mu (N_b^\mbox{ref} )^2 + \frac{U}{h^2 \kappa^2 N_b^3} . +\f] + +where \f$\mu\f$ is a nondimensional constant \f$(\mu = 0.06970)\f$ and \f$N_b^\mbox{ref} = 9.6 \times +10^{-4} s^{-1}\f$. Finally, a minimum decay scale of \f$z_p = 100 m\f$ is imposed in our +implementation. + +\subsubsection subsection_reformulation_WKB Reformulation of the WKB scaling + +Since the dissipation is expressed as a function of the ratio \f$z^\ast / z_p\f$, a different WKB +scaling can be used so long as we modify \f$z_p\f$ accordingly. In the implemented parameterization, +we define the scaled height coordinate \f$z^\ast\f$ by + +\f[ + z^\ast (z) = \frac{1}{\overline{N^2 (z)}^z} \int_{0}^{z} N^2(z^\prime ) dz ^\prime , +\f] + +with \f$z^\prime\f$ defined to be the height above the ocean bottom. By normalizing \f$N^2\f$ by its +vertical mean \f$\overline{N^2}^z\f$, \f$z^\ast\f$ ranges from \f$0\f$ to \f$H\f$, the depth of the +ocean. + +The WKB-scaled vertical decay scale for the Polzin formulation becomes + +\f[ + z^\ast_p = \mu(N_b^\mbox{ref})^2 \frac{U}{h^2 \kappa^2 N_b \overline{N^2}^z} . +\f] + +Unlike the \cite st_laurent2002 parameterization, the vertical decay scale now depends on physical +variables and can evolve with a changing climate. + +Finally, the Polzin vertical profile of dissipation implemented in the model is given by + +\f[ + \epsilon = \frac{qE(x,y)}{\rho [1 + (z^\ast/z_p^\ast)]^2} \frac{N^2(z)}{\overline{N^2}^z} + \left( \frac{1}{H} + \frac{1}{z_p^\ast} \right) . +\f] + +In both parameterizations, turbulent diapycnal diffusivities are inferred from the dissipation +\f$\epsilon\f$ by: + +\f[ + K_d = \frac{\Gamma \epsilon}{N^2} +\f] + +and using this form of \f$\Gamma\f$: + +\f[ + \Gamma = 0.2 \frac{N^2}{N^2 + \Omega^2} +\f] + +instead of \f$\Gamma = 0.2\f$, where \f$\Omega\f$ is the angular velocity +of the Earth. This allows the buoyancy fluxes to tend to zero in regions +of very weak stratification, allowing a no-flux bottom boundary condition +to be satisfied. + +\subsection subsection_Lee_waves Nikurashin Lee Wave Mixing + +If one has the INT_TIDE_DISSIPATION flag on, there is an option to also turn on +LEE_WAVE_DISSIPATION. The theory is presented in \cite nikurashin2010a +while the application of it is presented in \cite nikurashin2010b. For +the implementation in MOM6, it is required that you provide an estimate +of the TKE loss due to the Lee waves which is then applied with either +the St. Laurent or the Polzin vertical profile. + +\todo Is there a script to produce this somewhere or what??? + +*/ diff --git a/parameterizations/vertical/_V_viscosity.dox b/parameterizations/vertical/_V_viscosity.dox new file mode 100644 index 0000000000..e40123386f --- /dev/null +++ b/parameterizations/vertical/_V_viscosity.dox @@ -0,0 +1,122 @@ +/*! \page Vertical_Viscosity Vertical Viscosity + +The vertical viscosity is composed of several components. + +-# The vertical diffusivity computations for the background and shear +mixing all save contributions to the viscosity with an assumed turbulent +Prandtl number of 1.0, though this can be changed with the PRANDTL_BKGND and +PRANDTL_TURB parameters, respectively. +-# If the ePBL scheme is used, it contributes to the vertical viscosity +with a Prandtl number of PRANDTL_EPBL. +-# If the CVMix scheme is used, it contributes to the vertical viscosity +with a Prandtl number of PRANDTL_CONV. +-# If the tidal mixing scheme is used, it contributes to the vertical +viscosity with a Prandtl number of PRANDTL_TIDAL. + +\section set_viscous_BBL Viscous Bottom Boundary Layer + +A drag law is used, either linearized about an assumed bottom velocity or using the +actual near-bottom velocities combined with an assumed unresolved velocity. The bottom +boundary layer thickness is limited by a combination of stratification and rotation, as +in the paper of \cite killworth1999. It is not necessary to calculate the +thickness and viscosity every time step; instead previous values may be used. + +If set_visc_CS\%bottomdraglaw is True then a bottom boundary layer viscosity and thickness +are calculated so that the bottom stress is +\f[ +\mathbf{\tau}_b = C_d | U_{bbl} | \mathbf{u}_{bbl} +\f] +If set_visc_CS\%bottomdraglaw is True then the term \f$|U_{bbl}|\f$ is set equal to the +value in set_visc_CS.drag_bg_vel so that \f$C_d |U_{bbl}|\f$ becomes a Rayleigh bottom drag. +Otherwise \f$|U_{bbl}|\f$ is found by averaging the flow over the bottom set_visc_CS\%hbbl +of the model, adding the amplitude of tides set_visc_CS\%tideamp and a constant +set_visc_CS\%drag_bg_vel. For these calculations the vertical grid at the velocity +component locations is found by +\f[ +\begin{array}{ll} +\frac{2 h^- h^+}{h^- + h^+} & u \left( h^+ - h^-\right) >= 0 +\\ +\frac{1}{2} \left( h^- + h^+ \right) & u \left( h^+ - h^-\right) < 0 +\end{array} +\f] +which biases towards the thin cell if the thin cell is upwind. Biasing the grid toward +thin upwind cells helps increase the effect of viscosity and inhibits flow out of these +thin cells. + +After diagnosing \f$|U_{bbl}|\f$ over a fixed depth an active viscous boundary layer +thickness is found using the ideas of \cite killworth1999 (hereafter KW99). +KW99 solve the equation +\f[ +\left( \frac{h_{bbl}}{h_f} \right)^2 + \frac{h_{bbl}}{h_N} = 1 +\f] +for the boundary layer depth \f$h_{bbl}\f$. Here +\f[ +h_f = \frac{C_n u_*}{f} +\f] +is the rotation controlled boundary layer depth in the absence of stratification. +\f$u_*\f$ is the surface friction speed given by +\f[ +u_*^2 = C_d |U_{bbl}|^2 +\f] +and is a function of near bottom model flow. +\f[ +h_N = \frac{C_i u_*}{N} = \frac{ (C_i u_* )^2 }{g^\prime} +\f] +is the stratification controlled boundary layer depth. The non-dimensional parameters +\f$C_n=0.5\f$ and \f$C_i=20\f$ are suggested by \cite zilitinkevich1996. + +If a Richardson number dependent mixing scheme is being used, as indicated by +set_visc_CS\%rino_mix, then the boundary layer thickness is bounded to be no larger +than a half of set_visc_CS\%hbbl . + +A BBL viscosity is calculated so that the no-slip boundary condition in the vertical +viscosity solver implies the stress \f$\mathbf{\tau}_b\f$: + +\f[ + K_{bbl} = \frac{1}{2} h_{bbl} \sqrt{C_{drag}} \, u^\ast +\f] + +\section section_Channel_drag Channel Drag + +The channel drag is an extra Rayleigh drag applied to those layers +within the bottom boundary layer. It is called channel drag because it +accounts for curvature of the bottom, applying the drag proportionally +to how much of each cell is within the bottom boundary layer. +The bottom shape is approximated as locally parabolic. The +bottom drag is applied to each layer with a factor \f$R_k\f$, the sum +of which is 1 over all the layers. + +\image html channel_drag.png "Example of layers intersecting a sloping bottom, with the blue showing the fraction of the cell over which bottom drag is applied." +\imagelatex{channel_drag.png,Example of layers intersecting a sloping bottom\, with the blue showing the fraction of the cell over which bottom drag is applied.,\includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true]} + +The velocity that is actually subject to the bottom drag may be +substantially lower than the mean layer velocity, especially if only +a small fraction of the layer's width is subject to the bottom drag. + +The code begins by finding the arithmetic mean of the water depths to +find the depth at the velocity points. It then uses these to construct +a parabolic bottom shape, valid for \f$I - \frac{1}{2}\f$ to \f$I + +\frac{1}{2}\f$. The parabola is: + +\f[ + D(x) = a x^2 + b x + D - \frac{a}{12} +\f] + +For sufficiently small curvature \f$a\f$, one can drop the quadratic +term and assume a linear function instead. We want a form that matches +the traditional bottom drag when the bottom is flat. + +We defined the open fraction of each cell as \f$l(k) \equiv L(k)/L_{Tot}\f$, +where terms of order \f$l^2\f$ will be dropped. + +Hallberg (personal communication) shows how they came up with the form used in the code, in which the +\f$R_k\f$ above are set to: + +\f[ + R_k = \gamma_k l_{k-1/2} \left[ \frac{12 c_{Smag} h_k}{12 c_{Smag} k_k + c_d \gamma_k (1 - \gamma_k) + (1 - \frac{3}{2} \gamma_k) l^2_{k-1/2} L_{Tot}} \right] +\f] +with the definition \f$\gamma_k \equiv (l_{k-1/2} - l_{k+1/2})/l_{k-1/2}\f$. This ensures that \f$\sum^N_{k=1} +\gamma_k l_{k-1/2} = 1\f$ since \f$l_{1/2} = 1\f$ and \f$l_{N+1/2} = 0\f$. + +*/ diff --git a/tracer/DOME_tracer.F90 b/tracer/DOME_tracer.F90 new file mode 100644 index 0000000000..e0bd659a60 --- /dev/null +++ b/tracer/DOME_tracer.F90 @@ -0,0 +1,408 @@ +!> A tracer package that is used as a diagnostic in the DOME experiments +module DOME_tracer + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_hor_index, only : hor_index_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_tracer_type +use MOM_open_boundary, only : OBC_segment_type +use MOM_restart, only : MOM_restart_CS +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public register_DOME_tracer, initialize_DOME_tracer +public DOME_tracer_column_physics, DOME_tracer_surface_state, DOME_tracer_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +integer, parameter :: ntr = 11 !< The number of tracers in this module. + +!> The DOME_tracer control structure +type, public :: DOME_tracer_CS ; private + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + character(len=200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, perhaps in [g kg-1] + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out, perhaps in [g kg-1] + logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. + + real :: stripe_width !< The meridional width of the vertical stripes in the initial condition + !! for some of the DOME tracers, in [km] or [degrees_N] or [m]. + real :: stripe_s_lat !< The southern latitude of the first vertical stripe in the initial condition + !! for some of the DOME tracers, in [km] or [degrees_N] or [m]. + real :: sheet_spacing !< The vertical spacing between successive horizontal sheets of tracer in the initial + !! conditions for some of the DOME tracers [Z ~> m], and twice the thickness of + !! these horizontal tracer sheets + + integer, dimension(NTR) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + + type(vardesc) :: tr_desc(NTR) !< Descriptions and metadata for the tracers +end type DOME_tracer_CS + +contains + +!> Register tracer fields and subroutines to be used with MOM. +function register_DOME_tracer(G, GV, US, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(DOME_tracer_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< A pointer to the tracer registry. + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + + ! Local variables + character(len=80) :: name, longname + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "DOME_tracer" ! This module's name. + character(len=48) :: flux_units ! The units for tracer fluxes, usually + ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. + character(len=200) :: inputdir + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] + logical :: register_DOME_tracer + integer :: isd, ied, jsd, jed, nz, m + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "DOME_register_tracer called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DOME_TRACER_IC_FILE", CS%tracer_IC_file, & + "The name of a file from which to read the initial "//& + "conditions for the DOME tracers, or blank to initialize "//& + "them internally.", default=" ") + if (len_trim(CS%tracer_IC_file) >= 1) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + CS%tracer_IC_file = trim(inputdir)//trim(CS%tracer_IC_file) + call log_param(param_file, mdl, "INPUTDIR/DOME_TRACER_IC_FILE", & + CS%tracer_IC_file) + endif + call get_param(param_file, mdl, "DOME_TRACER_STRIPE_WIDTH", CS%stripe_width, & + "The meridional width of the vertical stripes in the initial condition "//& + "for the DOME tracers.", units=G%y_ax_unit_short, default=50.0) + call get_param(param_file, mdl, "DOME_TRACER_STRIPE_LAT", CS%stripe_s_lat, & + "The southern latitude of the first vertical stripe in the initial condition "//& + "for the DOME tracers.", units=G%y_ax_unit_short, default=350.0) + call get_param(param_file, mdl, "DOME_TRACER_SHEET_SPACING", CS%sheet_spacing, & + "The vertical spacing between successive horizontal sheets of tracer in the initial "//& + "conditions for the DOME tracers, and twice the thickness of these tracer sheets.", & + units="m", default=600.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified from MOM_initialization.F90.", default=.false.) + + allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) + + do m=1,NTR + if (m < 10) then ; write(name,'("tr_D",I1.1)') m + else ; write(name,'("tr_D",I2.2)') m ; endif + write(longname,'("Concentration of DOME Tracer ",I2.2)') m + CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" + else ; flux_units = "kg s-1" ; endif + + ! This is needed to force the compiler not to do a copy in the registration + ! calls. Curses on the designers and implementers of Fortran90. + tr_ptr => CS%tr(:,:,:,m) + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, G%HI, GV, & + name=name, longname=longname, units="kg kg-1", & + registry_diags=.true., restart_CS=restart_CS, & + flux_units=trim(flux_units), flux_scale=GV%H_to_MKS) + + ! Set coupled_tracers to be true (hard-coded above) to provide the surface + ! values to the coupler (if any). This is meta-code and its arguments will + ! currently (deliberately) give fatal errors if it is used. + if (CS%coupled_tracers) & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(name)//'_flux', & + flux_type=' ', implementation=' ', caller="register_DOME_tracer") + enddo + + CS%tr_Reg => tr_Reg + register_DOME_tracer = .true. +end function register_DOME_tracer + +!> Initializes the NTR tracer fields in tr(:,:,:,:) and sets up the tracer output. +subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & + sponge_CSp, tv) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< Structure specifying open boundary options. + type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to DOME_register_tracer. + type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure + !! for the sponges, if they are in use. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + + ! Local variables + real, allocatable :: temp(:,:,:) ! Target values for the tracers in the sponges, perhaps in [g kg-1] + character(len=16) :: name ! A variable's name in a NetCDF file. + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: tr_y ! Initial zonally uniform tracer concentrations, perhaps in [g kg-1] + real :: dz_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m or kg m-2]. + real :: e(SZK_(GV)+1) ! Interface heights relative to the sea surface (negative down) [Z ~> m] + real :: e_top ! Height of the top of the tracer band relative to the sea surface [Z ~> m] + real :: e_bot ! Height of the bottom of the tracer band relative to the sea surface [Z ~> m] + real :: d_tr ! A change in tracer concentrations, in tracer units, perhaps [g kg-1] + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m + + if (.not.associated(CS)) return + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + dz_neglect = GV%dz_subroundoff + + CS%Time => day + CS%diag => diag + + if (.not.restart) then + if (len_trim(CS%tracer_IC_file) >= 1) then + ! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & + call MOM_error(FATAL, "DOME_initialize_tracer: Unable to open "// & + CS%tracer_IC_file) + do m=1,NTR + call query_vardesc(CS%tr_desc(m), name, caller="initialize_DOME_tracer") + call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) + enddo + else + do m=1,NTR + do k=1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = 1.0e-20 ! This could just as well be 0. + enddo ; enddo ; enddo + enddo + +! This sets a stripe of tracer across the basin. + do m=2,min(6,NTR) ; do j=js,je ; do i=is,ie + tr_y = 0.0 + if ((G%geoLatT(i,j) > (CS%stripe_s_lat + CS%stripe_width*real(m-2))) .and. & + (G%geoLatT(i,j) < (CS%stripe_s_lat + CS%stripe_width*real(m-1)))) & + tr_y = 1.0 + do k=1,nz +! This adds the stripes of tracer to every layer. + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + tr_y + enddo + enddo ; enddo ; enddo + + if (NTR >= 7) then + do j=js,je + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=is,ie + e(1) = 0.0 + do k=1,nz + e(K+1) = e(K) - dz(i,k) + do m=7,NTR + e_top = -CS%sheet_spacing * (real(m-6)) + e_bot = -CS%sheet_spacing * (real(m-6) + 0.5) + if (e_top < e(K)) then + if (e_top < e(K+1)) then ; d_tr = 0.0 + elseif (e_bot < e(K+1)) then + d_tr = 1.0 * (e_top-e(K+1)) / (dz(i,k)+dz_neglect) + else ; d_tr = 1.0 * (e_top-e_bot) / (dz(i,k)+dz_neglect) + endif + elseif (e_bot < e(K)) then + if (e_bot < e(K+1)) then ; d_tr = 1.0 + else ; d_tr = 1.0 * (e(K)-e_bot) / (dz(i,k)+dz_neglect) + endif + else + d_tr = 0.0 + endif + if (dz(i,k) < 2.0*GV%Angstrom_Z) d_tr=0.0 + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + d_tr + enddo + enddo + enddo + enddo + endif + + endif + endif ! restart + + if ( CS%use_sponge ) then +! If sponges are used, this example damps tracers in sponges in the +! northern half of the domain to 1 and tracers in the southern half +! to 0. For any tracers that are not damped in the sponge, the call +! to set_up_sponge_field can simply be omitted. + if (.not.associated(sponge_CSp)) & + call MOM_error(FATAL, "DOME_initialize_tracer: "// & + "The pointer to sponge_CSp must be associated if SPONGE is defined.") + + allocate(temp(G%isd:G%ied,G%jsd:G%jed,nz)) + do k=1,nz ; do j=js,je ; do i=is,ie + if (G%geoLatT(i,j) > 700.0 .and. (k > nz/2)) then + temp(i,j,k) = 1.0 + else + temp(i,j,k) = 0.0 + endif + enddo ; enddo ; enddo + +! do m=1,NTR + do m=1,1 + ! This pointer is needed to force the compiler not to do a copy in the sponge calls. + tr_ptr => CS%tr(:,:,:,m) + call set_up_sponge_field(temp, tr_ptr, G, GV, nz, sponge_CSp) + enddo + deallocate(temp) + endif + +end subroutine initialize_DOME_tracer + +!> This subroutine applies diapycnal diffusion and any other column +!! tracer physics or chemistry to the tracers from this file. +!! This is a simple example of a set of advected passive tracers. +!! +!! The arguments to this subroutine are redundant in that +!! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) +subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to DOME_register_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [H ~> m or kg m-2] + +! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + integer :: i, j, k, is, ie, js, je, nz, m + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,NTR + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + else + do m=1,NTR + call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + endif + +end subroutine DOME_tracer_column_physics + +!> This subroutine extracts the surface fields from this tracer package that +!! are to be shared with the atmosphere in coupled configurations. +!! This particular tracer package does not report anything back to the coupler. +subroutine DOME_tracer_surface_state(sfc_state, h, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to DOME_register_tracer. + + ! This particular tracer package does not report anything back to the coupler. + ! The code that is here is just a rough guide for packages that would. + + integer :: m, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (.not.associated(CS)) return + + if (CS%coupled_tracers) then + do m=1,NTR + ! This call loads the surface values into the appropriate array in the + ! coupler-type structure. + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + enddo + endif + +end subroutine DOME_tracer_surface_state + +!> Clean up memory allocations, if any. +subroutine DOME_tracer_end(CS) + type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to DOME_register_tracer. + if (associated(CS)) then + if (associated(CS%tr)) deallocate(CS%tr) + deallocate(CS) + endif +end subroutine DOME_tracer_end + +!> \namespace dome_tracer +!! +!! By Robert Hallberg, 2002 +!! +!! This file contains an example of the code that is needed to set +!! up and use a set (in this case eleven) of dynamically passive +!! tracers. These tracers dye the inflowing water or water initially +!! within a range of latitudes or water initially in a range of +!! depths. +!! +!! A single subroutine is called from within each file to register +!! each of the tracers for reinitialization and advection and to +!! register the subroutine that initializes the tracers and set up +!! their output and the subroutine that does any tracer physics or +!! chemistry along with diapycnal mixing (included here because some +!! tracers may float or swim vertically or dye diapycnal processes). + +end module DOME_tracer diff --git a/tracer/ISOMIP_tracer.F90 b/tracer/ISOMIP_tracer.F90 new file mode 100644 index 0000000000..fb2a44242f --- /dev/null +++ b/tracer/ISOMIP_tracer.F90 @@ -0,0 +1,351 @@ +!> Routines used to set up and use a set of (one for now) +!! dynamically passive tracers in the ISOMIP configuration. +!! +!! For now, just one passive tracer is injected in +!! the sponge layer. +module ISOMIP_tracer + +! This file is part of MOM6. See LICENSE.md for the license. + +! Original sample tracer package by Robert Hallberg, 2002 +! Adapted to the ISOMIP test case by Gustavo Marques, May 2016 + +use MOM_coms, only : max_across_PEs +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_hor_index, only : hor_index_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : MOM_restart_CS +use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +!< Publicly available functions +public register_ISOMIP_tracer, initialize_ISOMIP_tracer +public ISOMIP_tracer_column_physics, ISOMIP_tracer_surface_state, ISOMIP_tracer_end + +integer, parameter :: ntr = 1 !< ntr is the number of tracers in this module. + +!> ISOMIP tracer package control structure +type, public :: ISOMIP_tracer_CS ; private + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + character(len = 200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in g m-3? + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. + logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. + + integer, dimension(NTR) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux + !< if it is used and the surface tracer concentrations are to be + !< provided to the coupler. + + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. + + type(vardesc) :: tr_desc(NTR) !< Descriptions and metadata for the tracers in this package +end type ISOMIP_tracer_CS + +contains + + +!> This subroutine is used to register tracer fields +function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI ! NULL() + logical :: register_ISOMIP_tracer + integer :: isd, ied, jsd, jed, nz, m + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "ISOMIP_register_tracer called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "ISOMIP_TRACER_IC_FILE", CS%tracer_IC_file, & + "The name of a file from which to read the initial "//& + "conditions for the ISOMIP tracers, or blank to initialize "//& + "them internally.", default=" ") + if (len_trim(CS%tracer_IC_file) >= 1) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + CS%tracer_IC_file = trim(inputdir)//trim(CS%tracer_IC_file) + call log_param(param_file, mdl, "INPUTDIR/ISOMIP_TRACER_IC_FILE", & + CS%tracer_IC_file) + endif + call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified from MOM_initialization.F90.", default=.false.) + + allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) + + do m=1,NTR + if (m < 10) then ; write(name,'("tr_D",I1.1)') m + else ; write(name,'("tr_D",I2.2)') m ; endif + write(longname,'("Concentration of ISOMIP Tracer ",I2.2)') m + CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" + else ; flux_units = "kg s-1" ; endif + + ! This is needed to force the compiler not to do a copy in the registration + ! calls. Curses on the designers and implementers of Fortran90. + tr_ptr => CS%tr(:,:,:,m) + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + name=name, longname=longname, units="kg kg-1", & + registry_diags=.true., flux_units=flux_units, & + restart_CS=restart_CS) + + ! Set coupled_tracers to be true (hard-coded above) to provide the surface + ! values to the coupler (if any). This is meta-code and its arguments will + ! currently (deliberately) give fatal errors if it is used. + if (CS%coupled_tracers) & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(name)//'_flux', & + flux_type=' ', implementation=' ', caller="register_ISOMIP_tracer") + enddo + + CS%tr_Reg => tr_Reg + register_ISOMIP_tracer = .true. +end function register_ISOMIP_tracer + +!> Initializes the NTR tracer fields in tr(:,:,:,:) +! and it sets up the tracer output. +subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & + ALE_sponge_CSp) + + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary conditions + !! are used. This is not being used for now. + type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous call + !! to ISOMIP_register_tracer. + type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< A pointer to the control structure for + !! the sponges, if they are in use. Otherwise this + !! may be unassociated. + + character(len=16) :: name ! A variable's name in a NetCDF file. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m + integer :: IsdB, IedB, JsdB, JedB + + if (.not.associated(CS)) return + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + h_neglect = GV%H_subroundoff + + CS%Time => day + CS%diag => diag + + if (.not.restart) then + if (len_trim(CS%tracer_IC_file) >= 1) then + ! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & + call MOM_error(FATAL, "ISOMIP_initialize_tracer: Unable to open "// & + CS%tracer_IC_file) + do m=1,NTR + call query_vardesc(CS%tr_desc(m), name, caller="initialize_ISOMIP_tracer") + call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) + enddo + else + do m=1,NTR + do k=1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = 0.0 + enddo ; enddo ; enddo + enddo + endif + endif ! restart + +! the following does not work in layer mode yet +!! if ( CS%use_sponge ) then + ! If sponges are used, this example damps tracers in sponges in the + ! northern half of the domain to 1 and tracers in the southern half + ! to 0. For any tracers that are not damped in the sponge, the call + ! to set_up_sponge_field can simply be omitted. +! if (.not.associated(ALE_sponge_CSp)) & +! call MOM_error(FATAL, "ISOMIP_initialize_tracer: "// & +! "The pointer to ALEsponge_CSp must be associated if SPONGE is defined.") + +! allocate(temp(G%isd:G%ied,G%jsd:G%jed,nz)) + +! do j=js,je ; do i=is,ie +! if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then +! temp(i,j,:) = 1.0 +! else +! temp(i,j,:) = 0.0 +! endif +! enddo ; enddo + + ! do m=1,NTR +! do m=1,1 + ! This is needed to force the compiler not to do a copy in the sponge + ! calls. Curses on the designers and implementers of Fortran90. +! tr_ptr => CS%tr(:,:,:,m) +! call set_up_ALE_sponge_field(temp, G, tr_ptr, ALE_sponge_CSp) +! enddo +! deallocate(temp) +! endif + +end subroutine initialize_ISOMIP_tracer + +!> This subroutine applies diapycnal diffusion, including the surface boundary +!! conditions and any other column tracer physics or chemistry to the tracers from this file. +subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to ISOMIP_register_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [H ~> m or kg m-2] + +! The arguments to this subroutine are redundant in that +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting, negative for freezing) [R Z T-1 ~> kg m-2 s-1] + real :: mmax ! The global maximum melting rate [R Z T-1 ~> kg m-2 s-1] + integer :: i, j, k, is, ie, js, je, nz, m + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + + melt(:,:) = fluxes%iceshelf_melt(:,:) + + ! max. melt + mmax = MAXVAL(melt(is:ie,js:je)) + call max_across_PEs(mmax) + ! write(mesg,*) 'max melt = ', mmax + ! call MOM_mesg(mesg, 5) + ! dye melt water (m=1), dye = 1 if melt=max(melt) + do m=1,NTR + do j=js,je ; do i=is,ie + if (melt(i,j) > 0.0) then ! melting + CS%tr(i,j,1:2,m) = melt(i,j)/mmax ! inject dye in the ML + else ! freezing + CS%tr(i,j,1:2,m) = 0.0 + endif + enddo ; enddo + enddo + + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,NTR + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + else + do m=1,NTR + call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + endif + +end subroutine ISOMIP_tracer_column_physics + +!> This subroutine extracts the surface fields from this tracer package that +!! are to be shared with the atmosphere in coupled configurations. +!! This particular tracer package does not report anything back to the coupler. +subroutine ISOMIP_tracer_surface_state(sfc_state, h, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to ISOMIP_register_tracer. + + ! This particular tracer package does not report anything back to the coupler. + ! The code that is here is just a rough guide for packages that would. + + integer :: m, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (.not.associated(CS)) return + + if (CS%coupled_tracers) then + do m=1,ntr + ! This call loads the surface values into the appropriate array in the + ! coupler-type structure. + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + enddo + endif + +end subroutine ISOMIP_tracer_surface_state + +!> Deallocate any memory used by the ISOMIP tracer package +subroutine ISOMIP_tracer_end(CS) + type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to ISOMIP_register_tracer. + + if (associated(CS)) then + if (associated(CS%tr)) deallocate(CS%tr) + deallocate(CS) + endif +end subroutine ISOMIP_tracer_end + +end module ISOMIP_tracer diff --git a/tracer/MOM_CFC_cap.F90 b/tracer/MOM_CFC_cap.F90 new file mode 100644 index 0000000000..489948a63c --- /dev/null +++ b/tracer/MOM_CFC_cap.F90 @@ -0,0 +1,746 @@ + !> Simulates CFCs using atmospheric pressure, wind speed and sea ice cover +!! provided via cap (only NUOPC cap is implemented so far). +module MOM_CFC_cap + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : EFP_type +use MOM_debugging, only : hchksum +use MOM_diag_mediator, only : diag_ctrl, register_diag_field, post_data +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_hor_index, only : hor_index_type +use MOM_grid, only : ocean_grid_type +use MOM_CVMix_KPP, only : KPP_NonLocalTransport, KPP_CS +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, query_vardesc, stdout +use MOM_tracer_registry, only : tracer_type +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_time_manager, only : time_type, increment_date +use MOM_interpolate, only : external_field, init_external_field, time_interp_external +use MOM_tracer_registry, only : register_tracer +use MOM_tracer_types, only : tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public register_CFC_cap, initialize_CFC_cap, CFC_cap_unit_tests +public CFC_cap_column_physics, CFC_cap_set_forcing +public CFC_cap_stock, CFC_cap_end + +integer, parameter :: NTR = 2 !< the number of tracers in this module. + +!> Contains the concentration array, surface flux, a pointer to Tr in Tr_reg, +!! and some metadata for a single CFC tracer +type, private :: CFC_tracer_data + type(vardesc) :: desc !< A set of metadata for the tracer + real :: IC_val = 0.0 !< The initial value assigned to the tracer [mol kg-1]. + real :: land_val = -1.0 !< The value of the tracer used where land is + !! masked out [mol kg-1]. + character(len=32) :: name !< Tracer variable name + integer :: id_cmor = -1 !< Diagnostic id + integer :: id_sfc_flux = -1 !< Surface flux id + real, pointer, dimension(:,:,:) :: conc !< The tracer concentration [mol kg-1]. + real, pointer, dimension(:,:) :: sfc_flux !< Surface flux [CU R Z T-1 ~> mol m-2 s-1] + type(tracer_type), pointer :: tr_ptr !< pointer to tracer inside Tr_reg +end type CFC_tracer_data + +!> The control structure for the CFC_cap tracer package +type, public :: CFC_cap_CS ; private + logical :: debug !< If true, write verbose checksums for debugging purposes. + character(len=200) :: IC_file !< The file in which the CFC initial values can + !! be found, or an empty string for internal initilaization. + logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM6 tracer registry + logical :: tracers_may_reinit !< If true, tracers may be reset via the initialization code + !! if they are not found in the restart files. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate + !! the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Model restart control structure + + type(CFC_tracer_data), dimension(NTR) :: CFC_data !< per-tracer parameters / metadata + integer :: CFC_BC_year_offset = 0 !< offset to add to model time to get time value used in CFC_BC_file + type(external_field) :: cfc11_atm_nh_handle !< Handle for time-interpolated CFC11 atm NH + type(external_field) :: cfc11_atm_sh_handle !< Handle for time-interpolated CFC11 atm SH + type(external_field) :: cfc12_atm_nh_handle !< Handle for time-interpolated CFC12 atm NH + type(external_field) :: cfc12_atm_sh_handle !< Handle for time-interpolated CFC12 atm SH +end type CFC_cap_CS + +contains + +!> Register the CFCs to be used with MOM and read the parameters +!! that are used with this tracer package +function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. + type(CFC_cap_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module. + type(tracer_registry_type), & + pointer :: tr_Reg !< A pointer to the tracer registry. + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + + ! Local variables + character(len=40) :: mdl = "MOM_CFC_cap" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=200) :: inputdir ! The directory where NetCDF input files are. + real, dimension(:,:,:), pointer :: tr_ptr => NULL() + character(len=200) :: CFC_BC_file ! filename with cfc11 and cfc12 data + character(len=30) :: CFC_BC_var_name ! varname of field in CFC_BC_file + character :: m2char + logical :: register_CFC_cap + integer :: isd, ied, jsd, jed, nz, m + integer :: CFC_BC_data_year ! specific year in CFC BC data calendar + integer :: CFC_BC_model_year ! model year corresponding to CFC_BC_data_year + + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "register_CFC_cap called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "CFC_IC_FILE", CS%IC_file, & + "The file in which the CFC initial values can be "//& + "found, or an empty string for internal initialization.", & + default=" ") + if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file, '/') == 0)) then + ! Add the directory if CS%IC_file is not already a complete path. + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) + call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", CS%IC_file, & + "full path of CFC_IC_FILE") + endif + call get_param(param_file, mdl, "CFC_IC_FILE_IS_Z", CS%Z_IC_file, & + "If true, CFC_IC_FILE is in depth space, not layer space", & + default=.false.) + call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if tracers are not found in the "//& + "restart files of a restarted run.", default=.false.) + do m=1,NTR + write(m2char, "(I1)") m + call get_param(param_file, mdl, "CFC1"//m2char//"_IC_VAL", CS%CFC_data(m)%IC_val, & + "Value that CFC_1"//m2char//" is set to when it is not read from a file.", & + units="mol kg-1", default=0.0) + enddo + + ! the following params are not used in this module. Instead, they are used in + ! the cap but are logged here to keep all the CFC cap params together. + call get_param(param_file, mdl, "CFC_BC_FILE", CFC_BC_file, & + "The file in which the CFC-11 and CFC-12 atm concentrations can be "//& + "found (units must be parts per trillion).", default=" ") + if (len_trim(CFC_BC_file) == 0) then + call MOM_error(FATAL, "CFC_BC_FILE must be specified if USE_CFC_CAP=.true.") + endif + if (scan(CFC_BC_file, '/') == 0) then + ! Add the directory if CFC_BC_file is not already a complete path. + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + CFC_BC_file = trim(slasher(inputdir))//trim(CFC_BC_file) + call log_param(param_file, mdl, "INPUTDIR/CFC_BC_FILE", CFC_BC_file, & + "full path of CFC_BC_FILE") + endif + + call get_param(param_file, mdl, "CFC_BC_DATA_YEAR", CFC_BC_data_year, & + "Specific year in CFC_BC_FILE data calendar", default=2000) + call get_param(param_file, mdl, "CFC_BC_MODEL_YEAR", CFC_BC_model_year, & + "Model year corresponding to CFC_BC_MODEL_YEAR", default=2000) + CS%CFC_BC_year_offset = CFC_BC_data_year - CFC_BC_model_year + + call get_param(param_file, mdl, "CFC11_NH_VARIABLE", CFC_BC_var_name, & + "Variable name of NH CFC-11 atm mole fraction in CFC_BC_FILE.", & + default="cfc11_nh") + CS%cfc11_atm_nh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) + + call get_param(param_file, mdl, "CFC11_SH_VARIABLE", CFC_BC_var_name, & + "Variable name of SH CFC-11 atm mole fraction in CFC_BC_FILE.", & + default="cfc11_sh") + CS%cfc11_atm_sh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) + + call get_param(param_file, mdl, "CFC12_NH_VARIABLE", CFC_BC_var_name, & + "Variable name of NH CFC-12 atm mole fraction in CFC_BC_FILE.", & + default="cfc12_nh") + CS%cfc12_atm_nh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) + + call get_param(param_file, mdl, "CFC12_SH_VARIABLE", CFC_BC_var_name, & + "Variable name of SH CFC-12 atm mole fraction in CFC_BC_FILE.", & + default="cfc12_sh") + CS%cfc12_atm_sh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) +! domain=G%Domain%mpp_domain) + + ! The following vardesc types contain a package of metadata about each tracer, + ! including, the name; units; longname; and grid information. + do m=1,NTR + write(m2char, "(I1)") m + write(CS%CFC_data(m)%name, "(2A)") "CFC_1", m2char + CS%CFC_data(m)%desc = var_desc(CS%CFC_data(m)%name, & + "mol kg-1", & + "Moles Per Unit Mass of CFC-1"//m2char//" in sea water", & + caller=mdl) + + allocate(CS%CFC_data(m)%conc(isd:ied,jsd:jed,nz), source=0.0) + allocate(CS%CFC_data(m)%sfc_flux(isd:ied,jsd:jed), source=0.0) + + ! This pointer assignment is needed to force the compiler not to do a copy in + ! the registration calls. Curses on the designers and implementers of F90. + tr_ptr => CS%CFC_data(m)%conc + ! Register CFC tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + tr_desc=CS%CFC_data(m)%desc, registry_diags=.true., & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit, & + Tr_out=CS%CFC_data(m)%tr_ptr) + enddo + + CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS + register_CFC_cap = .true. + +end function register_CFC_cap + +!> Initialize the CFC tracer fields and set up the tracer output. +subroutine initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS) + logical, intent(in) :: restart !< .true. if the fields have already been + !! read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type + !! specifies whether, where, and what + !! open boundary conditions are used. + type(CFC_cap_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_CFC_cap. + + ! local variables + integer :: m + character :: m2char + + if (.not.associated(CS)) return + + CS%Time => day + CS%diag => diag + + do m=1,NTR + if (.not.restart .or. (CS%tracers_may_reinit .and. & + .not.query_initialized(CS%CFC_data(m)%conc, CS%CFC_data(m)%name, CS%restart_CSp))) then + call init_tracer_CFC(h, CS%CFC_data(m)%conc, CS%CFC_data(m)%name, CS%CFC_data(m)%land_val, & + CS%CFC_data(m)%IC_val, G, GV, US, CS) + call set_initialized(CS%CFC_data(m)%conc, CS%CFC_data(m)%name, CS%restart_CSp) + endif + + ! cmor diagnostics + ! units for cfc11_flux and cfc12_flux are [Conc R Z T-1 ~> mol m-2 s-1] + ! CFC11 cmor conventions: http://clipc-services.ceda.ac.uk/dreq/u/42625c97b8fe75124a345962c4430982.html + ! http://clipc-services.ceda.ac.uk/dreq/u/0940cbee6105037e4b7aa5579004f124.html + ! CFC12 cmor conventions: http://clipc-services.ceda.ac.uk/dreq/u/3ab8e10027d7014f18f9391890369235.html + ! http://clipc-services.ceda.ac.uk/dreq/u/e9e21426e4810d0bb2d3dddb24dbf4dc.html + write(m2char, "(I1)") m + CS%CFC_data(m)%id_cmor = register_diag_field('ocean_model', & + 'cfc1'//m2char, diag%axesTL, day, & + 'Mole Concentration of CFC1'//m2char//' in Sea Water', 'mol m-3', & + conversion=GV%Rho0*US%R_to_kg_m3) + + CS%CFC_data(m)%id_sfc_flux = register_diag_field('ocean_model', & + 'cfc1'//m2char//'_flux', diag%axesT1, day, & + 'Gas exchange flux of CFC1'//m2char//' into the ocean ', & + 'mol m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + cmor_field_name='fgcfc1'//m2char, & + cmor_long_name='Surface Downward CFC1'//m2char//' Flux', & + cmor_standard_name='surface_downward_cfc1'//m2char//'_flux') + enddo + + + if (associated(OBC)) then + ! Steal from updated DOME in the fullness of time. + ! GMM: TODO this must be coded if we intend to use this module in regional applications + endif + +end subroutine initialize_CFC_cap + +!>This subroutine initializes a tracer array. +subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: tr !< The tracer concentration array + character(len=*), intent(in) :: name !< The tracer name + real, intent(in) :: land_val !< A value the tracer takes over land + real, intent(in) :: IC_val !< The initial condition value for the tracer + type(CFC_cap_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_CFC_cap. + + ! local variables + logical :: OK + integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (len_trim(CS%IC_file) > 0) then + ! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%IC_file, G%Domain)) & + call MOM_error(FATAL, "initialize_CFC_cap: Unable to open "//CS%IC_file) + if (CS%Z_IC_file) then + OK = tracer_Z_init(tr, h, CS%IC_file, name, G, GV, US) + if (.not.OK) then + OK = tracer_Z_init(tr, h, CS%IC_file, trim(name), G, GV, US) + if (.not.OK) call MOM_error(FATAL,"initialize_CFC_cap: "//& + "Unable to read "//trim(name)//" from "//& + trim(CS%IC_file)//".") + endif + else + call MOM_read_data(CS%IC_file, trim(name), tr, G%Domain) + endif + else + do k=1,nz ; do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) < 0.5) then + tr(i,j,k) = land_val + else + tr(i,j,k) = IC_val + endif + enddo ; enddo ; enddo + endif + +end subroutine init_tracer_CFC + +!> Applies diapycnal diffusion, souces and sinks and any other column +!! tracer physics to the CFC cap tracers. CFCs are relatively simple, +!! as they are passive tracers with only a surface flux as a source. +subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, KPP_CSp, & + nonLocalTrans, evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes!< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(CFC_cap_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_CFC_cap. + type(KPP_CS), optional, pointer :: KPP_CSp !< KPP control structure + real, optional, intent(in) :: nonLocalTrans(:,:,:) !< Non-local transport [nondim] + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [H ~> m or kg m-2] + + ! The arguments to this subroutine are redundant in that + ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + integer :: i, j, k, is, ie, js, je, nz, m + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + + ! Compute KPP nonlocal term if necessary + if (present(KPP_CSp)) then + if (associated(KPP_CSp) .and. present(nonLocalTrans)) then + do m=1,NTR + call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, & + CS%CFC_data(m)%sfc_flux(:,:), dt, CS%diag, & + CS%CFC_data(m)%tr_ptr, CS%CFC_data(m)%conc(:,:,:), & + flux_scale=GV%RZ_to_H) + enddo + endif + endif + + ! Use a tridiagonal solver to determine the concentrations after the + ! surface source is applied and diapycnal advection and diffusion occurs. + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,NTR + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%CFC_data(m)%conc, dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%CFC_data(m)%conc, G, GV, & + sfc_flux=CS%CFC_data(m)%sfc_flux) + enddo + else + do m=1,NTR + call tracer_vertdiff(h_old, ea, eb, dt, CS%CFC_data(m)%conc, G, GV, & + sfc_flux=CS%CFC_data(m)%sfc_flux) + enddo + endif + + ! If needed, write out any desired diagnostics from tracer sources & sinks here. + do m=1,NTR + if (CS%CFC_data(m)%id_cmor > 0) & + call post_data(CS%CFC_data(m)%id_cmor, CS%CFC_data(m)%conc, CS%diag) + + if (CS%CFC_data(m)%id_sfc_flux > 0) & + call post_data(CS%CFC_data(m)%id_sfc_flux, CS%CFC_data(m)%sfc_flux, CS%diag) + enddo + +end subroutine CFC_cap_column_physics + + +!> Calculates the mass-weighted integral of all tracer stocks, +!! returning the number of stocks it has calculated. If the stock_index +!! is present, only the stock corresponding to that coded index is returned. +function CFC_cap_stock(h, stocks, G, GV, CS, names, units, stock_index) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] + type(CFC_cap_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_CFC_cap. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< The coded index of a specific + !! stock being sought. + integer :: CFC_cap_stock !< The number of stocks calculated here. + + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] + real :: mass ! The cell volume or mass [H L2 ~> m3 or kg] + integer :: i, j, k, is, ie, js, je, nz, m + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + CFC_cap_stock = 0 + if (.not.associated(CS)) return + + if (present(stock_index)) then ; if (stock_index > 0) then + ! Check whether this stock is available from this routine. + + ! No stocks from this routine are being checked yet. Return 0. + return + endif ; endif + + do m=1,NTR + call query_vardesc(CS%CFC_data(m)%desc, name=names(m), units=units(m), caller="CFC_cap_stock") + units(m) = trim(units(m))//" kg" + stocks(m) = global_mass_int_EFP(h, G, GV, CS%CFC_data(m)%conc, on_PE_only=.true.) + enddo + + CFC_cap_stock = NTR + +end function CFC_cap_stock + +!> Orchestrates the calculation of the CFC fluxes [mol m-2 s-1], including getting the ATM +!! concentration, and calculating the solubility, Schmidt number, and gas exchange. +subroutine CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, CS) + type(surface), intent(in ) :: sfc_state !< A structure containing fields + !! that describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers + !! to thermodynamic and tracer forcing fields. Unused fields + !! have NULL ptrs. + type(time_type), intent(in) :: day_start !< Start time of the fluxes. + type(time_type), intent(in) :: day_interval !< Length of time over which these + !! fluxes will be applied. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< The mean ocean density [R ~> kg m-3] + type(CFC_cap_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_CFC_cap. + + ! Local variables + type(time_type) :: Time_external ! time value used in CFC_BC_file + real, dimension(SZI_(G),SZJ_(G)) :: & + kw_wo_sc_no_term, & ! gas transfer velocity, without the Schmidt number term [Z T-1 ~> m s-1]. + kw, & ! gas transfer velocity [Z T-1 ~> m s-1]. + cair, & ! The surface gas concentration in equilibrium with the atmosphere + ! (saturation concentration) [mol kg-1]. + cfc11_atm, & ! CFC11 atm mole fraction [pico mol/mol] + cfc12_atm ! CFC12 atm mole fraction [pico mol/mol] + real :: cfc11_atm_nh ! NH value for cfc11_atm + real :: cfc11_atm_sh ! SH value for cfc11_atm + real :: cfc12_atm_nh ! NH value for cfc12_atm + real :: cfc12_atm_sh ! SH value for cfc12_atm + real :: ta ! Absolute sea surface temperature [hectoKelvin] + real :: sal ! Surface salinity [PSU]. + real :: alpha_11 ! The solubility of CFC 11 [mol kg-1 atm-1]. + real :: alpha_12 ! The solubility of CFC 12 [mol kg-1 atm-1]. + real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12 [nondim]. + real :: kw_coeff ! A coefficient used to compute the piston velocity [Z T-1 T2 L-2 = Z T L-2 ~> s / m] + real, parameter :: pa_to_atm = 9.8692316931427e-6 ! factor for converting from Pa to atm [atm Pa-1]. + real :: press_to_atm ! converts from model pressure units to atm [atm T2 R-1 L-2 ~> atm Pa-1] + integer :: i, j, is, ie, js, je, m + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + ! Time_external = increment_date(day_start + day_interval/2, years=CS%CFC_BC_year_offset) + Time_external = increment_date(day_start, years=CS%CFC_BC_year_offset) + + ! CFC11 atm mole fraction, convert from ppt (pico mol/mol) to mol/mol + call time_interp_external(CS%cfc11_atm_nh_handle, Time_external, cfc11_atm_nh) + cfc11_atm_nh = cfc11_atm_nh * 1.0e-12 + call time_interp_external(CS%cfc11_atm_sh_handle, Time_external, cfc11_atm_sh) + cfc11_atm_sh = cfc11_atm_sh * 1.0e-12 + + ! CFC12 atm mole fraction, convert from ppt (pico mol/mol) to mol/mol + call time_interp_external(CS%cfc12_atm_nh_handle, Time_external, cfc12_atm_nh) + cfc12_atm_nh = cfc12_atm_nh * 1.0e-12 + call time_interp_external(CS%cfc12_atm_sh_handle, Time_external, cfc12_atm_sh) + cfc12_atm_sh = cfc12_atm_sh * 1.0e-12 + + !--------------------------------------------------------------------- + ! Gas exchange/piston velocity parameter + !--------------------------------------------------------------------- + ! From a = 0.251 cm/hr s^2/m^2 in Wannikhof 2014 + ! = 6.97e-7 m/s s^2/m^2 [Z T-1 T2 L-2 = Z T L-2 ~> s / m] + kw_coeff = (US%m_to_Z*US%s_to_T*US%L_to_m**2) * 6.97e-7 + + ! set unit conversion factors + press_to_atm = US%R_to_kg_m3*US%L_T_to_m_s**2 * pa_to_atm + + do j=js,je ; do i=is,ie + if (G%geoLatT(i,j) < -10.0) then + cfc11_atm(i,j) = cfc11_atm_sh + cfc12_atm(i,j) = cfc12_atm_sh + elseif (G%geoLatT(i,j) <= 10.0) then + cfc11_atm(i,j) = cfc11_atm_sh + & + (0.05 * G%geoLatT(i,j) + 0.5) * (cfc11_atm_nh - cfc11_atm_sh) + cfc12_atm(i,j) = cfc12_atm_sh + & + (0.05 * G%geoLatT(i,j) + 0.5) * (cfc12_atm_nh - cfc12_atm_sh) + else + cfc11_atm(i,j) = cfc11_atm_nh + cfc12_atm(i,j) = cfc12_atm_nh + endif + enddo ; enddo + + do j=js,je ; do i=is,ie + ! ta in hectoKelvin + ta = max(0.01, (US%C_to_degC*sfc_state%SST(i,j) + 273.15) * 0.01) + sal = US%S_to_ppt*sfc_state%SSS(i,j) + + ! Calculate solubilities + call get_solubility(alpha_11, alpha_12, ta, sal , G%mask2dT(i,j)) + + ! Calculate Schmidt numbers using coefficients given by + ! Wanninkhof (2014); doi:10.4319/lom.2014.12.351. + call comp_CFC_schmidt(US%C_to_degC*sfc_state%SST(i,j), sc_11, sc_12) + + kw_wo_sc_no_term(i,j) = kw_coeff * ((1.0 - fluxes%ice_fraction(i,j))*fluxes%u10_sqr(i,j)) + + ! air concentrations and cfcs BC's fluxes + ! CFC flux units: CU R Z T-1 = mol kg-1 R Z T-1 ~> mol m-2 s-1 + kw(i,j) = kw_wo_sc_no_term(i,j) * sqrt(660.0 / sc_11) + cair(i,j) = press_to_atm * alpha_11 * cfc11_atm(i,j) * fluxes%p_surf_full(i,j) + CS%CFC_data(1)%sfc_flux(i,j) = kw(i,j) * (cair(i,j) - CS%CFC_data(1)%conc(i,j,1)) * Rho0 + + kw(i,j) = kw_wo_sc_no_term(i,j) * sqrt(660.0 / sc_12) + cair(i,j) = press_to_atm * alpha_12 * cfc12_atm(i,j) * fluxes%p_surf_full(i,j) + CS%CFC_data(2)%sfc_flux(i,j) = kw(i,j) * (cair(i,j) - CS%CFC_data(2)%conc(i,j,1)) * Rho0 + enddo ; enddo + + if (CS%debug) then + do m=1,NTR + call hchksum(CS%CFC_data(m)%sfc_flux, trim(CS%CFC_data(m)%name)//" sfc_flux", G%HI, & + scale=US%RZ_T_to_kg_m2s) + enddo + endif + +end subroutine CFC_cap_set_forcing + +!> Calculates the CFC's solubility function following Warner and Weiss (1985) DSR, vol 32. +subroutine get_solubility(alpha_11, alpha_12, ta, sal , mask) + real, intent(inout) :: alpha_11 !< The solubility of CFC 11 [mol kg-1 atm-1] + real, intent(inout) :: alpha_12 !< The solubility of CFC 12 [mol kg-1 atm-1] + real, intent(in ) :: ta !< Absolute sea surface temperature [hectoKelvin] + real, intent(in ) :: sal !< Surface salinity [PSU]. + real, intent(in ) :: mask !< ocean mask [nondim] + + ! Local variables + + ! Coefficients for calculating CFC11 solubilities + ! from Table 5 in Warner and Weiss (1985) DSR, vol 32. + + real, parameter :: d1_11 = -232.0411 ! [nondim] + real, parameter :: d2_11 = 322.5546 ! [hectoKelvin-1] + real, parameter :: d3_11 = 120.4956 ! [log(hectoKelvin)-1] + real, parameter :: d4_11 = -1.39165 ! [hectoKelvin-2] + + real, parameter :: e1_11 = -0.146531 ! [PSU-1] + real, parameter :: e2_11 = 0.093621 ! [PSU-1 hectoKelvin-1] + real, parameter :: e3_11 = -0.0160693 ! [PSU-2 hectoKelvin-2] + + ! Coefficients for calculating CFC12 solubilities + ! from Table 5 in Warner and Weiss (1985) DSR, vol 32. + + real, parameter :: d1_12 = -220.2120 ! [nondim] + real, parameter :: d2_12 = 301.8695 ! [hectoKelvin-1] + real, parameter :: d3_12 = 114.8533 ! [log(hectoKelvin)-1] + real, parameter :: d4_12 = -1.39165 ! [hectoKelvin-2] + + real, parameter :: e1_12 = -0.147718 ! [PSU-1] + real, parameter :: e2_12 = 0.093175 ! [PSU-1 hectoKelvin-1] + real, parameter :: e3_12 = -0.0157340 ! [PSU-2 hectoKelvin-2] + + real :: factor ! introduce units to result [mol kg-1 atm-1] + + ! Eq. 9 from Warner and Weiss (1985) DSR, vol 32. + factor = 1.0 + alpha_11 = exp(d1_11 + d2_11/ta + d3_11*log(ta) + d4_11*ta**2 +& + sal * ((e3_11 * ta + e2_11) * ta + e1_11)) * & + factor * mask + alpha_12 = exp(d1_12 + d2_12/ta + d3_12*log(ta) + d4_12*ta**2 +& + sal * ((e3_12 * ta + e2_12) * ta + e1_12)) * & + factor * mask + +end subroutine get_solubility + + +!> Compute Schmidt numbers of CFCs following Wanninkhof (2014); doi:10.4319/lom.2014.12.351 +!! Range of validity of fit is -2:40. +subroutine comp_CFC_schmidt(sst_in, cfc11_sc, cfc12_sc) + real, intent(in) :: sst_in !< The sea surface temperature [degC]. + real, intent(inout) :: cfc11_sc !< Schmidt number of CFC11 [nondim]. + real, intent(inout) :: cfc12_sc !< Schmidt number of CFC12 [nondim]. + + !local variables + real , parameter :: a_11 = 3579.2 ! CFC11 Schmidt number fit coefficient [nondim] + real , parameter :: b_11 = -222.63 ! CFC11 Schmidt number fit coefficient [degC-1] + real , parameter :: c_11 = 7.5749 ! CFC11 Schmidt number fit coefficient [degC-2] + real , parameter :: d_11 = -0.14595 ! CFC11 Schmidt number fit coefficient [degC-3] + real , parameter :: e_11 = 0.0011874 ! CFC11 Schmidt number fit coefficient [degC-4] + real , parameter :: a_12 = 3828.1 ! CFC12 Schmidt number fit coefficient [nondim] + real , parameter :: b_12 = -249.86 ! CFC12 Schmidt number fit coefficient [degC-1] + real , parameter :: c_12 = 8.7603 ! CFC12 Schmidt number fit coefficient [degC-2] + real , parameter :: d_12 = -0.1716 ! CFC12 Schmidt number fit coefficient [degC-3] + real , parameter :: e_12 = 0.001408 ! CFC12 Schmidt number fit coefficient [degC-4] + real :: sst ! A range-limited sea surface temperature [degC] + + + ! clip SST to avoid bad values + sst = MAX(-2.0, MIN(40.0, sst_in)) + cfc11_sc = a_11 + sst * (b_11 + sst * (c_11 + sst * (d_11 + sst * e_11))) + cfc12_sc = a_12 + sst * (b_12 + sst * (c_12 + sst * (d_12 + sst * e_12))) + +end subroutine comp_CFC_schmidt + +!> Deallocate any memory associated with the CFC cap tracer package +subroutine CFC_cap_end(CS) + type(CFC_cap_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_CFC_cap. + + ! local variables + integer :: m + + if (associated(CS)) then + do m=1,NTR + if (associated(CS%CFC_data(m)%conc)) deallocate(CS%CFC_data(m)%conc) + if (associated(CS%CFC_data(m)%sfc_flux)) deallocate(CS%CFC_data(m)%sfc_flux) + enddo + + deallocate(CS) + endif +end subroutine CFC_cap_end + +!> Unit tests for the CFC cap module. +logical function CFC_cap_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, output additional + !! information for debugging unit tests + + ! Local variables + real :: dummy1, dummy2, ta, sal + character(len=120) :: test_name ! Title of the unit test + + CFC_cap_unit_tests = .false. + write(stdout,*) '==== MOM_CFC_cap =======================' + + ! test comp_CFC_schmidt, Table 1 in Wanninkhof (2014); doi:10.4319/lom.2014.12.351 + test_name = 'Schmidt number calculation' + call comp_CFC_schmidt(20.0, dummy1, dummy2) + CFC_cap_unit_tests = CFC_cap_unit_tests .or. & + compare_values(verbose, test_name, dummy1, 1179.0, 0.5) + CFC_cap_unit_tests = CFC_cap_unit_tests .or. & + compare_values(verbose, test_name, dummy2, 1188.0, 0.5) + + if (.not. CFC_cap_unit_tests) write(stdout,'(2x,a)') "Passed "//test_name + + test_name = 'Solubility function, SST = 1.0 C, and SSS = 10 psu' + ta = max(0.01, (1.0 + 273.15) * 0.01); sal = 10. + ! cfc1 = 3.238 10-2 mol kg-1 atm-1 + ! cfc2 = 7.943 10-3 mol kg-1 atm-1 + call get_solubility(dummy1, dummy2, ta, sal , 1.0) + CFC_cap_unit_tests = CFC_cap_unit_tests .or. & + compare_values(verbose, test_name, dummy1, 3.238e-2, 5.0e-6) + CFC_cap_unit_tests = CFC_cap_unit_tests .or. & + compare_values(verbose, test_name, dummy2, 7.943e-3, 5.0e-6) + + if (.not. CFC_cap_unit_tests) write(stdout,'(2x,a)')"Passed "//test_name + + test_name = 'Solubility function, SST = 20.0 C, and SSS = 35 psu' + ta = max(0.01, (20.0 + 273.15) * 0.01); sal = 35. + ! cfc1 = 0.881 10-2 mol kg-1 atm-1 + ! cfc2 = 2.446 10-3 mol kg-1 atm-1 + call get_solubility(dummy1, dummy2, ta, sal , 1.0) + CFC_cap_unit_tests = CFC_cap_unit_tests .or. & + compare_values(verbose, test_name, dummy1, 8.8145e-3, 5.0e-8) + CFC_cap_unit_tests = CFC_cap_unit_tests .or. & + compare_values(verbose, test_name, dummy2, 2.4462e-3, 5.0e-8) + if (.not. CFC_cap_unit_tests) write(stdout,'(2x,a)')"Passed "//test_name + +end function CFC_cap_unit_tests + +!> Test that ans and calc are approximately equal by computing the difference +!! and comparing it against limit. +logical function compare_values(verbose, test_name, calc, ans, limit) + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=80), intent(in) :: test_name !< Brief description of the unit test + real, intent(in) :: calc !< computed value + real, intent(in) :: ans !< correct value + real, intent(in) :: limit !< value above which test fails + + ! Local variables + real :: diff + + diff = ans - calc + + compare_values = .false. + if (diff > limit ) then + compare_values = .true. + write(stdout,*) "CFC_cap_unit_tests, UNIT TEST FAILED: ", test_name + write(stdout,10) calc, ans + elseif (verbose) then + write(stdout,10) calc, ans + endif + +10 format("calc=",f22.16," ans",f22.16) +end function compare_values + +!> \namespace mom_CFC_cap +!! +!! This module contains the code that is needed to simulate +!! CFC-11 and CFC-12 using atmospheric and sea ice variables +!! provided via cap (only NUOPC cap is implemented so far). + +end module MOM_CFC_cap diff --git a/tracer/MOM_OCMIP2_CFC.F90 b/tracer/MOM_OCMIP2_CFC.F90 new file mode 100644 index 0000000000..bb312b5a50 --- /dev/null +++ b/tracer/MOM_OCMIP2_CFC.F90 @@ -0,0 +1,624 @@ +!> Simulates CFCs using the OCMIP2 protocols +module MOM_OCMIP2_CFC + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : extract_coupler_type_data, set_coupler_type_data +use MOM_coupler_types, only : atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_hor_index, only : hor_index_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public register_OCMIP2_CFC, initialize_OCMIP2_CFC, flux_init_OCMIP2_CFC +public OCMIP2_CFC_column_physics, OCMIP2_CFC_surface_state +public OCMIP2_CFC_stock, OCMIP2_CFC_end + +!> The control structure for the OCMPI2_CFC tracer package +type, public :: OCMIP2_CFC_CS ; private + character(len=200) :: IC_file !< The file in which the CFC initial values can + !! be found, or an empty string for internal initilaization. + logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false.. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM6 tracer registry + real, pointer, dimension(:,:,:) :: & + CFC11 => NULL(), & !< The CFC11 concentration [mol m-3]. + CFC12 => NULL() !< The CFC12 concentration [mol m-3]. + ! In the following variables a suffix of _11 refers to CFC11 and _12 to CFC12. + !>@{ Coefficients used in the CFC11 and CFC12 solubility calculation + real :: a1_11, a1_12 ! Coefficients for calculating CFC11 and CFC12 Schmidt numbers [nondim] + real :: a2_11, a2_12 ! Coefficients for calculating CFC11 and CFC12 Schmidt numbers [degC-1] + real :: a3_11, a3_12 ! Coefficients for calculating CFC11 and CFC12 Schmidt numbers [degC-2] + real :: a4_11, a4_12 ! Coefficients for calculating CFC11 and CFC12 Schmidt numbers [degC-3] + + real :: d1_11, d1_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [nondim] + real :: d2_11, d2_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [hectoKelvin-1] + real :: d3_11, d3_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [log(hectoKelvin)-1] + real :: d4_11, d4_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [hectoKelvin-2] + + real :: e1_11, e1_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [PSU-1] + real :: e2_11, e2_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [PSU-1 hectoKelvin-1] + real :: e3_11, e3_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [PSU-2 hectoKelvin-2] + !>@} + real :: CFC11_IC_val = 0.0 !< The initial value assigned to CFC11 [mol m-3]. + real :: CFC12_IC_val = 0.0 !< The initial value assigned to CFC12 [mol m-3]. + real :: CFC11_land_val = -1.0 !< The value of CFC11 used where land is masked out [mol m-3]. + real :: CFC12_land_val = -1.0 !< The value of CFC12 used where land is masked out [mol m-3]. + logical :: tracers_may_reinit !< If true, tracers may be reset via the initialization code + !! if they are not found in the restart files. + character(len=16) :: CFC11_name !< CFC11 variable name + character(len=16) :: CFC12_name !< CFC12 variable name + + integer :: ind_cfc_11_flux !< Index returned by atmos_ocn_coupler_flux that is used to + !! pack and unpack surface boundary condition arrays. + integer :: ind_cfc_12_flux !< Index returned by atmos_ocn_coupler_flux that is used to + !! pack and unpack surface boundary condition arrays. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate + !! the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Model restart control structure + + ! The following vardesc types contain a package of metadata about each tracer. + type(vardesc) :: CFC11_desc !< A set of metadata for the CFC11 tracer + type(vardesc) :: CFC12_desc !< A set of metadata for the CFC12 tracer +end type OCMIP2_CFC_CS + +contains + +!> Register the OCMIP2 CFC tracers to be used with MOM and read the parameters +!! that are used with this tracer package +function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. + type(OCMIP2_CFC_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module. + type(tracer_registry_type), & + pointer :: tr_Reg !< A pointer to the tracer registry. + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + + ! Local variables + character(len=40) :: mdl = "MOM_OCMIP2_CFC" ! This module's name. + character(len=200) :: inputdir ! The directory where NetCDF input files are. + ! This include declares and sets the variable "version". +# include "version_variable.h" + real, dimension(:,:,:), pointer :: tr_ptr => NULL() + real :: a11_dflt(4), a12_dflt(4) ! Default values of the various coefficients + real :: d11_dflt(4), d12_dflt(4) ! in the expressions for the solubility and + real :: e11_dflt(3), e12_dflt(3) ! Schmidt numbers [various units by element]. + character(len=48) :: flux_units ! The units for tracer fluxes. + logical :: register_OCMIP2_CFC + integer :: isd, ied, jsd, jed, nz + + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "register_OCMIP2_CFC called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! This call sets default properties for the air-sea CFC fluxes and obtains the + ! indicies for the CFC11 and CFC12 flux coupling. + call flux_init_OCMIP2_CFC(CS, verbosity=3) + if ((CS%ind_cfc_11_flux < 0) .or. (CS%ind_cfc_12_flux < 0)) then + ! This is most likely to happen with the dummy version of atmos_ocn_coupler_flux + ! used in ocean-only runs. + call MOM_ERROR(WARNING, "CFCs are currently only set up to be run in " // & + " coupled model configurations, and will be disabled.") + deallocate(CS) + register_OCMIP2_CFC = .false. + return + endif + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "CFC_IC_FILE", CS%IC_file, & + "The file in which the CFC initial values can be "//& + "found, or an empty string for internal initialization.", & + default=" ") + if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then + ! Add the directory if CS%IC_file is not already a complete path. + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) + call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", CS%IC_file) + endif + call get_param(param_file, mdl, "CFC_IC_FILE_IS_Z", CS%Z_IC_file, & + "If true, CFC_IC_FILE is in depth space, not layer space", & + default=.false.) + call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if tracers are not found in the "//& + "restart files of a restarted run.", default=.false.) + + ! The following vardesc types contain a package of metadata about each tracer, + ! including, the name; units; longname; and grid information. + CS%CFC11_name = "CFC11" ; CS%CFC12_name = "CFC12" + CS%CFC11_desc = var_desc(CS%CFC11_name,"mol m-3","CFC-11 Concentration", caller=mdl) + CS%CFC12_desc = var_desc(CS%CFC12_name,"mol m-3","CFC-12 Concentration", caller=mdl) + if (GV%Boussinesq) then ; flux_units = "mol s-1" + else ; flux_units = "mol m-3 kg s-1" ; endif + + allocate(CS%CFC11(isd:ied,jsd:jed,nz), source=0.0) + allocate(CS%CFC12(isd:ied,jsd:jed,nz), source=0.0) + + ! This pointer assignment is needed to force the compiler not to do a copy in + ! the registration calls. Curses on the designers and implementers of F90. + tr_ptr => CS%CFC11 + ! Register CFC11 for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + tr_desc=CS%CFC11_desc, registry_diags=.true., & + flux_units=flux_units, & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + ! Do the same for CFC12 + tr_ptr => CS%CFC12 + call register_tracer(tr_ptr, Tr_Reg, param_file, HI, GV, & + tr_desc=CS%CFC12_desc, registry_diags=.true., & + flux_units=flux_units, & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + + ! Set and read the various empirical coefficients. + +!----------------------------------------------------------------------- +! Default Schmidt number coefficients for CFC11 (_11) and CFC12 (_12) are given +! by Zheng et al (1998), JGR vol 103, C1. +!----------------------------------------------------------------------- + a11_dflt(:) = (/ 3501.8, -210.31, 6.1851, -0.07513 /) + a12_dflt(:) = (/ 3845.4, -228.95, 6.1908, -0.06743 /) + call get_param(param_file, mdl, "CFC11_A1", CS%a1_11, & + "A coefficient in the Schmidt number of CFC11.", & + units="nondim", default=a11_dflt(1)) + call get_param(param_file, mdl, "CFC11_A2", CS%a2_11, & + "A coefficient in the Schmidt number of CFC11.", & + units="degC-1", default=a11_dflt(2)) + call get_param(param_file, mdl, "CFC11_A3", CS%a3_11, & + "A coefficient in the Schmidt number of CFC11.", & + units="degC-2", default=a11_dflt(3)) + call get_param(param_file, mdl, "CFC11_A4", CS%a4_11, & + "A coefficient in the Schmidt number of CFC11.", & + units="degC-3", default=a11_dflt(4)) + + call get_param(param_file, mdl, "CFC12_A1", CS%a1_12, & + "A coefficient in the Schmidt number of CFC12.", & + units="nondim", default=a12_dflt(1)) + call get_param(param_file, mdl, "CFC12_A2", CS%a2_12, & + "A coefficient in the Schmidt number of CFC12.", & + units="degC-1", default=a12_dflt(2)) + call get_param(param_file, mdl, "CFC12_A3", CS%a3_12, & + "A coefficient in the Schmidt number of CFC12.", & + units="degC-2", default=a12_dflt(3)) + call get_param(param_file, mdl, "CFC12_A4", CS%a4_12, & + "A coefficient in the Schmidt number of CFC12.", & + units="degC-3", default=a12_dflt(4)) + +!----------------------------------------------------------------------- +! Solubility coefficients for alpha in mol/l/atm for CFC11 (_11) and CFC12 (_12) +! after Warner and Weiss (1985) DSR, vol 32. +!----------------------------------------------------------------------- + d11_dflt(:) = (/ -229.9261, 319.6552, 119.4471, -1.39165 /) + e11_dflt(:) = (/ -0.142382, 0.091459, -0.0157274 /) + d12_dflt(:) = (/ -218.0971, 298.9702, 113.8049, -1.39165 /) + e12_dflt(:) = (/ -0.143566, 0.091015, -0.0153924 /) + + call get_param(param_file, mdl, "CFC11_D1", CS%d1_11, & + "A coefficient in the solubility of CFC11.", & + units="none", default=d11_dflt(1)) + call get_param(param_file, mdl, "CFC11_D2", CS%d2_11, & + "A coefficient in the solubility of CFC11.", & + units="hK", default=d11_dflt(2)) + call get_param(param_file, mdl, "CFC11_D3", CS%d3_11, & + "A coefficient in the solubility of CFC11.", & + units="none", default=d11_dflt(3)) + call get_param(param_file, mdl, "CFC11_D4", CS%d4_11, & + "A coefficient in the solubility of CFC11.", & + units="hK-2", default=d11_dflt(4)) + call get_param(param_file, mdl, "CFC11_E1", CS%e1_11, & + "A coefficient in the solubility of CFC11.", & + units="PSU-1", default=e11_dflt(1)) + call get_param(param_file, mdl, "CFC11_E2", CS%e2_11, & + "A coefficient in the solubility of CFC11.", & + units="PSU-1 hK-1", default=e11_dflt(2)) + call get_param(param_file, mdl, "CFC11_E3", CS%e3_11, & + "A coefficient in the solubility of CFC11.", & + units="PSU-1 hK-2", default=e11_dflt(3)) + + call get_param(param_file, mdl, "CFC12_D1", CS%d1_12, & + "A coefficient in the solubility of CFC12.", & + units="none", default=d12_dflt(1)) + call get_param(param_file, mdl, "CFC12_D2", CS%d2_12, & + "A coefficient in the solubility of CFC12.", & + units="hK", default=d12_dflt(2)) + call get_param(param_file, mdl, "CFC12_D3", CS%d3_12, & + "A coefficient in the solubility of CFC12.", & + units="none", default=d12_dflt(3)) + call get_param(param_file, mdl, "CFC12_D4", CS%d4_12, & + "A coefficient in the solubility of CFC12.", & + units="hK-2", default=d12_dflt(4)) + call get_param(param_file, mdl, "CFC12_E1", CS%e1_12, & + "A coefficient in the solubility of CFC12.", & + units="PSU-1", default=e12_dflt(1)) + call get_param(param_file, mdl, "CFC12_E2", CS%e2_12, & + "A coefficient in the solubility of CFC12.", & + units="PSU-1 hK-1", default=e12_dflt(2)) + call get_param(param_file, mdl, "CFC12_E3", CS%e3_12, & + "A coefficient in the solubility of CFC12.", & + units="PSU-1 hK-2", default=e12_dflt(3)) + + CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS + + register_OCMIP2_CFC = .true. +end function register_OCMIP2_CFC + +!> This subroutine initializes the air-sea CFC fluxes, and optionally returns +!! the indicies of these fluxes. It can safely be called multiple times. +subroutine flux_init_OCMIP2_CFC(CS, verbosity) + type(OCMIP2_CFC_CS), optional, pointer :: CS !< An optional pointer to the control structure + !! for this module; if not present, the flux indicies + !! are not stored. + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + + ! These can be overridden later in via the field manager? + character(len=128) :: default_ice_restart_file = 'ice_ocmip2_cfc.res.nc' + character(len=128) :: default_ocean_restart_file = 'ocmip2_cfc.res.nc' + integer :: ind_flux(2) ! Integer indices of the fluxes + + ! 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', & + 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) + 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 /), & + ice_restart_file=default_ice_restart_file, & + ocean_restart_file=default_ocean_restart_file, & + caller="register_OCMIP2_CFC", verbosity=verbosity) + + if (present(CS)) then ; if (associated(CS)) then + CS%ind_cfc_11_flux = ind_flux(1) + CS%ind_cfc_12_flux = ind_flux(2) + endif ; endif + +end subroutine flux_init_OCMIP2_CFC + +!> Initialize the OCMP2 CFC tracer fields and set up the tracer output. +subroutine initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS, & + sponge_CSp) + logical, intent(in) :: restart !< .true. if the fields have already been + !! read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type + !! specifies whether, where, and what + !! open boundary conditions are used. + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. + type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure for + !! the sponges, if they are in use. + !! Otherwise this may be unassociated. + + if (.not.associated(CS)) return + + CS%Time => day + CS%diag => diag + + if (.not.restart .or. (CS%tracers_may_reinit .and. & + .not.query_initialized(CS%CFC11, CS%CFC11_name, CS%restart_CSp))) then + call init_tracer_CFC(h, CS%CFC11, CS%CFC11_name, CS%CFC11_land_val, & + CS%CFC11_IC_val, G, GV, US, CS) + call set_initialized(CS%CFC11, CS%CFC11_name, CS%restart_CSp) + endif + + if (.not.restart .or. (CS%tracers_may_reinit .and. & + .not.query_initialized(CS%CFC12, CS%CFC12_name, CS%restart_CSp))) then + call init_tracer_CFC(h, CS%CFC12, CS%CFC12_name, CS%CFC12_land_val, & + CS%CFC12_IC_val, G, GV, US, CS) + call set_initialized(CS%CFC12, CS%CFC12_name, CS%restart_CSp) + endif + + if (associated(OBC)) then + ! Steal from updated DOME in the fullness of time. + endif + +end subroutine initialize_OCMIP2_CFC + +!>This subroutine initializes a tracer array. +subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: tr !< The tracer concentration array + character(len=*), intent(in) :: name !< The tracer name + real, intent(in) :: land_val !< A value the tracer takes over land + real, intent(in) :: IC_val !< The initial condition value for the tracer + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. + + ! This subroutine initializes a tracer array. + + logical :: OK + integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (len_trim(CS%IC_file) > 0) then + ! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%IC_file, G%Domain)) & + call MOM_error(FATAL, "initialize_OCMIP2_CFC: Unable to open "//CS%IC_file) + if (CS%Z_IC_file) then + OK = tracer_Z_init(tr, h, CS%IC_file, name, G, GV, US) + if (.not.OK) then + OK = tracer_Z_init(tr, h, CS%IC_file, trim(name), G, GV, US) + if (.not.OK) call MOM_error(FATAL,"initialize_OCMIP2_CFC: "//& + "Unable to read "//trim(name)//" from "//& + trim(CS%IC_file)//".") + endif + else + call MOM_read_data(CS%IC_file, trim(name), tr, G%Domain) + endif + else + do k=1,nz ; do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) < 0.5) then + tr(i,j,k) = land_val + else + tr(i,j,k) = IC_val + endif + enddo ; enddo ; enddo + endif + +end subroutine init_tracer_CFC + +!> This subroutine applies diapycnal diffusion, souces and sinks and any other column +!! tracer physics or chemistry to the OCMIP2 CFC tracers. +!! CFCs are relatively simple, as they are passive tracers with only a surface flux as a source. +subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [H ~> m or kg m-2] +! This subroutine applies diapycnal diffusion and any other column +! tracer physics or chemistry to the tracers from this file. +! CFCs are relatively simple, as they are passive tracers. with only a surface +! flux as a source. + +! The arguments to this subroutine are redundant in that +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + CFC11_flux, & ! The fluxes of CFC11 and CFC12 into the ocean, in unscaled units of + CFC12_flux ! CFC concentrations times meters per second [CU R Z T-1 ~> CU kg m-2 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + integer :: i, j, k, is, ie, js, je, nz, idim(4), jdim(4) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + idim(:) = (/G%isd, is, ie, G%ied/) ; jdim(:) = (/G%jsd, js, je, G%jed/) + + if (.not.associated(CS)) return + + ! These two calls unpack the fluxes from the input arrays. + ! The -GV%Rho0 changes the sign convention of the flux and with the scaling factors changes + ! the units of the flux from [Conc. m s-1] to [Conc. R Z T-1 ~> Conc. kg m-2 s-1]. + call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, CFC11_flux, & + scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim) + call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, CFC12_flux, & + scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim) + + ! Use a tridiagonal solver to determine the concentrations after the + ! surface source is applied and diapycnal advection and diffusion occurs. + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%CFC11, dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%CFC11, G, GV, sfc_flux=CFC11_flux) + + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%CFC12, dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%CFC12, G, GV, sfc_flux=CFC12_flux) + else + call tracer_vertdiff(h_old, ea, eb, dt, CS%CFC11, G, GV, sfc_flux=CFC11_flux) + call tracer_vertdiff(h_old, ea, eb, dt, CS%CFC12, G, GV, sfc_flux=CFC12_flux) + endif + + ! Write out any desired diagnostics from tracer sources & sinks here. + +end subroutine OCMIP2_CFC_column_physics + +!> This function calculates the mass-weighted integral of all tracer stocks, +!! returning the number of stocks it has calculated. If the stock_index +!! is present, only the stock corresponding to that coded index is returned. +function OCMIP2_CFC_stock(h, stocks, G, GV, CS, names, units, stock_index) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< The coded index of a specific + !! stock being sought. + integer :: OCMIP2_CFC_stock !< The number of stocks calculated here. + + + OCMIP2_CFC_stock = 0 + if (.not.associated(CS)) return + + if (present(stock_index)) then ; if (stock_index > 0) then + ! Check whether this stock is available from this routine. + + ! No stocks from this routine are being checked yet. Return 0. + return + endif ; endif + + call query_vardesc(CS%CFC11_desc, name=names(1), units=units(1), caller="OCMIP2_CFC_stock") + call query_vardesc(CS%CFC12_desc, name=names(2), units=units(2), caller="OCMIP2_CFC_stock") + units(1) = trim(units(1))//" kg" ; units(2) = trim(units(2))//" kg" + + stocks(1) = global_mass_int_EFP(h, G, GV, CS%CFC11, on_PE_only=.true.) + stocks(2) = global_mass_int_EFP(h, G, GV, CS%CFC12, on_PE_only=.true.) + + OCMIP2_CFC_stock = 2 + +end function OCMIP2_CFC_stock + +!> This subroutine extracts the surface CFC concentrations and other fields that +!! are shared with the atmosphere to calculate CFC fluxes. +subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_OCMIP2_CFC. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + CFC11_Csurf, & ! The CFC-11 surface concentrations times the Schmidt number term [mol m-3]. + CFC12_Csurf, & ! The CFC-12 surface concentrations times the Schmidt number term [mol m-3]. + CFC11_alpha, & ! The CFC-11 solubility [mol m-3 pptv-1]. + CFC12_alpha ! The CFC-12 solubility [mol m-3 pptv-1]. + real :: ta ! Absolute sea surface temperature [hectoKelvin] (Why use such bizzare units?) + real :: sal ! Surface salinity [PSU]. + real :: SST ! Sea surface temperature [degC]. + real :: alpha_11 ! The solubility of CFC 11 [mol m-3 pptv-1]. + real :: alpha_12 ! The solubility of CFC 12 [mol m-3 pptv-1]. + real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12. + real :: sc_no_term ! A term related to the Schmidt number. + integer :: i, j, is, ie, js, je, idim(4), jdim(4) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + idim(:) = (/G%isd, is, ie, G%ied/) ; jdim(:) = (/G%jsd, js, je, G%jed/) + + if (.not.associated(CS)) return + + do j=js,je ; do i=is,ie + ta = max(0.01, (US%C_to_degC*sfc_state%SST(i,j) + 273.15) * 0.01) ! Why is this in hectoKelvin? + sal = US%S_to_ppt*sfc_state%SSS(i,j) ; SST = US%C_to_degC*sfc_state%SST(i,j) + ! Calculate solubilities using Warner and Weiss (1985) DSR, vol 32. + ! The final result is in mol/cm3/pptv (1 part per trillion 1e-12) + ! Use Bullister and Wisegavger for CCl4. + ! The factor 1.e-09 converts from mol/(l * atm) to mol/(m3 * pptv). + alpha_11 = exp(CS%d1_11 + CS%d2_11/ta + CS%d3_11*log(ta) + CS%d4_11*ta**2 +& + sal * ((CS%e3_11 * ta + CS%e2_11) * ta + CS%e1_11)) * & + 1.0e-09 * G%mask2dT(i,j) + alpha_12 = exp(CS%d1_12 + CS%d2_12/ta + CS%d3_12*log(ta) + CS%d4_12*ta**2 +& + sal * ((CS%e3_12 * ta + CS%e2_12) * ta + CS%e1_12)) * & + 1.0e-09 * G%mask2dT(i,j) + ! Calculate Schmidt numbers using coefficients given by + ! Zheng et al (1998), JGR vol 103, C1. + sc_11 = CS%a1_11 + SST * (CS%a2_11 + SST * (CS%a3_11 + SST * CS%a4_11)) * & + G%mask2dT(i,j) + sc_12 = CS%a1_12 + SST * (CS%a2_12 + SST * (CS%a3_12 + SST * CS%a4_12)) * & + G%mask2dT(i,j) + ! The abs here is to avoid NaNs. The model should be failing at this point. + sc_no_term = sqrt(660.0 / (abs(sc_11) + 1.0e-30)) + CFC11_alpha(i,j) = alpha_11 * sc_no_term + CFC11_Csurf(i,j) = CS%CFC11(i,j,1) * sc_no_term + + sc_no_term = sqrt(660.0 / (abs(sc_12) + 1.0e-30)) + CFC12_alpha(i,j) = alpha_12 * sc_no_term + CFC12_Csurf(i,j) = CS%CFC12(i,j,1) * sc_no_term + enddo ; enddo + + ! These calls load these values into the appropriate arrays in the + ! coupler-type structure. + call set_coupler_type_data(CFC11_alpha, CS%ind_cfc_11_flux, sfc_state%tr_fields, & + solubility=.true., idim=idim, jdim=jdim) + call set_coupler_type_data(CFC11_Csurf, CS%ind_cfc_11_flux, sfc_state%tr_fields, & + idim=idim, jdim=jdim) + call set_coupler_type_data(CFC12_alpha, CS%ind_cfc_12_flux, sfc_state%tr_fields, & + solubility=.true., idim=idim, jdim=jdim) + call set_coupler_type_data(CFC12_Csurf, CS%ind_cfc_12_flux, sfc_state%tr_fields, & + idim=idim, jdim=jdim) + +end subroutine OCMIP2_CFC_surface_state + +!> Deallocate any memory associated with the OCMIP2 CFC tracer package +subroutine OCMIP2_CFC_end(CS) + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. +! This subroutine deallocates the memory owned by this module. +! Argument: CS - The control structure returned by a previous call to +! register_OCMIP2_CFC. + + if (associated(CS)) then + if (associated(CS%CFC11)) deallocate(CS%CFC11) + if (associated(CS%CFC12)) deallocate(CS%CFC12) + + deallocate(CS) + endif +end subroutine OCMIP2_CFC_end + + +!> \namespace mom_ocmip2_cfc +!! +!! By Robert Hallberg, 2007 +!! +!! This module contains the code that is needed to set +!! up and use CFC-11 and CFC-12 in a fully coupled or ice-ocean model +!! context using the OCMIP2 protocols + +end module MOM_OCMIP2_CFC diff --git a/tracer/MOM_generic_tracer.F90 b/tracer/MOM_generic_tracer.F90 new file mode 100644 index 0000000000..f430e94515 --- /dev/null +++ b/tracer/MOM_generic_tracer.F90 @@ -0,0 +1,1046 @@ +!> Drives the generic version of tracers TOPAZ and CFC and other GFDL BGC components +module MOM_generic_tracer + +! This file is part of MOM6. See LICENSE.md for the license. + +#include + +! The following macro is usually defined in but since MOM6 should not directly +! include files from FMS we replicate the macro lines here: +#ifdef NO_F2000 +#define _ALLOCATED associated +#else +#define _ALLOCATED allocated +#endif + + ! ### These imports should not reach into FMS directly ### + use field_manager_mod, only: fm_string_len + + use generic_tracer, only: generic_tracer_register, generic_tracer_get_diag_list + use generic_tracer, only: generic_tracer_init, generic_tracer_source, generic_tracer_register_diag + use generic_tracer, only: generic_tracer_coupler_get, generic_tracer_coupler_set + use generic_tracer, only: generic_tracer_end, generic_tracer_get_list, do_generic_tracer + use generic_tracer, only: generic_tracer_update_from_bottom,generic_tracer_vertdiff_G + use generic_tracer, only: generic_tracer_coupler_accumulate + + use g_tracer_utils, only: g_tracer_get_name,g_tracer_set_values,g_tracer_set_common,g_tracer_get_common + use g_tracer_utils, only: g_tracer_get_next,g_tracer_type,g_tracer_is_prog,g_tracer_flux_init + use g_tracer_utils, only: g_tracer_send_diag,g_tracer_get_values + use g_tracer_utils, only: g_tracer_get_pointer,g_tracer_get_alias,g_tracer_set_csdiag + use g_tracer_utils, only: g_tracer_get_obc_segment_props + + use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS + use MOM_coms, only : EFP_type, max_across_PEs, min_across_PEs, PE_here + use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr + use MOM_diag_mediator, only : diag_ctrl, get_diag_time_end + use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe + use MOM_file_parser, only : get_param, log_param, log_version, param_file_type + use MOM_forcing_type, only : forcing, optics_type + use MOM_grid, only : ocean_grid_type + use MOM_hor_index, only : hor_index_type + use MOM_interface_heights, only : thickness_to_dz + use MOM_io, only : file_exists, MOM_read_data, slasher + use MOM_open_boundary, only : ocean_OBC_type + use MOM_open_boundary, only : register_obgc_segments, fill_obgc_segments + use MOM_open_boundary, only : set_obgc_segments_props + use MOM_restart, only : register_restart_field, query_initialized, set_initialized, MOM_restart_CS + use MOM_spatial_means, only : global_area_mean, global_mass_int_EFP + use MOM_sponge, only : set_up_sponge_field, sponge_CS + use MOM_time_manager, only : time_type, set_time + use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut + use MOM_tracer_registry, only : register_tracer, tracer_registry_type + use MOM_tracer_Z_init, only : tracer_Z_init + use MOM_tracer_initialization_from_Z, only : MOM_initialize_tracer_from_Z + use MOM_unit_scaling, only : unit_scale_type + use MOM_variables, only : surface, thermo_var_ptrs + use MOM_verticalGrid, only : verticalGrid_type + + + implicit none ; private + + !> A state hidden in module data that is very much not allowed in MOM6 + ! ### This needs to be fixed + logical :: g_registered = .false. + + public register_MOM_generic_tracer, initialize_MOM_generic_tracer + public MOM_generic_tracer_column_physics, MOM_generic_tracer_surface_state + public end_MOM_generic_tracer, MOM_generic_tracer_get + public MOM_generic_tracer_stock + public MOM_generic_flux_init + public MOM_generic_tracer_min_max + public MOM_generic_tracer_fluxes_accumulate + public register_MOM_generic_tracer_segments + + !> Control structure for generic tracers + type, public :: MOM_generic_tracer_CS ; private + character(len = 200) :: IC_file !< The file in which the generic tracer initial values can + !! be found, or an empty string for internal initialization. + logical :: Z_IC_file !< If true, the generic_tracer IC_file is in Z-space. The default is false. + real :: tracer_IC_val = 0.0 !< The initial value assigned to tracers, in + !! concentration units [conc] + real :: tracer_land_val = -1.0 !< The values of tracers used where land is masked out, in + !! concentration units [conc] + logical :: tracers_may_reinit !< If true, tracers may go through the + !! initialization code if they are not found in the restart files. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Restart control structure + type(ocean_OBC_type), pointer :: OBC => NULL() ! Pointer to the first element of the linked list of generic tracers. + type(g_tracer_type), pointer :: g_tracer_list => NULL() + + end type MOM_generic_tracer_CS + +contains + + !> Initializes the generic tracer packages and adds their tracers to the list + !! Adds the tracers in the list of generic tracers to the set of MOM tracers (i.e., MOM-register them) + !! Register these tracers for restart + function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI !< Horizontal index ranges + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer + !! advection and diffusion module. + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + + ! Local variables + logical :: register_MOM_generic_tracer + logical :: obc_has + ! This include declares and sets the variable "version". +# include "version_variable.h" + + character(len=128), parameter :: sub_name = 'register_MOM_generic_tracer' + character(len=200) :: inputdir ! The directory where NetCDF input files are. + ! These can be overridden later in via the field manager? + + integer :: ntau, axes(3) + type(g_tracer_type), pointer :: g_tracer, g_tracer_next + character(len=fm_string_len) :: g_tracer_name, longname,units + character(len=fm_string_len) :: obc_src_file_name, obc_src_field_name + real :: lfac_in ! Multiplicative factor used in setting the tracer-specific inverse length + ! scales associated with inflowing tracer reservoirs at OBCs [nondim] + real :: lfac_out ! Multiplicative factor used in setting the tracer-specific inverse length + ! scales associated with outflowing tracer reservoirs at OBCs [nondim] + real, dimension(:,:,:,:), pointer :: tr_field ! A pointer to a generic tracer field, in concentration units [conc] + real, dimension(:,:,:), pointer :: tr_ptr ! A pointer to a generic tracer field, in concentration units [conc] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)) :: grid_tmask ! A 3-d copy of G%mask2dT [nondim] + integer, dimension(SZI_(HI),SZJ_(HI)) :: grid_kmt ! A 2-d array of nk + + register_MOM_generic_tracer = .false. + if (associated(CS)) then + call MOM_error(FATAL, "register_MOM_generic_tracer called with an "// & + "associated control structure.") + endif + allocate(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. + endif + + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, sub_name, version, "") + call get_param(param_file, sub_name, "GENERIC_TRACER_IC_FILE", CS%IC_file, & + "The file in which the generic tracer initial values can "//& + "be found, or an empty string for internal initialization.", & + default=" ") + if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then + ! Add the directory if CS%IC_file is not already a complete path. + call get_param(param_file, sub_name, "INPUTDIR", inputdir, default=".") + CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) + call log_param(param_file, sub_name, "INPUTDIR/GENERIC_TRACER_IC_FILE", CS%IC_file) + endif + call get_param(param_file, sub_name, "GENERIC_TRACER_IC_FILE_IS_Z", CS%Z_IC_file, & + "If true, GENERIC_TRACER_IC_FILE is in depth space, not "//& + "layer space.",default=.false.) + call get_param(param_file, sub_name, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if tracers are not found in the "//& + "restart files of a restarted run.", default=.false.) + + CS%restart_CSp => restart_CS + + ntau=1 ! MOM needs the fields at only one time step + + + ! At this point G%mask2dT and CS%diag%axesTL are not allocated. + ! postpone diag_registeration to initialize_MOM_generic_tracer + + !Fields cannot be diag registered as they are allocated and have to registered later. + grid_tmask(:,:,:) = 0.0 + grid_kmt(:,:) = 0 + axes(:) = -1 + + ! + ! Initialize all generic tracers + ! + call generic_tracer_init(HI%isc,HI%iec,HI%jsc,HI%jec,HI%isd,HI%ied,HI%jsd,HI%jed,& + GV%ke,ntau,axes,grid_tmask,grid_kmt,set_time(0,0)) + + + ! + ! MOM-register the generic tracers + ! + + !Get the tracer list + call generic_tracer_get_list(CS%g_tracer_list) + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& + ": No tracer in the list.") + ! For each tracer name get its T_prog index and get its fields + + 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 + + enddo + + register_MOM_generic_tracer = .true. + end function register_MOM_generic_tracer + + !> Register OBC segments for generic tracers + subroutine register_MOM_generic_tracer_segments(CS, GV, OBC, tr_Reg, param_file) + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, + !! where, and what open boundary conditions are used. + type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer + !! advection and diffusion module. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + + ! Local variables + logical :: obc_has + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=128), parameter :: sub_name = 'register_MOM_generic_tracer_segments' + type(g_tracer_type), pointer :: g_tracer,g_tracer_next + character(len=fm_string_len) :: g_tracer_name + character(len=fm_string_len) :: obc_src_file_name, obc_src_field_name + real :: lfac_in ! Multiplicative factor used in setting the tracer-specific inverse length + ! scales associated with inflowing tracer reservoirs at OBCs [nondim] + real :: lfac_out ! Multiplicative factor used in setting the tracer-specific inverse length + ! scales associated with outflowing tracer reservoirs at OBCs [nondim] + + if (.NOT. associated(OBC)) return + !Get the tracer list + call generic_tracer_get_list(CS%g_tracer_list) + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& + ": No tracer in the list.") + + g_tracer=>CS%g_tracer_list + do + call g_tracer_get_alias(g_tracer,g_tracer_name) + if (g_tracer_is_prog(g_tracer)) then + call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_has ,& + obc_src_file_name,obc_src_field_name,lfac_in,lfac_out) + if (obc_has) then + call set_obgc_segments_props(OBC,g_tracer_name,obc_src_file_name,obc_src_field_name,lfac_in,lfac_out) + call register_obgc_segments(GV, OBC, tr_Reg, param_file, g_tracer_name) + endif + 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 + + end subroutine register_MOM_generic_tracer_segments + + !> Initialize phase II: Initialize required variables for generic tracers + !! There are some steps of initialization that cannot be done in register_MOM_generic_tracer + !! This is the place and time to do them: + !! Set the grid mask and initial time for all generic tracers. + !! Diag_register them. + !! Z_diag_register them. + !! + !! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) + !! and it sets up the tracer output. + subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, tv, param_file, diag, OBC, & + CS, sponge_CSp, ALE_sponge_CSp) + logical, intent(in) :: restart !< .true. if the fields have already been + !! read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic + !! variables + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(in) :: diag !< Regulates diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, + !! where, and what open boundary conditions are used. + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the + !! ALE sponges. + + character(len=128), parameter :: sub_name = 'initialize_MOM_generic_tracer' + logical :: OK,obc_has + integer :: i, j, k, isc, iec, jsc, jec, nk + type(g_tracer_type), pointer :: g_tracer,g_tracer_next + character(len=fm_string_len) :: g_tracer_name + real, dimension(:,:,:,:), pointer :: tr_field ! A pointer to a generic tracer field, in concentration units [conc] + real, dimension(:,:,:), pointer :: tr_ptr ! A pointer to a generic tracer field, in concentration units [conc] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Layer vertical extent [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: grid_tmask ! A 3-d copy of G%mask2dT [nondim] + integer, dimension(SZI_(G),SZJ_(G)) :: grid_kmt ! A 2-d array of nk + + !! 2010/02/04 Add code to re-initialize Generic Tracers if needed during a model simulation + !! By default, restart cpio should not contain a Generic Tracer IC file and step below will be skipped. + !! Ideally, the generic tracer IC file should have the tracers on Z levels. + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke + + CS%diag=>diag + !Get the tracer list + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& + ": No tracer in the list.") + !For each tracer name get its fields + g_tracer=>CS%g_tracer_list + + call thickness_to_dz(h, tv, dz, G, GV, US) + + do + if (INDEX(CS%IC_file, '_NULL_') /= 0) then + call MOM_error(WARNING, "The name of the IC_file "//trim(CS%IC_file)//& + " indicates no MOM initialization was asked for the generic tracers."//& + "Bypassing the MOM initialization of ALL generic tracers!") + exit + endif + call g_tracer_get_alias(g_tracer,g_tracer_name) + call g_tracer_get_pointer(g_tracer,g_tracer_name,'field',tr_field) + tr_ptr => tr_field(:,:,:,1) + + 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(dz, 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, & + h_in_Z_units=.true.) + + !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. + !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)//".") + 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 + 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 + + call set_initialized(tr_ptr, g_tracer_name, CS%restart_CSp) + endif + + call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_has ) + if(obc_has .and. g_tracer_is_prog(g_tracer) .and. .not.restart) & + call fill_obgc_segments(G, GV, OBC, tr_ptr, g_tracer_name) + !traverse the linked list till hit NULL + call g_tracer_get_next(g_tracer, g_tracer_next) + if (.NOT. associated(g_tracer_next)) exit + g_tracer=>g_tracer_next + enddo + !! end section to re-initialize generic tracers + + + !Now we can reset the grid mask, axes and time to their true values + !Note that grid_tmask must be set correctly on the data domain boundary + !so that coast mask can be deduced from it. + 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.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 + enddo ; enddo + call g_tracer_set_common(G%isc,G%iec,G%jsc,G%jec,G%isd,G%ied,G%jsd,G%jed,& + GV%ke,1,CS%diag%axesTL%handles,grid_tmask,grid_kmt,day) + + ! Register generic tracer modules diagnostics + +#ifdef _USE_MOM6_DIAG + call g_tracer_set_csdiag(CS%diag) +#endif + call generic_tracer_register_diag() +#ifdef _USE_MOM6_DIAG + call g_tracer_set_csdiag(CS%diag) +#endif + + end subroutine initialize_MOM_generic_tracer + + !> Column physics for generic tracers. + !! Get the coupler values for generic tracers that exchange with atmosphere + !! Update generic tracer concentration fields from sources and sinks. + !! Vertically diffuse generic tracer concentration fields. + !! Update generic tracers from bottom and their bottom reservoir. + !! + !! This subroutine applies diapycnal diffusion and any other column + !! tracer physics or chemistry to the tracers from this file. + !! CFCs are relatively simple, as they are passive tracers. with only a surface + !! flux as a source. + subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, US, CS, tv, optics, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< The amount of fluid entrained from the layer + !! above during this call [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< The amount of fluid entrained from the layer + !! below during this call [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(optics_type), intent(in) :: optics !< The structure containing optical properties. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + ! Stored previously in diabatic CS. + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes + !! can be applied [H ~> m or kg m-2] + ! Stored previously in diabatic CS. + ! The arguments to this subroutine are redundant in that + ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + + ! Local variables + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_column_physics' + + type(g_tracer_type), pointer :: g_tracer, g_tracer_next + character(len=fm_string_len) :: g_tracer_name + real, dimension(:,:), pointer :: stf_array ! The surface flux of the tracer [conc kg m-2 s-1] + real, dimension(:,:), pointer :: trunoff_array ! The tracer concentration in the river runoff [conc] + real, dimension(:,:), pointer :: runoff_tracer_flux_array ! The runoff tracer flux [conc kg m-2 s-1] + + real :: surface_field(SZI_(G),SZJ_(G)) ! The surface value of some field, here only used for salinity [S ~> ppt] + real :: dz_ml(SZI_(G),SZJ_(G)) ! The mixed layer depth in the MKS units used for generic tracers [m] + real :: sosga ! The global mean surface salinity [ppt] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: rho_dzt ! Layer mass per unit area [kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dzt ! Layer vertical extents [m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! A work array of thicknesses [H ~> m or kg m-2] + integer :: i, j, k, isc, iec, jsc, jec, nk + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke + + !Get the tracer list + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL,& + trim(sub_name)//": No tracer in the list.") + +#ifdef _USE_MOM6_DIAG + call g_tracer_set_csdiag(CS%diag) +#endif + + ! + !Extract the tracer surface fields from coupler and update tracer fields from sources + ! + !call generic_tracer_coupler_get(fluxes%tr_fluxes) + !Niki: This is moved out to ocean_model_MOM.F90 because if dt_therm>dt_cpld we need to average + ! the fluxes without coming into this subroutine. + ! MOM5 has to modified to conform. + + ! + !Add contribution of river to surface flux + ! + g_tracer=>CS%g_tracer_list + do + if (_ALLOCATED(g_tracer%trunoff) .and. (.NOT. g_tracer%runoff_added_to_stf)) 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 + g_tracer%runoff_added_to_stf = .true. + 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 + + ! + !Prepare input arrays for source update + ! + + rho_dzt(:,:,:) = GV%H_to_kg_m2 * GV%Angstrom_H + do k=1,nk ; do j=jsc,jec ; do i=isc,iec + rho_dzt(i,j,k) = GV%H_to_kg_m2 * h_old(i,j,k) + enddo ; enddo ; enddo + + dzt(:,:,:) = 1.0 + call thickness_to_dz(h_old, tv, dzt, G, GV, US) + do k=1,nk ; do j=jsc,jec ; do i=isc,iec + dzt(i,j,k) = US%Z_to_m * dzt(i,j,k) + enddo ; enddo ; enddo + dz_ml(:,:) = 0.0 + do j=jsc,jec ; do i=isc,iec + surface_field(i,j) = tv%S(i,j,1) + dz_ml(i,j) = US%Z_to_m * Hml(i,j) + enddo ; enddo + sosga = global_area_mean(surface_field, G, scale=US%S_to_ppt) + + ! + !Calculate tendencies (i.e., field changes at dt) from the sources / sinks + ! + if ((G%US%L_to_m == 1.0) .and. (G%US%s_to_T == 1.0) .and. (G%US%Z_to_m == 1.0) .and. & + (G%US%Q_to_J_kg == 1.0) .and. (G%US%RZ_to_kg_m2 == 1.0) .and. & + (US%C_to_degC == 1.0) .and. (US%S_to_ppt == 1.0)) then + ! Avoid unnecessary copies when no unit conversion is needed. + call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & + G%areaT, get_diag_time_end(CS%diag), & + optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & + internal_heat=tv%internal_heat, frunoff=fluxes%frunoff, sosga=sosga) + else + call generic_tracer_source(US%C_to_degC*tv%T, US%S_to_ppt*tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & + G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & + optics%nbands, optics%max_wavelength_band, & + sw_pen_band=G%US%QRZ_T_to_W_m2*optics%sw_pen_band(:,:,:), & + opacity_band=G%US%m_to_Z*optics%opacity_band(:,:,:,:), & + internal_heat=G%US%RZ_to_kg_m2*US%C_to_degC*tv%internal_heat(:,:), & + frunoff=G%US%RZ_T_to_kg_m2s*fluxes%frunoff(:,:), sosga=sosga) + endif + + ! This uses applyTracerBoundaryFluxesInOut to handle the change in tracer due to freshwater fluxes + ! usually in ALE mode + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + g_tracer=>CS%g_tracer_list + do + if (g_tracer_is_prog(g_tracer)) then + do k=1,nk ;do j=jsc,jec ; do i=isc,iec + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, g_tracer%field(:,:,:,1), dt, & + fluxes, h_work, evap_CFL_limit, minimum_forcing_depth) + 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 + endif + + ! + !Update Tr(n)%field from explicit vertical diffusion + ! + ! Use a tridiagonal solver to determine the concentrations after the + ! surface source is applied and diapycnal advection and diffusion occurs. + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + ! Last arg is tau which is always 1 for MOM6 + call generic_tracer_vertdiff_G(h_work, ea, eb, US%T_to_s*dt, GV%kg_m2_to_H, GV%m_to_H, 1) + else + ! Last arg is tau which is always 1 for MOM6 + call generic_tracer_vertdiff_G(h_old, ea, eb, US%T_to_s*dt, GV%kg_m2_to_H, GV%m_to_H, 1) + endif + + ! Update bottom fields after vertical processes + + ! Second arg is tau which is always 1 for MOM6 + call generic_tracer_update_from_bottom(US%T_to_s*dt, 1, get_diag_time_end(CS%diag)) + + !Output diagnostics via diag_manager for all generic tracers and their fluxes + call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) +#ifdef _USE_MOM6_DIAG + call g_tracer_set_csdiag(CS%diag) +#endif + + end subroutine MOM_generic_tracer_column_physics + + !> This subroutine calculates mass-weighted integral on the PE either + !! of all available tracer concentrations, or of a tracer that is + !! being requested specifically, returning the number of stocks it has + !! calculated. If the stock_index is present, only the stock corresponding + !! to that coded index is returned. + function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< The coded index of a specific stock + !! being sought. + integer :: MOM_generic_tracer_stock !< Return value, the + !! number of stocks calculated here. + + ! Local variables + type(g_tracer_type), pointer :: g_tracer, g_tracer_next + real, dimension(:,:,:,:), pointer :: tr_field ! A pointer to a generic tracer field, in concentration units [conc] + real, dimension(:,:,:), pointer :: tr_ptr ! A pointer to a generic tracer field, in concentration units [conc] + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_stock' + + integer :: m + + MOM_generic_tracer_stock = 0 + if (.not.associated(CS)) return + + if (present(stock_index)) then ; if (stock_index > 0) then + ! Check whether this stock is available from this routine. + + ! No stocks from this routine are being checked yet. Return 0. + return + endif ; endif + + if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. + + m=1 ; g_tracer=>CS%g_tracer_list + do + call g_tracer_get_alias(g_tracer,names(m)) + call g_tracer_get_values(g_tracer,names(m),'units',units(m)) + units(m) = trim(units(m))//" kg" + call g_tracer_get_pointer(g_tracer,names(m),'field',tr_field) + + tr_ptr => tr_field(:,:,:,1) + stocks(m) = global_mass_int_EFP(h, G, GV, tr_ptr, on_PE_only=.true.) + + !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 + m = m+1 + enddo + + MOM_generic_tracer_stock = m + + end function MOM_generic_tracer_stock + + !> This subroutine find the global min and max of either of all + !! available tracer concentrations, or of a tracer that is being + !! requested specifically, returning the number of tracers it has gone through. + function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, ygmin, zgmin, & + xgmax, ygmax, zgmax , G, CS, names, units) + integer, intent(in) :: ind_start !< The index of the tracer to start with + logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and + !! max are found for each tracer + real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer, in kg + !! times concentration units. + real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer, in kg + !! times concentration units. + real, dimension(:), intent(out) :: xgmin !< The x-position of the global minimum + real, dimension(:), intent(out) :: ygmin !< The y-position of the global minimum + real, dimension(:), intent(out) :: zgmin !< The z-position of the global minimum + real, dimension(:), intent(out) :: xgmax !< The x-position of the global maximum + real, dimension(:), intent(out) :: ygmax !< The y-position of the global maximum + real, dimension(:), intent(out) :: zgmax !< The z-position of the global maximum + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer :: MOM_generic_tracer_min_max !< Return value, the + !! number of tracers done here. + +! Local variables + type(g_tracer_type), pointer :: g_tracer, g_tracer_next + real, dimension(:,:,:,:), pointer :: tr_field + real, dimension(:,:,:), pointer :: tr_ptr + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_min_max' + + real, dimension(:,:,:),pointer :: grid_tmask + integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau + + integer :: k, is, ie, js, je, m + real, allocatable, dimension(:) :: geo_z + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + MOM_generic_tracer_min_max = 0 + if (.not.associated(CS)) return + + if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. + + + call g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,grid_tmask=grid_tmask) + + ! Because the use of a simple z-coordinate can not be assumed, simply + ! use the layer index as the vertical label. + allocate(geo_z(nk)) + do k=1,nk ; geo_z(k) = real(k) ; enddo + + m=ind_start ; g_tracer=>CS%g_tracer_list + do + call g_tracer_get_alias(g_tracer,names(m)) + call g_tracer_get_values(g_tracer,names(m),'units',units(m)) + units(m) = trim(units(m))//" kg" + call g_tracer_get_pointer(g_tracer,names(m),'field',tr_field) + + gmin(m) = -1.0 + gmax(m) = -1.0 + + tr_ptr => tr_field(:,:,:,1) + + call array_global_min_max(tr_ptr, grid_tmask, isd, jsd, isc, iec, jsc, jec, nk, gmin(m), gmax(m), & + G%geoLonT, G%geoLatT, geo_z, xgmin(m), ygmin(m), zgmin(m), & + xgmax(m), ygmax(m), zgmax(m)) + + got_minmax(m) = .true. + + !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 + m = m+1 + enddo + + MOM_generic_tracer_min_max = m + + end function MOM_generic_tracer_min_max + + !> Find the global maximum and minimum of a tracer array and return the locations of the extrema. + subroutine array_global_min_max(tr_array, tmask, isd, jsd, isc, iec, jsc, jec, nk, g_min, g_max, & + geo_x, geo_y, geo_z, xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) + integer, intent(in) :: isd !< The starting data domain i-index + integer, intent(in) :: jsd !< The starting data domain j-index + real, dimension(isd:,jsd:,:), intent(in) :: tr_array !< The tracer array to search for extrema + real, dimension(isd:,jsd:,:), intent(in) :: tmask !< A mask that is 0 for points to exclude + integer, intent(in) :: isc !< The starting compute domain i-index + integer, intent(in) :: iec !< The ending compute domain i-index + integer, intent(in) :: jsc !< The starting compute domain j-index + integer, intent(in) :: jec !< The ending compute domain j-index + integer, intent(in) :: nk !< The number of vertical levels + real, intent(out) :: g_min !< The global minimum of tr_array + real, intent(out) :: g_max !< The global maximum of tr_array + real, dimension(isd:,jsd:), intent(in) :: geo_x !< The geographic x-positions of points + real, dimension(isd:,jsd:), intent(in) :: geo_y !< The geographic y-positions of points + real, dimension(:), intent(in) :: geo_z !< The vertical pseudo-positions of points + real, intent(out) :: xgmin !< The x-position of the global minimum + real, intent(out) :: ygmin !< The y-position of the global minimum + real, intent(out) :: zgmin !< The z-position of the global minimum + real, intent(out) :: xgmax !< The x-position of the global maximum + real, intent(out) :: ygmax !< The y-position of the global maximum + real, intent(out) :: zgmax !< The z-position of the global maximum + + ! This subroutine is an exact transcription (bugs and all) of mpp_array_global_min_max() + ! from the version in FMS/mpp/mpp_utilities.F90, but with some whitespace changes to match + ! MOM6 code styles and to use infrastructure routines via the MOM6 framework code, and with + ! added comments to document its arguments.i + + !### The obvious problems with this routine as currently written include: + ! 1. It does not return exactly the maximum and minimum values. + ! 2. The reported maximum and minimum are dependent on PE count and layout. + ! 3. For all-zero arrays, the reported maxima scale with the PE_count + ! 4. For arrays with a large enough offset or scaling, so that the magnitude of values exceed + ! 1e10, the values it returns are simply wrong. + ! 5. The results do not scale appropriately if the argument is rescaled. + ! 6. The extrema and locations are not rotationally invariant. + ! 7. It is inefficient because it uses 8 blocking global reduction calls when it could use just 2 or 3. + + ! Local variables + real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array + real :: tmax0, tmin0 ! First-guest values of tmax and tmin. + integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin + real :: fudge ! A factor that is close to 1 that is used to find the location of the extrema [nondim]. + + ! arrays to enable vectorization + integer :: iminarr(3), imaxarr(3) + + !### These dimensional constant values mean that the results can not be guaranteed to be rescalable. + g_min = -88888888888.0 ; g_max = -999999999.0 + tmax = -1.e10 ; tmin = 1.e10 + itmax = 0 ; jtmax = 0 ; ktmax = 0 + itmin = 0 ; jtmin = 0 ; ktmin = 0 + + if (ANY(tmask(isc:iec,jsc:jec,:) > 0.)) then + ! Vectorized using maxloc() and minloc() intrinsic functions by Russell.Fiedler@csiro.au. + iminarr = minloc(tr_array(isc:iec,jsc:jec,:), (tmask(isc:iec,jsc:jec,:) > 0.)) + imaxarr = maxloc(tr_array(isc:iec,jsc:jec,:), (tmask(isc:iec,jsc:jec,:) > 0.)) + itmin = iminarr(1)+isc-1 + jtmin = iminarr(2)+jsc-1 + ktmin = iminarr(3) + itmax = imaxarr(1)+isc-1 + jtmax = imaxarr(2)+jsc-1 + ktmax = imaxarr(3) + tmin = tr_array(itmin,jtmin,ktmin) + tmax = tr_array(itmax,jtmax,ktmax) + end if + + ! use "fudge" to distinguish processors when tracer extreme is independent of processor + !### This fudge factor is not independent of PE layout, and while it mostly works for finding + ! a positive maximum or a negative minimum, it could miss the true extrema in the opposite + ! cases, for which the fudge factor should be slightly reduced. The fudge factor should + ! be based on global index-space conventions, which are decomposition invariant, and + ! not the PE-number! + fudge = 1.0 + 1.e-12*real(PE_here() ) + tmax = tmax*fudge + tmin = tmin*fudge + if (tmax == 0.0) then + tmax = tmax + 1.e-12*real(PE_here() ) + endif + if (tmin == 0.0) then + tmin = tmin + 1.e-12*real(PE_here() ) + endif + + tmax0 = tmax ; tmin0 = tmin + + call max_across_PEs(tmax) + call min_across_PEs(tmin) + + g_max = tmax + g_min = tmin + + ! Now find the location of the global extrema. + ! + ! Note that the fudge factor above guarantees that the location of max (min) is unique, + ! since tmax0 (tmin0) has slightly different values on each processor. + ! Otherwise, the function tr_array(i,j,k) could be equal to global max (min) at more + ! than one point in space and this would be a much more difficult problem to solve. + ! + !-999 on all current PE's + xgmax = -999. ; ygmax = -999. ; zgmax = -999. + xgmin = -999. ; ygmin = -999. ; zgmin = -999. + + if (tmax0 == tmax) then !This happens ONLY on ONE processor because of fudge factor above. + xgmax = geo_x(itmax,jtmax) + ygmax = geo_y(itmax,jtmax) + zgmax = geo_z(ktmax) + endif + + !### These three calls and the three calls that follow in about 10 lines should be combined + ! into a single call for efficiency. + call max_across_PEs(xgmax) + call max_across_PEs(ygmax) + call max_across_PEs(zgmax) + + if (tmin0 == tmin) then !This happens ONLY on ONE processor because of fudge factor above. + xgmin = geo_x(itmin,jtmin) + ygmin = geo_y(itmin,jtmin) + zgmin = geo_z(ktmin) + endif + + call max_across_PEs(xgmin) + call max_across_PEs(ygmin) + call max_across_PEs(zgmin) + + end subroutine array_global_min_max + + !> This subroutine calculates the surface state and sets coupler values for + !! those generic tracers that have flux exchange with atmosphere. + !! + !! This subroutine sets up the fields that the coupler needs to calculate the + !! CFC fluxes between the ocean and atmosphere. + subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + + ! Local variables + real :: sosga ! The global mean surface salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV),1) :: rho0 ! An unused array of densities [kg m-3] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dzt ! Layer vertical extents [m] + + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_surface_state' + + !Set coupler values + !nnz: fake rho0 + rho0(:,:,:,:) = 1.0 + + dzt(:,:,:) = GV%H_to_m * h(:,:,:) + + sosga = global_area_mean(sfc_state%SSS, G, scale=G%US%S_to_ppt) + + if ((G%US%C_to_degC == 1.0) .and. (G%US%S_to_ppt == 1.0)) then + call generic_tracer_coupler_set(sfc_state%tr_fields, & + ST=sfc_state%SST, SS=sfc_state%SSS, & + rho=rho0, & !nnz: required for MOM5 and previous versions. + ilb=G%isd, jlb=G%jsd, & + dzt=dzt,& !This is needed for the Mocsy method of carbonate system vars + tau=1, sosga=sosga, model_time=get_diag_time_end(CS%diag)) + else + call generic_tracer_coupler_set(sfc_state%tr_fields, & + ST=G%US%C_to_degC*sfc_state%SST, SS=G%US%S_to_ppt*sfc_state%SSS, & + rho=rho0, & !nnz: required for MOM5 and previous versions. + ilb=G%isd, jlb=G%jsd, & + dzt=dzt,& !This is needed for the Mocsy method of carbonate system vars + tau=1, sosga=sosga, model_time=get_diag_time_end(CS%diag)) + endif + + !Output diagnostics via diag_manager for all tracers in this module +! if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& +! "No tracer in the list.") +! call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) + !Niki: The problem with calling diagnostic outputs here is that this subroutine is called every dt_cpld + ! hence if dt_therm > dt_cpld we get output (and contribution to the mean) at times that tracers + ! had not been updated. + ! Moving this to the end of column physics subroutine fixes this issue. + + end subroutine MOM_generic_tracer_surface_state + +!ALL PE subroutine on Ocean! Due to otpm design the fluxes should be initialized like this on ALL PE's! + subroutine MOM_generic_flux_init(verbosity) + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + + character(len=128), parameter :: sub_name = 'MOM_generic_flux_init' + type(g_tracer_type), pointer :: g_tracer_list,g_tracer,g_tracer_next + + if (.not. g_registered) then + call generic_tracer_register() + g_registered = .true. + endif + + call generic_tracer_get_list(g_tracer_list) + if (.NOT. associated(g_tracer_list)) then + call MOM_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") + return + endif + + g_tracer=>g_tracer_list + do + + call g_tracer_flux_init(g_tracer) !, verbosity=verbosity) !### Add this after ocean shared is updated. + + ! 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 + + end subroutine MOM_generic_flux_init + + subroutine MOM_generic_tracer_fluxes_accumulate(flux_tmp, weight) + type(forcing), intent(in) :: flux_tmp !< A structure containing pointers to + !! thermodynamic and tracer forcing fields. + real, intent(in) :: weight !< A weight for accumulating this flux [nondim] + + call generic_tracer_coupler_accumulate(flux_tmp%tr_fluxes, weight) + + end subroutine MOM_generic_tracer_fluxes_accumulate + + !> Copy the requested tracer into an array. + subroutine MOM_generic_tracer_get(name,member,array, CS) + character(len=*), intent(in) :: name !< Name of requested tracer. + character(len=*), intent(in) :: member !< The tracer element to return. + real, dimension(:,:,:), intent(out) :: array !< Array filled by this routine, in arbitrary units [A] + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + + ! Local variables + real, dimension(:,:,:), pointer :: array_ptr ! The tracer in the generic tracer structures, in + ! arbitrary units [A] + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_get' + + call g_tracer_get_pointer(CS%g_tracer_list,name,member,array_ptr) + array(:,:,:) = array_ptr(:,:,:) + + end subroutine MOM_generic_tracer_get + + !> This subroutine deallocates the memory owned by this module. + subroutine end_MOM_generic_tracer(CS) + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + + call generic_tracer_end() + + if (associated(CS)) then + deallocate(CS) + endif + end subroutine end_MOM_generic_tracer + +!---------------------------------------------------------------- +! Niki Zadeh +! +! +! William Cooke +! +! +! +! This module drives the generic version of tracers TOPAZ and CFC +! +!---------------------------------------------------------------- + +end module MOM_generic_tracer diff --git a/tracer/MOM_hor_bnd_diffusion.F90 b/tracer/MOM_hor_bnd_diffusion.F90 new file mode 100644 index 0000000000..163d8a480f --- /dev/null +++ b/tracer/MOM_hor_bnd_diffusion.F90 @@ -0,0 +1,1230 @@ +!> Calculates and applies diffusive fluxes as a parameterization of horizontal mixing (non-neutral) by +!! mesoscale eddies near the top and bottom (to be implemented) boundary layers of the ocean. + +module MOM_hor_bnd_diffusion + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE +use MOM_checksums, only : hchksum +use MOM_domains, only : pass_var +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_remapping, only : remapping_CS, initialize_remapping, reintegrate_column +use MOM_remapping, only : extract_member_remapping_CS, remapping_core_h +use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme +use MOM_spatial_means, only : global_mass_integral +use MOM_tracer_registry, only : tracer_registry_type, tracer_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS +use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member +use MOM_io, only : stdout, stderr + +implicit none ; private + +public near_boundary_unit_tests, hor_bnd_diffusion, hor_bnd_diffusion_init +public boundary_k_range, hor_bnd_diffusion_end + +! Private parameters to avoid doing string comparisons for bottom or top boundary layer +integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface boundary +integer, public, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary +#include + +!> Sets parameters for horizontal boundary mixing module. +type, public :: hbd_CS ; private + logical :: debug !< If true, write verbose checksums for debugging. + integer :: deg !< Degree of polynomial reconstruction. + integer :: hbd_nk !< Maximum number of levels in the HBD grid [nondim] + integer :: surface_boundary_scheme !< Which boundary layer scheme to use + !! 1. ePBL; 2. KPP + logical :: limiter !< Controls whether a flux limiter is applied in the + !! native grid (default is true). + logical :: limiter_remap !< Controls whether a flux limiter is applied in the + !! remapped grid (default is false). + logical :: linear !< If True, apply a linear transition at the base/top of the boundary. + !! The flux will be fully applied at k=k_min and zero at k=k_max. + real :: H_subroundoff !< A thickness that is so small that it can be added to a thickness of + !! Angstrom or larger without changing it at the bit level [H ~> m or kg m-2]. + !! If Angstrom is 0 or exceedingly small, this is negligible compared to 1e-17 m. + ! HBD dynamic grids + real, allocatable, dimension(:,:,:) :: hbd_grd_u !< HBD thicknesses at t-points adjacent to + !! u-points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: hbd_grd_v !< HBD thicknesses at t-points adjacent to + !! v-points (left and right) [H ~> m or kg m-2] + integer, allocatable, dimension(:,:) :: hbd_u_kmax !< Maximum vertical index in hbd_grd_u [nondim] + integer, allocatable, dimension(:,:) :: hbd_v_kmax !< Maximum vertical index in hbd_grd_v [nondim] + type(remapping_CS) :: remap_CS !< Control structure to hold remapping configuration. + type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD. + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get BLD. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. +end type hbd_CS + +! This include declares and sets the variable "version". +#include "version_variable.h" +character(len=40) :: mdl = "MOM_hor_bnd_diffusion" !< Name of this module +integer :: id_clock_hbd !< CPU clock for hbd + +contains + +!> Initialization routine that reads runtime parameters and sets up pointers to other control structures that might be +!! needed for horizontal boundary diffusion. +logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diabatic_CSp, CS) + type(time_type), target, intent(in) :: Time !< Time structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(diabatic_CS), pointer :: diabatic_CSp !< KPP control structure needed to get BLD + type(hbd_CS), pointer :: CS !< Horizontal boundary mixing control structure + + ! local variables + character(len=80) :: string ! Temporary strings + logical :: boundary_extrap ! controls if boundary extrapolation is used in the HBD code + logical :: debug !< If true, write verbose checksums for debugging purposes + + if (ASSOCIATED(CS)) then + call MOM_error(FATAL, "hor_bnd_diffusion_init called with associated control structure.") + return + endif + + ! Log this module and master switch for turning it on/off + call get_param(param_file, mdl, "USE_HORIZONTAL_BOUNDARY_DIFFUSION", hor_bnd_diffusion_init, & + default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, & + "This module implements horizontal diffusion of tracers near boundaries", & + all_default=.not.hor_bnd_diffusion_init) + call get_param(param_file, mdl, "USE_HORIZONTAL_BOUNDARY_DIFFUSION", hor_bnd_diffusion_init, & + "If true, enables the horizonal boundary tracer's diffusion module.", & + default=.false.) + if (.not. hor_bnd_diffusion_init) return + + allocate(CS) + CS%diag => diag + CS%H_subroundoff = GV%H_subroundoff + call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) + call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) + + ! max. number of vertical layers + CS%hbd_nk = 2 + (GV%ke*2) + ! allocate the hbd grids and k_max + allocate(CS%hbd_grd_u(SZIB_(G),SZJ_(G),CS%hbd_nk), source=0.0) + allocate(CS%hbd_grd_v(SZI_(G),SZJB_(G),CS%hbd_nk), source=0.0) + allocate(CS%hbd_u_kmax(SZIB_(G),SZJ_(G)), source=0) + allocate(CS%hbd_v_kmax(SZI_(G),SZJB_(G)), source=0) + + CS%surface_boundary_scheme = -1 + if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then + call MOM_error(FATAL,"Horizontal boundary diffusion is true, but no valid boundary layer scheme was found") + endif + + ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mdl, "HBD_LINEAR_TRANSITION", CS%linear, & + "If True, apply a linear transition at the base/top of the boundary. \n"//& + "The flux will be fully applied at k=k_min and zero at k=k_max.", default=.false.) + call get_param(param_file, mdl, "APPLY_LIMITER", CS%limiter, & + "If True, apply a flux limiter in the native grid.", default=.true.) + call get_param(param_file, mdl, "APPLY_LIMITER_REMAP", CS%limiter_remap, & + "If True, apply a flux limiter in the remapped grid.", default=.false.) + call get_param(param_file, mdl, "HBD_BOUNDARY_EXTRAP", boundary_extrap, & + "Use boundary extrapolation in HBD code", & + default=.false.) + call get_param(param_file, mdl, "HBD_REMAPPING_SCHEME", string, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: "//& + trim(remappingSchemesDoc), default=remappingDefaultScheme) + + ! GMM, TODO: add HBD params to control optional arguments in initialize_remapping. + call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& + check_reconstruction=.false., check_remapping=.false.) + call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) + call get_param(param_file, mdl, "DEBUG", debug, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "HBD_DEBUG", CS%debug, & + "If true, write out verbose debugging data in the HBD module.", & + default=debug) + + id_clock_hbd = cpu_clock_id('(Ocean HBD)', grain=CLOCK_MODULE) + +end function hor_bnd_diffusion_init + +!> Driver routine for calculating horizontal diffusive fluxes near the top and bottom boundaries. +!! Diffusion is applied using only information from neighboring cells, as follows: +!! 1) remap tracer to a z* grid (HBD grid) +!! 2) calculate diffusive tracer fluxes (F) in the HBD grid using a layer by layer approach +!! 3) remap fluxes to the native grid +!! 4) update tracer by adding the divergence of F +subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) + type(ocean_grid_type), intent(inout) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] + real, intent(in) :: dt !< Tracer time step * I_numitts + !! (I_numitts in tracer_hordiff) [T ~> s] + type(tracer_registry_type), pointer :: Reg !< Tracer registry + type(hbd_CS), pointer :: CS !< Control structure for this module + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< Boundary layer depth [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uFlx !< Zonal flux of tracer [conc H L2 ~> conc m3 or conc kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vFlx !< Meridional flux of tracer + !! [conc H L2 ~> conc m3 or conc kg] + real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport + !! [conc H L2 ~> conc m3 or conc kg] + real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport + !! [conc H L2 ~> conc m3 or conc kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diagnostics at first in + !! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1], + !! then converted to [conc T-1 ~> conc s-1]. + ! For temperature these units are + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] and + ! then [C T-1 ~> degC s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d !< depth integrated content tendency for diagnostics in + !! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1]. + !! For temperature these units are + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + type(tracer_type), pointer :: tracer => NULL() !< Pointer to the current tracer [conc] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tracer_old !< local copy of the initial tracer concentration, + !! only used to compute tendencies [conc]. + real :: tracer_int_prev !< Globally integrated tracer before HBD is applied, in mks units [conc kg] + real :: tracer_int_end !< Integrated tracer after HBD is applied, in mks units [conc kg] + real :: Idt !< inverse of the time step [T-1 ~> s-1] + character(len=256) :: mesg !< Message for error messages. + integer :: i, j, k, m !< indices to loop over + + call cpu_clock_begin(id_clock_hbd) + Idt = 1./dt + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, & + m_to_MLD_units=GV%m_to_H) + call pass_var(hbl,G%Domain) + + ! build HBD grid + call hbd_grid(SURFACE, G, GV, hbl, h, CS) + + do m = 1,Reg%ntr + ! current tracer + tracer => Reg%tr(m) + + if (CS%debug) then + call hchksum(tracer%t, "before HBD "//tracer%name,G%HI) + endif + + ! for diagnostics + if (tracer%id_hbdxy_conc > 0 .or. tracer%id_hbdxy_cont > 0 .or. tracer%id_hbdxy_cont_2d > 0 .or. CS%debug) then + tendency(:,:,:) = 0.0 + tracer_old(:,:,:) = tracer%t(:,:,:) + endif + + ! Diffusive fluxes in the i- and j-direction + uFlx(:,:,:) = 0. + vFlx(:,:,:) = 0. + + ! HBD layer by layer + do j=G%jsc,G%jec + do i=G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call fluxes_layer_method(SURFACE, GV%ke, hbl(I,j), hbl(I+1,j), & + h(I,j,:), h(I+1,j,:), tracer%t(I,j,:), tracer%t(I+1,j,:), & + Coef_x(I,j,:), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS%hbd_u_kmax(I,j), & + CS%hbd_grd_u(I,j,:), CS) + endif + enddo + enddo + do J=G%jsc-1,G%jec + do i=G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call fluxes_layer_method(SURFACE, GV%ke, hbl(i,J), hbl(i,J+1), & + h(i,J,:), h(i,J+1,:), tracer%t(i,J,:), tracer%t(i,J+1,:), & + Coef_y(i,J,:), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS%hbd_v_kmax(i,J), & + CS%hbd_grd_v(i,J,:), CS) + endif + enddo + enddo + + ! Update the tracer fluxes + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J-1,k)-vFlx(i,J,k) ) ))* & + G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) + + if (tracer%id_hbdxy_conc > 0 .or. tracer%id_hbdxy_cont > 0 .or. tracer%id_hbdxy_cont_2d > 0 ) then + tendency(i,j,k) = ((uFlx(I-1,j,k)-uFlx(I,j,k)) + (vFlx(i,J-1,k)-vFlx(i,J,k))) * & + G%IareaT(i,j) * Idt + endif + endif + enddo ; enddo ; enddo + + ! Do user controlled underflow of the tracer concentrations. + if (tracer%conc_underflow > 0.0) then + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(tracer%t, "after HBD "//tracer%name,G%HI) + ! tracer (native grid) integrated tracer amounts before and after HBD + tracer_int_prev = global_mass_integral(h, G, GV, tracer_old) + tracer_int_end = global_mass_integral(h, G, GV, tracer%t) + write(mesg,*) 'Total '//tracer%name//' before/after HBD:', tracer_int_prev, tracer_int_end + call MOM_mesg(mesg) + endif + + ! Post the tracer diagnostics + if (tracer%id_hbd_dfx>0) call post_data(tracer%id_hbd_dfx, uFlx(:,:,:)*Idt, CS%diag) + if (tracer%id_hbd_dfy>0) call post_data(tracer%id_hbd_dfy, vFlx(:,:,:)*Idt, CS%diag) + if (tracer%id_hbd_dfx_2d>0) then + uwork_2d(:,:) = 0. + do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec + uwork_2d(I,j) = uwork_2d(I,j) + (uFlx(I,j,k) * Idt) + enddo ; enddo ; enddo + call post_data(tracer%id_hbd_dfx_2d, uwork_2d, CS%diag) + endif + + if (tracer%id_hbd_dfy_2d>0) then + vwork_2d(:,:) = 0. + do k=1,GV%ke ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + vwork_2d(i,J) = vwork_2d(i,J) + (vFlx(i,J,k) * Idt) + enddo ; enddo ; enddo + call post_data(tracer%id_hbd_dfy_2d, vwork_2d, CS%diag) + endif + + ! post tendency of tracer content + if (tracer%id_hbdxy_cont > 0) then + call post_data(tracer%id_hbdxy_cont, tendency, CS%diag) + endif + + ! post depth summed tendency for tracer content + if (tracer%id_hbdxy_cont_2d > 0) then + tendency_2d(:,:) = 0. + do j=G%jsc,G%jec ; do i=G%isc,G%iec + do k=1,GV%ke + tendency_2d(i,j) = tendency_2d(i,j) + tendency(i,j,k) + enddo + enddo ; enddo + call post_data(tracer%id_hbdxy_cont_2d, tendency_2d, CS%diag) + endif + + ! post tendency of tracer concentration; this step must be + ! done after posting tracer content tendency, since we alter + ! the tendency array and its units. + if (tracer%id_hbdxy_conc > 0) then + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + tendency(i,j,k) = tendency(i,j,k) / ( h(i,j,k) + CS%H_subroundoff ) + enddo ; enddo ; enddo + call post_data(tracer%id_hbdxy_conc, tendency, CS%diag) + endif + + enddo + + call cpu_clock_end(id_clock_hbd) + +end subroutine hor_bnd_diffusion + +!> Build the HBD grid where tracers will be remapped to. +subroutine hbd_grid(boundary, G, GV, hbl, h, CS) + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + type(ocean_grid_type), intent(inout) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< Boundary layer depth [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness in the native grid [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure + + ! Local variables + real, allocatable :: dz_top(:) !< temporary HBD grid given by merge_interfaces [H ~> m or kg m-2] + integer :: nk, i, j, k !< number of layers in the HBD grid, and integers used in do-loops + + ! reset arrays + CS%hbd_grd_u(:,:,:) = 0.0 + CS%hbd_grd_v(:,:,:) = 0.0 + CS%hbd_u_kmax(:,:) = 0 + CS%hbd_v_kmax(:,:) = 0 + + do j=G%jsc,G%jec + do I=G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call merge_interfaces(GV%ke, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + CS%H_subroundoff, dz_top) + nk = SIZE(dz_top) + if (nk > CS%hbd_nk) then + write(*,*)'nk, CS%hbd_nk', nk, CS%hbd_nk + call MOM_error(FATAL,"Houston, we've had a problem in hbd_grid, u-points (nk cannot be > CS%hbd_nk)") + endif + + CS%hbd_u_kmax(I,j) = nk + + ! set the HBD grid to dz_top + do k=1,nk + CS%hbd_grd_u(I,j,k) = dz_top(k) + enddo + deallocate(dz_top) + endif + enddo + enddo + + do J=G%jsc-1,G%jec + do i=G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call merge_interfaces(GV%ke, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + CS%H_subroundoff, dz_top) + + nk = SIZE(dz_top) + if (nk > CS%hbd_nk) then + write(*,*)'nk, CS%hbd_nk', nk, CS%hbd_nk + call MOM_error(FATAL,"Houston, we've had a problem in hbd_grid, v-points (nk cannot be > CS%hbd_nk)") + endif + + CS%hbd_v_kmax(i,J) = nk + + ! set the HBD grid to dz_top + do k=1,nk + CS%hbd_grd_v(i,J,k) = dz_top(k) + enddo + deallocate(dz_top) + endif + enddo + enddo + +end subroutine hbd_grid + +!> Calculate the harmonic mean of two quantities +!! See \ref section_harmonic_mean. +real function harmonic_mean(h1,h2) + real :: h1 !< Scalar quantity [arbitrary] + real :: h2 !< Scalar quantity [arbitrary] + if (h1 + h2 == 0.) then + harmonic_mean = 0. + else + harmonic_mean = 2.*(h1*h2)/(h1+h2) + endif +end function harmonic_mean + +!> Returns the location of the minimum value in a 1D array +!! between indices s and e. +integer function find_minimum(x, s, e) + integer, intent(in) :: s !< start index + integer, intent(in) :: e !< end index + real, dimension(e), intent(in) :: x !< 1D array to be checked [arbitrary] + + ! local variables + real :: minimum ! Minimum value in the same units as x [arbitrary] + integer :: location + integer :: i + + minimum = x(s) ! assume the first is the min + location = s ! record its position + do i = s+1, e ! start with next elements + if (x(i) < minimum) then ! if x(i) less than the min? + minimum = x(i) ! Yes, a new minimum found + location = i ! record its position + end if + enddo + find_minimum = location ! return the position +end function find_minimum + +!> Swaps the values of its two formal arguments. +subroutine swap(a, b) + real, intent(inout) :: a !< First value to be swapped [arbitrary] + real, intent(inout) :: b !< Second value to be swapped [arbitrary] + + ! local variables + real :: tmp ! A temporary copy of a [arbitrary] + + tmp = a + a = b + b = tmp +end subroutine swap + +!> Receives a 1D array x and sorts it into ascending order. +subroutine sort(x, n) + integer, intent(in ) :: n !< Number of points in the array + real, dimension(n), intent(inout) :: x !< 1D array to be sorted [arbitrary] + + ! local variables + integer :: i, location + + do i = 1, n-1 + location = find_minimum(x, i, n) ! find min from this to last + call swap(x(i), x(location)) ! swap this and the minimum + enddo +end subroutine sort + +!> Returns the unique values in a 1D array. +subroutine unique(val, n, val_unique, val_max) + integer, intent(in ) :: n !< Number of points in the array. + real, dimension(n), intent(in ) :: val !< 1D array to be checked [arbitrary] + real, dimension(:), allocatable, intent(inout) :: val_unique !< Returned 1D array with unique values [arbitrary] + real, optional, intent(in ) :: val_max !< sets the maximum value in val_unique to + !! this value [arbitrary] + ! local variables + real, dimension(n) :: tmp ! The list of unique values [arbitrary] + integer :: i, j, ii + real :: min_val, max_val ! The minimum and maximum values in the list [arbitrary] + logical :: limit + + limit = .false. + if (present(val_max)) then + limit = .true. + if (val_max > MAXVAL(val)) then + if (is_root_pe()) write(*,*)'val_max, MAXVAL(val)',val_max, MAXVAL(val) + call MOM_error(FATAL,"Houston, we've had a problem in unique (val_max cannot be > MAXVAL(val))") + endif + endif + + tmp(:) = 0. + min_val = MINVAL(val)-1 + max_val = MAXVAL(val) + i = 0 + do while (min_valmin_val) + tmp(i) = min_val + enddo + ii = i + if (limit) then + do j=1,ii + if (tmp(j) <= val_max) i = j + enddo + endif + allocate(val_unique(i), source=tmp(1:i)) +end subroutine unique + + +!> Given layer thicknesses (and corresponding interfaces) and BLDs in two adjacent columns, +!! return a set of 1-d layer thicknesses whose interfaces cover all interfaces in the left +!! and right columns plus the two BLDs. This can be used to accurately remap tracer tendencies +!! in both columns. +subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) + integer, intent(in ) :: nk !< Number of layers [nondim] + real, dimension(nk), intent(in ) :: h_L !< Layer thicknesses in the left column [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_R !< Layer thicknesses in the right column [H ~> m or kg m-2] + real, intent(in ) :: hbl_L !< Thickness of the boundary layer in the left column + !! [H ~> m or kg m-2] + real, intent(in ) :: hbl_R !< Thickness of the boundary layer in the right column + !! [H ~> m or kg m-2] + real, intent(in ) :: H_subroundoff !< GV%H_subroundoff [H ~> m or kg m-2] + real, dimension(:), allocatable, intent(inout) :: h !< Combined thicknesses [H ~> m or kg m-2] + + ! Local variables + integer :: n !< Number of layers in eta_all + real, dimension(nk+1) :: eta_L, eta_R!< Interfaces in the left and right columns [H ~> m or kg m-2] + real, dimension(:), allocatable :: eta_all !< Combined list of interfaces in the left and right columns + !! plus hbl_L and hbl_R [H ~> m or kg m-2] + real, dimension(:), allocatable :: eta_unique !< Combined list of unique interfaces (eta_L, eta_R), possibly + !! hbl_L and hbl_R [H ~> m or kg m-2] + real :: min_depth !< Minimum depth [H ~> m or kg m-2] + real :: max_depth !< Maximum depth [H ~> m or kg m-2] + real :: max_bld !< Deepest BLD [H ~> m or kg m-2] + integer :: k, kk, nk1 !< loop indices (k and kk) and array size (nk1) + + n = (2*nk)+3 + allocate(eta_all(n)) + ! compute and merge interfaces + eta_L(:) = 0.0; eta_R(:) = 0.0; eta_all(:) = 0.0 + kk = 0 + do k=2,nk+1 + eta_L(k) = eta_L(k-1) + h_L(k-1) + eta_R(k) = eta_R(k-1) + h_R(k-1) + kk = kk + 2 + eta_all(kk) = eta_L(k) + eta_all(kk+1) = eta_R(k) + enddo + + ! add hbl_L and hbl_R into eta_all + eta_all(kk+2) = hbl_L + eta_all(kk+3) = hbl_R + + ! find maximum depth + min_depth = MIN(MAXVAL(eta_L), MAXVAL(eta_R)) + max_bld = MAX(hbl_L, hbl_R) + max_depth = MIN(min_depth, max_bld) + + ! sort eta_all + call sort(eta_all, n) + ! remove duplicates from eta_all and sets maximum depth + call unique(eta_all, n, eta_unique, max_depth) + + nk1 = SIZE(eta_unique) + allocate(h(nk1-1)) + do k=1,nk1-1 + h(k) = (eta_unique(k+1) - eta_unique(k)) + H_subroundoff + enddo +end subroutine merge_interfaces + +!> Calculates the maximum flux that can leave a cell and uses that to apply a +!! limiter to F_layer. +subroutine flux_limiter(F_layer, area_L, area_R, phi_L, phi_R, h_L, h_R) + real, intent(inout) :: F_layer !< Tracer flux to be checked [H L2 conc ~> m3 conc] + real, intent(in) :: area_L !< Area of left cell [L2 ~> m2] + real, intent(in) :: area_R !< Area of right cell [L2 ~> m2] + real, intent(in) :: h_L !< Thickness of left cell [H ~> m or kg m-2] + real, intent(in) :: h_R !< Thickness of right cell [H ~> m or kg m-2] + real, intent(in) :: phi_L !< Tracer concentration in the left cell [conc] + real, intent(in) :: phi_R !< Tracer concentration in the right cell [conc] + + ! local variables + real :: F_max !< maximum flux allowed [conc H L2 ~> conc m3 or conc kg] + ! limit the flux to 0.2 of the tracer *gradient* + ! Why 0.2? + ! t=0 t=inf + ! 0 .2 + ! 0 1 0 .2.2.2 + ! 0 .2 + ! + F_max = -0.2 * ((area_R*(phi_R*h_R))-(area_L*(phi_L*h_L))) + + if ( SIGN(1.,F_layer) == SIGN(1., F_max)) then + ! Apply flux limiter calculated above + if (F_max >= 0.) then + F_layer = MIN(F_layer,F_max) + else + F_layer = MAX(F_layer,F_max) + endif + else + F_layer = 0.0 + endif +end subroutine flux_limiter + +!> Find the k-index range corresponding to the layers that are within the boundary-layer region +subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_bot) + integer, intent(in ) :: boundary !< SURFACE or BOTTOM [nondim] + integer, intent(in ) :: nk !< Number of layers [nondim] + real, dimension(nk), intent(in ) :: h !< Layer thicknesses of the column [H ~> m or kg m-2] + real, intent(in ) :: hbl !< Thickness of the boundary layer [H ~> m or kg m-2] + !! If surface, with respect to zbl_ref = 0. + !! If bottom, with respect to zbl_ref = SUM(h) + integer, intent( out) :: k_top !< Index of the first layer within the boundary + real, intent( out) :: zeta_top !< Distance from the top of a layer to the intersection of the + !! top extent of the boundary layer (0 at top, 1 at bottom) [nondim] + integer, intent( out) :: k_bot !< Index of the last layer within the boundary + real, intent( out) :: zeta_bot !< Distance of the lower layer to the boundary layer depth + !! (0 at top, 1 at bottom) [nondim] + ! Local variables + real :: htot ! Summed thickness [H ~> m or kg m-2] + integer :: k + + ! Surface boundary layer + if ( boundary == SURFACE ) then + k_top = 1 + zeta_top = 0. + htot = 0. + k_bot = 1 + zeta_bot = 0. + if (hbl == 0.) return + if (hbl >= SUM(h(:))) then + k_bot = nk + zeta_bot = 1. + return + endif + do k=1,nk + htot = htot + h(k) + if ( htot >= hbl) then + k_bot = k + zeta_bot = 1 - (htot - hbl)/h(k) + return + endif + enddo + + ! Bottom boundary layer + elseif ( boundary == BOTTOM ) then + k_top = nk + zeta_top = 1. + k_bot = nk + zeta_bot = 0. + htot = 0. + if (hbl == 0.) return + if (hbl >= SUM(h(:))) then + k_top = 1 + zeta_top = 1. + return + endif + do k=nk,1,-1 + htot = htot + h(k) + if (htot >= hbl) then + k_top = k + zeta_top = 1 - (htot - hbl)/h(k) + return + endif + enddo + else + call MOM_error(FATAL,"Houston, we've had a problem in boundary_k_range") + endif + +end subroutine boundary_k_range + +!> Calculate the horizontal boundary diffusive fluxes using the layer by layer method. +!! See \ref section_method +subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, area_L, area_R, nk, dz_top, CS) + + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + integer, intent(in ) :: ke !< Number of layers in the native grid [nondim] + real, intent(in ) :: hbl_L !< Thickness of the boundary boundary + !! layer (left) [H ~> m or kg m-2] + real, intent(in ) :: hbl_R !< Thickness of the boundary boundary + !! layer (right) [H ~> m or kg m-2] + real, dimension(ke), intent(in ) :: h_L !< Thicknesses in the native grid (left) [H ~> m or kg m-2] + real, dimension(ke), intent(in ) :: h_R !< Thicknesses in the native grid (right) [H ~> m or kg m-2] + real, dimension(ke), intent(in ) :: phi_L !< Tracer values in the native grid (left) [conc] + real, dimension(ke), intent(in ) :: phi_R !< Tracer values in the native grid (right) [conc] + real, dimension(ke+1),intent(in ) :: khtr_u !< Horizontal diffusivities times the time step + !! at a velocity point and vertical interfaces [L2 ~> m2] + real, dimension(ke), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point + !! in the native grid [H L2 conc ~> m3 conc] + real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] + real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] + integer, intent(in ) :: nk !< Number of layers in the HBD grid [nondim] + real, dimension(nk), intent(in ) :: dz_top !< The HBD z grid [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure + + ! Local variables + real, allocatable :: phi_L_z(:) !< Tracer values in the ztop grid (left) [conc] + real, allocatable :: phi_R_z(:) !< Tracer values in the ztop grid (right) [conc] + real, allocatable :: F_layer_z(:) !< Diffusive flux at U/V-point in the ztop grid [H L2 conc ~> m3 conc] + real, allocatable :: khtr_ul_z(:) !< khtr_u at layer centers in the ztop grid [H L2 conc ~> m3 conc] + real, dimension(ke) :: h_vel !< Thicknesses at u- and v-points in the native grid + !! The harmonic mean is used to avoid zero values [H ~> m or kg m-2] + real, dimension(ke) :: khtr_ul !< khtr_u at the vertical layer of the native grid [L2 ~> m2] + real :: htot !< Total column thickness [H ~> m or kg m-2] + integer :: k !< Index used in the vertical direction + integer :: k_bot_min !< Minimum k-index for the bottom + integer :: k_bot_max !< Maximum k-index for the bottom + integer :: k_bot_diff !< Difference between bottom left and right k-indices + integer :: k_top_L, k_bot_L !< k-indices left native grid + integer :: k_top_R, k_bot_R !< k-indices right native grid + real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary + !! layer depth in the native grid [nondim] + real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary + !! layer depth in the native grid [nondim] + real :: wgt !< weight to be used in the linear transition to the interior [nondim] + real :: a !< coefficient used in the linear transition to the interior [nondim] + real :: tmp1, tmp2 !< dummy variables [H ~> m or kg m-2] + real :: htot_max !< depth below which no fluxes should be applied [H ~> m or kg m-2] + + F_layer(:) = 0.0 + khtr_ul(:) = 0.0 + if (hbl_L == 0. .or. hbl_R == 0.) then + return + endif + + ! allocate arrays + allocate(phi_L_z(nk), source=0.0) + allocate(phi_R_z(nk), source=0.0) + allocate(F_layer_z(nk), source=0.0) + allocate(khtr_ul_z(nk), source=0.0) + + ! remap tracer to dz_top + call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:), & + CS%H_subroundoff, CS%H_subroundoff) + call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:), & + CS%H_subroundoff, CS%H_subroundoff) + + ! thicknesses at velocity points & khtr_u at layer centers + do k = 1,ke + h_vel(k) = harmonic_mean(h_L(k), h_R(k)) + ! GMM, writing 0.5 * (A(k) + A(k+1)) as A(k) + 0.5 * (A(k+1) - A(k)) to recover + ! answers with depth-independent khtr + khtr_ul(k) = khtr_u(k) + 0.5 * (khtr_u(k+1) - khtr_u(k)) + enddo + + ! remap khtr_ul to khtr_ul_z + call remapping_core_h(CS%remap_cs, ke, h_vel(:), khtr_ul(:), nk, dz_top(:), khtr_ul_z(:), & + CS%H_subroundoff, CS%H_subroundoff) + + ! Calculate vertical indices containing the boundary layer in dz_top + call boundary_k_range(boundary, nk, dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) + call boundary_k_range(boundary, nk, dz_top, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) + + if (boundary == SURFACE) then + k_bot_min = MIN(k_bot_L, k_bot_R) + k_bot_max = MAX(k_bot_L, k_bot_R) + k_bot_diff = (k_bot_max - k_bot_min) + + ! tracer flux where the minimum BLD intersects layer + if ((CS%linear) .and. (k_bot_diff > 1)) then + ! apply linear decay at the base of hbl + do k = k_bot_min,1,-1 + F_layer_z(k) = -(dz_top(k) * khtr_ul_z(k)) * (phi_R_z(k) - phi_L_z(k)) + if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & + phi_R_z(k), dz_top(k), dz_top(k)) + enddo + htot = 0.0 + do k = k_bot_min+1,k_bot_max, 1 + htot = htot + dz_top(k) + enddo + + a = -1.0/htot + htot = 0. + do k = k_bot_min+1,k_bot_max, 1 + wgt = (a*(htot + (dz_top(k) * 0.5))) + 1.0 + F_layer_z(k) = -(dz_top(k) * khtr_ul_z(k)) * (phi_R_z(k) - phi_L_z(k)) * wgt + htot = htot + dz_top(k) + if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & + phi_R_z(k), dz_top(k), dz_top(k)) + enddo + else + do k = k_bot_min,1,-1 + F_layer_z(k) = -(dz_top(k) * khtr_ul_z(k)) * (phi_R_z(k) - phi_L_z(k)) + if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & + phi_R_z(k), dz_top(k), dz_top(k)) + enddo + endif + endif + + !GMM, TODO: boundary == BOTTOM + + ! remap flux to h_vel (native grid) + call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), F_layer(:)) + + ! used to avoid fluxes below hbl + if (CS%linear) then + htot_max = MAX(hbl_L, hbl_R) + else + htot_max = MIN(hbl_L, hbl_R) + endif + + tmp1 = 0.0; tmp2 = 0.0 + do k = 1,ke + ! apply flux_limiter + if (CS%limiter .and. F_layer(k) /= 0.) then + call flux_limiter(F_layer(k), area_L, area_R, phi_L(k), phi_R(k), h_L(k), h_R(k)) + endif + + ! if tracer point is below htot_max, set flux to zero + if (MAX(tmp1+(h_L(k)*0.5), tmp2+(h_R(k)*0.5)) > htot_max) then + F_layer(k) = 0. + endif + + tmp1 = tmp1 + h_L(k) + tmp2 = tmp2 + h_R(k) + enddo + + ! deallocated arrays + deallocate(phi_L_z) + deallocate(phi_R_z) + deallocate(F_layer_z) + deallocate(khtr_ul_z) + +end subroutine fluxes_layer_method + +!> Unit tests for near-boundary horizontal mixing +logical function near_boundary_unit_tests( verbose ) + logical, intent(in) :: verbose !< If true, output additional information for debugging unit tests + + ! Local variables + integer, parameter :: nk = 2 ! Number of layers + real, dimension(nk+1) :: eta1 ! Updated interfaces with one extra value [m] + real, dimension(:), allocatable :: h1 ! Updated list of layer thicknesses or other field [m] or [arbitrary] + real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [conc] + real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] + real, dimension(nk+1) :: khtr_u ! Horizontal diffusivities at U-point and interfaces[m2 s-1] + real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] + real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [conc m3 s-1] + character(len=120) :: test_name ! Title of the unit test + integer :: k_top ! Index of cell containing top of boundary + real :: zeta_top ! Fractional position in the cell of the top [nondim] + integer :: k_bot ! Index of cell containing bottom of boundary + real :: zeta_bot ! Fractional position in the cell of the bottom [nondim] + type(hbd_CS), pointer :: CS + + 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 extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) + CS%H_subroundoff = 1.0E-20 + CS%debug=.false. + CS%limiter=.false. + CS%limiter_remap=.false. + CS%hbd_nk = 2 + (2*2) + allocate(CS%hbd_grd_u(1,1,CS%hbd_nk), source=0.0) + allocate(CS%hbd_u_kmax(1,1), source=0) + near_boundary_unit_tests = .false. + write(stdout,*) '==== MOM_hor_bnd_diffusion =======================' + + ! Unit tests for boundary_k_range + test_name = 'Surface boundary spans the entire top cell' + h_L = (/5.,5./) + call boundary_k_range(SURFACE, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) + + test_name = 'Surface boundary spans the entire column' + h_L = (/5.,5./) + call boundary_k_range(SURFACE, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + + test_name = 'Bottom boundary spans the entire bottom cell' + h_L = (/5.,5./) + call boundary_k_range(BOTTOM, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 1., 2, 0., test_name, verbose) + + test_name = 'Bottom boundary spans the entire column' + h_L = (/5.,5./) + call boundary_k_range(BOTTOM, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 1., 2, 0., test_name, verbose) + + test_name = 'Surface boundary intersects second layer' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) + + test_name = 'Surface boundary intersects first layer' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) + + test_name = 'Surface boundary is deeper than column thickness' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 21.0, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + + test_name = 'Bottom boundary intersects first layer' + h_L = (/10.,10./) + call boundary_k_range(BOTTOM, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 0., test_name, verbose) + + test_name = 'Bottom boundary intersects second layer' + h_L = (/10.,10./) + call boundary_k_range(BOTTOM, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 0., test_name, verbose) + + if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed boundary_k_range' + + ! unit tests for sorting array and finding unique values + test_name = 'Sorting array' + eta1 = (/1., 0., 0.1/) + call sort(eta1, nk+1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, eta1, (/0., 0.1, 1./) ) + + test_name = 'Unique values' + call unique((/0., 1., 1., 2./), nk+2, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, h1, (/0., 1., 2./) ) + deallocate(h1) + + test_name = 'Unique values with maximum depth' + call unique((/0., 1., 1., 2., 3./), nk+3, h1, 2.) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, h1, (/0., 1., 2./) ) + deallocate(h1) + + if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed sort and unique' + + ! unit tests for merge_interfaces + test_name = 'h_L = h_R and BLD_L = BLD_R' + call merge_interfaces(nk, (/1., 2./), (/1., 2./), 1.5, 1.5, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/1., 0.5/) ) + deallocate(h1) + + test_name = 'h_L = h_R and BLD_L /= BLD_R' + call merge_interfaces(nk, (/1., 2./), (/1., 2./), 0.5, 1.5, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, h1, (/0.5, 0.5, 0.5/) ) + deallocate(h1) + + test_name = 'h_L /= h_R and BLD_L = BLD_R' + call merge_interfaces(nk, (/1., 3./), (/2., 2./), 1.5, 1.5, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/1., 0.5/) ) + deallocate(h1) + + test_name = 'h_L /= h_R and BLD_L /= BLD_R' + call merge_interfaces(nk, (/1., 3./), (/2., 2./), 0.5, 1.5, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, h1, (/0.5, 0.5, 0.5/) ) + deallocate(h1) + + test_name = 'Left deeper than right, h_L /= h_R and BLD_L /= BLD_R' + call merge_interfaces(nk, (/2., 3./), (/2., 2./), 1.0, 2.0, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/1., 1./) ) + deallocate(h1) + + test_name = 'Left has zero thickness, h_L /= h_R and BLD_L = BLD_R' + call merge_interfaces(nk, (/4., 0./), (/2., 2./), 2.0, 2.0, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk-1, test_name, h1, (/2./) ) + deallocate(h1) + + test_name = 'Left has zero thickness, h_L /= h_R and BLD_L /= BLD_R' + call merge_interfaces(nk, (/4., 0./), (/2., 2./), 1.0, 2.0, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/1., 1./) ) + deallocate(h1) + + test_name = 'Right has zero thickness, h_L /= h_R and BLD_L = BLD_R' + call merge_interfaces(nk, (/2., 2./), (/0., 4./), 2.0, 2.0, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk-1, test_name, h1, (/2./) ) + deallocate(h1) + + test_name = 'Right has zero thickness, h_L /= h_R and BLD_L /= BLD_R' + call merge_interfaces(nk, (/2., 2./), (/0., 4./), 1.0, 2.0, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/1., 1./) ) + deallocate(h1) + + test_name = 'Right deeper than left, h_L /= h_R and BLD_L = BLD_R' + call merge_interfaces(nk+1, (/2., 2., 0./), (/2., 2., 1./), 4., 4., CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/2., 2./) ) + deallocate(h1) + + test_name = 'Right and left small values at bottom, h_L /= h_R and BLD_L = BLD_R' + call merge_interfaces(nk+2, (/2., 2., 1., 1./), (/1., 1., .5, .5/), 3., 3., CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+2, test_name, h1, (/1., 1., .5, .5/) ) + deallocate(h1) + + if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed merge interfaces' + + ! All cases in this section have hbl which are equal to the column thicknesses + test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' + hbl_L = 2.; hbl_R = 2. + h_L = (/2.,2./) ; h_R = (/2.,2./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + khtr_u = (/1.,1.,1./) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.0,0.0/) ) + + test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' + hbl_L = 2.; hbl_R = 2. + h_L = (/2.,2./) ; h_R = (/2.,2./) + phi_L = (/2.,1./) ; phi_R = (/1.,1./) + khtr_u = (/0.5,0.5,0.5/) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/1.0,0.0/) ) + + test_name = 'hbl < column thickness, hbl same, linear profile right, khtr=2' + hbl_L = 2; hbl_R = 2 + h_L = (/1.,2./) ; h_R = (/1.,2./) + phi_L = (/0.,0./) ; phi_R = (/0.5,2./) + khtr_u = (/2.,2.,2./) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-4.0/) ) + + test_name = 'Different hbl and different column thicknesses (zero gradient)' + hbl_L = 12; hbl_R = 20 + h_L = (/6.,6./) ; h_R = (/10.,10./) + phi_L = (/1.,1./) ; phi_R = (/1.,1./) + khtr_u = (/1.,1.,1./) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.,0./) ) + + test_name = 'Different hbl and different column thicknesses (gradient from left to right)' + + hbl_L = 15; hbl_R = 10. + h_L = (/10.,5./) ; h_R = (/10.,0./) + phi_L = (/1.,1./) ; phi_R = (/0.,0./) + khtr_u = (/1.,1.,1./) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/10.,0.0/) ) + + if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed fluxes_layer_method' + +end function near_boundary_unit_tests + +!> Returns true if output of near-boundary unit tests does not match correct computed values +!! and conditionally writes results to stream +logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=80), intent(in) :: test_name !< Brief description of the unit test + integer, intent(in) :: nk !< Number of layers + real, dimension(nk), intent(in) :: F_calc !< Fluxes or other quantity from the algorithm [arbitrary] + real, dimension(nk), intent(in) :: F_ans !< Expected value calculated by hand [arbitrary] + ! Local variables + integer :: k + + test_layer_fluxes = .false. + do k=1,nk + if ( F_calc(k) /= F_ans(k) ) then + test_layer_fluxes = .true. + write(stdout,*) "MOM_hor_bnd_diffusion, UNIT TEST FAILED: ", test_name + write(stdout,10) k, F_calc(k), F_ans(k) + elseif (verbose) then + write(stdout,10) k, F_calc(k), F_ans(k) + endif + enddo + +10 format("Layer=",i3," F_calc=",f20.16," F_ans",f20.16) +end function test_layer_fluxes + +!> Return true if output of unit tests for boundary_k_range does not match answers +logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_ans, zeta_top_ans,& + k_bot_ans, zeta_bot_ans, test_name, verbose) + integer :: k_top !< Index of cell containing top of boundary + real :: zeta_top !< Fractional position in the cell of the top boundary [nondim] + integer :: k_bot !< Index of cell containing bottom of boundary + real :: zeta_bot !< Fractional position in the cell of the bottom boundary [nondim] + integer :: k_top_ans !< Expected index of cell containing top of boundary + real :: zeta_top_ans !< Expected fractional position of the top boundary [nondim] + integer :: k_bot_ans !< Expected index of cell containing bottom of boundary + real :: zeta_bot_ans !< Expected fractional position of the bottom boundary [nondim] + character(len=80) :: test_name !< Name of the unit test + logical :: verbose !< If true always print output + + test_boundary_k_range = k_top /= k_top_ans + test_boundary_k_range = test_boundary_k_range .or. (zeta_top /= zeta_top_ans) + test_boundary_k_range = test_boundary_k_range .or. (k_bot /= k_bot_ans) + test_boundary_k_range = test_boundary_k_range .or. (zeta_bot /= zeta_bot_ans) + + if (test_boundary_k_range) write(stdout,*) "UNIT TEST FAILED: ", test_name + if (test_boundary_k_range .or. verbose) then + write(stdout,20) "k_top", k_top, "k_top_ans", k_top_ans + write(stdout,20) "k_bot", k_bot, "k_bot_ans", k_bot_ans + write(stdout,30) "zeta_top", zeta_top, "zeta_top_ans", zeta_top_ans + write(stdout,30) "zeta_bot", zeta_bot, "zeta_bot_ans", zeta_bot_ans + endif + + 20 format(A,"=",i3,1X,A,"=",i3) + 30 format(A,"=",f20.16,1X,A,"=",f20.16) + + +end function test_boundary_k_range + +!> Same as hbd_grid, but only used in the unit tests. +subroutine hbd_grid_test(boundary, hbl_L, hbl_R, h_L, h_R, CS) + integer, intent(in) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + real, intent(in) :: hbl_L !< Boundary layer depth, left [H ~> m or kg m-2] + real, intent(in) :: hbl_R !< Boundary layer depth, right [H ~> m or kg m-2] + real, dimension(2), intent(in) :: h_L !< Layer thickness in the native grid, left [H ~> m or kg m-2] + real, dimension(2), intent(in) :: h_R !< Layer thickness in the native grid, right [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure + + ! Local variables + real, allocatable :: dz_top(:) !< temporary HBD grid given by merge_interfaces [H ~> m or kg m-2] + integer :: nk, k !< number of layers in the HBD grid, and integers used in do-loops + + ! reset arrays + CS%hbd_grd_u(1,1,:) = 0.0 + CS%hbd_u_kmax(1,1) = 0 + + call merge_interfaces(2, h_L, h_R, hbl_L, hbl_R, CS%H_subroundoff, dz_top) + nk = SIZE(dz_top) + if (nk > CS%hbd_nk) then + write(*,*)'nk, CS%hbd_nk', nk, CS%hbd_nk + call MOM_error(FATAL,"Houston, we've had a problem in hbd_grid_test, (nk cannot be > CS%hbd_nk)") + endif + + CS%hbd_u_kmax(1,1) = nk + + ! set the HBD grid to dz_top + do k=1,nk + CS%hbd_grd_u(1,1,k) = dz_top(k) + enddo + deallocate(dz_top) + +end subroutine hbd_grid_test + +!> Deallocates hor_bnd_diffusion control structure +subroutine hor_bnd_diffusion_end(CS) + type(hbd_CS), pointer :: CS !< Horizontal boundary diffusion control structure + + if (associated(CS)) deallocate(CS) + +end subroutine hor_bnd_diffusion_end + +!> \namespace mom_hor_bnd_diffusion +!! +!! \section section_HBD The Horizontal Boundary Diffusion (HBD) framework +!! +!! The HBD framework accounts for the effects of diabatic mesoscale fluxes +!! within surface and bottom boundary layers. Unlike the equivalent adiabatic +!! fluxes, which is applied along neutral density surfaces, HBD is purely +!! horizontal. To assure that diffusive fluxes are strictly horizontal +!! regardless of the vertical coordinate system, this method relies on +!! regridding/remapping techniques. +!! +!! The bottom boundary layer fluxes remain to be implemented, although some +!! of the steps needed to do so have already been added and tested. +!! +!! Horizontal boundary diffusion is applied as follows: +!! +!! 1) remap tracer to a z* grid (HBD grid) +!! 2) calculate diffusive tracer fluxes (F) in the HBD grid using a layer by layer approach (@ref section_method) +!! 3) remap fluxes to the native grid +!! 4) update tracer by adding the divergence of F +!! +!! \subsection section_method Along layer approach +!! +!! Here diffusion is applied layer by layer using only information from neighboring cells. +!! +!! Step #1: define vertical grid using interfaces and surface boundary layers from left and right +!! columns (see merge_interfaces). +!! +!! Step #2: compute vertical indices containing boundary layer (boundary_k_range). +!! For the TOP boundary layer, these are: +!! +!! k_top, k_bot, zeta_top, zeta_bot +!! +!! Step #2: calculate the diffusive flux at each layer: +!! +!! \f[ F_{k} = -KHTR \times h_{eff}(k) \times (\phi_R(k) - \phi_L(k)), \f] +!! where h_eff is the [harmonic mean](@ref section_harmonic_mean) of the layer thickness +!! in the left and right columns. +!! +!! Step #3: option to linearly decay the flux from k_bot_min to k_bot_max: +!! +!! If HBD_LINEAR_TRANSITION = True and k_bot_diff > 1, the diffusive flux will decay +!! linearly between the top interface of the layer containing the minimum boundary +!! layer depth (k_bot_min) and the lower interface of the layer containing the +!! maximum layer depth (k_bot_max). +!! +!! Step #4: remap the fluxes back to the native grid. This is done at velocity points, whose vertical grid +!! is determined using [harmonic mean](@ref section_harmonic_mean). To assure monotonicity, +!! tracer fluxes are limited so that 1) only down-gradient fluxes are applied, +!! and 2) the flux cannot be larger than F_max, which is defined using the tracer +!! gradient: +!! +!! \f[ F_{max} = -0.2 \times [(V_R(k) \times \phi_R(k)) - (V_L(k) \times \phi_L(k))], \f] +!! where V is the cell volume. Why 0.2? +!! t=0 t=inf +!! 0 .2 +!! 0 1 0 .2.2.2 +!! 0 .2 +!! +!! \subsection section_harmonic_mean Harmonic Mean +!! +!! The harmonic mean (HM) betwen h1 and h2 is defined as: +!! +!! \f[ HM = \frac{2 \times h1 \times h2}{h1 + h2} \f] +!! +end module MOM_hor_bnd_diffusion diff --git a/tracer/MOM_neutral_diffusion.F90 b/tracer/MOM_neutral_diffusion.F90 new file mode 100644 index 0000000000..b64c665c87 --- /dev/null +++ b/tracer/MOM_neutral_diffusion.F90 @@ -0,0 +1,3345 @@ +!> A column-wise toolbox for implementing neutral diffusion +module MOM_neutral_diffusion + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_domains, only : pass_var +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_EOS, only : EOS_type, EOS_manual_init, EOS_domain +use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : EOS_LINEAR +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_grid, only : ocean_grid_type +use MOM_remapping, only : remapping_CS, initialize_remapping +use MOM_remapping, only : extract_member_remapping_CS, build_reconstructions_1d +use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme +use MOM_tracer_registry, only : tracer_registry_type, tracer_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +use polynomial_functions, only : evaluation_polynomial, first_derivative_polynomial +use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use regrid_edge_values, only : edge_values_implicit_h4 +use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS +use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member +use MOM_io, only : stdout, stderr +use MOM_hor_bnd_diffusion, only : boundary_k_range, SURFACE, BOTTOM + +implicit none ; private + +#include + +public neutral_diffusion, neutral_diffusion_init, neutral_diffusion_end +public neutral_diffusion_calc_coeffs +public neutral_diffusion_unit_tests + +!> The control structure for the MOM_neutral_diffusion module +type, public :: neutral_diffusion_CS ; private + integer :: nkp1 !< Number of interfaces for a column = nk + 1 + integer :: nsurf !< Number of neutral surfaces + integer :: deg = 2 !< Degree of polynomial used for reconstructions + logical :: continuous_reconstruction = .true. !< True if using continuous PPM reconstruction at interfaces + logical :: debug = .false. !< If true, write verbose debugging messages + logical :: hard_fail_heff !< Bring down the model if a problem with heff is detected + integer :: max_iter !< Maximum number of iterations if refine_position is defined + real :: drho_tol !< Convergence criterion representing density difference from true neutrality [R ~> kg m-3] + real :: x_tol !< Convergence criterion for how small an update of the position can be [nondim] + real :: ref_pres !< Reference pressure, negative if using locally referenced neutral + !! density [R L2 T-2 ~> Pa] + logical :: interior_only !< If true, only applies neutral diffusion in the ocean interior. + !! That is, the algorithm will exclude the surface and bottom boundary layers. + logical :: tapering = .false. !< If true, neutral diffusion linearly decays towards zero within a + !! transition zone defined using boundary layer depths. Only available when + !! interior_only=true. + logical :: KhTh_use_ebt_struct !< If true, uses the equivalent barotropic structure + !! as the vertical structure of tracer diffusivity. + logical :: 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. + real, allocatable, dimension(:,:) :: hbl !< Boundary layer depth [H ~> m or kg m-2] + ! Coefficients used to apply tapering from neutral to horizontal direction + real, allocatable, dimension(:) :: coeff_l !< Non-dimensional coefficient in the left column, + !! at cell interfaces [nondim] + real, allocatable, dimension(:) :: coeff_r !< Non-dimensional coefficient in the right column, + !! at cell interfaces [nondim] + ! Array used when KhTh_use_ebt_struct is true + real, allocatable, dimension(:,:,:) :: Coef_h !< Coef_x and Coef_y averaged at t-points [L2 ~> m2] + ! Positions of neutral surfaces in both the u, v directions + real, allocatable, dimension(:,:,:) :: uPoL !< Non-dimensional position with left layer uKoL-1, u-point [nondim] + real, allocatable, dimension(:,:,:) :: uPoR !< Non-dimensional position with right layer uKoR-1, u-point [nondim] + integer, allocatable, dimension(:,:,:) :: uKoL !< Index of left interface corresponding to neutral surface, + !! at a u-point + integer, allocatable, dimension(:,:,:) :: uKoR !< Index of right interface corresponding to neutral surface, + !! at a u-point + real, allocatable, dimension(:,:,:) :: uHeff !< Effective thickness at u-point [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: vPoL !< Non-dimensional position with left layer uKoL-1, v-point [nondim] + real, allocatable, dimension(:,:,:) :: vPoR !< Non-dimensional position with right layer uKoR-1, v-point [nondim] + integer, allocatable, dimension(:,:,:) :: vKoL !< Index of left interface corresponding to neutral surface, + !! at a v-point + integer, allocatable, dimension(:,:,:) :: vKoR !< Index of right interface corresponding to neutral surface, + !! at a v-point + real, allocatable, dimension(:,:,:) :: vHeff !< Effective thickness at v-point [H ~> m or kg m-2] + ! Coefficients of polynomial reconstructions for temperature and salinity + real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_T !< Polynomial coefficients of the + !! sub-gridscale temperatures [C ~> degC] + real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_S !< Polynomial coefficients of the + !! sub-gridscale salinity [S ~> ppt] + ! Variables needed for continuous reconstructions + real, allocatable, dimension(:,:,:) :: dRdT !< dRho/dT [R C-1 ~> kg m-3 degC-1] at interfaces + real, allocatable, dimension(:,:,:) :: dRdS !< dRho/dS [R S-1 ~> kg m-3 ppt-1] at interfaces + real, allocatable, dimension(:,:,:) :: Tint !< Interface T [C ~> degC] + real, allocatable, dimension(:,:,:) :: Sint !< Interface S [S ~> ppt] + real, allocatable, dimension(:,:,:) :: Pint !< Interface pressure [R L2 T-2 ~> Pa] + ! Variables needed for discontinuous reconstructions + real, allocatable, dimension(:,:,:,:) :: T_i !< Top edge reconstruction of temperature [C ~> degC] + real, allocatable, dimension(:,:,:,:) :: S_i !< Top edge reconstruction of salinity [S ~> ppt] + real, allocatable, dimension(:,:,:,:) :: P_i !< Interface pressures [R L2 T-2 ~> Pa] + real, allocatable, dimension(:,:,:,:) :: dRdT_i !< dRho/dT [R C-1 ~> kg m-3 degC-1] at top edge + real, allocatable, dimension(:,:,:,:) :: dRdS_i !< dRho/dS [R S-1 ~> kg m-3 ppt-1] at top edge + integer, allocatable, dimension(:,:) :: ns !< Number of interfaces in a column + logical, allocatable, dimension(:,:,:) :: stable_cell !< True if the cell is stably stratified wrt to the next cell + real :: R_to_kg_m3 = 1.0 !< A rescaling factor translating density to kg m-3 for + !! use in diagnostic messages [kg m-3 R-1 ~> 1]. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + integer :: neutral_pos_method !< Method to find the position of a neutral surface within the layer + character(len=40) :: delta_rho_form !< Determine which (if any) approximation is made to the + !! equation describing the difference in density + + integer :: id_uhEff_2d = -1 !< Diagnostic IDs + integer :: id_vhEff_2d = -1 !< Diagnostic IDs + + type(EOS_type), pointer :: EOS => NULL() !< Equation of state parameters + type(remapping_CS) :: remap_CS !< Remapping control structure used to create sublayers + integer :: remap_answer_date !< The vintage of the order of arithmetic and expressions to use + !! for remapping. Values below 20190101 recover the remapping + !! answers from 2018, while higher values use more robust + !! forms of the same remapping expressions. + integer :: ndiff_answer_date !< The vintage of the order of arithmetic to use for the neutral + !! diffusion. Values of 20240330 or below recover the answers + !! from the original form of this code, while higher values use + !! mathematically equivalent expressions that recover rotational symmetry. + type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL()!< ePBL control structure needed to get MLD +end type neutral_diffusion_CS + +! This include declares and sets the variable "version". +#include "version_variable.h" +character(len=40) :: mdl = "MOM_neutral_diffusion" !< module name + +contains + +!> Read parameters and allocate control structure for neutral_diffusion module. +logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, diabatic_CSp, CS) + type(time_type), target, intent(in) :: Time !< Time structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(EOS_type), target, intent(in) :: EOS !< Equation of state + type(diabatic_CS), pointer :: diabatic_CSp!< KPP control structure needed to get BLD + type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure + + ! Local variables + character(len=80) :: string ! Temporary strings + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: debug ! If true, write verbose checksums for debugging purposes. + logical :: boundary_extrap ! Indicate whether high-order boundary + !! extrapolation should be used within boundary cells. + + if (associated(CS)) then + call MOM_error(FATAL, "neutral_diffusion_init called with associated control structure.") + return + endif + + ! Log this module and master switch for turning it on/off + call get_param(param_file, mdl, "USE_NEUTRAL_DIFFUSION", neutral_diffusion_init, & + default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, & + "This module implements neutral diffusion of tracers", & + all_default=.not.neutral_diffusion_init) + call get_param(param_file, mdl, "USE_NEUTRAL_DIFFUSION", neutral_diffusion_init, & + "If true, enables the neutral diffusion module.", & + default=.false.) + + if (.not.neutral_diffusion_init) return + + allocate(CS) + CS%diag => diag + CS%EOS => EOS + ! call openParameterBlock(param_file,'NEUTRAL_DIFF') + + ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mdl, "NDIFF_CONTINUOUS", CS%continuous_reconstruction, & + "If true, uses a continuous reconstruction of T and S when "//& + "finding neutral surfaces along which diffusion will happen. "//& + "If false, a PPM discontinuous reconstruction of T and S "//& + "is done which results in a higher order routine but exacts "//& + "a higher computational cost.", default=.true.) + call get_param(param_file, mdl, "NDIFF_REF_PRES", CS%ref_pres, & + "The reference pressure (Pa) used for the derivatives of "//& + "the equation of state. If negative (default), local pressure is used.", & + units="Pa", default=-1., scale=US%Pa_to_RL2_T2) + 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.) + if (CS%interior_only) then + call get_param(param_file, mdl, "NDIFF_TAPERING", CS%tapering, & + "If true, neutral diffusion linearly decays to zero within "//& + "a transition zone defined using boundary layer depths. "//& + "Only applicable when NDIFF_INTERIOR_ONLY=True", default=.false.) + endif + call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of the tracer diffusivity.",& + default=.false.,do_not_log=.true.) + 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.) + + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "NDIFF_ANSWER_DATE", CS%ndiff_answer_date, & + "The vintage of the order of arithmetic to use for the neutral diffusion. "//& + "Values of 20240330 or below recover the answers from the original form of the "//& + "neutral diffusion code, while higher values use mathematically equivalent "//& + "expressions that recover rotational symmetry.", & + default=20240101) !### Change this default later to default_answer_date. + + ! Initialize and configure remapping + if ( .not.CS%continuous_reconstruction ) then + call get_param(param_file, mdl, "NDIFF_BOUNDARY_EXTRAP", boundary_extrap, & + "Extrapolate at the top and bottommost cells, otherwise \n"// & + "assume boundaries are piecewise constant", & + default=.false.) + call get_param(param_file, mdl, "NDIFF_REMAPPING_SCHEME", string, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: "//& + trim(remappingSchemesDoc), default=remappingDefaultScheme) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) + call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & + answer_date=CS%remap_answer_date ) + call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) + call get_param(param_file, mdl, "NEUTRAL_POS_METHOD", CS%neutral_pos_method, & + "Method used to find the neutral position \n"// & + "1. Delta_rho varies linearly, find 0 crossing \n"// & + "2. Alpha and beta vary linearly from top to bottom, \n"// & + " Newton's method for neutral position \n"// & + "3. Full nonlinear equation of state, use regula falsi \n"// & + " for neutral position", default=3) + if (CS%neutral_pos_method > 4 .or. CS%neutral_pos_method < 0) then + call MOM_error(FATAL,"Invalid option for NEUTRAL_POS_METHOD") + endif + + call get_param(param_file, mdl, "DELTA_RHO_FORM", CS%delta_rho_form, & + "Determine how the difference in density is calculated \n"// & + " full : Difference of in-situ densities \n"// & + " no_pressure: Calculated from dRdT, dRdS, but no \n"// & + " pressure dependence", & + default="mid_pressure") + if (CS%neutral_pos_method > 1) then + call get_param(param_file, mdl, "NDIFF_DRHO_TOL", CS%drho_tol, & + "Sets the convergence criterion for finding the neutral "// & + "position within a layer in kg m-3.", & + units="kg m-3", default=1.e-10, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "NDIFF_X_TOL", CS%x_tol, & + "Sets the convergence criterion for a change in nondimensional "// & + "position within a layer.", & + units="nondim", default=0.) + call get_param(param_file, mdl, "NDIFF_MAX_ITER", CS%max_iter, & + "The maximum number of iterations to be done before "// & + "exiting the iterative loop to find the neutral surface", & + default=10) + endif + call get_param(param_file, mdl, "DEBUG", debug, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "NDIFF_DEBUG", CS%debug, & + "Turns on verbose output for discontinuous neutral "//& + "diffusion routines.", default=debug) + call get_param(param_file, mdl, "HARD_FAIL_HEFF", CS%hard_fail_heff, & + "Bring down the model if a problem with heff is detected",& + default=.true.) + endif + + if (CS%interior_only) then + allocate(CS%hbl(SZI_(G),SZJ_(G)), source=0.) + call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) + call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) + if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then + call MOM_error(FATAL,"NDIFF_INTERIOR_ONLY is true, but no valid boundary layer scheme was found") + endif + + if (CS%tapering) then + allocate(CS%coeff_l(SZK_(GV)+1), source=1.) + allocate(CS%coeff_r(SZK_(GV)+1), source=1.) + endif + endif + + if (CS%KhTh_use_ebt_struct) & + allocate(CS%Coef_h(G%isd:G%ied,G%jsd:G%jed,SZK_(GV)+1), source=0.) + + ! Store a rescaling factor for use in diagnostic messages. + CS%R_to_kg_m3 = US%R_to_kg_m3 + +! call closeParameterBlock(param_file) + if (CS%continuous_reconstruction) then + CS%nsurf = 2*GV%ke+2 ! Continuous reconstruction means that every interface has two connections + allocate(CS%dRdT(SZI_(G),SZJ_(G),SZK_(GV)+1), source=0.) + allocate(CS%dRdS(SZI_(G),SZJ_(G),SZK_(GV)+1), source=0.) + else + CS%nsurf = 4*GV%ke ! Discontinuous means that every interface has four connections + allocate(CS%T_i(SZI_(G),SZJ_(G),SZK_(GV),2), source=0.) + allocate(CS%S_i(SZI_(G),SZJ_(G),SZK_(GV),2), source=0.) + allocate(CS%P_i(SZI_(G),SZJ_(G),SZK_(GV),2), source=0.) + allocate(CS%dRdT_i(SZI_(G),SZJ_(G),SZK_(GV),2), source=0.) + allocate(CS%dRdS_i(SZI_(G),SZJ_(G),SZK_(GV),2), source=0.) + allocate(CS%ppoly_coeffs_T(SZI_(G),SZJ_(G),SZK_(GV),CS%deg+1), source=0.) + allocate(CS%ppoly_coeffs_S(SZI_(G),SZJ_(G),SZK_(GV),CS%deg+1), source=0.) + allocate(CS%ns(SZI_(G),SZJ_(G)), source=0) + endif + ! T-points + allocate(CS%Tint(SZI_(G),SZJ_(G),SZK_(GV)+1), source=0.) + allocate(CS%Sint(SZI_(G),SZJ_(G),SZK_(GV)+1), source=0.) + allocate(CS%Pint(SZI_(G),SZJ_(G),SZK_(GV)+1), source=0.) + allocate(CS%stable_cell(SZI_(G),SZJ_(G),SZK_(GV)), source=.true.) + ! U-points + allocate(CS%uPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%uPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%uKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%uKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%uHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1), source=0.) + ! V-points + allocate(CS%vPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%vPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%vKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%vKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%vHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1), source=0.) + +end function neutral_diffusion_init + +!> Calculate remapping factors for u/v columns used to map adjoining columns to +!! a shared coordinate space. +subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S !< Salinity [S ~> ppt] + type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: p_surf !< Surface pressure to include in pressures used + !! for equation of state calculations [R L2 T-2 ~> Pa] + + ! Local variables + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k + ! Variables used for reconstructions + real, dimension(SZK_(GV),2) :: ppoly_r_S ! Reconstruction slopes that are unused here, in units of a vertical + ! gradient, which for temperature would be [C H-1 ~> degC m-1 or degC m2 kg-1]. + real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum ! Summed effective face thicknesses [H ~> m or kg m-2] + integer :: iMethod + real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta [R L2 T-2 ~> Pa] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + integer, dimension(SZI_(G), SZJ_(G)) :: k_top ! Index of the first layer within the boundary + real, dimension(SZI_(G), SZJ_(G)) :: zeta_top ! Distance from the top of a layer to the intersection of the + ! top extent of the boundary layer (0 at top, 1 at bottom) [nondim] + integer, dimension(SZI_(G), SZJ_(G)) :: k_bot ! Index of the last layer within the boundary + real, dimension(SZI_(G), SZJ_(G)) :: zeta_bot ! Distance of the lower layer to the boundary layer depth [nondim] + real :: pa_to_H ! A conversion factor from rescaled pressure to thickness + ! (H) units [H T2 R-1 Z-2 ~> m Pa-1 or s2 m-1] + + pa_to_H = 1. / (GV%H_to_RZ * GV%g_Earth) + + k_top(:,:) = 1 ; k_bot(:,:) = 1 + zeta_top(:,:) = 0. ; zeta_bot(:,:) = 0. + + ! Check if hbl needs to be extracted + if (CS%interior_only) then + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, CS%hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, CS%hbl, G, US, & + m_to_MLD_units=GV%m_to_H) + call pass_var(CS%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.0) then + call boundary_k_range(SURFACE, G%ke, h(i,j,:), CS%hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), & + zeta_bot(i,j)) + endif + enddo; enddo + ! TODO: add similar code for BOTTOM boundary layer + endif + + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + + if (.not. CS%continuous_reconstruction) then + if (CS%remap_answer_date < 20190101) then + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + endif + endif + + ! If doing along isopycnal diffusion (as opposed to neutral diffusion, set the reference pressure) + if (CS%ref_pres>=0.) then + ref_pres(:) = CS%ref_pres + endif + + if (CS%continuous_reconstruction) then + CS%dRdT(:,:,:) = 0. + CS%dRdS(:,:,:) = 0. + else + CS%T_i(:,:,:,:) = 0. + CS%S_i(:,:,:,:) = 0. + CS%dRdT_i(:,:,:,:) = 0. + CS%dRdS_i(:,:,:,:) = 0. + CS%ns(:,:) = 0. + CS%stable_cell(:,:,:) = .true. + endif + + ! Calculate pressure at interfaces and layer averaged alpha/beta + if (present(p_surf)) then + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%Pint(i,j,1) = p_surf(i,j) + enddo ; enddo + else + CS%Pint(:,:,1) = 0. + endif + do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%Pint(i,j,k+1) = CS%Pint(i,j,k) + h(i,j,k)*(GV%g_Earth*GV%H_to_RZ) + enddo ; enddo ; enddo + + ! Pressures at the interfaces, this is redundant as P_i(k,1) = P_i(k-1,2) however retain this + ! for now to ensure consistency of indexing for discontinuous reconstructions + if (.not. CS%continuous_reconstruction) then + if (present(p_surf)) then + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%P_i(i,j,1,1) = p_surf(i,j) + CS%P_i(i,j,1,2) = p_surf(i,j) + h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) + enddo ; enddo + else + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%P_i(i,j,1,1) = 0. + CS%P_i(i,j,1,2) = h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) + enddo ; enddo + endif + do k=2,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%P_i(i,j,k,1) = CS%P_i(i,j,k-1,2) + CS%P_i(i,j,k,2) = CS%P_i(i,j,k-1,2) + h(i,j,k)*(GV%H_to_RZ*GV%g_Earth) + enddo ; enddo ; enddo + endif + + EOSdom(:) = EOS_domain(G%HI, halo=1) + do j = G%jsc-1, G%jec+1 + ! Interpolate state to interface + do i = G%isc-1, G%iec+1 + if (CS%continuous_reconstruction) then + call interface_scalar(GV%ke, h(i,j,:), T(i,j,:), CS%Tint(i,j,:), 2, h_neglect) + call interface_scalar(GV%ke, h(i,j,:), S(i,j,:), CS%Sint(i,j,:), 2, h_neglect) + else + call build_reconstructions_1d( CS%remap_CS, GV%ke, h(i,j,:), T(i,j,:), CS%ppoly_coeffs_T(i,j,:,:), & + CS%T_i(i,j,:,:), ppoly_r_S, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( CS%remap_CS, GV%ke, h(i,j,:), S(i,j,:), CS%ppoly_coeffs_S(i,j,:,:), & + CS%S_i(i,j,:,:), ppoly_r_S, iMethod, h_neglect, h_neglect_edge ) + ! In the current ALE formulation, interface values are not exactly at the 0. or 1. of the + ! polynomial reconstructions + do k=1,GV%ke + CS%T_i(i,j,k,1) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 0. ) + CS%T_i(i,j,k,2) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 1. ) + CS%S_i(i,j,k,1) = evaluation_polynomial( CS%ppoly_coeffs_S(i,j,k,:), CS%deg+1, 0. ) + CS%S_i(i,j,k,2) = evaluation_polynomial( CS%ppoly_coeffs_S(i,j,k,:), CS%deg+1, 1. ) + enddo + endif + enddo + + ! Continuous reconstruction + if (CS%continuous_reconstruction) then + do k = 1, GV%ke+1 + if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) + call calculate_density_derivs(CS%Tint(:,j,k), CS%Sint(:,j,k), ref_pres, CS%dRdT(:,j,k), & + CS%dRdS(:,j,k), CS%EOS, EOSdom) + enddo + else ! Discontinuous reconstruction + do k = 1, GV%ke + if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) + ! Calculate derivatives for the top interface + call calculate_density_derivs(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, CS%dRdT_i(:,j,k,1), & + CS%dRdS_i(:,j,k,1), CS%EOS, EOSdom) + if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k+1) + ! Calculate derivatives at the bottom interface + call calculate_density_derivs(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, CS%dRdT_i(:,j,k,2), & + CS%dRdS_i(:,j,k,2), CS%EOS, EOSdom) + enddo + endif + enddo + + if (.not. CS%continuous_reconstruction) then + do j = G%jsc-1, G%jec+1 ; do i = G%isc-1, G%iec+1 + call mark_unstable_cells( CS, GV%ke, CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%P_i(i,j,:,:), CS%stable_cell(i,j,:) ) + if (CS%interior_only) then + if (.not. CS%stable_cell(i,j,k_bot(i,j))) zeta_bot(i,j) = -1. + ! set values in the surface and bottom boundary layer to false. + do k = 1, k_bot(i,j) + CS%stable_cell(i,j,k) = .false. + enddo + endif + enddo ; enddo + endif + + CS%uhEff(:,:,:) = 0. + CS%vhEff(:,:,:) = 0. + CS%uPoL(:,:,:) = 0. + CS%vPoL(:,:,:) = 0. + CS%uPoR(:,:,:) = 0. + CS%vPoR(:,:,:) = 0. + CS%uKoL(:,:,:) = 1 + CS%vKoL(:,:,:) = 1 + CS%uKoR(:,:,:) = 1 + CS%vKoR(:,:,:) = 1 + + ! 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.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,:), & + CS%Pint(i+1,j,:), CS%Tint(i+1,j,:), CS%Sint(i+1,j,:), CS%dRdT(i+1,j,:), CS%dRdS(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & + k_bot(I,j), k_bot(I+1,j), zeta_bot(I,j), zeta_bot(I+1,j)) + else + call find_neutral_surface_positions_discontinuous(CS, GV%ke, & + CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & + CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & + CS%P_i(i+1,j,:,:), h(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), CS%ppoly_coeffs_T(i+1,j,:,:), & + CS%ppoly_coeffs_S(i+1,j,:,:), CS%stable_cell(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & + hard_fail_heff = CS%hard_fail_heff) + endif + endif + enddo ; enddo + + ! 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.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,:), & + CS%Pint(i,j+1,:), CS%Tint(i,j+1,:), CS%Sint(i,j+1,:), CS%dRdT(i,j+1,:), CS%dRdS(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), CS%vKoL(i,J,:), CS%vKoR(i,J,:), CS%vhEff(i,J,:), & + k_bot(i,J), k_bot(i,J+1), zeta_bot(i,J), zeta_bot(i,J+1)) + else + call find_neutral_surface_positions_discontinuous(CS, GV%ke, & + CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & + CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & + CS%P_i(i,j+1,:,:), h(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), CS%ppoly_coeffs_T(i,j+1,:,:), & + CS%ppoly_coeffs_S(i,j+1,:,:), CS%stable_cell(i,j+1,:), & + CS%vPoL(I,j,:), CS%vPoR(I,j,:), CS%vKoL(I,j,:), CS%vKoR(I,j,:), CS%vhEff(I,j,:), & + hard_fail_heff = CS%hard_fail_heff) + endif + endif + enddo ; enddo + + ! Continuous reconstructions calculate hEff as the difference between the pressures of the + ! neutral surfaces which need to be reconverted to thickness units. The discontinuous version + ! calculates hEff from the nondimensional fraction of the layer spanned by adjacent neutral + ! surfaces, so hEff is already in thickness units. + if (CS%continuous_reconstruction) then + if (CS%use_unmasked_transport_bug) then + ! This option is not recommended but needed to recover answers prior to Jan 2018. + ! It is independent of the other 2018 answers flags. + do k = 1, CS%nsurf-1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec + CS%uhEff(I,j,k) = CS%uhEff(I,j,k) / GV%H_to_pa + enddo ; enddo ; enddo + do k = 1, CS%nsurf-1 ; do J = G%jsc-1, G%jec ; do i = G%isc, G%iec + CS%vhEff(I,j,k) = CS%vhEff(I,j,k) / GV%H_to_pa + 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.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.0) CS%vhEff(i,J,k) = CS%vhEff(i,J,k) * pa_to_H + enddo ; enddo ; enddo + endif + endif + + if (CS%id_uhEff_2d>0) then + hEff_sum(:,:) = 0. + do k = 1,CS%nsurf-1 ; do j=G%jsc,G%jec ; do i=G%isc-1,G%iec + hEff_sum(i,j) = hEff_sum(i,j) + CS%uhEff(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_uhEff_2d, hEff_sum, CS%diag) + endif + if (CS%id_vhEff_2d>0) then + hEff_sum(:,:) = 0. + do k = 1,CS%nsurf-1 ; do j=G%jsc-1,G%jec ; do i=G%isc,G%iec + hEff_sum(i,j) = hEff_sum(i,j) + CS%vhEff(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_vhEff_2d, hEff_sum, CS%diag) + endif + +end subroutine neutral_diffusion_calc_coeffs + +!> Update tracer concentration due to neutral diffusion; layer thickness unchanged by this update. +subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] + real, intent(in) :: dt !< Tracer time step * I_numitts [T ~> s] + !! (I_numitts is in tracer_hordiff) + type(tracer_registry_type), pointer :: Reg !< Tracer registry + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G),CS%nsurf-1) :: uFlx ! Zonal flux of tracer in units that vary between a + ! thickness times a concentration ([C H ~> degC m or degC kg m-2] for temperature) or a + ! volume or mass times a concentration ([C H L2 ~> degC m3 or degC kg] for temperature), + ! depending on the setting of CS%KhTh_use_ebt_struct. + real, dimension(SZI_(G),SZJB_(G),CS%nsurf-1) :: vFlx ! Meridional flux of tracer in units that vary between a + ! thickness times a concentration ([C H ~> degC m or degC kg m-2] for temperature) or a + ! volume or mass times a concentration ([C H L2 ~> degC m3 or degC kg] for temperature), + ! depending on the setting of CS%KhTh_use_ebt_struct. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency ! tendency array for diagnostics + ! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1] + ! For temperature these units are + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! Depth integrated content tendency for diagnostics + ! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1]. + ! For temperature these units are + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + real, dimension(SZIB_(G),SZJ_(G)) :: trans_x_2d ! Depth integrated diffusive tracer x-transport + ! diagnostic. For temperature this has units of + ! [C H L2 ~> degC m3 or degC kg]. + real, dimension(SZI_(G),SZJB_(G)) :: trans_y_2d ! depth integrated diffusive tracer y-transport + ! diagnostic. For temperature this has units of + ! [C H L2 ~> degC m3 or degC kg]. + real, dimension(SZK_(GV)) :: dTracer ! Change in tracer concentration due to neutral diffusion + ! [H L2 conc ~> m3 conc or kg conc]. For temperature + ! these units are [C H L2 ~> degC m3 or degC kg]. + real, dimension(SZK_(GV)) :: dTracer_N ! Change in tracer concentration due to neutral diffusion + ! into a cell via its logically northern face, in + ! [H L2 conc ~> m3 conc or kg conc]. + real, dimension(SZK_(GV)) :: dTracer_S ! Change in tracer concentration due to neutral diffusion + ! into a cell via its logically southern face, in + ! [H L2 conc ~> m3 conc or kg conc]. + real, dimension(SZK_(GV)) :: dTracer_E ! Change in tracer concentration due to neutral diffusion + ! into a cell via its logically eastern face, in + ! [H L2 conc ~> m3 conc or kg conc]. + real, dimension(SZK_(GV)) :: dTracer_W ! Change in tracer concentration due to neutral diffusion + ! into a cell via its logically western face, in + ! [H L2 conc ~> m3 conc or kg conc]. + real :: normalize ! normalization used for averaging Coef_x and Coef_y to t-points [nondim]. + + type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer + + integer :: i, j, k, m, ks, nk + real :: Idt ! The inverse of the time step [T-1 ~> s-1] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + + if (.not. CS%continuous_reconstruction) then + if (CS%remap_answer_date < 20190101) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + endif + endif + + if (CS%KhTh_use_ebt_struct) then + ! Compute Coef at h points + CS%Coef_h(:,:,:) = 0. + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + normalize = 1.0 / ((G%mask2dCu(I-1,j)+G%mask2dCu(I,j)) + & + (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + 1.0e-37) + do k = 1, GV%ke+1 + CS%Coef_h(i,j,k) = normalize*G%mask2dT(i,j)*((Coef_x(I-1,j,k)+Coef_x(I,j,k)) + & + (Coef_y(i,J-1,k)+Coef_y(i,J,k))) + enddo + endif + enddo; enddo + call pass_var(CS%Coef_h,G%Domain) + endif + + nk = GV%ke + + do m = 1,Reg%ntr ! Loop over tracer registry + + tracer => Reg%Tr(m) + + ! for diagnostics + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 .or. & + tracer%id_dfx_2d > 0 .or. tracer%id_dfy_2d > 0) then + Idt = 1.0 / dt + tendency(:,:,:) = 0.0 + endif + + uFlx(:,:,:) = 0. + vFlx(:,:,:) = 0. + + ! x-flux + if (CS%KhTh_use_ebt_struct) then + if (CS%tapering) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(I,j), CS%hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & + h(I,j,:), h(I+1,j,:)) + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:)*CS%Coef_h(i,j,:), & + CS%coeff_r(:)*CS%Coef_h(i+1,j,:)) + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%Coef_h(i,j,:), & + CS%Coef_h(i+1,j,:)) + endif + enddo ; enddo + endif + else + if (CS%tapering) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(I,j), CS%hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & + h(I,j,:), h(I+1,j,:)) + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:), & + CS%coeff_r(:)) + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge) + endif + enddo ; enddo + endif + endif + + ! y-flux + if (CS%KhTh_use_ebt_struct) then + if (CS%tapering) then + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(i,J), CS%hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & + h(i,J,:), h(i,J+1,:)) + + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:)*CS%Coef_h(i,j,:), & + CS%coeff_r(:)*CS%Coef_h(i,j+1,:)) + endif + enddo ; enddo + else + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%Coef_h(i,j,:), & + CS%Coef_h(i,j+1,:)) + endif + enddo ; enddo + endif + else + if (CS%tapering) then + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(i,J), CS%hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & + h(i,J,:), h(i,J+1,:)) + + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:), & + CS%coeff_r(:)) + endif + enddo ; enddo + else + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge) + endif + enddo ; enddo + endif + endif + + ! Update the tracer concentration from divergence of neutral diffusive flux components, noting + ! that uFlx and vFlx use an unexpected sign convention. + if (CS%KhTh_use_ebt_struct) then + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + if (CS%ndiff_answer_date <= 20240330) then + dTracer(:) = 0. + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer(k) = dTracer(k) + uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer(k) = dTracer(k) - uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer(k) = dTracer(k) + vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer(k) = dTracer(k) - vFlx(i,J-1,ks) + enddo + else ! This form recovers rotational symmetry. + dTracer_N(:) = 0.0 ; dTracer_S(:) = 0.0 ; dTracer_E(:) = 0.0 ; dTracer_W(:) = 0.0 + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer_E(k) = dTracer_E(k) + uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer_W(k) = dTracer_W(k) - uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer_N(k) = dTracer_N(k) + vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer_S(k) = dTracer_S(k) - vFlx(i,J-1,ks) + enddo + do k = 1, GV%ke + dTracer(k) = (dTracer_N(k) + dTracer_S(k)) + (dTracer_E(k) + dTracer_W(k)) + enddo + endif + do k = 1, GV%ke + tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & + ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 + enddo + + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + do k = 1, GV%ke + tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt + enddo + endif + + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + if (CS%ndiff_answer_date <= 20240330) then + dTracer(:) = 0. + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer(k) = dTracer(k) + Coef_x(I,j,1) * uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer(k) = dTracer(k) - Coef_x(I-1,j,1) * uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer(k) = dTracer(k) + Coef_y(i,J,1) * vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer(k) = dTracer(k) - Coef_y(i,J-1,1) * vFlx(i,J-1,ks) + enddo + else ! This form recovers rotational symmetry. + dTracer_N(:) = 0.0 ; dTracer_S(:) = 0.0 ; dTracer_E(:) = 0.0 ; dTracer_W(:) = 0.0 + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer_E(k) = dTracer_E(k) + Coef_x(I,j,1) * uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer_W(k) = dTracer_W(k) - Coef_x(I-1,j,1) * uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer_N(k) = dTracer_N(k) + Coef_y(i,J,1) * vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer_S(k) = dTracer_S(k) - Coef_y(i,J-1,1) * vFlx(i,J-1,ks) + enddo + do k = 1, GV%ke + dTracer(k) = (dTracer_N(k) + dTracer_S(k)) + (dTracer_E(k) + dTracer_W(k)) + enddo + endif + do k = 1, GV%ke + tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & + ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 + enddo + + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + do k = 1, GV%ke + tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt + enddo + endif + + endif + enddo ; enddo + endif + + ! Do user controlled underflow of the tracer concentrations. + if (tracer%conc_underflow > 0.0) then + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif + + ! Diagnose vertically summed zonal flux, giving zonal tracer transport from ndiff. + ! Note sign corresponds to downgradient flux convention. + if (tracer%id_dfx_2d > 0) then + + if (CS%KhTh_use_ebt_struct) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + trans_x_2d(I,j) = 0. + if (G%mask2dCu(I,j)>0.) then + do ks = 1,CS%nsurf-1 + trans_x_2d(I,j) = trans_x_2d(I,j) - uFlx(I,j,ks) + enddo + trans_x_2d(I,j) = trans_x_2d(I,j) * Idt + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + trans_x_2d(I,j) = 0. + if (G%mask2dCu(I,j)>0.) then + do ks = 1,CS%nsurf-1 + trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j,1) * uFlx(I,j,ks) + enddo + trans_x_2d(I,j) = trans_x_2d(I,j) * Idt + endif + enddo ; enddo + endif + + call post_data(tracer%id_dfx_2d, trans_x_2d(:,:), CS%diag) + endif + + ! Diagnose vertically summed merid flux, giving meridional tracer transport from ndiff. + ! Note sign corresponds to downgradient flux convention. + if (tracer%id_dfy_2d > 0) then + + if (CS%KhTh_use_ebt_struct) then + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + trans_y_2d(i,J) = 0. + if (G%mask2dCv(i,J)>0.) then + do ks = 1,CS%nsurf-1 + trans_y_2d(i,J) = trans_y_2d(i,J) - vFlx(i,J,ks) + enddo + trans_y_2d(i,J) = trans_y_2d(i,J) * Idt + endif + enddo ; enddo + else + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + trans_y_2d(i,J) = 0. + if (G%mask2dCv(i,J)>0.) then + do ks = 1,CS%nsurf-1 + trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J,1) * vFlx(i,J,ks) + enddo + trans_y_2d(i,J) = trans_y_2d(i,J) * Idt + endif + enddo ; enddo + endif + + call post_data(tracer%id_dfy_2d, trans_y_2d(:,:), CS%diag) + endif + + ! post tendency of layer-integrated tracer content + if (tracer%id_dfxy_cont > 0) then + call post_data(tracer%id_dfxy_cont, tendency(:,:,:), CS%diag) + endif + + ! post depth summed tendency for tracer content + if (tracer%id_dfxy_cont_2d > 0) then + tendency_2d(:,:) = 0. + do j = G%jsc,G%jec ; do i = G%isc,G%iec + do k = 1, GV%ke + tendency_2d(i,j) = tendency_2d(i,j) + tendency(i,j,k) + enddo + enddo ; enddo + call post_data(tracer%id_dfxy_cont_2d, tendency_2d(:,:), CS%diag) + endif + + ! post tendency of tracer concentration; this step must be + ! done after posting tracer content tendency, since we alter + ! the tendency array. + if (tracer%id_dfxy_conc > 0) then + do k = 1, GV%ke ; do j = G%jsc,G%jec ; do i = G%isc,G%iec + tendency(i,j,k) = tendency(i,j,k) / ( h(i,j,k) + GV%H_subroundoff ) + enddo ; enddo ; enddo + call post_data(tracer%id_dfxy_conc, tendency, CS%diag) + endif + enddo ! Loop over tracer registry + +end subroutine neutral_diffusion + +!> Computes linear tapering coefficients at interfaces of the left and right columns +!! within a region defined by the boundary layer depths in the two columns. +subroutine compute_tapering_coeffs(ne, bld_l, bld_r, coeff_l, coeff_r, h_l, h_r) + integer, intent(in) :: ne !< Number of interfaces + real, intent(in) :: bld_l !< Boundary layer depth, left column [H ~> m or kg m-2] + real, intent(in) :: bld_r !< Boundary layer depth, right column [H ~> m or kg m-2] + real, dimension(ne-1), intent(in) :: h_l !< Layer thickness, left column [H ~> m or kg m-2] + real, dimension(ne-1), intent(in) :: h_r !< Layer thickness, right column [H ~> m or kg m-2] + real, dimension(ne), intent(inout) :: coeff_l !< Tapering coefficient, left column [nondim] + real, dimension(ne), intent(inout) :: coeff_r !< Tapering coefficient, right column [nondim] + + ! Local variables + real :: min_bld, max_bld ! Min/Max boundary layer depth in two adjacent columns + integer :: dummy1 ! dummy integer + real :: dummy2 ! dummy real [nondim] + integer :: k_min_l, k_min_r, k_max_l, k_max_r ! Min/max vertical indices in two adjacent columns + real :: zeta_l, zeta_r ! dummy variables [nondim] + integer :: k ! vertical index + + ! Initialize coefficients + coeff_l(:) = 1.0 + coeff_r(:) = 1.0 + + ! Calculate vertical indices containing the boundary layer depths + max_bld = MAX(bld_l, bld_r) + min_bld = MIN(bld_l, bld_r) + + ! k_min + call boundary_k_range(SURFACE, ne-1, h_l, min_bld, dummy1, dummy2, k_min_l, & + zeta_l) + call boundary_k_range(SURFACE, ne-1, h_r, min_bld, dummy1, dummy2, k_min_r, & + zeta_r) + + ! k_max + call boundary_k_range(SURFACE, ne-1, h_l, max_bld, dummy1, dummy2, k_max_l, & + zeta_l) + call boundary_k_range(SURFACE, ne-1, h_r, max_bld, dummy1, dummy2, k_max_r, & + zeta_r) + ! left + do k=1,k_min_l + coeff_l(k) = 0.0 + enddo + do k=k_min_l+1,k_max_l+1 + coeff_l(k) = (real(k - k_min_l) + 1.0)/(real(k_max_l - k_min_l) + 2.0) + enddo + + ! right + do k=1,k_min_r + coeff_r(k) = 0.0 + enddo + do k=k_min_r+1,k_max_r+1 + coeff_r(k) = (real(k - k_min_r) + 1.0)/(real(k_max_r - k_min_r) + 2.0) + enddo + +end subroutine compute_tapering_coeffs + +!> Returns interface scalar, Si, for a column of layer values, S. +subroutine interface_scalar(nk, h, S, Si, i_method, h_neglect) + integer, intent(in) :: nk !< Number of levels + real, dimension(nk), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(nk), intent(in) :: S !< Layer scalar (or concentrations) in arbitrary + !! concentration units (e.g. [C ~> degC] for temperature) + real, dimension(nk+1), intent(inout) :: Si !< Interface scalar (or concentrations) in arbitrary + !! concentration units (e.g. [C ~> degC] for temperature) + integer, intent(in) :: i_method !< =1 use average of PLM edges + !! =2 use continuous PPM edge interpolation + real, intent(in) :: h_neglect !< A negligibly small thickness [H ~> m or kg m-2] + ! Local variables + integer :: k, km2, kp1 + real, dimension(nk) :: diff ! Difference in scalar concentrations between layer centers in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature) + real :: Sb, Sa ! Values of scalar concentrations at the upper and lower edges of a layer in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature) + + call PLM_diff(nk, h, S, 2, 1, diff) + Si(1) = S(1) - 0.5 * diff(1) + if (i_method==1) then + do k = 2, nk + ! Average of the two edge values (will be bounded and, + ! when slopes are unlimited, notionally second-order accurate) + Sa = S(k-1) + 0.5 * diff(k-1) ! Lower edge value of a PLM reconstruction for layer above + Sb = S(k) - 0.5 * diff(k) ! Upper edge value of a PLM reconstruction for layer below + Si(k) = 0.5 * ( Sa + Sb ) + enddo + elseif (i_method==2) then + do k = 2, nk + ! PPM quasi-fourth order interpolation for edge values following + ! equation 1.6 in Colella & Woodward, 1984: JCP 54, 174-201. + km2 = max(1, k-2) + kp1 = min(nk, k+1) + Si(k) = ppm_edge(h(km2), h(k-1), h(k), h(kp1), S(k-1), S(k), diff(k-1), diff(k), h_neglect) + enddo + endif + Si(nk+1) = S(nk) + 0.5 * diff(nk) + +end subroutine interface_scalar + +!> Returns the PPM quasi-fourth order edge value at k+1/2 following +!! equation 1.6 in Colella & Woodward, 1984: JCP 54, 174-201. +real function ppm_edge(hkm1, hk, hkp1, hkp2, Ak, Akp1, Pk, Pkp1, h_neglect) + real, intent(in) :: hkm1 !< Width of cell k-1 in [H ~> m or kg m-2] or other units + real, intent(in) :: hk !< Width of cell k in [H ~> m or kg m-2] or other units + real, intent(in) :: hkp1 !< Width of cell k+1 in [H ~> m or kg m-2] or other units + real, intent(in) :: hkp2 !< Width of cell k+2 in [H ~> m or kg m-2] or other units + real, intent(in) :: Ak !< Average scalar value of cell k in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Akp1 !< Average scalar value of cell k+1 in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Pk !< PLM slope for cell k in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Pkp1 !< PLM slope for cell k+1 in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: h_neglect !< A negligibly small thickness [H ~> m or kg m-2] + + ! Local variables + real :: R_hk_hkp1, R_2hk_hkp1, R_hk_2hkp1 ! Reciprocals of combinations of thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: f1 ! A work variable with units of an inverse cell width [H-1 ~> m-1 or m2 kg-1] + real :: f2, f3, f4 ! Work variables with units of the cell width [H ~> m or kg m-2] + + R_hk_hkp1 = hk + hkp1 + if (R_hk_hkp1 <= 0.) then + ppm_edge = 0.5 * ( Ak + Akp1 ) + return + endif + R_hk_hkp1 = 1. / R_hk_hkp1 + if (hk Returns the average of a PPM reconstruction between two fractional positions in the same +!! arbitrary concentration units as aMean (e.g. usually [C ~> degC] for temperature) +real function ppm_ave(xL, xR, aL, aR, aMean) + real, intent(in) :: xL !< Fraction position of left bound (0,1) [nondim] + real, intent(in) :: xR !< Fraction position of right bound (0,1) [nondim] + real, intent(in) :: aL !< Left edge scalar value, at x=0, in arbitrary concentration + !! units (e.g. usually [C ~> degC] for temperature) + real, intent(in) :: aR !< Right edge scalar value, at x=1 in arbitrary concentration + !! units (e.g. usually [C ~> degC] for temperature) + real, intent(in) :: aMean !< Average scalar value of cell in arbitrary concentration + !! units (e.g. usually [C ~> degC] for temperature) + + ! Local variables + real :: dx ! Distance between the bounds [nondim] + real :: xave ! Average fractional position [nondim] + real :: a6, a6o3 ! Terms proportional to the normalized scalar curvature in the same arbitrary + ! concentration units as aMean (e.g. usually [C ~> degC] for temperature) + + dx = xR - xL + xave = 0.5 * ( xR + xL ) + a6o3 = 2. * aMean - ( aL + aR ) ! a6 / 3. + a6 = 3. * a6o3 + + if (dx<0.) then + stop 'ppm_ave: dx<0 should not happened!' + elseif (dx>1.) then + stop 'ppm_ave: dx>1 should not happened!' + elseif (dx==0.) then + ppm_ave = aL + ( aR - aL ) * xR + a6 * xR * ( 1. - xR ) + else + ppm_ave = ( aL + xave * ( ( aR - aL ) + a6 ) ) - a6o3 * ( xR**2 + xR * xL + xL**2 ) + endif +end function ppm_ave + +!> A true signum function that returns either -abs(a), when x<0; or abs(a) when x>0; or 0 when x=0. +!! The returned units are the same as those of a [arbitrary]. +real function signum(a,x) + real, intent(in) :: a !< The magnitude argument in arbitrary units [arbitrary] + real, intent(in) :: x !< The sign (or zero) argument [arbitrary] + + signum = sign(a,x) + if (x==0.) signum = 0. + +end function signum + +!> Returns PLM slopes for a column where the slopes are the difference in value across each cell. +!! The limiting follows equation 1.8 in Colella & Woodward, 1984: JCP 54, 174-201. +subroutine PLM_diff(nk, h, S, c_method, b_method, diff) + integer, intent(in) :: nk !< Number of levels + real, dimension(nk), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] or other units + real, dimension(nk), intent(in) :: S !< Layer salinity (conc, e.g. ppt) or other tracer + !! concentration in arbitrary units [A ~> a] + integer, intent(in) :: c_method !< Method to use for the centered difference + integer, intent(in) :: b_method !< =1, use PCM in first/last cell, =2 uses linear extrapolation + real, dimension(nk), intent(inout) :: diff !< Scalar difference across layer (conc, e.g. ppt) + !! in the same arbitrary units as S [A ~> a], + !! determined by the following values for c_method: + !! 1. Second order finite difference (not recommended) + !! 2. Second order finite volume (used in original PPM) + !! 3. Finite-volume weighted least squares linear fit + !! \todo The use of c_method to choose a scheme is inefficient + !! and should eventually be moved up the call tree. + + ! Local variables + integer :: k + real :: hkm1, hk, hkp1 ! Successive layer thicknesses [H ~> m or kg m-2] or other units + real :: Skm1, Sk, Skp1 ! Successive layer tracer concentrations in the same arbitrary units as S [A ~> a] + real :: diff_l, diff_r, diff_c ! Differences in tracer concentrations in arbitrary units [A ~> a] + + do k = 2, nk-1 + hkm1 = h(k-1) + hk = h(k) + hkp1 = h(k+1) + + if ( ( hkp1 + hk ) * ( hkm1 + hk ) > 0.) then + Skm1 = S(k-1) + Sk = S(k) + Skp1 = S(k+1) + if (c_method==1) then + ! Simple centered diff (from White) + if ( hk + 0.5 * (hkm1 + hkp1) /= 0. ) then + diff_c = ( Skp1 - Skm1 ) * ( hk / ( hk + 0.5 * (hkm1 + hkp1) ) ) + else + diff_c = 0. + endif + elseif (c_method==2) then + ! Second order accurate centered finite-volume slope (from Colella and Woodward, JCP 1984) + diff_c = fv_diff(hkm1, hk, hkp1, Skm1, Sk, Skp1) + elseif (c_method==3) then + ! Second order accurate finite-volume least squares slope + diff_c = hk * fvlsq_slope(hkm1, hk, hkp1, Skm1, Sk, Skp1) + endif + ! Limit centered slope by twice the side differenced slopes + diff_l = 2. * ( Sk - Skm1 ) + diff_r = 2. * ( Skp1 - Sk ) + if ( signum(1., diff_l) * signum(1., diff_r) <= 0. ) then + diff(k) = 0. ! PCM for local extrema + else + diff(k) = sign( min( abs(diff_l), abs(diff_c), abs(diff_r) ), diff_c ) + endif + else + diff(k) = 0. ! PCM next to vanished layers + endif + enddo + if (b_method==1) then ! PCM for top and bottom layer + diff(1) = 0. + diff(nk) = 0. + elseif (b_method==2) then ! Linear extrapolation for top and bottom interfaces + diff(1) = ( S(2) - S(1) ) * 2. * ( h(1) / ( h(1) + h(2) ) ) + diff(nk) = S(nk) - S(nk-1) * 2. * ( h(nk) / ( h(nk-1) + h(nk) ) ) + endif + +end subroutine PLM_diff + +!> Returns the cell-centered second-order finite volume (unlimited PLM) slope +!! using three consecutive cell widths and average values. Slope is returned +!! as a difference across the central cell (i.e. units of scalar S). +!! Discretization follows equation 1.7 in Colella & Woodward, 1984: JCP 54, 174-201. +real function fv_diff(hkm1, hk, hkp1, Skm1, Sk, Skp1) + real, intent(in) :: hkm1 !< Left cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: hk !< Center cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: hkp1 !< Right cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: Skm1 !< Left cell average value in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Sk !< Center cell average value in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Skp1 !< Right cell average value in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + + ! Local variables + real :: h_sum, hp, hm ! At first sums of thicknesses [H ~> m or kg m-2], then changed into + ! their reciprocals [H-1 ~> m-1 or m2 kg-1] + + h_sum = ( hkm1 + hkp1 ) + hk + if (h_sum /= 0.) h_sum = 1./ h_sum + hm = hkm1 + hk + if (hm /= 0.) hm = 1./ hm + hp = hkp1 + hk + if (hp /= 0.) hp = 1./ hp + fv_diff = ( hk * h_sum ) * & + ( ( 2. * hkm1 + hk ) * hp * ( Skp1 - Sk ) & + + ( 2. * hkp1 + hk ) * hm * ( Sk - Skm1 ) ) +end function fv_diff + + +!> Returns the cell-centered second-order weighted least squares slope +!! using three consecutive cell widths and average values. Slope is returned +!! as a gradient (i.e. units of scalar S over width units). For example, for temperature +!! fvlsq_slope would usually be returned in units of [C H-1 ~> degC m-1 or degC m2 kg-1]. +real function fvlsq_slope(hkm1, hk, hkp1, Skm1, Sk, Skp1) + real, intent(in) :: hkm1 !< Left cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: hk !< Center cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: hkp1 !< Right cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: Skm1 !< Left cell average value in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Sk !< Center cell average value often in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Skp1 !< Right cell average value often in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + + ! Local variables + real :: xkm1, xkp1 ! Distances between layer centers [H ~> m or kg m-2] or other arbitrary units + real :: h_sum ! Sum of the successive cell widths [H ~> m or kg m-2] or other arbitrary units + real :: hx_sum ! Thicknesses times distances [H2 ~> m2 or kg2 m-4] + real :: hxsq_sum ! Thicknesses times squared distances [H3 ~> m3 or kg3 m-6] + real :: det ! The denominator in the weighted slope calculation [H4 ~> m4 or kg4 m-8] + real :: hxy_sum ! Sum of layer concentrations times thicknesses and distances in units that + ! depend on those of Sk (e.g. [C H2 ~> degC m2 or degC kg2 m-4] for temperature) + real :: hy_sum ! Sum of layer concentrations times thicknesses in units that depend on + ! those of Sk (e.g. [C H ~> degC m or degC kg m-2] for temperature) + + xkm1 = -0.5 * ( hk + hkm1 ) + xkp1 = 0.5 * ( hk + hkp1 ) + h_sum = ( hkm1 + hkp1 ) + hk + hx_sum = hkm1*xkm1 + hkp1*xkp1 + hxsq_sum = hkm1*(xkm1**2) + hkp1*(xkp1**2) + hxy_sum = hkm1*xkm1*Skm1 + hkp1*xkp1*Skp1 + hy_sum = ( hkm1*Skm1 + hkp1*Skp1 ) + hk*Sk + det = h_sum * hxsq_sum - hx_sum**2 + if (det /= 0.) then + !a = ( hxsq_sum * hy_sum - hx_sum*hxy_sum ) / det ! a would be mean of straight line fit + fvlsq_slope = ( h_sum * hxy_sum - hx_sum*hy_sum ) / det ! Gradient of straight line fit + else + fvlsq_slope = 0. ! Adcroft's reciprocal rule + endif +end function fvlsq_slope + + +!> Returns positions within left/right columns of combined interfaces using continuous reconstructions of T/S +subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdSl, Pr, Tr, Sr, & + dRdTr, dRdSr, PoL, PoR, KoL, KoR, hEff, bl_kl, bl_kr, bl_zl, bl_zr) + integer, intent(in) :: nk !< Number of levels + real, dimension(nk+1), intent(in) :: Pl !< Left-column interface pressure [R L2 T-2 ~> Pa] or other units + real, dimension(nk+1), intent(in) :: Tl !< Left-column interface potential temperature [C ~> degC] + real, dimension(nk+1), intent(in) :: Sl !< Left-column interface salinity [S ~> ppt] + real, dimension(nk+1), intent(in) :: dRdTl !< Left-column dRho/dT [R C-1 ~> kg m-3 degC-1] + real, dimension(nk+1), intent(in) :: dRdSl !< Left-column dRho/dS [R S-1 ~> kg m-3 ppt-1] + real, dimension(nk+1), intent(in) :: Pr !< Right-column interface pressure [R L2 T-2 ~> Pa] or other units + real, dimension(nk+1), intent(in) :: Tr !< Right-column interface potential temperature [C ~> degC] + real, dimension(nk+1), intent(in) :: Sr !< Right-column interface salinity [S ~> ppt] + real, dimension(nk+1), intent(in) :: dRdTr !< Left-column dRho/dT [R C-1 ~> kg m-3 degC-1] + real, dimension(nk+1), intent(in) :: dRdSr !< Left-column dRho/dS [R S-1 ~> kg m-3 ppt-1] + real, dimension(2*nk+2), intent(inout) :: PoL !< Fractional position of neutral surface within + !! layer KoL of left column [nondim] + real, dimension(2*nk+2), intent(inout) :: PoR !< Fractional position of neutral surface within + !! layer KoR of right column [nondim] + integer, dimension(2*nk+2), intent(inout) :: KoL !< Index of first left interface above neutral surface + integer, dimension(2*nk+2), intent(inout) :: KoR !< Index of first right interface above neutral surface + real, dimension(2*nk+1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces + !! [R L2 T-2 ~> Pa] or other units following Pl and Pr. + integer, optional, intent(in) :: bl_kl !< Layer index of the boundary layer (left) + integer, optional, intent(in) :: bl_kr !< Layer index of the boundary layer (right) + real, optional, intent(in) :: bl_zl !< Fractional position of the boundary layer (left) [nondim] + real, optional, intent(in) :: bl_zr !< Fractional position of the boundary layer (right) [nondim] + + ! Local variables + integer :: ns ! Number of neutral surfaces + integer :: k_surface ! Index of neutral surface + integer :: kl ! Index of left interface + integer :: kr ! Index of right interface + logical :: searching_left_column ! True if searching for the position of a right interface in the left column + logical :: searching_right_column ! True if searching for the position of a left interface in the right column + logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target + integer :: krm1, klm1 + real :: dRho, dRhoTop, dRhoBot ! Potential density differences at various points [R ~> kg m-3] + real :: hL, hR ! Pressure thicknesses [R L2 T-2 ~> Pa] + integer :: lastK_left, lastK_right ! Layers used during the last iteration + real :: lastP_left, lastP_right ! Fractional positions during the last iteration [nondim] + logical :: interior_limit + + ns = 2*nk+2 + + ! Initialize variables for the search + kr = 1 ; + kl = 1 ; + lastP_right = 0. + lastP_left = 0. + lastK_right = 1 + lastK_left = 1 + reached_bottom = .false. + + ! Check to see if we should limit the diffusion to the interior + interior_limit = PRESENT(bl_kl) .and. PRESENT(bl_kr) .and. PRESENT(bl_zr) .and. PRESENT(bl_zl) + + ! Loop over each neutral surface, working from top to bottom + neutral_surfaces: do k_surface = 1, ns + klm1 = max(kl-1, 1) + if (klm1>nk) stop 'find_neutral_surface_positions(): klm1 went out of bounds!' + krm1 = max(kr-1, 1) + if (krm1>nk) stop 'find_neutral_surface_positions(): krm1 went out of bounds!' + + ! Potential density difference, rho(kr) - rho(kl) + dRho = 0.5 * ( ( dRdTr(kr) + dRdTl(kl) ) * ( Tr(kr) - Tl(kl) ) & + + ( dRdSr(kr) + dRdSl(kl) ) * ( Sr(kr) - Sl(kl) ) ) + ! Which column has the lighter surface for the current indexes, kr and kl + if (.not. reached_bottom) then + if (dRho < 0.) then + searching_left_column = .true. + searching_right_column = .false. + elseif (dRho > 0.) then + searching_right_column = .true. + searching_left_column = .false. + else ! dRho == 0. + if (kl + kr == 2) then ! Still at surface + searching_left_column = .true. + searching_right_column = .false. + else ! Not the surface so we simply change direction + searching_left_column = .not. searching_left_column + searching_right_column = .not. searching_right_column + endif + endif + endif + + if (searching_left_column) then + ! Interpolate for the neutral surface position within the left column, layer klm1 + ! Potential density difference, rho(kl-1) - rho(kr) (should be negative) + dRhoTop = 0.5 * ( ( dRdTl(klm1) + dRdTr(kr) ) * ( Tl(klm1) - Tr(kr) ) & + + ( dRdSl(klm1) + dRdSr(kr) ) * ( Sl(klm1) - Sr(kr) ) ) + ! Potential density difference, rho(kl) - rho(kr) (will be positive) + dRhoBot = 0.5 * ( ( dRdTl(klm1+1) + dRdTr(kr) ) * ( Tl(klm1+1) - Tr(kr) ) & + + ( dRdSl(klm1+1) + dRdSr(kr) ) * ( Sl(klm1+1) - Sr(kr) ) ) + + ! Because we are looking left, the right surface, kr, is lighter than klm1+1 and should be denser than klm1 + ! unless we are still at the top of the left column (kl=1) + if (dRhoTop > 0. .or. kr+kl==2) then + PoL(k_surface) = 0. ! The right surface is lighter than anything in layer klm1 + elseif (dRhoTop >= dRhoBot) then ! Left layer is unstratified + PoL(k_surface) = 1. + else + ! Linearly interpolate for the position between Pl(kl-1) and Pl(kl) where the density difference + ! between right and left is zero. The Pl here are only used to handle massless layers. + PoL(k_surface) = interpolate_for_nondim_position( dRhoTop, Pl(klm1), dRhoBot, Pl(klm1+1) ) + endif + if (PoL(k_surface)>=1. .and. klm1= is really ==, when PoL==1 we point to the bottom of the cell + klm1 = klm1 + 1 + PoL(k_surface) = PoL(k_surface) - 1. + endif + if (real(klm1-lastK_left)+(PoL(k_surface)-lastP_left)<0.) then + PoL(k_surface) = lastP_left + klm1 = lastK_left + endif + KoL(k_surface) = klm1 + if (kr <= nk) then + PoR(k_surface) = 0. + KoR(k_surface) = kr + else + PoR(k_surface) = 1. + KoR(k_surface) = nk + endif + if (kr <= nk) then + kr = kr + 1 + else + reached_bottom = .true. + searching_right_column = .true. + searching_left_column = .false. + endif + elseif (searching_right_column) then + ! Interpolate for the neutral surface position within the right column, layer krm1 + ! Potential density difference, rho(kr-1) - rho(kl) (should be negative) + dRhoTop = 0.5 * ( ( dRdTr(krm1) + dRdTl(kl) ) * ( Tr(krm1) - Tl(kl) ) + & + ( dRdSr(krm1) + dRdSl(kl) ) * ( Sr(krm1) - Sl(kl) ) ) + ! Potential density difference, rho(kr) - rho(kl) (will be positive) + dRhoBot = 0.5 * ( ( dRdTr(krm1+1) + dRdTl(kl) ) * ( Tr(krm1+1) - Tl(kl) ) + & + ( dRdSr(krm1+1) + dRdSl(kl) ) * ( Sr(krm1+1) - Sl(kl) ) ) + + ! Because we are looking right, the left surface, kl, is lighter than krm1+1 and should be denser than krm1 + ! unless we are still at the top of the right column (kr=1) + if (dRhoTop >= 0. .or. kr+kl==2) then + PoR(k_surface) = 0. ! The left surface is lighter than anything in layer krm1 + elseif (dRhoTop >= dRhoBot) then ! Right layer is unstratified + PoR(k_surface) = 1. + else + ! Linearly interpolate for the position between Pr(kr-1) and Pr(kr) where the density difference + ! between right and left is zero. The Pr here are only used to handle massless layers. + PoR(k_surface) = interpolate_for_nondim_position( dRhoTop, Pr(krm1), dRhoBot, Pr(krm1+1) ) + endif + if (PoR(k_surface)>=1. .and. krm1= is really ==, when PoR==1 we point to the bottom of the cell + krm1 = krm1 + 1 + PoR(k_surface) = PoR(k_surface) - 1. + endif + if (real(krm1-lastK_right)+(PoR(k_surface)-lastP_right)<0.) then + PoR(k_surface) = lastP_right + krm1 = lastK_right + endif + KoR(k_surface) = krm1 + if (kl <= nk) then + PoL(k_surface) = 0. + KoL(k_surface) = kl + else + PoL(k_surface) = 1. + KoL(k_surface) = nk + endif + if (kl <= nk) then + kl = kl + 1 + else + reached_bottom = .true. + searching_right_column = .false. + searching_left_column = .true. + endif + else + stop 'Else what?' + endif + if (interior_limit) then + if (KoL(k_surface)<=bl_kl) then + KoL(k_surface) = bl_kl + if (PoL(k_surface)1) then + hL = absolute_position(nk,ns,Pl,KoL,PoL,k_surface) - absolute_position(nk,ns,Pl,KoL,PoL,k_surface-1) + hR = absolute_position(nk,ns,Pr,KoR,PoR,k_surface) - absolute_position(nk,ns,Pr,KoR,PoR,k_surface-1) + if ( hL + hR > 0.) then + hEff(k_surface-1) = 2. * hL * hR / ( hL + hR ) ! Harmonic mean of layer thicknesses + else + hEff(k_surface-1) = 0. + endif + endif + + enddo neutral_surfaces + +end subroutine find_neutral_surface_positions_continuous + +!> Returns the non-dimensional position between Pneg and Ppos where the +!! interpolated density difference equals zero. +!! The result is always bounded to be between 0 and 1. +real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) + real, intent(in) :: dRhoNeg !< Negative density difference [R ~> kg m-3] + real, intent(in) :: Pneg !< Position of negative density difference [R L2 T-2 ~> Pa] or [nondim] + real, intent(in) :: dRhoPos !< Positive density difference [R ~> kg m-3] + real, intent(in) :: Ppos !< Position of positive density difference [R L2 T-2 ~> Pa] or [nondim] + + character(len=120) :: mesg + + if (Ppos < Pneg) then + call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! PposdRhoPos) then + write(stderr,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=',dRhoNeg, Pneg, dRhoPos, Ppos + write(mesg,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=', dRhoNeg, Pneg, dRhoPos, Ppos + call MOM_error(WARNING, 'interpolate_for_nondim_position: '//trim(mesg)) + elseif (dRhoNeg>dRhoPos) then !### Does this duplicated test belong here? + call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! dRhoNeg>dRhoPos') + endif + if (Ppos<=Pneg) then ! Handle vanished or inverted layers + interpolate_for_nondim_position = 0.5 + elseif ( dRhoPos - dRhoNeg > 0. ) then + interpolate_for_nondim_position = min( 1., max( 0., -dRhoNeg / ( dRhoPos - dRhoNeg ) ) ) + elseif ( dRhoPos - dRhoNeg == 0) then + if (dRhoNeg>0.) then + interpolate_for_nondim_position = 0. + elseif (dRhoNeg<0.) then + interpolate_for_nondim_position = 1. + else ! dRhoPos = dRhoNeg = 0 + interpolate_for_nondim_position = 0.5 + endif + else ! dRhoPos - dRhoNeg < 0 + interpolate_for_nondim_position = 0.5 + endif + if ( interpolate_for_nondim_position < 0. ) & + call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! Pint < Pneg') + if ( interpolate_for_nondim_position > 1. ) & + call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos') +end function interpolate_for_nondim_position + +!> Higher order version of find_neutral_surface_positions. Returns positions within left/right columns +!! of combined interfaces using intracell reconstructions of T/S. Note that the polynomial reconstructions +!! of T and S are optional to aid with unit testing, but will always be passed otherwise +subroutine find_neutral_surface_positions_discontinuous(CS, nk, & + Pres_l, hcol_l, Tl, Sl, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hcol_r, Tr, Sr, ppoly_T_r, ppoly_S_r, stable_r, & + PoL, PoR, KoL, KoR, hEff, zeta_bot_L, zeta_bot_R, k_bot_L, k_bot_R, hard_fail_heff) + + type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure + integer, intent(in) :: nk !< Number of levels + real, dimension(nk,2), intent(in) :: Pres_l !< Left-column interface pressure [R L2 T-2 ~> Pa] + real, dimension(nk), intent(in) :: hcol_l !< Left-column layer thicknesses [H ~> m or kg m-2] + !! or other units + real, dimension(nk,2), intent(in) :: Tl !< Left-column top interface potential + !! temperature [C ~> degC] + real, dimension(nk,2), intent(in) :: Sl !< Left-column top interface salinity [S ~> ppt] + real, dimension(:,:), intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction [C ~> degC] + real, dimension(:,:), intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction [S ~> ppt] + logical, dimension(nk), intent(in) :: stable_l !< True where the left-column is stable + real, dimension(nk,2), intent(in) :: Pres_r !< Right-column interface pressure [R L2 T-2 ~> Pa] + real, dimension(nk), intent(in) :: hcol_r !< Left-column layer thicknesses [H ~> m or kg m-2] + !! or other units + real, dimension(nk,2), intent(in) :: Tr !< Right-column top interface potential + !! temperature [C ~> degC] + real, dimension(nk,2), intent(in) :: Sr !< Right-column top interface salinity [S ~> ppt] + real, dimension(:,:), intent(in) :: ppoly_T_r !< Right-column coefficients of T + !! reconstruction [C ~> degC] + real, dimension(:,:), intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction [S ~> ppt] + logical, dimension(nk), intent(in) :: stable_r !< True where the right-column is stable + real, dimension(4*nk), intent(inout) :: PoL !< Fractional position of neutral surface within + !! layer KoL of left column [nondim] + real, dimension(4*nk), intent(inout) :: PoR !< Fractional position of neutral surface within + !! layer KoR of right column [nondim] + integer, dimension(4*nk), intent(inout) :: KoL !< Index of first left interface above neutral surface + integer, dimension(4*nk), intent(inout) :: KoR !< Index of first right interface above neutral surface + real, dimension(4*nk-1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces + !! [H ~> m or kg m-2] or other units taken from hcol_l + real, optional, intent(in) :: zeta_bot_L!< Non-dimensional distance to where the boundary layer + !! intersects the cell (left) [nondim] + real, optional, intent(in) :: zeta_bot_R!< Non-dimensional distance to where the boundary layer + !! intersects the cell (right) [nondim] + + integer, optional, intent(in) :: k_bot_L !< k-index for the boundary layer (left) [nondim] + integer, optional, intent(in) :: k_bot_R !< k-index for the boundary layer (right) [nondim] + logical, optional, intent(in) :: hard_fail_heff !< If true (default) bring down the model if the + !! neutral surfaces ever cross + ! Local variables + integer :: ns ! Number of neutral surfaces + integer :: k_surface ! Index of neutral surface + integer :: kl_left, kl_right ! Index of layers on the left/right + integer :: ki_left, ki_right ! Index of interfaces on the left/right + logical :: searching_left_column ! True if searching for the position of a right interface in the left column + logical :: searching_right_column ! True if searching for the position of a left interface in the right column + logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target + logical :: fail_heff ! Fail if negative thickness are encountered. By default this + ! is true, but it can take its value from hard_fail_heff. + real :: dRho ! A density difference between columns [R ~> kg m-3] + real :: hL, hR ! Left and right layer thicknesses [H ~> m or kg m-2] or units from hcol_l + real :: lastP_left, lastP_right ! Previous positions for left and right [nondim] + integer :: k_init_L, k_init_R ! Starting indices layers for left and right + real :: p_init_L, p_init_R ! Starting positions for left and right [nondim] + ! Initialize variables for the search + ns = 4*nk + ki_right = 1 + ki_left = 1 + kl_left = 1 + kl_right = 1 + lastP_left = 0. + lastP_right = 0. + reached_bottom = .false. + searching_left_column = .false. + searching_right_column = .false. + + fail_heff = .true. + if (PRESENT(hard_fail_heff)) fail_heff = hard_fail_heff + + if (PRESENT(k_bot_L) .and. PRESENT(k_bot_R) .and. PRESENT(zeta_bot_L) .and. PRESENT(zeta_bot_R)) then + k_init_L = k_bot_L; k_init_R = k_bot_R + p_init_L = zeta_bot_L; p_init_R = zeta_bot_R + lastP_left = zeta_bot_L; lastP_right = zeta_bot_R + kl_left = k_bot_L; kl_right = k_bot_R + else + k_init_L = 1 ; k_init_R = 1 + p_init_L = 0. ; p_init_R = 0. + endif + ! Loop over each neutral surface, working from top to bottom + neutral_surfaces: do k_surface = 1, ns + + if (k_surface == ns) then + PoL(k_surface) = 1. + PoR(k_surface) = 1. + KoL(k_surface) = nk + KoR(k_surface) = nk + ! If the layers are unstable, then simply point the surface to the previous location + elseif (.not. stable_l(kl_left)) then + if (k_surface > 1) then + PoL(k_surface) = ki_left - 1 ! Top interface is at position = 0., Bottom is at position = 1 + KoL(k_surface) = kl_left + PoR(k_surface) = PoR(k_surface-1) + KoR(k_surface) = KoR(k_surface-1) + else + PoR(k_surface) = p_init_R + KoR(k_surface) = k_init_R + PoL(k_surface) = p_init_L + KoL(k_Surface) = k_init_L + endif + call increment_interface(nk, kl_left, ki_left, reached_bottom, searching_left_column, searching_right_column) + searching_left_column = .true. + searching_right_column = .false. + elseif (.not. stable_r(kl_right)) then ! Check the right layer for stability + if (k_surface > 1) then + PoR(k_surface) = ki_right - 1 ! Top interface is at position = 0., Bottom is at position = 1 + KoR(k_surface) = kl_right + PoL(k_surface) = PoL(k_surface-1) + KoL(k_surface) = KoL(k_surface-1) + else + PoR(k_surface) = 0. + KoR(k_surface) = 1 + PoL(k_surface) = 0. + KoL(k_surface) = 1 + endif + call increment_interface(nk, kl_right, ki_right, reached_bottom, searching_right_column, searching_left_column) + searching_left_column = .false. + searching_right_column = .true. + else ! Layers are stable so need to figure out whether we need to search right or left + ! For convenience, the left column uses the searched "from" interface variables, and the right column + ! uses the searched 'to'. These will get reset in subsequent calc_delta_rho calls + + call calc_delta_rho_and_derivs(CS, & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right), & + Tl(kl_left, ki_left), Sl(kl_left, ki_left) , Pres_l(kl_left,ki_left), & + dRho) + if (CS%debug) write(stdout,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') & + "k_surface=",k_surface, " dRho=",CS%R_to_kg_m3*dRho, & + "kl_left=",kl_left, " ki_left=",ki_left, " kl_right=",kl_right, " ki_right=",ki_right + ! Which column has the lighter surface for the current indexes, kr and kl + if (.not. reached_bottom) then + if (dRho < 0.) then + searching_left_column = .true. + searching_right_column = .false. + elseif (dRho > 0.) then + searching_left_column = .false. + searching_right_column = .true. + else ! dRho == 0. + if ( ( kl_left + kl_right == 2 ) .and. (ki_left + ki_right == 2) ) then ! Still at surface + searching_left_column = .true. + searching_right_column = .false. + else ! Not the surface so we simply change direction + searching_left_column = .not. searching_left_column + searching_right_column = .not. searching_right_column + endif + endif + endif + if (searching_left_column) then + ! Position of the right interface is known and all quantities are fixed + PoR(k_surface) = ki_right - 1. + KoR(k_surface) = kl_right + PoL(k_surface) = search_other_column(CS, k_surface, lastP_left, & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & + Tl(kl_left,1), Sl(kl_left,1), Pres_l(kl_left,1), & + Tl(kl_left,2), Sl(kl_left,2), Pres_l(kl_left,2), & + ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:)) + KoL(k_surface) = kl_left + + if (CS%debug) then + write(stdout,'(A,I2)') "Searching left layer ", kl_left + write(stdout,'(A,I2,1X,I2)') "Searching from right: ", kl_right, ki_right + write(stdout,*) "Temp/Salt Reference: ", Tr(kl_right,ki_right), Sr(kl_right,ki_right) + write(stdout,*) "Temp/Salt Top L: ", Tl(kl_left,1), Sl(kl_left,1) + write(stdout,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) + endif + call increment_interface(nk, kl_right, ki_right, reached_bottom, searching_right_column, searching_left_column) + lastP_left = PoL(k_surface) + ! If the right layer increments, then we need to reset the last position on the right + if ( kl_right == (KoR(k_surface) + 1) ) lastP_right = 0. + + elseif (searching_right_column) then + ! Position of the right interface is known and all quantities are fixed + PoL(k_surface) = ki_left - 1. + KoL(k_surface) = kl_left + PoR(k_surface) = search_other_column(CS, k_surface, lastP_right, & + Tl(kl_left, ki_left), Sl(kl_left, ki_left), Pres_l(kl_left, ki_left), & + Tr(kl_right,1), Sr(kl_right,1), Pres_r(kl_right,1), & + Tr(kl_right,2), Sr(kl_right,2), Pres_r(kl_right,2), & + ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:)) + KoR(k_surface) = kl_right + + if (CS%debug) then + write(stdout,'(A,I2)') "Searching right layer ", kl_right + write(stdout,'(A,I2,1X,I2)') "Searching from left: ", kl_left, ki_left + write(stdout,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) + write(stdout,*) "Temp/Salt Top L: ", Tr(kl_right,1), Sr(kl_right,1) + write(stdout,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2) + endif + call increment_interface(nk, kl_left, ki_left, reached_bottom, searching_left_column, searching_right_column) + lastP_right = PoR(k_surface) + ! If the right layer increments, then we need to reset the last position on the right + if ( kl_left == (KoL(k_surface) + 1) ) lastP_left = 0. + else + stop 'Else what?' + endif + if (CS%debug) write(stdout,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), & + " KoR:", KoR(k_surface), " PoR:", PoR(k_surface) + endif + ! Effective thickness + if (k_surface>1) then + if ( KoL(k_surface) == KoL(k_surface-1) .and. KoR(k_surface) == KoR(k_surface-1) ) then + hL = (PoL(k_surface) - PoL(k_surface-1))*hcol_l(KoL(k_surface)) + hR = (PoR(k_surface) - PoR(k_surface-1))*hcol_r(KoR(k_surface)) + if (hL < 0. .or. hR < 0.) then + if (fail_heff) then + call MOM_error(FATAL,"Negative thicknesses in neutral diffusion") + else + if (searching_left_column) then + PoL(k_surface) = PoL(k_surface-1) + KoL(k_surface) = KoL(k_surface-1) + elseif (searching_right_column) then + PoR(k_surface) = PoR(k_surface-1) + KoR(k_surface) = KoR(k_surface-1) + endif + endif + elseif ( hL + hR == 0. ) then + hEff(k_surface-1) = 0. + else + hEff(k_surface-1) = 2. * ( (hL * hR) / ( hL + hR ) )! Harmonic mean + if ( KoL(k_surface) /= KoL(k_surface-1) ) then + call MOM_error(FATAL,"Neutral sublayer spans multiple layers") + endif + if ( KoR(k_surface) /= KoR(k_surface-1) ) then + call MOM_error(FATAL,"Neutral sublayer spans multiple layers") + endif + endif + else + hEff(k_surface-1) = 0. + endif + endif + enddo neutral_surfaces +end subroutine find_neutral_surface_positions_discontinuous + +!> Sweep down through the column and mark as stable if the bottom interface of a cell is denser than the top +subroutine mark_unstable_cells(CS, nk, T, S, P, stable_cell) + type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure + integer, intent(in) :: nk !< Number of levels in a column + real, dimension(nk,2), intent(in) :: T !< Temperature at interfaces [C ~> degC] + real, dimension(nk,2), intent(in) :: S !< Salinity at interfaces [S ~> ppt] + real, dimension(nk,2), intent(in) :: P !< Pressure at interfaces [R L2 T-2 ~> Pa] + logical, dimension(nk), intent( out) :: stable_cell !< True if this cell is unstably stratified + + integer :: k + real :: delta_rho ! A density difference [R ~> kg m-3] + + do k = 1,nk + call calc_delta_rho_and_derivs( CS, T(k,2), S(k,2), max(P(k,2), CS%ref_pres), & + T(k,1), S(k,1), max(P(k,1), CS%ref_pres), delta_rho ) + stable_cell(k) = (delta_rho > 0.) + enddo +end subroutine mark_unstable_cells + +!> Searches the "other" (searched) column for the position of the neutral surface +real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T_top, S_top, P_top, & + T_bot, S_bot, P_bot, T_poly, S_poly ) result(pos) + type(neutral_diffusion_CS), intent(in ) :: CS !< Neutral diffusion control structure + integer, intent(in ) :: ksurf !< Current index of neutral surface + real, intent(in ) :: pos_last !< Last position within the current layer, used as the lower + !! bound in the root finding algorithm [nondim] + real, intent(in ) :: T_from !< Temperature at the searched from interface [C ~> degC] + real, intent(in ) :: S_from !< Salinity at the searched from interface [S ~> ppt] + real, intent(in ) :: P_from !< Pressure at the searched from interface [R L2 T-2 ~> Pa] + real, intent(in ) :: T_top !< Temperature at the searched to top interface [C ~> degC] + real, intent(in ) :: S_top !< Salinity at the searched to top interface [S ~> ppt] + real, intent(in ) :: P_top !< Pressure at the searched to top interface [R L2 T-2 ~> Pa] + !! interface [R L2 T-2 ~> Pa] + real, intent(in ) :: T_bot !< Temperature at the searched to bottom interface [C ~> degC] + real, intent(in ) :: S_bot !< Salinity at the searched to bottom interface [S ~> ppt] + real, intent(in ) :: P_bot !< Pressure at the searched to bottom + !! interface [R L2 T-2 ~> Pa] + real, dimension(:), intent(in ) :: T_poly !< Temperature polynomial reconstruction + !! coefficients [C ~> degC] + real, dimension(:), intent(in ) :: S_poly !< Salinity polynomial reconstruction + !! coefficients [S ~> ppt] + ! Local variables + real :: dRhotop, dRhobot ! Density differences [R ~> kg m-3] + real :: dRdT_top, dRdT_bot, dRdT_from ! Partial derivatives of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dRdS_top, dRdS_bot, dRdS_from ! Partial derivatives of density with salinity [R S-1 ~> kg m-3 ppt-1] + + ! Calculate the difference in density at the tops or the bottom + if (CS%neutral_pos_method == 1 .or. CS%neutral_pos_method == 3) then + call calc_delta_rho_and_derivs(CS, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop) + call calc_delta_rho_and_derivs(CS, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot) + elseif (CS%neutral_pos_method == 2) then + call calc_delta_rho_and_derivs(CS, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop, & + dRdT_top, dRdS_top, dRdT_from, dRdS_from) + call calc_delta_rho_and_derivs(CS, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot, & + dRdT_bot, dRdS_bot, dRdT_from, dRdS_from) + endif + + ! Handle all the special cases EXCEPT if it connects within the layer + if ( (dRhoTop > 0.) .or. (ksurf == 1) ) then ! First interface or lighter than anything in layer + pos = pos_last + elseif ( dRhoTop > dRhoBot ) then ! Unstably stratified + pos = 1. + elseif ( dRhoTop < 0. .and. dRhoBot < 0.) then ! Denser than anything in layer + pos = 1. + elseif ( dRhoTop == 0. .and. dRhoBot == 0. ) then ! Perfectly unstratified + pos = 1. + elseif ( dRhoBot == 0. ) then ! Matches perfectly at the Top + pos = 1. + elseif ( dRhoTop == 0. ) then ! Matches perfectly at the Bottom + pos = pos_last + else ! Neutral surface within layer + pos = -1 + endif + + ! Can safely return if position is >= 0 otherwise will need to find the position within the layer + if (pos>=0) return + + if (CS%neutral_pos_method==1) then + pos = interpolate_for_nondim_position( dRhoTop, P_top, dRhoBot, P_bot ) + ! For the 'Linear' case of finding the neutral position, the reference pressure to use is the average + ! of the midpoint of the layer being searched and the interface being searched from + elseif (CS%neutral_pos_method == 2) then + pos = find_neutral_pos_linear( CS, pos_last, T_from, S_from, dRdT_from, dRdS_from, & + dRdT_top, dRdS_top, dRdT_bot, dRdS_bot, T_poly, S_poly ) + elseif (CS%neutral_pos_method == 3) then + pos = find_neutral_pos_full( CS, pos_last, T_from, S_from, P_from, P_top, P_bot, T_poly, S_poly) + endif + +end function search_other_column + +!> Increments the interface which was just connected and also set flags if the bottom is reached +subroutine increment_interface(nk, kl, ki, reached_bottom, searching_this_column, searching_other_column) + integer, intent(in ) :: nk !< Number of vertical levels + integer, intent(inout) :: kl !< Current layer (potentially updated) + integer, intent(inout) :: ki !< Current interface + logical, intent(inout) :: reached_bottom !< Updated when kl == nk and ki == 2 + logical, intent(inout) :: searching_this_column !< Updated when kl == nk and ki == 2 + logical, intent(inout) :: searching_other_column !< Updated when kl == nk and ki == 2 + + reached_bottom = .false. + if (ki == 2) then ! At the bottom interface + if ((ki == 2) .and. (kl < nk) ) then ! Not at the bottom so just go to the next layer + kl = kl+1 + ki = 1 + elseif ((kl == nk) .and. (ki==2)) then + reached_bottom = .true. + searching_this_column = .false. + searching_other_column = .true. + endif + elseif (ki==1) then ! At the top interface + ki = 2 ! Next interface is same layer, but bottom interface + else + call MOM_error(FATAL,"Unanticipated eventuality in increment_interface") + endif +end subroutine increment_interface + +!> Search a layer to find where delta_rho = 0 based on a linear interpolation of alpha and beta of the top and bottom +!! being searched and polynomial reconstructions of T and S. Compressibility is not needed because either, we are +!! assuming incompressibility in the equation of state for this module or alpha and beta are calculated having been +!! displaced to the average pressures of the two pressures We need Newton's method because the T and S reconstructions +!! make delta_rho a polynomial function of z if using PPM or higher. If Newton's method would search fall out of the +!! interval [0,1], a bisection step would be taken instead. Also this linearization of alpha, beta means that second +!! derivatives of the EOS are not needed. Note that delta in variable names below refers to horizontal differences and +!! 'd' refers to vertical differences +function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, & + dRdT_top, dRdS_top, dRdT_bot, dRdS_bot, ppoly_T, ppoly_S ) result( z ) + type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module + real, intent(in) :: z0 !< Lower bound of position, also serves as the + !! initial guess [nondim] + real, intent(in) :: T_ref !< Temperature at the searched from interface [C ~> degC] + real, intent(in) :: S_ref !< Salinity at the searched from interface [S ~> ppt] + real, intent(in) :: dRdT_ref !< dRho/dT at the searched from interface + !! [R C-1 ~> kg m-3 degC-1] + real, intent(in) :: dRdS_ref !< dRho/dS at the searched from interface + !! [R S-1 ~> kg m-3 ppt-1] + real, intent(in) :: dRdT_top !< dRho/dT at top of layer being searched + !! [R C-1 ~> kg m-3 degC-1] + real, intent(in) :: dRdS_top !< dRho/dS at top of layer being searched + !! [R S-1 ~> kg m-3 ppt-1] + real, intent(in) :: dRdT_bot !< dRho/dT at bottom of layer being searched + !! [R C-1 ~> kg m-3 degC-1] + real, intent(in) :: dRdS_bot !< dRho/dS at bottom of layer being searched + !! [R S-1 ~> kg m-3 ppt-1] + real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the polynomial reconstruction of T within + !! the layer to be searched [C ~> degC]. + real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of S within + !! the layer to be searched [S ~> ppt]. + real :: z !< Position where drho = 0 [nondim] + ! Local variables + real :: dRdT_diff ! Difference in the partial derivative of density with temperature across the + ! layer [R C-1 ~> kg m-3 degC-1] + real :: dRdS_diff ! Difference in the partial derivative of density with salinity across the + ! layer [R S-1 ~> kg m-3 ppt-1] + real :: drho, drho_dz ! Density anomaly and its derivative with fractional position [R ~> kg m-3] + real :: dRdT_z ! Partial derivative of density with temperature at a point [R C-1 ~> kg m-3 degC-1] + real :: dRdS_z ! Partial derivative of density with salinity at a point [R S-1 ~> kg m-3 ppt-1] + real :: T_z, dT_dz ! Temperature at a point and its derivative with fractional position [C ~> degC] + real :: S_z, dS_dz ! Salinity at a point and its derivative with fractional position [S ~> ppt] + real :: drho_min, drho_max ! Bounds on density differences [R ~> kg m-3] + real :: ztest, zmin, zmax ! Fractional positions in the cell [nondim] + real :: a1, a2 ! Fractional weights of the top and bottom values [nondim] + integer :: iter + integer :: nterm + + nterm = SIZE(ppoly_T) + + ! Position independent quantities + dRdT_diff = dRdT_bot - dRdT_top + dRdS_diff = dRdS_bot - dRdS_top + ! Initial starting drho (used for bisection) + zmin = z0 ! Lower bounding interval + zmax = 1. ! Maximum bounding interval (bottom of layer) + a1 = 1. - zmin + a2 = zmin + T_z = evaluation_polynomial( ppoly_T, nterm, zmin ) + S_z = evaluation_polynomial( ppoly_S, nterm, zmin ) + dRdT_z = a1*dRdT_top + a2*dRdT_bot + dRdS_z = a1*dRdS_top + a2*dRdS_bot + drho_min = 0.5*((dRdT_z+dRdT_ref)*(T_z-T_ref) + (dRdS_z+dRdS_ref)*(S_z-S_ref)) + + T_z = evaluation_polynomial( ppoly_T, nterm, 1. ) + S_z = evaluation_polynomial( ppoly_S, nterm, 1. ) + drho_max = 0.5*((dRdT_bot+dRdT_ref)*(T_z-T_ref) + (dRdS_bot+dRdS_ref)*(S_z-S_ref)) + + if (drho_min >= 0.) then + z = z0 + return + elseif (drho_max == 0.) then + z = 1. + return + endif + if ( SIGN(1.,drho_min) == SIGN(1.,drho_max) ) then + call MOM_error(FATAL, "drho_min is the same sign as dhro_max") + endif + + z = z0 + ztest = z0 + do iter = 1, CS%max_iter + ! Calculate quantities at the current nondimensional position + a1 = 1.-z + a2 = z + dRdT_z = a1*dRdT_top + a2*dRdT_bot + dRdS_z = a1*dRdS_top + a2*dRdS_bot + T_z = evaluation_polynomial( ppoly_T, nterm, z ) + S_z = evaluation_polynomial( ppoly_S, nterm, z ) + drho = 0.5*((dRdT_z+dRdT_ref)*(T_z-T_ref) + (dRdS_z+dRdS_ref)*(S_z-S_ref)) + + ! Check for convergence + if (ABS(drho) <= CS%drho_tol) exit + ! Update bisection bracketing intervals + if (drho < 0. .and. drho > drho_min) then + drho_min = drho + zmin = z + elseif (drho > 0. .and. drho < drho_max) then + drho_max = drho + zmax = z + endif + + ! Calculate a Newton step + dT_dz = first_derivative_polynomial( ppoly_T, nterm, z ) + dS_dz = first_derivative_polynomial( ppoly_S, nterm, z ) + drho_dz = 0.5*( (dRdT_diff*(T_z - T_ref) + (dRdT_ref+dRdT_z)*dT_dz) + & + (dRdS_diff*(S_z - S_ref) + (dRdS_ref+dRdS_z)*dS_dz) ) + + ztest = z - drho/drho_dz + ! Take a bisection if z falls out of [zmin,zmax] + if (ztest < zmin .or. ztest > zmax) then + if ( drho < 0. ) then + ztest = 0.5*(z + zmax) + else + ztest = 0.5*(zmin + z) + endif + endif + + ! Test to ensure we haven't stalled out + if ( abs(z-ztest) <= CS%x_tol ) exit + ! Reset for next iteration + z = ztest + enddo + +end function find_neutral_pos_linear + +!> Use the full equation of state to calculate the difference in locally referenced potential density. The derivatives +!! in this case are not trivial to calculate, so instead we use a regula falsi method +function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly_T, ppoly_S ) result( z ) + type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module + real, intent(in) :: z0 !< Lower bound of position, also serves as the + !! initial guess [nondim] + real, intent(in) :: T_ref !< Temperature at the searched from interface [C ~> degC] + real, intent(in) :: S_ref !< Salinity at the searched from interface [S ~> ppt] + real, intent(in) :: P_ref !< Pressure at the searched from interface [R L2 T-2 ~> Pa] + real, intent(in) :: P_top !< Pressure at top of layer being searched [R L2 T-2 ~> Pa] + real, intent(in) :: P_bot !< Pressure at bottom of layer being searched [R L2 T-2 ~> Pa] + real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the polynomial reconstruction of T within + !! the layer to be searched [C ~> degC] + real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of T within + !! the layer to be searched [S ~> ppt] + real :: z !< Position where drho = 0 [nondim] + ! Local variables + integer :: iter + integer :: nterm + + real :: drho_a, drho_b, drho_c ! Density differences [R ~> kg m-3] + real :: a, b, c ! Fractional positions [nondim] + real :: Ta, Tb, Tc ! Temperatures [C ~> degC] + real :: Sa, Sb, Sc ! Salinities [S ~> ppt] + real :: Pa, Pb, Pc ! Pressures [R L2 T-2 ~> Pa] + integer :: side + + side = 0 + ! Set the first two evaluation to the endpoints of the interval + b = z0 ; c = 1 + nterm = SIZE(ppoly_T) + + ! Calculate drho at the minimum bound + Tb = evaluation_polynomial( ppoly_T, nterm, b ) + Sb = evaluation_polynomial( ppoly_S, nterm, b ) + Pb = P_top*(1.-b) + P_bot*b + call calc_delta_rho_and_derivs(CS, Tb, Sb, Pb, T_ref, S_ref, P_ref, drho_b) + + ! Calculate drho at the maximum bound + Tc = evaluation_polynomial( ppoly_T, nterm, 1. ) + Sc = evaluation_polynomial( ppoly_S, nterm, 1. ) + Pc = P_Bot + call calc_delta_rho_and_derivs(CS, Tc, Sc, Pc, T_ref, S_ref, P_ref, drho_c) + + if (drho_b >= 0.) then + z = z0 + return + elseif (drho_c == 0.) then + z = 1. + return + endif + if ( SIGN(1.,drho_b) == SIGN(1.,drho_c) ) then + z = z0 + return + endif + + do iter = 1, CS%max_iter + ! Calculate new position and evaluate if we have converged + a = (drho_b*c - drho_c*b)/(drho_b-drho_c) + Ta = evaluation_polynomial( ppoly_T, nterm, a ) + Sa = evaluation_polynomial( ppoly_S, nterm, a ) + Pa = P_top*(1.-a) + P_bot*a + call calc_delta_rho_and_derivs(CS, Ta, Sa, Pa, T_ref, S_ref, P_ref, drho_a) + if (ABS(drho_a) < CS%drho_tol) then + z = a + return + endif + + if (drho_a*drho_c > 0.) then + if ( ABS(a-c) 0 ) then + if ( ABS(a-b) Calculate the difference in density between two points in a variety of ways +subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, & + drdt1_out, drds1_out, drdt2_out, drds2_out ) + type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure + real, intent(in ) :: T1 !< Temperature at point 1 [C ~> degC] + real, intent(in ) :: S1 !< Salinity at point 1 [S ~> ppt] + real, intent(in ) :: p1_in !< Pressure at point 1 [R L2 T-2 ~> Pa] + real, intent(in ) :: T2 !< Temperature at point 2 [C ~> degC] + real, intent(in ) :: S2 !< Salinity at point 2 [S ~> ppt] + real, intent(in ) :: p2_in !< Pressure at point 2 [R L2 T-2 ~> Pa] + real, intent( out) :: drho !< Difference in density between the two points [R ~> kg m-3] + real, optional, intent( out) :: dRdT1_out !< drho_dt at point 1 [R C-1 ~> kg m-3 degC-1] + real, optional, intent( out) :: dRdS1_out !< drho_ds at point 1 [R S-1 ~> kg m-3 ppt-1] + real, optional, intent( out) :: dRdT2_out !< drho_dt at point 2 [R C-1 ~> kg m-3 degC-1] + real, optional, intent( out) :: dRdS2_out !< drho_ds at point 2 [R S-1 ~> kg m-3 ppt-1] + ! Local variables + real :: rho1, rho2 ! Densities [R ~> kg m-3] + real :: p1, p2, pmid ! Pressures [R L2 T-2 ~> Pa] + real :: drdt1, drdt2 ! Partial derivatives of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: drds1, drds2 ! Partial derivatives of density with salinity [R S-1 ~> kg m-3 ppt-1] + + ! Use the same reference pressure or the in-situ pressure + if (CS%ref_pres > 0.) then + p1 = CS%ref_pres + p2 = CS%ref_pres + else + p1 = p1_in + p2 = p2_in + endif + + ! Use the full linear equation of state to calculate the difference in density (expensive!) + if (TRIM(CS%delta_rho_form) == 'full') then + pmid = 0.5 * (p1 + p2) + call calculate_density(T1, S1, pmid, rho1, CS%EOS) + call calculate_density(T2, S2, pmid, rho2, CS%EOS) + drho = rho1 - rho2 + ! Use the density derivatives at the average of pressures and the differences in temperature + elseif (TRIM(CS%delta_rho_form) == 'mid_pressure') then + pmid = 0.5 * (p1 + p2) + if (CS%ref_pres>=0) pmid = CS%ref_pres + call calculate_density_derivs(T1, S1, pmid, drdt1, drds1, CS%EOS) + call calculate_density_derivs(T2, S2, pmid, drdt2, drds2, CS%EOS) + drho = delta_rho_from_derivs( T1, S1, p1, drdt1, drds1, T2, S2, p2, drdt2, drds2) + elseif (TRIM(CS%delta_rho_form) == 'local_pressure') then + call calculate_density_derivs(T1, S1, p1, drdt1, drds1, CS%EOS) + call calculate_density_derivs(T2, S2, p2, drdt2, drds2, CS%EOS) + drho = delta_rho_from_derivs( T1, S1, p1, drdt1, drds1, T2, S2, p2, drdt2, drds2) + else + call MOM_error(FATAL, "delta_rho_form is not recognized") + endif + + if (PRESENT(drdt1_out)) drdt1_out = drdt1 + if (PRESENT(drds1_out)) drds1_out = drds1 + if (PRESENT(drdt2_out)) drdt2_out = drdt2 + if (PRESENT(drds2_out)) drds2_out = drds2 + +end subroutine calc_delta_rho_and_derivs + +!> Calculate delta rho from derivatives and gradients of properties +!! \f$ \Delta \rho = \frac{1}{2}\left[ (\alpha_1 + \alpha_2)*(T_1-T_2) + +!! (\beta_1 + \beta_2)*(S_1-S_2) + +!! (\gamma^{-1}_1 + \gamma^{-1}_2)*(P_1-P_2) \right] \f$ +function delta_rho_from_derivs( T1, S1, P1, dRdT1, dRdS1, & + T2, S2, P2, dRdT2, dRdS2 ) result (drho) + real :: T1 !< Temperature at point 1 [C ~> degC] + real :: S1 !< Salinity at point 1 [S ~> ppt] + real :: P1 !< Pressure at point 1 [R L2 T-2 ~> Pa] + real :: dRdT1 !< The partial derivative of density with temperature at point 1 [R C-1 ~> kg m-3 degC-1] + real :: dRdS1 !< The partial derivative of density with salinity at point 1 [R S-1 ~> kg m-3 ppt-1] + real :: T2 !< Temperature at point 2 [C ~> degC] + real :: S2 !< Salinity at point 2 [S ~> ppt] + real :: P2 !< Pressure at point 2 [R L2 T-2 ~> Pa] + real :: dRdT2 !< The partial derivative of density with temperature at point 2 [R C-1 ~> kg m-3 degC-1] + real :: dRdS2 !< The partial derivative of density with salinity at point 2 [R S-1 ~> kg m-3 ppt-1] + ! Local variables + real :: drho ! The density difference [R ~> kg m-3] + + drho = 0.5 * ( (dRdT1+dRdT2)*(T1-T2) + (dRdS1+dRdS2)*(S1-S2)) + +end function delta_rho_from_derivs + +!> Converts non-dimensional position within a layer to absolute position (for debugging) +function absolute_position(n,ns,Pint,Karr,NParr,k_surface) + integer, intent(in) :: n !< Number of levels + integer, intent(in) :: ns !< Number of neutral surfaces + real, intent(in) :: Pint(n+1) !< Position of interfaces [R L2 T-2 ~> Pa] or other units + integer, intent(in) :: Karr(ns) !< Index of interface above position + real, intent(in) :: NParr(ns) !< Non-dimensional position within layer Karr(:) [nondim] + integer, intent(in) :: k_surface !< k-interface to query + real :: absolute_position !< The absolute position of a location [R L2 T-2 ~> Pa] + !! or other units following Pint + ! Local variables + integer :: k + + k = Karr(k_surface) + if (k>n) stop 'absolute_position: k>nk is out of bounds!' + absolute_position = Pint(k) + NParr(k_surface) * ( Pint(k+1) - Pint(k) ) + +end function absolute_position + +!> Converts non-dimensional positions within layers to absolute positions (for debugging) +function absolute_positions(n,ns,Pint,Karr,NParr) + integer, intent(in) :: n !< Number of levels + integer, intent(in) :: ns !< Number of neutral surfaces + real, intent(in) :: Pint(n+1) !< Position of interface [R L2 T-2 ~> Pa] or other units + integer, intent(in) :: Karr(ns) !< Indexes of interfaces about positions + real, intent(in) :: NParr(ns) !< Non-dimensional positions within layers Karr(:) [nondim] + + real, dimension(ns) :: absolute_positions !< Absolute positions [R L2 T-2 ~> Pa] + !! or other units following Pint + + ! Local variables + integer :: k_surface + + do k_surface = 1, ns + absolute_positions(k_surface) = absolute_position(n,ns,Pint,Karr,NParr,k_surface) + enddo + +end function absolute_positions + +!> Returns a single column of neutral diffusion fluxes of a tracer. +subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, KoR, & + hEff, Flx, continuous, h_neglect, remap_CS, h_neglect_edge, & + coeff_l, coeff_r) + integer, intent(in) :: nk !< Number of levels + integer, intent(in) :: nsurf !< Number of neutral surfaces + integer, intent(in) :: deg !< Degree of polynomial reconstructions + real, dimension(nk), intent(in) :: hl !< Left-column layer thickness [H ~> m or kg m-2] + real, dimension(nk), intent(in) :: hr !< Right-column layer thickness [H ~> m or kg m-2] + real, dimension(nk), intent(in) :: Tl !< Left-column layer tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk), intent(in) :: Tr !< Right-column layer tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nsurf), intent(in) :: PiL !< Fractional position of neutral surface + !! within layer KoL of left column [nondim] + real, dimension(nsurf), intent(in) :: PiR !< Fractional position of neutral surface + !! within layer KoR of right column [nondim] + integer, dimension(nsurf), intent(in) :: KoL !< Index of first left interface above neutral surface + integer, dimension(nsurf), intent(in) :: KoR !< Index of first right interface above neutral surface + real, dimension(nsurf-1), intent(in) :: hEff !< Effective thickness between two neutral + !! surfaces [H ~> m or kg m-2] + real, dimension(nsurf-1), intent(inout) :: Flx !< Flux of tracer between pairs of neutral layers + !! in units (conc H or conc H L2) that depend on + !! the presence and units of coeff_l and coeff_r. + !! If the tracer is temperature, this could have + !! units of [C H ~> degC m or degC kg m-2] or + !! [C H L2 ~> degC m3 or degC kg] if coeff_l has + !! units of [L2 ~> m2] + logical, intent(in) :: continuous !< True if using continuous reconstruction + real, intent(in) :: h_neglect !< A negligibly small width for the purpose + !! of cell reconstructions [H ~> m or kg m-2] + type(remapping_CS), optional, intent(in) :: remap_CS !< Remapping control structure used + !! to create sublayers + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width used for edge value + !! calculations if continuous is false [H ~> m or kg m-2] + real, dimension(nk+1), optional, intent(in) :: coeff_l !< Left-column diffusivity [L2 ~> m2] or [nondim] + real, dimension(nk+1), optional, intent(in) :: coeff_r !< Right-column diffusivity [L2 ~> m2] or [nondim] + + ! Local variables + integer :: k_sublayer, klb, klt, krb, krt + real :: T_right_sub, T_left_sub ! Tracer concentrations averaged over sub-intervals in the right and left + ! columns in arbitrary concentration units (e.g. [C ~> degC] for temperature). + real :: T_right_layer, T_left_layer ! Tracer concentrations averaged over layers in the right and left + ! columns in arbitrary concentration units (e.g. [C ~> degC] for temperature). + real :: T_right_top, T_right_bottom, T_right_top_int, T_right_bot_int ! Tracer concentrations + ! at various positions in the right column in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature). + real :: T_left_top, T_left_bottom, T_left_top_int, T_left_bot_int ! Tracer concentrations + ! at various positions in the left column in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature). + real :: dT_layer, dT_ave, dT_sublayer ! Differences in vertically averaged tracer concentrations + ! over various portions of the right and left columns in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature). + real :: dT_top, dT_bottom, dT_top_int, dT_bot_int ! Differences in tracer concentrations + ! at various positions between the right and left columns in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature). + real :: khtr_ave ! An averaged diffusivity in normalized units [nondim] if coeff_l and coeff_r are + ! absent or in units copied from coeff_l and coeff_r [L2 ~> m2] or [nondim] + real, dimension(nk+1) :: Til !< Left-column interface tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk+1) :: Tir !< Right-column interface tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk) :: aL_l !< Left-column left edge value of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk) :: aR_l !< Left-column right edge value of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk) :: aL_r !< Right-column left edge value of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk) :: aR_r !< Right-column right edge value of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + ! Discontinuous reconstruction + integer :: iMethod + real, dimension(nk,2) :: Tid_l !< Left-column interface tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk,2) :: Tid_r !< Right-column interface tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk,deg+1) :: ppoly_r_coeffs_l ! Coefficients of the polynomial descriptions of + ! sub-gridscale tracer concentrations in the left column, in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature) + real, dimension(nk,deg+1) :: ppoly_r_coeffs_r ! Coefficients of the polynomial descriptions of + ! sub-gridscale tracer concentrations in the right column, in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature) + real, dimension(nk,deg+1) :: ppoly_r_S_l ! Reconstruction slopes that are unused here, in units of a vertical + ! gradient, which for temperature would be [C H-1 ~> degC m-1 or degC m2 kg-1]. + real, dimension(nk,deg+1) :: ppoly_r_S_r ! Reconstruction slopes that are unused here, in units of a vertical + ! gradient, which for temperature would be [C H-1 ~> degC m-1 or degC m2 kg-1]. + logical :: down_flux, tapering + + tapering = .false. + if (present(coeff_l) .and. present(coeff_r)) tapering = .true. + khtr_ave = 1.0 + + ! Setup reconstruction edge values + if (continuous) then + call interface_scalar(nk, hl, Tl, Til, 2, h_neglect) + call interface_scalar(nk, hr, Tr, Tir, 2, h_neglect) + call ppm_left_right_edge_values(nk, Tl, Til, aL_l, aR_l) + call ppm_left_right_edge_values(nk, Tr, Tir, aL_r, aR_r) + else + ppoly_r_coeffs_l(:,:) = 0. + ppoly_r_coeffs_r(:,:) = 0. + Tid_l(:,:) = 0. + Tid_r(:,:) = 0. + + call build_reconstructions_1d( remap_CS, nk, hl, Tl, ppoly_r_coeffs_l, Tid_l, & + ppoly_r_S_l, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hr, Tr, ppoly_r_coeffs_r, Tid_r, & + ppoly_r_S_r, iMethod, h_neglect, h_neglect_edge ) + endif + + do k_sublayer = 1, nsurf-1 + if (hEff(k_sublayer) == 0.) then + Flx(k_sublayer) = 0. + else + if (tapering) then + klb = KoL(k_sublayer+1) + klt = KoL(k_sublayer) + krb = KoR(k_sublayer+1) + krt = KoR(k_sublayer) + ! these are added in this order to preserve vertically-uniform diffusivity answers + khtr_ave = 0.25 * ((coeff_l(klb) + coeff_l(klt)) + (coeff_r(krb) + coeff_r(krt))) + endif + if (continuous) then + klb = KoL(k_sublayer+1) + T_left_bottom = ( 1. - PiL(k_sublayer+1) ) * Til(klb) + PiL(k_sublayer+1) * Til(klb+1) + klt = KoL(k_sublayer) + T_left_top = ( 1. - PiL(k_sublayer) ) * Til(klt) + PiL(k_sublayer) * Til(klt+1) + T_left_layer = ppm_ave(PiL(k_sublayer), PiL(k_sublayer+1) + real(klb-klt), & + aL_l(klt), aR_l(klt), Tl(klt)) + + krb = KoR(k_sublayer+1) + T_right_bottom = ( 1. - PiR(k_sublayer+1) ) * Tir(krb) + PiR(k_sublayer+1) * Tir(krb+1) + krt = KoR(k_sublayer) + T_right_top = ( 1. - PiR(k_sublayer) ) * Tir(krt) + PiR(k_sublayer) * Tir(krt+1) + T_right_layer = ppm_ave(PiR(k_sublayer), PiR(k_sublayer+1) + real(krb-krt), & + aL_r(krt), aR_r(krt), Tr(krt)) + dT_top = T_right_top - T_left_top + dT_bottom = T_right_bottom - T_left_bottom + dT_ave = 0.5 * ( dT_top + dT_bottom ) + dT_layer = T_right_layer - T_left_layer + if (signum(1.,dT_top) * signum(1.,dT_bottom) <= 0. .or. signum(1.,dT_ave) * signum(1.,dT_layer) <= 0.) then + dT_ave = 0. + else + dT_ave = dT_layer + endif + Flx(k_sublayer) = dT_ave * hEff(k_sublayer) * khtr_ave + else ! Discontinuous reconstruction + ! Calculate tracer values on left and right side of the neutral surface + call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoL, PiL, Tl, Tid_l, deg, iMethod, & + ppoly_r_coeffs_l, T_left_top, T_left_bottom, T_left_sub, & + T_left_top_int, T_left_bot_int, T_left_layer) + call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoR, PiR, Tr, Tid_r, deg, iMethod, & + ppoly_r_coeffs_r, T_right_top, T_right_bottom, T_right_sub, & + T_right_top_int, T_right_bot_int, T_right_layer) + + dT_top = T_right_top - T_left_top + dT_bottom = T_right_bottom - T_left_bottom + dT_sublayer = T_right_sub - T_left_sub + dT_top_int = T_right_top_int - T_left_top_int + dT_bot_int = T_right_bot_int - T_left_bot_int + ! Enforcing the below criterion incorrectly zero out fluxes + !dT_layer = T_right_layer - T_left_layer + + down_flux = dT_top <= 0. .and. dT_bottom <= 0. .and. & + dT_sublayer <= 0. .and. dT_top_int <= 0. .and. & + dT_bot_int <= 0. + down_flux = down_flux .or. & + (dT_top >= 0. .and. dT_bottom >= 0. .and. & + dT_sublayer >= 0. .and. dT_top_int >= 0. .and. & + dT_bot_int >= 0.) + if (down_flux) then + Flx(k_sublayer) = dT_sublayer * hEff(k_sublayer) * khtr_ave + else + Flx(k_sublayer) = 0. + endif + endif + endif + enddo + +end subroutine neutral_surface_flux + +!> Evaluate various parts of the reconstructions to calculate gradient-based flux limiter +subroutine neutral_surface_T_eval(nk, ns, k_sub, Ks, Ps, T_mean, T_int, deg, iMethod, T_poly, & + T_top, T_bot, T_sub, T_top_int, T_bot_int, T_layer) + integer, intent(in ) :: nk !< Number of cell averages + integer, intent(in ) :: ns !< Number of neutral surfaces + integer, intent(in ) :: k_sub !< Index of current neutral layer + integer, dimension(ns), intent(in ) :: Ks !< List of the layers associated with each neutral surface + real, dimension(ns), intent(in ) :: Ps !< List of the positions within a layer of each surface [nondim] + real, dimension(nk), intent(in ) :: T_mean !< Layer average of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk,2), intent(in ) :: T_int !< Layer interface values of tracer from reconstruction + !! in concentration units (e.g. [C ~> degC] for temperature) + integer, intent(in ) :: deg !< Degree of reconstruction polynomial (e.g. 1 is linear) + integer, intent(in ) :: iMethod !< Method of integration to use + real, dimension(nk,deg+1), intent(in ) :: T_poly !< Coefficients of polynomial reconstructions in arbitrary + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_top !< Tracer value at top (across discontinuity if necessary) in + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_bot !< Tracer value at bottom (across discontinuity if necessary) + !! in concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_sub !< Average of the tracer value over the sublayer in arbitrary + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_top_int !< Tracer value at the top interface of a neutral layer in + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_bot_int !< Tracer value at the bottom interface of a neutral layer in + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_layer !< Cell-average tracer concentration in a layer that + !! the reconstruction belongs to in concentration + !! units (e.g. [C ~> degC] for temperature) + + integer :: kl, ks_top, ks_bot + + ks_top = k_sub + ks_bot = k_sub + 1 + if ( Ks(ks_top) /= Ks(ks_bot) ) then + call MOM_error(FATAL, "Neutral surfaces span more than one layer") + endif + kl = Ks(k_sub) + ! First if the neutral surfaces spans the entirety of a cell, then do not search across the discontinuity + if ( (Ps(ks_top) == 0.) .and. (Ps(ks_bot) == 1.)) then + T_top = T_int(kl,1) + T_bot = T_int(kl,2) + else + ! Search across potential discontinuity at top + if ( (kl > 1) .and. (Ps(ks_top) == 0.) ) then + T_top = T_int(kl-1,2) + else + T_top = evaluation_polynomial( T_poly(kl,:), deg+1, Ps(ks_top) ) + endif + ! Search across potential discontinuity at bottom + if ( (kl < nk) .and. (Ps(ks_bot) == 1.) ) then + T_bot = T_int(kl+1,1) + else + T_bot = evaluation_polynomial( T_poly(kl,:), deg+1, Ps(ks_bot) ) + endif + endif + T_sub = average_value_ppoly(nk, T_mean, T_int, T_poly, iMethod, kl, Ps(ks_top), Ps(ks_bot)) + T_top_int = evaluation_polynomial( T_poly(kl,:), deg+1, Ps(ks_top)) + T_bot_int = evaluation_polynomial( T_poly(kl,:), deg+1, Ps(ks_bot)) + T_layer = T_mean(kl) + +end subroutine neutral_surface_T_eval + +!> Discontinuous PPM reconstructions of the left/right edge values within a cell +subroutine ppm_left_right_edge_values(nk, Tl, Ti, aL, aR) + integer, intent(in) :: nk !< Number of levels + real, dimension(nk), intent(in) :: Tl !< Layer tracer (conc, e.g. degC) in arbitrary units [A ~> a] + real, dimension(nk+1), intent(in) :: Ti !< Interface tracer (conc, e.g. degC) in arbitrary units [A ~> a] + real, dimension(nk), intent(inout) :: aL !< Left edge value of tracer (conc, e.g. degC) + !! in the same arbitrary units as Tl and Ti [A ~> a] + real, dimension(nk), intent(inout) :: aR !< Right edge value of tracer (conc, e.g. degC) + !! in the same arbitrary units as Tl and Ti [A ~> a] + + integer :: k + ! Setup reconstruction edge values + do k = 1, nk + aL(k) = Ti(k) + aR(k) = Ti(k+1) + if ( signum(1., aR(k) - Tl(k))*signum(1., Tl(k) - aL(k)) <= 0.0 ) then + aL(k) = Tl(k) + aR(k) = Tl(k) + elseif ( sign(3., aR(k) - aL(k)) * ( (Tl(k) - aL(k)) + (Tl(k) - aR(k))) > abs(aR(k) - aL(k)) ) then + aL(k) = Tl(k) + 2.0 * ( Tl(k) - aR(k) ) + elseif ( sign(3., aR(k) - aL(k)) * ( (Tl(k) - aL(k)) + (Tl(k) - aR(k))) < -abs(aR(k) - aL(k)) ) then + aR(k) = Tl(k) + 2.0 * ( Tl(k) - aL(k) ) + endif + enddo +end subroutine ppm_left_right_edge_values + +!> Returns true if unit tests of neutral_diffusion functions fail. Otherwise returns false. +logical function neutral_diffusion_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + + neutral_diffusion_unit_tests = .false. .or. & + ndiff_unit_tests_continuous(verbose) .or. ndiff_unit_tests_discontinuous(verbose) + +end function neutral_diffusion_unit_tests + +!> Returns true if unit tests of neutral_diffusion functions fail. Otherwise returns false. +logical function ndiff_unit_tests_continuous(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + integer, parameter :: nk = 4 + real, dimension(nk+1) :: Tio ! Test interface temperatures [degC] + real, dimension(2*nk+2) :: PiLRo, PiRLo ! Fractional test positions [nondim] + integer, dimension(2*nk+2) :: KoL, KoR ! Test indexes + real, dimension(2*nk+1) :: hEff ! Test positions in arbitrary units [arbitrary] + real, dimension(2*nk+1) :: Flx ! Test flux in the arbitrary units of hEff times [degC] + logical :: v + real :: h_neglect ! A negligible thickness in arbitrary units [arbitrary] + + h_neglect = 1.0e-30 + + v = verbose + + ndiff_unit_tests_continuous = .false. ! Normally return false + write(stdout,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_continuous =' + + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,1.,1.,1., 0.,1.,2., 1., 'FV: Straight line on uniform grid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,1.,1.,0., 0.,4.,8., 7., 'FV: Vanished right cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,0.,1.,1., 0.,4.,8., 7., 'FV: Vanished left cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,1.,2.,4., 0.,3.,9., 4., 'FV: Stretched grid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,2.,0.,2., 0.,1.,2., 0., 'FV: Vanished middle cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,0.,1.,0., 0.,1.,2., 2., 'FV: Vanished on both sides') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,1.,0.,0., 0.,1.,2., 0., 'FV: Two vanished cell sides') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,0.,0.,0., 0.,1.,2., 0., 'FV: All vanished cells') + + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,1.,1., 0.,1.,2., 1., 'LSQ: Straight line on uniform grid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,1.,0., 0.,1.,2., 1., 'LSQ: Vanished right cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,0.,1.,1., 0.,1.,2., 1., 'LSQ: Vanished left cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,2.,4., 0.,3.,9., 2., 'LSQ: Stretched grid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,0.,1., 0.,1.,2., 2., 'LSQ: Vanished middle cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,0.,1.,0., 0.,1.,2., 0., 'LSQ: Vanished on both sides') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,0.,0., 0.,1.,2., 0., 'LSQ: Two vanished cell sides') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,0.,0.,0., 0.,1.,2., 0., 'LSQ: All vanished cells') + + call interface_scalar(4, (/10.,10.,10.,10./), (/24.,18.,12.,6./), Tio, 1, h_neglect) + !ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + ! test_data1d(5, Tio, (/27.,21.,15.,9.,3./), 'Linear profile, interface temperatures') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_data1d(v,5, Tio, (/24.,22.5,15.,7.5,6./), 'Linear profile, linear interface temperatures') + call interface_scalar(4, (/10.,10.,10.,10./), (/24.,18.,12.,6./), Tio, 2, h_neglect) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_data1d(v,5, Tio, (/24.,22.,15.,8.,6./), 'Linear profile, PPM interface temperatures') + + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., 1.0, 1.0, 0.5, 'Check mid-point') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v, 0.0, 0., 1.0, 1.0, 0.0, 'Check bottom') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v, 0.1, 0., 1.1, 1.0, 0.0, 'Check below') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., 0.0, 1.0, 1.0, 'Check top') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., -0.1, 1.0, 1.0, 'Check above') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., 3.0, 1.0, 0.25, 'Check 1/4') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-3.0, 0., 1.0, 1.0, 0.75, 'Check 3/4') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v, 1.0, 0., 1.0, 1.0, 0.0, 'Check dRho=0 below') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., -1.0, 1.0, 1.0, 'Check dRho=0 above') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v, 0.0, 0., 0.0, 1.0, 0.5, 'Check dRho=0 mid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-2.0, .5, 5.0, 0.5, 0.5, 'Check dP=0') + + ! Identical columns + call find_neutral_surface_positions_continuous(3, & + (/0.,10.,20.,30./), (/22.,18.,14.,10./), (/0.,0.,0.,0./), & ! Left positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Left dRdT and dRdS + (/0.,10.,20.,30./), (/22.,18.,14.,10./), (/0.,0.,0.,0./), & ! Right positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Right dRdT and dRdS + PiLRo, PiRLo, KoL, KoR, hEff) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_nsp(v, 8, KoL, KoR, PiLRo, PiRLo, hEff, & + (/1,1,2,2,3,3,3,3/), & ! KoL + (/1,1,2,2,3,3,3,3/), & ! KoR + (/0.,0.,0.,0.,0.,0.,1.,1./), & ! pL + (/0.,0.,0.,0.,0.,0.,1.,1./), & ! pR + (/0.,10.,0.,10.,0.,10.,0./), & ! hEff + 'Identical columns') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v, 8, & + absolute_positions(3, 8, (/0.,10.,20.,30./), KoL, PiLRo), & + (/0.,0.,10.,10.,20.,20.,30.,30./), '... left positions') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v, 8, & + absolute_positions(3, 8, (/0.,10.,20.,30./), KoR, PiRLo), & + (/0.,0.,10.,10.,20.,20.,30.,30./), '... right positions') + call neutral_surface_flux(3, 2*3+2, 2, (/10.,10.,10./), (/10.,10.,10./), & ! nk, hL, hR + (/20.,16.,12./), (/20.,16.,12./), & ! Tl, Tr + PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true., h_neglect) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v, 7, Flx, & + (/0.,0.,0.,0.,0.,0.,0./), 'Identical columns, rho flux (=0)') + call neutral_surface_flux(3, 2*3+2, 2, (/10.,10.,10./), (/10.,10.,10./), & ! nk, hL, hR + (/-1.,-1.,-1./), (/1.,1.,1./), & ! Sl, Sr + PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true., h_neglect) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v, 7, Flx, & + (/0.,20.,0.,20.,0.,20.,0./), 'Identical columns, S flux') + + ! Right column slightly cooler than left + call find_neutral_surface_positions_continuous(3, & + (/0.,10.,20.,30./), (/22.,18.,14.,10./), (/0.,0.,0.,0./), & ! Left positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Left dRdT and dRdS + (/0.,10.,20.,30./), (/20.,16.,12.,8./), (/0.,0.,0.,0./), & ! Right positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Right dRdT and dRdS + PiLRo, PiRLo, KoL, KoR, hEff) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_nsp(v, 8, KoL, KoR, PiLRo, PiRLo, hEff, & + (/1,1,2,2,3,3,3,3/), & ! kL + (/1,1,1,2,2,3,3,3/), & ! kR + (/0.,0.5,0.,0.5,0.,0.5,1.,1./), & ! pL + (/0.,0.,0.5,0.,0.5,0.,0.5,1./), & ! pR + (/0.,5.,5.,5.,5.,5.,0./), & ! hEff + 'Right column slightly cooler') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v, 8, & + absolute_positions(3, 8, (/0.,10.,20.,30./), KoL, PiLRo), & + (/0.,5.,10.,15.,20.,25.,30.,30./), '... left positions') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v, 8, & + absolute_positions(3, 8, (/0.,10.,20.,30./), KoR, PiRLo), & + (/0.,0.,5.,10.,15.,20.,25.,30./), '... right positions') + + ! Right column slightly warmer than left + call find_neutral_surface_positions_continuous(3, & + (/0.,10.,20.,30./), (/22.,18.,14.,10./), (/0.,0.,0.,0./), & ! Left positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Left dRdT and dRdS + (/0.,10.,20.,30./), (/24.,20.,16.,12./), (/0.,0.,0.,0./), & ! Right positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Right dRdT and dRdS + PiLRo, PiRLo, KoL, KoR, hEff) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_nsp(v, 8, KoL, KoR, PiLRo, PiRLo, hEff, & + (/1,1,1,2,2,3,3,3/), & ! kL + (/1,1,2,2,3,3,3,3/), & ! kR + (/0.,0.,0.5,0.,0.5,0.,0.5,1./), & ! pL + (/0.,0.5,0.,0.5,0.,0.5,1.,1./), & ! pR + (/0.,5.,5.,5.,5.,5.,0./), & ! hEff + 'Right column slightly warmer') + + ! Right column somewhat cooler than left + call find_neutral_surface_positions_continuous(3, & + (/0.,10.,20.,30./), (/22.,18.,14.,10./), (/0.,0.,0.,0./), & ! Left positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Left dRdT and dRdS + (/0.,10.,20.,30./), (/16.,12.,8.,4./), (/0.,0.,0.,0./), & ! Right positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Right dRdT and dRdS + PiLRo, PiRLo, KoL, KoR, hEff) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_nsp(v, 8, KoL, KoR, PiLRo, PiRLo, hEff, & + (/1,2,2,3,3,3,3,3/), & ! kL + (/1,1,1,1,2,2,3,3/), & ! kR + (/0.,0.,0.5,0.,0.5,1.,1.,1./), & ! pL + (/0.,0.,0.,0.5,0.,0.5,0.,1./), & ! pR + (/0.,0.,5.,5.,5.,0.,0./), & ! hEff + 'Right column somewhat cooler') + + ! Right column much colder than left with no overlap + call find_neutral_surface_positions_continuous(3, & + (/0.,10.,20.,30./), (/22.,18.,14.,10./), (/0.,0.,0.,0./), & ! Left positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Left dRdT and dRdS + (/0.,10.,20.,30./), (/9.,7.,5.,3./), (/0.,0.,0.,0./), & ! Right positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Right dRdT and dRdS + PiLRo, PiRLo, KoL, KoR, hEff) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_nsp(v, 8, KoL, KoR, PiLRo, PiRLo, hEff, & + (/1,2,3,3,3,3,3,3/), & ! kL + (/1,1,1,1,1,2,3,3/), & ! kR + (/0.,0.,0.,1.,1.,1.,1.,1./), & ! pL + (/0.,0.,0.,0.,0.,0.,0.,1./), & ! pR + (/0.,0.,0.,0.,0.,0.,0./), & ! hEff + 'Right column much cooler') + + ! Right column with mixed layer + call find_neutral_surface_positions_continuous(3, & + (/0.,10.,20.,30./), (/22.,18.,14.,10./), (/0.,0.,0.,0./), & ! Left positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Left dRdT and dRdS + (/0.,10.,20.,30./), (/14.,14.,10.,2./), (/0.,0.,0.,0./), & ! Right positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Right dRdT and dRdS + PiLRo, PiRLo, KoL, KoR, hEff) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_nsp(v, 8, KoL, KoR, PiLRo, PiRLo, hEff, & + (/1,2,3,3,3,3,3,3/), & ! kL + (/1,1,1,1,2,3,3,3/), & ! kR + (/0.,0.,0.,0.,0.,1.,1.,1./), & ! pL + (/0.,0.,0.,0.,0.,0.,0.,1./), & ! pR + (/0.,0.,0.,0.,10.,0.,0./), & ! hEff + 'Right column with mixed layer') + + ! Identical columns with mixed layer + call find_neutral_surface_positions_continuous(3, & + (/0.,10.,20.,30./), (/14.,14.,10.,2./), (/0.,0.,0.,0./), & ! Left positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Left dRdT and dRdS + (/0.,10.,20.,30./), (/14.,14.,10.,2./), (/0.,0.,0.,0./), & ! Right positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Right dRdT and dRdS + PiLRo, PiRLo, KoL, KoR, hEff) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_nsp(v, 8, KoL, KoR, PiLRo, PiRLo, hEff, & + (/1,1,2,2,3,3,3,3/), & ! kL + (/1,1,2,2,3,3,3,3/), & ! kR + (/0.,0.,0.,0.,0.,0.,1.,1./), & ! pL + (/0.,0.,0.,0.,0.,0.,1.,1./), & ! pR + (/0.,10.,0.,10.,0.,10.,0./), & ! hEff + 'Identical columns with mixed layer') + + ! Right column with unstable mixed layer + call find_neutral_surface_positions_continuous(3, & + (/0.,10.,20.,30./), (/14.,14.,10.,2./), (/0.,0.,0.,0./), & ! Left positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Left dRdT and dRdS + (/0.,10.,20.,30./), (/10.,14.,12.,4./), (/0.,0.,0.,0./), & ! Right positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Right dRdT and dRdS + PiLRo, PiRLo, KoL, KoR, hEff) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_nsp(v, 8, KoL, KoR, PiLRo, PiRLo, hEff, & + (/1,2,3,3,3,3,3,3/), & ! kL + (/1,1,1,2,3,3,3,3/), & ! kR + (/0.,0.,0.,0.,0.,0.,.75,1./), & ! pL + (/0.,0.,0.,0.,0.,0.25,1.,1./), & ! pR + (/0.,0.,0.,0.,0.,7.5,0./), & ! hEff + 'Right column with unstable mixed layer') + + ! Left column with unstable mixed layer + call find_neutral_surface_positions_continuous(3, & + (/0.,10.,20.,30./), (/10.,14.,12.,4./), (/0.,0.,0.,0./), & ! Left positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Left dRdT and dRdS + (/0.,10.,20.,30./), (/14.,14.,10.,2./), (/0.,0.,0.,0./), & ! Right positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Right dRdT and dRdS + PiLRo, PiRLo, KoL, KoR, hEff) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_nsp(v, 8, KoL, KoR, PiLRo, PiRLo, hEff, & + (/1,1,1,2,3,3,3,3/), & ! kL + (/1,2,3,3,3,3,3,3/), & ! kR + (/0.,0.,0.,0.,0.,0.25,1.,1./), & ! pL + (/0.,0.,0.,0.,0.,0.,.75,1./), & ! pR + (/0.,0.,0.,0.,0.,7.5,0./), & ! hEff + 'Left column with unstable mixed layer') + + ! Two unstable mixed layers + call find_neutral_surface_positions_continuous(3, & + (/0.,10.,20.,30./), (/8.,12.,10.,2./), (/0.,0.,0.,0./), & ! Left positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Left dRdT and dRdS + (/0.,10.,20.,30./), (/10.,14.,12.,4./), (/0.,0.,0.,0./), & ! Right positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Right dRdT and dRdS + PiLRo, PiRLo, KoL, KoR, hEff) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_nsp(v, 8, KoL, KoR, PiLRo, PiRLo, hEff, & + (/1,1,1,1,2,3,3,3/), & ! kL + (/1,2,3,3,3,3,3,3/), & ! kR + (/0.,0.,0.,0.,0.,0.,0.75,1./), & ! pL + (/0.,0.,0.,0.5,0.5,0.5,1.,1./), & ! pR + (/0.,0.,0.,0.,0.,6.,0./), & ! hEff + 'Two unstable mixed layers') + + if (.not. ndiff_unit_tests_continuous) write(stdout,*) 'Pass' + +end function ndiff_unit_tests_continuous + +logical function ndiff_unit_tests_discontinuous(verbose) + logical, intent(in) :: verbose !< It true, write results to stdout + ! Local variables + integer, parameter :: nk = 3 + integer, parameter :: ns = nk*4 + real, dimension(nk) :: Sl, Sr ! Salinities [ppt] and temperatures [degC] + real, dimension(nk) :: hl, hr ! Thicknesses in pressure units [R L2 T-2 ~> Pa] or other + ! arbitrary units [arbitrary] + real, dimension(nk,2) :: TiL, SiL, TiR, SiR ! Cell edge salinities [ppt] and temperatures [degC] + real, dimension(nk,2) :: Pres_l, Pres_r ! Interface pressures [R L2 T-2 ~> Pa] + integer, dimension(ns) :: KoL, KoR ! Index of the layer where the interface is found in the + ! left and right columns + real, dimension(ns) :: PoL, PoR ! Fractional position of neutral surface within layer KoL + ! of the left column or KoR of the right column [nondim] + real, dimension(ns-1) :: hEff ! Effective thickness between two neutral surfaces + ! in the same units as hl and hr [arbitrary] + type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure + real, dimension(nk,2) :: ppoly_T_l, ppoly_T_r ! Linear reconstruction for T [degC] + real, dimension(nk,2) :: ppoly_S_l, ppoly_S_r ! Linear reconstruction for S [ppt] + logical, dimension(nk) :: stable_l, stable_r + integer :: k + logical :: v + + v = verbose + ndiff_unit_tests_discontinuous = .false. ! Normally return false + write(stdout,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_discontinuous =' + + ! Unit tests for find_neutral_surface_positions_discontinuous + ! Salinity is 0 for all these tests + allocate(CS%EOS) + call EOS_manual_init(CS%EOS, form_of_EOS=EOS_LINEAR, dRho_dT=-1., dRho_dS=0.) + Sl(:) = 0. ; Sr(:) = 0. ; ; SiL(:,:) = 0. ; SiR(:,:) = 0. + ppoly_T_l(:,:) = 0.; ppoly_T_r(:,:) = 0. + ppoly_S_l(:,:) = 0.; ppoly_S_r(:,:) = 0. + ! Intialize any control structures needed for unit tests + CS%ref_pres = -1. + + hL = (/10.,10.,10./) ; hR = (/10.,10.,10./) + Pres_l(1,1) = 0. ; Pres_l(1,2) = hL(1) ; Pres_r(1,1) = 0. ; Pres_r(1,2) = hR(1) + do k = 2,nk + Pres_l(k,1) = Pres_l(k-1,2) + Pres_l(k,2) = Pres_l(k,1) + hL(k) + Pres_r(k,1) = Pres_r(k-1,2) + Pres_r(k,2) = Pres_r(k,1) + hR(k) + enddo + CS%delta_rho_form = 'mid_pressure' + CS%neutral_pos_method = 1 + + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & + (/ 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff + 'Identical Columns') + + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 20.00, 16.00 /); TiR(2,:) = (/ 16.00, 12.00 /); TiR(3,:) = (/ 12.00, 8.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & + (/ 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 1.00 /), & ! PoR + (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Right slightly cooler') + + TiL(1,:) = (/ 20.00, 16.00 /); TiL(2,:) = (/ 16.00, 12.00 /); TiL(3,:) = (/ 12.00, 8.00 /); + TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & + (/ 1, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 1.00 /), & ! PoL + (/ 0.00, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 1.00 /), & ! PoR + (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Left slightly cooler') + + TiL(1,:) = (/ 22.00, 20.00 /); TiL(2,:) = (/ 18.00, 16.00 /); TiL(3,:) = (/ 14.00, 12.00 /); + TiR(1,:) = (/ 32.00, 24.00 /); TiR(2,:) = (/ 22.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & + (/ 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 1.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 1.00, 0.00, 0.00, 0.25, 0.50, 0.75, 1.00, 0.00, 0.00, 0.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 4.00, 0.00, 4.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff + 'Right more strongly stratified') + + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 8.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & + (/ 1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoL + (/ 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Deep Mixed layer on the right') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 14.00, 14.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & + (/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3 /), & ! KoL + (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff + 'Right unstratified column') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & + (/ 1, 1, 1, 1, 1, 1, 2, 2, 2, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 1.00, 1.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.25, 0.50, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff + 'Right unstratified column') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 10.00 /); TiL(3,:) = (/ 10.00, 2.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 10.00 /); TiR(3,:) = (/ 10.00, 2.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & + (/ 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff + 'Identical columns with mixed layer') + + TiL(1,:) = (/ 14.00, 12.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 2.00 /); + TiR(1,:) = (/ 14.00, 12.00 /); TiR(2,:) = (/ 12.00, 8.00 /); TiR(3,:) = (/ 8.00, 2.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & + (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff + 'Left interior unstratified') + + TiL(1,:) = (/ 12.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 10.00, 6.00 /); + TiR(1,:) = (/ 12.00, 10.00 /); TiR(2,:) = (/ 10.00, 12.00 /); TiR(3,:) = (/ 8.00, 4.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & + (/ 1, 1, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Left mixed layer, Right unstable interior') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 6.00 /); + TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 16.00, 16.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & + (/ 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.50, 0.75, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff + 'Left thick mixed layer, Right unstable mixed') + + TiL(1,:) = (/ 8.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 8.00, 4.00 /); + TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 14.00, 12.00 /); TiR(3,:) = (/ 10.00, 6.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & + (/ 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 1.00, 0.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Unstable mixed layers, left cooler') + + call EOS_manual_init(CS%EOS, form_of_EOS = EOS_LINEAR, dRho_dT = -1., dRho_dS = 2.) + ! Tests for linearized version of searching the layer for neutral surface position + ! EOS linear in T, uniform alpha + CS%max_iter = 10 + ! Unit tests require explicit initialization of tolerance + CS%Drho_tol = 0. + CS%x_tol = 0. + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., & + -0.2, 0., -0.2, 0., & + (/12.,-4./), (/34.,0./)), "Temp Uniform Linearized Alpha/Beta")) + ! EOS linear in S, uniform beta + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, & + 0., 0.8, 0., 0.8, & + (/12.,0./), (/34.,2./)), "Salt Uniform Linearized Alpha/Beta")) + ! EOS linear in T/S, uniform alpha/beta + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear(CS, 0., 10., 35., -0.5, 0.5, & + -0.5, 0.5, -0.5, 0.5, & + (/12.,-4./), (/34.,2./)), "Temp/salt Uniform Linearized Alpha/Beta")) + ! EOS linear in T, insensitive to So + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., & + -0.4, 0., -0.6, 0., & + (/12.,-4./), (/34.,0./)), "Temp stratified Linearized Alpha/Beta")) + ! EOS linear in S, insensitive to T + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, & + 0., 1.0, 0., 0.5, & + (/12.,0./), (/34.,2./)), "Salt stratified Linearized Alpha/Beta")) + if (.not. ndiff_unit_tests_discontinuous) write(stdout,*) 'Pass' + +end function ndiff_unit_tests_discontinuous + +!> Returns true if a test of fv_diff() fails, and conditionally writes results to stream +logical function test_fv_diff(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, title) + logical, intent(in) :: verbose !< If true, write results to stdout + real, intent(in) :: hkm1 !< Left cell width [nondim] + real, intent(in) :: hk !< Center cell width [nondim] + real, intent(in) :: hkp1 !< Right cell width [nondim] + real, intent(in) :: Skm1 !< Left cell average value in arbitrary units [arbitrary] + real, intent(in) :: Sk !< Center cell average value in arbitrary units [arbitrary] + real, intent(in) :: Skp1 !< Right cell average value in arbitrary units [arbitrary] + real, intent(in) :: Ptrue !< True answer in arbitrary units [arbitrary] + character(len=*), intent(in) :: title !< Title for messages + + ! Local variables + integer :: stdunit + real :: Pret ! Returned normalized gradient in arbitrary units [arbitrary] + + Pret = fv_diff(hkm1, hk, hkp1, Skm1, Sk, Skp1) + test_fv_diff = (Pret /= Ptrue) + + if (test_fv_diff .or. verbose) then + stdunit = stdout + if (test_fv_diff) stdunit = stderr ! In case of wrong results, write to error stream + write(stdunit,'(a)') title + if (test_fv_diff) then + write(stdunit,'(2(1x,a,f20.16),1x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' + else + write(stdunit,'(2(1x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue + endif + endif + +end function test_fv_diff + +!> Returns true if a test of fvlsq_slope() fails, and conditionally writes results to stream +logical function test_fvlsq_slope(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, title) + logical, intent(in) :: verbose !< If true, write results to stdout + real, intent(in) :: hkm1 !< Left cell width in arbitrary units [B ~> b] + real, intent(in) :: hk !< Center cell width in arbitrary units [B ~> b] + real, intent(in) :: hkp1 !< Right cell width in arbitrary units [B ~> b] + real, intent(in) :: Skm1 !< Left cell average value in arbitrary units [A ~> a] + real, intent(in) :: Sk !< Center cell average value in arbitrary units [A ~> a] + real, intent(in) :: Skp1 !< Right cell average value in arbitrary units [A ~> a] + real, intent(in) :: Ptrue !< True answer in arbitrary units [A B-1 ~> a b-1] + character(len=*), intent(in) :: title !< Title for messages + + ! Local variables + integer :: stdunit + real :: Pret ! Returned slope value [A B-1 ~> a b-1] + + Pret = fvlsq_slope(hkm1, hk, hkp1, Skm1, Sk, Skp1) + test_fvlsq_slope = (Pret /= Ptrue) + + if (test_fvlsq_slope .or. verbose) then + stdunit = stdout + if (test_fvlsq_slope) stdunit = stderr ! In case of wrong results, write to error stream + write(stdunit,'(a)') title + if (test_fvlsq_slope) then + write(stdunit,'(2(1x,a,f20.16),1x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' + else + write(stdunit,'(2(1x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue + endif + endif + +end function test_fvlsq_slope + +!> Returns true if a test of interpolate_for_nondim_position() fails, and conditionally writes results to stream +logical function test_ifndp(verbose, rhoNeg, Pneg, rhoPos, Ppos, Ptrue, title) + logical, intent(in) :: verbose !< If true, write results to stdout + real, intent(in) :: rhoNeg !< Lighter density [R ~> kg m-3] + real, intent(in) :: Pneg !< Interface position of lighter density [nondim] + real, intent(in) :: rhoPos !< Heavier density [R ~> kg m-3] + real, intent(in) :: Ppos !< Interface position of heavier density [nondim] + real, intent(in) :: Ptrue !< True answer [nondim] + character(len=*), intent(in) :: title !< Title for messages + + ! Local variables + integer :: stdunit + real :: Pret ! Interpolated fractional position [nondim] + + Pret = interpolate_for_nondim_position(rhoNeg, Pneg, rhoPos, Ppos) + test_ifndp = (Pret /= Ptrue) + + if (test_ifndp .or. verbose) then + stdunit = stdout + if (test_ifndp) stdunit = stderr ! In case of wrong results, write to error stream + write(stdunit,'(a)') title + if (test_ifndp) then + write(stdunit,'(4(1x,a,f20.16),2(1x,a,1pe22.15),1x,a)') & + 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' + else + write(stdunit,'(4(1x,a,f20.16),2(1x,a,1pe22.15))') & + 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue + endif + endif + +end function test_ifndp + +!> Returns true if comparison of Po and Ptrue fails, and conditionally writes results to stream +logical function test_data1d(verbose, nk, Po, Ptrue, title) + logical, intent(in) :: verbose !< If true, write results to stdout + integer, intent(in) :: nk !< Number of layers + real, dimension(nk), intent(in) :: Po !< Calculated answer [arbitrary] + real, dimension(nk), intent(in) :: Ptrue !< True answer [arbitrary] + character(len=*), intent(in) :: title !< Title for messages + + ! Local variables + integer :: k, stdunit + + test_data1d = .false. + do k = 1,nk + if (Po(k) /= Ptrue(k)) test_data1d = .true. + enddo + + if (test_data1d .or. verbose) then + stdunit = stdout + if (test_data1d) stdunit = stderr ! In case of wrong results, write to error stream + write(stdunit,'(a)') title + do k = 1,nk + if (Po(k) /= Ptrue(k)) then + test_data1d = .true. + write(stdunit,'(a,i2,2(1x,a,f20.16),1x,a,1pe22.15,1x,a)') & + 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k),'WRONG!' + else + if (verbose) & + write(stdunit,'(a,i2,2(1x,a,f20.16),1x,a,1pe22.15)') & + 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k) + endif + enddo + endif + +end function test_data1d + +!> Returns true if comparison of Po and Ptrue fails, and conditionally writes results to stream +logical function test_data1di(verbose, nk, Po, Ptrue, title) + logical, intent(in) :: verbose !< If true, write results to stdout + integer, intent(in) :: nk !< Number of layers + integer, dimension(nk), intent(in) :: Po !< Calculated answer [arbitrary] + integer, dimension(nk), intent(in) :: Ptrue !< True answer [arbitrary] + character(len=*), intent(in) :: title !< Title for messages + + ! Local variables + integer :: k, stdunit + + test_data1di = .false. + do k = 1,nk + if (Po(k) /= Ptrue(k)) test_data1di = .true. + enddo + + if (test_data1di .or. verbose) then + stdunit = stdout + if (test_data1di) stdunit = stderr ! In case of wrong results, write to error stream + write(stdunit,'(a)') title + do k = 1,nk + if (Po(k) /= Ptrue(k)) then + test_data1di = .true. + write(stdunit,'(a,i2,2(1x,a,i5),1x,a)') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k),'WRONG!' + else + if (verbose) & + write(stdunit,'(a,i2,2(1x,a,i5))') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k) + endif + enddo + endif + +end function test_data1di + +!> Returns true if output of find_neutral_surface_positions() does not match correct values, +!! and conditionally writes results to stream +logical function test_nsp(verbose, ns, KoL, KoR, pL, pR, hEff, KoL0, KoR0, pL0, pR0, hEff0, title) + logical, intent(in) :: verbose !< If true, write results to stdout + integer, intent(in) :: ns !< Number of surfaces + integer, dimension(ns), intent(in) :: KoL !< Index of first left interface above neutral surface + integer, dimension(ns), intent(in) :: KoR !< Index of first right interface above neutral surface + real, dimension(ns), intent(in) :: pL !< Fractional position of neutral surface within layer + !! KoL of left column [nondim] + real, dimension(ns), intent(in) :: pR !< Fractional position of neutral surface within layer + !! KoR of right column [nondim] + real, dimension(ns-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces [R L2 T-2 ~> Pa] + integer, dimension(ns), intent(in) :: KoL0 !< Correct value for KoL + integer, dimension(ns), intent(in) :: KoR0 !< Correct value for KoR + real, dimension(ns), intent(in) :: pL0 !< Correct value for pL [nondim] + real, dimension(ns), intent(in) :: pR0 !< Correct value for pR [nondim] + real, dimension(ns-1), intent(in) :: hEff0 !< Correct value for hEff [R L2 T-2 ~> Pa] + character(len=*), intent(in) :: title !< Title for messages + + ! Local variables + integer :: k, stdunit + logical :: this_row_failed + + test_nsp = .false. + do k = 1,ns + test_nsp = test_nsp .or. compare_nsp_row(KoL(k), KoR(k), pL(k), pR(k), KoL0(k), KoR0(k), pL0(k), pR0(k)) + if (k < ns) then + if (hEff(k) /= hEff0(k)) test_nsp = .true. + endif + enddo + + if (test_nsp .or. verbose) then + stdunit = stdout + if (test_nsp) stdunit = stderr ! In case of wrong results, write to error stream + write(stdunit,'(a)') title + do k = 1,ns + this_row_failed = compare_nsp_row(KoL(k), KoR(k), pL(k), pR(k), KoL0(k), KoR0(k), pL0(k), pR0(k)) + if (this_row_failed) then + write(stdunit,10) k,KoL(k),pL(k),KoR(k),pR(k),' <-- WRONG!' + write(stdunit,10) k,KoL0(k),pL0(k),KoR0(k),pR0(k),' <-- should be this' + else + write(stdunit,10) k,KoL(k),pL(k),KoR(k),pR(k) + endif + if (k < ns) then + if (hEff(k) /= hEff0(k)) then + write(stdunit,'(i3,8x,"layer hEff =",2(f20.16,a))') k,hEff(k)," .neq. ",hEff0(k),' <-- WRONG!' + else + write(stdunit,'(i3,8x,"layer hEff =",f20.16)') k,hEff(k) + endif + endif + enddo + endif + if (test_nsp) call MOM_error(FATAL,"test_nsp failed") + +10 format("ks=",i3," kL=",i3," pL=",f20.16," kR=",i3," pR=",f20.16,a) +end function test_nsp + +!> Compares a single row, k, of output from find_neutral_surface_positions() +logical function compare_nsp_row(KoL, KoR, pL, pR, KoL0, KoR0, pL0, pR0) + integer, intent(in) :: KoL !< Index of first left interface above neutral surface + integer, intent(in) :: KoR !< Index of first right interface above neutral surface + real, intent(in) :: pL !< Fractional position of neutral surface within layer KoL of left column [nondim] + real, intent(in) :: pR !< Fractional position of neutral surface within layer KoR of right column [nondim] + integer, intent(in) :: KoL0 !< Correct value for KoL + integer, intent(in) :: KoR0 !< Correct value for KoR + real, intent(in) :: pL0 !< Correct value for pL [nondim] + real, intent(in) :: pR0 !< Correct value for pR [nondim] + + compare_nsp_row = .false. + if (KoL /= KoL0) compare_nsp_row = .true. + if (KoR /= KoR0) compare_nsp_row = .true. + if (pL /= pL0) compare_nsp_row = .true. + if (pR /= pR0) compare_nsp_row = .true. +end function compare_nsp_row + +!> Compares output position from refine_nondim_position with an expected value +logical function test_rnp(expected_pos, test_pos, title) + real, intent(in) :: expected_pos !< The expected position [arbitrary] + real, intent(in) :: test_pos !< The position returned by the code [arbitrary] + character(len=*), intent(in) :: title !< A label for this test + ! Local variables + integer :: stdunit + + stdunit = stdout ! Output to standard error + test_rnp = ABS(expected_pos - test_pos) > 2*EPSILON(test_pos) + if (test_rnp) then + write(stdunit,'(A, f20.16, " .neq. ", f20.16, " <-- WRONG")') title, expected_pos, test_pos + else + write(stdunit,'(A, f20.16, " == ", f20.16)') title, expected_pos, test_pos + endif +end function test_rnp + +!> Deallocates neutral_diffusion control structure +subroutine neutral_diffusion_end(CS) + type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure + + if (associated(CS)) deallocate(CS) + +end subroutine neutral_diffusion_end + +end module MOM_neutral_diffusion diff --git a/tracer/MOM_offline_aux.F90 b/tracer/MOM_offline_aux.F90 new file mode 100644 index 0000000000..bd105439c7 --- /dev/null +++ b/tracer/MOM_offline_aux.F90 @@ -0,0 +1,842 @@ +!> Contains routines related to offline transport of tracers. These routines are likely to be called from +!> the MOM_offline_main module +module MOM_offline_aux + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_debugging, only : check_column_integrals +use MOM_domains, only : pass_var, pass_vector, To_All +use MOM_diag_mediator, only : post_data +use MOM_error_handler, only : callTree_enter, callTree_leave, MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER +use MOM_opacity, only : optics_type +use MOM_time_manager, only : time_type, operator(-) +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : vertvisc_type +use MOM_verticalGrid, only : verticalGrid_type +use astronomy_mod, only : orbital_time, diurnal_solar, daily_mean_solar + +implicit none ; private + +public update_offline_from_files +public update_offline_from_arrays +public update_h_horizontal_flux +public update_h_vertical_flux +public limit_mass_flux_3d +public distribute_residual_uh_barotropic +public distribute_residual_vh_barotropic +public distribute_residual_uh_upwards +public distribute_residual_vh_upwards +public next_modulo_time +public offline_add_diurnal_sw + +#include "MOM_memory.h" + +contains + +!> This updates thickness based on the convergence of horizontal mass fluxes +!! NOTE: Only used in non-ALE mode +subroutine update_h_horizontal_flux(G, GV, uhtr, vhtr, h_pre, h_new) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: uhtr !< Accumulated mass flux through zonal face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vhtr !< Accumulated mass flux through meridional face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_pre !< Previous layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_new !< Updated layer thicknesses [H ~> m or kg m-2] + + ! Local variables + integer :: i, j, k, is, ie, js, je, nz + ! Set index-related variables for fields on T-grid + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + do k=1,nz + do i=is-1,ie+1 ; do j=js-1,je+1 + + h_new(i,j,k) = max(0.0, G%areaT(i,j)*h_pre(i,j,k) + & + ((uhtr(I-1,j,k) - uhtr(I,j,k)) + (vhtr(i,J-1,k) - vhtr(i,J,k)))) + + ! Convert back to thickness + h_new(i,j,k) = max(GV%Angstrom_H, h_new(i,j,k) * G%IareaT(i,j)) + + enddo ; enddo + enddo +end subroutine update_h_horizontal_flux + +!> Updates layer thicknesses due to vertical mass transports +!! NOTE: Only used in non-ALE configuration +subroutine update_h_vertical_flux(G, GV, ea, eb, h_pre, h_new) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< Mass of fluid entrained from the layer + !! above within this timestep [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< Mass of fluid entrained from the layer + !! below within this timestep [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_pre !< Layer thicknesses at the end of the previous + !! step [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_new !< Updated layer thicknesses [H ~> m or kg m-2] + + ! Local variables + integer :: i, j, k, is, ie, js, je, nz + ! Set index-related variables for fields on T-grid + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + ! Update h_new with convergence of vertical mass transports + do j=js-1,je+1 + do i=is-1,ie+1 + ! Top layer + h_new(i,j,1) = max(0.0, h_pre(i,j,1) + ((eb(i,j,1) - ea(i,j,2)) + ea(i,j,1))) + + ! Bottom layer + h_new(i,j,nz) = max(0.0, h_pre(i,j,nz) + ((ea(i,j,nz) - eb(i,j,nz-1)) + eb(i,j,nz))) + enddo + + ! Interior layers + do k=2,nz-1 ; do i=is-1,ie+1 + h_new(i,j,k) = max(0.0, h_pre(i,j,k) + ((ea(i,j,k) - eb(i,j,k-1)) + & + (eb(i,j,k) - ea(i,j,k+1)))) + enddo ; enddo + enddo + +end subroutine update_h_vertical_flux + +!> This routine limits the mass fluxes so that the a layer cannot be completely depleted. +!! NOTE: Only used in non-ALE mode +subroutine limit_mass_flux_3d(G, GV, uh, vh, ea, eb, h_pre) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uh !< Mass flux through zonal face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vh !< Mass flux through meridional face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ea !< Mass of fluid entrained from the layer + !! above within this timestep [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: eb !< Mass of fluid entrained from the layer + !! below within this timestep [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_pre !< Layer thicknesses at the end of the previous + !! step [H ~> m or kg m-2] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: top_flux ! Net upward fluxes through the layer + ! top [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: bottom_flux ! Net downward fluxes through the layer + ! bottom [H ~> m or kg m-2] + real :: pos_flux ! Net flux out of cell [H L2 ~> m3 or kg] + real :: hvol ! Cell volume [H L2 ~> m3 or kg] + real :: scale_factor ! A nondimensional rescaling factor between 0 and 1 [nondim] + real :: max_off_cfl ! The maximum permitted fraction that can leave in a timestep [nondim] + integer :: i, j, k, is, ie, js, je, nz + + max_off_cfl = 0.5 + + ! In this subroutine, fluxes out of the box are scaled away if they deplete + ! the layer, note that we define the positive direction as flux out of the box. + ! Hence, uh(I-1) is multipled by negative one, but uh(I) is not + + ! Set index-related variables for fields on T-grid + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + ! Calculate top and bottom fluxes from ea and eb. Note the explicit negative signs + ! to enforce the positive out convention + k = 1 + do j=js-1,je+1 ; do i=is-1,ie+1 + top_flux(i,j,k) = -ea(i,j,k) + bottom_flux(i,j,k) = -(eb(i,j,k)-ea(i,j,k+1)) + enddo ; enddo + + do k=2,nz-1 ; do j=js-1,je+1 ; do i=is-1,ie+1 + top_flux(i,j,k) = -(ea(i,j,k)-eb(i,j,k-1)) + bottom_flux(i,j,k) = -(eb(i,j,k)-ea(i,j,k+1)) + enddo ; enddo ; enddo + + k=nz + do j=js-1,je+1 ; do i=is-1,ie+1 + top_flux(i,j,k) = -(ea(i,j,k)-eb(i,j,k-1)) + bottom_flux(i,j,k) = -eb(i,j,k) + enddo ; enddo + + + ! Calculate sum of positive fluxes (negatives applied to enforce convention) + ! in a given cell and scale it back if it would deplete a layer + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + + hvol = h_pre(i,j,k) * G%areaT(i,j) + pos_flux = ((max(0.0, -uh(I-1,j,k)) + max(0.0, uh(I,j,k))) + & + (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 + scale_factor = (hvol / pos_flux) * max_off_cfl + else ! Don't scale + scale_factor = 1.0 + endif + + ! Scale horizontal fluxes + if (-uh(I-1,j,k) > 0.0) uh(I-1,j,k) = uh(I-1,j,k) * scale_factor + if (uh(I,j,k) > 0.0) uh(I,j,k) = uh(I,j,k) * scale_factor + if (-vh(i,J-1,k) > 0.0) vh(i,J-1,k) = vh(i,J-1,k) * scale_factor + if (vh(i,J,k) > 0.0) vh(i,J,k) = vh(i,J,k) * scale_factor + + ! Scale the flux across the interface atop a layer if it is upward + if (top_flux(i,j,k) > 0.0) then + ea(i,j,k) = ea(i,j,k) * scale_factor + if (k > 1) & + eb(i,j,k-1) = eb(i,j,k-1) * scale_factor + endif + ! Scale the flux across the interface atop a layer if it is downward + if (bottom_flux(i,j,k) > 0.0) then + eb(i,j,k) = eb(i,j,k) * scale_factor + if (k < nz) & + ea(i,j,k+1) = ea(i,j,k+1) * scale_factor + endif + enddo ; enddo ; enddo + +end subroutine limit_mass_flux_3d + +!> In the case where offline advection has failed to converge, redistribute the u-flux +!! into remainder of the water column as a barotropic equivalent +subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) + type(ocean_grid_type), intent(in ) :: G !< ocean grid structure + type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in ) :: hvol !< Mass of water in the cells at the end + !! of the previous timestep [H L2 ~> m3 or kg] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uh !< Zonal mass transport within a timestep [H L2 ~> m3 or kg] + + ! Local variables + real, dimension(SZIB_(G),SZK_(GV)) :: uh2d ! A 2-d slice of transports [H L2 ~> m3 or kg] + real, dimension(SZIB_(G)) :: uh2d_sum ! Vertically summed transports [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZK_(GV)) :: h2d ! A 2-d slice of cell volumes [H L2 ~> m3 or kg] + real, dimension(SZI_(G)) :: h2d_sum ! Vertically summed cell volumes [H L2 ~> m3 or kg] + + real :: abs_uh_sum ! The vertical sum of the absolute value of the transports [H L2 ~> m3 or kg] + real :: new_uh_sum ! The vertically summed transports after redistribution [H L2 ~> m3 or kg] + real :: uh_neglect ! A negligible transport [H L2 ~> m3 or kg] + integer :: i, j, k, is, ie, js, je, nz + + ! Set index-related variables for fields on T-grid + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + do j=js,je + uh2d_sum(:) = 0.0 + ! Copy over uh to a working array and sum up the remaining fluxes in a column + do k=1,nz ; do I=is-1,ie + uh2d(I,k) = uh(I,j,k) + uh2d_sum(I) = uh2d_sum(I) + uh2d(I,k) + enddo ; enddo + + ! Copy over h to a working array and calculate total column volume + h2d_sum(:) = 0.0 + do k=1,nz ; do i=is-1,ie+1 + h2d(i,k) = hvol(i,j,k) + if (hvol(i,j,k)>0.) then + h2d_sum(i) = h2d_sum(i) + h2d(i,k) + else + h2d(i,k) = GV%H_subroundoff * G%areaT(i,j) + endif + enddo ; enddo + + ! Distribute flux. Note min/max is intended to make sure that the mass transport + ! does not deplete a cell + do I=is-1,ie + if ( uh2d_sum(I)>0.0 ) then + do k=1,nz + uh2d(I,k) = uh2d_sum(I)*(h2d(i,k)/h2d_sum(i)) + enddo + elseif (uh2d_sum(I)<0.0) then + do k=1,nz + uh2d(I,k) = uh2d_sum(I)*(h2d(i+1,k)/h2d_sum(i+1)) + enddo + else + do k=1,nz + uh2d(I,k) = 0.0 + enddo + endif + + ! Check that column integrated transports match the original to within roundoff. + uh_neglect = GV%Angstrom_H * min(G%areaT(i,j), G%areaT(i+1,j)) + abs_uh_sum = 0.0 ; new_uh_sum = 0.0 + do k=1,nz + abs_uh_sum = abs_uh_sum + abs(uh2d(j,k)) + new_uh_sum = new_uh_sum + uh2d(j,k) + enddo + if ( abs(new_uh_sum - uh2d_sum(j)) > max(uh_neglect, (5.0e-16*nz)*abs_uh_sum) ) & + call MOM_error(WARNING, "Column integral of uh does not match after "//& + "barotropic redistribution") + enddo + + do k=1,nz ; do I=is-1,ie + uh(I,j,k) = uh2d(I,k) + enddo ; enddo + enddo + +end subroutine distribute_residual_uh_barotropic + +!> Redistribute the v-flux as a barotropic equivalent +subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) + type(ocean_grid_type), intent(in ) :: G !< ocean grid structure + type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in ) :: hvol !< Mass of water in the cells at the end + !! of the previous timestep [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vh !< Meridional mass transport within a timestep [H L2 ~> m3 or kg] + + ! Local variables + real, dimension(SZJB_(G),SZK_(GV)) :: vh2d ! A 2-d slice of transports [H L2 ~> m3 or kg] + real, dimension(SZJB_(G)) :: vh2d_sum ! Vertically summed transports [H L2 ~> m3 or kg] + real, dimension(SZJ_(G),SZK_(GV)) :: h2d ! A 2-d slice of cell volumes [H L2 ~> m3 or kg] + real, dimension(SZJ_(G)) :: h2d_sum ! Vertically summed cell volumes [H L2 ~> m3 or kg] + + real :: abs_vh_sum ! The vertical sum of the absolute value of the transports [H L2 ~> m3 or kg] + real :: new_vh_sum ! The vertically summed transports after redistribution [H L2 ~> m3 or kg] + real :: vh_neglect ! A negligible transport [H L2 ~> m3 or kg] + integer :: i, j, k, is, ie, js, je, nz + + ! Set index-related variables for fields on T-grid + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + do i=is,ie + vh2d_sum(:) = 0.0 + ! Copy over uh to a working array and sum up the remaining fluxes in a column + do k=1,nz ; do J=js-1,je + vh2d(J,k) = vh(i,J,k) + vh2d_sum(J) = vh2d_sum(J) + vh2d(J,k) + enddo ; enddo + + ! Copy over h to a working array and calculate column volume + h2d_sum(:) = 0.0 + do k=1,nz ; do j=js-1,je+1 + h2d(j,k) = hvol(i,j,k) + if (hvol(i,j,k)>0.) then + h2d_sum(j) = h2d_sum(j) + h2d(j,k) + else + h2d(i,k) = GV%H_subroundoff * G%areaT(i,j) + endif + enddo ; enddo + + ! Distribute flux evenly throughout a column + do J=js-1,je + if ( vh2d_sum(J)>0.0 ) then + do k=1,nz + vh2d(J,k) = vh2d_sum(J)*(h2d(j,k)/h2d_sum(j)) + enddo + elseif (vh2d_sum(J)<0.0) then + do k=1,nz + vh2d(J,k) = vh2d_sum(J)*(h2d(j+1,k)/h2d_sum(j+1)) + enddo + else + do k=1,nz + vh2d(J,k) = 0.0 + enddo + endif + + ! Check that column integrated transports match the original to within roundoff. + vh_neglect = GV%Angstrom_H * min(G%areaT(i,j), G%areaT(i,j+1)) + abs_vh_sum = 0.0 ; new_vh_sum = 0.0 + do k=1,nz + abs_vh_sum = abs_vh_sum + abs(vh2d(J,k)) + new_vh_sum = new_vh_sum + vh2d(J,k) + enddo + if ( abs(new_vh_sum - vh2d_sum(J)) > max(vh_neglect, (5.0e-16*nz)*abs_vh_sum) ) & + call MOM_error(WARNING, "Column integral of vh does not match after "//& + "barotropic redistribution") + enddo + + do k=1,nz ; do J=js-1,je + vh(i,J,k) = vh2d(J,k) + enddo ; enddo + enddo + +end subroutine distribute_residual_vh_barotropic + +!> In the case where offline advection has failed to converge, redistribute the u-flux +!! into layers above +subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) + type(ocean_grid_type), intent(in ) :: G !< ocean grid structure + type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in ) :: hvol !< Mass of water in the cells at the end + !! of the previous timestep [H L2 ~> m3 or kg] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uh !< Zonal mass transport within a timestep [H L2 ~> m3 or kg] + + ! Local variables + real, dimension(SZIB_(G),SZK_(GV)) :: uh2d ! A slice of transports [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZK_(GV)) :: h2d ! A slice of updated cell volumes [H L2 ~> m3 or kg] + + real :: uh_neglect, uh_remain, uh_sum, uh_col ! Transports [H L2 ~> m3 or kg] + real :: hup, hlos ! Various cell volumes [H L2 ~> m3 or kg] + real :: min_h ! A minimal layer thickness [H ~> m or kg m-2] + integer :: i, j, k, is, ie, js, je, nz, k_rev + + ! Set index-related variables for fields on T-grid + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + min_h = GV%Angstrom_H*0.1 + + do j=js,je + ! Copy over uh and cell volume to working arrays + do k=1,nz ; do i=is-2,ie+1 + uh2d(I,k) = uh(I,j,k) + enddo ; enddo + do k=1,nz ; do i=is-1,ie+1 + ! Subtract just a little bit of thickness to avoid roundoff errors + h2d(i,k) = hvol(i,j,k) - min_h * G%areaT(i,j) + enddo ; enddo + + do I=is-1,ie + uh_col = SUM(uh2d(I,:)) ! Store original column-integrated transport + do k=1,nz + uh_remain = uh2d(I,k) + uh2d(I,k) = 0.0 + 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 + hup = h2d(i+1,k_rev) + hlos = max(0.0,uh2d(I+1,k_rev)) + if ((((hup - hlos) + uh_sum) < 0.0) .and. & + ((0.5*hup + uh_sum) < 0.0)) then + uh2d(I,k_rev) = min(-0.5*hup,-hup+hlos,0.0) + uh_remain = uh_sum - uh2d(I,k_rev) + else + uh2d(I,k_rev) = uh_sum + uh_remain = 0.0 + exit + endif + else ! Transport to the right + hup = h2d(i,k_rev) + hlos = max(0.0,-uh2d(I-1,k_rev)) + if ((((hup - hlos) - uh_sum) < 0.0) .and. & + ((0.5*hup - uh_sum) < 0.0)) then + uh2d(I,k_rev) = max(0.5*hup,hup-hlos,0.0) + uh_remain = uh_sum - uh2d(I,k_rev) + else + uh2d(I,k_rev) = uh_sum + uh_remain = 0.0 + exit + endif + endif + enddo ! k_rev + endif + + if (abs(uh_remain) > 0.0) then + if (k uh_neglect) then + call MOM_error(WARNING,"Column integral of uh does not match after upwards redistribution") + endif + + enddo ! i-loop + + do k=1,nz ; do I=is-1,ie + uh(I,j,k) = uh2d(I,k) + enddo ; enddo + enddo + +end subroutine distribute_residual_uh_upwards + +!> In the case where offline advection has failed to converge, redistribute the u-flux +!! into layers above +subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) + type(ocean_grid_type), intent(in ) :: G !< ocean grid structure + type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in ) :: hvol !< Mass of water in the cells at the end + !! of the previous timestep [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vh !< Meridional mass transport within a timestep [H L2 ~> m3 or kg] + + ! Local variables + real, dimension(SZJB_(G),SZK_(GV)) :: vh2d ! A slice of transports [H L2 ~> m3 or kg] + real, dimension(SZJ_(G),SZK_(GV)) :: h2d ! A slice of updated cell volumes [H L2 ~> m3 or kg] + + real :: vh_neglect, vh_remain, vh_col, vh_sum ! Transports [H L2 ~> m3 or kg] + real :: hup, hlos ! Various cell volumes [H L2 ~> m3 or kg] + real :: min_h ! A minimal layer thickness [H ~> m or kg m-2] + integer :: i, j, k, is, ie, js, je, nz, k_rev + + ! Set index-related variables for fields on T-grid + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + min_h = 0.1*GV%Angstrom_H + + do i=is,ie + ! Copy over uh and cell volume to working arrays + do k=1,nz ; do J=js-2,je+1 + vh2d(J,k) = vh(i,J,k) + enddo ; enddo + do k=1,nz ; do j=js-1,je+1 + h2d(j,k) = hvol(i,j,k) - min_h * G%areaT(i,j) + enddo ; enddo + + do J=js-1,je + vh_col = SUM(vh2d(J,:)) + do k=1,nz + vh_remain = vh2d(J,k) + vh2d(J,k) = 0.0 + 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 + hup = h2d(j+1,k_rev) + hlos = MAX(0.0,vh2d(J+1,k_rev)) + if ((((hup - hlos) + vh_sum) < 0.0) .and. & + ((0.5*hup + vh_sum) < 0.0)) then + vh2d(J,k_rev) = MIN(-0.5*hup,-hup+hlos,0.0) + vh_remain = vh_sum - vh2d(J,k_rev) + else + vh2d(J,k_rev) = vh_sum + vh_remain = 0.0 + exit + endif + else ! Transport to the right + hup = h2d(j,k_rev) + hlos = MAX(0.0,-vh2d(J-1,k_rev)) + if ((((hup - hlos) - vh_sum) < 0.0) .and. & + ((0.5*hup - vh_sum) < 0.0)) then + vh2d(J,k_rev) = MAX(0.5*hup,hup-hlos,0.0) + vh_remain = vh_sum - vh2d(J,k_rev) + else + vh2d(J,k_rev) = vh_sum + vh_remain = 0.0 + exit + endif + endif + + enddo ! k_rev + endif + + if (abs(vh_remain) > 0.0) then + if (k vh_neglect) then + call MOM_error(WARNING,"Column integral of vh does not match after "//& + "upwards redistribution") + endif + enddo + + do k=1,nz ; do J=js-1,je + vh(i,J,k) = vh2d(J,k) + enddo ; enddo + enddo + +end subroutine distribute_residual_vh_upwards + +!> add_diurnal_SW adjusts the shortwave fluxes in an forcying_type variable +!! to add a synthetic diurnal cycle. Adapted from SIS2 +subroutine offline_add_diurnal_SW(fluxes, G, Time_start, Time_end) + type(forcing), intent(inout) :: fluxes !< The type with atmospheric fluxes to be adjusted. + type(ocean_grid_type), intent(in) :: G !< The ocean lateral grid type. + type(time_type), intent(in) :: Time_start !< The start time for this step. + type(time_type), intent(in) :: Time_end !< The ending time for this step. + + real :: diurnal_factor ! A scaling factor to insert a synthetic diurnal cycle [nondim] + real :: time_since_ae ! Time since the autumnal equinox expressed as a fraction of a year times 2 pi [nondim] + real :: rad ! A conversion factor from degrees to radians = pi/180 degrees [nondim] + real :: fracday_dt ! Daylight fraction averaged over a timestep [nondim] + real :: fracday_day ! Daylight fraction averaged over a day [nondim] + real :: cosz_day ! Cosine of the solar zenith angle averaged over a day [nondim] + real :: cosz_dt ! Cosine of the solar zenith angle averaged over a timestep [nondim] + real :: rrsun_day ! Earth-Sun distance (r) relative to the semi-major axis of + ! the orbital ellipse averaged over a day [nondim] + real :: rrsun_dt ! Earth-Sun distance (r) relative to the semi-major axis of + ! the orbital ellipse averaged over a timestep [nondim] + type(time_type) :: dt_here ! The time increment covered by this call + + integer :: i, j, i2, j2, isc, iec, jsc, jec, i_off, j_off + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + i_off = LBOUND(fluxes%sens,1) - G%isc ; j_off = LBOUND(fluxes%sens,2) - G%jsc + + ! Orbital_time extracts the time of year relative to the northern + ! hemisphere autumnal equinox from a time_type variable. + time_since_ae = orbital_time(Time_start) + dt_here = Time_end - Time_start + rad = acos(-1.)/180. + + !$OMP parallel do default(shared) private(i,j,i2,j2,cosz_dt,fracday_dt,rrsun_dt, & + !$OMP fracday_day,cosz_day,rrsun_day,diurnal_factor) + do j=jsc,jec ; do i=isc,iec +! Per Rick Hemler: +! Call diurnal_solar with dtime=dt_here to get cosz averaged over dt_here. +! Call daily_mean_solar to get cosz averaged over a day. Then +! diurnal_factor = cosz_dt_ice*fracday_dt_ice*rrsun_dt_ice / +! cosz_day*fracday_day*rrsun_day + + call diurnal_solar(G%geoLatT(i,j)*rad, G%geoLonT(i,j)*rad, Time_start, cosz=cosz_dt, & + fracday=fracday_dt, rrsun=rrsun_dt, dt_time=dt_here) + call daily_mean_solar(G%geoLatT(i,j)*rad, time_since_ae, cosz_day, fracday_day, rrsun_day) + diurnal_factor = cosz_dt*fracday_dt*rrsun_dt / & + max(1e-30, cosz_day*fracday_day*rrsun_day) + + i2 = i+i_off ; j2 = j+j_off + fluxes%sw(i2,j2) = fluxes%sw(i2,j2) * diurnal_factor + fluxes%sw_vis_dir(i2,j2) = fluxes%sw_vis_dir(i2,j2) * diurnal_factor + fluxes%sw_vis_dif(i2,j2) = fluxes%sw_vis_dif(i2,j2) * diurnal_factor + fluxes%sw_nir_dir(i2,j2) = fluxes%sw_nir_dir(i2,j2) * diurnal_factor + fluxes%sw_nir_dif(i2,j2) = fluxes%sw_nir_dif(i2,j2) * diurnal_factor + enddo ; enddo + +end subroutine offline_add_diurnal_sw + +!> Controls the reading in 3d mass fluxes, diffusive fluxes, and other fields stored +!! in a previous integration of the online model +subroutine update_offline_from_files(G, GV, US, nk_input, mean_file, sum_file, snap_file, & + surf_file, h_end, uhtr, vhtr, temp_mean, salt_mean, mld, Kd, fluxes, & + ridx_sum, ridx_snap, read_mld, read_sw, read_ts_uvh, do_ale_in) + + type(ocean_grid_type), intent(inout) :: G !< Horizontal grid type + type(verticalGrid_type), intent(in ) :: GV !< Vertical grid type + type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type + integer, intent(in ) :: nk_input !< Number of levels in input file + character(len=*), intent(in ) :: mean_file !< Name of file with averages fields + character(len=*), intent(in ) :: sum_file !< Name of file with summed fields + character(len=*), intent(in ) :: snap_file !< Name of file with snapshot fields + character(len=*), intent(in ) :: surf_file !< Name of file with surface fields + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_end !< End of timestep layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Zonal mass fluxes [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Meridional mass fluxes [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: temp_mean !< Averaged temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: salt_mean !< Averaged salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: mld !< Averaged mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(inout) :: Kd !< Diapycnal diffusivities at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + type(forcing), intent(inout) :: fluxes !< Fields with surface fluxes + integer, intent(in ) :: ridx_sum !< Read index for sum, mean, and surf files + integer, intent(in ) :: ridx_snap !< Read index for snapshot file + logical, intent(in ) :: read_mld !< True if reading in MLD + logical, intent(in ) :: read_sw !< True if reading in radiative fluxes + logical, intent(in ) :: read_ts_uvh !< True if reading in uh, vh, and h + logical, optional, intent(in ) :: do_ale_in !< True if using ALE algorithms + + logical :: do_ale + real :: convert_to_H ! A scale conversion factor from the thickness units in the + ! file to H [H m-1 or H m2 kg-1 ~> 1] + integer :: i, j, k, is, ie, js, je, nz + + do_ale = .false. + if (present(do_ale_in)) do_ale = do_ale_in + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (GV%Boussinesq) then + convert_to_H = GV%m_to_H + else + convert_to_H = GV%kg_m2_to_H + endif + + ! Check if reading in temperature, salinity, transports and ending thickness + if (read_ts_uvh) then + h_end(:,:,:) = 0.0 + temp_mean(:,:,:) = 0.0 + salt_mean(:,:,:) = 0.0 + uhtr(:,:,:) = 0.0 + vhtr(:,:,:) = 0.0 + ! Time-summed fields + call MOM_read_vector(sum_file, 'uhtr_sum', 'vhtr_sum', uhtr(:,:,1:nk_input), & + vhtr(:,:,1:nk_input), G%Domain, timelevel=ridx_sum, & + scale=US%m_to_L**2*GV%kg_m2_to_H) + call MOM_read_data(snap_file, 'h_end', h_end(:,:,1:nk_input), G%Domain, & + timelevel=ridx_snap, position=CENTER, scale=convert_to_H) + call MOM_read_data(mean_file, 'temp', temp_mean(:,:,1:nk_input), G%Domain, & + timelevel=ridx_sum, position=CENTER, scale=US%degC_to_C) + call MOM_read_data(mean_file, 'salt', salt_mean(:,:,1:nk_input), G%Domain, & + timelevel=ridx_sum, position=CENTER, scale=US%ppt_to_S) + + ! Fill temperature and salinity downward from the deepest input data. + do k=nk_input+1,nz ; do j=js,je ; do i=is,ie + if (G%mask2dT(i,j)>0.) then + temp_mean(i,j,k) = temp_mean(i,j,nk_input) + salt_mean(i,j,k) = salt_mean(i,j,nk_input) + endif + enddo ; enddo ; enddo + endif + + ! Check if reading vertical diffusivities or entrainment fluxes + call MOM_read_data( mean_file, 'Kd_interface', Kd(:,:,1:nk_input+1), G%Domain, & + timelevel=ridx_sum, position=CENTER, scale=GV%m2_s_to_HZ_T) + + ! This block makes sure that the fluxes control structure, which may not be used in the solo_driver, + ! contains netMassIn and netMassOut which is necessary for the applyTracerBoundaryFluxesInOut routine + if (do_ale) then + if (.not. associated(fluxes%netMassOut)) & + allocate(fluxes%netMassOut(G%isd:G%ied,G%jsd:G%jed), source=0.0) + if (.not. associated(fluxes%netMassIn)) & + allocate(fluxes%netMassIn(G%isd:G%ied,G%jsd:G%jed), source=0.0) + + fluxes%netMassOut(:,:) = 0.0 + fluxes%netMassIn(:,:) = 0.0 + call MOM_read_data(surf_file,'massout_flux_sum',fluxes%netMassOut, G%Domain, & + timelevel=ridx_sum, scale=GV%kg_m2_to_H) + call MOM_read_data(surf_file,'massin_flux_sum', fluxes%netMassIn, G%Domain, & + timelevel=ridx_sum, scale=GV%kg_m2_to_H) + + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j)<1.0) then + fluxes%netMassOut(i,j) = 0.0 + fluxes%netMassIn(i,j) = 0.0 + endif + enddo ; enddo + + endif + + if (read_mld) then + call MOM_read_data(surf_file, 'ePBL_h_ML', mld, G%Domain, timelevel=ridx_sum, scale=US%m_to_Z) + endif + + if (read_sw) then + ! Shortwave radiation is only needed for offline mode with biogeochemistry but without the coupler. + ! Need to double check, but set_opacity seems to only need the sum of the diffuse and + ! direct fluxes in the visible and near-infrared bands. For convenience, we store the + ! sum of the direct and diffuse fluxes in the 'dir' field and set the 'dif' fields to zero + call MOM_read_data(mean_file,'sw_vis', fluxes%sw_vis_dir, G%Domain, & + timelevel=ridx_sum, scale=US%W_m2_to_QRZ_T) + call MOM_read_data(mean_file,'sw_nir', fluxes%sw_nir_dir, G%Domain, & + timelevel=ridx_sum, scale=US%W_m2_to_QRZ_T) + fluxes%sw_vis_dir(:,:) = fluxes%sw_vis_dir(:,:)*0.5 + fluxes%sw_vis_dif(:,:) = fluxes%sw_vis_dir(:,:) + fluxes%sw_nir_dir(:,:) = fluxes%sw_nir_dir(:,:)*0.5 + fluxes%sw_nir_dif(:,:) = fluxes%sw_nir_dir(:,:) + fluxes%sw = (fluxes%sw_vis_dir + fluxes%sw_vis_dif) + (fluxes%sw_nir_dir + fluxes%sw_nir_dif) + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j)<1.0) then + fluxes%sw(i,j) = 0.0 + fluxes%sw_vis_dir(i,j) = 0.0 + fluxes%sw_nir_dir(i,j) = 0.0 + fluxes%sw_vis_dif(i,j) = 0.0 + fluxes%sw_nir_dif(i,j) = 0.0 + endif + enddo ; enddo + call pass_var(fluxes%sw,G%Domain) + call pass_var(fluxes%sw_vis_dir,G%Domain) + call pass_var(fluxes%sw_vis_dif,G%Domain) + call pass_var(fluxes%sw_nir_dir,G%Domain) + call pass_var(fluxes%sw_nir_dif,G%Domain) + endif + +end subroutine update_offline_from_files + +!> Fields for offline transport are copied from the stored arrays read during initialization +subroutine update_offline_from_arrays(G, GV, nk_input, ridx_sum, mean_file, sum_file, snap_file, uhtr, vhtr, & + hend, uhtr_all, vhtr_all, hend_all, temp, salt, temp_all, salt_all ) + type(ocean_grid_type), intent(inout) :: G !< Horizontal grid type + type(verticalGrid_type), intent(in ) :: GV !< Vertical grid type + integer, intent(in ) :: nk_input !< Number of levels in input file + integer, intent(in ) :: ridx_sum !< Index to read from + character(len=200), intent(in ) :: mean_file !< Name of file with averages fields + character(len=200), intent(in ) :: sum_file !< Name of file with summed fields + character(len=200), intent(in ) :: snap_file !< Name of file with snapshot fields + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Zonal mass fluxes [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Meridional mass fluxes [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: hend !< End of timestep layer thickness + !! [H ~> m or kg m-2] + real, dimension(:,:,:,:), allocatable, intent(inout) :: uhtr_all !< Zonal mass fluxes [H L2 ~> m3 or kg] + real, dimension(:,:,:,:), allocatable, intent(inout) :: vhtr_all !< Meridional mass fluxes [H L2 ~> m3 or kg] + real, dimension(:,:,:,:), allocatable, intent(inout) :: hend_all !< End of timestep layer thickness + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: temp !< Temperature array [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: salt !< Salinity array [S ~> ppt] + real, dimension(:,:,:,:), allocatable, intent(inout) :: temp_all !< Temperature array [C ~> degC] + real, dimension(:,:,:,:), allocatable, intent(inout) :: salt_all !< Salinity array [S ~> ppt] + + integer :: i, j, k, is, ie, js, je, nz + real, parameter :: fill_value = 0. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + ! Check that all fields are allocated (this is a redundant check) + if (.not. allocated(uhtr_all)) & + call MOM_error(FATAL, "uhtr_all not allocated before call to update_transport_from_arrays") + if (.not. allocated(vhtr_all)) & + call MOM_error(FATAL, "vhtr_all not allocated before call to update_transport_from_arrays") + if (.not. allocated(hend_all)) & + call MOM_error(FATAL, "hend_all not allocated before call to update_transport_from_arrays") + if (.not. allocated(temp_all)) & + call MOM_error(FATAL, "temp_all not allocated before call to update_transport_from_arrays") + if (.not. allocated(salt_all)) & + call MOM_error(FATAL, "salt_all not allocated before call to update_transport_from_arrays") + + ! Copy uh, vh, h_end, temp, and salt + do k=1,nk_input ; do j=js,je ; do i=is,ie + uhtr(I,j,k) = uhtr_all(I,j,k,ridx_sum) + vhtr(i,J,k) = vhtr_all(i,J,k,ridx_sum) + hend(i,j,k) = hend_all(i,j,k,ridx_sum) + temp(i,j,k) = temp_all(i,j,k,ridx_sum) + salt(i,j,k) = salt_all(i,j,k,ridx_sum) + enddo ; enddo ; enddo + + ! Fill the rest of the arrays with 0s (fill_value could probably be changed to a runtime parameter) + do k=nk_input+1,nz ; do j=js,je ; do i=is,ie + uhtr(I,j,k) = fill_value + vhtr(i,J,k) = fill_value + hend(i,j,k) = fill_value + temp(i,j,k) = fill_value + salt(i,j,k) = fill_value + enddo ; enddo ; enddo + +end subroutine update_offline_from_arrays + +!> Calculates the next timelevel to read from the input fields. This allows the 'looping' +!! of the fields +function next_modulo_time(inidx, numtime) + ! Returns the next time interval to be read + integer :: numtime ! Number of time levels in input fields + integer :: inidx ! The current time index + + integer :: read_index ! The index in the input files that corresponds + ! to the current timestep + + integer :: next_modulo_time + + read_index = mod(inidx+1,numtime) + if (read_index < 0) read_index = inidx-read_index + if (read_index == 0) read_index = numtime + + next_modulo_time = read_index + +end function next_modulo_time + +end module MOM_offline_aux + diff --git a/tracer/MOM_offline_main.F90 b/tracer/MOM_offline_main.F90 new file mode 100644 index 0000000000..06af35cefd --- /dev/null +++ b/tracer/MOM_offline_main.F90 @@ -0,0 +1,1649 @@ +!> The routines here implement the offline tracer algorithm used in MOM6. These are called from step_offline +!! Some routines called here can be found in the MOM_offline_aux module. +module MOM_offline_main + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_ALE, only : ALE_CS, ALE_regrid, ALE_offline_inputs +use MOM_ALE, only : pre_ALE_adjustments, ALE_update_regrid_weights +use MOM_ALE, only : ALE_remap_tracers +use MOM_checksums, only : hchksum, uvchksum +use MOM_coms, only : reproducing_sum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diabatic_aux, only : diabatic_aux_CS, set_pen_shortwave +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member +use MOM_diabatic_aux, only : tridiagTS +use MOM_diag_mediator, only : diag_ctrl, post_data, register_diag_field +use MOM_domains, only : pass_var, pass_vector +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING +use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_file_parser, only : read_param, get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : calc_derived_thermo, thickness_to_dz +use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER +use MOM_offline_aux, only : update_offline_from_arrays, update_offline_from_files +use MOM_offline_aux, only : next_modulo_time, offline_add_diurnal_sw +use MOM_offline_aux, only : update_h_horizontal_flux, update_h_vertical_flux, limit_mass_flux_3d +use MOM_offline_aux, only : distribute_residual_uh_barotropic, distribute_residual_vh_barotropic +use MOM_offline_aux, only : distribute_residual_uh_upwards, distribute_residual_vh_upwards +use MOM_opacity, only : opacity_CS, optics_type +use MOM_open_boundary, only : ocean_OBC_type +use MOM_time_manager, only : time_type, real_to_time +use MOM_tracer_advect, only : tracer_advect_CS, advect_tracer +use MOM_tracer_diabatic, only : applyTracerBoundaryFluxesInOut +use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_column_fns, call_tracer_stocks +use MOM_tracer_registry, only : tracer_registry_type, MOM_tracer_chksum, MOM_tracer_chkinv +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units + +implicit none ; private + +#include "MOM_memory.h" + +!> The control structure for the offline transport module +type, public :: offline_transport_CS ; private + + ! Pointers to relevant fields from the main MOM control structure + type(ALE_CS), pointer :: ALE_CSp => NULL() + !< A pointer to the ALE control structure + type(diabatic_CS), pointer :: diabatic_CSp => NULL() + !< A pointer to the diabatic control structure + type(diag_ctrl), pointer :: diag => NULL() + !< Structure that regulates diagnostic output + type(ocean_OBC_type), pointer :: OBC => NULL() + !< A pointer to the open boundary condition control structure + type(tracer_advect_CS), pointer :: tracer_adv_CSp => NULL() + !< A pointer to the tracer advection control structure + type(opacity_CS), pointer :: opacity_CSp => NULL() + !< A pointer to the opacity control structure + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() + !< A pointer to control structure that orchestrates the calling of tracer packages + type(tracer_registry_type), pointer :: tracer_Reg => NULL() + !< A pointer to the tracer registry + type(thermo_var_ptrs), pointer :: tv => NULL() + !< A structure pointing to various thermodynamic variables + type(optics_type), pointer :: optics => NULL() + !< Pointer to the optical properties type + type(diabatic_aux_CS), pointer :: diabatic_aux_CSp => NULL() + !< Pointer to the diabatic_aux control structure + + !> Variables related to reading in fields from online run + integer :: start_index !< Timelevel to start + integer :: iter_no !< Timelevel to start + integer :: numtime !< How many timelevels in the input fields + type(time_type) :: accumulated_time !< Length of time accumulated in the current offline interval + type(time_type) :: vertical_time !< The next value of accumulate_time at which to apply vertical processes + ! Index of each of the variables to be read in with separate indices for each variable if they + ! are set off from each other in time + integer :: ridx_sum = -1 !< Read index offset of the summed variables + integer :: ridx_snap = -1 !< Read index offset of the snapshot variables + integer :: nk_input !< Number of input levels in the input fields + character(len=200) :: offlinedir !< Directory where offline fields are stored + character(len=200) :: & ! Names of input files + surf_file, & !< Contains surface fields (2d arrays) + snap_file, & !< Snapshotted fields (layer thicknesses) + sum_file, & !< Fields which are accumulated over time + mean_file !< Fields averaged over time + character(len=20) :: redistribute_method !< 'barotropic' if evenly distributing extra flow + !! throughout entire watercolumn, 'upwards', + !! if trying to do it just in the layers above + !! 'both' if both methods are used + character(len=20) :: mld_var_name !< Name of the mixed layer depth variable to use + logical :: fields_are_offset !< True if the time-averaged fields and snapshot fields are + !! offset by one time level + logical :: x_before_y !< Which horizontal direction is advected first + logical :: print_adv_offline !< Prints out some updates each advection sub interation + logical :: skip_diffusion !< Skips horizontal diffusion of tracers + logical :: read_sw !< Read in averaged values for shortwave radiation + logical :: read_mld !< Check to see whether mixed layer depths should be read in + logical :: diurnal_sw !< Adds a synthetic diurnal cycle on shortwave radiation + logical :: debug !< If true, write verbose debugging messages + logical :: redistribute_barotropic !< Redistributes column-summed residual transports throughout + !! a column weighted by thickness + logical :: redistribute_upwards !< Redistributes remaining fluxes only in layers above + !! the current one based as the max allowable transport + !! in that cell + logical :: read_all_ts_uvh !< If true, then all timelevels of temperature, salinity, mass transports, and + !! Layer thicknesses are read during initialization + !! Variables controlling some of the numerical considerations of offline transport + integer :: num_off_iter !< Number of advection iterations per offline step + integer :: num_vert_iter !< Number of vertical iterations per offline step + integer :: off_ale_mod !< Sets how frequently the ALE step is done during the advection + real :: dt_offline !< Timestep used for offline tracers [T ~> s] + real :: dt_offline_vertical !< Timestep used for calls to tracer vertical physics [T ~> s] + real :: evap_CFL_limit !< Limit on the fraction of the water that can be fluxed out of the top + !! layer in a timestep [nondim]. This is Copied from diabatic_CS controlling + !! how tracers follow freshwater fluxes + real :: minimum_forcing_depth !< The smallest depth over which fluxes can be applied [H ~> m or kg m-2]. + !! This is copied from diabatic_CS controlling how tracers follow freshwater fluxes + + real :: Kd_max !< Runtime parameter specifying the maximum value of vertical diffusivity + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: min_residual !< The minimum amount of total mass flux before exiting the main advection + !! routine [H L2 ~> m3 or kg] + !>@{ Diagnostic manager IDs for some fields that may be of interest when doing offline transport + integer :: & + id_uhr = -1, & + id_vhr = -1, & + id_ear = -1, & + id_ebr = -1, & + id_hr = -1, & + id_hdiff = -1, & + id_uhr_redist = -1, & + id_vhr_redist = -1, & + id_uhr_end = -1, & + id_vhr_end = -1, & + id_eta_pre_distribute = -1, & + id_eta_post_distribute = -1, & + id_h_redist = -1, & + id_eta_diff_end = -1 + + ! Diagnostic IDs for the regridded/remapped input fields + integer :: & + id_uhtr_regrid = -1, & + id_vhtr_regrid = -1, & + id_temp_regrid = -1, & + id_salt_regrid = -1, & + id_h_regrid = -1 + !>@} + + ! IDs for timings of various offline components + integer :: id_clock_read_fields = -1 !< A CPU time clock + integer :: id_clock_offline_diabatic = -1 !< A CPU time clock + integer :: id_clock_offline_adv = -1 !< A CPU time clock + integer :: id_clock_redistribute = -1 !< A CPU time clock + + !> Zonal transport that may need to be stored between calls to step_MOM [H L2 ~> m3 or kg] + real, allocatable, dimension(:,:,:) :: uhtr + !> Meridional transport that may need to be stored between calls to step_MOM [H L2 ~> m3 or kg] + real, allocatable, dimension(:,:,:) :: vhtr + + ! Fields at T-point + real, allocatable, dimension(:,:,:) :: eatr + !< Amount of fluid entrained from the layer above within + !! one time step [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: ebtr + !< Amount of fluid entrained from the layer below within + !! one time step [H ~> m or kg m-2] + ! Fields at T-points on interfaces + real, allocatable, dimension(:,:,:) :: Kd !< Vertical diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, allocatable, dimension(:,:,:) :: h_end !< Thicknesses at the end of offline timestep [H ~> m or kg m-2] + + real, allocatable, dimension(:,:) :: mld !< Mixed layer depths at thickness points [Z ~> m] + + ! Allocatable arrays to read in entire fields during initialization + real, allocatable, dimension(:,:,:,:) :: uhtr_all !< Entire field of zonal transport [H L2 ~> m3 or kg] + real, allocatable, dimension(:,:,:,:) :: vhtr_all !< Entire field of meridional transport [H L2 ~> m3 or kg] + real, allocatable, dimension(:,:,:,:) :: hend_all !< Entire field of layer thicknesses [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:,:) :: temp_all !< Entire field of temperatures [C ~> degC] + real, allocatable, dimension(:,:,:,:) :: salt_all !< Entire field of salinities [S ~> ppt] + +end type offline_transport_CS + +public offline_advection_ale +public offline_redistribute_residual +public offline_diabatic_ale +public offline_fw_fluxes_into_ocean +public offline_fw_fluxes_out_ocean +public offline_advection_layer +public register_diags_offline_transport +public update_offline_fields +public insert_offline_main +public extract_offline_main +public post_offline_convergence_diags +public offline_transport_init +public offline_transport_end + +contains + +!> 3D advection is done by doing flux-limited nonlinear horizontal advection interspersed with an ALE +!! regridding/remapping step. The loop in this routine is exited if remaining residual transports are below +!! a runtime-specified value or a maximum number of iterations is reached. +subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, CS, id_clock_ale, & + h_pre, uhtr, vhtr, converged) + type(forcing), intent(inout) :: fluxes !< pointers to forcing fields + type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type + real, intent(in) :: time_interval !< time interval covered by this call [T ~> s] + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(offline_transport_CS), pointer :: CS !< control structure for offline module + integer, intent(in) :: id_clock_ALE !< Clock for ALE routines + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_pre !< layer thicknesses before advection + !! [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Zonal mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Meridional mass transport [H L2 ~> m3 or kg] + logical, intent( out) :: converged !< True if the iterations have converged + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uhtr_sub ! Substep zonal mass transports [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vhtr_sub ! Substep meridional mass transports [H L2 ~> m3 or kg] + + real :: prev_tot_residual, tot_residual ! Used to keep track of how close to convergence we are [H L2 ~> m3 or kg] + + ! Variables used to keep track of layer thicknesses at various points in the code + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + h_new, & ! Updated layer thicknesses [H ~> m or kg m-2] + h_post_remap, & ! Layer thicknesses after remapping [H ~> m or kg m-2] + h_vol ! Layer volumes [H L2 ~> m3 or kg] + real :: dzRegrid(SZI_(G),SZJ_(G),SZK_(GV)+1) ! The change in grid interface positions due to regridding, + ! in the same units as thicknesses [H ~> m or kg m-2] + integer :: niter, iter + real :: Inum_iter ! The inverse of the number of iterations [nondim] + character(len=256) :: mesg ! The text of an error message + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + logical :: x_before_y + real :: evap_CFL_limit ! Limit on the fraction of the water that can be fluxed out of the + ! top layer in a timestep [nondim] + real :: minimum_forcing_depth ! The smallest depth over which fluxes can be applied [H ~> m or kg m-2] + real :: dt_iter ! The timestep to use for each iteration [T ~> s] + real :: HL2_to_kg_scale ! Unit conversion factors to cell mass [kg H-1 L-2 ~> kg m-3 or 1] + character(len=20) :: debug_msg + call cpu_clock_begin(CS%id_clock_offline_adv) + + ! Grid-related pointer assignments + + x_before_y = CS%x_before_y + + ! Initialize some shorthand variables from other structures + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + evap_CFL_limit = CS%evap_CFL_limit + minimum_forcing_depth = CS%minimum_forcing_depth + + HL2_to_kg_scale = US%L_to_m**2*GV%H_to_kg_m2 + niter = CS%num_off_iter + Inum_iter = 1./real(niter) + dt_iter = CS%dt_offline*Inum_iter + + ! Initialize working arrays + h_new(:,:,:) = 0.0 + h_vol(:,:,:) = 0.0 + uhtr_sub(:,:,:) = 0.0 + vhtr_sub(:,:,:) = 0.0 + + ! converged should only be true if there are no remaining mass fluxes + converged = .false. + + ! Tracers are transported using the stored mass fluxes. Where possible, operators are Strang-split around + ! the call to + ! 1) Using the layer thicknesses and tracer concentrations from the previous timestep, + ! half of the accumulated vertical mixing (eatr and ebtr) is applied in the call to tracer_column_fns. + ! For tracers whose source/sink terms need dt, this value is set to 1/2 dt_offline + ! 2) Half of the accumulated surface freshwater fluxes are applied + !! START ITERATION + ! 3) Accumulated mass fluxes are used to do horizontal transport. The number of iterations used in + ! advect_tracer is limited to 2 (e.g x->y->x->y). The remaining mass fluxes are stored for later use + ! and resulting layer thicknesses fed into the next step + ! 4) Tracers and the h-grid are regridded and remapped in a call to ALE. This allows for layers which might + ! 'vanish' because of horizontal mass transport to be 'reinflated' + ! 5) Check that transport is done if the remaining mass fluxes equals 0 or if the max number of iterations + ! has been reached + !! END ITERATION + ! 6) Repeat steps 1 and 2 + ! 7) Force a remapping to the stored layer thicknesses that correspond to the snapshot of the online model + ! 8) Reset T/S and h to their stored snapshotted values to prevent model drift + + ! Copy over the horizontal mass fluxes from the total mass fluxes + do k=1,nz ; do j=jsd,jed ; do i=isdB,iedB + uhtr_sub(I,j,k) = uhtr(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do j=jsdB,jedB ; do i=isd,ied + vhtr_sub(i,J,k) = vhtr(i,J,k) + enddo ; enddo ; enddo + do k=1,nz ; do j=js,je ; do i=is,ie + h_new(i,j,k) = h_pre(i,j,k) + enddo ; enddo ; enddo + + if (CS%debug) then + call hchksum(h_pre, "h_pre before transport", G%HI, scale=GV%H_to_MKS) + call uvchksum("[uv]htr_sub before transport", uhtr_sub, vhtr_sub, G%HI, scale=HL2_to_kg_scale) + endif + tot_residual = remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) + if (CS%print_adv_offline) then + write(mesg,'(A,ES24.16)') "Main advection starting transport: ", tot_residual*HL2_to_kg_scale + call MOM_mesg(mesg) + endif + + ! This loop does essentially a flux-limited, nonlinear advection scheme until all mass fluxes + ! are used. ALE is done after the horizontal advection. + do iter=1,CS%num_off_iter + + do k=1,nz ; do j=js,je ; do i=is,ie + h_vol(i,j,k) = h_new(i,j,k) * G%areaT(i,j) + h_pre(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + if (CS%debug) then + call hchksum(h_vol, "h_vol before advect", G%HI, scale=HL2_to_kg_scale) + call uvchksum("[uv]htr_sub before advect", uhtr_sub, vhtr_sub, G%HI, scale=HL2_to_kg_scale) + write(debug_msg, '(A,I4.4)') 'Before advect ', iter + call MOM_tracer_chkinv(debug_msg, G, GV, h_pre, CS%tracer_reg) + endif + + call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, CS%dt_offline, G, GV, US, & + CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_before_y, vol_prev=h_vol, & + max_iter_in=1, update_vol_prev=.true., uhr_out=uhtr, vhr_out=vhtr) + + ! Switch the direction every iteration + x_before_y = .not. x_before_y + + ! Update the new layer thicknesses after one round of advection has happened + do k=1,nz ; do j=js,je ; do i=is,ie + h_new(i,j,k) = h_vol(i,j,k) * G%IareaT(i,j) + enddo ; enddo ; enddo + + if (MODULO(iter,CS%off_ale_mod)==0) then + ! Do ALE remapping/regridding to allow for more advection to occur in the next iteration + call pass_var(h_new,G%Domain) + if (CS%debug) then + call hchksum(h_new,"h_new before ALE", G%HI, scale=GV%H_to_MKS) + write(debug_msg, '(A,I4.4)') 'Before ALE ', iter + call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg) + endif + call cpu_clock_begin(id_clock_ALE) + + call ALE_update_regrid_weights(CS%dt_offline, CS%ALE_CSp) + call pre_ALE_adjustments(G, GV, US, h_new, CS%tv, CS%tracer_Reg, CS%ALE_CSp) + ! Uncomment this to adjust the target grids for diagnostics, if there have been thickness + ! adjustments, but the offline tracer code does not yet have the other corresponding calls + ! that would be needed to support remapping its output. + ! call diag_update_remap_grids(CS%diag, alt_h=h_new) + + call ALE_regrid(G, GV, US, h_new, h_post_remap, dzRegrid, CS%tv, CS%ALE_CSp) + + ! Remap all variables from the old grid h_new onto the new grid h_post_remap + call ALE_remap_tracers(CS%ALE_CSp, G, GV, h_new, h_post_remap, CS%tracer_Reg, & + CS%debug, dt=CS%dt_offline) + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + h_new(i,j,k) = h_post_remap(i,j,k) + enddo ; enddo ; enddo + call cpu_clock_end(id_clock_ALE) + + if (CS%debug) then + call hchksum(h_new, "h_new after ALE", G%HI, scale=GV%H_to_MKS) + write(debug_msg, '(A,I4.4)') 'After ALE ', iter + call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg) + endif + endif + + do k=1,nz ; do j=js,je ; do i=is,ie + uhtr_sub(I,j,k) = uhtr(I,j,k) + vhtr_sub(i,J,k) = vhtr(i,J,k) + enddo ; enddo ; enddo + call pass_var(h_new, G%Domain) + call pass_vector(uhtr_sub, vhtr_sub, G%Domain) + + ! Check for whether we've used up all the advection, or if we need to move on because + ! advection has stalled + tot_residual = remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) + if (CS%print_adv_offline) then + write(mesg,'(A,ES24.16)') "Main advection remaining transport: ", tot_residual*HL2_to_kg_scale + call MOM_mesg(mesg) + endif + ! If all the mass transports have been used u, then quit + if (tot_residual == 0.0) then + write(mesg,*) "Converged after iteration ", iter + call MOM_mesg(mesg) + converged = .true. + exit + endif + ! If advection has stalled or the remaining residual is less than a specified amount, quit + if ( (tot_residual == prev_tot_residual) .or. (tot_residual In the case where the main advection routine did not converge, something needs to be done with the remaining +!! transport. Two different ways are offered, 'barotropic' means that the residual is distributed equally +!! throughout the water column. 'upwards' attempts to redistribute the transport in the layers above and will +!! eventually work down the entire water column +subroutine offline_redistribute_residual(CS, G, GV, US, h_pre, uhtr, vhtr, converged) + type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_pre !< layer thicknesses before advection [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Zonal mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Meridional mass transport [H L2 ~> m3 or kg] + logical, intent(in ) :: converged !< True if the iterations have converged + + logical :: x_before_y + ! Variables used to keep track of layer thicknesses at various points in the code + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + h_new, & ! New layer thicknesses [H ~> m or kg m-2] + h_vol ! Cell volume [H L2 ~> m3 or kg] + + ! Used to calculate the eta diagnostics + real, dimension(SZI_(G),SZJ_(G)) :: eta_work ! The total column thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uhr !< Remaining zonal mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vhr !< Remaining meridional mass transport [H L2 ~> m3 or kg] + + character(len=256) :: mesg ! The text of an error message + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, iter + real :: HL2_to_kg_scale ! Unit conversion factors to cell mass [kg H-1 L-2 ~> kg m-3 or 1] + real :: prev_tot_residual, tot_residual ! The absolute value of the remaining transports [H L2 ~> m3 or kg] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + x_before_y = CS%x_before_y + HL2_to_kg_scale = US%L_to_m**2*GV%H_to_kg_m2 + + if (CS%id_eta_pre_distribute>0) then + eta_work(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + if (h_pre(i,j,k) > GV%Angstrom_H) then + eta_work(i,j) = eta_work(i,j) + h_pre(i,j,k) + endif + enddo ; enddo ; enddo + call post_data(CS%id_eta_pre_distribute, eta_work, CS%diag) + endif + + ! These are used to find out how much will be redistributed in this routine + if (CS%id_h_redist>0) call post_data(CS%id_h_redist, h_pre, CS%diag) + if (CS%id_uhr_redist>0) call post_data(CS%id_uhr_redist, uhtr, CS%diag) + if (CS%id_vhr_redist>0) call post_data(CS%id_vhr_redist, vhtr, CS%diag) + + if (converged) return + + if (CS%debug) then + call MOM_tracer_chkinv("Before redistribute ", G, GV, h_pre, CS%tracer_reg) + endif + + call cpu_clock_begin(CS%id_clock_redistribute) + + if (CS%redistribute_upwards .or. CS%redistribute_barotropic) then + do iter = 1, CS%num_off_iter + + ! Perform upwards redistribution + if (CS%redistribute_upwards) then + + ! Calculate the layer volumes at beginning of redistribute + do k=1,nz ; do j=js,je ; do i=is,ie + h_vol(i,j,k) = h_pre(i,j,k) * G%areaT(i,j) + enddo ; enddo ; enddo + call pass_var(h_vol,G%Domain) + call pass_vector(uhtr, vhtr, G%Domain) + + if (CS%debug) then + call MOM_tracer_chksum("Before upwards redistribute ", CS%tracer_Reg, G) + call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) + endif + + if (x_before_y) then + call distribute_residual_uh_upwards(G, GV, h_vol, uhtr) + call distribute_residual_vh_upwards(G, GV, h_vol, vhtr) + else + call distribute_residual_vh_upwards(G, GV, h_vol, vhtr) + call distribute_residual_uh_upwards(G, GV, h_vol, uhtr) + endif + + call advect_tracer(h_pre, uhtr, vhtr, CS%OBC, CS%dt_offline, G, GV, US, & + CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_before_y, vol_prev=h_vol, & + max_iter_in=1, update_vol_prev=.true., uhr_out=uhr, vhr_out=vhr) + + if (CS%debug) then + call MOM_tracer_chksum("After upwards redistribute ", CS%tracer_Reg, G) + endif + + ! Convert h_new back to layer thickness for ALE remapping + do k=1,nz ; do j=js,je ; do i=is,ie + uhtr(I,j,k) = uhr(I,j,k) + vhtr(i,J,k) = vhr(i,J,k) + h_new(i,j,k) = h_vol(i,j,k) * G%IareaT(i,j) + h_pre(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + endif ! redistribute upwards + + ! Perform barotropic redistribution + if (CS%redistribute_barotropic) then + + ! Calculate the layer volumes at beginning of redistribute + do k=1,nz ; do j=js,je ; do i=is,ie + h_vol(i,j,k) = h_pre(i,j,k) * G%areaT(i,j) + enddo ; enddo ; enddo + call pass_var(h_vol, G%Domain) + call pass_vector(uhtr, vhtr, G%Domain) + + if (CS%debug) then + call MOM_tracer_chksum("Before barotropic redistribute ", CS%tracer_Reg, G) + call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) + endif + + if (x_before_y) then + call distribute_residual_uh_barotropic(G, GV, h_vol, uhtr) + call distribute_residual_vh_barotropic(G, GV, h_vol, vhtr) + else + call distribute_residual_vh_barotropic(G, GV, h_vol, vhtr) + call distribute_residual_uh_barotropic(G, GV, h_vol, uhtr) + endif + + call advect_tracer(h_pre, uhtr, vhtr, CS%OBC, CS%dt_offline, G, GV, US, & + CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_before_y, vol_prev=h_vol, & + max_iter_in=1, update_vol_prev=.true., uhr_out=uhr, vhr_out=vhr) + + if (CS%debug) then + call MOM_tracer_chksum("After barotropic redistribute ", CS%tracer_Reg, G) + endif + + ! Convert h_new back to layer thickness for ALE remapping + do k=1,nz ; do j=js,je ; do i=is,ie + uhtr(I,j,k) = uhr(I,j,k) + vhtr(i,J,k) = vhr(i,J,k) + h_new(i,j,k) = h_vol(i,j,k) * G%IareaT(i,j) + h_pre(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + endif ! redistribute barotropic + + ! Check to see if all transport has been exhausted + tot_residual = remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) + if (CS%print_adv_offline) then + write(mesg,'(A,ES24.16)') "Residual advection remaining transport: ", tot_residual*HL2_to_kg_scale + call MOM_mesg(mesg) + endif + ! If the remaining residual is 0, then this return is done + if (tot_residual==0.0 ) then + exit + endif + + if ( (tot_residual == prev_tot_residual) .or. (tot_residual0) then + eta_work(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + if (h_pre(i,j,k)>GV%Angstrom_H) then + eta_work(i,j) = eta_work(i,j) + h_pre(i,j,k) + endif + enddo ; enddo ; enddo + call post_data(CS%id_eta_post_distribute, eta_work, CS%diag) + endif + + if (CS%id_uhr>0) call post_data(CS%id_uhr, uhtr, CS%diag) + if (CS%id_vhr>0) call post_data(CS%id_vhr, vhtr, CS%diag) + + if (CS%debug) then + call hchksum(h_pre, "h_pre after redistribute", G%HI, scale=GV%H_to_MKS) + call uvchksum("uhtr after redistribute", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) + call MOM_tracer_chkinv("after redistribute ", G, GV, h_new, CS%tracer_Reg) + endif + + call cpu_clock_end(CS%id_clock_redistribute) + +end subroutine offline_redistribute_residual + +!> Returns the sums of any non-negligible remaining transport [H L2 ~> m3 or kg] to check for advection convergence +real function remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in ) :: uhtr !< Zonal mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in ) :: vhtr !< Meridional mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in ) :: h_new !< Layer thicknesses [H ~> m or kg m-2] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: trans_rem_col !< The vertical sum of the absolute value of + !! transports through the faces of a column, in MKS units [kg]. + real :: trans_cell !< The sum of the absolute value of the remaining transports through the faces + !! of a tracer cell [H L2 ~> m3 or kg] + real :: HL2_to_kg_scale !< Unit conversion factor to cell mass [kg H-1 L-2 ~> kg m-3 or 1] + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + HL2_to_kg_scale = GV%H_to_kg_m2 * US%L_to_m**2 + + trans_rem_col(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + trans_cell = (ABS(uhtr(I-1,j,k)) + ABS(uhtr(I,j,k))) + & + (ABS(vhtr(i,J-1,k)) + ABS(vhtr(i,J,k))) + if (trans_cell > max(1.0e-16*h_new(i,j,k), GV%H_subroundoff) * G%areaT(i,j)) & + trans_rem_col(i,j) = trans_rem_col(i,j) + HL2_to_kg_scale * trans_cell + enddo ; enddo ; enddo + + ! The factor of 0.5 here is to avoid double-counting because two cells share a face. + remaining_transport_sum = 0.5 * GV%kg_m2_to_H*US%m_to_L**2 * & + reproducing_sum(trans_rem_col, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) + +end function remaining_transport_sum + +!> The vertical/diabatic driver for offline tracers. First the eatr/ebtr associated with the interpolated +!! vertical diffusivities are calculated and then any tracer column functions are done which can include +!! vertical diffuvities and source/sink terms. +subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_pre, tv, eatr, ebtr) + + type(forcing), intent(inout) :: fluxes !< pointers to forcing fields + type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type + type(time_type), intent(in) :: Time_end !< ending time of a segment, as a time type + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_pre !< layer thicknesses before advection [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in ) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: eatr !< Entrainment from layer above [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ebtr !< Entrainment from layer below [H ~> m or kg m-2] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + sw, sw_vis, sw_nir !< Save old values of shortwave radiation [Q R Z T-1 ~> W m-2] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Vertical distance across layers [Z ~> m] + real :: I_dZval ! An inverse distance between layer centers [Z-1 ~> m] + integer :: i, j, k, is, ie, js, je, nz + integer :: k_nonzero + real :: Kd_bot ! Near-bottom diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + call cpu_clock_begin(CS%id_clock_offline_diabatic) + + call MOM_mesg("Applying tracer source, sinks, and vertical mixing") + + if (CS%debug) then + call hchksum(h_pre, "h_pre before offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call hchksum(eatr, "eatr before offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call hchksum(ebtr, "ebtr before offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call MOM_tracer_chkinv("Before offline_diabatic_ale", G, GV, h_pre, CS%tracer_reg) + endif + + call thickness_to_dz(h_pre, tv, dz, G, GV, US) + + eatr(:,:,:) = 0. + ebtr(:,:,:) = 0. + ! Calculate eatr and ebtr if vertical diffusivity is read + ! Because the saved remapped diagnostics from the online run assume a zero minimum thickness + ! but ALE may have a minimum thickness. Flood the diffusivities for all layers with the value + ! of Kd closest to the bottom which is non-zero + do j=js,je ; do i=is,ie + k_nonzero = nz+1 + ! Find the nonzero bottom Kd + do k=nz+1,1,-1 + if (CS%Kd(i,j,k)>0.) then + Kd_bot = CS%Kd(i,j,k) + k_nonzero = k + exit + endif + enddo + ! Flood the bottom interfaces + do k=k_nonzero,nz+1 + CS%Kd(i,j,k) = Kd_bot + enddo + enddo ; enddo + + do j=js,je ; do i=is,ie + eatr(i,j,1) = 0. + enddo ; enddo + do k=2,nz ; do j=js,je ; do i=is,ie + I_dZval = 1.0 / (GV%dZ_subroundoff + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + eatr(i,j,k) = CS%dt_offline_vertical * I_dZval * CS%Kd(i,j,k) + ebtr(i,j,k-1) = eatr(i,j,k) + enddo ; enddo ; enddo + do j=js,je ; do i=is,ie + ebtr(i,j,nz) = 0. + enddo ; enddo + + ! Add diurnal cycle for shortwave radiation (only used if run in ocean-only mode) + if (CS%diurnal_SW .and. CS%read_sw) then + sw(:,:) = fluxes%sw(:,:) + sw_vis(:,:) = fluxes%sw_vis_dir(:,:) + sw_nir(:,:) = fluxes%sw_nir_dir(:,:) + call offline_add_diurnal_SW(fluxes, G, Time_start, Time_end) + endif + + if (associated(CS%optics)) & + call set_pen_shortwave(CS%optics, fluxes, G, GV, US, CS%diabatic_aux_CSp, & + CS%opacity_CSp, CS%tracer_flow_CSp) + + ! Note that tracerBoundaryFluxesInOut within this subroutine should NOT be called + ! as the freshwater fluxes have already been accounted for + call call_tracer_column_fns(h_pre, h_pre, eatr, ebtr, fluxes, CS%MLD, CS%dt_offline_vertical, & + G, GV, US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) + + if (CS%diurnal_SW .and. CS%read_sw) then + fluxes%sw(:,:) = sw(:,:) + fluxes%sw_vis_dir(:,:) = sw_vis(:,:) + fluxes%sw_nir_dir(:,:) = sw_nir(:,:) + endif + + if (CS%debug) then + call hchksum(h_pre, "h_pre after offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call hchksum(eatr, "eatr after offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call hchksum(ebtr, "ebtr after offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call MOM_tracer_chkinv("After offline_diabatic_ale", G, GV, h_pre, CS%tracer_reg) + endif + + call cpu_clock_end(CS%id_clock_offline_diabatic) + +end subroutine offline_diabatic_ale + +!> Apply positive freshwater fluxes (into the ocean) and update netMassOut with only the negative +!! (out of the ocean) fluxes +subroutine offline_fw_fluxes_into_ocean(G, GV, CS, fluxes, h, in_flux_optional) + type(offline_transport_CS), intent(inout) :: CS !< Offline control structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(forcing), intent(inout) :: fluxes !< Surface fluxes container + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: in_flux_optional !< The total time-integrated amount + !! of tracer that leaves with freshwater + !! [CU H ~> Conc m or Conc kg m-2] + + integer :: i, j, m + real, dimension(SZI_(G),SZJ_(G)) :: negative_fw !< store all negative fluxes [H ~> m or kg m-2] + logical :: update_h !< Flag for whether h should be updated + + if ( present(in_flux_optional) ) & + call MOM_error(WARNING, "Positive freshwater fluxes with non-zero tracer concentration not supported yet") + + ! Set all fluxes to 0 + negative_fw(:,:) = 0. + + ! Sort fluxes into positive and negative + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (fluxes%netMassOut(i,j)<0.0) then + negative_fw(i,j) = fluxes%netMassOut(i,j) + fluxes%netMassOut(i,j) = 0. + endif + enddo ; enddo + + if (CS%debug) then + call hchksum(h, "h before fluxes into ocean", G%HI, scale=GV%H_to_MKS) + call MOM_tracer_chkinv("Before fluxes into ocean", G, GV, h, CS%tracer_reg) + endif + do m = 1,CS%tracer_reg%ntr + ! Layer thicknesses should only be updated after the last tracer is finished + update_h = ( m == CS%tracer_reg%ntr ) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tracer_reg%tr(m)%t, CS%dt_offline, fluxes, h, & + CS%evap_CFL_limit, CS%minimum_forcing_depth, update_h_opt=update_h) + enddo + if (CS%debug) then + call hchksum(h, "h after fluxes into ocean", G%HI, scale=GV%H_to_MKS) + call MOM_tracer_chkinv("After fluxes into ocean", G, GV, h, CS%tracer_reg) + endif + + ! Now that fluxes into the ocean are done, save the negative fluxes for later + fluxes%netMassOut(:,:) = negative_fw(:,:) + +end subroutine offline_fw_fluxes_into_ocean + +!> Apply negative freshwater fluxes (out of the ocean) +subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) + type(offline_transport_CS), intent(inout) :: CS !< Offline control structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(forcing), intent(inout) :: fluxes !< Surface fluxes container + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: out_flux_optional !< The total time-integrated amount + !! of tracer that leaves with freshwater + !! [CU H ~> Conc m or Conc kg m-2] + + integer :: m + logical :: update_h !< Flag for whether h should be updated + + if ( present(out_flux_optional) ) & + call MOM_error(WARNING, "Negative freshwater fluxes with non-zero tracer concentration not supported yet") + + if (CS%debug) then + call hchksum(h, "h before fluxes out of ocean", G%HI, scale=GV%H_to_MKS) + call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg) + endif + do m = 1, CS%tracer_reg%ntr + ! Layer thicknesses should only be updated after the last tracer is finished + update_h = ( m == CS%tracer_reg%ntr ) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tracer_reg%tr(m)%t, CS%dt_offline, fluxes, h, & + CS%evap_CFL_limit, CS%minimum_forcing_depth, update_h_opt = update_h) + enddo + if (CS%debug) then + call hchksum(h, "h after fluxes out of ocean", G%HI, scale=GV%H_to_MKS) + call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg) + endif + +end subroutine offline_fw_fluxes_out_ocean + +!> When in layer mode, 3D horizontal advection using stored mass fluxes must be used. Horizontal advection is +!! done via tracer_advect, whereas the vertical component is actually handled by vertdiff in tracer_column_fns +subroutine offline_advection_layer(fluxes, Time_start, time_interval, G, GV, US, CS, h_pre, eatr, ebtr, uhtr, vhtr) + type(forcing), intent(inout) :: fluxes !< pointers to forcing fields + type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type + real, intent(in) :: time_interval !< Offline transport time interval [T ~> s] + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(offline_transport_CS), pointer :: CS !< Control structure for offline module + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_pre !< layer thicknesses before advection [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: eatr !< Entrainment from layer above [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ebtr !< Entrainment from layer below [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Zonal mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Meridional mass transport [H L2 ~> m3 or kg] + + ! Local variables + + ! Remaining zonal mass transports [H L2 ~> m3 or kg] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uhtr_sub + ! Remaining meridional mass transports [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vhtr_sub + + real, dimension(SZI_(G),SZJB_(G)) :: rem_col_flux ! The summed absolute value of the remaining + ! fluxes through the faces of a column or within a column, in mks units [kg] + real :: sum_flux ! Globally summed absolute value of fluxes in mks units [kg], which is + ! used to keep track of how close to convergence we are. + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + eatr_sub, & ! Layer entrainment rate from above for this sub-cycle [H ~> m or kg m-2] + ebtr_sub ! Layer entrainment rate from below for this sub-cycle [H ~> m or kg m-2] + ! Variables used to keep track of layer thicknesses at various points in the code + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + h_new, & ! Updated thicknesses [H ~> m or kg m-2] + h_vol ! Cell volumes [H L2 ~> m3 or kg] + ! Work arrays for temperature and salinity + integer :: iter + real :: dt_iter ! The timestep of each iteration [T ~> s] + real :: HL2_to_kg_scale ! Unit conversion factors to cell mass [kg H-1 L-2 ~> kg m-3 or 1] + character(len=160) :: mesg ! The text of an error message + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + logical :: z_first, x_before_y + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + dt_iter = time_interval / real(max(1, CS%num_off_iter)) + x_before_y = CS%x_before_y + + do iter=1,CS%num_off_iter + + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + eatr_sub(i,j,k) = eatr(i,j,k) + ebtr_sub(i,j,k) = ebtr(i,j,k) + enddo ; enddo ; enddo + + do k=1,nz ; do j=js-1,je+1 ; do i=is-2,ie+1 + uhtr_sub(I,j,k) = uhtr(I,j,k) + enddo ; enddo ; enddo + + do k=1,nz ; do j=js-2,je+1 ; do i=is-1,ie+1 + vhtr_sub(i,J,k) = vhtr(i,J,k) + enddo ; enddo ; enddo + + ! Calculate 3d mass transports to be used in this iteration + call limit_mass_flux_3d(G, GV, uhtr_sub, vhtr_sub, eatr_sub, ebtr_sub, h_pre) + + if (z_first) then + ! First do vertical advection + call update_h_vertical_flux(G, GV, eatr_sub, ebtr_sub, h_pre, h_new) + call call_tracer_column_fns(h_pre, h_new, eatr_sub, ebtr_sub, & + fluxes, CS%mld, dt_iter, G, GV, US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) + ! We are now done with the vertical mass transports, so now h_new is h_sub + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + h_pre(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + call pass_var(h_pre,G%Domain) + + ! Second zonal and meridional advection + call update_h_horizontal_flux(G, GV, uhtr_sub, vhtr_sub, h_pre, h_new) + do k=1,nz ; do i=is-1,ie+1 ; do j=js-1,je+1 + h_vol(i,j,k) = h_pre(i,j,k) * G%areaT(i,j) + enddo ; enddo ; enddo + call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, dt_iter, G, GV, US, & + CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_before_y, vol_prev=h_vol, max_iter_in=30) + + ! Done with horizontal so now h_pre should be h_new + do k=1,nz ; do i=is-1,ie+1 ; do j=js-1,je+1 + h_pre(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + endif + + if (.not. z_first) then + + ! First zonal and meridional advection + call update_h_horizontal_flux(G, GV, uhtr_sub, vhtr_sub, h_pre, h_new) + do k=1,nz ; do i=is-1,ie+1 ; do j=js-1,je+1 + h_vol(i,j,k) = h_pre(i,j,k) * G%areaT(i,j) + enddo ; enddo ; enddo + call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, dt_iter, G, GV, US, CS%tracer_adv_CSp, & + CS%tracer_Reg, x_first_in=x_before_y, vol_prev=h_vol, max_iter_in=30) + + ! Done with horizontal so now h_pre should be h_new + do k=1,nz ; do i=is-1,ie+1 ; do j=js-1,je+1 + h_pre(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + ! Second vertical advection + call update_h_vertical_flux(G, GV, eatr_sub, ebtr_sub, h_pre, h_new) + call call_tracer_column_fns(h_pre, h_new, eatr_sub, ebtr_sub, & + fluxes, CS%mld, dt_iter, G, GV, US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) + ! We are now done with the vertical mass transports, so now h_new is h_sub + do k=1,nz ; do i=is-1,ie+1 ; do j=js-1,je+1 + h_pre(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + endif + + ! Update remaining transports + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + eatr(i,j,k) = eatr(i,j,k) - eatr_sub(i,j,k) + ebtr(i,j,k) = ebtr(i,j,k) - ebtr_sub(i,j,k) + enddo ; enddo ; enddo + + do k=1,nz ; do j=js-1,je+1 ; do i=is-2,ie+1 + uhtr(I,j,k) = uhtr(I,j,k) - uhtr_sub(I,j,k) + enddo ; enddo ; enddo + + do k=1,nz ; do j=js-2,je+1 ; do i=is-1,ie+1 + vhtr(i,J,k) = vhtr(i,J,k) - vhtr_sub(i,J,k) + enddo ; enddo ; enddo + + call pass_var(eatr,G%Domain) + call pass_var(ebtr,G%Domain) + call pass_var(h_pre,G%Domain) + call pass_vector(uhtr,vhtr,G%Domain) + + ! Calculate how close we are to converging by summing the remaining fluxes at each point + HL2_to_kg_scale = US%L_to_m**2*GV%H_to_kg_m2 + rem_col_flux(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + rem_col_flux(i,j) = rem_col_flux(i,j) + HL2_to_kg_scale * & + ( (abs(eatr(i,j,k)) + abs(ebtr(i,j,k))) + & + ((abs(uhtr(I-1,j,k)) + abs(uhtr(I,j,k))) + & + (abs(vhtr(i,J-1,k)) + abs(vhtr(i,J,k))) ) ) + enddo ; enddo ; enddo + sum_flux = reproducing_sum(rem_col_flux, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) + + if (sum_flux==0) then + write(mesg,*) 'offline_advection_layer: Converged after iteration', iter + call MOM_mesg(mesg) + exit + else + write(mesg,*) "offline_advection_layer: Iteration ", iter, " remaining total fluxes: ", sum_flux + call MOM_mesg(mesg) + endif + + ! Switch order of Strang split every iteration + z_first = .not. z_first + x_before_y = .not. x_before_y + enddo + +end subroutine offline_advection_layer + +!> Update fields used in this round of offline transport. First fields are updated from files or from arrays +!! read during initialization. Then if in an ALE-dependent coordinate, regrid/remap fields. +subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) + type(offline_transport_CS), pointer :: CS !< Control structure for offline module + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< The regridded layer thicknesses [H ~> m or kg m-2] + type(forcing), intent(inout) :: fluxes !< Pointers to forcing fields + logical, intent(in ) :: do_ale !< True if using ALE + ! Local variables + integer :: stencil + integer :: i, j, k, is, ie, js, je, nz + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_start ! Initial thicknesses [H ~> m or kg m-2] + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call cpu_clock_begin(CS%id_clock_read_fields) + call callTree_enter("update_offline_fields, MOM_offline_main.F90") + + if (CS%debug) then + call uvchksum("[uv]htr before update_offline_fields", CS%uhtr, CS%vhtr, G%HI, & + scale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(CS%h_end, "h_end before update_offline_fields", G%HI, scale=GV%H_to_MKS) + call hchksum(CS%tv%T, "Temp before update_offline_fields", G%HI, scale=US%C_to_degC) + call hchksum(CS%tv%S, "Salt before update_offline_fields", G%HI, scale=US%S_to_ppt) + endif + + ! Store a copy of the layer thicknesses before ALE regrid/remap + h_start(:,:,:) = h(:,:,:) + + ! Most fields will be read in from files + call update_offline_from_files( G, GV, US, CS%nk_input, CS%mean_file, CS%sum_file, CS%snap_file, & + CS%surf_file, CS%h_end, CS%uhtr, CS%vhtr, CS%tv%T, CS%tv%S, & + CS%mld, CS%Kd, fluxes, CS%ridx_sum, CS%ridx_snap, CS%read_mld, & + CS%read_sw, .not.CS%read_all_ts_uvh, do_ale) + ! If uh, vh, h_end, temp, salt were read in at the beginning, fields are copied from those arrays + if (CS%read_all_ts_uvh) then + call update_offline_from_arrays(G, GV, CS%nk_input, CS%ridx_sum, CS%mean_file, CS%sum_file, & + CS%snap_file, CS%uhtr, CS%vhtr, CS%h_end, CS%uhtr_all, CS%vhtr_all, & + CS%hend_all, CS%tv%T, CS%tv%S, CS%temp_all, CS%salt_all) + endif + if (CS%debug) then + call uvchksum("[uv]h after update offline from files and arrays", CS%uhtr, CS%vhtr, G%HI, & + scale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(CS%tv%T, "Temp after update offline from files and arrays", G%HI, scale=US%C_to_degC) + call hchksum(CS%tv%S, "Salt after update offline from files and arrays", G%HI, scale=US%S_to_ppt) + endif + + ! If using an ALE-dependent vertical coordinate, fields will need to be remapped + if (do_ale) then + ! These halo passes are necessary because u, v fields will need information 1 step into the halo + call pass_var(h, G%Domain) + call pass_var(CS%tv%T, G%Domain) + call pass_var(CS%tv%S, G%Domain) + call ALE_offline_inputs(CS%ALE_CSp, G, GV, US, h, CS%tv, CS%tracer_Reg, CS%uhtr, CS%vhtr, CS%Kd, & + CS%debug, CS%OBC) + if (CS%id_temp_regrid>0) call post_data(CS%id_temp_regrid, CS%tv%T, CS%diag) + if (CS%id_salt_regrid>0) call post_data(CS%id_salt_regrid, CS%tv%S, CS%diag) + if (CS%id_uhtr_regrid>0) call post_data(CS%id_uhtr_regrid, CS%uhtr, CS%diag) + if (CS%id_vhtr_regrid>0) call post_data(CS%id_vhtr_regrid, CS%vhtr, CS%diag) + if (CS%id_h_regrid>0) call post_data(CS%id_h_regrid, h, CS%diag) + if (CS%debug) then + call uvchksum("[uv]htr after ALE regridding/remapping of inputs", CS%uhtr, CS%vhtr, G%HI, & + scale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(h_start,"h_start after ALE regridding/remapping of inputs", G%HI, scale=GV%H_to_MKS) + endif + endif + + ! Update halos for some + call pass_var(CS%h_end, G%Domain) + call pass_var(CS%tv%T, G%Domain) + call pass_var(CS%tv%S, G%Domain) + + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call calc_derived_thermo(CS%tv, CS%h_end, G, GV, US, halo=stencil) + endif + + ! Update the read indices + CS%ridx_snap = next_modulo_time(CS%ridx_snap,CS%numtime) + CS%ridx_sum = next_modulo_time(CS%ridx_sum,CS%numtime) + + ! Apply masks/factors at T, U, and V points + do k=1,nz ; do j=js,je ; do i=is,ie + if (G%mask2dT(i,j)<1.0) then + CS%h_end(i,j,k) = GV%Angstrom_H + endif + enddo ; enddo ; enddo + + do k=1,nz+1 ; do j=js,je ; do i=is,ie + CS%Kd(i,j,k) = max(0.0, CS%Kd(i,j,k)) + if (CS%Kd_max>0.) then + CS%Kd(i,j,k) = MIN(CS%Kd_max, CS%Kd(i,j,k)) + endif + enddo ; enddo ; enddo + + do k=1,nz ; do J=js-1,je ; do i=is,ie + if (G%mask2dCv(i,J)<1.0) then + CS%vhtr(i,J,k) = 0.0 + endif + enddo ; enddo ; enddo + + do k=1,nz ; do j=js,je ; do I=is-1,ie + if (G%mask2dCu(I,j)<1.0) then + CS%uhtr(I,j,k) = 0.0 + endif + enddo ; enddo ; enddo + + if (CS%debug) then + call uvchksum("[uv]htr after update_offline_fields", CS%uhtr, CS%vhtr, G%HI, & + scale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(CS%h_end, "h_end after update_offline_fields", G%HI, scale=GV%H_to_MKS) + call hchksum(CS%tv%T, "Temp after update_offline_fields", G%HI, scale=US%C_to_degC) + call hchksum(CS%tv%S, "Salt after update_offline_fields", G%HI, scale=US%S_to_ppt) + endif + + call callTree_leave("update_offline_fields") + call cpu_clock_end(CS%id_clock_read_fields) + +end subroutine update_offline_fields + +!> Initialize additional diagnostics required for offline tracer transport +subroutine register_diags_offline_transport(Time, diag, CS, GV, US) + + type(offline_transport_CS), pointer :: CS !< Control structure for offline module + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(time_type), intent(in) :: Time !< current model time + type(diag_ctrl), intent(in) :: diag !< Structure that regulates diagnostic output + + ! U-cell fields + CS%id_uhr = register_diag_field('ocean_model', 'uhr', diag%axesCuL, Time, & + 'Zonal thickness fluxes remaining at end of advection', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) + CS%id_uhr_redist = register_diag_field('ocean_model', 'uhr_redist', diag%axesCuL, Time, & + 'Zonal thickness fluxes to be redistributed vertically', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) + CS%id_uhr_end = register_diag_field('ocean_model', 'uhr_end', diag%axesCuL, Time, & + 'Zonal thickness fluxes at end of offline step', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) + + ! V-cell fields + CS%id_vhr = register_diag_field('ocean_model', 'vhr', diag%axesCvL, Time, & + 'Meridional thickness fluxes remaining at end of advection', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) + CS%id_vhr_redist = register_diag_field('ocean_model', 'vhr_redist', diag%axesCvL, Time, & + 'Meridional thickness to be redistributed vertically', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) + CS%id_vhr_end = register_diag_field('ocean_model', 'vhr_end', diag%axesCvL, Time, & + 'Meridional thickness at end of offline step', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) + + ! T-cell fields + CS%id_hdiff = register_diag_field('ocean_model', 'hdiff', diag%axesTL, Time, & + 'Difference between the stored and calculated layer thickness', & + 'm', conversion=GV%H_to_m) + CS%id_hr = register_diag_field('ocean_model', 'hr', diag%axesTL, Time, & + 'Layer thickness at end of offline step', 'm', conversion=GV%H_to_m) + CS%id_ear = register_diag_field('ocean_model', 'ear', diag%axesTL, Time, & + 'Remaining thickness entrained from above', 'm') + CS%id_ebr = register_diag_field('ocean_model', 'ebr', diag%axesTL, Time, & + 'Remaining thickness entrained from below', 'm') + CS%id_eta_pre_distribute = register_diag_field('ocean_model','eta_pre_distribute', & + diag%axesT1, Time, 'Total water column height before residual transport redistribution', & + 'm', conversion=GV%H_to_m) + CS%id_eta_post_distribute = register_diag_field('ocean_model','eta_post_distribute', & + diag%axesT1, Time, 'Total water column height after residual transport redistribution', & + 'm', conversion=GV%H_to_m) + CS%id_eta_diff_end = register_diag_field('ocean_model','eta_diff_end', diag%axesT1, Time, & + 'Difference in total water column height from online and offline ' // & + 'at the end of the offline timestep', 'm', conversion=GV%H_to_m) + CS%id_h_redist = register_diag_field('ocean_model','h_redist', diag%axesTL, Time, & + 'Layer thicknesses before redistribution of mass fluxes', & + get_thickness_units(GV), conversion=GV%H_to_MKS) + + ! Regridded/remapped input fields + CS%id_uhtr_regrid = register_diag_field('ocean_model', 'uhtr_regrid', diag%axesCuL, Time, & + 'Zonal mass transport regridded/remapped onto offline grid', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) + CS%id_vhtr_regrid = register_diag_field('ocean_model', 'vhtr_regrid', diag%axesCvL, Time, & + 'Meridional mass transport regridded/remapped onto offline grid', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) + CS%id_temp_regrid = register_diag_field('ocean_model', 'temp_regrid', diag%axesTL, Time, & + 'Temperature regridded/remapped onto offline grid',& + 'C', conversion=US%C_to_degC) + CS%id_salt_regrid = register_diag_field('ocean_model', 'salt_regrid', diag%axesTL, Time, & + 'Salinity regridded/remapped onto offline grid', & + 'g kg-1', conversion=US%S_to_ppt) + CS%id_h_regrid = register_diag_field('ocean_model', 'h_regrid', diag%axesTL, Time, & + 'Layer thicknesses regridded/remapped onto offline grid', & + 'm', conversion=GV%H_to_m) + +end subroutine register_diags_offline_transport + +!> Posts diagnostics related to offline convergence diagnostics +subroutine post_offline_convergence_diags(G, GV, CS, h_off, h_end, uhtr, vhtr) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(offline_transport_CS), intent(in ) :: CS !< Offline control structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_off !< Thicknesses at end of offline step [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_end !< Stored thicknesses [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Remaining zonal mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Remaining meridional mass transport [H L2 ~> m3 or kg] + + real, dimension(SZI_(G),SZJ_(G)) :: eta_diff ! Differences in column thickness [H ~> m or kg m-2] + integer :: i, j, k + + if (CS%id_eta_diff_end>0) then + ! Calculate difference in column thickness + eta_diff = 0. + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + eta_diff(i,j) = eta_diff(i,j) + h_off(i,j,k) + enddo ; enddo ; enddo + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + eta_diff(i,j) = eta_diff(i,j) - h_end(i,j,k) + enddo ; enddo ; enddo + + call post_data(CS%id_eta_diff_end, eta_diff, CS%diag) + endif + + if (CS%id_hdiff>0) call post_data(CS%id_hdiff, h_off-h_end, CS%diag) + if (CS%id_hr>0) call post_data(CS%id_hr, h_off, CS%diag) + if (CS%id_uhr_end>0) call post_data(CS%id_uhr_end, uhtr, CS%diag) + if (CS%id_vhr_end>0) call post_data(CS%id_vhr_end, vhtr, CS%diag) + +end subroutine post_offline_convergence_diags + +!> Extracts members of the offline main control structure. All arguments are optional except +!! the control structure itself +subroutine extract_offline_main(CS, uhtr, vhtr, eatr, ebtr, h_end, accumulated_time, vertical_time, & + dt_offline, dt_offline_vertical, skip_diffusion) + type(offline_transport_CS), target, intent(in ) :: CS !< Offline control structure + ! Returned optional arguments + real, dimension(:,:,:), optional, pointer :: uhtr !< Remaining zonal mass transport [H L2 ~> m3 or kg] + real, dimension(:,:,:), optional, pointer :: vhtr !< Remaining meridional mass transport [H L2 ~> m3 or kg] + real, dimension(:,:,:), optional, pointer :: eatr !< Amount of fluid entrained from the layer above within + !! one time step [H ~> m or kg m-2] + real, dimension(:,:,:), optional, pointer :: ebtr !< Amount of fluid entrained from the layer below within + !! one time step [H ~> m or kg m-2] + real, dimension(:,:,:), optional, pointer :: h_end !< Thicknesses at the end of offline timestep + !! [H ~> m or kg m-2] + type(time_type), optional, pointer :: accumulated_time !< Length of time accumulated in the + !! current offline interval + type(time_type), optional, pointer :: vertical_time !< The next value of accumulate_time at which to + !! vertical processes + real, optional, intent( out) :: dt_offline !< Timestep used for offline tracers [T ~> s] + real, optional, intent( out) :: dt_offline_vertical !< Timestep used for calls to tracer + !! vertical physics [T ~> s] + logical, optional, intent( out) :: skip_diffusion !< Skips horizontal diffusion of tracers + + ! Pointers to 3d members + if (present(uhtr)) uhtr => CS%uhtr + if (present(vhtr)) vhtr => CS%vhtr + if (present(eatr)) eatr => CS%eatr + if (present(ebtr)) ebtr => CS%ebtr + if (present(h_end)) h_end => CS%h_end + + ! Pointers to integer members which need to be modified + if (present(accumulated_time)) accumulated_time => CS%accumulated_time + if (present(vertical_time)) vertical_time => CS%vertical_time + + ! Return value of non-modified integers + if (present(dt_offline)) dt_offline = CS%dt_offline + if (present(dt_offline_vertical)) dt_offline_vertical = CS%dt_offline_vertical + if (present(skip_diffusion)) skip_diffusion = CS%skip_diffusion + +end subroutine extract_offline_main + +!> Inserts (assigns values to) members of the offline main control structure. All arguments +!! are optional except for the CS itself +subroutine insert_offline_main(CS, ALE_CSp, diabatic_CSp, diag, OBC, tracer_adv_CSp, & + tracer_flow_CSp, tracer_Reg, tv, x_before_y, debug) + type(offline_transport_CS), intent(inout) :: CS !< Offline control structure + ! Inserted optional arguments + type(ALE_CS), & + target, optional, intent(in ) :: ALE_CSp !< A pointer to the ALE control structure + type(diabatic_CS), & + target, optional, intent(in ) :: diabatic_CSp !< A pointer to the diabatic control structure + type(diag_ctrl), & + target, optional, intent(in ) :: diag !< A pointer to the structure that regulates diagnostic output + type(ocean_OBC_type), & + target, optional, intent(in ) :: OBC !< A pointer to the open boundary condition control structure + type(tracer_advect_CS), & + target, optional, intent(in ) :: tracer_adv_CSp !< A pointer to the tracer advection control structure + type(tracer_flow_control_CS), & + target, optional, intent(in ) :: tracer_flow_CSp !< A pointer to the tracer flow control control structure + type(tracer_registry_type), & + target, optional, intent(in ) :: tracer_Reg !< A pointer to the tracer registry + type(thermo_var_ptrs), & + target, optional, intent(in ) :: tv !< A structure pointing to various thermodynamic variables + logical, optional, intent(in ) :: x_before_y !< Indicates which horizontal direction is advected first + logical, optional, intent(in ) :: debug !< If true, write verbose debugging messages + + + if (present(ALE_CSp)) CS%ALE_CSp => ALE_CSp + if (present(diabatic_CSp)) CS%diabatic_CSp => diabatic_CSp + if (present(diag)) CS%diag => diag + if (present(OBC)) CS%OBC => OBC + if (present(tracer_adv_CSp)) CS%tracer_adv_CSp => tracer_adv_CSp + if (present(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp + if (present(tracer_Reg)) CS%tracer_Reg => tracer_Reg + if (present(tv)) CS%tv => tv + if (present(x_before_y)) CS%x_before_y = x_before_y + if (present(debug)) CS%debug = debug + +end subroutine insert_offline_main + +!> Initializes the control structure for offline transport and reads in some of the +! run time parameters from MOM_input +subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) + + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(offline_transport_CS), pointer :: CS !< Offline control structure + type(diabatic_CS), intent(in) :: diabatic_CSp !< The diabatic control structure + type(ocean_grid_type), target, intent(in) :: G !< ocean grid structure + type(verticalGrid_type), target, intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), target, intent(in) :: US !< A dimensional unit scaling type + + character(len=40) :: mdl = "offline_transport" + character(len=20) :: redistribute_method + ! This include declares and sets the variable "version". +# include "version_variable.h" + integer :: is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + call callTree_enter("offline_transport_init, MOM_offline_control.F90") + + if (associated(CS)) then + call MOM_error(WARNING, "offline_transport_init called with an associated control structure.") + return + endif + allocate(CS) + call log_version(param_file, mdl, version, "This module allows for tracers to be run offline") + + ! Parse MOM_input for offline control + call get_param(param_file, mdl, "OFFLINEDIR", CS%offlinedir, & + "Input directory where the offline fields can be found", fail_if_missing=.true.) + call get_param(param_file, mdl, "OFF_SUM_FILE", CS%sum_file, & + "Filename where the accumulated fields can be found", fail_if_missing=.true.) + call get_param(param_file, mdl, "OFF_SNAP_FILE", CS%snap_file, & + "Filename where snapshot fields can be found", fail_if_missing=.true.) + call get_param(param_file, mdl, "OFF_MEAN_FILE", CS%mean_file, & + "Filename where averaged fields can be found", fail_if_missing=.true.) + call get_param(param_file, mdl, "OFF_SURF_FILE", CS%surf_file, & + "Filename where averaged fields can be found", fail_if_missing=.true.) + call get_param(param_file, mdl, "NUMTIME", CS%numtime, & + "Number of timelevels in offline input files", fail_if_missing=.true.) + call get_param(param_file, mdl, "NK_INPUT", CS%nk_input, & + "Number of vertical levels in offline input files", default=nz) + call get_param(param_file, mdl, "DT_OFFLINE", CS%dt_offline, & + "Length of time between reading in of input fields", units='s', scale=US%s_to_T, fail_if_missing=.true.) + call get_param(param_file, mdl, "DT_OFFLINE_VERTICAL", CS%dt_offline_vertical, & + "Length of the offline timestep for tracer column sources/sinks " //& + "This should be set to the length of the coupling timestep for " //& + "tracers which need shortwave fluxes", units="s", scale=US%s_to_T, fail_if_missing=.true.) + call get_param(param_file, mdl, "START_INDEX", CS%start_index, & + "Which time index to start from", default=1) + call get_param(param_file, mdl, "FIELDS_ARE_OFFSET", CS%fields_are_offset, & + "True if the time-averaged fields and snapshot fields "//& + "are offset by one time level", default=.false.) + call get_param(param_file, mdl, "REDISTRIBUTE_METHOD", redistribute_method, & + "Redistributes any remaining horizontal fluxes throughout " //& + "the rest of water column. Options are 'barotropic' which " //& + "evenly distributes flux throughout the entire water column, " //& + "'upwards' which adds the maximum of the remaining flux in " //& + "each layer above, both which first applies upwards and then " //& + "barotropic, and 'none' which does no redistribution", & + default='barotropic') + call get_param(param_file, mdl, "NUM_OFF_ITER", CS%num_off_iter, & + "Number of iterations to subdivide the offline tracer advection and diffusion", & + default=60) + call get_param(param_file, mdl, "OFF_ALE_MOD", CS%off_ale_mod, & + "Sets how many horizontal advection steps are taken before an ALE "//& + "remapping step is done. 1 would be x->y->ALE, 2 would be x->y->x->y->ALE", default=1) + call get_param(param_file, mdl, "PRINT_ADV_OFFLINE", CS%print_adv_offline, & + "Print diagnostic output every advection subiteration", default=.false.) + call get_param(param_file, mdl, "SKIP_DIFFUSION_OFFLINE", CS%skip_diffusion, & + "Do not do horizontal diffusion", default=.false.) + call get_param(param_file, mdl, "READ_SW", CS%read_sw, & + "Read in shortwave radiation field instead of using values from the coupler "//& + "when in offline tracer mode", default=.false.) + call get_param(param_file, mdl, "READ_MLD", CS%read_mld, & + "Read in mixed layer depths for tracers which exchange with the atmosphere "//& + "when in offline tracer mode", default=.false.) + call get_param(param_file, mdl, "MLD_VAR_NAME", CS%mld_var_name, & + "Name of the variable containing the depth of active mixing", default='ePBL_h_ML') + call get_param(param_file, mdl, "OFFLINE_ADD_DIURNAL_SW", CS%diurnal_sw, & + "Adds a synthetic diurnal cycle in the same way that the ice "//& + "model would have when time-averaged fields of shortwave "//& + "radiation are read in", default=.false.) + call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & + "The maximum permitted increment for the diapycnal "//& + "diffusivity from TKE-based parameterizations, or a "//& + "negative value for no limit.", units="m2 s-1", default=-1.0, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "MIN_RESIDUAL_TRANSPORT", CS%min_residual, & + "How much remaining transport before the main offline advection is exited. "//& + "The default value corresponds to about 1 meter of difference in a grid cell", & + default=1.e9, units="m3", scale=GV%m_to_H*US%m_to_L**2) + call get_param(param_file, mdl, "READ_ALL_TS_UVH", CS%read_all_ts_uvh, & + "Reads all time levels of a subset of the fields necessary to run " // & + "the model offline. This can require a large amount of memory "// & + "and will make initialization very slow. However, for offline "// & + "runs spanning more than a year this can reduce total I/O overhead", & + default=.false.) + + ! Concatenate offline directory and file names + CS%snap_file = trim(CS%offlinedir)//trim(CS%snap_file) + CS%mean_file = trim(CS%offlinedir)//trim(CS%mean_file) + CS%sum_file = trim(CS%offlinedir)//trim(CS%sum_file) + CS%surf_file = trim(CS%offlinedir)//trim(CS%surf_file) + + CS%num_vert_iter = CS%dt_offline / CS%dt_offline_vertical + + ! Map redistribute_method onto logicals in CS + select case (redistribute_method) + case ('barotropic') + CS%redistribute_barotropic = .true. + CS%redistribute_upwards = .false. + case ('upwards') + CS%redistribute_barotropic = .false. + CS%redistribute_upwards = .true. + case ('both') + CS%redistribute_barotropic = .true. + CS%redistribute_upwards = .true. + case ('none') + CS%redistribute_barotropic = .false. + CS%redistribute_upwards = .false. + end select + + ! Set the accumulated time to zero + CS%accumulated_time = real_to_time(0.0) + CS%vertical_time = CS%accumulated_time + ! Set the starting read index for time-averaged and snapshotted fields + CS%ridx_sum = CS%start_index + if (CS%fields_are_offset) CS%ridx_snap = next_modulo_time(CS%start_index,CS%numtime) + if (.not. CS%fields_are_offset) CS%ridx_snap = CS%start_index + + ! Copy members from other modules + call extract_diabatic_member(diabatic_CSp, opacity_CSp=CS%opacity_CSp, optics_CSp=CS%optics, & + diabatic_aux_CSp=CS%diabatic_aux_CSp, & + evap_CFL_limit=CS%evap_CFL_limit, & + minimum_forcing_depth=CS%minimum_forcing_depth) + + ! Allocate arrays + allocate(CS%uhtr(IsdB:IedB,jsd:jed,nz), source=0.0) + allocate(CS%vhtr(isd:ied,JsdB:JedB,nz), source=0.0) + allocate(CS%eatr(isd:ied,jsd:jed,nz), source=0.0) + allocate(CS%ebtr(isd:ied,jsd:jed,nz), source=0.0) + allocate(CS%h_end(isd:ied,jsd:jed,nz), source=0.0) + allocate(CS%Kd(isd:ied,jsd:jed,nz+1), source=0.0) + if (CS%read_mld) allocate(CS%mld(G%isd:G%ied,G%jsd:G%jed), source=0.0) + + if (CS%read_all_ts_uvh) then + call read_all_input(CS, G, GV, US) + endif + + ! Initialize ids for clocks used in offline routines + CS%id_clock_read_fields = cpu_clock_id('(Offline read fields)',grain=CLOCK_MODULE) + CS%id_clock_offline_diabatic = cpu_clock_id('(Offline diabatic)',grain=CLOCK_MODULE) + CS%id_clock_offline_adv = cpu_clock_id('(Offline transport)',grain=CLOCK_MODULE) + CS%id_clock_redistribute = cpu_clock_id('(Offline redistribute)',grain=CLOCK_MODULE) + + call callTree_leave("offline_transport_init") + +end subroutine offline_transport_init + +!> Coordinates the allocation and reading in all time levels of uh, vh, hend, temp, and salt from files. Used +!! when read_all_ts_uvh +subroutine read_all_input(CS, G, GV, US) + type(offline_transport_CS), intent(inout) :: CS !< Control structure for offline module + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + integer :: isd, ied, jsd, jed, nz, t, ntime + integer :: IsdB, IedB, JsdB, JedB + + nz = GV%ke ; ntime = CS%numtime + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + ! Extra safety check that we're not going to overallocate any arrays + if (CS%read_all_ts_uvh) then + if (allocated(CS%uhtr_all)) call MOM_error(FATAL, "uhtr_all is already allocated") + if (allocated(CS%vhtr_all)) call MOM_error(FATAL, "vhtr_all is already allocated") + if (allocated(CS%hend_all)) call MOM_error(FATAL, "hend_all is already allocated") + if (allocated(CS%temp_all)) call MOM_error(FATAL, "temp_all is already allocated") + if (allocated(CS%salt_all)) call MOM_error(FATAL, "salt_all is already allocated") + + allocate(CS%uhtr_all(IsdB:IedB,jsd:jed,nz,ntime), source=0.0) + allocate(CS%vhtr_all(isd:ied,JsdB:JedB,nz,ntime), source=0.0) + allocate(CS%hend_all(isd:ied,jsd:jed,nz,ntime), source=0.0) + allocate(CS%temp_all(isd:ied,jsd:jed,nz,1:ntime), source=0.0) + allocate(CS%salt_all(isd:ied,jsd:jed,nz,1:ntime), source=0.0) + + call MOM_mesg("Reading in uhtr, vhtr, h_start, h_end, temp, salt") + do t = 1,ntime + call MOM_read_vector(CS%snap_file, 'uhtr_sum', 'vhtr_sum', CS%uhtr_all(:,:,1:CS%nk_input,t), & + CS%vhtr_all(:,:,1:CS%nk_input,t), G%Domain, timelevel=t, & + scale=US%m_to_L**2*GV%kg_m2_to_H) + call MOM_read_data(CS%snap_file,'h_end', CS%hend_all(:,:,1:CS%nk_input,t), G%Domain, & + timelevel=t, position=CENTER, scale=GV%kg_m2_to_H) + call MOM_read_data(CS%mean_file,'temp', CS%temp_all(:,:,1:CS%nk_input,t), G%Domain, & + timelevel=t, position=CENTER, scale=US%degC_to_C) + call MOM_read_data(CS%mean_file,'salt', CS%salt_all(:,:,1:CS%nk_input,t), G%Domain, & + timelevel=t, position=CENTER, scale=US%ppt_to_S) + enddo + endif + +end subroutine read_all_input + +!> Deallocates (if necessary) arrays within the offline control structure +subroutine offline_transport_end(CS) + type(offline_transport_CS), pointer :: CS !< Control structure for offline module + + ! Explicitly allocate all allocatable arrays + deallocate(CS%uhtr) + deallocate(CS%vhtr) + deallocate(CS%eatr) + deallocate(CS%ebtr) + deallocate(CS%h_end) + deallocate(CS%Kd) + if (CS%read_mld) deallocate(CS%mld) + if (CS%read_all_ts_uvh) then + deallocate(CS%uhtr_all) + deallocate(CS%vhtr_all) + deallocate(CS%hend_all) + deallocate(CS%temp_all) + deallocate(CS%salt_all) + endif + + deallocate(CS) + +end subroutine offline_transport_end + +!> \namespace mom_offline_main +!! \section offline_overview Offline Tracer Transport in MOM6 +!! 'Offline tracer modeling' uses physical fields (e.g. mass transports and layer thicknesses) saved +!! from a previous integration of the physical model to transport passive tracers. These fields are +!! accumulated or averaged over a period of time (in this test case, 1 day) and used to integrate +!! portions of the MOM6 code base that handle the 3d advection and diffusion of passive tracers. +!! +!! The distribution of tracers in the ocean modeled offline should not be expected to match an online +!! simulation. Accumulating transports over more than one online model timestep implicitly assumes +!! homogeneity over that time period and essentially aliases over processes that occur with higher +!! frequency. For example, consider the case of a surface boundary layer with a strong diurnal cycle. +!! An offline simulation with a 1 day timestep, captures the net transport into or out of that layer, +!! but not the exact cycling. This effective aliasing may also complicate online model configurations +!! which strongly-eddying regions. In this case, the offline model timestep must be limited to some +!! fraction of the eddy correlation timescale. Lastly, the nonlinear advection scheme which applies +!! limited mass-transports over a sequence of iterations means that tracers are not transported along +!! exactly the same path as they are in the online model. +!! +!! This capability has currently targeted the Baltic_ALE_z test case, though some work has also been +!! done with the OM4 1/2 degree configuration. Work is ongoing to develop recommendations and best +!! practices for investigators seeking to use MOM6 for offline tracer modeling. +!! +!! \section offline_technical Implementation of offline routine in MOM6 +!! +!! The subroutine step_tracers that coordinates this can be found in MOM.F90 and is only called +!! using the solo ocean driver. This is to avoid issues with coupling to other climate components +!! that may be relying on fluxes from the ocean to be coupled more often than the offline time step. +!! Other routines related to offline tracer modeling can be found in tracers/MOM_offline_control.F90 +!! +!! As can also be seen in the comments for the step_tracers subroutine, an offline time step +!! comprises the following steps: +!! -# Using the layer thicknesses and tracer concentrations from the previous timestep, +!! half of the accumulated vertical mixing (eatr and ebtr) is applied in the call to +!! tracer_column_fns. +!! For tracers whose source/sink terms need dt, this value is set to 1/2 dt_offline +!! -# Half of the accumulated surface freshwater fluxes are applied +!! START ITERATION +!! -# Accumulated mass fluxes are used to do horizontal transport. The number of iterations +!! used in advect_tracer is limited to 2 (e.g x->y->x->y). The remaining mass fluxes are +!! stored for later use and resulting layer thicknesses fed into the next step +!! -# Tracers and the h-grid are regridded and remapped in a call to ALE. This allows for +!! layers which might 'vanish' because of horizontal mass transport to be 'reinflated' +!! and essentially allows for the vertical transport of tracers +!! -# Check that transport is done if the remaining mass fluxes equals 0 or if the max +!! number of iterations has been reached +!! END ITERATION +!! -# Repeat steps 1 and 2 +!! -# Redistribute any residual mass fluxes that remain after the advection iterations +!! in a barotropic manner, progressively upward through the water column. +!! -# Force a remapping to the stored layer thicknesses that correspond to the snapshot of +!! the online model at the end of an accumulation interval +!! -# Reset T/S and h to their stored snapshotted values to prevent model drift +!! +!! \section offline_evaluation Evaluating the utility of an offline tracer model +!! How well an offline tracer model can be used as an alternative to integrating tracers online +!! with the prognostic model must be evaluated for each application. This efficacy may be related +!! to the native coordinate of the online model, to the length of the offline timestep, and to the +!! behavior of the tracer itself. +!! +!! A framework for formally regression testing the offline capability still needs to be developed. +!! However, as a simple way of testing whether the offline model is nominally behaving as expected, +!! the total inventory of the advection test tracers (tr1, tr2, etc.) should be conserved between +!! time steps except for the last 4 decimal places. As a general guideline, an offline timestep of +!! 5 days or less. +!! +!! \section offline_parameters Runtime parameters for offline tracers +!! - OFFLINEDIR: Input directory where the offline fields can be found +!! - OFF_SUM_FILE: Filename where the accumulated fields can be found (e.g. horizontal mass transports) +!! - OFF_SNAP_FILE: Filename where snapshot fields can be found (e.g. end of timestep layer thickness) +!! - START_INDEX: Which timelevel of the input files to read first +!! - NUMTIME: How many timelevels to read before 'looping' back to 1 +!! - FIELDS_ARE_OFFSET: True if the time-averaged fields and snapshot fields are offset by one +!! time level, probably not needed +!! -NUM_OFF_ITER: Maximum number of iterations to do for the nonlinear advection scheme +!! -REDISTRIBUTE_METHOD: Redistributes any remaining horizontal fluxes throughout the rest of water column. +!! Options are 'barotropic' which "evenly distributes flux throughout the entire water +!! column,'upwards' which adds the maximum of the remaining flux in each layer above, +!! and 'none' which does no redistribution" + +end module MOM_offline_main + diff --git a/tracer/MOM_tracer_Z_init.F90 b/tracer/MOM_tracer_Z_init.F90 new file mode 100644 index 0000000000..2cf0ba1efe --- /dev/null +++ b/tracer/MOM_tracer_Z_init.F90 @@ -0,0 +1,743 @@ +!> Used to initialize tracers from a depth- (or z*-) space file. +module MOM_tracer_Z_init + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : MOM_read_data, get_var_sizes, read_attribute, read_variable +use MOM_io, only : open_file_to_read, close_file_to_read +use MOM_EOS, only : EOS_type, calculate_density, calculate_density_derivs, EOS_domain +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public tracer_Z_init, tracer_Z_init_array, determine_temperature + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> This function initializes a tracer by reading a Z-space file, returning +!! .true. if this appears to have been successful, and false otherwise. +function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_val, scale) + logical :: tracer_Z_init !< A return code indicating if the initialization has been successful + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: tr !< The tracer to initialize [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] or other + !! arbitrary units such as [Z ~> m] + character(len=*), intent(in) :: filename !< The name of the file to read from + character(len=*), intent(in) :: tr_name !< The name of the tracer in the file + real, optional, intent(in) :: missing_val !< The missing value for the tracer [CU ~> conc] + real, optional, intent(in) :: land_val !< A value to use to fill in land points [CU ~> conc] + real, optional, intent(in) :: scale !< A factor by which to scale the output tracers from the + !! their units in the file [CU conc-1 ~> 1] + + ! Local variables + real, allocatable, dimension(:,:,:) :: & + tr_in ! The z-space array of tracer concentrations that is read in [CU ~> conc] + real, allocatable, dimension(:) :: & + z_edges, & ! The depths of the cell edges or cell centers (depending on + ! the value of has_edges) in the input z* data [Z ~> m]. + tr_1d, & ! A copy of the input tracer concentrations in a column [CU ~> conc] + wt, & ! The fractional weight for each layer in the range between + ! k_top and k_bot [nondim] + z1, z2 ! z1 and z2 are the depths of the top and bottom limits of the part + ! of a z-cell that contributes to a layer, relative to the cell + ! center and normalized by the cell thickness [nondim]. + ! Note that -1/2 <= z1 <= z2 <= 1/2. + real :: e(SZK_(GV)+1) ! The z-star interface heights [Z ~> m]. + real :: landval ! The tracer value to use in land points [CU ~> conc] + real :: sl_tr ! The normalized slope of the tracer + ! within the cell, in tracer units [CU ~> conc] + real :: htot(SZI_(G)) ! The vertical sum of h [H ~> m or kg m-2]. + real :: dilate ! The amount by which the thicknesses are dilated to + ! create a z-star coordinate [Z H-1 ~> nondim or m3 kg-1] + ! or other units reflecting those of h + real :: missing ! The missing value for the tracer [CU ~> conc] + real :: scale_fac ! A factor by which to scale the output tracers from the units in the + ! input file [CU conc-1 ~> 1] + ! This include declares and sets the variable "version". +# include "version_variable.h" + logical :: has_edges, use_missing, zero_surface + character(len=80) :: loc_msg + integer :: k_top, k_bot, k_bot_prev, k_start + integer :: i, j, k, kz, is, ie, js, je, nz, nz_in + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + scale_fac = 1.0 ; if (present(scale)) then ; scale_fac = scale ; endif + + landval = 0.0 ; if (present(land_val)) landval = land_val + + zero_surface = .false. ! Make this false for errors to be fatal. + + use_missing = .false. + if (present(missing_val)) then + use_missing = .true. ; missing = missing_val + endif + + ! Find out the number of input levels and read the depth of the edges, + ! also modifying their sign convention to be monotonically decreasing. + call read_Z_edges(filename, tr_name, z_edges, nz_in, has_edges, use_missing, & + missing, scale=US%m_to_Z, missing_scale=scale_fac) + if (nz_in < 1) then + tracer_Z_init = .false. + return + endif + + allocate(tr_in(G%isd:G%ied,G%jsd:G%jed,nz_in), source=0.0) + allocate(tr_1d(nz_in), source=0.0) + call MOM_read_data(filename, tr_name, tr_in(:,:,:), G%Domain, scale=scale_fac) + + ! Fill missing values from above? Use a "close" test to avoid problems + ! from type-conversion rounoff. + if (present(missing_val)) then + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) == 0.0) then + tr_in(i,j,1) = landval + elseif (abs(tr_in(i,j,1) - missing_val) <= 1e-6*abs(missing_val)) then + write(loc_msg,'(f7.2," N ",f7.2," E")') G%geoLatT(i,j), G%geoLonT(i,j) + if (zero_surface) then + call MOM_error(WARNING, "tracer_Z_init: Missing value of "// & + trim(tr_name)//" found in an ocean point at "//trim(loc_msg)// & + " in "//trim(filename) ) + tr_in(i,j,1) = 0.0 + else + call MOM_error(FATAL, "tracer_Z_init: Missing value of "// & + trim(tr_name)//" found in an ocean point at "//trim(loc_msg)// & + " in "//trim(filename) ) + endif + endif + enddo ; enddo + do k=2,nz_in ; do j=js,je ; do i=is,ie + if (abs(tr_in(i,j,k) - missing_val) <= 1e-6*abs(missing_val)) & + tr_in(i,j,k) = tr_in(i,j,k-1) + enddo ; enddo ; enddo + endif + + allocate(wt(nz_in+1)) ; allocate(z1(nz_in+1)) ; allocate(z2(nz_in+1)) + + ! This is a placeholder, and will be replaced with our full vertical + ! interpolation machinery when it is in place. + if (has_edges) then + do j=js,je + do i=is,ie ; htot(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo + + do i=is,ie ; if (G%mask2dT(i,j)*htot(i) > 0.0) then + ! Determine the z* heights of the model interfaces. + dilate = (G%bathyT(i,j) + G%Z_ref) / htot(i) + e(nz+1) = -G%bathyT(i,j) - G%Z_ref + do k=nz,1,-1 ; e(K) = e(K+1) + dilate * h(i,j,k) ; enddo + + ! Create a single-column copy of tr_in. Efficiency is not an issue here. + do k=1,nz_in ; tr_1d(k) = tr_in(i,j,k) ; enddo + k_bot = 1 ; k_bot_prev = -1 + do k=1,nz + if (e(K+1) > z_edges(1)) then + tr(i,j,k) = tr_1d(1) + elseif (e(K) < z_edges(nz_in+1)) then + tr(i,j,k) = tr_1d(nz_in) + else + k_start = k_bot ! The starting point for this search + call find_overlap(z_edges, e(K), e(K+1), nz_in, & + k_start, k_top, k_bot, wt, z1, z2) + kz = k_top + if (kz /= k_bot_prev) then + ! Calculate the intra-cell profile. + sl_tr = 0.0 ! ; cur_tr = 0.0 + if ((kz < nz_in) .and. (kz > 1)) & + sl_tr = find_limited_slope(tr_1d, z_edges, kz) + endif + ! This is the piecewise linear form. + tr(i,j,k) = wt(kz) * (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) + ! For the piecewise parabolic form add the following... + ! + C1_3*cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) + do kz=k_top+1,k_bot-1 + tr(i,j,k) = tr(i,j,k) + wt(kz)*tr_1d(kz) + enddo + if (k_bot > k_top) then + kz = k_bot + ! Calculate the intra-cell profile. + sl_tr = 0.0 ! ; cur_tr = 0.0 + if ((kz < nz_in) .and. (kz > 1)) & + sl_tr = find_limited_slope(tr_1d, z_edges, kz) + ! This is the piecewise linear form. + tr(i,j,k) = tr(i,j,k) + wt(kz) * & + (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) + ! For the piecewise parabolic form add the following... + ! + C1_3*cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) + endif + k_bot_prev = k_bot + + ! Now handle the unlikely case where the layer partially extends + ! past the valid range of the input data by extrapolating using + ! the top or bottom value. + if ((e(K) > z_edges(1)) .and. (z_edges(nz_in+1) > e(K+1))) then + tr(i,j,k) = (((e(K) - z_edges(1)) * tr_1d(1) + & + (z_edges(1) - z_edges(nz_in)) * tr(i,j,k)) + & + (z_edges(nz_in+1) - e(K+1)) * tr_1d(nz_in)) / & + (e(K) - e(K+1)) + elseif (e(K) > z_edges(1)) then + tr(i,j,k) = ((e(K) - z_edges(1)) * tr_1d(1) + & + (z_edges(1) - e(K+1)) * tr(i,j,k)) / & + (e(K) - e(K+1)) + elseif (z_edges(nz_in) > e(K+1)) then + tr(i,j,k) = ((e(K) - z_edges(nz_in+1)) * tr(i,j,k) + & + (z_edges(nz_in+1) - e(K+1)) * tr_1d(nz_in)) / & + (e(K) - e(K+1)) + endif + endif + enddo ! k-loop + else + do k=1,nz ; tr(i,j,k) = landval ; enddo + endif ; enddo ! i-loop + enddo ! j-loop + else + ! Without edge values, integrate a linear interpolation between cell centers. + do j=js,je + do i=is,ie ; htot(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo + + do i=is,ie ; if (G%mask2dT(i,j)*htot(i) > 0.0) then + ! Determine the z* heights of the model interfaces. + dilate = (G%bathyT(i,j) + G%Z_ref) / htot(i) + e(nz+1) = -G%bathyT(i,j) - G%Z_ref + do k=nz,1,-1 ; e(K) = e(K+1) + dilate * h(i,j,k) ; enddo + + ! Create a single-column copy of tr_in. Efficiency is not an issue here. + do k=1,nz_in ; tr_1d(k) = tr_in(i,j,k) ; enddo + k_bot = 1 + do k=1,nz + if (e(K+1) > z_edges(1)) then + tr(i,j,k) = tr_1d(1) + elseif (z_edges(nz_in) > e(K)) then + tr(i,j,k) = tr_1d(nz_in) + else + k_start = k_bot ! The starting point for this search + call find_overlap(z_edges, e(K), e(K+1), nz_in-1, & + k_start, k_top, k_bot, wt, z1, z2) + + kz = k_top + if (k_top < nz_in) then + tr(i,j,k) = wt(kz)*0.5*((tr_1d(kz) + tr_1d(kz+1)) + & + (tr_1d(kz+1) - tr_1d(kz))*(z2(kz)+z1(kz))) + else + tr(i,j,k) = wt(kz)*tr_1d(nz_in) + endif + do kz=k_top+1,k_bot-1 + tr(i,j,k) = tr(i,j,k) + wt(kz)*0.5*(tr_1d(kz) + tr_1d(kz+1)) + enddo + if (k_bot > k_top) then + kz = k_bot + tr(i,j,k) = tr(i,j,k) + wt(kz)*0.5*((tr_1d(kz) + tr_1d(kz+1)) + & + (tr_1d(kz+1) - tr_1d(kz))*(z2(kz)+z1(kz))) + endif + + ! Now handle the case where the layer partially extends past + ! the valid range of the input data. + if ((e(K) > z_edges(1)) .and. (z_edges(nz_in) > e(K+1))) then + tr(i,j,k) = (((e(K) - z_edges(1)) * tr_1d(1) + & + (z_edges(1) - z_edges(nz_in)) * tr(i,j,k)) + & + (z_edges(nz_in) - e(K+1)) * tr_1d(nz_in)) / & + (e(K) - e(K+1)) + elseif (e(K) > z_edges(1)) then + tr(i,j,k) = ((e(K) - z_edges(1)) * tr_1d(1) + & + (z_edges(1) - e(K+1)) * tr(i,j,k)) / & + (e(K) - e(K+1)) + elseif (z_edges(nz_in) > e(K+1)) then + tr(i,j,k) = ((e(K) - z_edges(nz_in)) * tr(i,j,k) + & + (z_edges(nz_in) - e(K+1)) * tr_1d(nz_in)) / & + (e(K) - e(K+1)) + endif + endif + enddo + else + do k=1,nz ; tr(i,j,k) = landval ; enddo + endif ; enddo ! i-loop + enddo ! j-loop + endif + + deallocate(tr_in) ; deallocate(tr_1d) ; deallocate(z_edges) + deallocate(wt) ; deallocate(z1) ; deallocate(z2) + + tracer_Z_init = .true. + +end function tracer_Z_init + +!> Layer model routine for remapping tracers from pseudo-z coordinates into layers defined +!! by target interface positions. +subroutine tracer_z_init_array(tr_in, z_edges, nk_data, e, land_fill, G, nlay, nlevs, & + eps_z, tr, scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer, intent(in) :: nk_data !< The number of levels in the input data + real, dimension(SZI_(G),SZJ_(G),nk_data), & + intent(in) :: tr_in !< The z-space array of tracer concentrations + !! that is read in [A] + real, dimension(nk_data+1), intent(in) :: z_edges !< The depths of the cell edges in the input z* data + !! [Z ~> m] or [m] + integer, intent(in) :: nlay !< The number of vertical layers in the target grid + real, dimension(SZI_(G),SZJ_(G),nlay+1), & + intent(in) :: e !< The depths of the target layer interfaces [Z ~> m] or [m] + real, intent(in) :: land_fill !< fill in data over land [B] + integer, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: nlevs !< The number of input levels with valid data + real, intent(in) :: eps_z !< A negligibly thin layer thickness [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),nlay), & + intent(out) :: tr !< tracers in model space [B] + real, optional, intent(in) :: scale !< A factor by which to scale the output tracers from the + !! input tracers [B A-1 ~> 1] + + ! Local variables + real :: tr_1d(nk_data) ! A copy of the input tracer concentrations in a column [B] + real :: e_1d(nlay+1) ! A 1-d column of interface heights, in the same units as e [Z ~> m] or [m] + real :: sl_tr ! The tracer concentration slope times the layer thickness, in tracer units [B] + real :: wt(nk_data) ! The fractional weight for each layer in the range between z1 and z2 [nondim] + real :: z1(nk_data) ! The fractional depth of the top limit of the part of a z-cell that contributes to + ! a layer, relative to the cell center and normalized by the cell thickness [nondim]. + real :: z2(nk_data) ! The fractional depth of the bottom limit of the part of a z-cell that contributes to + ! a layer, relative to the cell center and normalized by the cell thickness [nondim]. + ! Note that -1/2 <= z1 <= z2 <= 1/2. + real :: scale_fac ! A factor by which to scale the output tracers from the input tracers [B A-1 ~> 1] + integer :: k_top, k_bot, k_bot_prev, kstart + integer :: i, j, k, kz, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + scale_fac = 1.0 ; if (present(scale)) then ; scale_fac = scale ; endif + + do j=js,je + i_loop: do i=is,ie + if (nlevs(i,j) == 0 .or. G%mask2dT(i,j) == 0.) then + tr(i,j,:) = land_fill + cycle i_loop + endif + + do k=1,nk_data + tr_1d(k) = scale_fac*tr_in(i,j,k) + enddo + + do k=1,nlay+1 + e_1d(k) = e(i,j,k) + enddo + k_bot = 1 ; k_bot_prev = -1 + do k=1,nlay + if (e_1d(k+1) > z_edges(1)) then + tr(i,j,k) = tr_1d(1) + elseif (e_1d(k) < z_edges(nlevs(i,j)+1)) then + tr(i,j,k) = tr_1d(nlevs(i,j)) + + else + kstart = k_bot + call find_overlap(z_edges, e_1d(k), e_1d(k+1), nlevs(i,j), & + kstart, k_top, k_bot, wt, z1, z2) + kz = k_top + sl_tr = 0.0 ! ; cur_tr=0.0 + if (kz /= k_bot_prev) then + ! Calculate the intra-cell profile. + if ((kz < nlevs(i,j)) .and. (kz > 1)) then + sl_tr = find_limited_slope(tr_1d, z_edges, kz) + endif + endif + if (kz > nlevs(i,j)) kz = nlevs(i,j) + ! This is the piecewise linear form. + tr(i,j,k) = wt(kz) * (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) + ! For the piecewise parabolic form add the following... + ! + C1_3*wt(kz) * cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) + do kz=k_top+1,k_bot-1 + tr(i,j,k) = tr(i,j,k) + wt(kz)*tr_1d(kz) + enddo + + if (k_bot > k_top) then + kz = k_bot + ! Calculate the intra-cell profile. + sl_tr = 0.0 ! ; cur_tr = 0.0 + if ((kz < nlevs(i,j)) .and. (kz > 1)) then + sl_tr = find_limited_slope(tr_1d, z_edges, kz) + endif + ! This is the piecewise linear form. + tr(i,j,k) = tr(i,j,k) + wt(kz) * (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) + ! For the piecewise parabolic form add the following... + ! + C1_3*cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) + endif + k_bot_prev = k_bot + + endif + enddo ! k-loop + + do k=2,nlay ! simply fill vanished layers with adjacent value + if (e_1d(k)-e_1d(k+1) <= eps_z) tr(i,j,k) = tr(i,j,k-1) + enddo + + enddo i_loop + enddo + +end subroutine tracer_z_init_array + +!> This subroutine reads the vertical coordinate data for a field from a NetCDF file. +!! It also might read the missing value attribute for that same field. +subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & + use_missing, missing, scale, missing_scale) + character(len=*), intent(in) :: filename !< The name of the file to read from. + character(len=*), intent(in) :: tr_name !< The name of the tracer in the file. + real, dimension(:), allocatable, & + intent(out) :: z_edges !< The depths of the vertical edges of the tracer array [Z ~> m] + integer, intent(out) :: nz_out !< The number of vertical layers in the tracer array + logical, intent(out) :: has_edges !< If true the values in z_edges are the edges of the + !! tracer cells, otherwise they are the cell centers + logical, intent(inout) :: use_missing !< If false on input, see whether the tracer has a + !! missing value, and if so return true + real, intent(inout) :: missing !< The missing value, if one has been found [CU ~> conc] + real, intent(in) :: scale !< A scaling factor for z_edges into new units [Z m-1 ~> 1] + real, intent(in) :: missing_scale !< A scaling factor to use to convert the + !! tracers and their missing value from the units in + !! the file into their internal units [CU conc-1 ~> 1] + + ! This subroutine reads the vertical coordinate data for a field from a + ! NetCDF file. It also might read the missing value attribute for that same field. + character(len=32) :: mdl + character(len=120) :: tr_msg, dim_msg + character(:), allocatable :: edge_name + character(len=256) :: dim_names(4) + logical :: monotonic + integer :: ncid, k + integer :: nz_edge, ndim, sizes(4) + + mdl = "MOM_tracer_Z_init read_Z_edges: " + tr_msg = trim(tr_name)//" in "//trim(filename) + + if (is_root_PE()) then + call open_file_to_read(filename, ncid) + else + ncid = -1 + endif + + call get_var_sizes(filename, tr_name, ndim, sizes, dim_names=dim_names, ncid_in=ncid) + if ((ndim < 3) .or. (ndim > 4)) & + call MOM_ERROR(FATAL, mdl//" "//trim(tr_msg)//" has too many or too few dimensions.") + nz_out = sizes(3) + + if (.not.use_missing) then ! Try to find the missing value from the dataset. + call read_attribute(filename, "missing_value", missing, varname=tr_name, found=use_missing, ncid_in=ncid) + if (use_missing) missing = missing * missing_scale + endif + ! Find out if the Z-axis has an edges attribute + call read_attribute(filename, "edges", edge_name, varname=dim_names(3), found=has_edges, ncid_in=ncid) + + nz_edge = sizes(3) ; if (has_edges) nz_edge = sizes(3)+1 + allocate(z_edges(nz_edge), source=0.0) + + if (nz_out < 1) return + + ! Read the right variable. + if (has_edges) then + call read_variable(filename, edge_name, z_edges, ncid) + else + call read_variable(filename, dim_names(3), z_edges, ncid) + endif + call close_file_to_read(ncid, filename) + if (allocated(edge_name)) deallocate(edge_name) + + ! z_edges should be montonically decreasing with our sign convention. + ! Change the sign sign convention if it looks like z_edges is increasing. + if (z_edges(1) < z_edges(2)) then + do k=1,nz_edge ; z_edges(k) = -z_edges(k) ; enddo + endif + ! Check that z_edges is now monotonically decreasing. + monotonic = .true. + do k=2,nz_edge ; if (z_edges(k) >= z_edges(k-1)) monotonic = .false. ; enddo + if (.not.monotonic) call MOM_error(WARNING,mdl//" "//trim(dim_msg)//" is not monotonic.") + + if (scale /= 1.0) then ; do k=1,nz_edge ; z_edges(k) = scale*z_edges(k) ; enddo ; endif + +end subroutine read_Z_edges + +!### `find_overlap` and `find_limited_slope` were previously part of +! MOM_diag_to_Z.F90, and are nearly identical to `find_overlap` in +! `midas_vertmap.F90` with some slight differences. We keep it here for +! reproducibility, but the two should be merged at some point + +!> Determines the layers bounded by interfaces e that overlap +!! with the depth range between Z_top and Z_bot, and the fractional weights +!! of each layer. It also calculates the normalized relative depths of the range +!! of each layer that overlaps that depth range. +subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z2) + real, dimension(:), intent(in) :: e !< Column interface heights, [Z ~> m] or other units. + real, intent(in) :: Z_top !< Top of range being mapped to, in the units of e [Z ~> m]. + real, intent(in) :: Z_bot !< Bottom of range being mapped to, in the units of e [Z ~> m]. + integer, intent(in) :: k_max !< Number of valid layers. + integer, intent(in) :: k_start !< Layer at which to start searching. + integer, intent(out) :: k_top !< Indices of top layers that overlap with the depth range. + integer, intent(out) :: k_bot !< Indices of bottom layers that overlap with the depth range. + real, dimension(:), intent(out) :: wt !< Relative weights of each layer from k_top to k_bot [nondim]. + real, dimension(:), intent(out) :: z1 !< Depth of the top limits of the part of + !! a layer that contributes to a depth level, relative to the cell center and normalized + !! by the cell thickness [nondim]. Note that -1/2 <= z1 < z2 <= 1/2. + real, dimension(:), intent(out) :: z2 !< Depths of the bottom limit of the part of + !! a layer that contributes to a depth level, relative to the cell center and normalized + !! by the cell thickness [nondim]. Note that -1/2 <= z1 < z2 <= 1/2. + + ! Local variables + real :: Ih ! The inverse of the vertical distance across a layer, in the inverse of the units of e [Z-1 ~> m-1] + real :: e_c ! The height of the layer center, in the units of e [Z ~> m] + real :: tot_wt ! The sum of the thicknesses contributing to a layer [Z ~> m] + real :: I_totwt ! The Adcroft reciprocal of tot_wt [Z-1 ~> m-1] + integer :: k + + wt(:) = 0.0 ; z1(:) = 0.0 ; z2(:) = 0.0 ; k_bot = k_max + + do k=k_start,k_max ; if (e(K+1) < Z_top) exit ; enddo + k_top = k + if (k_top > k_max) return + + ! Determine the fractional weights of each layer. + ! Note that by convention, e and Z_int decrease with increasing k. + if (e(K+1) <= Z_bot) then + wt(k) = 1.0 ; k_bot = k + Ih = 0.0 ; if (e(K) /= e(K+1)) Ih = 1.0 / (e(K)-e(K+1)) + e_c = 0.5*(e(K)+e(K+1)) + z1(k) = (e_c - MIN(e(K), Z_top)) * Ih + z2(k) = (e_c - Z_bot) * Ih + else + ! Note that in theis branch, wt temporarily has units of [Z ~> m] + wt(k) = MIN(e(K),Z_top) - e(K+1) ; tot_wt = wt(k) ! These are always > 0. + if (e(K) /= e(K+1)) then + z1(k) = (0.5*(e(K)+e(K+1)) - MIN(e(K), Z_top)) / (e(K)-e(K+1)) + else ; z1(k) = -0.5 ; endif + z2(k) = 0.5 + k_bot = k_max + do k=k_top+1,k_max + if (e(K+1) <= Z_bot) then + k_bot = k + wt(k) = e(K) - Z_bot ; z1(k) = -0.5 + if (e(K) /= e(K+1)) then + z2(k) = (0.5*(e(K)+e(K+1)) - Z_bot) / (e(K)-e(K+1)) + else ; z2(k) = 0.5 ; endif + else + wt(k) = e(K) - e(K+1) ; z1(k) = -0.5 ; z2(k) = 0.5 + endif + tot_wt = tot_wt + wt(k) ! wt(k) is always > 0. + if (k>=k_bot) exit + enddo + + I_totwt = 0.0 ; if (tot_wt > 0.0) I_totwt = 1.0 / tot_wt + ! This loop changes the units of wt from [Z ~> m] to [nondim]. + do k=k_top,k_bot ; wt(k) = I_totwt*wt(k) ; enddo + endif + +end subroutine find_overlap + +!> This subroutine determines a limited slope for val to be advected with +!! a piecewise limited scheme. +function find_limited_slope(val, e, k) result(slope) + real, dimension(:), intent(in) :: val !< A column of the values that are being interpolated, in arbitrary units [A] + real, dimension(:), intent(in) :: e !< A column's interface heights [Z ~> m] or other units. + integer, intent(in) :: k !< The layer whose slope is being determined. + real :: slope !< The normalized slope in the intracell distribution of val [A] + ! Local variables + real :: amn, cmn ! Limited differences and curvatures in the values [A] + real :: d1, d2 ! Layer thicknesses, in the units of e [Z ~> m] + + if ((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) then + slope = 0.0 ! ; curvature = 0.0 + else + d1 = 0.5*(e(K-1)-e(K+1)) ; d2 = 0.5*(e(K)-e(K+2)) + if (d1*d2 > 0.0) then + slope = ((d1**2)*(val(k+1) - val(k)) + (d2**2)*(val(k) - val(k-1))) * & + (e(K) - e(K+1)) / (d1*d2*(d1+d2)) + ! slope = 0.5*(val(k+1) - val(k-1)) + ! This is S.J. Lin's form of the PLM limiter. + amn = min(abs(slope), 2.0*(max(val(k-1), val(k), val(k+1)) - val(k))) + cmn = 2.0*(val(k) - min(val(k-1), val(k), val(k+1))) + slope = sign(1.0, slope) * min(amn, cmn) + + ! min(abs(slope), 2.0*(max(val(k-1),val(k),val(k+1)) - val(k)), & + ! 2.0*(val(k) - min(val(k-1),val(k),val(k+1)))) + ! curvature = 0.0 + else + slope = 0.0 ! ; curvature = 0.0 + endif + endif + +end function find_limited_slope + +!> This subroutine determines the potential temperature and salinity that +!! is consistent with the target density using provided initial guess +subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, G, GV, US, PF, & + just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: temp !< potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: salt !< salinity [S ~> ppt] + real, dimension(SZK_(GV)), intent(in) :: R_tgt !< desired potential density [R ~> kg m-3]. + type(EOS_type), intent(in) :: EOS !< seawater equation of state control structure + real, intent(in) :: p_ref !< reference pressure [R L2 T-2 ~> Pa]. + integer, intent(in) :: niter !< maximum number of iterations + integer, intent(in) :: k_start !< starting index (i.e. below the buffer layer) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: PF !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T or S. + + ! Local variables (All of which need documentation!) + real, dimension(SZI_(G),SZK_(GV)) :: & + T, & ! A 2-d working copy of the layer temperatures [C ~> degC] + S, & ! A 2-d working copy of the layer salinities [S ~> ppt] + dT, & ! An estimated change in temperature before bounding [C ~> degC] + dS, & ! An estimated change in salinity before bounding [S ~> ppt] + rho, & ! Layer densities with the current estimate of temperature and salinity [R ~> kg m-3] + drho_dT, & ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + drho_dS ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + real, dimension(SZI_(G)) :: press ! Reference pressures [R L2 T-2 ~> Pa] + real :: dT_dS_gauge ! The relative penalizing of temperature to salinity changes when + ! minimizing property changes while correcting density [C S-1 ~> degC ppt-1]. + real :: I_denom ! The inverse of the magnitude squared of the density gradient in + ! T-S space when stretched with dT_dS_gauge [S2 R-2 ~> ppt2 m6 kg-2] + real :: T_min, T_max ! The minimum and maximum temperatures [C ~> degC] + real :: S_min, S_max ! Minimum and maximum salinities [S ~> ppt] + real :: tol_T ! The tolerance for temperature matches [C ~> degC] + real :: tol_S ! The tolerance for salinity matches [S ~> ppt] + real :: tol_rho ! The tolerance for density matches [R ~> kg m-3] + real :: max_t_adj ! The largest permitted temperature changes with each iteration + ! when old_fit is true [C ~> degC] + real :: max_s_adj ! The largest permitted salinity changes with each iteration + ! when old_fit is true [S ~> ppt] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "determine_temperature" ! This subroutine's name. + logical :: adjust_salt, fit_together + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, nz, itt + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + ! ### The algorithms of determine_temperature subroutine needs to be reexamined. + + + call log_version(PF, mdl, version, "") + + ! We should switch the default to the newer method which simultaneously adjusts + ! temp and salt based on the ratio of the thermal and haline coefficients, once it is tested. + call get_param(PF, mdl, "DETERMINE_TEMP_ADJUST_T_AND_S", fit_together, & + "If true, simltaneously adjust the estimates of the temperature and salinity "//& + "based on the ratio of the thermal and haline coefficients. Otherwise try to "//& + "match the density by only adjusting temperatures within a maximum range before "//& + "revising estimates of the salinity.", default=.false., do_not_log=just_read) + ! These hard coded parameters need to be set properly. + call get_param(PF, mdl, "DETERMINE_TEMP_T_MIN", T_min, & + "The minimum temperature that can be found by determine_temperature.", & + units="degC", default=-2.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_T_MAX", T_max, & + "The maximum temperature that can be found by determine_temperature.", & + units="degC", default=31.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_S_MIN", S_min, & + "The minimum salinity that can be found by determine_temperature.", & + units="ppt", default=0.5, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_S_MAX", S_max, & + "The maximum salinity that can be found by determine_temperature.", & + units="ppt", default=65.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_T_TOLERANCE", tol_T, & + "The convergence tolerance for temperature in determine_temperature.", & + units="degC", default=1.0e-4, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_S_TOLERANCE", tol_S, & + "The convergence tolerance for temperature in determine_temperature.", & + units="ppt", default=1.0e-4, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_RHO_TOLERANCE", tol_rho, & + "The convergence tolerance for density in determine_temperature.", & + units="kg m-3", default=1.0e-4, scale=US%kg_m3_to_R, do_not_log=just_read) + if (fit_together) then + ! By default 10 degC is weighted equivalently to 1 ppt when minimizing changes. + call get_param(PF, mdl, "DETERMINE_TEMP_DT_DS_WEIGHT", dT_dS_gauge, & + "When extrapolating T & S to match the layer target densities, this "//& + "factor (in degC / ppt) is combined with the derivatives of density "//& + "with T & S to determine what direction is orthogonal to density contours. "//& + "It could be based on a typical value of (dR/dS) / (dR/dT) in oceanic profiles.", & + units="degC ppt-1", default=10.0, scale=US%degC_to_C*US%S_to_ppt) + else + call get_param(PF, mdl, "DETERMINE_TEMP_T_ADJ_RANGE", max_t_adj, & + "The maximum amount by which the initial layer temperatures can be "//& + "modified in determine_temperature.", & + units="degC", default=1.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_S_ADJ_RANGE", max_S_adj, & + "The maximum amount by which the initial layer salinities can be "//& + "modified in determine_temperature.", & + units="ppt", default=0.5, scale=US%ppt_to_S, do_not_log=just_read) + endif + + if (just_read) return ! All run-time parameters have been read, so return. + + press(:) = p_ref + EOSdom(:) = EOS_domain(G%HI) + + do j=js,je + dS(:,:) = 0. ! Needs to be zero everywhere since there is a maxval(abs(dS)) later... + T(:,:) = temp(:,j,:) + S(:,:) = salt(:,j,:) + dT(:,:) = 0.0 + adjust_salt = .true. + iter_loop: do itt = 1,niter + do k=1,nz + call calculate_density(T(:,k), S(:,k), press, rho(:,k), EOS, EOSdom ) + call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & + EOS, EOSdom ) + enddo + do k=k_start,nz ; do i=is,ie +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln) then + if (abs(rho(i,k)-R_tgt(k))>tol_rho) then + if (.not.fit_together) then + dT(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + else + I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) + dS(i,k) = (R_tgt(k)-rho(i,k)) * drho_dS(i,k) * I_denom + dT(i,k) = (R_tgt(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom + + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + endif + endif + enddo ; enddo + if (maxval(abs(dT)) < tol_T) then + adjust_salt = .false. + exit iter_loop + endif + enddo iter_loop + + if (adjust_salt .and. .not.fit_together) then ; do itt = 1,niter + do k=1,nz + call calculate_density(T(:,k), S(:,k), press, rho(:,k), EOS, EOSdom ) + call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & + EOS, EOSdom ) + enddo + do k=k_start,nz ; do i=is,ie +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln ) then + if (abs(rho(i,k)-R_tgt(k)) > tol_rho) then + dS(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + endif + enddo ; enddo + if (maxval(abs(dS)) < tol_S) exit + enddo ; endif + + temp(:,j,:) = T(:,:) + salt(:,j,:) = S(:,:) + enddo + +end subroutine determine_temperature + +end module MOM_tracer_Z_init diff --git a/tracer/MOM_tracer_advect.F90 b/tracer/MOM_tracer_advect.F90 new file mode 100644 index 0000000000..ef2c3125cd --- /dev/null +++ b/tracer/MOM_tracer_advect.F90 @@ -0,0 +1,1173 @@ +!> This module contains the subroutines that advect tracers along coordinate surfaces. +module MOM_tracer_advect + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type +use MOM_domains, only : sum_across_PEs, max_across_PEs +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type, pass_var +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_E +use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S +use MOM_open_boundary, only : OBC_segment_type +use MOM_tracer_registry, only : tracer_registry_type, tracer_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +implicit none ; private + +#include + +public advect_tracer +public tracer_advect_init +public tracer_advect_end + +!> Control structure for this module +type, public :: tracer_advect_CS ; private + real :: dt !< The baroclinic dynamics time step [T ~> s]. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !< timing of diagnostic output. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: usePPM !< If true, use PPM instead of PLM + logical :: useHuynh !< If true, use the Huynh scheme for PPM interface values + type(group_pass_type) :: pass_uhr_vhr_t_hprev !< A structure used for group passes +end type tracer_advect_CS + +!>@{ CPU time clocks +integer :: id_clock_advect +integer :: id_clock_pass +integer :: id_clock_sync +!>@} + +contains + +!> This routine time steps the tracer concentration using a +!! monotonic, conservative, weakly diffusive scheme. +subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first_in, & + vol_prev, max_iter_in, update_vol_prev, uhr_out, vhr_out) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_end !< Layer thickness after advection [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: uhtr !< Accumulated volume or mass flux through the + !! zonal faces [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vhtr !< Accumulated volume or mass flux through the + !! meridional faces [H L2 ~> m3 or kg] + type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used + real, intent(in) :: dt !< time increment [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tracer_advect_CS), pointer :: CS !< control structure for module + type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry + logical, optional, intent(in) :: x_first_in !< If present, indicate whether to update + !! first in the x- or y-direction. + ! The remaining optional arguments are only used in offline tracer mode. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(inout) :: vol_prev !< Cell volume before advection [H L2 ~> m3 or kg]. + !! If update_vol_prev is true, the returned value is + !! the cell volume after the transport that was done + !! by this call, and if all the transport could be + !! accommodated it should be close to h_end*G%areaT. + integer, optional, intent(in) :: max_iter_in !< The maximum number of iterations + logical, optional, intent(in) :: update_vol_prev !< If present and true, update vol_prev to + !! return its value after the tracer have been updated. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: uhr_out !< Remaining accumulated volume or mass fluxes + !! through the zonal faces [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(out) :: vhr_out !< Remaining accumulated volume or mass fluxes + !! through the meridional faces [H L2 ~> m3 or kg] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + hprev ! cell volume at the end of previous tracer change [H L2 ~> m3 or kg] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + uhr ! The remaining zonal thickness flux [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + vhr ! The remaining meridional thickness fluxes [H L2 ~> m3 or kg] + real :: uh_neglect(SZIB_(G),SZJ_(G)) ! uh_neglect and vh_neglect are the + real :: vh_neglect(SZI_(G),SZJB_(G)) ! magnitude of remaining transports that + ! can be simply discarded [H L2 ~> m3 or kg]. + + real :: landvolfill ! An arbitrary? nonzero cell volume [H L2 ~> m3 or kg]. + real :: Idt ! 1/dt [T-1 ~> s-1]. + logical :: domore_u(SZJ_(G),SZK_(GV)) ! domore_u and domore_v indicate whether there is more + logical :: domore_v(SZJB_(G),SZK_(GV)) ! advection to be done in the corresponding row or column. + logical :: x_first ! If true, advect in the x-direction first. + integer :: max_iter ! maximum number of iterations in each layer + integer :: domore_k(SZK_(GV)) + integer :: stencil ! stencil of the advection scheme + integer :: nsten_halo ! number of stencils that fit in the halos + integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz, itt, ntr, do_any + integer :: isv, iev, jsv, jev ! The valid range of the indices. + integer :: IsdB, IedB, JsdB, JedB + + domore_u(:,:) = .false. + domore_v(:,:) = .false. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + landvolfill = 1.0e-20 ! This is arbitrary, but must be positive. + stencil = 2 ! The scheme's stencil; 2 for PLM and PPM:H3 + + if (.not. associated(CS)) call MOM_error(FATAL, "MOM_tracer_advect: "// & + "tracer_advect_init must be called before advect_tracer.") + if (.not. associated(Reg)) call MOM_error(FATAL, "MOM_tracer_advect: "// & + "register_tracer must be called before advect_tracer.") + if (Reg%ntr==0) return + call cpu_clock_begin(id_clock_advect) + x_first = (MOD(G%first_direction,2) == 0) + + ! increase stencil size for Colella & Woodward PPM +! if (CS%usePPM .and. .not. CS%useHuynh) stencil = 3 + if (CS%usePPM) stencil = 3 + + ntr = Reg%ntr + Idt = 1.0 / dt + + max_iter = 2*INT(CEILING(dt/CS%dt)) + 1 + + if (present(max_iter_in)) max_iter = max_iter_in + if (present(x_first_in)) x_first = x_first_in + call cpu_clock_begin(id_clock_pass) + call create_group_pass(CS%pass_uhr_vhr_t_hprev, uhr, vhr, G%Domain) + call create_group_pass(CS%pass_uhr_vhr_t_hprev, hprev, G%Domain) + do m=1,ntr + call create_group_pass(CS%pass_uhr_vhr_t_hprev, Reg%Tr(m)%t, G%Domain) + enddo + call cpu_clock_end(id_clock_pass) + + !$OMP parallel default(shared) + + ! This initializes the halos of uhr and vhr because pass_vector might do + ! calculations on them, even though they are never used. + !$OMP do + do k=1,nz + do j=jsd,jed ; do I=IsdB,IedB ; uhr(I,j,k) = 0.0 ; enddo ; enddo + do J=jsdB,jedB ; do i=Isd,Ied ; vhr(i,J,k) = 0.0 ; enddo ; enddo + do j=jsd,jed ; do i=Isd,Ied ; hprev(i,j,k) = 0.0 ; enddo ; enddo + domore_k(k)=1 + ! Put the remaining (total) thickness fluxes into uhr and vhr. + do j=js,je ; do I=is-1,ie ; uhr(I,j,k) = uhtr(I,j,k) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; vhr(i,J,k) = vhtr(i,J,k) ; enddo ; enddo + if (.not. present(vol_prev)) then + ! This loop reconstructs the thickness field the last time that the + ! tracers were updated, probably just after the diabatic forcing. A useful + ! diagnostic could be to compare this reconstruction with that older value. + do j=js,je ; do i=is,ie + hprev(i,j,k) = max(0.0, G%areaT(i,j)*h_end(i,j,k) + & + ((uhr(I,j,k) - uhr(I-1,j,k)) + (vhr(i,J,k) - vhr(i,J-1,k)))) + ! In the case that the layer is now dramatically thinner than it was previously, + ! add a bit of mass to avoid truncation errors. This will lead to + ! non-conservation of tracers + hprev(i,j,k) = hprev(i,j,k) + & + max(0.0, 1.0e-13*hprev(i,j,k) - G%areaT(i,j)*h_end(i,j,k)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + hprev(i,j,k) = vol_prev(i,j,k) + enddo ; enddo + endif + enddo + + + !$OMP do + do j=jsd,jed ; do I=isd,ied-1 + uh_neglect(I,j) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i+1,j)) + enddo ; enddo + !$OMP do + do J=jsd,jed-1 ; do i=isd,ied + vh_neglect(i,J) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i,j+1)) + enddo ; enddo + + ! initialize diagnostic fluxes and tendencies + !$OMP do + do m=1,ntr + if (associated(Reg%Tr(m)%ad_x)) Reg%Tr(m)%ad_x(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%ad_y)) Reg%Tr(m)%ad_y(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%advection_xy)) Reg%Tr(m)%advection_xy(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%ad2d_x)) Reg%Tr(m)%ad2d_x(:,:) = 0.0 + if (associated(Reg%Tr(m)%ad2d_y)) Reg%Tr(m)%ad2d_y(:,:) = 0.0 + enddo + !$OMP end parallel + + isv = is ; iev = ie ; jsv = js ; jev = je + + do itt=1,max_iter + + if (isv > is-stencil) then + call do_group_pass(CS%pass_uhr_vhr_t_hprev, G%Domain, clock=id_clock_pass) + + nsten_halo = min(is-isd,ied-ie,js-jsd,jed-je)/stencil + isv = is-nsten_halo*stencil ; jsv = js-nsten_halo*stencil + iev = ie+nsten_halo*stencil ; jev = je+nsten_halo*stencil + ! Reevaluate domore_u & domore_v unless the valid range is the same size as + ! before. Also, do this if there is Strang splitting. + if ((nsten_halo > 1) .or. (itt==1)) then + !$OMP parallel do default(shared) + do k=1,nz ; if (domore_k(k) > 0) then + do j=jsv,jev ; if (.not.domore_u(j,k)) then + do i=isv+stencil-1,iev-stencil ; if (uhr(I,j,k) /= 0.0) then + domore_u(j,k) = .true. ; exit + endif ; enddo ! i-loop + endif ; enddo + do J=jsv+stencil-1,jev-stencil ; if (.not.domore_v(J,k)) then + do i=isv+stencil,iev-stencil ; if (vhr(i,J,k) /= 0.0) then + domore_v(J,k) = .true. ; exit + endif ; enddo ! i-loop + endif ; enddo + + ! At this point, domore_k is global. Change it so that it indicates + ! whether any work is needed on a layer on this processor. + domore_k(k) = 0 + do j=jsv,jev ; if (domore_u(j,k)) domore_k(k) = 1 ; enddo + do J=jsv+stencil-1,jev-stencil ; if (domore_v(J,k)) domore_k(k) = 1 ; enddo + + endif ; enddo ! k-loop + endif + endif + + ! Set the range of valid points after this iteration. + isv = isv + stencil ; iev = iev - stencil + jsv = jsv + stencil ; jev = jev - stencil + + ! To ensure positive definiteness of the thickness at each iteration, the + ! mass fluxes out of each layer are checked each step, and limited to keep + ! the thicknesses positive. This means that several iterations may be required + ! for all the transport to happen. The sum over domore_k keeps the processors + ! synchronized. This may not be very efficient, but it should be reliable. + + !$OMP parallel default(shared) + + if (x_first) then + + !$OMP do ordered + do k=1,nz ; if (domore_k(k) > 0) then + ! First, advect zonally. + call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & + isv, iev, jsv-stencil, jev+stencil, k, G, GV, US, CS%usePPM, CS%useHuynh) + endif ; enddo + + !$OMP do ordered + do k=1,nz ; if (domore_k(k) > 0) then + ! Next, advect meridionally. + call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & + isv, iev, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) + + ! Update domore_k(k) for the next iteration + domore_k(k) = 0 + do j=jsv-stencil,jev+stencil ; if (domore_u(j,k)) domore_k(k) = 1 ; enddo + do J=jsv-1,jev ; if (domore_v(J,k)) domore_k(k) = 1 ; enddo + + endif ; enddo + + else + + !$OMP do ordered + do k=1,nz ; if (domore_k(k) > 0) then + ! First, advect meridionally. + call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & + isv-stencil, iev+stencil, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) + endif ; enddo + + !$OMP do ordered + do k=1,nz ; if (domore_k(k) > 0) then + ! Next, advect zonally. + call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & + isv, iev, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) + + ! Update domore_k(k) for the next iteration + domore_k(k) = 0 + do j=jsv,jev ; if (domore_u(j,k)) domore_k(k) = 1 ; enddo + do J=jsv-1,jev ; if (domore_v(J,k)) domore_k(k) = 1 ; enddo + endif ; enddo + + endif ! x_first + + !$OMP end parallel + + ! If the advection just isn't finishing after max_iter, move on. + if (itt >= max_iter) then + exit + endif + + ! Exit if there are no layers that need more iterations. + if (isv > is-stencil) then + do_any = 0 + call cpu_clock_begin(id_clock_sync) + call sum_across_PEs(domore_k(:), nz) + call cpu_clock_end(id_clock_sync) + do k=1,nz ; do_any = do_any + domore_k(k) ; enddo + if (do_any == 0) then + exit + endif + + endif + + enddo ! Iterations loop + + if (present(uhr_out)) uhr_out(:,:,:) = uhr(:,:,:) + if (present(vhr_out)) vhr_out(:,:,:) = vhr(:,:,:) + if (present(vol_prev) .and. present(update_vol_prev)) then + if (update_vol_prev) vol_prev(:,:,:) = hprev(:,:,:) + endif + + call cpu_clock_end(id_clock_advect) + +end subroutine advect_tracer + + +!> This subroutine does 1-d flux-form advection in the zonal direction using +!! a monotonic piecewise linear scheme. +subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & + is, ie, js, je, k, G, GV, US, usePPM, useHuynh) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: ntr !< The number of tracers + type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: hprev !< cell volume at the end of previous + !! tracer change [H L2 ~> m3 or kg] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhr !< accumulated volume/mass flux through + !! the zonal face [H L2 ~> m3 or kg] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: uh_neglect !< A tiny zonal mass flux that can + !! be neglected [H L2 ~> m3 or kg] + type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used + logical, dimension(SZJ_(G),SZK_(GV)), intent(inout) :: domore_u !< If true, there is more advection to be + !! done in this u-row + real, intent(in) :: Idt !< The inverse of dt [T-1 ~> s-1] + integer, intent(in) :: is !< The starting tracer i-index to work on + integer, intent(in) :: ie !< The ending tracer i-index to work on + integer, intent(in) :: js !< The starting tracer j-index to work on + integer, intent(in) :: je !< The ending tracer j-index to work on + integer, intent(in) :: k !< The k-level to work on + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: usePPM !< If true, use PPM instead of PLM + logical, intent(in) :: useHuynh !< If true, use the Huynh scheme + !! for PPM interface values + + real, dimension(SZI_(G),ntr) :: & + slope_x ! The concentration slope per grid point [conc]. + real, dimension(SZIB_(G),SZJ_(G),ntr) :: & + flux_x ! The tracer flux across a boundary [H L2 conc ~> m3 conc or kg conc]. + real, dimension(SZI_(G),ntr) :: & + T_tmp ! The copy of the tracer concentration at constant i,k [conc]. + + real :: hup, hlos ! hup is the upwind volume, hlos is the + ! part of that volume that might be lost + ! due to advection out the other side of + ! the grid box, both in [H L2 ~> m3 or kg]. + real :: uhh(SZIB_(G)) ! The zonal flux that occurs during the + ! current iteration [H L2 ~> m3 or kg]. + real, dimension(SZIB_(G)) :: & + hlst, & ! Work variable [H L2 ~> m3 or kg]. + Ihnew, & ! Work variable [H-1 L-2 ~> m-3 or kg-1]. + CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. + real :: min_h ! The minimum thickness that can be realized during + ! any of the passes [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertible thickness [H ~> m or kg m-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: aR, aL ! Reconstructed tracer concentrations at the right and left edges [conc] + real :: dMx ! Difference between the maximum of the surrounding cell concentrations and + ! the value in the cell whose reconstruction is being found [conc] + real :: dMn ! Difference between the tracer concentration in the cell whose reconstruction + ! is being found and the minimum of the surrounding values [conc] + real :: Tp, Tc, Tm ! Tracer concentrations around the upstream cell [conc] + real :: dA ! Difference between the reconstruction tracer edge values [conc] + real :: mA ! Average of the reconstruction tracer edge values [conc] + real :: a6 ! Curvature of the reconstruction tracer values [conc] + logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. + logical :: usePLMslope + integer :: i, j, m, n, i_up, stencil, ntr_id + type(OBC_segment_type), pointer :: segment=>NULL() + logical, dimension(SZJ_(G),SZK_(GV)) :: domore_u_initial + + ! keep a local copy of the initial values of domore_u, which is to be used when computing ad2d_x + ! diagnostic at the end of this subroutine. + domore_u_initial = domore_u + + usePLMslope = .not. (usePPM .and. useHuynh) + ! stencil for calculating slope values + stencil = 1 + if (usePPM .and. .not. useHuynh) stencil = 2 + + min_h = 0.1*GV%Angstrom_H + tiny_h = tiny(min_h) + h_neglect = GV%H_subroundoff + + do I=is-1,ie ; CFL(I) = 0.0 ; enddo + + do j=js,je ; if (domore_u(j,k)) then + domore_u(j,k) = .false. + + ! Calculate the i-direction profiles (slopes) of each tracer that is being advected. + if (usePLMslope) then + do m=1,ntr ; do i=is-stencil,ie+stencil + !if (ABS(Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k)) < & + ! ABS(Tr(m)%t(i,j,k)-Tr(m)%t(i-1,j,k))) then + ! maxslope = 4.0*(Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k)) + !else + ! maxslope = 4.0*(Tr(m)%t(i,j,k)-Tr(m)%t(i-1,j,k)) + !endif + !if ((Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k)) * (Tr(m)%t(i,j,k)-Tr(m)%t(i-1,j,k)) < 0.0) then + ! slope_x(i,m) = 0.0 + !elseif (ABS(Tr(m)%t(i+1,j,k)-Tr(m)%t(i-1,j,k))OBC%segment(n) + if (.not. associated(segment%tr_Reg)) cycle + if (segment%is_E_or_W) then + if (j>=segment%HI%jsd .and. j<=segment%HI%jed) then + I = segment%HI%IsdB + do m = 1,segment%tr_Reg%ntseg ! replace tracers with OBC values + ntr_id = segment%tr_reg%Tr(m)%ntr_index + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + if (segment%direction == OBC_DIRECTION_W) then + T_tmp(i,ntr_id) = segment%tr_Reg%Tr(m)%tres(i,j,k) + else + T_tmp(i+1,ntr_id) = segment%tr_Reg%Tr(m)%tres(i,j,k) + endif + else + if (segment%direction == OBC_DIRECTION_W) then + T_tmp(i,ntr_id) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + else + T_tmp(i+1,ntr_id) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + endif + endif + enddo + do m = 1,ntr ! Apply update tracer values for slope calculation + do i=segment%HI%IsdB-1,segment%HI%IsdB+1 + Tp = T_tmp(i+1,m) ; Tc = T_tmp(i,m) ; Tm = T_tmp(i-1,m) + dMx = max( Tp, Tc, Tm ) - Tc + dMn= Tc - min( Tp, Tc, Tm ) + slope_x(i,m) = G%mask2dCu(I,j)*G%mask2dCu(I-1,j) * & + sign( min(0.5*abs(Tp-Tm), 2.0*dMx, 2.0*dMn), Tp-Tm ) + enddo + enddo + + endif + endif + enddo + endif ; endif + + + ! Calculate the i-direction fluxes of each tracer, using as much + ! the minimum of the remaining mass flux (uhr) and the half the mass + ! in the cell plus whatever part of its half of the mass flux that + ! the flux through the other side does not require. + do I=is-1,ie + if ((uhr(I,j,k) == 0.0) .or. & + ((uhr(I,j,k) < 0.0) .and. (hprev(i+1,j,k) <= tiny_h)) .or. & + ((uhr(I,j,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then + uhh(I) = 0.0 + CFL(I) = 0.0 + elseif (uhr(I,j,k) < 0.0) then + hup = hprev(i+1,j,k) - G%areaT(i+1,j)*min_h + hlos = MAX(0.0, uhr(I+1,j,k)) + if ((((hup - hlos) + uhr(I,j,k)) < 0.0) .and. & + ((0.5*hup + uhr(I,j,k)) < 0.0)) then + uhh(I) = MIN(-0.5*hup, -hup+hlos, 0.0) + domore_u(j,k) = .true. + else + uhh(I) = uhr(I,j,k) + endif + CFL(I) = - uhh(I) / (hprev(i+1,j,k)) ! CFL is positive + else + hup = hprev(i,j,k) - G%areaT(i,j)*min_h + hlos = MAX(0.0, -uhr(I-1,j,k)) + if ((((hup - hlos) - uhr(I,j,k)) < 0.0) .and. & + ((0.5*hup - uhr(I,j,k)) < 0.0)) then + uhh(I) = MAX(0.5*hup, hup-hlos, 0.0) + domore_u(j,k) = .true. + else + uhh(I) = uhr(I,j,k) + endif + CFL(I) = uhh(I) / (hprev(i,j,k)) ! CFL is positive + endif + enddo + + + if (usePPM) then + do m=1,ntr ; do I=is-1,ie + ! centre cell depending on upstream direction + if (uhh(I) >= 0.0) then + i_up = i + else + i_up = i+1 + endif + + ! Implementation of PPM-H3 + Tp = T_tmp(i_up+1,m) ; Tc = T_tmp(i_up,m) ; Tm = T_tmp(i_up-1,m) + + if (useHuynh) then + aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate + aL = max( min(Tc,Tm), aL) ; aL = min( max(Tc,Tm), aL) ! Bound + aR = ( 5.*Tc + ( 2.*Tp - Tm ) )/6. ! H3 estimate + aR = max( min(Tc,Tp), aR) ; aR = min( max(Tc,Tp), aR) ! Bound + else + aL = 0.5 * ((Tm + Tc) + (slope_x(i_up-1,m) - slope_x(i_up,m)) / 3.) + aR = 0.5 * ((Tc + Tp) + (slope_x(i_up,m) - slope_x(i_up+1,m)) / 3.) + endif + + dA = aR - aL ; mA = 0.5*( aR + aL ) + if (G%mask2dCu(I_up,j)*G%mask2dCu(I_up-1,j)*(Tp-Tc)*(Tc-Tm) <= 0.) then + aL = Tc ; aR = Tc ! PCM for local extrema and boundary cells + elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then + aL = 3.*Tc - 2.*aR + elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then + aR = 3.*Tc - 2.*aL + endif + + a6 = 6.*Tc - 3. * (aR + aL) ! Curvature + + if (uhh(I) >= 0.0) then + flux_x(I,j,m) = uhh(I)*( aR - 0.5 * CFL(I) * ( & + ( aR - aL ) - a6 * ( 1. - 2./3. * CFL(I) ) ) ) + else + flux_x(I,j,m) = uhh(I)*( aL + 0.5 * CFL(I) * ( & + ( aR - aL ) + a6 * ( 1. - 2./3. * CFL(I) ) ) ) + endif + enddo ; enddo + else ! PLM + do m=1,ntr ; do I=is-1,ie + if (uhh(I) >= 0.0) then + ! Indirect implementation of PLM + !aL = Tr(m)%t(i,j,k) - 0.5 * slope_x(i,m) + !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) + !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * (aR-aL) * CFL(I) ) + ! Alternative implementation of PLM + Tc = T_tmp(i,m) + flux_x(I,j,m) = uhh(I)*( Tc + 0.5 * slope_x(i,m) * ( 1. - CFL(I) ) ) + else + ! Indirect implementation of PLM + !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) + !aR = Tr(m)%t(i+1,j,k) + 0.5 * slope_x(i+1,m) + !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * (aR-aL) * CFL(I) ) + ! Alternative implementation of PLM + Tc = T_tmp(i+1,m) + flux_x(I,j,m) = uhh(I)*( Tc - 0.5 * slope_x(i+1,m) * ( 1. - CFL(I) ) ) + endif + enddo ; enddo + endif ! usePPM + + if (associated(OBC)) then ; if (OBC%OBC_pe) then + if (OBC%specified_u_BCs_exist_globally .or. OBC%open_u_BCs_exist_globally) then + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. associated(segment%tr_Reg)) cycle + if (segment%is_E_or_W) then + if (j>=segment%HI%jsd .and. j<=segment%HI%jed) then + I = segment%HI%IsdB + ! Tracer fluxes are set to prescribed values only for inflows from masked areas. + ! Now changing to simply fixed inflows. + if ((uhr(I,j,k) > 0.0) .and. (segment%direction == OBC_DIRECTION_W) .or. & + (uhr(I,j,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_E)) then + uhh(I) = uhr(I,j,k) + ! should the reservoir evolve for this case Kate ?? - Nope + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else ; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + enddo + endif + endif + endif + enddo + endif + + if (OBC%open_u_BCs_exist_globally) then + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + I = segment%HI%IsdB + if (segment%is_E_or_W .and. (j >= segment%HI%jsd .and. j<= segment%HI%jed)) then + if (segment%specified) cycle + if (.not. associated(segment%tr_Reg)) cycle + + ! Tracer fluxes are set to prescribed values only for inflows from masked areas. + if ((uhr(I,j,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. & + (uhr(I,j,k) < 0.0) .and. (G%mask2dT(i+1,j) < 0.5)) then + uhh(I) = uhr(I,j,k) + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif + enddo + endif + endif + enddo + endif + endif ; endif + + ! Calculate new tracer concentration in each cell after accounting + ! for the i-direction fluxes. + do I=is-1,ie + uhr(I,j,k) = uhr(I,j,k) - uhh(I) + if (abs(uhr(I,j,k)) < uh_neglect(I,j)) uhr(I,j,k) = 0.0 + enddo + do i=is,ie + if ((uhh(I) /= 0.0) .or. (uhh(I-1) /= 0.0)) then + do_i(i,j) = .true. + hlst(i) = hprev(i,j,k) + hprev(i,j,k) = hprev(i,j,k) - (uhh(I) - uhh(I-1)) + if (hprev(i,j,k) <= 0.0) then ; do_i(i,j) = .false. + elseif (hprev(i,j,k) < h_neglect*G%areaT(i,j)) then + hlst(i) = hlst(i) + (h_neglect*G%areaT(i,j) - hprev(i,j,k)) + Ihnew(i) = 1.0 / (h_neglect*G%areaT(i,j)) + else ; Ihnew(i) = 1.0 / hprev(i,j,k) ; endif + else + do_i(i,j) = .false. + endif + enddo + + ! update tracer concentration from i-flux and save some diagnostics + do m=1,ntr + + ! update tracer + do i=is,ie + if (do_i(i,j)) then + if (Ihnew(i) > 0.0) then + Tr(m)%t(i,j,k) = (Tr(m)%t(i,j,k) * hlst(i) - & + (flux_x(I,j,m) - flux_x(I-1,j,m))) * Ihnew(i) + endif + endif + enddo + + ! diagnostics + if (associated(Tr(m)%ad_x)) then ; do I=is-1,ie ; if (do_i(i,j)) then + Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,j,m)*Idt + endif ; enddo ; endif + + ! diagnose convergence of flux_x (do not use the Ihnew(i) part of the logic). + ! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt. + if (associated(Tr(m)%advection_xy)) then + do i=is,ie ; if (do_i(i,j)) then + Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - (flux_x(I,j,m) - flux_x(I-1,j,m)) * & + Idt * G%IareaT(i,j) + endif ; enddo + endif + + enddo + + endif ; enddo ! End of j-loop. + + ! Do user controlled underflow of the tracer concentrations. + do m=1,ntr ; if (Tr(m)%conc_underflow > 0.0) then + do j=js,je ; do i=is,ie + if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0 + enddo ; enddo + endif ; enddo + + ! compute ad2d_x diagnostic outside above j-loop so as to make the summation ordered when OMP is active. + + !$OMP ordered + do m=1,ntr ; if (associated(Tr(m)%ad2d_x)) then + do j=js,je ; if (domore_u_initial(j,k)) then + do I=is-1,ie ; if (do_i(i,j)) then + Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,j,m)*Idt + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. + !$OMP end ordered + +end subroutine advect_x + +!> This subroutine does 1-d flux-form advection using a monotonic piecewise +!! linear scheme. +subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & + is, ie, js, je, k, G, GV, US, usePPM, useHuynh) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: ntr !< The number of tracers + type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: hprev !< cell volume at the end of previous + !! tracer change [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhr !< accumulated volume/mass flux through + !! the meridional face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vh_neglect !< A tiny meridional mass flux that can + !! be neglected [H L2 ~> m3 or kg] + type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used + logical, dimension(SZJB_(G),SZK_(GV)), intent(inout) :: domore_v !< If true, there is more advection to be + !! done in this v-row + real, intent(in) :: Idt !< The inverse of dt [T-1 ~> s-1] + integer, intent(in) :: is !< The starting tracer i-index to work on + integer, intent(in) :: ie !< The ending tracer i-index to work on + integer, intent(in) :: js !< The starting tracer j-index to work on + integer, intent(in) :: je !< The ending tracer j-index to work on + integer, intent(in) :: k !< The k-level to work on + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: usePPM !< If true, use PPM instead of PLM + logical, intent(in) :: useHuynh !< If true, use the Huynh scheme + !! for PPM interface values + + real, dimension(SZI_(G),ntr,SZJ_(G)) :: & + slope_y ! The concentration slope per grid point [conc]. + real, dimension(SZI_(G),ntr,SZJB_(G)) :: & + flux_y ! The tracer flux across a boundary [H L2 conc ~> m3 conc or kg conc]. + real, dimension(SZI_(G),ntr,SZJB_(G)) :: & + T_tmp ! The copy of the tracer concentration at constant i,k [conc]. + real :: vhh(SZI_(G),SZJB_(G)) ! The meridional flux that occurs during the + ! current iteration [H L2 ~> m3 or kg]. + real :: hup, hlos ! hup is the upwind volume, hlos is the + ! part of that volume that might be lost + ! due to advection out the other side of + ! the grid box, both in [H L2 ~> m3 or kg]. + real, dimension(SZIB_(G)) :: & + hlst, & ! Work variable [H L2 ~> m3 or kg]. + Ihnew, & ! Work variable [H-1 L-2 ~> m-3 or kg-1]. + CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. + real :: min_h ! The minimum thickness that can be realized during + ! any of the passes [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertible thickness [H ~> m or kg m-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: aR, aL ! Reconstructed tracer concentrations at the right and left edges [conc] + real :: dMx ! Difference between the maximum of the surrounding cell concentrations and + ! the value in the cell whose reconstruction is being found [conc] + real :: dMn ! Difference between the tracer average in the cell whose reconstruction + ! is being found and the minimum of the surrounding values [conc] + real :: Tp, Tc, Tm ! Tracer concentrations around the upstream cell [conc] + real :: dA ! Difference between the reconstruction tracer edge values [conc] + real :: mA ! Average of the reconstruction tracer edge values [conc] + real :: a6 ! Curvature of the reconstruction tracer values [conc] + logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. + logical :: do_i(SZIB_(G), SZJ_(G)) ! If true, work on given points. + logical :: usePLMslope + integer :: i, j, j2, m, n, j_up, stencil, ntr_id + type(OBC_segment_type), pointer :: segment=>NULL() + logical :: domore_v_initial(SZJB_(G)) ! Initial state of domore_v + + usePLMslope = .not. (usePPM .and. useHuynh) + ! stencil for calculating slope values + stencil = 1 + if (usePPM .and. .not. useHuynh) stencil = 2 + + min_h = 0.1*GV%Angstrom_H + tiny_h = tiny(min_h) + h_neglect = GV%H_subroundoff + + ! We conditionally perform work on tracer points: calculating the PLM slope, + ! and updating tracer concentration within a cell + ! this depends on whether there is a flux which would affect this tracer point, + ! as indicated by domore_v. In the case of PPM reconstruction, a flux requires + ! slope calculations at the two tracer points on either side (as indicated by + ! the stencil variable), so we account for this with the do_j_tr flag array + ! + ! Note: this does lead to unnecessary work in updating tracer concentrations, + ! since that doesn't need a wider stencil with the PPM advection scheme, but + ! this would require an additional loop, etc. + do_j_tr(:) = .false. + do J=js-1,je ; if (domore_v(J,k)) then ; do j2=1-stencil,stencil ; do_j_tr(j+j2) = .true. ; enddo ; endif ; enddo + domore_v_initial(:) = domore_v(:,k) + + ! Calculate the j-direction profiles (slopes) of each tracer that + ! is being advected. + if (usePLMslope) then + do j=js-stencil,je+stencil ; if (do_j_tr(j)) then ; do m=1,ntr ; do i=is,ie + !if (ABS(Tr(m)%t(i,j+1,k)-Tr(m)%t(i,j,k)) < & + ! ABS(Tr(m)%t(i,j,k)-Tr(m)%t(i,j-1,k))) then + ! maxslope = 4.0*(Tr(m)%t(i,j+1,k)-Tr(m)%t(i,j,k)) + !else + ! maxslope = 4.0*(Tr(m)%t(i,j,k)-Tr(m)%t(i,j-1,k)) + !endif + !if ((Tr(m)%t(i,j+1,k)-Tr(m)%t(i,j,k))*(Tr(m)%t(i,j,k)-Tr(m)%t(i,j-1,k)) < 0.0) then + ! slope_y(i,m,j) = 0.0 + !elseif (ABS(Tr(m)%t(i,j+1,k)-Tr(m)%t(i,j-1,k))OBC%segment(n) + if (.not. associated(segment%tr_Reg)) cycle + do i=is,ie + if (segment%is_N_or_S) then + if (i>=segment%HI%isd .and. i<=segment%HI%ied) then + J = segment%HI%JsdB + do m = 1,segment%tr_Reg%ntseg ! replace tracers with OBC values + ntr_id = segment%tr_reg%Tr(m)%ntr_index + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + if (segment%direction == OBC_DIRECTION_S) then + T_tmp(i,ntr_id,j) = segment%tr_Reg%Tr(m)%tres(i,j,k) + else + T_tmp(i,ntr_id,j+1) = segment%tr_Reg%Tr(m)%tres(i,j,k) + endif + else + if (segment%direction == OBC_DIRECTION_S) then + T_tmp(i,ntr_id,j) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + else + T_tmp(i,ntr_id,j+1) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + endif + endif + enddo + do m = 1,ntr ! Apply update tracer values for slope calculation + do j=segment%HI%JsdB-1,segment%HI%JsdB+1 + Tp = T_tmp(i,m,j+1) ; Tc = T_tmp(i,m,j) ; Tm = T_tmp(i,m,j-1) + dMx = max( Tp, Tc, Tm ) - Tc + dMn= Tc - min( Tp, Tc, Tm ) + slope_y(i,m,j) = G%mask2dCv(i,J)*G%mask2dCv(i,J-1) * & + sign( min(0.5*abs(Tp-Tm), 2.0*dMx, 2.0*dMn), Tp-Tm ) + enddo + enddo + endif + endif ! is_N_S + enddo ! i-loop + enddo ! segment loop + endif ; endif + + ! Calculate the j-direction fluxes of each tracer, using as much + ! the minimum of the remaining mass flux (vhr) and the half the mass + ! in the cell plus whatever part of its half of the mass flux that + ! the flux through the other side does not require. + do J=js-1,je ; if (domore_v(J,k)) then + domore_v(J,k) = .false. + + do i=is,ie + if ((vhr(i,J,k) == 0.0) .or. & + ((vhr(i,J,k) < 0.0) .and. (hprev(i,j+1,k) <= tiny_h)) .or. & + ((vhr(i,J,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then + vhh(i,J) = 0.0 + CFL(i) = 0.0 + elseif (vhr(i,J,k) < 0.0) then + hup = hprev(i,j+1,k) - G%areaT(i,j+1)*min_h + hlos = MAX(0.0, vhr(i,J+1,k)) + if ((((hup - hlos) + vhr(i,J,k)) < 0.0) .and. & + ((0.5*hup + vhr(i,J,k)) < 0.0)) then + vhh(i,J) = MIN(-0.5*hup, -hup+hlos, 0.0) + domore_v(J,k) = .true. + else + vhh(i,J) = vhr(i,J,k) + endif + CFL(i) = - vhh(i,J) / hprev(i,j+1,k) ! CFL is positive + else + hup = hprev(i,j,k) - G%areaT(i,j)*min_h + hlos = MAX(0.0, -vhr(i,J-1,k)) + if ((((hup - hlos) - vhr(i,J,k)) < 0.0) .and. & + ((0.5*hup - vhr(i,J,k)) < 0.0)) then + vhh(i,J) = MAX(0.5*hup, hup-hlos, 0.0) + domore_v(J,k) = .true. + else + vhh(i,J) = vhr(i,J,k) + endif + CFL(i) = vhh(i,J) / hprev(i,j,k) ! CFL is positive + endif + enddo + + if (usePPM) then + do m=1,ntr ; do i=is,ie + ! centre cell depending on upstream direction + if (vhh(i,J) >= 0.0) then + j_up = j + else + j_up = j + 1 + endif + + ! Implementation of PPM-H3 + Tp = T_tmp(i,m,j_up+1) ; Tc = T_tmp(i,m,j_up) ; Tm = T_tmp(i,m,j_up-1) + + if (useHuynh) then + aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate + aL = max( min(Tc,Tm), aL) ; aL = min( max(Tc,Tm), aL) ! Bound + aR = ( 5.*Tc + ( 2.*Tp - Tm ) )/6. ! H3 estimate + aR = max( min(Tc,Tp), aR) ; aR = min( max(Tc,Tp), aR) ! Bound + else + aL = 0.5 * ((Tm + Tc) + (slope_y(i,m,j_up-1) - slope_y(i,m,j_up)) / 3.) + aR = 0.5 * ((Tc + Tp) + (slope_y(i,m,j_up) - slope_y(i,m,j_up+1)) / 3.) + endif + + dA = aR - aL ; mA = 0.5*( aR + aL ) + if (G%mask2dCv(i,J_up)*G%mask2dCv(i,J_up-1)*(Tp-Tc)*(Tc-Tm) <= 0.) then + aL = Tc ; aR = Tc ! PCM for local extrema and boundary cells + elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then + aL = 3.*Tc - 2.*aR + elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then + aR = 3.*Tc - 2.*aL + endif + + a6 = 6.*Tc - 3. * (aR + aL) ! Curvature + + if (vhh(i,J) >= 0.0) then + flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * CFL(i) * ( & + ( aR - aL ) - a6 * ( 1. - 2./3. * CFL(I) ) ) ) + else + flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * CFL(i) * ( & + ( aR - aL ) + a6 * ( 1. - 2./3. * CFL(I) ) ) ) + endif + enddo ; enddo + else ! PLM + do m=1,ntr ; do i=is,ie + if (vhh(i,J) >= 0.0) then + ! Indirect implementation of PLM + !aL = Tr(m)%t(i,j,k) - 0.5 * slope_y(i,m,j) + !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) + !flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * (aR-aL) * CFL(i) ) + ! Alternative implementation of PLM + Tc = T_tmp(i,m,j) + flux_y(i,m,J) = vhh(i,J)*( Tc + 0.5 * slope_y(i,m,j) * ( 1. - CFL(i) ) ) + else + ! Indirect implementation of PLM + !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) + !aR = Tr(m)%t(i,j+1,k) + 0.5 * slope_y(i,m,j+1) + !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * (aR-aL) * CFL(i) ) + ! Alternative implementation of PLM + Tc = T_tmp(i,m,j+1) + flux_y(i,m,J) = vhh(i,J)*( Tc - 0.5 * slope_y(i,m,j+1) * ( 1. - CFL(i) ) ) + endif + enddo ; enddo + endif ! usePPM + + if (associated(OBC)) then ; if (OBC%OBC_pe) then + if (OBC%specified_v_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) then + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%specified) cycle + if (.not. associated(segment%tr_Reg)) cycle + if (OBC%segment(n)%is_N_or_S) then + if (J >= segment%HI%JsdB .and. J<= segment%HI%JedB) then + do i=segment%HI%isd,segment%HI%ied + ! Tracer fluxes are set to prescribed values only for inflows from masked areas. + ! Now changing to simply fixed inflows. + if ((vhr(i,J,k) > 0.0) .and. (segment%direction == OBC_DIRECTION_S) .or. & + (vhr(i,J,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_N)) then + vhh(i,J) = vhr(i,J,k) + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k) + else ; flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + enddo + endif + enddo + endif + endif + enddo + endif + + if (OBC%open_v_BCs_exist_globally) then + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (segment%specified) cycle + if (.not. associated(segment%tr_Reg)) cycle + if (segment%is_N_or_S .and. (J >= segment%HI%JsdB .and. J<= segment%HI%JedB)) then + do i=segment%HI%isd,segment%HI%ied + ! Tracer fluxes are set to prescribed values only for inflows from masked areas. + if ((vhr(i,J,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. & + (vhr(i,J,k) < 0.0) .and. (G%mask2dT(i,j+1) < 0.5)) then + vhh(i,J) = vhr(i,J,k) + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%tres(i,J,k) + else ; flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + enddo + endif + enddo + endif + enddo + endif + endif ; endif + + else ! not domore_v. + do i=is,ie ; vhh(i,J) = 0.0 ; enddo + do m=1,ntr ; do i=is,ie ; flux_y(i,m,J) = 0.0 ; enddo ; enddo + endif ; enddo ! End of j-loop + + do J=js-1,je ; do i=is,ie + vhr(i,J,k) = vhr(i,J,k) - vhh(i,J) + if (abs(vhr(i,J,k)) < vh_neglect(i,J)) vhr(i,J,k) = 0.0 + enddo ; enddo + + ! Calculate new tracer concentration in each cell after accounting + ! for the j-direction fluxes. + do j=js,je ; if (do_j_tr(j)) then + do i=is,ie + if ((vhh(i,J) /= 0.0) .or. (vhh(i,J-1) /= 0.0)) then + do_i(i,j) = .true. + hlst(i) = hprev(i,j,k) + hprev(i,j,k) = max(hprev(i,j,k) - (vhh(i,J) - vhh(i,J-1)), 0.0) + if (hprev(i,j,k) <= 0.0) then ; do_i(i,j) = .false. + elseif (hprev(i,j,k) < h_neglect*G%areaT(i,j)) then + hlst(i) = hlst(i) + (h_neglect*G%areaT(i,j) - hprev(i,j,k)) + Ihnew(i) = 1.0 / (h_neglect*G%areaT(i,j)) + else ; Ihnew(i) = 1.0 / hprev(i,j,k) ; endif + else ; do_i(i,j) = .false. ; endif + enddo + + ! update tracer and save some diagnostics + do m=1,ntr + do i=is,ie ; if (do_i(i,j)) then + Tr(m)%t(i,j,k) = (Tr(m)%t(i,j,k) * hlst(i) - & + (flux_y(i,m,J) - flux_y(i,m,J-1))) * Ihnew(i) + endif ; enddo + + ! diagnose convergence of flux_y and add to convergence of flux_x. + ! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt. + if (associated(Tr(m)%advection_xy)) then + do i=is,ie ; if (do_i(i,j)) then + Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - (flux_y(i,m,J) - flux_y(i,m,J-1))* Idt * & + G%IareaT(i,j) + endif ; enddo + endif + + enddo + endif ; enddo ! End of j-loop. + + ! Do user controlled underflow of the tracer concentrations. + do m=1,ntr ; if (Tr(m)%conc_underflow > 0.0) then + do j=js,je ; do i=is,ie + if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0 + enddo ; enddo + endif ; enddo + + ! compute ad_y and ad2d_y diagnostic outside above j-loop so as to make the summation ordered when OMP is active. + !$OMP ordered + do m=1,ntr ; if (associated(Tr(m)%ad_y)) then + do J=js-1,je ; if (domore_v_initial(J)) then + ! (The logical test could be "do_i(i,j) .or. do_i(i+1,j)" to be clearer, but not needed) + do i=is,ie ; if (do_i(i,j)) then + Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. + + do m=1,ntr ; if (associated(Tr(m)%ad2d_y)) then + do J=js-1,je ; if (domore_v_initial(J)) then + do i=is,ie ; if (do_i(i,j)) then + Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. + !$OMP end ordered + +end subroutine advect_y + +!> Initialize lateral tracer advection module +subroutine tracer_advect_init(Time, G, US, param_file, diag, CS) + type(time_type), target, intent(in) :: Time !< current model time + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< open file to parse for model parameters + type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output + type(tracer_advect_CS), pointer :: CS !< module control structure + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_tracer_advect" ! This module's name. + character(len=256) :: mesg ! Message for error messages. + + if (associated(CS)) then + call MOM_error(WARNING, "tracer_advect_init called with associated control structure.") + return + endif + allocate(CS) + + CS%diag => diag + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DT", CS%dt, fail_if_missing=.true., & + desc="The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T) + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) + call get_param(param_file, mdl, "TRACER_ADVECTION_SCHEME", mesg, & + desc="The horizontal transport scheme for tracers:\n"//& + " PLM - Piecewise Linear Method\n"//& + " PPM:H3 - Piecewise Parabolic Method (Huyhn 3rd order)\n"// & + " PPM - Piecewise Parabolic Method (Colella-Woodward)" & + , default='PLM') + select case (trim(mesg)) + case ("PLM") + CS%usePPM = .false. + case ("PPM:H3") + CS%usePPM = .true. + CS%useHuynh = .true. + case ("PPM") + CS%usePPM = .true. + CS%useHuynh = .false. + case default + call MOM_error(FATAL, "MOM_tracer_advect, tracer_advect_init: "//& + "Unknown TRACER_ADVECTION_SCHEME = "//trim(mesg)) + end select + + id_clock_advect = cpu_clock_id('(Ocean advect tracer)', grain=CLOCK_MODULE) + id_clock_pass = cpu_clock_id('(Ocean tracer halo updates)', grain=CLOCK_ROUTINE) + id_clock_sync = cpu_clock_id('(Ocean tracer global synch)', grain=CLOCK_ROUTINE) + +end subroutine tracer_advect_init + +!> Close the tracer advection module +subroutine tracer_advect_end(CS) + type(tracer_advect_CS), pointer :: CS !< module control structure + + if (associated(CS)) deallocate(CS) + +end subroutine tracer_advect_end + + +!> \namespace mom_tracer_advect +!! +!! This program contains the subroutines that advect tracers +!! horizontally (i.e. along layers). +!! +!! \section section_mom_advect_intro +!! +!! * advect_tracer advects tracer concentrations using a combination +!! of the modified flux advection scheme from Easter (Mon. Wea. Rev., +!! 1993) with tracer distributions given by the monotonic modified +!! van Leer scheme proposed by Lin et al. (Mon. Wea. Rev., 1994). +!! This scheme conserves the total amount of tracer while avoiding +!! spurious maxima and minima of the tracer concentration. If a +!! higher order accuracy scheme is needed, suggest monotonic +!! piecewise parabolic method, as described in Carpenter et al. +!! (MWR, 1990). +!! +!! * advect_tracer has 4 arguments, described below. This +!! subroutine determines the volume of a layer in a grid cell at the +!! previous instance when the tracer concentration was changed, so +!! it is essential that the volume fluxes should be correct. It is +!! also important that the tracer advection occurs before each +!! calculation of the diabatic forcing. + +end module MOM_tracer_advect diff --git a/tracer/MOM_tracer_diabatic.F90 b/tracer/MOM_tracer_diabatic.F90 new file mode 100644 index 0000000000..f18c14e105 --- /dev/null +++ b/tracer/MOM_tracer_diabatic.F90 @@ -0,0 +1,643 @@ +!> This module contains routines that implement physical fluxes of tracers (e.g. due +!! to surface fluxes or mixing). These are intended to be called from call_tracer_column_fns +!! in the MOM_tracer_flow_control module. +module MOM_tracer_diabatic + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_forcing_type, only : forcing +use MOM_error_handler, only : MOM_error, FATAL, WARNING + +implicit none ; private + +#include +public tracer_vertdiff, tracer_vertdiff_Eulerian +public applyTracerBoundaryFluxesInOut + +contains + +!> This subroutine solves a tridiagonal equation for the final tracer concentrations after the +!! dual-entrainments, and possibly sinking or surface and bottom sources, are applied. The sinking +!! is implemented with an fully implicit upwind advection scheme. Alternate time units can be +!! used for the timestep, surface and bottom fluxes and sink_rate provided they are all consistent. +subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & + sfc_flux, btm_flux, btm_reservoir, sink_rate, convert_flux_in) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< layer thickness before entrainment + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: ea !< amount of fluid entrained from the layer + !! above [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: eb !< amount of fluid entrained from the layer + !! below [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: tr !< tracer concentration in concentration units [CU] + real, intent(in) :: dt !< amount of time covered by this call [T ~> s] + real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: sfc_flux !< surface flux of the tracer in units of + !! [CU R Z T-1 ~> CU kg m-2 s-1] or + !! [CU H ~> CU m or CU kg m-2] if + !! convert_flux_in is .false. + real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: btm_flux !< The (negative upward) bottom flux of the + !! tracer in [CU R Z T-1 ~> CU kg m-2 s-1] or + !! [CU H ~> CU m or CU kg m-2] if + !! convert_flux_in is .false. + real, dimension(SZI_(G),SZJ_(G)), optional,intent(inout) :: btm_reservoir !< amount of tracer in a bottom reservoir + !! [CU R Z ~> CU kg m-2] + real, optional,intent(in) :: sink_rate !< rate at which the tracer sinks + !! [Z T-1 ~> m s-1] + logical, optional,intent(in) :: convert_flux_in !< True if the specified sfc_flux needs + !! to be integrated in time + + ! local variables + real :: sink_dist !< The distance the tracer sinks in a time step [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + sfc_src, & !< The time-integrated surface source of the tracer [CU H ~> CU m or CU kg m-2]. + btm_src !< The time-integrated bottom source of the tracer [CU H ~> CU m or CU kg m-2]. + real, dimension(SZI_(G)) :: & + b1, & !< b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + d1 !! d1=1-c1 is used by the tridiagonal solver [nondim]. + real :: c1(SZI_(G),SZK_(GV)) !< c1 is used by the tridiagonal solver [nondim]. + real :: h_minus_dsink(SZI_(G),SZK_(GV)) !< The layer thickness minus the + !! difference in sinking rates across the layer [H ~> m or kg m-2]. + !! By construction, 0 <= h_minus_dsink < h_work. + real :: sink(SZI_(G),SZK_(GV)+1) !< The tracer's sinking distances at the + !! interfaces, limited to prevent characteristics from + !! crossing within a single timestep [H ~> m or kg m-2]. + real :: b_denom_1 !< The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: h_tr !< h_tr is h at tracer points with a h_neglect added to + !! ensure positive definiteness [H ~> m or kg m-2]. + real :: h_neglect !< A thickness that is so small it is usually lost + !! in roundoff and can be neglected [H ~> m or kg m-2]. + logical :: convert_flux = .true. + + integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (nz == 1) then + call MOM_error(WARNING, "MOM_tracer_diabatic.F90, tracer_vertdiff called "//& + "with only one vertical level") + return + endif + + if (present(convert_flux_in)) convert_flux = convert_flux_in + h_neglect = GV%H_subroundoff + sink_dist = 0.0 + if (present(sink_rate)) sink_dist = (dt*sink_rate) * GV%Z_to_H + !$OMP parallel default(shared) private(sink,h_minus_dsink,b_denom_1,b1,d1,h_tr,c1) + !$OMP do + do j=js,je ; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo ; enddo + if (present(sfc_flux)) then + if (convert_flux) then + !$OMP do + do j=js,je ; do i=is,ie + sfc_src(i,j) = (sfc_flux(i,j)*dt) * GV%RZ_to_H + enddo ; enddo + else + !$OMP do + do j=js,je ; do i=is,ie + sfc_src(i,j) = sfc_flux(i,j) + enddo ; enddo + endif + endif + if (present(btm_flux)) then + if (convert_flux) then + !$OMP do + do j=js,je ; do i=is,ie + btm_src(i,j) = (btm_flux(i,j)*dt) * GV%RZ_to_H + enddo ; enddo + else + !$OMP do + do j=js,je ; do i=is,ie + btm_src(i,j) = btm_flux(i,j) + enddo ; enddo + endif + endif + + if (present(sink_rate)) then + !$OMP do + do j=js,je + ! Find the sinking rates at all interfaces, limiting them if necesary + ! so that the characteristics do not cross within a timestep. + ! If a non-constant sinking rate were used, that would be incorprated + ! here. + if (present(btm_reservoir)) then + do i=is,ie ; sink(i,nz+1) = sink_dist ; enddo + do k=2,nz ; do i=is,ie + sink(i,K) = sink_dist ; h_minus_dsink(i,k) = h_old(i,j,k) + enddo ; enddo + else + do i=is,ie ; sink(i,nz+1) = 0.0 ; enddo + ! Find the limited sinking distance at the interfaces. + do k=nz,2,-1 ; do i=is,ie + if (sink(i,K+1) >= sink_dist) then + sink(i,K) = sink_dist + h_minus_dsink(i,k) = h_old(i,j,k) + (sink(i,K+1) - sink(i,K)) + elseif (sink(i,K+1) + h_old(i,j,k) < sink_dist) then + sink(i,K) = sink(i,K+1) + h_old(i,j,k) + h_minus_dsink(i,k) = 0.0 + else + sink(i,K) = sink_dist + h_minus_dsink(i,k) = (h_old(i,j,k) + sink(i,K+1)) - sink(i,K) + endif + enddo ; enddo + endif + do i=is,ie + sink(i,1) = 0.0 ; h_minus_dsink(i,1) = (h_old(i,j,1) + sink(i,2)) + enddo + + ! Now solve the tridiagonal equation for the tracer concentrations. + 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.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 + b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) + d1(i) = b_denom_1 * b1(i) + h_tr = h_old(i,j,k) + h_neglect + 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.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 + b1(i) = 1.0 / (b_denom_1 + eb(i,j,nz)) + h_tr = h_old(i,j,nz) + h_neglect + 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.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.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.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.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) + b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) + 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.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) + b1(i) = 1.0 / ( b_denom_1 + eb(i,j,nz)) + 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.0) then + tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) + endif ; enddo ; enddo + enddo + endif + !$OMP end parallel + +end subroutine tracer_vertdiff + + +!> This subroutine solves a tridiagonal equation for the final tracer concentrations after +!! Eulerian mixing, and possibly sinking or surface and bottom sources, are applied. The sinking +!! is implemented with an fully implicit upwind advection scheme. Alternate time units can be +!! used for the timestep, surface and bottom fluxes and sink_rate provided they are all consistent. +subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & + sfc_flux, btm_flux, btm_reservoir, sink_rate, convert_flux_in) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< layer thickness before entrainment + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: ent !< Amount of fluid mixed across interfaces + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: tr !< tracer concentration in concentration units [CU] + real, intent(in) :: dt !< amount of time covered by this call [T ~> s] + real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: sfc_flux !< surface flux of the tracer in units of + !! [CU R Z T-1 ~> CU kg m-2 s-1] or + !! [CU H ~> CU m or CU kg m-2] if + !! convert_flux_in is .false. + real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: btm_flux !< The (negative upward) bottom flux of the + !! tracer in [CU kg m-2 T-1 ~> CU kg m-2 s-1] or + !! [CU H ~> CU m or CU kg m-2] if + !! convert_flux_in is .false. + real, dimension(SZI_(G),SZJ_(G)), optional,intent(inout) :: btm_reservoir !< amount of tracer in a bottom reservoir + !! [CU R Z ~> CU kg m-2] + real, optional,intent(in) :: sink_rate !< rate at which the tracer sinks + !! [Z T-1 ~> m s-1] + logical, optional,intent(in) :: convert_flux_in !< True if the specified sfc_flux needs + !! to be integrated in time + + ! local variables + real :: sink_dist !< The distance the tracer sinks in a time step [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + sfc_src, & !< The time-integrated surface source of the tracer [CU H ~> CU m or CU kg m-2]. + btm_src !< The time-integrated bottom source of the tracer [CU H ~> CU m or CU kg m-2]. + real, dimension(SZI_(G)) :: & + b1, & !< b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + d1 !! d1=1-c1 is used by the tridiagonal solver [nondim]. + real :: c1(SZI_(G),SZK_(GV)) !< c1 is used by the tridiagonal solver [nondim]. + real :: h_minus_dsink(SZI_(G),SZK_(GV)) !< The layer thickness minus the + !! difference in sinking rates across the layer [H ~> m or kg m-2]. + !! By construction, 0 <= h_minus_dsink < h_work. + real :: sink(SZI_(G),SZK_(GV)+1) !< The tracer's sinking distances at the + !! interfaces, limited to prevent characteristics from + !! crossing within a single timestep [H ~> m or kg m-2]. + real :: b_denom_1 !< The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: h_tr !< h_tr is h at tracer points with a h_neglect added to + !! ensure positive definiteness [H ~> m or kg m-2]. + real :: h_neglect !< A thickness that is so small it is usually lost + !! in roundoff and can be neglected [H ~> m or kg m-2]. + logical :: convert_flux + + integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (nz == 1) then + call MOM_error(WARNING, "MOM_tracer_diabatic.F90, tracer_vertdiff called "//& + "with only one vertical level") + return + endif + + convert_flux = .true. + if (present(convert_flux_in)) convert_flux = convert_flux_in + h_neglect = GV%H_subroundoff + sink_dist = 0.0 + if (present(sink_rate)) sink_dist = (dt*sink_rate) * GV%Z_to_H + !$OMP parallel default(shared) private(sink,h_minus_dsink,b_denom_1,b1,d1,h_tr,c1) + !$OMP do + do j=js,je ; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo ; enddo + if (present(sfc_flux)) then + if (convert_flux) then + !$OMP do + do j=js,je ; do i=is,ie + sfc_src(i,j) = (sfc_flux(i,j)*dt) * GV%RZ_to_H + enddo ; enddo + else + !$OMP do + do j=js,je ; do i=is,ie + sfc_src(i,j) = sfc_flux(i,j) + enddo ; enddo + endif + endif + if (present(btm_flux)) then + if (convert_flux) then + !$OMP do + do j=js,je ; do i=is,ie + btm_src(i,j) = (btm_flux(i,j)*dt) * GV%kg_m2_to_H + enddo ; enddo + else + !$OMP do + do j=js,je ; do i=is,ie + btm_src(i,j) = btm_flux(i,j) + enddo ; enddo + endif + endif + + if (present(sink_rate)) then + !$OMP do + do j=js,je + ! Find the sinking rates at all interfaces, limiting them if necesary + ! so that the characteristics do not cross within a timestep. + ! If a non-constant sinking rate were used, that would be incorprated + ! here. + if (present(btm_reservoir)) then + do i=is,ie ; sink(i,nz+1) = sink_dist ; enddo + do k=2,nz ; do i=is,ie + sink(i,K) = sink_dist ; h_minus_dsink(i,k) = h_old(i,j,k) + enddo ; enddo + else + do i=is,ie ; sink(i,nz+1) = 0.0 ; enddo + ! Find the limited sinking distance at the interfaces. + do k=nz,2,-1 ; do i=is,ie + if (sink(i,K+1) >= sink_dist) then + sink(i,K) = sink_dist + h_minus_dsink(i,k) = h_old(i,j,k) + (sink(i,K+1) - sink(i,K)) + elseif (sink(i,K+1) + h_old(i,j,k) < sink_dist) then + sink(i,K) = sink(i,K+1) + h_old(i,j,k) + h_minus_dsink(i,k) = 0.0 + else + sink(i,K) = sink_dist + h_minus_dsink(i,k) = (h_old(i,j,k) + sink(i,K+1)) - sink(i,K) + endif + enddo ; enddo + endif + do i=is,ie + sink(i,1) = 0.0 ; h_minus_dsink(i,1) = (h_old(i,j,1) + sink(i,2)) + enddo + + ! Now solve the tridiagonal equation for the tracer concentrations. + 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.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 + b1(i) = 1.0 / (b_denom_1 + ent(i,j,K+1)) + d1(i) = b_denom_1 * b1(i) + h_tr = h_old(i,j,k) + h_neglect + 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.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 + b1(i) = 1.0 / (b_denom_1 + ent(i,j,nz+1)) + h_tr = h_old(i,j,nz) + h_neglect + 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.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.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.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.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) + b1(i) = 1.0 / (b_denom_1 + ent(i,j,K+1)) + 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.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) + b1(i) = 1.0 / ( b_denom_1 + ent(i,j,nz+1)) + 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.0) then + tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) + endif ; enddo ; enddo + enddo + endif + !$OMP end parallel + +end subroutine tracer_vertdiff_Eulerian + + +!> This routine is modeled after applyBoundaryFluxesInOut in MOM_diabatic_aux.F90 +!! NOTE: Please note that in this routine sfc_flux gets set to zero to ensure that the surface +!! flux of the tracer does not get applied again during a subsequent call to tracer_vertdif +subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_limit, minimum_forcing_depth, & + in_flux_optional, out_flux_optional, update_h_opt) + + type(ocean_grid_type), intent(in ) :: G !< Grid structure + type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: Tr !< Tracer concentration on T-cell [conc] + real, intent(in ) :: dt !< Time-step over which forcing is applied [T ~> s] + type(forcing), intent(in ) :: fluxes !< Surface fluxes container + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, intent(in ) :: evap_CFL_limit !< Limit on the fraction of the + !! water that can be fluxed out of the top + !! layer in a timestep [nondim] + real, intent(in ) :: minimum_forcing_depth !< The smallest depth over + !! which fluxes can be applied [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: in_flux_optional !< The total time-integrated + !! amount of tracer that enters with freshwater + !! [conc H ~> conc m or conc kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: out_flux_optional !< The total time-integrated + !! amount of tracer that leaves with freshwater + !! [conc H ~> conc m or conc kg m-2] + logical, optional, intent(in) :: update_h_opt !< Optional flag to determine whether + !! h should be updated + + integer, parameter :: maxGroundings = 5 + integer :: numberOfGroundings, iGround(maxGroundings), jGround(maxGroundings) + real :: IforcingDepthScale ! The inverse of the scale over which to apply forcing [H-1 ~> m-1 or m2 kg-1] + real :: dThickness ! The change in a layer's thickness [H ~> m or kg m-2] + real :: dTracer ! The change in the integrated tracer content of a layer [conc H ~> conc m or conc kg m-2] + real :: fractionOfForcing ! The fraction of the forcing to apply to a layer [nondim] + real :: hOld ! The layer thickness before surface forcing is applied [H ~> m or kg m-2] + real :: Ithickness ! The inverse of the new layer thickness [H-1 ~> m-1 or m2 kg-1] + + real :: h2d(SZI_(G),SZK_(GV)) ! A 2-d work copy of layer thicknesses [H ~> m or kg m-2] + real :: Tr2d(SZI_(G),SZK_(GV)) ! A 2-d work copy of tracer concentrations [conc] + real :: in_flux(SZI_(G),SZJ_(G)) ! The total time-integrated amount of tracer that + ! enters with freshwater [conc H ~> conc m or conc kg m-2] + real :: out_flux(SZI_(G),SZJ_(G)) ! The total time-integrated amount of tracer that + ! leaves with freshwater [conc H ~> conc m or conc kg m-2] + real :: netMassIn(SZI_(G)) ! The remaining mass entering ocean surface [H ~> m or kg m-2] + real :: netMassOut(SZI_(G)) ! The remaining mass leaving ocean surface [H ~> m or kg m-2] + real :: in_flux_1d(SZI_(G)) ! The remaining amount of tracer that enters with + ! the freshwater [conc H ~> conc m or conc kg m-2] + real :: out_flux_1d(SZI_(G)) ! The remaining amount of tracer that leaves with + ! the freshwater [conc H ~> conc m or conc kg m-2] + real :: hGrounding(maxGroundings) ! The remaining fresh water flux that was not able to be + ! supplied from a column that grounded out [H ~> m or kg m-2] + logical :: update_h + integer :: i, j, is, ie, js, je, k, nz + character(len=45) :: mesg + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + ! If no freshwater fluxes, nothing needs to be done in this routine + if ( (.not. associated(fluxes%netMassIn)) .or. (.not. associated(fluxes%netMassOut)) ) return + + in_flux(:,:) = 0.0 ; out_flux(:,:) = 0.0 + if (present(in_flux_optional)) then + do j=js,je ; do i=is,ie + in_flux(i,j) = in_flux_optional(i,j) + enddo ; enddo + endif + if (present(out_flux_optional)) then + do j=js,je ; do i=is,ie + out_flux(i,j) = out_flux_optional(i,j) + enddo ; enddo + endif + + if (present(update_h_opt)) then + update_h = update_h_opt + else + update_h = .true. + endif + + numberOfGroundings = 0 + +!$OMP parallel do default(none) shared(is,ie,js,je,nz,h,Tr,G,GV,fluxes,dt, & +!$OMP IforcingDepthScale,minimum_forcing_depth, & +!$OMP numberOfGroundings,iGround,jGround,update_h, & +!$OMP in_flux,out_flux,hGrounding,evap_CFL_limit) & +!$OMP private(h2d,Tr2d,netMassIn,netMassOut, & +!$OMP in_flux_1d,out_flux_1d,fractionOfForcing, & +!$OMP dThickness,dTracer,hOld,Ithickness) + + ! Work in vertical slices for efficiency + do j=js,je + + ! Copy state into 2D-slice arrays + do k=1,nz ; do i=is,ie + h2d(i,k) = h(i,j,k) + Tr2d(i,k) = Tr(i,j,k) + enddo ; enddo + + do i = is,ie + in_flux_1d(i) = in_flux(i,j) + out_flux_1d(i) = out_flux(i,j) + enddo + ! The surface forcing is contained in the fluxes type. + ! We aggregate the thermodynamic forcing for a time step into the following: + ! These should have been set and stored during a call to applyBoundaryFluxesInOut + ! netMassIn = net mass entering at ocean surface over a timestep + ! netMassOut = net mass leaving ocean surface [H ~> m or kg m-2] over a time step. + ! netMassOut < 0 means mass leaves ocean. + + ! Note here that the aggregateFW flag has already been taken care of in the call to + ! applyBoundaryFluxesInOut + do i=is,ie + netMassOut(i) = fluxes%netMassOut(i,j) + netMassIn(i) = fluxes%netMassIn(i,j) + enddo + + ! Apply the surface boundary fluxes in three steps: + ! A/ update concentration from mass entering the ocean + ! B/ update concentration from mass leaving ocean. + do i=is,ie + if (G%mask2dT(i,j)>0.) then + + ! A/ Update tracer due to incoming mass flux. + do k=1,1 + + ! Change in state due to forcing + dThickness = netMassIn(i) ! Since we are adding mass, we can use all of it + dTracer = 0. + + ! Update the forcing by the part to be consumed within the present k-layer. + ! If fractionOfForcing = 1, then updated netMassIn, netHeat, and netSalt vanish. + netMassIn(i) = netMassIn(i) - dThickness + dTracer = dTracer + in_flux_1d(i) + in_flux_1d(i) = 0.0 + + ! Update state + hOld = h2d(i,k) ! Keep original thickness in hand + h2d(i,k) = h2d(i,k) + dThickness ! New thickness + if (h2d(i,k) > 0.0) then + Ithickness = 1.0/h2d(i,k) ! Inverse new thickness + ! The "if"s below avoid changing T/S by roundoff unnecessarily + if (dThickness /= 0. .or. dTracer /= 0.) tr2d(i,k) = (hOld*tr2d(i,k)+ dTracer)*Ithickness + endif + + enddo ! k=1,1 + + ! B/ Update tracer from mass leaving ocean + do k=1,nz + + ! Place forcing into this layer if this layer has nontrivial thickness. + ! For layers thin relative to 1/IforcingDepthScale, then distribute + ! forcing into deeper layers. + IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) + ! fractionOfForcing = 1.0, unless h2d is less than IforcingDepthScale. + fractionOfForcing = min(1.0, h2d(i,k)*IforcingDepthScale) + + ! In the case with (-1)*netMassOut*fractionOfForcing greater than cfl*h, we + ! limit the forcing applied to this cell, leaving the remaining forcing to + ! be distributed downwards. + if (-fractionOfForcing*netMassOut(i) > evap_CFL_limit*h2d(i,k)) then + fractionOfForcing = -evap_CFL_limit*h2d(i,k)/netMassOut(i) + endif + + ! Change in state due to forcing + dThickness = max( fractionOfForcing*netMassOut(i), -h2d(i,k) ) + ! Note this is slightly different to how salt is currently treated + dTracer = fractionOfForcing*out_flux_1d(i) + + ! Update the forcing by the part to be consumed within the present k-layer. + ! If fractionOfForcing = 1, then new netMassOut vanishes. + netMassOut(i) = netMassOut(i) - dThickness + out_flux_1d(i) = out_flux_1d(i) - dTracer + + ! Update state by the appropriate increment. + hOld = h2d(i,k) ! Keep original thickness in hand + h2d(i,k) = h2d(i,k) + dThickness ! New thickness + if (h2d(i,k) > 0.) then + Ithickness = 1.0/h2d(i,k) ! Inverse of new thickness + Tr2d(i,k) = (hOld*Tr2d(i,k) + dTracer)*Ithickness + endif + + enddo ! k + + endif + + ! If anything remains after the k-loop, then we have grounded out, which is a problem. + if (abs(in_flux_1d(i))+abs(out_flux_1d(i)) /= 0.0) then +!$OMP critical + numberOfGroundings = numberOfGroundings +1 + if (numberOfGroundings<=maxGroundings) then + iGround(numberOfGroundings) = i ! Record i,j location of event for + jGround(numberOfGroundings) = j ! warning message + hGrounding(numberOfGroundings) = abs(in_flux_1d(i))+abs(out_flux_1d(i)) + endif +!$OMP end critical + endif + + enddo ! i + + ! Step C/ copy updated tracer concentration from the 2d slice now back into model state. + do k=1,nz ; do i=is,ie + Tr(i,j,k) = Tr2d(i,k) + enddo ; enddo + + if (update_h) then + do k=1,nz ; do i=is,ie + h(i,j,k) = h2d(i,k) + enddo ; enddo + endif + + enddo ! j-loop finish + + if (numberOfGroundings>0) then + do i = 1, min(numberOfGroundings, maxGroundings) + write(mesg(1:45),'(3es15.3)') G%geoLonT( iGround(i), jGround(i) ), & + G%geoLatT( iGround(i), jGround(i)) , hGrounding(i) + call MOM_error(WARNING, "MOM_tracer_diabatic.F90, applyTracerBoundaryFluxesInOut(): "//& + "Tracer created. x,y,dh= "//trim(mesg), all_print=.true.) + enddo + + if (numberOfGroundings - maxGroundings > 0) then + write(mesg, '(i4)') numberOfGroundings - maxGroundings + call MOM_error(WARNING, "MOM_tracer_vertical.F90, applyTracerBoundaryFluxesInOut(): "//& + trim(mesg) // " groundings remaining", all_print=.true.) + endif + endif + +end subroutine applyTracerBoundaryFluxesInOut +end module MOM_tracer_diabatic diff --git a/tracer/MOM_tracer_flow_control.F90 b/tracer/MOM_tracer_flow_control.F90 new file mode 100644 index 0000000000..6d035e1d27 --- /dev/null +++ b/tracer/MOM_tracer_flow_control.F90 @@ -0,0 +1,893 @@ +!> Orchestrates the registration and calling of tracer packages +module MOM_tracer_flow_control + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : EFP_type, assignment(=), EFP_to_real, real_to_EFP, EFP_sum_across_PEs +use MOM_diag_mediator, only : time_type, diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type, close_param_file +use MOM_forcing_type, only : forcing, optics_type +use MOM_get_input, only : Get_MOM_input +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_CVMix_KPP, only : KPP_CS +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : MOM_restart_CS +use MOM_sponge, only : sponge_CS +use MOM_ALE_sponge, only : ALE_sponge_CS +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +#include + +! Add references to other user-provide tracer modules here. +use USER_tracer_example, only : tracer_column_physics, USER_initialize_tracer, USER_tracer_stock +use USER_tracer_example, only : USER_register_tracer_example, USER_tracer_surface_state +use USER_tracer_example, only : USER_tracer_example_end, USER_tracer_example_CS +use DOME_tracer, only : register_DOME_tracer, initialize_DOME_tracer +use DOME_tracer, only : DOME_tracer_column_physics, DOME_tracer_surface_state +use DOME_tracer, only : DOME_tracer_end, DOME_tracer_CS +use ISOMIP_tracer, only : register_ISOMIP_tracer, initialize_ISOMIP_tracer +use ISOMIP_tracer, only : ISOMIP_tracer_column_physics, ISOMIP_tracer_surface_state +use ISOMIP_tracer, only : ISOMIP_tracer_end, ISOMIP_tracer_CS +use RGC_tracer, only : register_RGC_tracer, initialize_RGC_tracer +use RGC_tracer, only : RGC_tracer_column_physics +use RGC_tracer, only : RGC_tracer_end, RGC_tracer_CS +use ideal_age_example, only : register_ideal_age_tracer, initialize_ideal_age_tracer +use ideal_age_example, only : ideal_age_tracer_column_physics, ideal_age_tracer_surface_state +use ideal_age_example, only : ideal_age_stock, ideal_age_example_end, ideal_age_tracer_CS +use regional_dyes, only : register_dye_tracer, initialize_dye_tracer +use regional_dyes, only : dye_tracer_column_physics, dye_tracer_surface_state +use regional_dyes, only : dye_stock, regional_dyes_end, dye_tracer_CS +use MOM_OCMIP2_CFC, only : register_OCMIP2_CFC, initialize_OCMIP2_CFC, flux_init_OCMIP2_CFC +use MOM_OCMIP2_CFC, only : OCMIP2_CFC_column_physics, OCMIP2_CFC_surface_state +use MOM_OCMIP2_CFC, only : OCMIP2_CFC_stock, OCMIP2_CFC_end, OCMIP2_CFC_CS +use MOM_CFC_cap, only : register_CFC_cap, initialize_CFC_cap +use MOM_CFC_cap, only : CFC_cap_column_physics, CFC_cap_set_forcing +use MOM_CFC_cap, only : CFC_cap_stock, CFC_cap_end, CFC_cap_CS +use oil_tracer, only : register_oil_tracer, initialize_oil_tracer +use oil_tracer, only : oil_tracer_column_physics, oil_tracer_surface_state +use oil_tracer, only : oil_stock, oil_tracer_end, oil_tracer_CS +use advection_test_tracer, only : register_advection_test_tracer, initialize_advection_test_tracer +use advection_test_tracer, only : advection_test_tracer_column_physics, advection_test_tracer_surface_state +use advection_test_tracer, only : advection_test_stock, advection_test_tracer_end, advection_test_tracer_CS +use dyed_obc_tracer, only : register_dyed_obc_tracer, initialize_dyed_obc_tracer +use dyed_obc_tracer, only : dyed_obc_tracer_column_physics +use dyed_obc_tracer, only : dyed_obc_tracer_end, dyed_obc_tracer_CS +use MOM_generic_tracer, only : register_MOM_generic_tracer, initialize_MOM_generic_tracer +use MOM_generic_tracer, only : MOM_generic_tracer_column_physics, MOM_generic_tracer_surface_state +use MOM_generic_tracer, only : end_MOM_generic_tracer, MOM_generic_tracer_get, MOM_generic_flux_init +use MOM_generic_tracer, only : MOM_generic_tracer_stock, MOM_generic_tracer_min_max, MOM_generic_tracer_CS +use MOM_generic_tracer, only : register_MOM_generic_tracer_segments +use pseudo_salt_tracer, only : register_pseudo_salt_tracer, initialize_pseudo_salt_tracer +use pseudo_salt_tracer, only : pseudo_salt_tracer_column_physics, pseudo_salt_tracer_surface_state +use pseudo_salt_tracer, only : pseudo_salt_stock, pseudo_salt_tracer_end, pseudo_salt_tracer_CS +use boundary_impulse_tracer, only : register_boundary_impulse_tracer, initialize_boundary_impulse_tracer +use boundary_impulse_tracer, only : boundary_impulse_tracer_column_physics, boundary_impulse_tracer_surface_state +use boundary_impulse_tracer, only : boundary_impulse_stock, boundary_impulse_tracer_end +use boundary_impulse_tracer, only : boundary_impulse_tracer_CS +use nw2_tracers, only : nw2_tracers_CS, register_nw2_tracers, nw2_tracer_column_physics +use nw2_tracers, only : initialize_nw2_tracers, nw2_tracers_end + +implicit none ; private + +public call_tracer_register, tracer_flow_control_init, call_tracer_set_forcing +public call_tracer_column_fns, call_tracer_surface_state, call_tracer_stocks +public call_tracer_flux_init, get_chl_from_model, tracer_flow_control_end +public call_tracer_register_obc_segments + +!> The control structure for orchestrating the calling of tracer packages +type, public :: tracer_flow_control_CS ; private + logical :: use_USER_tracer_example = .false. !< If true, use the USER_tracer_example package + logical :: use_DOME_tracer = .false. !< If true, use the DOME_tracer package + logical :: use_ISOMIP_tracer = .false. !< If true, use the ISOMPE_tracer package + logical :: use_RGC_tracer =.false. !< If true, use the RGC_tracer package + logical :: use_ideal_age = .false. !< If true, use the ideal age tracer package + logical :: use_regional_dyes = .false. !< If true, use the regional dyes tracer package + logical :: use_oil = .false. !< If true, use the oil tracer package + logical :: use_advection_test_tracer = .false. !< If true, use the advection_test_tracer package + logical :: use_OCMIP2_CFC = .false. !< If true, use the OCMIP2_CFC tracer package + logical :: use_CFC_cap = .false. !< If true, use the CFC_cap tracer package + logical :: use_MOM_generic_tracer = .false. !< If true, use the MOM_generic_tracer packages + logical :: use_pseudo_salt_tracer = .false. !< If true, use the psuedo_salt tracer package + logical :: use_boundary_impulse_tracer = .false. !< If true, use the boundary impulse tracer package + logical :: use_dyed_obc_tracer = .false. !< If true, use the dyed OBC tracer package + logical :: use_nw2_tracers = .false. !< If true, use the NW2 tracer package + !>@{ Pointers to the control strucures for the tracer packages + type(USER_tracer_example_CS), pointer :: USER_tracer_example_CSp => NULL() + type(DOME_tracer_CS), pointer :: DOME_tracer_CSp => NULL() + type(ISOMIP_tracer_CS), pointer :: ISOMIP_tracer_CSp => NULL() + type(RGC_tracer_CS), pointer :: RGC_tracer_CSp => NULL() + type(ideal_age_tracer_CS), pointer :: ideal_age_tracer_CSp => NULL() + type(dye_tracer_CS), pointer :: dye_tracer_CSp => NULL() + type(oil_tracer_CS), pointer :: oil_tracer_CSp => NULL() + type(advection_test_tracer_CS), pointer :: advection_test_tracer_CSp => NULL() + type(OCMIP2_CFC_CS), pointer :: OCMIP2_CFC_CSp => NULL() + type(CFC_cap_CS), pointer :: CFC_cap_CSp => NULL() + type(MOM_generic_tracer_CS), pointer :: MOM_generic_tracer_CSp => NULL() + type(pseudo_salt_tracer_CS), pointer :: pseudo_salt_tracer_CSp => NULL() + type(boundary_impulse_tracer_CS), pointer :: boundary_impulse_tracer_CSp => NULL() + type(dyed_obc_tracer_CS), pointer :: dyed_obc_tracer_CSp => NULL() + type(nw2_tracers_CS), pointer :: nw2_tracers_CSp => NULL() + !>@} +end type tracer_flow_control_CS + +contains + + +!> This subroutine carries out a series of calls to initialize the air-sea +!! tracer fluxes, but it does not record the generated indicies, and it may +!! be called _before_ the ocean model has been initialized and may be called +!! on non-ocean PEs. It is not necessary to call this routine for ocean-only +!! runs, because the same calls are made again inside of the routines called by +!! call_tracer_register +subroutine call_tracer_flux_init(verbosity) + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + + type(param_file_type) :: param_file ! A structure to parse for run-time parameters + character(len=40) :: mdl = "call_tracer_flux_init" ! This module's name. + logical :: use_OCMIP_CFCs, use_MOM_generic_tracer + + ! Determine which tracer routines with tracer fluxes are to be called. Note + ! that not every tracer package is required to have a flux_init call. + call get_MOM_Input(param_file, check_params=.false.) + + call get_param(param_file, mdl, "USE_OCMIP2_CFC", use_OCMIP_CFCs, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_generic_tracer", use_MOM_generic_tracer,& + default=.false., do_not_log=.true.) + call close_param_file(param_file, quiet_close=.true.) + + if (use_OCMIP_CFCs) call flux_init_OCMIP2_CFC(verbosity=verbosity) + if (use_MOM_generic_tracer) then + call MOM_generic_flux_init(verbosity=verbosity) + endif + +end subroutine call_tracer_flux_init + +! The following 5 subroutines and associated definitions provide the machinery to register and call +! the subroutines that initialize tracers and apply vertical column processes to tracers. + +!> This subroutine determines which tracer packages are to be used and does the calls to +!! register their tracers to be advected, diffused, and read from restarts. +subroutine call_tracer_register(G, GV, US, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(tracer_flow_control_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the + !! control structure for the tracer + !! advection and diffusion module. + type(MOM_restart_CS), intent(inout) :: restart_CS !< A pointer to the restart control + !! structure. + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_tracer_flow_control" ! This module's name. + + if (associated(CS)) then + call MOM_error(WARNING, "call_tracer_register called with an associated "// & + "control structure.") + return + else ; allocate(CS) ; endif + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "USE_USER_TRACER_EXAMPLE", CS%use_USER_tracer_example, & + "If true, use the USER_tracer_example tracer package.", & + default=.false.) + call get_param(param_file, mdl, "USE_DOME_TRACER", CS%use_DOME_tracer, & + "If true, use the DOME_tracer tracer package.", & + default=.false.) + call get_param(param_file, mdl, "USE_ISOMIP_TRACER", CS%use_ISOMIP_tracer, & + "If true, use the ISOMIP_tracer tracer package.", & + default=.false.) + call get_param(param_file, mdl, "USE_RGC_TRACER", CS%use_RGC_tracer, & + "If true, use the RGC_tracer tracer package.", & + default=.false.) + call get_param(param_file, mdl, "USE_IDEAL_AGE_TRACER", CS%use_ideal_age, & + "If true, use the ideal_age_example tracer package.", & + default=.false.) + call get_param(param_file, mdl, "USE_REGIONAL_DYES", CS%use_regional_dyes, & + "If true, use the regional_dyes tracer package.", & + default=.false.) + call get_param(param_file, mdl, "USE_OIL_TRACER", CS%use_oil, & + "If true, use the oil_tracer tracer package.", & + default=.false.) + call get_param(param_file, mdl, "USE_ADVECTION_TEST_TRACER", CS%use_advection_test_tracer, & + "If true, use the advection_test_tracer tracer package.", & + default=.false.) + call get_param(param_file, mdl, "USE_OCMIP2_CFC", CS%use_OCMIP2_CFC, & + "If true, use the MOM_OCMIP2_CFC tracer package.", & + default=.false.) + call get_param(param_file, mdl, "USE_CFC_CAP", CS%use_CFC_cap, & + "If true, use the MOM_CFC_cap tracer package.", & + default=.false.) + call get_param(param_file, mdl, "USE_generic_tracer", CS%use_MOM_generic_tracer, & + "If true and _USE_GENERIC_TRACER is defined as a "//& + "preprocessor macro, use the MOM_generic_tracer packages.", & + default=.false.) + call get_param(param_file, mdl, "USE_PSEUDO_SALT_TRACER", CS%use_pseudo_salt_tracer, & + "If true, use the pseudo salt tracer, typically run as a diagnostic.", & + default=.false.) + call get_param(param_file, mdl, "USE_BOUNDARY_IMPULSE_TRACER", CS%use_boundary_impulse_tracer, & + "If true, use the boundary impulse tracer.", & + default=.false.) + call get_param(param_file, mdl, "USE_DYED_OBC_TRACER", CS%use_dyed_obc_tracer, & + "If true, use the dyed_obc_tracer tracer package.", & + default=.false.) + call get_param(param_file, mdl, "USE_NW2_TRACERS", CS%use_nw2_tracers, & + "If true, use the NeverWorld2 tracers.", & + default=.false.) + +! Add other user-provided calls to register tracers for restarting here. Each +! tracer package registration call returns a logical false if it cannot be run +! for some reason. This then overrides the run-time selection from above. + if (CS%use_USER_tracer_example) CS%use_USER_tracer_example = & + USER_register_tracer_example(G, GV, US, param_file, CS%USER_tracer_example_CSp, & + tr_Reg, restart_CS) + if (CS%use_DOME_tracer) CS%use_DOME_tracer = & + register_DOME_tracer(G, GV, US, param_file, CS%DOME_tracer_CSp, & + tr_Reg, restart_CS) + if (CS%use_ISOMIP_tracer) CS%use_ISOMIP_tracer = & + register_ISOMIP_tracer(G%HI, GV, param_file, CS%ISOMIP_tracer_CSp, & + tr_Reg, restart_CS) + if (CS%use_RGC_tracer) CS%use_RGC_tracer = & + register_RGC_tracer(G, GV, param_file, CS%RGC_tracer_CSp, & + tr_Reg, restart_CS) + if (CS%use_ideal_age) CS%use_ideal_age = & + register_ideal_age_tracer(G%HI, GV, param_file, CS%ideal_age_tracer_CSp, & + tr_Reg, restart_CS) + if (CS%use_regional_dyes) CS%use_regional_dyes = & + register_dye_tracer(G%HI, GV, US, param_file, CS%dye_tracer_CSp, & + tr_Reg, restart_CS) + if (CS%use_oil) CS%use_oil = & + register_oil_tracer(G%HI, GV, US, param_file, CS%oil_tracer_CSp, & + tr_Reg, restart_CS) + if (CS%use_advection_test_tracer) CS%use_advection_test_tracer = & + register_advection_test_tracer(G, GV, param_file, CS%advection_test_tracer_CSp, & + tr_Reg, restart_CS) + if (CS%use_OCMIP2_CFC) CS%use_OCMIP2_CFC = & + register_OCMIP2_CFC(G%HI, GV, param_file, CS%OCMIP2_CFC_CSp, & + tr_Reg, restart_CS) + if (CS%use_CFC_cap) CS%use_CFC_cap = & + register_CFC_cap(G%HI, GV, param_file, CS%CFC_cap_CSp, & + tr_Reg, restart_CS) + if (CS%use_MOM_generic_tracer) CS%use_MOM_generic_tracer = & + register_MOM_generic_tracer(G%HI, GV, param_file, CS%MOM_generic_tracer_CSp, & + tr_Reg, restart_CS) + if (CS%use_pseudo_salt_tracer) CS%use_pseudo_salt_tracer = & + register_pseudo_salt_tracer(G%HI, GV, param_file, CS%pseudo_salt_tracer_CSp, & + tr_Reg, restart_CS) + if (CS%use_boundary_impulse_tracer) CS%use_boundary_impulse_tracer = & + register_boundary_impulse_tracer(G%HI, GV, US, param_file, CS%boundary_impulse_tracer_CSp, & + tr_Reg, restart_CS) + if (CS%use_dyed_obc_tracer) CS%use_dyed_obc_tracer = & + register_dyed_obc_tracer(G%HI, GV, param_file, CS%dyed_obc_tracer_CSp, & + tr_Reg, restart_CS) + if (CS%use_nw2_tracers) CS%use_nw2_tracers = & + register_nw2_tracers(G%HI, GV, US, param_file, CS%nw2_tracers_CSp, tr_Reg, restart_CS) + +end subroutine call_tracer_register + +!> This subroutine calls all registered tracer initialization +!! subroutines. +subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag, OBC, & + CS, sponge_CSp, ALE_sponge_CSp, tv) + logical, intent(in) :: restart !< 1 if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid + !! structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(param_file_type), intent(in) :: param_file !< A structure to parse for + !! run-time parameters + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to + !! regulate diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition + !! type specifies whether, where, + !! and what open boundary + !! conditions are used. + type(tracer_flow_control_CS), pointer :: CS !< The control structure returned + !! by a previous call to + !! call_tracer_register. + type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control + !! structure for the sponges, if they are in use. + !! Otherwise this may be unassociated. + type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< A pointer to the control + !! structure for the ALE sponges, if they are in use. + !! Otherwise this may be unassociated. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + + if (.not. associated(CS)) call MOM_error(FATAL, "tracer_flow_control_init: "// & + "Module must be initialized via call_tracer_register before it is used.") + +! Add other user-provided calls here. + if (CS%use_USER_tracer_example) & + call USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS%USER_tracer_example_CSp, & + sponge_CSp) + if (CS%use_DOME_tracer) & + call initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS%DOME_tracer_CSp, & + sponge_CSp, tv) + if (CS%use_ISOMIP_tracer) & + call initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS%ISOMIP_tracer_CSp, & + ALE_sponge_CSp) + if (CS%use_RGC_tracer) & + call initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS%RGC_tracer_CSp, & + sponge_CSp, ALE_sponge_CSp) + if (CS%use_ideal_age) & + call initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS%ideal_age_tracer_CSp, & + sponge_CSp) + if (CS%use_regional_dyes) & + call initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS%dye_tracer_CSp, sponge_CSp, tv) + if (CS%use_oil) & + call initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS%oil_tracer_CSp, sponge_CSp) + if (CS%use_advection_test_tracer) & + call initialize_advection_test_tracer(restart, day, G, GV, h, diag, OBC, CS%advection_test_tracer_CSp, & + sponge_CSp) + if (CS%use_OCMIP2_CFC) & + call initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS%OCMIP2_CFC_CSp, sponge_CSp) + if (CS%use_CFC_cap) & + call initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS%CFC_cap_CSp) + + if (CS%use_MOM_generic_tracer) & + call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, tv, param_file, diag, OBC, & + CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp) + if (CS%use_pseudo_salt_tracer) & + call initialize_pseudo_salt_tracer(restart, day, G, GV, US, h, diag, OBC, CS%pseudo_salt_tracer_CSp, & + sponge_CSp, tv) + if (CS%use_boundary_impulse_tracer) & + call initialize_boundary_impulse_tracer(restart, day, G, GV, US, h, diag, OBC, CS%boundary_impulse_tracer_CSp, & + sponge_CSp, tv) + if (CS%use_dyed_obc_tracer) & + call initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS%dyed_obc_tracer_CSp) + if (CS%use_nw2_tracers) & + call initialize_nw2_tracers(restart, day, G, GV, US, h, tv, diag, CS%nw2_tracers_CSp) + +end subroutine tracer_flow_control_init + +!> This subroutine calls all registered tracers to register their OBC segments +!! similar to register_temp_salt_segments for T&S +subroutine call_tracer_register_obc_segments(GV, param_file, CS, tr_Reg, OBC) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(tracer_flow_control_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the + !! control structure for the tracer + !! advection and diffusion module. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition + !! type specifies whether, where, + !! and what open boundary + !! conditions are used. + + if (CS%use_MOM_generic_tracer) & + call register_MOM_generic_tracer_segments(CS%MOM_generic_tracer_CSp, GV, OBC, tr_Reg, param_file) + +end subroutine call_tracer_register_obc_segments + +!> This subroutine extracts the chlorophyll concentrations from the model state, if possible +subroutine get_chl_from_model(Chl_array, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: Chl_array !< The array in which to store the model's + !! Chlorophyll-A concentrations [mg m-3]. + type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a + !! previous call to call_tracer_register. + + if (CS%use_MOM_generic_tracer) then + call MOM_generic_tracer_get('chl', 'field', Chl_array, CS%MOM_generic_tracer_CSp) + else + call MOM_error(FATAL, "get_chl_from_model was called in a configuration "// & + "that is unable to provide a sensible model-based value.\n"// & + "CS%use_MOM_generic_tracer is false and no other viable options are on.") + endif + +end subroutine get_chl_from_model + +!> This subroutine calls the individual tracer modules' subroutines to +!! specify or read quantities related to their surface forcing. +subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, CS) + + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the + !! ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL ptrs. + type(time_type), intent(in) :: day_start !< Start time of the fluxes. + type(time_type), intent(in) :: day_interval !< Length of time over which these + !! fluxes will be applied. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< The mean ocean density [R ~> kg m-3] + type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a + !! previous call to call_tracer_register. + + if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_set_forcing"// & + "Module must be initialized via call_tracer_register before it is used.") +! if (CS%use_ideal_age) & +! call ideal_age_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, & +! G, CS%ideal_age_tracer_CSp) + if (CS%use_CFC_cap) & + call CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, & + CS%CFC_cap_CSp) + +end subroutine call_tracer_set_forcing + +!> This subroutine calls all registered tracer column physics subroutines. +subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, US, tv, optics, CS, & + debug, KPP_CSp, nonLocalTrans, evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Layer thickness before entrainment + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Layer thickness after entrainment + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: ea !< an array to which the amount of + !! fluid entrained from the layer above during this call + !! will be added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: eb !< an array to which the amount of + !! fluid entrained from the layer below during this call + !! will be added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to + !! any possible forcing fields. + !! Unused fields have NULL ptrs. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] + real, intent(in) :: dt !< The amount of time covered by this + !! call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + type(optics_type), pointer :: optics !< The structure containing optical + !! properties. + type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by + !! a previous call to + !! call_tracer_register. + logical, intent(in) :: debug !< If true calculate checksums + type(KPP_CS), optional, pointer :: KPP_CSp !< KPP control structure + real, optional, intent(in) :: nonLocalTrans(:,:,:) !< Non-local transport [nondim] + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of + !! the water that can be fluxed out + !! of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over + !! which fluxes can be applied [H ~> m or kg m-2] + + if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_column_fns: "// & + "Module must be initialized via call_tracer_register before it is used.") + + ! Use the applyTracerBoundaryFluxesInOut to handle surface fluxes + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + ! Add calls to tracer column functions here. + if (CS%use_USER_tracer_example) & + call tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%USER_tracer_example_CSp) + if (CS%use_DOME_tracer) & + call DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%DOME_tracer_CSp, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + if (CS%use_ISOMIP_tracer) & + call ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%ISOMIP_tracer_CSp, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + if (CS%use_RGC_tracer) & + call RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%RGC_tracer_CSp, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + if (CS%use_ideal_age) & + call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, tv, CS%ideal_age_tracer_CSp, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth, & + Hbl=Hml) + if (CS%use_regional_dyes) & + call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, tv, CS%dye_tracer_CSp, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + if (CS%use_oil) & + call oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%oil_tracer_CSp, tv, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + + if (CS%use_advection_test_tracer) & + call advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%advection_test_tracer_CSp, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + if (CS%use_OCMIP2_CFC) & + call OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%OCMIP2_CFC_CSp, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + if (CS%use_CFC_cap) & + call CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%CFC_cap_CSp, & + KPP_CSp=KPP_CSp, & + nonLocalTrans=nonLocalTrans, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + if (CS%use_MOM_generic_tracer) then + if (US%QRZ_T_to_W_m2 /= 1.0) call MOM_error(FATAL, "MOM_generic_tracer_column_physics "//& + "has not been written to permit dimensionsal rescaling. Set all 4 of the "//& + "[QRZT]_RESCALE_POWER parameters to 0.") + call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, & + G, GV, US, CS%MOM_generic_tracer_CSp, tv, optics, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + endif + if (CS%use_pseudo_salt_tracer) & + call pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%pseudo_salt_tracer_CSp, tv, & + debug, & + KPP_CSp=KPP_CSp, & + nonLocalTrans=nonLocalTrans, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + if (CS%use_boundary_impulse_tracer) & + call boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%boundary_impulse_tracer_CSp, tv, debug, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + if (CS%use_dyed_obc_tracer) & + call dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%dyed_obc_tracer_CSp, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + if (CS%use_nw2_tracers) & + call nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, tv, CS%nw2_tracers_CSp, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) + else ! Apply tracer surface fluxes using ea on the first layer + if (CS%use_USER_tracer_example) & + call tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%USER_tracer_example_CSp) + if (CS%use_DOME_tracer) & + call DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%DOME_tracer_CSp) + if (CS%use_ISOMIP_tracer) & + call ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%ISOMIP_tracer_CSp) + if (CS%use_RGC_tracer) & + call RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%RGC_tracer_CSp) + if (CS%use_ideal_age) & + call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, tv, CS%ideal_age_tracer_CSp, Hbl=Hml) + if (CS%use_regional_dyes) & + call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, tv, CS%dye_tracer_CSp) + if (CS%use_oil) & + call oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%oil_tracer_CSp, tv) + if (CS%use_advection_test_tracer) & + call advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%advection_test_tracer_CSp) + if (CS%use_OCMIP2_CFC) & + call OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%OCMIP2_CFC_CSp) + if (CS%use_CFC_cap) & + call CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%CFC_cap_CSp, & + KPP_CSp=KPP_CSp, & + nonLocalTrans=nonLocalTrans) + if (CS%use_MOM_generic_tracer) then + if (US%QRZ_T_to_W_m2 /= 1.0) call MOM_error(FATAL, "MOM_generic_tracer_column_physics "//& + "has not been written to permit dimensionsal rescaling. Set all 4 of the "//& + "[QRZT]_RESCALE_POWER parameters to 0.") + call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, & + G, GV, US, CS%MOM_generic_tracer_CSp, tv, optics) + endif + if (CS%use_pseudo_salt_tracer) & + call pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%pseudo_salt_tracer_CSp, & + tv, debug, & + KPP_CSp=KPP_CSp, & + nonLocalTrans=nonLocalTrans) + if (CS%use_boundary_impulse_tracer) & + call boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%boundary_impulse_tracer_CSp, tv, debug) + if (CS%use_dyed_obc_tracer) & + call dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%dyed_obc_tracer_CSp) + if (CS%use_nw2_tracers) call nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, tv, CS%nw2_tracers_CSp) + endif + +end subroutine call_tracer_column_fns + +!> This subroutine calls all registered tracer packages to enable them to +!! add to the surface state returned to the coupler. These routines are optional. +subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock_units, & + num_stocks, stock_index, got_min_max, global_min, global_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(:), intent(out) :: stock_values !< The globally mass-integrated + !! amount of a tracer [kg conc]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a + !! previous call to + !! call_tracer_register. + character(len=*), dimension(:), & + optional, intent(out) :: stock_names !< Diagnostic names to use for each stock. + character(len=*), dimension(:), & + optional, intent(out) :: stock_units !< Units to use in the metadata for each stock. + integer, optional, intent(out) :: num_stocks !< The number of tracer stocks being returned. + integer, optional, intent(in) :: stock_index !< The integer stock index from + !! stocks_constants_mod of the stock to be returned. If this is + !! present and greater than 0, only a single stock can be returned. + logical, dimension(:), & + optional, intent(inout) :: got_min_max !< Indicates whether the global min and + !! max are found for each tracer + real, dimension(:), optional, intent(out) :: global_min !< The global minimum of each tracer [conc] + real, dimension(:), optional, intent(out) :: global_max !< The global maximum of each tracer [conc] + real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] + real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] + real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] + real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] + real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] + + ! Local variables + character(len=200), dimension(MAX_FIELDS_) :: names, units + character(len=200) :: set_pkg_name + ! real, dimension(MAX_FIELDS_) :: values ! Globally integrated tracer amounts in a + ! new list for each tracer package [kg conc] + type(EFP_type), dimension(MAX_FIELDS_) :: values_EFP ! Globally integrated tracer amounts in a + ! new list for each tracer package [kg conc] + type(EFP_type), dimension(MAX_FIELDS_) :: stock_val_EFP ! Globally integrated tracer amounts in a + ! single master list for all tracers [kg conc] + integer :: max_ns, ns_tot, ns, index, nn, n + + if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_stocks: "// & + "Module must be initialized via call_tracer_register before it is used.") + + index = -1 ; if (present(stock_index)) index = stock_index + ns_tot = 0 + max_ns = size(stock_values) + if (present(stock_names)) max_ns = min(max_ns,size(stock_names)) + if (present(stock_units)) max_ns = min(max_ns,size(stock_units)) + +! Add other user-provided calls here. + if (CS%use_USER_tracer_example) then + ns = USER_tracer_stock(h, values_EFP, G, GV, CS%USER_tracer_example_CSp, & + names, units, stock_index) + call store_stocks("tracer_example", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + endif +! if (CS%use_DOME_tracer) then +! ns = DOME_tracer_stock(h, values, G, GV, CS%DOME_tracer_CSp, & +! names, units, stock_index) +! do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo +! call store_stocks("DOME_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & +! set_pkg_name, max_ns, ns_tot, stock_names, stock_units) +! endif + if (CS%use_ideal_age) then + ns = ideal_age_stock(h, values_EFP, G, GV, CS%ideal_age_tracer_CSp, & + names, units, stock_index) + call store_stocks("ideal_age_example", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + endif + if (CS%use_regional_dyes) then + ns = dye_stock(h, values_EFP, G, GV, CS%dye_tracer_CSp, names, units, stock_index) + call store_stocks("regional_dyes", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + endif + if (CS%use_oil) then + ns = oil_stock(h, values_EFP, G, GV, CS%oil_tracer_CSp, names, units, stock_index) + call store_stocks("oil_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + endif + if (CS%use_OCMIP2_CFC) then + ns = OCMIP2_CFC_stock(h, values_EFP, G, GV, CS%OCMIP2_CFC_CSp, names, units, stock_index) + call store_stocks("MOM_OCMIP2_CFC", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + endif + + if (CS%use_CFC_cap) then + ns = CFC_cap_stock(h, values_EFP, G, GV, CS%CFC_cap_CSp, names, units, stock_index) + call store_stocks("MOM_CFC_cap", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + endif + + if (CS%use_advection_test_tracer) then + ns = advection_test_stock( h, values_EFP, G, GV, CS%advection_test_tracer_CSp, & + names, units, stock_index ) + ! do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("advection_test_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + endif + + if (CS%use_MOM_generic_tracer) then + ns = MOM_generic_tracer_stock(h, values_EFP, G, GV, CS%MOM_generic_tracer_CSp, & + names, units, stock_index) + call store_stocks("MOM_generic_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + nn=ns_tot-ns+1 + nn=MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax ,& + G, CS%MOM_generic_tracer_CSp,names, units) + + endif + if (CS%use_pseudo_salt_tracer) then + ns = pseudo_salt_stock(h, values_EFP, G, GV, CS%pseudo_salt_tracer_CSp, & + names, units, stock_index) + call store_stocks("pseudo_salt_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + endif + + if (CS%use_boundary_impulse_tracer) then + ns = boundary_impulse_stock(h, values_EFP, G, GV, CS%boundary_impulse_tracer_CSp, & + names, units, stock_index) + call store_stocks("boundary_impulse_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + endif + + ! Sum the various quantities across all the processors. + if (ns_tot > 0) then + call EFP_sum_across_PEs(stock_val_EFP, ns_tot) + do n=1,ns_tot ; stock_values(n) = EFP_to_real(stock_val_EFP(n)) ; enddo + else + stock_values(1) = 0.0 + endif + + if (present(num_stocks)) num_stocks = ns_tot + +end subroutine call_tracer_stocks + +!> This routine stores the stocks and does error handling for call_tracer_stocks. +subroutine store_stocks(pkg_name, ns, names, units, values, index, stock_values, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + character(len=*), intent(in) :: pkg_name !< The tracer package name + integer, intent(in) :: ns !< The number of stocks associated with this tracer package + character(len=*), dimension(:), & + intent(in) :: names !< Diagnostic names to use for each stock. + character(len=*), dimension(:), & + intent(in) :: units !< Units to use in the metadata for each stock. + type(EFP_type), dimension(:), & + intent(in) :: values !< The values of the tracer stocks [conc kg] + integer, intent(in) :: index !< The integer stock index from + !! stocks_constants_mod of the stock to be returned. If this is + !! present and greater than 0, only a single stock can be returned. + type(EFP_type), dimension(:), & + intent(inout) :: stock_values !< The master list of stock values [conc kg] + character(len=*), intent(inout) :: set_pkg_name !< The name of the last tracer package whose + !! stocks were stored for a specific index. This is + !! used to trigger an error if there are redundant stocks. + integer, intent(in) :: max_ns !< The maximum size of the master stock list + integer, intent(inout) :: ns_tot !< The total number of stocks in the master list + character(len=*), dimension(:), & + optional, intent(inout) :: stock_names !< Diagnostic names to use for each stock in the master list + character(len=*), dimension(:), & + optional, intent(inout) :: stock_units !< Units to use in the metadata for each stock in the master list + +! This routine stores the stocks and does error handling for call_tracer_stocks. + character(len=16) :: ind_text, ns_text, max_text + integer :: n + + if ((index > 0) .and. (ns > 0)) then + write(ind_text,'(i8)') index + if (ns > 1) then + call MOM_error(FATAL,"Tracer package "//trim(pkg_name)//& + " is not permitted to return more than one value when queried"//& + " for specific stock index "//trim(adjustl(ind_text))//".") + elseif (ns+ns_tot > 1) then + call MOM_error(FATAL,"Tracer packages "//trim(pkg_name)//" and "//& + trim(set_pkg_name)//" both attempted to set values for"//& + " specific stock index "//trim(adjustl(ind_text))//".") + else + set_pkg_name = pkg_name + endif + endif + + if (ns_tot+ns > max_ns) then + write(ns_text,'(i8)') ns_tot+ns ; write(max_text,'(i8)') max_ns + call MOM_error(FATAL,"Attempted to return more tracer stock values (at least "//& + trim(adjustl(ns_text))//") than the size "//trim(adjustl(max_text))//& + "of the smallest value, name, or units array.") + endif + + do n=1,ns + stock_values(ns_tot+n) = values(n) + if (present(stock_names)) stock_names(ns_tot+n) = names(n) + if (present(stock_units)) stock_units(ns_tot+n) = units(n) + enddo + ns_tot = ns_tot + ns + +end subroutine store_stocks + +!> This subroutine calls all registered tracer packages to enable them to +!! add to the surface state returned to the coupler. These routines are optional. +subroutine call_tracer_surface_state(sfc_state, h, G, GV, US, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a + !! previous call to call_tracer_register. + + if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_surface_state: "// & + "Module must be initialized via call_tracer_register before it is used.") + +! Add other user-provided calls here. + if (CS%use_USER_tracer_example) & + call USER_tracer_surface_state(sfc_state, h, G, GV, CS%USER_tracer_example_CSp) + if (CS%use_DOME_tracer) & + call DOME_tracer_surface_state(sfc_state, h, G, GV, CS%DOME_tracer_CSp) + if (CS%use_ISOMIP_tracer) & + call ISOMIP_tracer_surface_state(sfc_state, h, G, GV, CS%ISOMIP_tracer_CSp) + if (CS%use_ideal_age) & + call ideal_age_tracer_surface_state(sfc_state, h, G, GV, CS%ideal_age_tracer_CSp) + if (CS%use_regional_dyes) & + call dye_tracer_surface_state(sfc_state, h, G, GV, CS%dye_tracer_CSp) + if (CS%use_oil) & + call oil_tracer_surface_state(sfc_state, h, G, GV, CS%oil_tracer_CSp) + if (CS%use_advection_test_tracer) & + call advection_test_tracer_surface_state(sfc_state, h, G, GV, CS%advection_test_tracer_CSp) + if (CS%use_OCMIP2_CFC) & + call OCMIP2_CFC_surface_state(sfc_state, h, G, GV, US, CS%OCMIP2_CFC_CSp) + if (CS%use_MOM_generic_tracer) & + call MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS%MOM_generic_tracer_CSp) + +end subroutine call_tracer_surface_state + +subroutine tracer_flow_control_end(CS) + type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a + !! previous call to call_tracer_register. + + if (CS%use_USER_tracer_example) & + call USER_tracer_example_end(CS%USER_tracer_example_CSp) + if (CS%use_DOME_tracer) call DOME_tracer_end(CS%DOME_tracer_CSp) + if (CS%use_ISOMIP_tracer) call ISOMIP_tracer_end(CS%ISOMIP_tracer_CSp) + if (CS%use_RGC_tracer) call RGC_tracer_end(CS%RGC_tracer_CSp) + if (CS%use_ideal_age) call ideal_age_example_end(CS%ideal_age_tracer_CSp) + if (CS%use_regional_dyes) call regional_dyes_end(CS%dye_tracer_CSp) + if (CS%use_oil) call oil_tracer_end(CS%oil_tracer_CSp) + if (CS%use_advection_test_tracer) call advection_test_tracer_end(CS%advection_test_tracer_CSp) + if (CS%use_OCMIP2_CFC) call OCMIP2_CFC_end(CS%OCMIP2_CFC_CSp) + if (CS%use_CFC_cap) call CFC_cap_end(CS%CFC_cap_CSp) + if (CS%use_MOM_generic_tracer) call end_MOM_generic_tracer(CS%MOM_generic_tracer_CSp) + if (CS%use_pseudo_salt_tracer) call pseudo_salt_tracer_end(CS%pseudo_salt_tracer_CSp) + if (CS%use_boundary_impulse_tracer) call boundary_impulse_tracer_end(CS%boundary_impulse_tracer_CSp) + if (CS%use_dyed_obc_tracer) call dyed_obc_tracer_end(CS%dyed_obc_tracer_CSp) + if (CS%use_nw2_tracers) call nw2_tracers_end(CS%nw2_tracers_CSp) + + if (associated(CS)) deallocate(CS) +end subroutine tracer_flow_control_end + +!> \namespace MOM_tracer_flow_control +!! +!! By Will Cooke, April 2003 +!! Edited by Elizabeth Yankovsky, May 2019 +!! +!! This module contains two subroutines into which calls to other +!! tracer initialization (call_tracer_init_fns) and column physics +!! routines (call_tracer_column_fns) can be inserted. +!! +end module MOM_tracer_flow_control diff --git a/tracer/MOM_tracer_hor_diff.F90 b/tracer/MOM_tracer_hor_diff.F90 new file mode 100644 index 0000000000..6f4e5d0f90 --- /dev/null +++ b/tracer/MOM_tracer_hor_diff.F90 @@ -0,0 +1,1681 @@ +!> Main routine for lateral (along surface or neutral) diffusion of tracers +module MOM_tracer_hor_diff + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type +use MOM_domains, only : sum_across_PEs, max_across_PEs +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : pass_vector +use MOM_debugging, only : hchksum, uvchksum +use MOM_diabatic_driver, only : diabatic_CS +use MOM_EOS, only : calculate_density, EOS_type, EOS_domain +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_lateral_mixing_coeffs, only : VarMix_CS +use MOM_MEKE_types, only : MEKE_type +use MOM_neutral_diffusion, only : neutral_diffusion_init, neutral_diffusion_end +use MOM_neutral_diffusion, only : neutral_diffusion_CS +use MOM_neutral_diffusion, only : neutral_diffusion_calc_coeffs, neutral_diffusion +use MOM_hor_bnd_diffusion, only : hbd_CS, hor_bnd_diffusion_init +use MOM_hor_bnd_diffusion, only : hor_bnd_diffusion, hor_bnd_diffusion_end +use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chksum +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public tracer_hordiff, tracer_hor_diff_init, tracer_hor_diff_end + +!> The control structure for along-layer and epineutral tracer diffusion +type, public :: tracer_hor_diff_CS ; private + real :: KhTr !< The along-isopycnal tracer diffusivity [L2 T-1 ~> m2 s-1]. + real :: KhTr_Slope_Cff !< The non-dimensional coefficient in KhTr formula [nondim] + real :: KhTr_min !< Minimum along-isopycnal tracer diffusivity [L2 T-1 ~> m2 s-1]. + real :: KhTr_max !< Maximum along-isopycnal tracer diffusivity [L2 T-1 ~> m2 s-1]. + real :: KhTr_passivity_coeff !< Passivity coefficient that scales Rd/dx (default = 0) + !! where passivity is the ratio between along-isopycnal + !! tracer mixing and thickness mixing [nondim] + real :: KhTr_passivity_min !< Passivity minimum (default = 1/2) [nondim] + real :: ML_KhTR_scale !< With Diffuse_ML_interior, the ratio of the + !! truly horizontal diffusivity in the mixed + !! layer to the epipycnal diffusivity [nondim]. + real :: max_diff_CFL !< If positive, locally limit the along-isopycnal + !! tracer diffusivity to keep the diffusive CFL + !! locally at or below this value [nondim]. + logical :: KhTh_use_ebt_struct !< If true, uses the equivalent barotropic structure + !! as the vertical structure of tracer diffusivity. + logical :: Diffuse_ML_interior !< If true, diffuse along isopycnals between + !! the mixed layer and the interior. + logical :: check_diffusive_CFL !< If true, automatically iterate the diffusion + !! to ensure that the diffusive equivalent of + !! the CFL limit is not violated. + logical :: use_neutral_diffusion !< If true, use the neutral_diffusion module from within + !! tracer_hor_diff. + logical :: use_hor_bnd_diffusion !< If true, use the hor_bnd_diffusion module from within + !! tracer_hor_diff. + logical :: recalc_neutral_surf !< If true, recalculate the neutral surfaces if CFL has been + !! exceeded + type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() !< Control structure for neutral diffusion. + type(hbd_CS), pointer :: hor_bnd_diffusion_CSp => NULL() !< Control structure for + !! horizontal boundary diffusion. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: show_call_tree !< Display the call tree while running. Set by VERBOSITY level. + logical :: first_call = .true. !< This is true until after the first call + !>@{ Diagnostic IDs + integer :: id_KhTr_u = -1 + integer :: id_KhTr_v = -1 + integer :: id_KhTr_h = -1 + integer :: id_CFL = -1 + integer :: id_khdt_x = -1 + integer :: id_khdt_y = -1 + !>@} + + type(group_pass_type) :: pass_t !< For group halo pass, used in both + !! tracer_hordiff and tracer_epipycnal_ML_diff +end type tracer_hor_diff_CS + +!> A type that can be used to create arrays of pointers to 2D arrays +type p2d + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array of reals [various] +end type p2d +!> A type that can be used to create arrays of pointers to 2D integer arrays +type p2di + integer, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array of integers +end type p2di + +!>@{ CPU time clocks +integer :: id_clock_diffuse, id_clock_epimix, id_clock_pass, id_clock_sync +!>@} + +contains + +!> Compute along-coordinate diffusion of all tracers +!! using the diffusivity in CS%KhTr, or using space-dependent diffusivity. +!! Multiple iterations are used (if necessary) so that there is no limit +!! on the acceptable time increment. +subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) + type(ocean_grid_type), intent(inout) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, intent(in) :: dt !< time step [T ~> s] + type(MEKE_type), intent(in) :: MEKE !< MEKE fields + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tracer_hor_diff_CS), pointer :: CS !< module control structure + type(tracer_registry_type), pointer :: Reg !< registered tracers + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields, including potential temp and + !! salinity or mixed layer density. Absent fields have + !! NULL ptrs, and these may (probably will) point to + !! some of the same arrays as Tr does. tv is required + !! for epipycnal mixing between mixed layer and the interior. + ! Optional inputs for offline tracer transport + logical, optional, intent(in) :: do_online_flag !< If present and true, do online + !! tracer transport with stored velocities. + ! The next two arguments do not appear to be used anywhere. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: read_khdt_x !< If present, these are the zonal diffusivities + !! times a timestep from a previous run [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: read_khdt_y !< If present, these are the meridional diffusivities + !! times a timestep from a previous run [L2 ~> m2] + + + real, dimension(SZI_(G),SZJ_(G)) :: & + Ihdxdy, & ! The inverse of the volume or mass of fluid in a layer in a + ! grid cell [H-1 L-2 ~> m-3 or kg-1]. + CFL, & ! A diffusive CFL number for each cell [nondim]. + dTr ! The change in a tracer's concentration, in units of concentration [Conc]. + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: Kh_h + ! The tracer diffusivity averaged to tracer points [L2 T-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZJ_(G)) :: & + khdt_x ! The value of Khtr*dt times the open face width divided by + ! the distance between adjacent tracer points [L2 ~> m2]. + real, dimension(SZI_(G),SZJB_(G)) :: & + khdt_y ! The value of Khtr*dt times the open face width divided by + ! the distance between adjacent tracer points [L2 ~> m2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & + Coef_x, & ! The coefficients relating zonal tracer differences to time-integrated + ! fluxes, in [L2 ~> m2] for some schemes and [H L2 ~> m3 or kg] for others. + Kh_u ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & + Coef_y, & ! The coefficients relating meridional tracer differences to time-integrated + ! fluxes, in [L2 ~> m2] for some schemes and [H L2 ~> m3 or kg] for others. + Kh_v ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. + + real :: khdt_max ! The local limiting value of khdt_x or khdt_y [L2 ~> m2]. + real :: max_CFL ! The global maximum of the diffusive CFL number [nondim] + logical :: use_VarMix, Resoln_scaled, do_online, use_Eady + integer :: i, j, k, m, is, ie, js, je, nz, ntr, itt, num_itts + real :: I_numitts ! The inverse of the number of iterations, num_itts [nondim] + real :: scale ! The fraction of khdt_x or khdt_y that is applied in this + ! layer for this iteration [nondim]. + real :: Idt ! The inverse of the time step [T-1 ~> s-1]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: Kh_loc ! The local value of Kh [L2 T-1 ~> m2 s-1]. + real :: Res_Fn ! The local value of the resolution function [nondim]. + real :: Rd_dx ! The local value of deformation radius over grid-spacing [nondim]. + real :: normalize ! normalization used for diagnostic Kh_h [nondim]; diffusivity averaged to h-points. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + do_online = .true. + if (present(do_online_flag)) do_online = do_online_flag + + if (.not. associated(CS)) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & + "register_tracer must be called before tracer_hordiff.") + 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 + + if (CS%show_call_tree) call callTree_enter("tracer_hordiff(), MOM_tracer_hor_diff.F90") + + call cpu_clock_begin(id_clock_diffuse) + + ntr = Reg%ntr + Idt = 1.0 / dt + h_neglect = GV%H_subroundoff + + if (CS%Diffuse_ML_interior .and. CS%first_call) then ; if (is_root_pe()) then + do m=1,ntr ; if (associated(Reg%Tr(m)%df_x) .or. associated(Reg%Tr(m)%df_y)) & + call MOM_error(WARNING, "tracer_hordiff: Tracer "//trim(Reg%Tr(m)%name)// & + " has associated 3-d diffusive flux diagnostics. These are not "//& + "valid when DIFFUSE_ML_TO_INTERIOR is defined. Use 2-d tracer "//& + "diffusion diagnostics instead to get accurate total fluxes.") + enddo + endif ; endif + CS%first_call = .false. + + if (CS%debug) call MOM_tracer_chksum("Before tracer diffusion ", Reg, G) + + use_VarMix = .false. ; Resoln_scaled = .false. ; use_Eady = .false. + if (VarMix%use_variable_mixing) then + use_VarMix = VarMix%use_variable_mixing + Resoln_scaled = VarMix%Resoln_scaled_KhTr + use_Eady = CS%KhTr_Slope_Cff > 0. + endif + + call cpu_clock_begin(id_clock_pass) + do m=1,ntr + call create_group_pass(CS%pass_t, Reg%Tr(m)%t(:,:,:), G%Domain) + enddo + call cpu_clock_end(id_clock_pass) + + if (CS%show_call_tree) call callTree_waypoint("Calculating diffusivity (tracer_hordiff)") + + if (do_online) then + if (use_VarMix) then + !$OMP parallel do default(shared) private(Kh_loc,Rd_dx) + do j=js,je ; do I=is-1,ie + Kh_loc = CS%KhTr + if (use_Eady) Kh_loc = Kh_loc + CS%KhTr_Slope_Cff*VarMix%L2u(I,j)*VarMix%SN_u(I,j) + if (allocated(MEKE%Kh)) & + Kh_loc = Kh_loc + MEKE%KhTr_fac*sqrt(MEKE%Kh(i,j)*MEKE%Kh(i+1,j)) + if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) + if (Resoln_scaled) & + Kh_loc = Kh_loc * 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) + Kh_u(I,j,1) = max(Kh_loc, CS%KhTr_min) + if (CS%KhTr_passivity_coeff>0.) then ! Apply passivity + Rd_dx=0.5*( VarMix%Rd_dx_h(i,j)+VarMix%Rd_dx_h(i+1,j) ) ! Rd/dx at u-points + Kh_loc = Kh_u(I,j,1)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) + if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max + Kh_u(I,j,1) = max(Kh_loc, CS%KhTr_min) ! Re-apply min + endif + enddo ; enddo + !$OMP parallel do default(shared) private(Kh_loc,Rd_dx) + do J=js-1,je ; do i=is,ie + Kh_loc = CS%KhTr + if (use_Eady) Kh_loc = Kh_loc + CS%KhTr_Slope_Cff*VarMix%L2v(i,J)*VarMix%SN_v(i,J) + if (allocated(MEKE%Kh)) & + Kh_loc = Kh_loc + MEKE%KhTr_fac*sqrt(MEKE%Kh(i,j)*MEKE%Kh(i,j+1)) + if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) + if (Resoln_scaled) & + Kh_loc = Kh_loc * 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) + Kh_v(i,J,1) = max(Kh_loc, CS%KhTr_min) + if (CS%KhTr_passivity_coeff>0.) then ! Apply passivity + Rd_dx = 0.5*( VarMix%Rd_dx_h(i,j)+VarMix%Rd_dx_h(i,j+1) ) ! Rd/dx at v-points + Kh_loc = Kh_v(i,J,1)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) + if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max + Kh_v(i,J,1) = max(Kh_loc, CS%KhTr_min) ! Re-apply min + endif + enddo ; enddo + + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + khdt_x(I,j) = dt*(Kh_u(I,j,1)*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + khdt_y(i,J) = dt*(Kh_v(i,J,1)*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + enddo ; enddo + elseif (Resoln_scaled) then + !$OMP parallel do default(shared) private(Res_fn) + do j=js,je ; do I=is-1,ie + Res_fn = 0.5 * (VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) + Kh_u(I,j,1) = max(CS%KhTr * Res_fn, CS%KhTr_min) + khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) * Res_fn + enddo ; enddo + !$OMP parallel do default(shared) private(Res_fn) + do J=js-1,je ; do i=is,ie + Res_fn = 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) + Kh_v(i,J,1) = max(CS%KhTr * Res_fn, CS%KhTr_min) + khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) * Res_fn + enddo ; enddo + else ! Use a simple constant diffusivity. + if (CS%id_KhTr_u > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + Kh_u(I,j,1) = CS%KhTr + khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + enddo ; enddo + endif + if (CS%id_KhTr_v > 0) then + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + Kh_v(i,J,1) = CS%KhTr + khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + enddo ; enddo + else + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + enddo ; enddo + endif + endif ! VarMix + + if (CS%max_diff_CFL > 0.0) then + if ((CS%id_KhTr_u > 0) .or. (CS%id_KhTr_h > 0)) then + !$OMP parallel do default(shared) private(khdt_max) + do j=js,je ; do I=is-1,ie + khdt_max = 0.125*CS%max_diff_CFL * min(G%areaT(i,j), G%areaT(i+1,j)) + if (khdt_x(I,j) > khdt_max) then + khdt_x(I,j) = khdt_max + if (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j)) > 0.0) & + Kh_u(I,j,1) = khdt_x(I,j) / (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + endif + enddo ; enddo + else + !$OMP parallel do default(shared) private(khdt_max) + do j=js,je ; do I=is-1,ie + khdt_max = 0.125*CS%max_diff_CFL * min(G%areaT(i,j), G%areaT(i+1,j)) + khdt_x(I,j) = min(khdt_x(I,j), khdt_max) + enddo ; enddo + endif + if ((CS%id_KhTr_v > 0) .or. (CS%id_KhTr_h > 0)) then + !$OMP parallel do default(shared) private(khdt_max) + do J=js-1,je ; do i=is,ie + khdt_max = 0.125*CS%max_diff_CFL * min(G%areaT(i,j), G%areaT(i,j+1)) + if (khdt_y(i,J) > khdt_max) then + khdt_y(i,J) = khdt_max + if (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J)) > 0.0) & + Kh_v(i,J,1) = khdt_y(i,J) / (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + endif + enddo ; enddo + else + !$OMP parallel do default(shared) private(khdt_max) + do J=js-1,je ; do i=is,ie + khdt_max = 0.125*CS%max_diff_CFL * min(G%areaT(i,j), G%areaT(i,j+1)) + khdt_y(i,J) = min(khdt_y(i,J), khdt_max) + enddo ; enddo + endif + endif + + else ! .not. do_online + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + khdt_x(I,j) = read_khdt_x(I,j) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + khdt_y(i,J) = read_khdt_y(i,J) + enddo ; enddo + call pass_vector(khdt_x, khdt_y, G%Domain) + endif ! do_online + + if (CS%check_diffusive_CFL) then + if (CS%show_call_tree) call callTree_waypoint("Checking diffusive CFL (tracer_hordiff)") + max_CFL = 0.0 + do j=js,je ; do i=is,ie + CFL(i,j) = 2.0*((khdt_x(I-1,j) + khdt_x(I,j)) + & + (khdt_y(i,J-1) + khdt_y(i,J))) * G%IareaT(i,j) + if (max_CFL < CFL(i,j)) max_CFL = CFL(i,j) + enddo ; enddo + call cpu_clock_begin(id_clock_sync) + call max_across_PEs(max_CFL) + call cpu_clock_end(id_clock_sync) + num_itts = max(1, ceiling(max_CFL - 4.0*EPSILON(max_CFL))) + I_numitts = 1.0 / (real(num_itts)) + if (CS%id_CFL > 0) call post_data(CS%id_CFL, CFL, CS%diag, mask=G%mask2dT) + elseif (CS%max_diff_CFL > 0.0) then + num_itts = max(1, ceiling(CS%max_diff_CFL - 4.0*EPSILON(CS%max_diff_CFL))) + I_numitts = 1.0 / (real(num_itts)) + else + num_itts = 1 ; I_numitts = 1.0 + endif + + do m=1,ntr + if (associated(Reg%Tr(m)%df_x)) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + Reg%Tr(m)%df_x(I,j,k) = 0.0 + enddo ; enddo ; enddo + endif + if (associated(Reg%Tr(m)%df_y)) then + do k=1,nz ; do J=js-1,je ; do i=is,ie + Reg%Tr(m)%df_y(i,J,k) = 0.0 + enddo ; enddo ; enddo + endif + if (associated(Reg%Tr(m)%df2d_x)) then + do j=js,je ; do I=is-1,ie ; Reg%Tr(m)%df2d_x(I,j) = 0.0 ; enddo ; enddo + endif + if (associated(Reg%Tr(m)%df2d_y)) then + do J=js-1,je ; do i=is,ie ; Reg%Tr(m)%df2d_y(i,J) = 0.0 ; enddo ; enddo + endif + enddo + + if (CS%use_hor_bnd_diffusion) then + + if (CS%show_call_tree) call callTree_waypoint("Calling horizontal boundary diffusion (tracer_hordiff)") + + call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) + + do k=1,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = I_numitts * khdt_y(i,J) + enddo + enddo + enddo + do k=1,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = I_numitts * khdt_x(I,j) + enddo + enddo + enddo + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + enddo + enddo + enddo + do k=2,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + enddo + enddo + enddo + endif + + do itt=1,num_itts + if (CS%show_call_tree) call callTree_waypoint("Calling horizontal boundary diffusion (tracer_hordiff)",itt) + if (itt>1) then ! Update halos for subsequent iterations + call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) + endif + call hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, & + CS%hor_bnd_diffusion_CSp) + enddo ! itt + endif + + if (CS%use_neutral_diffusion) then + + if (CS%show_call_tree) call callTree_waypoint("Calling neutral diffusion coeffs (tracer_hordiff)") + + call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) + ! We are assuming that neutral surfaces do not evolve (much) as a result of multiple + !horizontal diffusion iterations. Otherwise the call to neutral_diffusion_calc_coeffs() + ! would be inside the itt-loop. -AJA + + if (associated(tv%p_surf)) then + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp, p_surf=tv%p_surf) + else + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + endif + + do k=1,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = I_numitts * khdt_y(i,J) + enddo + enddo + enddo + do k=1,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = I_numitts * khdt_x(I,j) + enddo + enddo + enddo + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + enddo + enddo + enddo + do k=2,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + enddo + enddo + enddo + endif + + do itt=1,num_itts + if (CS%show_call_tree) call callTree_waypoint("Calling neutral diffusion (tracer_hordiff)",itt) + if (itt>1) then ! Update halos for subsequent iterations + call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) + if (CS%recalc_neutral_surf) then + if (associated(tv%p_surf)) then + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp, p_surf=tv%p_surf) + else + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + endif + endif + endif + call neutral_diffusion(G, GV, h, Coef_x, Coef_y, I_numitts*dt, Reg, US, CS%neutral_diffusion_CSp) + enddo ! itt + + else ! following if not using neutral diffusion, but instead along-surface diffusion + + if (CS%show_call_tree) call callTree_waypoint("Calculating horizontal diffusion (tracer_hordiff)") + do itt=1,num_itts + call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) + !$OMP parallel do default(shared) private(scale,Coef_y,Coef_x,Ihdxdy,dTr) + do k=1,nz + scale = I_numitts + if (CS%Diffuse_ML_interior) then + if (k<=GV%nkml) then + if (CS%ML_KhTr_scale <= 0.0) cycle + scale = I_numitts * CS%ML_KhTr_scale + endif + if ((k>GV%nkml) .and. (k<=GV%nk_rho_varies)) cycle + endif + + do J=js-1,je ; do i=is,ie + Coef_y(i,J,1) = ((scale * khdt_y(i,J))*2.0*(h(i,j,k)*h(i,j+1,k))) / & + (h(i,j,k)+h(i,j+1,k)+h_neglect) + enddo ; enddo + + do j=js,je + do I=is-1,ie + Coef_x(I,j,1) = ((scale * khdt_x(I,j))*2.0*(h(i,j,k)*h(i+1,j,k))) / & + (h(i,j,k)+h(i+1,j,k)+h_neglect) + enddo + + do i=is,ie + Ihdxdy(i,j) = G%IareaT(i,j) / (h(i,j,k)+h_neglect) + enddo + enddo + + do m=1,ntr + do j=js,je ; do i=is,ie + dTr(i,j) = Ihdxdy(i,j) * & + ((Coef_x(I-1,j,1) * (Reg%Tr(m)%t(i-1,j,k) - Reg%Tr(m)%t(i,j,k)) - & + Coef_x(I,j,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k))) + & + (Coef_y(i,J-1,1) * (Reg%Tr(m)%t(i,j-1,k) - Reg%Tr(m)%t(i,j,k)) - & + Coef_y(i,J,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)))) + enddo ; enddo + if (associated(Reg%Tr(m)%df_x)) then ; do j=js,je ; do I=G%IscB,G%IecB + Reg%Tr(m)%df_x(I,j,k) = Reg%Tr(m)%df_x(I,j,k) + Coef_x(I,j,1) & + * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)) * Idt + enddo ; enddo ; endif + if (associated(Reg%Tr(m)%df_y)) then ; do J=G%JscB,G%JecB ; do i=is,ie + Reg%Tr(m)%df_y(i,J,k) = Reg%Tr(m)%df_y(i,J,k) + Coef_y(i,J,1) & + * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)) * Idt + enddo ; enddo ; endif + if (associated(Reg%Tr(m)%df2d_x)) then ; do j=js,je ; do I=G%IscB,G%IecB + Reg%Tr(m)%df2d_x(I,j) = Reg%Tr(m)%df2d_x(I,j) + Coef_x(I,j,1) & + * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)) * Idt + enddo ; enddo ; endif + if (associated(Reg%Tr(m)%df2d_y)) then ; do J=G%JscB,G%JecB ; do i=is,ie + Reg%Tr(m)%df2d_y(i,J) = Reg%Tr(m)%df2d_y(i,J) + Coef_y(i,J,1) & + * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)) * Idt + enddo ; enddo ; endif + do j=js,je ; do i=is,ie + Reg%Tr(m)%t(i,j,k) = Reg%Tr(m)%t(i,j,k) + dTr(i,j) + enddo ; enddo + enddo + + enddo ! End of k loop. + + ! Do user controlled underflow of the tracer concentrations. + do m=1,ntr ; if (Reg%Tr(m)%conc_underflow > 0.0) then + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do i=is,ie + if (abs(Reg%Tr(m)%t(i,j,k)) < Reg%Tr(m)%conc_underflow) Reg%Tr(m)%t(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif ; enddo + + enddo ! End of "while" loop. + + endif ! endif for CS%use_neutral_diffusion + call cpu_clock_end(id_clock_diffuse) + + + if (CS%Diffuse_ML_interior) then + if (CS%show_call_tree) call callTree_waypoint("Calling epipycnal_ML_diff (tracer_hordiff)") + if (CS%debug) call MOM_tracer_chksum("Before epipycnal diff ", Reg, G) + + call cpu_clock_begin(id_clock_epimix) + call tracer_epipycnal_ML_diff(h, dt, Reg%Tr, ntr, khdt_x, khdt_y, G, GV, US, & + CS, tv, num_itts) + call cpu_clock_end(id_clock_epimix) + endif + + if (CS%debug) call MOM_tracer_chksum("After tracer diffusion ", Reg, G) + + ! post diagnostics for 2d tracer diffusivity + if (CS%id_KhTr_u > 0) then + do j=js,je ; do I=is-1,ie + Kh_u(I,j,:) = G%mask2dCu(I,j)*Kh_u(I,j,1) + enddo ; enddo + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + do j=js,je + do I=is-1,ie + Kh_u(I,j,K) = Kh_u(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + enddo + enddo + enddo + endif + !call post_data(CS%id_KhTr_u, Kh_u, CS%diag, is_static=.false., mask=G%mask2dCu) + call post_data(CS%id_KhTr_u, Kh_u, CS%diag) + endif + if (CS%id_KhTr_v > 0) then + do J=js-1,je ; do i=is,ie + Kh_v(i,J,:) = G%mask2dCv(i,J)*Kh_v(i,J,1) + enddo ; enddo + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + do J=js-1,je + do i=is,ie + Kh_v(i,J,K) = Kh_v(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + enddo + enddo + enddo + endif + !call post_data(CS%id_KhTr_v, Kh_v, CS%diag, is_static=.false., mask=G%mask2dCv) + call post_data(CS%id_KhTr_v, Kh_v, CS%diag) + endif + if (CS%id_KhTr_h > 0) then + Kh_h(:,:,:) = 0.0 + do j=js,je ; do I=is-1,ie + Kh_u(I,j,1) = G%mask2dCu(I,j)*Kh_u(I,j,1) + enddo ; enddo + do J=js-1,je ; do i=is,ie + Kh_v(i,J,1) = G%mask2dCv(i,J)*Kh_v(i,J,1) + enddo ; enddo + + do j=js,je ; do i=is,ie + normalize = 1.0 / ((G%mask2dCu(I-1,j)+G%mask2dCu(I,j)) + & + (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + 1.0e-37) + Kh_h(i,j,:) = normalize*G%mask2dT(i,j)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & + (Kh_v(i,J-1,1)+Kh_v(i,J,1))) + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + Kh_h(i,j,K) = normalize*G%mask2dT(i,j)*VarMix%ebt_struct(i,j,k-1)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & + (Kh_v(i,J-1,1)+Kh_v(i,J,1))) + enddo + endif + enddo ; enddo + !call post_data(CS%id_KhTr_h, Kh_h, CS%diag, is_static=.false., mask=G%mask2dT) + call post_data(CS%id_KhTr_h, Kh_h, CS%diag) + endif + + if (CS%debug) then + call uvchksum("After tracer diffusion khdt_[xy]", khdt_x, khdt_y, & + G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & + scalar_pair=.true.) + endif + + if (CS%id_khdt_x > 0) call post_data(CS%id_khdt_x, khdt_x, CS%diag) + if (CS%id_khdt_y > 0) call post_data(CS%id_khdt_y, khdt_y, CS%diag) + + if (CS%show_call_tree) call callTree_leave("tracer_hordiff()") + +end subroutine tracer_hordiff + +!> This subroutine does epipycnal diffusion of all tracers between the mixed +!! and buffer layers and the interior, using the diffusivity in CS%KhTr. +!! Multiple iterations are used (if necessary) so that there is no limit on the +!! acceptable time increment. +subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & + GV, US, CS, tv, num_itts) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, intent(in) :: dt !< time step [T ~> s] + type(tracer_type), intent(inout) :: Tr(:) !< tracer array + integer, intent(in) :: ntr !< number of tracers + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: khdt_epi_x !< Zonal epipycnal diffusivity times + !! a time step and the ratio of the open face width over + !! the distance between adjacent tracer points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: khdt_epi_y !< Meridional epipycnal diffusivity times + !! a time step and the ratio of the open face width over + !! the distance between adjacent tracer points [L2 ~> m2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tracer_hor_diff_CS), intent(inout) :: CS !< module control structure + type(thermo_var_ptrs), intent(in) :: tv !< thermodynamic structure + integer, intent(in) :: num_itts !< number of iterations (usually=1) + + + real, dimension(SZI_(G), SZJ_(G)) :: & + Rml_max ! The maximum coordinate density within the mixed layer [R ~> kg m-3]. + real, dimension(SZI_(G), SZJ_(G), max(1,GV%nk_rho_varies)) :: & + rho_coord ! The coordinate density that is used to mix along [R ~> kg m-3]. + + ! The naming mnemonic is a=above,b=below,L=Left,R=Right,u=u-point,v=v-point. + ! These are 1-D arrays of pointers to 2-d arrays to minimize memory usage. + type(p2d), dimension(SZJ_(G)) :: & + deep_wt_Lu, deep_wt_Ru, & ! The relative weighting of the deeper of a pair [nondim]. + hP_Lu, hP_Ru ! The total thickness on each side for each pair [H ~> m or kg m-2]. + + type(p2d), dimension(SZJB_(G)) :: & + deep_wt_Lv, deep_wt_Rv, & ! The relative weighting of the deeper of a pair [nondim]. + hP_Lv, hP_Rv ! The total thickness on each side for each pair [H ~> m or kg m-2]. + + type(p2di), dimension(SZJ_(G)) :: & + k0b_Lu, k0a_Lu, & ! The original k-indices of the layers that participate + k0b_Ru, k0a_Ru ! in each pair of mixing at u-faces. + type(p2di), dimension(SZJB_(G)) :: & + k0b_Lv, k0a_Lv, & ! The original k-indices of the layers that participate + k0b_Rv, k0a_Rv ! in each pair of mixing at v-faces. + + !### Accumulating the converge into this array one face at a time may lead to a lack of rotational symmetry. + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & + tr_flux_conv ! The flux convergence of tracers [conc H L2 ~> conc m3 or conc kg] + + ! The following 3-d arrays were created in 2014 in MOM6 PR#12 to facilitate openMP threading + ! on an i-loop, which might have been ill advised. The k-size extents here might also be problematic. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + Tr_flux_3d, & ! The tracer flux through pairings at meridional faces [conc H L2 ~> conc m3 or conc kg] + Tr_adj_vert_L, & ! Vertical adjustments to which layer the fluxes go into in the southern + ! columns at meridional face [conc H L2 ~> conc m3 or conc kg] + Tr_adj_vert_R ! Vertical adjustments to which layer the fluxes go into in the northern + ! columns at meridional face [conc H L2 ~> conc m3 or conc kg] + + real, dimension(SZI_(G),SZK_(GV), SZJ_(G)) :: & + rho_srt, & ! The density of each layer of the sorted columns [R ~> kg m-3]. + h_srt ! The thickness of each layer of the sorted columns [H ~> m or kg m-2]. + integer, dimension(SZI_(G),SZK_(GV), SZJ_(G)) :: & + k0_srt ! The original k-index that each layer of the sorted column corresponds to. + + real, dimension(SZK_(GV)) :: & + h_demand_L, & ! The thickness in the left column that is demanded to match the thickness + ! in the counterpart [H ~> m or kg m-2]. + h_demand_R, & ! The thickness in the right column that is demanded to match the thickness + ! in the counterpart [H ~> m or kg m-2]. + h_used_L, & ! The summed thickness from the left column that has actually been used [H ~> m or kg m-2] + h_used_R, & ! The summed thickness from the right columns that has actually been used [H ~> m or kg m-2] + h_supply_frac_L, & ! The fraction of the demanded thickness that can actually be supplied + ! from a layer on the left [nondim]. + h_supply_frac_R ! The fraction of the demanded thickness that can actually be supplied + ! from a layer on the right [nondim]. + integer, dimension(SZI_(G), SZJ_(G)) :: & + num_srt, & ! The number of layers that are sorted in each column. + k_end_srt, & ! The maximum index in each column that might need to be + ! sorted, based on neighboring values of max_kRho + max_kRho ! The index of the layer whose target density is just denser + ! than the densest part of the mixed layer. + integer, dimension(SZJ_(G)) :: & + max_srt ! The maximum value of num_srt in a k-row. + integer, dimension(SZIB_(G), SZJ_(G)) :: & + nPu ! The number of epipycnal pairings at each u-point. + integer, dimension(SZI_(G), SZJB_(G)) :: & + nPv ! The number of epipycnal pairings at each v-point. + real :: h_exclude ! A thickness that layers must attain to be considered + ! for inclusion in mixing [H ~> m or kg m-2]. + real :: Idt ! The inverse of the time step [T-1 ~> s-1]. + real :: I_maxitt ! The inverse of the maximum number of iterations [nondim] + real :: rho_pair, rho_a, rho_b ! Temporary densities [R ~> kg m-3]. + real :: Tr_min_face ! The minimum tracer concentration associated with a pairing [Conc] + real :: Tr_max_face ! The maximum tracer concentration associated with a pairing [Conc] + real :: Tr_La, Tr_Lb ! The 2 left-side tracer concentrations that might be associated with a pairing [Conc] + real :: Tr_Ra, Tr_Rb ! The 2 right-side tracer concentrations that might be associated with a pairing [Conc] + real :: Tr_av_L ! The average tracer concentrations on the left side of a pairing [Conc]. + real :: Tr_av_R ! The average tracer concentrations on the right side of a pairing [Conc]. + real :: Tr_flux ! The tracer flux from left to right in a pair [conc H L2 ~> conc m3 or conc kg]. + real :: Tr_adj_vert ! A downward vertical adjustment to Tr_flux between the two cells that + ! make up one side of the pairing [conc H L2 ~> conc m3 or conc kg]. + real :: h_L, h_R ! Thicknesses to the left and right [H ~> m or kg m-2]. + real :: wt_a, wt_b ! Fractional weights of layers above and below [nondim]. + real :: vol ! A cell volume or mass [H L2 ~> m3 or kg]. + + ! The total number of pairings is usually much less than twice the number of layers, but + ! the memory in these 1-d columns of pairings can be allocated generously for safety. + integer, dimension(SZK_(GV)*2) :: & + kbs_Lp, & ! The sorted indices of the Left and Right columns for + kbs_Rp ! each pairing. + logical, dimension(SZK_(GV)*2) :: & + left_set, & ! If true, the left or right point determines the density of + right_set ! of the trio. If densities are exactly equal, both are true. + + real :: tmp ! A temporary variable used in swaps [various] + real :: p_ref_cv(SZI_(G)) ! The reference pressure for the coordinate density [R L2 T-2 ~> Pa] + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: k_max, k_min, k_test, itmp + integer :: i, j, k, k2, m, is, ie, js, je, nz, nkmb + integer :: isd, ied, jsd, jed, IsdB, IedB, k_size + integer :: kL, kR, kLa, kLb, kRa, kRb, nP, itt, ns, max_itt + integer :: PEmax_kRho + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB + Idt = 1.0 / dt + nkmb = GV%nk_rho_varies + + if (num_itts <= 1) then + max_itt = 1 ; I_maxitt = 1.0 + else + max_itt = num_itts ; I_maxitt = 1.0 / (real(max_itt)) + endif + + do i=is-2,ie+2 ; p_ref_cv(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI,halo=2) + + call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) + ! Determine which layers the mixed- and buffer-layers map into... + !$OMP parallel do default(shared) + do k=1,nkmb ; do j=js-2,je+2 + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref_cv, rho_coord(:,j,k), & + tv%eqn_of_state, EOSdom) + enddo ; enddo + + do j=js-2,je+2 ; do i=is-2,ie+2 + Rml_max(i,j) = rho_coord(i,j,1) + num_srt(i,j) = 0 ; max_kRho(i,j) = 0 + enddo ; enddo + do k=2,nkmb ; do j=js-2,je+2 ; do i=is-2,ie+2 + if (Rml_max(i,j) < rho_coord(i,j,k)) Rml_max(i,j) = rho_coord(i,j,k) + enddo ; enddo ; enddo + ! Use bracketing and bisection to find the k-level that the densest of the + ! 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.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 + k_min = nkmb+2 ; k_max = nz + do + k_test = (k_min + k_max) / 2 + if (Rml_max(i,j) <= GV%Rlay(k_test-1)) then ; k_max = k_test-1 + elseif (GV%Rlay(k_test) < Rml_max(i,j)) then ; k_min = k_test+1 + else ; max_kRho(i,j) = k_test ; exit ; endif + + if (k_min == k_max) then ; max_kRho(i,j) = k_max ; exit ; endif + enddo + endif + endif ; enddo ; enddo + + PEmax_kRho = 0 + do j=js-1,je+1 ; do i=is-1,ie+1 + k_end_srt(i,j) = max(max_kRho(i,j), max_kRho(i-1,j), max_kRho(i+1,j), & + max_kRho(i,j-1), max_kRho(i,j+1)) + if (PEmax_kRho < k_end_srt(i,j)) PEmax_kRho = k_end_srt(i,j) + enddo ; enddo + if (PEmax_kRho > nz) PEmax_kRho = nz ! PEmax_kRho could have been nz+1. + + h_exclude = 10.0*(GV%Angstrom_H + GV%H_subroundoff) + !$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.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 + rho_srt(i,ns,j) = rho_coord(i,j,k) + 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.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 + rho_srt(i,ns,j) = GV%Rlay(k) + h_srt(i,ns,j) = h(i,j,k) + endif + endif ; enddo ; enddo + enddo + ! Sort each column by increasing density. This should already be close, + ! and the size of the arrays are small, so straight insertion is used. + !$OMP do + do j=js-1,je+1 ; do i=is-1,ie+1 + do k=2,num_srt(i,j) ; if (rho_srt(i,k,j) < rho_srt(i,k-1,j)) then + ! The last segment needs to be shuffled earlier in the list. + do k2 = k,2,-1 ; if (rho_srt(i,k2,j) >= rho_srt(i,k2-1,j)) exit + itmp = k0_srt(i,k2-1,j) ; k0_srt(i,k2-1,j) = k0_srt(i,k2,j) ; k0_srt(i,k2,j) = itmp + tmp = rho_srt(i,k2-1,j) ; rho_srt(i,k2-1,j) = rho_srt(i,k2,j) ; rho_srt(i,k2,j) = tmp + tmp = h_srt(i,k2-1,j) ; h_srt(i,k2-1,j) = h_srt(i,k2,j) ; h_srt(i,k2,j) = tmp + enddo + endif ; enddo + enddo ; enddo + !$OMP do + do j=js-1,je+1 + max_srt(j) = 0 + do i=is-1,ie+1 ; max_srt(j) = max(max_srt(j), num_srt(i,j)) ; enddo + enddo + !$OMP end parallel + + do j=js,je + k_size = max(2*max_srt(j),1) + allocate(deep_wt_Lu(j)%p(IsdB:IedB,k_size)) + allocate(deep_wt_Ru(j)%p(IsdB:IedB,k_size)) + allocate(hP_Lu(j)%p(IsdB:IedB,k_size)) + allocate(hP_Ru(j)%p(IsdB:IedB,k_size)) + allocate(k0a_Lu(j)%p(IsdB:IedB,k_size)) + allocate(k0a_Ru(j)%p(IsdB:IedB,k_size)) + allocate(k0b_Lu(j)%p(IsdB:IedB,k_size)) + allocate(k0b_Ru(j)%p(IsdB:IedB,k_size)) + enddo + +!$OMP parallel do default(none) shared(is,ie,js,je,G,num_srt,rho_srt,k0b_Lu,k0_srt, & +!$OMP k0b_Ru,k0a_Lu,k0a_Ru,deep_wt_Lu,deep_wt_Ru, & +!$OMP h_srt,nkmb,nPu,hP_Lu,hP_Ru) & +!$OMP private(h_demand_L,h_used_L,h_demand_R,h_used_R, & +!$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.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 + do k=1,num_srt(i+1,j) ; h_demand_R(k) = 0.0 ; h_used_R(k) = 0.0 ; enddo + + ! First merge the left and right lists into a single, sorted list. + + ! Discard any layers that are lighter than the lightest in the other + ! column. They can only participate in mixing as the lighter part of a + ! pair of points. + if (rho_srt(i,1,j) < rho_srt(i+1,1,j)) then + kR = 1 + do kL=2,num_srt(i,j) ; if (rho_srt(i,kL,j) >= rho_srt(i+1,1,j)) exit ; enddo + elseif (rho_srt(i+1,1,j) < rho_srt(i,1,j)) then + kL = 1 + do kR=2,num_srt(i+1,j) ; if (rho_srt(i+1,kR,j) >= rho_srt(i,1,j)) exit ; enddo + else + kL = 1 ; kR = 1 + endif + nP = 0 + do ! Loop to accumulate pairs of columns. + if ((kL > num_srt(i,j)) .or. (kR > num_srt(i+1,j))) exit + + if (rho_srt(i,kL,j) > rho_srt(i+1,kR,j)) then + ! The right point is lighter and defines the density for this trio. + nP = nP+1 ; k = nP + rho_pair = rho_srt(i+1,kR,j) + + k0b_Lu(j)%p(I,k) = k0_srt(i,kL,j) ; k0b_Ru(j)%p(I,k) = k0_srt(i+1,kR,j) + k0a_Lu(j)%p(I,k) = k0_srt(i,kL-1,j) ; k0a_Ru(j)%p(I,k) = k0b_Ru(j)%p(I,k) + kbs_Lp(k) = kL ; kbs_Rp(k) = kR + + rho_a = rho_srt(i,kL-1,j) ; rho_b = rho_srt(i,kL,j) + wt_b = 1.0 ; if (abs(rho_a - rho_b) > abs(rho_pair - rho_a)) & + wt_b = (rho_pair - rho_a) / (rho_b - rho_a) + deep_wt_Lu(j)%p(I,k) = wt_b ; deep_wt_Ru(j)%p(I,k) = 1.0 + + h_demand_L(kL) = h_demand_L(kL) + 0.5*h_srt(i+1,kR,j) * wt_b + h_demand_L(kL-1) = h_demand_L(kL-1) + 0.5*h_srt(i+1,kR,j) * (1.0-wt_b) + + kR = kR+1 ; left_set(k) = .false. ; right_set(k) = .true. + elseif (rho_srt(i,kL,j) < rho_srt(i+1,kR,j)) then + ! The left point is lighter and defines the density for this trio. + nP = nP+1 ; k = nP + rho_pair = rho_srt(i,kL,j) + k0b_Lu(j)%p(I,k) = k0_srt(i,kL,j) ; k0b_Ru(j)%p(I,k) = k0_srt(i+1,kR,j) + k0a_Lu(j)%p(I,k) = k0b_Lu(j)%p(I,k) ; k0a_Ru(j)%p(I,k) = k0_srt(i+1,kR-1,j) + + kbs_Lp(k) = kL ; kbs_Rp(k) = kR + + rho_a = rho_srt(i+1,kR-1,j) ; rho_b = rho_srt(i+1,kR,j) + wt_b = 1.0 ; if (abs(rho_a - rho_b) > abs(rho_pair - rho_a)) & + wt_b = (rho_pair - rho_a) / (rho_b - rho_a) + deep_wt_Lu(j)%p(I,k) = 1.0 ; deep_wt_Ru(j)%p(I,k) = wt_b + + h_demand_R(kR) = h_demand_R(kR) + 0.5*h_srt(i,kL,j) * wt_b + h_demand_R(kR-1) = h_demand_R(kR-1) + 0.5*h_srt(i,kL,j) * (1.0-wt_b) + + kL = kL+1 ; left_set(k) = .true. ; right_set(k) = .false. + elseif ((k0_srt(i,kL,j) <= nkmb) .or. (k0_srt(i+1,kR,j) <= nkmb)) then + ! The densities are exactly equal and one layer is above the interior. + nP = nP+1 ; k = nP + k0b_Lu(j)%p(I,k) = k0_srt(i,kL,j) ; k0b_Ru(j)%p(I,k) = k0_srt(i+1,kR,j) + k0a_Lu(j)%p(I,k) = k0b_Lu(j)%p(I,k) ; k0a_Ru(j)%p(I,k) = k0b_Ru(j)%p(I,k) + kbs_Lp(k) = kL ; kbs_Rp(k) = kR + deep_wt_Lu(j)%p(I,k) = 1.0 ; deep_wt_Ru(j)%p(I,k) = 1.0 + + h_demand_L(kL) = h_demand_L(kL) + 0.5*h_srt(i+1,kR,j) + h_demand_R(kR) = h_demand_R(kR) + 0.5*h_srt(i,kL,j) + + kL = kL+1 ; kR = kR+1 ; left_set(k) = .true. ; right_set(k) = .true. + else ! The densities are exactly equal and in the interior. + ! Mixing in this case has already occurred, so accumulate the thickness + ! demanded for that mixing and skip onward. + h_demand_L(kL) = h_demand_L(kL) + 0.5*h_srt(i+1,kR,j) + h_demand_R(kR) = h_demand_R(kR) + 0.5*h_srt(i,kL,j) + + kL = kL+1 ; kR = kR+1 + endif + enddo ! Loop to accumulate pairs of columns. + nPu(I,j) = nP ! This is the number of active pairings. + + ! Determine what fraction of the thickness "demand" can be supplied. + do k=1,num_srt(i+1,j) + h_supply_frac_R(k) = 1.0 + if (h_demand_R(k) > 0.5*h_srt(i+1,k,j)) & + h_supply_frac_R(k) = 0.5*h_srt(i+1,k,j) / h_demand_R(k) + enddo + do k=1,num_srt(i,j) + h_supply_frac_L(k) = 1.0 + if (h_demand_L(k) > 0.5*h_srt(i,k,j)) & + h_supply_frac_L(k) = 0.5*h_srt(i,k,j) / h_demand_L(k) + enddo + + ! Distribute the "exported" thicknesses proportionately. + do k=1,nPu(I,j) + kL = kbs_Lp(k) ; kR = kbs_Rp(k) + hP_Lu(j)%p(I,k) = 0.0 ; hP_Ru(j)%p(I,k) = 0.0 + if (left_set(k)) then ! Add the contributing thicknesses on the right. + if (deep_wt_Ru(j)%p(I,k) < 1.0) then + hP_Ru(j)%p(I,k) = 0.5*h_srt(i,kL,j) * min(h_supply_frac_R(kR), h_supply_frac_R(kR-1)) + wt_b = deep_wt_Ru(j)%p(I,k) + h_used_R(kR-1) = h_used_R(kR-1) + (1.0 - wt_b)*hP_Ru(j)%p(I,k) + h_used_R(kR) = h_used_R(kR) + wt_b*hP_Ru(j)%p(I,k) + else + hP_Ru(j)%p(I,k) = 0.5*h_srt(i,kL,j) * h_supply_frac_R(kR) + h_used_R(kR) = h_used_R(kR) + hP_Ru(j)%p(I,k) + endif + endif + if (right_set(k)) then ! Add the contributing thicknesses on the left. + if (deep_wt_Lu(j)%p(I,k) < 1.0) then + hP_Lu(j)%p(I,k) = 0.5*h_srt(i+1,kR,j) * min(h_supply_frac_L(kL), h_supply_frac_L(kL-1)) + wt_b = deep_wt_Lu(j)%p(I,k) + h_used_L(kL-1) = h_used_L(kL-1) + (1.0 - wt_b)*hP_Lu(j)%p(I,k) + h_used_L(kL) = h_used_L(kL) + wt_b*hP_Lu(j)%p(I,k) + else + hP_Lu(j)%p(I,k) = 0.5*h_srt(i+1,kR,j) * h_supply_frac_L(kL) + h_used_L(kL) = h_used_L(kL) + hP_Lu(j)%p(I,k) + endif + endif + enddo + + ! The left-over thickness (at least half the layer thickness) is now + ! added to the thicknesses of the importing columns. + do k=1,nPu(I,j) + if (left_set(k)) hP_Lu(j)%p(I,k) = hP_Lu(j)%p(I,k) + & + (h_srt(i,kbs_Lp(k),j) - h_used_L(kbs_Lp(k))) + if (right_set(k)) hP_Ru(j)%p(I,k) = hP_Ru(j)%p(I,k) + & + (h_srt(i+1,kbs_Rp(k),j) - h_used_R(kbs_Rp(k))) + enddo + + endif ; enddo ; enddo ! i- & j- loops over zonal faces. + + do J=js-1,je + k_size = max(max_srt(j)+max_srt(j+1),1) + allocate(deep_wt_Lv(J)%p(isd:ied,k_size)) + allocate(deep_wt_Rv(J)%p(isd:ied,k_size)) + allocate(hP_Lv(J)%p(isd:ied,k_size)) + allocate(hP_Rv(J)%p(isd:ied,k_size)) + allocate(k0a_Lv(J)%p(isd:ied,k_size)) + allocate(k0a_Rv(J)%p(isd:ied,k_size)) + allocate(k0b_Lv(J)%p(isd:ied,k_size)) + allocate(k0b_Rv(J)%p(isd:ied,k_size)) + enddo + +!$OMP parallel do default(none) shared(is,ie,js,je,G,num_srt,rho_srt,k0b_Lv,k0b_Rv, & +!$OMP k0_srt,k0a_Lv,k0a_Rv,deep_wt_Lv,deep_wt_Rv, & +!$OMP h_srt,nkmb,nPv,hP_Lv,hP_Rv) & +!$OMP private(h_demand_L,h_used_L,h_demand_R,h_used_R, & +!$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.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 + do k=1,num_srt(i,j+1) ; h_demand_R(k) = 0.0 ; h_used_R(k) = 0.0 ; enddo + + ! First merge the left and right lists into a single, sorted list. + + ! Discard any layers that are lighter than the lightest in the other + ! column. They can only participate in mixing as the lighter part of a + ! pair of points. + if (rho_srt(i,1,j) < rho_srt(i,1,j+1)) then + kR = 1 + do kL=2,num_srt(i,j) ; if (rho_srt(i,kL,j) >= rho_srt(i,1,j+1)) exit ; enddo + elseif (rho_srt(i,1,j+1) < rho_srt(i,1,j)) then + kL = 1 + do kR=2,num_srt(i,j+1) ; if (rho_srt(i,kR,j+1) >= rho_srt(i,1,j)) exit ; enddo + else + kL = 1 ; kR = 1 + endif + nP = 0 + do ! Loop to accumulate pairs of columns. + if ((kL > num_srt(i,j)) .or. (kR > num_srt(i,j+1))) exit + + if (rho_srt(i,kL,j) > rho_srt(i,kR,j+1)) then + ! The right point is lighter and defines the density for this trio. + nP = nP+1 ; k = nP + rho_pair = rho_srt(i,kR,j+1) + + k0b_Lv(J)%p(i,k) = k0_srt(i,kL,j) ; k0b_Rv(J)%p(i,k) = k0_srt(i,kR,j+1) + k0a_Lv(J)%p(i,k) = k0_srt(i,kL-1,j) ; k0a_Rv(J)%p(i,k) = k0b_Rv(J)%p(i,k) + kbs_Lp(k) = kL ; kbs_Rp(k) = kR + + rho_a = rho_srt(i,kL-1,j) ; rho_b = rho_srt(i,kL,j) + wt_b = 1.0 ; if (abs(rho_a - rho_b) > abs(rho_pair - rho_a)) & + wt_b = (rho_pair - rho_a) / (rho_b - rho_a) + deep_wt_Lv(J)%p(i,k) = wt_b ; deep_wt_Rv(J)%p(i,k) = 1.0 + + h_demand_L(kL) = h_demand_L(kL) + 0.5*h_srt(i,kR,j+1) * wt_b + h_demand_L(kL-1) = h_demand_L(kL-1) + 0.5*h_srt(i,kR,j+1) * (1.0-wt_b) + + kR = kR+1 ; left_set(k) = .false. ; right_set(k) = .true. + elseif (rho_srt(i,kL,j) < rho_srt(i,kR,j+1)) then + ! The left point is lighter and defines the density for this trio. + nP = nP+1 ; k = nP + rho_pair = rho_srt(i,kL,j) + k0b_Lv(J)%p(i,k) = k0_srt(i,kL,j) ; k0b_Rv(J)%p(i,k) = k0_srt(i,kR,j+1) + k0a_Lv(J)%p(i,k) = k0b_Lv(J)%p(i,k) ; k0a_Rv(J)%p(i,k) = k0_srt(i,kR-1,j+1) + + kbs_Lp(k) = kL ; kbs_Rp(k) = kR + + rho_a = rho_srt(i,kR-1,j+1) ; rho_b = rho_srt(i,kR,j+1) + wt_b = 1.0 ; if (abs(rho_a - rho_b) > abs(rho_pair - rho_a)) & + wt_b = (rho_pair - rho_a) / (rho_b - rho_a) + deep_wt_Lv(J)%p(i,k) = 1.0 ; deep_wt_Rv(J)%p(i,k) = wt_b + + h_demand_R(kR) = h_demand_R(kR) + 0.5*h_srt(i,kL,j) * wt_b + h_demand_R(kR-1) = h_demand_R(kR-1) + 0.5*h_srt(i,kL,j) * (1.0-wt_b) + + kL = kL+1 ; left_set(k) = .true. ; right_set(k) = .false. + elseif ((k0_srt(i,kL,j) <= nkmb) .or. (k0_srt(i,kR,j+1) <= nkmb)) then + ! The densities are exactly equal and one layer is above the interior. + nP = nP+1 ; k = nP + k0b_Lv(J)%p(i,k) = k0_srt(i,kL,j) ; k0b_Rv(J)%p(i,k) = k0_srt(i,kR,j+1) + k0a_Lv(J)%p(i,k) = k0b_Lv(J)%p(i,k) ; k0a_Rv(J)%p(i,k) = k0b_Rv(J)%p(i,k) + kbs_Lp(k) = kL ; kbs_Rp(k) = kR + deep_wt_Lv(J)%p(i,k) = 1.0 ; deep_wt_Rv(J)%p(i,k) = 1.0 + + h_demand_L(kL) = h_demand_L(kL) + 0.5*h_srt(i,kR,j+1) + h_demand_R(kR) = h_demand_R(kR) + 0.5*h_srt(i,kL,j) + + kL = kL+1 ; kR = kR+1 ; left_set(k) = .true. ; right_set(k) = .true. + else ! The densities are exactly equal and in the interior. + ! Mixing in this case has already occurred, so accumulate the thickness + ! demanded for that mixing and skip onward. + h_demand_L(kL) = h_demand_L(kL) + 0.5*h_srt(i,kR,j+1) + h_demand_R(kR) = h_demand_R(kR) + 0.5*h_srt(i,kL,j) + + kL = kL+1 ; kR = kR+1 + endif + enddo ! Loop to accumulate pairs of columns. + nPv(i,J) = nP ! This is the number of active pairings. + + ! Determine what fraction of the thickness "demand" can be supplied. + do k=1,num_srt(i,j+1) + h_supply_frac_R(k) = 1.0 + if (h_demand_R(k) > 0.5*h_srt(i,k,j+1)) & + h_supply_frac_R(k) = 0.5*h_srt(i,k,j+1) / h_demand_R(k) + enddo + do k=1,num_srt(i,j) + h_supply_frac_L(k) = 1.0 + if (h_demand_L(k) > 0.5*h_srt(i,k,j)) & + h_supply_frac_L(k) = 0.5*h_srt(i,k,j) / h_demand_L(k) + enddo + + ! Distribute the "exported" thicknesses proportionately. + do k=1,nPv(i,J) + kL = kbs_Lp(k) ; kR = kbs_Rp(k) + hP_Lv(J)%p(i,k) = 0.0 ; hP_Rv(J)%p(i,k) = 0.0 + if (left_set(k)) then ! Add the contributing thicknesses on the right. + if (deep_wt_Rv(J)%p(i,k) < 1.0) then + hP_Rv(J)%p(i,k) = 0.5*h_srt(i,kL,j) * min(h_supply_frac_R(kR), h_supply_frac_R(kR-1)) + wt_b = deep_wt_Rv(J)%p(i,k) + h_used_R(kR-1) = h_used_R(kR-1) + (1.0 - wt_b) * hP_Rv(J)%p(i,k) + h_used_R(kR) = h_used_R(kR) + wt_b * hP_Rv(J)%p(i,k) + else + hP_Rv(J)%p(i,k) = 0.5*h_srt(i,kL,j) * h_supply_frac_R(kR) + h_used_R(kR) = h_used_R(kR) + hP_Rv(J)%p(i,k) + endif + endif + if (right_set(k)) then ! Add the contributing thicknesses on the left. + if (deep_wt_Lv(J)%p(i,k) < 1.0) then + hP_Lv(J)%p(i,k) = 0.5*h_srt(i,kR,j+1) * min(h_supply_frac_L(kL), h_supply_frac_L(kL-1)) + wt_b = deep_wt_Lv(J)%p(i,k) + h_used_L(kL-1) = h_used_L(kL-1) + (1.0 - wt_b) * hP_Lv(J)%p(i,k) + h_used_L(kL) = h_used_L(kL) + wt_b * hP_Lv(J)%p(i,k) + else + hP_Lv(J)%p(i,k) = 0.5*h_srt(i,kR,j+1) * h_supply_frac_L(kL) + h_used_L(kL) = h_used_L(kL) + hP_Lv(J)%p(i,k) + endif + endif + enddo + + ! The left-over thickness (at least half the layer thickness) is now + ! added to the thicknesses of the importing columns. + do k=1,nPv(i,J) + if (left_set(k)) hP_Lv(J)%p(i,k) = hP_Lv(J)%p(i,k) + & + (h_srt(i,kbs_Lp(k),j) - h_used_L(kbs_Lp(k))) + if (right_set(k)) hP_Rv(J)%p(i,k) = hP_Rv(J)%p(i,k) + & + (h_srt(i,kbs_Rp(k),j+1) - h_used_R(kbs_Rp(k))) + enddo + + + endif ; enddo ; enddo ! i- & j- loops over meridional faces. + +! The tracer-specific calculations start here. + + ! Zero out tracer tendencies. + do k=1,PEmax_kRho ; do j=js-1,je+1 ; do i=is-1,ie+1 + tr_flux_conv(i,j,k) = 0.0 + enddo ; enddo ; enddo + + do itt=1,max_itt + + if (itt > 1) then ! The halos have already been filled if itt==1. + call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) + endif + + do m=1,ntr +!$OMP parallel do default(none) shared(is,ie,js,je,G,Tr,nkmb,nPu,m,max_kRho,nz,h,h_exclude, & +!$OMP k0b_Lu,k0b_Ru,deep_wt_Lu,k0a_Lu,deep_wt_Ru,k0a_Ru, & +!$OMP hP_Lu,hP_Ru,I_maxitt,khdt_epi_x,tr_flux_conv,Idt) & +!$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.0) then + ! Determine the fluxes through the zonal faces. + + ! Find the acceptable range of tracer concentration around this face. + if (nPu(I,j) >= 1) then + Tr_min_face = min(Tr(m)%t(i,j,1), Tr(m)%t(i+1,j,1)) + Tr_max_face = max(Tr(m)%t(i,j,1), Tr(m)%t(i+1,j,1)) + do k=2,nkmb + Tr_min_face = min(Tr_min_face, Tr(m)%t(i,j,k), Tr(m)%t(i+1,j,k)) + Tr_max_face = max(Tr_max_face, Tr(m)%t(i,j,k), Tr(m)%t(i+1,j,k)) + enddo + + ! Include the next two layers denser than the densest buffer layer. + kLa = nkmb+1 ; if (max_kRho(i,j) < nz+1) kLa = max_kRho(i,j) + kLb = kLa ; if (max_kRho(i,j) < nz) kLb = max_kRho(i,j)+1 + kRa = nkmb+1 ; if (max_kRho(i+1,j) < nz+1) kRa = max_kRho(i+1,j) + kRb = kRa ; if (max_kRho(i+1,j) < nz) kRb = max_kRho(i+1,j)+1 + Tr_La = Tr_min_face ; Tr_Lb = Tr_La ; Tr_Ra = Tr_La ; Tr_Rb = Tr_La + if (h(i,j,kLa) > h_exclude) Tr_La = Tr(m)%t(i,j,kLa) + if (h(i,j,kLb) > h_exclude) Tr_La = Tr(m)%t(i,j,kLb) + if (h(i+1,j,kRa) > h_exclude) Tr_Ra = Tr(m)%t(i+1,j,kRa) + if (h(i+1,j,kRb) > h_exclude) Tr_Rb = Tr(m)%t(i+1,j,kRb) + Tr_min_face = min(Tr_min_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb) + Tr_max_face = max(Tr_max_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb) + + ! Include all points in diffusive pairings at this face. + do k=1,nPu(I,j) + Tr_Lb = Tr(m)%t(i,j,k0b_Lu(j)%p(I,k)) + Tr_Rb = Tr(m)%t(i+1,j,k0b_Ru(j)%p(I,k)) + Tr_La = Tr_Lb ; Tr_Ra = Tr_Rb + if (deep_wt_Lu(j)%p(I,k) < 1.0) Tr_La = Tr(m)%t(i,j,k0a_Lu(j)%p(I,k)) + if (deep_wt_Ru(j)%p(I,k) < 1.0) Tr_Ra = Tr(m)%t(i+1,j,k0a_Ru(j)%p(I,k)) + Tr_min_face = min(Tr_min_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb) + Tr_max_face = max(Tr_max_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb) + enddo + endif + + do k=1,nPu(I,j) + kLb = k0b_Lu(j)%p(I,k) ; Tr_Lb = Tr(m)%t(i,j,kLb) ; Tr_av_L = Tr_Lb + if (deep_wt_Lu(j)%p(I,k) < 1.0) then + kLa = k0a_Lu(j)%p(I,k) ; Tr_La = Tr(m)%t(i,j,kLa) + wt_b = deep_wt_Lu(j)%p(I,k) + Tr_av_L = wt_b*Tr_Lb + (1.0-wt_b)*Tr_La + endif + + kRb = k0b_Ru(j)%p(I,k) ; Tr_Rb = Tr(m)%t(i+1,j,kRb) ; Tr_av_R = Tr_Rb + if (deep_wt_Ru(j)%p(I,k) < 1.0) then + kRa = k0a_Ru(j)%p(I,k) ; Tr_Ra = Tr(m)%t(i+1,j,kRa) + wt_b = deep_wt_Ru(j)%p(I,k) + Tr_av_R = wt_b*Tr_Rb + (1.0-wt_b)*Tr_Ra + endif + + h_L = hP_Lu(j)%p(I,k) ; h_R = hP_Ru(j)%p(I,k) + Tr_flux = I_maxitt * khdt_epi_x(I,j) * (Tr_av_L - Tr_av_R) * & + ((2.0 * h_L * h_R) / (h_L + h_R)) + + + if (deep_wt_Lu(j)%p(I,k) >= 1.0) then + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux + else + Tr_adj_vert = 0.0 + wt_b = deep_wt_Lu(j)%p(I,k) ; wt_a = 1.0 - wt_b + vol = hP_Lu(j)%p(I,k) * G%areaT(i,j) + + ! Ensure that the tracer flux does not drive the tracer values + ! outside of the range Tr_min_face <= Tr <= Tr_max_face, or if it + ! does that the concentration in both contributing pieces exceed + ! this range equally. With down-gradient fluxes and the initial tracer + ! concentrations determining the valid range, the latter condition + ! only enters for large values of the effective diffusive CFL number. + if (Tr_flux > 0.0) then + if (Tr_La < Tr_Lb) then ; if (vol*(Tr_La-Tr_min_face) < Tr_flux) & + Tr_adj_vert = -wt_a * min(Tr_flux - vol * (Tr_La-Tr_min_face), & + (vol*wt_b) * (Tr_Lb - Tr_La)) + else ; if (vol*(Tr_Lb-Tr_min_face) < Tr_flux) & + Tr_adj_vert = wt_b * min(Tr_flux - vol * (Tr_Lb-Tr_min_face), & + (vol*wt_a) * (Tr_La - Tr_Lb)) + endif + elseif (Tr_flux < 0.0) then + if (Tr_La > Tr_Lb) then ; if (vol * (Tr_max_face-Tr_La) < -Tr_flux) & + Tr_adj_vert = wt_a * min(-Tr_flux - vol * (Tr_max_face-Tr_La), & + (vol*wt_b) * (Tr_La - Tr_Lb)) + else ; if (vol*(Tr_max_face-Tr_Lb) < -Tr_flux) & + Tr_adj_vert = -wt_b * min(-Tr_flux - vol * (Tr_max_face-Tr_Lb), & + (vol*wt_a)*(Tr_Lb - Tr_La)) + endif + endif + + tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux + Tr_adj_vert) + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux - Tr_adj_vert) + endif + + if (deep_wt_Ru(j)%p(I,k) >= 1.0) then + tr_flux_conv(i+1,j,kRb) = tr_flux_conv(i+1,j,kRb) + Tr_flux + else + Tr_adj_vert = 0.0 + wt_b = deep_wt_Ru(j)%p(I,k) ; wt_a = 1.0 - wt_b + vol = hP_Ru(j)%p(I,k) * G%areaT(i+1,j) + + ! Ensure that the tracer flux does not drive the tracer values + ! outside of the range Tr_min_face <= Tr <= Tr_max_face, or if it + ! does that the concentration in both contributing pieces exceed + ! this range equally. With down-gradient fluxes and the initial tracer + ! concentrations determining the valid range, the latter condition + ! only enters for large values of the effective diffusive CFL number. + if (Tr_flux < 0.0) then + if (Tr_Ra < Tr_Rb) then ; if (vol * (Tr_Ra-Tr_min_face) < -Tr_flux) & + Tr_adj_vert = -wt_a * min(-Tr_flux - vol * (Tr_Ra-Tr_min_face), & + (vol*wt_b) * (Tr_Rb - Tr_Ra)) + else ; if (vol*(Tr_Rb-Tr_min_face) < (-Tr_flux)) & + Tr_adj_vert = wt_b * min(-Tr_flux - vol * (Tr_Rb-Tr_min_face), & + (vol*wt_a) * (Tr_Ra - Tr_Rb)) + endif + elseif (Tr_flux > 0.0) then + if (Tr_Ra > Tr_Rb) then ; if (vol * (Tr_max_face-Tr_Ra) < Tr_flux) & + Tr_adj_vert = wt_a * min(Tr_flux - vol * (Tr_max_face-Tr_Ra), & + (vol*wt_b) * (Tr_Ra - Tr_Rb)) + else ; if (vol*(Tr_max_face-Tr_Rb) < Tr_flux) & + Tr_adj_vert = -wt_b * min(Tr_flux - vol * (Tr_max_face-Tr_Rb), & + (vol*wt_a)*(Tr_Rb - Tr_Ra)) + endif + endif + + tr_flux_conv(i+1,j,kRa) = tr_flux_conv(i+1,j,kRa) + & + (wt_a*Tr_flux - Tr_adj_vert) + tr_flux_conv(i+1,j,kRb) = tr_flux_conv(i+1,j,kRb) + & + (wt_b*Tr_flux + Tr_adj_vert) + endif + if (associated(Tr(m)%df2d_x)) & + Tr(m)%df2d_x(I,j) = Tr(m)%df2d_x(I,j) + Tr_flux * Idt + enddo ! Loop over pairings at faces. + endif ; enddo ; enddo ! i- & j- loops over zonal faces. + +!$OMP parallel do default(none) shared(is,ie,js,je,G,Tr,nkmb,nPv,m,max_kRho,nz,h,h_exclude, & +!$OMP k0b_Lv,k0b_Rv,deep_wt_Lv,k0a_Lv,deep_wt_Rv,k0a_Rv, & +!$OMP hP_Lv,hP_Rv,I_maxitt,khdt_epi_y,Tr_flux_3d, & +!$OMP Tr_adj_vert_L,Tr_adj_vert_R,Idt) & +!$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.0) then + ! Determine the fluxes through the meridional faces. + + ! Find the acceptable range of tracer concentration around this face. + if (nPv(i,J) >= 1) then + Tr_min_face = min(Tr(m)%t(i,j,1), Tr(m)%t(i,j+1,1)) + Tr_max_face = max(Tr(m)%t(i,j,1), Tr(m)%t(i,j+1,1)) + do k=2,nkmb + Tr_min_face = min(Tr_min_face, Tr(m)%t(i,j,k), Tr(m)%t(i,j+1,k)) + Tr_max_face = max(Tr_max_face, Tr(m)%t(i,j,k), Tr(m)%t(i,j+1,k)) + enddo + + ! Include the next two layers denser than the densest buffer layer. + kLa = nkmb+1 ; if (max_kRho(i,j) < nz+1) kLa = max_kRho(i,j) + kLb = kLa ; if (max_kRho(i,j) < nz) kLb = max_kRho(i,j)+1 + kRa = nkmb+1 ; if (max_kRho(i,j+1) < nz+1) kRa = max_kRho(i,j+1) + kRb = kRa ; if (max_kRho(i,j+1) < nz) kRb = max_kRho(i,j+1)+1 + Tr_La = Tr_min_face ; Tr_Lb = Tr_La ; Tr_Ra = Tr_La ; Tr_Rb = Tr_La + if (h(i,j,kLa) > h_exclude) Tr_La = Tr(m)%t(i,j,kLa) + if (h(i,j,kLb) > h_exclude) Tr_La = Tr(m)%t(i,j,kLb) + if (h(i,j+1,kRa) > h_exclude) Tr_Ra = Tr(m)%t(i,j+1,kRa) + if (h(i,j+1,kRb) > h_exclude) Tr_Rb = Tr(m)%t(i,j+1,kRb) + Tr_min_face = min(Tr_min_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb) + Tr_max_face = max(Tr_max_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb) + + ! Include all points in diffusive pairings at this face. + do k=1,nPv(i,J) + Tr_Lb = Tr(m)%t(i,j,k0b_Lv(J)%p(i,k)) ; Tr_Rb = Tr(m)%t(i,j+1,k0b_Rv(J)%p(i,k)) + Tr_La = Tr_Lb ; Tr_Ra = Tr_Rb + if (deep_wt_Lv(J)%p(i,k) < 1.0) Tr_La = Tr(m)%t(i,j,k0a_Lv(J)%p(i,k)) + if (deep_wt_Rv(J)%p(i,k) < 1.0) Tr_Ra = Tr(m)%t(i,j+1,k0a_Rv(J)%p(i,k)) + Tr_min_face = min(Tr_min_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb) + Tr_max_face = max(Tr_max_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb) + enddo + endif + + do k=1,nPv(i,J) + kLb = k0b_Lv(J)%p(i,k) ; Tr_Lb = Tr(m)%t(i,j,kLb) ; Tr_av_L = Tr_Lb + if (deep_wt_Lv(J)%p(i,k) < 1.0) then + kLa = k0a_Lv(J)%p(i,k) ; Tr_La = Tr(m)%t(i,j,kLa) + wt_b = deep_wt_Lv(J)%p(i,k) + Tr_av_L = wt_b * Tr_Lb + (1.0-wt_b) * Tr_La + endif + + kRb = k0b_Rv(J)%p(i,k) ; Tr_Rb = Tr(m)%t(i,j+1,kRb) ; Tr_av_R = Tr_Rb + if (deep_wt_Rv(J)%p(i,k) < 1.0) then + kRa = k0a_Rv(J)%p(i,k) ; Tr_Ra = Tr(m)%t(i,j+1,kRa) + wt_b = deep_wt_Rv(J)%p(i,k) + Tr_av_R = wt_b * Tr_Rb + (1.0-wt_b) * Tr_Ra + endif + + h_L = hP_Lv(J)%p(i,k) ; h_R = hP_Rv(J)%p(i,k) + Tr_flux = I_maxitt * ((2.0 * h_L * h_R) / (h_L + h_R)) * & + khdt_epi_y(i,J) * (Tr_av_L - Tr_av_R) + Tr_flux_3d(i,J,k) = Tr_flux + + if (deep_wt_Lv(J)%p(i,k) < 1.0) then + Tr_adj_vert = 0.0 + wt_b = deep_wt_Lv(J)%p(i,k) ; wt_a = 1.0 - wt_b + vol = hP_Lv(J)%p(i,k) * G%areaT(i,j) + + ! Ensure that the tracer flux does not drive the tracer values + ! outside of the range Tr_min_face <= Tr <= Tr_max_face. + if (Tr_flux > 0.0) then + if (Tr_La < Tr_Lb) then ; if (vol * (Tr_La-Tr_min_face) < Tr_flux) & + Tr_adj_vert = -wt_a * min(Tr_flux - vol * (Tr_La-Tr_min_face), & + (vol*wt_b) * (Tr_Lb - Tr_La)) + else ; if (vol*(Tr_Lb-Tr_min_face) < Tr_flux) & + Tr_adj_vert = wt_b * min(Tr_flux - vol * (Tr_Lb-Tr_min_face), & + (vol*wt_a) * (Tr_La - Tr_Lb)) + endif + elseif (Tr_flux < 0.0) then + if (Tr_La > Tr_Lb) then ; if (vol * (Tr_max_face-Tr_La) < -Tr_flux) & + Tr_adj_vert = wt_a * min(-Tr_flux - vol * (Tr_max_face-Tr_La), & + (vol*wt_b) * (Tr_La - Tr_Lb)) + else ; if (vol*(Tr_max_face-Tr_Lb) < -Tr_flux) & + Tr_adj_vert = -wt_b * min(-Tr_flux - vol * (Tr_max_face-Tr_Lb), & + (vol*wt_a)*(Tr_Lb - Tr_La)) + endif + endif + Tr_adj_vert_L(i,J,k) = Tr_adj_vert + endif + + if (deep_wt_Rv(J)%p(i,k) < 1.0) then + Tr_adj_vert = 0.0 + wt_b = deep_wt_Rv(J)%p(i,k) ; wt_a = 1.0 - wt_b + vol = hP_Rv(J)%p(i,k) * G%areaT(i,j+1) + + ! Ensure that the tracer flux does not drive the tracer values + ! outside of the range Tr_min_face <= Tr <= Tr_max_face. + if (Tr_flux < 0.0) then + if (Tr_Ra < Tr_Rb) then ; if (vol * (Tr_Ra-Tr_min_face) < -Tr_flux) & + Tr_adj_vert = -wt_a * min(-Tr_flux - vol * (Tr_Ra-Tr_min_face), & + (vol*wt_b) * (Tr_Rb - Tr_Ra)) + else ; if (vol*(Tr_Rb-Tr_min_face) < (-Tr_flux)) & + Tr_adj_vert = wt_b * min(-Tr_flux - vol * (Tr_Rb-Tr_min_face), & + (vol*wt_a) * (Tr_Ra - Tr_Rb)) + endif + elseif (Tr_flux > 0.0) then + if (Tr_Ra > Tr_Rb) then ; if (vol * (Tr_max_face-Tr_Ra) < Tr_flux) & + Tr_adj_vert = wt_a * min(Tr_flux - vol * (Tr_max_face-Tr_Ra), & + (vol*wt_b) * (Tr_Ra - Tr_Rb)) + else ; if (vol*(Tr_max_face-Tr_Rb) < Tr_flux) & + Tr_adj_vert = -wt_b * min(Tr_flux - vol * (Tr_max_face-Tr_Rb), & + (vol*wt_a)*(Tr_Rb - Tr_Ra)) + endif + endif + Tr_adj_vert_R(i,J,k) = Tr_adj_vert + endif + if (associated(Tr(m)%df2d_y)) & + Tr(m)%df2d_y(i,J) = Tr(m)%df2d_y(i,J) + Tr_flux * Idt + enddo ! Loop over pairings at faces. + endif ; enddo ; enddo ! i- & j- loops over meridional faces. +!$OMP parallel do default(none) shared(is,ie,js,je,G,nPv,k0b_Lv,k0b_Rv,deep_wt_Lv, & +!$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.0) then + ! The non-stride-1 loop order here is to facilitate openMP threading. However, it might be + ! suboptimal when openMP threading is not used, at which point it might be better to fuse + ! these loope with those that precede it and thereby eliminate the need for three 3-d arrays. + 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 + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux_3d(i,J,k) + else + kLa = k0a_Lv(J)%p(i,k) + wt_b = deep_wt_Lv(J)%p(i,k) ; wt_a = 1.0 - wt_b + tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux_3d(i,J,k) + Tr_adj_vert_L(i,J,k)) + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux_3d(i,J,k) - Tr_adj_vert_L(i,J,k)) + endif + if (deep_wt_Rv(J)%p(i,k) >= 1.0) then + tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + Tr_flux_3d(i,J,k) + else + kRa = k0a_Rv(J)%p(i,k) + wt_b = deep_wt_Rv(J)%p(i,k) ; wt_a = 1.0 - wt_b + tr_flux_conv(i,j+1,kRa) = tr_flux_conv(i,j+1,kRa) + & + (wt_a*Tr_flux_3d(i,J,k) - Tr_adj_vert_R(i,J,k)) + tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + & + (wt_b*Tr_flux_3d(i,J,k) + Tr_adj_vert_R(i,J,k)) + endif + enddo + endif ; enddo ; enddo + !$OMP parallel do default(shared) + do k=1,PEmax_kRho ; do j=js,je ; do i=is,ie + 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 + endif + enddo ; enddo ; enddo + + ! Do user controlled underflow of the tracer concentrations. + if (Tr(m)%conc_underflow > 0.0) then + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do i=is,ie + if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif + + enddo ! Loop over tracers + enddo ! Loop over iterations + + do j=js,je + deallocate(deep_wt_Lu(j)%p) ; deallocate(deep_wt_Ru(j)%p) + deallocate(Hp_Lu(j)%p) ; deallocate(Hp_Ru(j)%p) + deallocate(k0a_Lu(j)%p) ; deallocate(k0a_Ru(j)%p) + deallocate(k0b_Lu(j)%p) ; deallocate(k0b_Ru(j)%p) + enddo + + do J=js-1,je + deallocate(deep_wt_Lv(J)%p) ; deallocate(deep_wt_Rv(J)%p) + deallocate(Hp_Lv(J)%p) ; deallocate(Hp_Rv(J)%p) + deallocate(k0a_Lv(J)%p) ; deallocate(k0a_Rv(J)%p) + deallocate(k0b_Lv(J)%p) ; deallocate(k0b_Rv(J)%p) + enddo + +end subroutine tracer_epipycnal_ML_diff + + +!> Initialize lateral tracer diffusion module +subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic_CSp, CS) + type(time_type), target, intent(in) :: Time !< current model time + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diag_ctrl), target, intent(inout) :: diag !< diagnostic control + type(EOS_type), target, intent(in) :: EOS !< Equation of state CS + type(diabatic_CS), pointer, intent(in) :: diabatic_CSp !< Equation of state CS + type(param_file_type), intent(in) :: param_file !< parameter file + type(tracer_hor_diff_CS), pointer :: CS !< horz diffusion control structure + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_tracer_hor_diff" ! This module's name. + + if (associated(CS)) then + call MOM_error(WARNING, "tracer_hor_diff_init called with associated control structure.") + return + endif + allocate(CS) + + CS%diag => diag + CS%show_call_tree = callTree_showQuery() + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "KHTR", CS%KhTr, & + "The background along-isopycnal tracer diffusivity.", & + units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of the tracer diffusivity.",& + default=.false.) + call get_param(param_file, mdl, "KHTR_SLOPE_CFF", CS%KhTr_Slope_Cff, & + "The scaling coefficient for along-isopycnal tracer "//& + "diffusivity using a shear-based (Visbeck-like) "//& + "parameterization. A non-zero value enables this param.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "KHTR_MIN", CS%KhTr_Min, & + "The minimum along-isopycnal tracer diffusivity.", & + units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KHTR_MAX", CS%KhTr_Max, & + "The maximum along-isopycnal tracer diffusivity.", & + units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KHTR_PASSIVITY_COEFF", CS%KhTr_passivity_coeff, & + "The coefficient that scales deformation radius over "//& + "grid-spacing in passivity, where passivity is the ratio "//& + "between along isopycnal mixing of tracers to thickness mixing. "//& + "A non-zero value enables this parameterization.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "KHTR_PASSIVITY_MIN", CS%KhTr_passivity_min, & + "The minimum passivity which is the ratio between "//& + "along isopycnal mixing of tracers to thickness mixing.", & + units="nondim", default=0.5) + call get_param(param_file, mdl, "DIFFUSE_ML_TO_INTERIOR", CS%Diffuse_ML_interior, & + "If true, enable epipycnal mixing between the surface "//& + "boundary layer and the interior.", default=.false.) + call get_param(param_file, mdl, "CHECK_DIFFUSIVE_CFL", CS%check_diffusive_CFL, & + "If true, use enough iterations the diffusion to ensure "//& + "that the diffusive equivalent of the CFL limit is not "//& + "violated. If false, always use the greater of 1 or "//& + "MAX_TR_DIFFUSION_CFL iteration.", default=.false.) + call get_param(param_file, mdl, "MAX_TR_DIFFUSION_CFL", CS%max_diff_CFL, & + "If positive, locally limit the along-isopycnal tracer "//& + "diffusivity to keep the diffusive CFL locally at or "//& + "below this value. The number of diffusive iterations "//& + "is often this value or the next greater integer.", & + units="nondim", default=-1.0) + 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.) + CS%ML_KhTR_scale = 1.0 + if (CS%Diffuse_ML_interior) then + call get_param(param_file, mdl, "ML_KHTR_SCALE", CS%ML_KhTR_scale, & + "With Diffuse_ML_interior, the ratio of the truly "//& + "horizontal diffusivity in the mixed layer to the "//& + "epipycnal diffusivity. The valid range is 0 to 1.", & + units="nondim", default=1.0) + endif + + CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, & + diabatic_CSp, CS%neutral_diffusion_CSp ) + if (CS%use_neutral_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & + "USE_NEUTRAL_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") + CS%use_hor_bnd_diffusion = hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diabatic_CSp, & + CS%hor_bnd_diffusion_CSp) + if (CS%use_hor_bnd_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & + "USE_HORIZONTAL_BOUNDARY_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") + + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) + + id_clock_diffuse = cpu_clock_id('(Ocean diffuse tracer)', grain=CLOCK_MODULE) + id_clock_epimix = cpu_clock_id('(Ocean epipycnal diffuse tracer)',grain=CLOCK_MODULE) + id_clock_pass = cpu_clock_id('(Ocean tracer halo updates)', grain=CLOCK_ROUTINE) + id_clock_sync = cpu_clock_id('(Ocean tracer global synch)', grain=CLOCK_ROUTINE) + + CS%id_KhTr_u = -1 + CS%id_KhTr_v = -1 + CS%id_KhTr_h = -1 + CS%id_CFL = -1 + + CS%id_KhTr_u = register_diag_field('ocean_model', 'KHTR_u', diag%axesCui, Time, & + 'Epipycnal tracer diffusivity at zonal faces of tracer cell', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_KhTr_v = register_diag_field('ocean_model', 'KHTR_v', diag%axesCvi, Time, & + 'Epipycnal tracer diffusivity at meridional faces of tracer cell', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_KhTr_h = register_diag_field('ocean_model', 'KHTR_h', diag%axesTi, Time, & + 'Epipycnal tracer diffusivity at tracer cell center', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T, & + cmor_field_name='diftrelo', & + cmor_standard_name= 'ocean_tracer_epineutral_laplacian_diffusivity', & + cmor_long_name = 'Ocean Tracer Epineutral Laplacian Diffusivity') + + CS%id_khdt_x = register_diag_field('ocean_model', 'KHDT_x', diag%axesCu1, Time, & + 'Epipycnal tracer diffusivity operator at zonal faces of tracer cell', 'm2', conversion=US%L_to_m**2) + CS%id_khdt_y = register_diag_field('ocean_model', 'KHDT_y', diag%axesCv1, Time, & + 'Epipycnal tracer diffusivity operator at meridional faces of tracer cell', 'm2', conversion=US%L_to_m**2) + if (CS%check_diffusive_CFL) then + CS%id_CFL = register_diag_field('ocean_model', 'CFL_lateral_diff', diag%axesT1, Time,& + 'Grid CFL number for lateral/neutral tracer diffusion', 'nondim') + endif + + +end subroutine tracer_hor_diff_init + +subroutine tracer_hor_diff_end(CS) + type(tracer_hor_diff_CS), pointer :: CS !< module control structure + + call neutral_diffusion_end(CS%neutral_diffusion_CSp) + call hor_bnd_diffusion_end(CS%hor_bnd_diffusion_CSp) + if (associated(CS)) deallocate(CS) + +end subroutine tracer_hor_diff_end + + +!> \namespace mom_tracer_hor_diff +!! +!! \section section_intro Introduction to the module +!! +!! This module contains subroutines that handle horizontal +!! diffusion (i.e., isoneutral or along layer) of tracers. +!! +!! Each of the tracers are subject to Fickian along-coordinate +!! diffusion if Khtr is defined and positive. The tracer diffusion +!! can use a suitable number of iterations to guarantee stability +!! with an arbitrarily large time step. + +end module MOM_tracer_hor_diff diff --git a/tracer/MOM_tracer_registry.F90 b/tracer/MOM_tracer_registry.F90 new file mode 100644 index 0000000000..c01419f3f8 --- /dev/null +++ b/tracer/MOM_tracer_registry.F90 @@ -0,0 +1,890 @@ +!> This module contains subroutines that handle registration of tracers +!! and related subroutines. The primary subroutine, register_tracer, is +!! called to indicate the tracers advected and diffused. +!! It also makes public the types defined in MOM_tracer_types. +module MOM_tracer_registry + +! This file is part of MOM6. See LICENSE.md for the license. + +! use MOM_diag_mediator, only : diag_ctrl +use MOM_coms, only : reproducing_sum +use MOM_debugging, only : hchksum +use MOM_diag_mediator, only : diag_ctrl, register_diag_field, post_data, safe_alloc_ptr +use MOM_diag_mediator, only : diag_grid_storage +use MOM_diag_mediator, only : diag_copy_storage_to_diag, diag_save_grids, diag_restore_grids +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_hor_index, only : hor_index_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : vardesc, query_vardesc, cmor_long_std +use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_string_functions, only : lowercase +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_types, only : tracer_type, tracer_registry_type + +implicit none ; private + +#include + +public register_tracer +public MOM_tracer_chksum, MOM_tracer_chkinv +public register_tracer_diagnostics, post_tracer_diagnostics_at_sync, post_tracer_transport_diagnostics +public preALE_tracer_diagnostics, postALE_tracer_diagnostics +public tracer_registry_init, lock_tracer_registry, tracer_registry_end +public tracer_name_lookup +public tracer_type, tracer_registry_type + +!> Write out checksums for registered tracers +interface MOM_tracer_chksum + module procedure tracer_array_chksum, tracer_Reg_chksum +end interface MOM_tracer_chksum + +!> Calculate and print the global inventories of registered tracers +interface MOM_tracer_chkinv + module procedure tracer_array_chkinv, tracer_Reg_chkinv +end interface MOM_tracer_chkinv + +contains + +!> This subroutine registers a tracer to be advected and laterally diffused. +subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, units, & + cmor_name, cmor_units, cmor_longname, net_surfflux_name, NLT_budget_name, & + net_surfflux_longname, tr_desc, OBC_inflow, OBC_in_u, OBC_in_v, ad_x, ad_y, & + df_x, df_y, ad_2d_x, ad_2d_y, df_2d_x, df_2d_y, advection_xy, registry_diags, & + conc_scale, flux_nameroot, flux_longname, flux_units, flux_scale, & + convergence_units, convergence_scale, cmor_tendprefix, diag_form, & + restart_CS, mandatory, underflow_conc, Tr_out) + type(hor_index_type), intent(in) :: HI !< horizontal index type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + target :: tr_ptr !< target or pointer to the tracer array [CU ~> conc] + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + character(len=*), optional, intent(in) :: name !< Short tracer name + character(len=*), optional, intent(in) :: longname !< The long tracer name + character(len=*), optional, intent(in) :: units !< The units of this tracer + character(len=*), optional, intent(in) :: cmor_name !< CMOR name + character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable + character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name + character(len=*), optional, intent(in) :: net_surfflux_name !< Name for net_surfflux diag + character(len=*), optional, intent(in) :: NLT_budget_name !< Name for NLT_budget diag + character(len=*), optional, intent(in) :: net_surfflux_longname !< Long name for net_surfflux diag + type(vardesc), optional, intent(in) :: tr_desc !< A structure with metadata about the tracer + + real, optional, intent(in) :: OBC_inflow !< the tracer for all inflows via OBC for which OBC_in_u + !! or OBC_in_v are not specified (units of tracer CONC) + real, dimension(:,:,:), optional, pointer :: OBC_in_u !< tracer at inflows through u-faces of + !! tracer cells (units of tracer CONC) + real, dimension(:,:,:), optional, pointer :: OBC_in_v !< tracer at inflows through v-faces of + !! tracer cells (units of tracer CONC) + + ! The following are probably not necessary if registry_diags is present and true. + real, dimension(:,:,:), optional, pointer :: ad_x !< diagnostic x-advective flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), optional, pointer :: ad_y !< diagnostic y-advective flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), optional, pointer :: df_x !< diagnostic x-diffusive flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), optional, pointer :: df_y !< diagnostic y-diffusive flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), optional, pointer :: ad_2d_x !< vert sum of diagnostic x-advect flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), optional, pointer :: ad_2d_y !< vert sum of diagnostic y-advect flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), optional, pointer :: df_2d_x !< vert sum of diagnostic x-diffuse flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), optional, pointer :: df_2d_y !< vert sum of diagnostic y-diffuse flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + + real, dimension(:,:,:), optional, pointer :: advection_xy !< convergence of lateral advective tracer fluxes + logical, optional, intent(in) :: registry_diags !< If present and true, use the registry for + !! the diagnostics of this tracer. + real, optional, intent(in) :: conc_scale !< A scaling factor used to convert the concentration + !! of this tracer to its desired units. + character(len=*), optional, intent(in) :: flux_nameroot !< Short tracer name snippet used construct the + !! names of flux diagnostics. + character(len=*), optional, intent(in) :: flux_longname !< A word or phrase used construct the long + !! names of flux diagnostics. + character(len=*), optional, intent(in) :: flux_units !< The units for the fluxes of this tracer. + real, optional, intent(in) :: flux_scale !< A scaling factor used to convert the fluxes + !! of this tracer to its desired units. + character(len=*), optional, intent(in) :: convergence_units !< The units for the flux convergence of + !! this tracer. + real, optional, intent(in) :: convergence_scale !< A scaling factor used to convert the flux + !! convergence of this tracer to its desired units. + character(len=*), optional, intent(in) :: cmor_tendprefix !< The CMOR name for the layer-integrated + !! tendencies of this tracer. + integer, optional, intent(in) :: diag_form !< An integer (1 or 2, 1 by default) indicating the + !! character string template to use in + !! labeling diagnostics + type(MOM_restart_CS), optional, intent(inout) :: restart_CS !< MOM restart control struct + logical, optional, intent(in) :: mandatory !< If true, this tracer must be read + !! from a restart file. + real, optional, intent(in) :: underflow_conc !< A tiny concentration, below which the tracer + !! concentration underflows to 0 [CU ~> conc]. + type(tracer_type), optional, pointer :: Tr_out !< If present, returns pointer into registry + + logical :: mand + type(tracer_type), pointer :: Tr=>NULL() + character(len=256) :: mesg ! Message for error messages. + + if (.not. associated(Reg)) call tracer_registry_init(param_file, Reg) + + if (Reg%ntr>=MAX_FIELDS_) then + write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for & + &all the tracers being registered via register_tracer.")') Reg%ntr+1 + call MOM_error(FATAL,"MOM register_tracer: "//mesg) + endif + Reg%ntr = Reg%ntr + 1 + + Tr => Reg%Tr(Reg%ntr) + if (present(Tr_out)) Tr_out => Reg%Tr(Reg%ntr) + + if (present(name)) then + Tr%name = name + Tr%longname = name ; if (present(longname)) Tr%longname = longname + Tr%units = "Conc" ; if (present(units)) Tr%units = units + + Tr%cmor_name = "" + if (present(cmor_name)) Tr%cmor_name = cmor_name + + Tr%cmor_units = Tr%units + if (present(cmor_units)) Tr%cmor_units = cmor_units + + Tr%cmor_longname = "" + if (present(cmor_longname)) Tr%cmor_longname = cmor_longname + + if (present(tr_desc)) call MOM_error(WARNING, "MOM register_tracer: "//& + "It is a bad idea to use both name and tr_desc when registring "//trim(name)) + elseif (present(tr_desc)) then + call query_vardesc(tr_desc, name=Tr%name, units=Tr%units, & + longname=Tr%longname, cmor_field_name=Tr%cmor_name, & + cmor_longname=Tr%cmor_longname, caller="register_tracer") + Tr%cmor_units = Tr%units + else + call MOM_error(FATAL,"MOM register_tracer: Either name or "//& + "tr_desc must be present when registering a tracer.") + endif + + if (Reg%locked) call MOM_error(FATAL, & + "MOM register_tracer was called for variable "//trim(Tr%name)//& + " with a locked tracer registry.") + + Tr%conc_scale = 1.0 + if (present(conc_scale)) Tr%conc_scale = conc_scale + + Tr%conc_underflow = 0.0 + if (present(underflow_conc)) Tr%conc_underflow = underflow_conc + + Tr%flux_nameroot = Tr%name + if (present(flux_nameroot)) then + if (len_trim(flux_nameroot) > 0) Tr%flux_nameroot = flux_nameroot + endif + + Tr%flux_longname = Tr%longname + if (present(flux_longname)) then + if (len_trim(flux_longname) > 0) Tr%flux_longname = flux_longname + endif + + Tr%net_surfflux_name = "KPP_net"//trim(Tr%name) + if (present(net_surfflux_name)) then + Tr%net_surfflux_name = net_surfflux_name + endif + + Tr%NLT_budget_name = 'KPP_NLT_'//trim(Tr%flux_nameroot)//'_budget' + if (present(NLT_budget_name)) then + Tr%NLT_budget_name = NLT_budget_name + endif + + Tr%net_surfflux_longname = 'Effective net surface '//trim(lowercase(Tr%flux_longname))//& + ' flux, as used by [CVMix] KPP' + if (present(net_surfflux_longname)) then + Tr%net_surfflux_longname = net_surfflux_longname + endif + + Tr%flux_units = "" + if (present(flux_units)) Tr%flux_units = flux_units + + Tr%flux_scale = GV%H_to_MKS*Tr%conc_scale + if (present(flux_scale)) Tr%flux_scale = flux_scale + + Tr%conv_units = "" + if (present(convergence_units)) Tr%conv_units = convergence_units + + Tr%cmor_tendprefix = "" + if (present(cmor_tendprefix)) Tr%cmor_tendprefix = cmor_tendprefix + + Tr%conv_scale = GV%H_to_MKS*Tr%conc_scale + if (present(convergence_scale)) then + Tr%conv_scale = convergence_scale + elseif (present(flux_scale)) then + Tr%conv_scale = flux_scale + endif + + Tr%diag_form = 1 + if (present(diag_form)) Tr%diag_form = diag_form + + Tr%t => tr_ptr + + if (present(registry_diags)) Tr%registry_diags = registry_diags + + if (present(ad_x)) then ; if (associated(ad_x)) Tr%ad_x => ad_x ; endif + if (present(ad_y)) then ; if (associated(ad_y)) Tr%ad_y => ad_y ; endif + if (present(df_x)) then ; if (associated(df_x)) Tr%df_x => df_x ; endif + if (present(df_y)) then ; if (associated(df_y)) Tr%df_y => df_y ; endif +! if (present(OBC_inflow)) Tr%OBC_inflow_conc = OBC_inflow +! if (present(OBC_in_u)) then ; if (associated(OBC_in_u)) Tr%OBC_in_u => OBC_in_u ; endif +! if (present(OBC_in_v)) then ; if (associated(OBC_in_v)) Tr%OBC_in_v => OBC_in_v ; endif + if (present(ad_2d_x)) then ; if (associated(ad_2d_x)) Tr%ad2d_x => ad_2d_x ; endif + if (present(ad_2d_y)) then ; if (associated(ad_2d_y)) Tr%ad2d_y => ad_2d_y ; endif + if (present(df_2d_x)) then ; if (associated(df_2d_x)) Tr%df2d_x => df_2d_x ; endif + + if (present(advection_xy)) then ; if (associated(advection_xy)) Tr%advection_xy => advection_xy ; endif + + if (present(restart_CS)) then + ! Register this tracer to be read from and written to restart files. + mand = .true. ; if (present(mandatory)) mand = mandatory + + call register_restart_field(tr_ptr, Tr%name, mand, restart_CS, & + longname=Tr%longname, units=Tr%units, conversion=conc_scale) + endif +end subroutine register_tracer + + +!> This subroutine locks the tracer registry to prevent the addition of more +!! tracers. After locked=.true., can then register common diagnostics. +subroutine lock_tracer_registry(Reg) + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + + if (.not. associated(Reg)) call MOM_error(WARNING, & + "lock_tracer_registry called with an unassociated registry.") + + Reg%locked = .True. + +end subroutine lock_tracer_registry + +!> register_tracer_diagnostics does a set of register_diag_field calls for any previously +!! registered in a tracer registry with a value of registry_diags set to .true. +subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, use_KPP) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(time_type), intent(in) :: Time !< current model time + type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output + logical, intent(in) :: use_ALE !< If true active diagnostics that only + !! apply to ALE configurations + logical, intent(in) :: use_KPP !< If true active diagnostics that only + !! apply to CVMix KPP mixings + + character(len=24) :: name ! A variable's name in a NetCDF file. + character(len=24) :: shortnm ! A shortened version of a variable's name for + ! creating additional diagnostics. + character(len=72) :: longname ! The long name of that tracer variable. + character(len=72) :: flux_longname ! The tracer name in the long names of fluxes. + character(len=48) :: units ! The dimensions of the tracer. + character(len=48) :: flux_units ! The units for fluxes, either + ! [units] m3 s-1 or [units] kg s-1. + character(len=48) :: conv_units ! The units for flux convergences, either + ! [units] m2 s-1 or [units] kg s-1. + character(len=48) :: unit2 ! The dimensions of the tracer squared + character(len=72) :: cmorname ! The CMOR name of this tracer. + character(len=120) :: cmor_longname ! The CMOR long name of that variable. + character(len=120) :: var_lname ! A temporary longname for a diagnostic. + character(len=120) :: cmor_var_lname ! The temporary CMOR long name for a diagnostic + real :: conversion ! Temporary term while we address a bug + type(tracer_type), pointer :: Tr=>NULL() + integer :: i, j, k, is, ie, js, je, nz, m, m2, nTr_in + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not. associated(Reg)) call MOM_error(FATAL, "register_tracer_diagnostics: "//& + "register_tracer must be called before register_tracer_diagnostics") + + nTr_in = Reg%ntr + + do m=1,nTr_in ; if (Reg%Tr(m)%registry_diags) then + Tr => Reg%Tr(m) +! call query_vardesc(Tr%vd, name, units=units, longname=longname, & +! cmor_field_name=cmorname, cmor_longname=cmor_longname, & +! caller="register_tracer_diagnostics") + name = Tr%name ; units=adjustl(Tr%units) ; longname = Tr%longname + cmorname = Tr%cmor_name ; cmor_longname = Tr%cmor_longname + shortnm = Tr%flux_nameroot + flux_longname = Tr%flux_longname + if (len_trim(cmor_longname) == 0) cmor_longname = longname + + if (len_trim(Tr%flux_units) > 0) then ; flux_units = Tr%flux_units + elseif (GV%Boussinesq) then ; flux_units = trim(units)//" m3 s-1" + else ; flux_units = trim(units)//" kg s-1" ; endif + + if (len_trim(Tr%conv_units) > 0) then ; conv_units = Tr%conv_units + elseif (GV%Boussinesq) then ; conv_units = trim(units)//" m s-1" + else ; conv_units = trim(units)//" kg m-2 s-1" ; endif + + if (len_trim(cmorname) == 0) then + Tr%id_tr = register_diag_field("ocean_model", trim(name), diag%axesTL, & + Time, trim(longname), trim(units), conversion=Tr%conc_scale) + else + Tr%id_tr = register_diag_field("ocean_model", trim(name), diag%axesTL, & + Time, trim(longname), trim(units), conversion=Tr%conc_scale, & + cmor_field_name=cmorname, cmor_long_name=cmor_longname, & + cmor_units=Tr%cmor_units, cmor_standard_name=cmor_long_std(cmor_longname)) + endif + Tr%id_tr_post_horzn = register_diag_field("ocean_model", & + trim(name)//"_post_horzn", diag%axesTL, Time, & + trim(longname)//" after horizontal transport (advection/diffusion) has occurred", & + trim(units), conversion=Tr%conc_scale) + if (Tr%diag_form == 1) then + Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & + diag%axesCuL, Time, trim(flux_longname)//" advective zonal flux" , & + trim(flux_units), v_extensive=.true., y_cell_method='sum', & + conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) + Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & + diag%axesCvL, Time, trim(flux_longname)//" advective meridional flux" , & + trim(flux_units), v_extensive=.true., x_cell_method='sum', & + conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) + Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_dfx", & + diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux" , & + trim(flux_units), v_extensive=.true., y_cell_method='sum', & + conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) + Tr%id_dfy = register_diag_field("ocean_model", trim(shortnm)//"_dfy", & + diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux" , & + trim(flux_units), v_extensive=.true., x_cell_method='sum', & + conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) + Tr%id_hbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx", & + diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux " //& + "from the horizontal boundary diffusion scheme", trim(flux_units), v_extensive=.true., & + y_cell_method='sum', conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) + Tr%id_hbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy", & + diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional " //& + "flux from the horizontal boundary diffusion scheme", trim(flux_units), v_extensive=.true., & + x_cell_method='sum', conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) + else + Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & + diag%axesCuL, Time, "Advective (by residual mean) Zonal Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, y_cell_method='sum') + Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & + diag%axesCvL, Time, "Advective (by residual mean) Meridional Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, x_cell_method='sum') + Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_diffx", & + diag%axesCuL, Time, "Diffusive Zonal Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & + y_cell_method='sum') + Tr%id_dfy = register_diag_field("ocean_model", trim(shortnm)//"_diffy", & + diag%axesCvL, Time, "Diffusive Meridional Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & + x_cell_method='sum') + Tr%id_hbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx", & + diag%axesCuL, Time, "Horizontal Boundary Diffusive Zonal Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & + y_cell_method='sum') + Tr%id_hbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy", & + diag%axesCvL, Time, "Horizontal Boundary Diffusive Meridional Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & + x_cell_method='sum') + endif + if (Tr%id_adx > 0) call safe_alloc_ptr(Tr%ad_x,IsdB,IedB,jsd,jed,nz) + if (Tr%id_ady > 0) call safe_alloc_ptr(Tr%ad_y,isd,ied,JsdB,JedB,nz) + if (Tr%id_dfx > 0) call safe_alloc_ptr(Tr%df_x,IsdB,IedB,jsd,jed,nz) + if (Tr%id_dfy > 0) call safe_alloc_ptr(Tr%df_y,isd,ied,JsdB,JedB,nz) + if (Tr%id_hbd_dfx > 0) call safe_alloc_ptr(Tr%hbd_dfx,IsdB,IedB,jsd,jed,nz) + if (Tr%id_hbd_dfy > 0) call safe_alloc_ptr(Tr%hbd_dfy,isd,ied,JsdB,JedB,nz) + + Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & + diag%axesCu1, Time, & + "Vertically Integrated Advective Zonal Flux of "//trim(flux_longname), & + flux_units, conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, y_cell_method='sum') + Tr%id_ady_2d = register_diag_field("ocean_model", trim(shortnm)//"_ady_2d", & + diag%axesCv1, Time, & + "Vertically Integrated Advective Meridional Flux of "//trim(flux_longname), & + flux_units, conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, x_cell_method='sum') + Tr%id_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_diffx_2d", & + diag%axesCu1, Time, & + "Vertically Integrated Diffusive Zonal Flux of "//trim(flux_longname), & + flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & + y_cell_method='sum') + Tr%id_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_diffy_2d", & + diag%axesCv1, Time, & + "Vertically Integrated Diffusive Meridional Flux of "//trim(flux_longname), & + flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & + x_cell_method='sum') + Tr%id_hbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx_2d", & + diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the horizontal boundary diffusion "//& + "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & + y_cell_method='sum') + Tr%id_hbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy_2d", & + diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the horizontal boundary diffusion "//& + "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & + x_cell_method='sum') + + if (Tr%id_adx_2d > 0) call safe_alloc_ptr(Tr%ad2d_x,IsdB,IedB,jsd,jed) + if (Tr%id_ady_2d > 0) call safe_alloc_ptr(Tr%ad2d_y,isd,ied,JsdB,JedB) + if (Tr%id_dfx_2d > 0) call safe_alloc_ptr(Tr%df2d_x,IsdB,IedB,jsd,jed) + if (Tr%id_dfy_2d > 0) call safe_alloc_ptr(Tr%df2d_y,isd,ied,JsdB,JedB) + if (Tr%id_hbd_dfx_2d > 0) call safe_alloc_ptr(Tr%hbd_dfx_2d,IsdB,IedB,jsd,jed) + if (Tr%id_hbd_dfy_2d > 0) call safe_alloc_ptr(Tr%hbd_dfy_2d,isd,ied,JsdB,JedB) + + Tr%id_adv_xy = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy", & + diag%axesTL, Time, & + 'Horizontal convergence of residual mean advective fluxes of '//trim(lowercase(flux_longname)), & + conv_units, v_extensive=.true., conversion=Tr%conv_scale*US%s_to_T) + Tr%id_adv_xy_2d = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy_2d", & + diag%axesT1, Time, & + 'Vertical sum of horizontal convergence of residual mean advective fluxes of '//& + trim(lowercase(flux_longname)), conv_units, conversion=Tr%conv_scale*US%s_to_T) + if ((Tr%id_adv_xy > 0) .or. (Tr%id_adv_xy_2d > 0)) & + call safe_alloc_ptr(Tr%advection_xy,isd,ied,jsd,jed,nz) + + Tr%id_tendency = register_diag_field('ocean_model', trim(shortnm)//'_tendency', & + diag%axesTL, Time, & + 'Net time tendency for '//trim(lowercase(longname)), & + trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) + + if (Tr%id_tendency > 0) then + call safe_alloc_ptr(Tr%t_prev,isd,ied,jsd,jed,nz) + do k=1,nz ; do j=js,je ; do i=is,ie + Tr%t_prev(i,j,k) = Tr%t(i,j,k) + enddo ; enddo ; enddo + endif + + ! Neutral/Horizontal diffusion convergence tendencies + if (Tr%diag_form == 1) then + Tr%id_dfxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency', & + diag%axesTL, Time, "Neutral diffusion tracer content tendency for "//trim(shortnm), & + conv_units, conversion=Tr%conv_scale*US%s_to_T, x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + + Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency_2d', & + diag%axesT1, Time, "Depth integrated neutral diffusion tracer content "//& + "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & + x_cell_method='sum', y_cell_method='sum') + + Tr%id_hbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency', & + diag%axesTL, Time, "Horizontal boundary diffusion tracer content tendency for "//trim(shortnm), & + conv_units, conversion=Tr%conv_scale*US%s_to_T, x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + + Tr%id_hbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency_2d', & + diag%axesT1, Time, "Depth integrated horizontal boundary diffusion tracer content "//& + "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & + x_cell_method='sum', y_cell_method='sum') + else + cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& + trim(lowercase(flux_longname))//' content due to parameterized mesoscale neutral diffusion' + Tr%id_dfxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency', & + diag%axesTL, Time, "Neutral diffusion tracer content tendency for "//trim(shortnm), & + conv_units, conversion=Tr%conv_scale*US%s_to_T, cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff', & + cmor_long_name=trim(cmor_var_lname), cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & + x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + + cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& + trim(lowercase(flux_longname))//' content due to parameterized mesoscale neutral diffusion' + Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency_2d', & + diag%axesT1, Time, "Depth integrated neutral diffusion tracer "//& + "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & + cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff_2d', & + cmor_long_name=trim(cmor_var_lname), cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & + x_cell_method='sum', y_cell_method='sum') + + Tr%id_hbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency', & + diag%axesTL, Time, "Horizontal boundary diffusion tracer content tendency for "//trim(shortnm), & + conv_units, conversion=Tr%conv_scale*US%s_to_T, & + x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + + Tr%id_hbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency_2d', & + diag%axesT1, Time, "Depth integrated horizontal boundary diffusion of tracer "//& + "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & + x_cell_method='sum', y_cell_method='sum') + endif + Tr%id_dfxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_conc_tendency', & + diag%axesTL, Time, "Neutral diffusion tracer concentration tendency for "//trim(shortnm), & + trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) + + Tr%id_hbdxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_conc_tendency', & + diag%axesTL, Time, "Horizontal diffusion tracer concentration tendency for "//trim(shortnm), & + trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) + + var_lname = "Net time tendency for "//lowercase(flux_longname) + if (len_trim(Tr%cmor_tendprefix) == 0) then + Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & + diag%axesTL, Time, var_lname, conv_units, conversion=Tr%conv_scale*US%s_to_T, & + v_extensive=.true.) + Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & + diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), & + conv_units, conversion=Tr%conv_scale*US%s_to_T) + else + cmor_var_lname = "Tendency of "//trim(cmor_longname)//" Expressed as "//& + trim(flux_longname)//" Content" + Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & + diag%axesTL, Time, var_lname, conv_units, conversion=Tr%conv_scale*US%s_to_T, & + cmor_field_name=trim(Tr%cmor_tendprefix)//"tend", & + cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & + v_extensive=.true.) + cmor_var_lname = trim(cmor_var_lname)//" Vertical Sum" + Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & + diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), & + conv_units, conversion=Tr%conv_scale*US%s_to_T, & + cmor_field_name=trim(Tr%cmor_tendprefix)//"tend_2d", & + cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname) + endif + if ((Tr%id_trxh_tendency > 0) .or. (Tr%id_trxh_tendency_2d > 0)) then + call safe_alloc_ptr(Tr%Trxh_prev,isd,ied,jsd,jed,nz) + do k=1,nz ; do j=js,je ; do i=is,ie + Tr%Trxh_prev(i,j,k) = Tr%t(i,j,k) * h(i,j,k) + enddo ; enddo ; enddo + endif + + ! Vertical regridding/remapping tendencies + if (use_ALE .and. Tr%remap_tr) then + var_lname = "Vertical remapping tracer concentration tendency for "//trim(Reg%Tr(m)%name) + Tr%id_remap_conc= register_diag_field('ocean_model', & + trim(Tr%flux_nameroot)//'_tendency_vert_remap', diag%axesTL, Time, var_lname, & + trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) + + var_lname = "Vertical remapping tracer content tendency for "//trim(Reg%Tr(m)%flux_longname) + Tr%id_remap_cont = register_diag_field('ocean_model', & + trim(Tr%flux_nameroot)//'h_tendency_vert_remap', & + diag%axesTL, Time, var_lname, conv_units, v_extensive=.true., conversion=Tr%conv_scale*US%s_to_T) + + var_lname = "Vertical sum of vertical remapping tracer content tendency for "//& + trim(Reg%Tr(m)%flux_longname) + Tr%id_remap_cont_2d = register_diag_field('ocean_model', & + trim(Tr%flux_nameroot)//'h_tendency_vert_remap_2d', & + diag%axesT1, Time, var_lname, conv_units, conversion=Tr%conv_scale*US%s_to_T) + + endif + + if (use_ALE .and. (Reg%ntr 0) unit2 = "("//trim(units)//")2" + Tr%id_tr_vardec = register_diag_field('ocean_model', trim(shortnm)//"_vardec", diag%axesTL, & + Time, "ALE variance decay for "//lowercase(longname), & + trim(unit2)//" s-1", conversion=Tr%conc_scale**2*US%s_to_T) + if (Tr%id_tr_vardec > 0) then + ! Set up a new tracer for this tracer squared + m2 = Reg%ntr+1 + Tr%ind_tr_squared = m2 + call safe_alloc_ptr(Reg%Tr(m2)%t,isd,ied,jsd,jed,nz) ; Reg%Tr(m2)%t(:,:,:) = 0.0 + Reg%Tr(m2)%name = trim(shortnm)//"2" + Reg%Tr(m2)%longname = "Squared "//trim(longname) + Reg%Tr(m2)%units = unit2 + Reg%Tr(m2)%registry_diags = .false. + Reg%Tr(m2)%ind_tr_squared = -1 + ! Augment the total number of tracers, including the squared tracers. + Reg%ntr = Reg%ntr + 1 + endif + endif + + ! KPP nonlocal term diagnostics + if (use_KPP) then + Tr%id_net_surfflux = register_diag_field('ocean_model', Tr%net_surfflux_name, diag%axesT1, Time, & + Tr%net_surfflux_longname, trim(units)//' m s-1', conversion=GV%H_to_m*US%s_to_T) + Tr%id_NLT_tendency = register_diag_field('ocean_model', "KPP_NLT_d"//trim(shortnm)//"dt", & + diag%axesTL, Time, & + trim(longname)//' tendency due to non-local transport of '//trim(lowercase(flux_longname))//& + ', as calculated by [CVMix] KPP', trim(units)//' s-1', conversion=US%s_to_T) + if (Tr%conv_scale == 0.001*GV%H_to_kg_m2) then + conversion = GV%H_to_kg_m2 + else + conversion = Tr%conv_scale + end if + ! We actually want conversion=Tr%conv_scale for all tracers, but introducing the local variable + ! 'conversion' and setting it to GV%H_to_kg_m2 instead of 0.001*GV%H_to_kg_m2 for salt tracers + ! keeps changes introduced by this refactoring limited to round-off level; as it turns out, + ! there is a bug in the code and the NLT budget term for salinity is off by a factor of 10^3 + ! so introducing the 0.001 here will fix that bug. + Tr%id_NLT_budget = register_diag_field('ocean_model', Tr%NLT_budget_name, & + diag%axesTL, Time, & + trim(flux_longname)//' content change due to non-local transport, as calculated by [CVMix] KPP', & + conv_units, conversion=conversion*US%s_to_T, v_extensive=.true.) + endif + + endif ; enddo + +end subroutine register_tracer_diagnostics + +subroutine preALE_tracer_diagnostics(Reg, G, GV) + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + + integer :: i, j, k, is, ie, js, je, nz, m, m2 + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + do m=1,Reg%ntr ; if (Reg%Tr(m)%ind_tr_squared > 0) then + m2 = Reg%Tr(m)%ind_tr_squared + ! Update squared quantities + do k=1,nz ; do j=js,je ; do i=is,ie + Reg%Tr(m2)%T(i,j,k) = Reg%Tr(m)%T(i,j,k)**2 + enddo ; enddo ; enddo + endif ; enddo + +end subroutine preALE_tracer_diagnostics + +subroutine postALE_tracer_diagnostics(Reg, G, GV, diag, dt) + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + real, intent(in) :: dt !< total time interval for these diagnostics [T ~> s] + + real :: work(SZI_(G),SZJ_(G),SZK_(GV)) + real :: Idt ! The inverse of the time step [T-1 ~> s-1] + integer :: i, j, k, is, ie, js, je, nz, m, m2 + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + ! The "if" is to avoid NaNs if the diagnostic is called for a zero length interval + Idt = 0.0 ; if (dt /= 0.0) Idt = 1.0 / dt + + do m=1,Reg%ntr ; if (Reg%Tr(m)%id_tr_vardec > 0) then + m2 = Reg%Tr(m)%ind_tr_squared + if (m2 < 1) call MOM_error(FATAL, "Bad value of Tr%ind_tr_squared for "//trim(Reg%Tr(m)%name)) + ! Update squared quantities + do k=1,nz ; do j=js,je ; do i=is,ie + work(i,j,k) = (Reg%Tr(m2)%T(i,j,k) - Reg%Tr(m)%T(i,j,k)**2) * Idt + enddo ; enddo ; enddo + call post_data(Reg%Tr(m)%id_tr_vardec, work, diag) + endif ; enddo + +end subroutine postALE_tracer_diagnostics + +!> Post tracer diganostics when that should only be posted when MOM's state +!! is self-consistent (also referred to as 'synchronized') +subroutine post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_grid_storage), intent(in) :: diag_prev !< Contains diagnostic grids from previous timestep + type(diag_ctrl), intent(inout) :: diag !< structure to regulate diagnostic output + real, intent(in) :: dt !< total time step for tracer updates [T ~> s] + + real :: work3d(SZI_(G),SZJ_(G),SZK_(GV)) + real :: work2d(SZI_(G),SZJ_(G)) + real :: Idt ! The inverse of the time step [T-1 ~> s-1] + type(tracer_type), pointer :: Tr=>NULL() + integer :: i, j, k, is, ie, js, je, nz, m + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + Idt = 0.; if (dt/=0.) Idt = 1.0 / dt ! The "if" is in case the diagnostic is called for a zero length interval + + ! Tendency diagnostics need to be posted on the grid from the last call to this routine + call diag_save_grids(diag) + call diag_copy_storage_to_diag(diag, diag_prev) + do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then + Tr => Reg%Tr(m) + if (Tr%id_tr > 0) call post_data(Tr%id_tr, Tr%t, diag) + if (Tr%id_tendency > 0) then + work3d(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work3d(i,j,k) = (Tr%t(i,j,k) - Tr%t_prev(i,j,k))*Idt + tr%t_prev(i,j,k) = Tr%t(i,j,k) + enddo ; enddo ; enddo + call post_data(Tr%id_tendency, work3d, diag, alt_h=diag_prev%h_state) + endif + if ((Tr%id_trxh_tendency > 0) .or. (Tr%id_trxh_tendency_2d > 0)) then + do k=1,nz ; do j=js,je ; do i=is,ie + work3d(i,j,k) = (Tr%t(i,j,k)*h(i,j,k) - Tr%Trxh_prev(i,j,k)) * Idt + Tr%Trxh_prev(i,j,k) = Tr%t(i,j,k) * h(i,j,k) + enddo ; enddo ; enddo + if (Tr%id_trxh_tendency > 0) call post_data(Tr%id_trxh_tendency, work3d, diag, alt_h=diag_prev%h_state) + if (Tr%id_trxh_tendency_2d > 0) then + work2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work2d(i,j) = work2d(i,j) + work3d(i,j,k) + enddo ; enddo ; enddo + call post_data(Tr%id_trxh_tendency_2d, work2d, diag) + endif + endif + endif ; enddo + call diag_restore_grids(diag) + +end subroutine post_tracer_diagnostics_at_sync + +!> Post the advective and diffusive tendencies +subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_diag !< Layer thicknesses on which to post fields [H ~> m or kg m-2] + type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output + + integer :: i, j, k, is, ie, js, je, nz, m + real :: work2d(SZI_(G),SZJ_(G)) + type(tracer_type), pointer :: Tr=>NULL() + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then + Tr => Reg%Tr(m) + if (Tr%id_tr_post_horzn> 0) call post_data(Tr%id_tr_post_horzn, Tr%t, diag) + if (Tr%id_adx > 0) call post_data(Tr%id_adx, Tr%ad_x, diag, alt_h=h_diag) + if (Tr%id_ady > 0) call post_data(Tr%id_ady, Tr%ad_y, diag, alt_h=h_diag) + if (Tr%id_dfx > 0) call post_data(Tr%id_dfx, Tr%df_x, diag, alt_h=h_diag) + if (Tr%id_dfy > 0) call post_data(Tr%id_dfy, Tr%df_y, diag, alt_h=h_diag) + if (Tr%id_adx_2d > 0) call post_data(Tr%id_adx_2d, Tr%ad2d_x, diag) + if (Tr%id_ady_2d > 0) call post_data(Tr%id_ady_2d, Tr%ad2d_y, diag) + if (Tr%id_dfx_2d > 0) call post_data(Tr%id_dfx_2d, Tr%df2d_x, diag) + if (Tr%id_dfy_2d > 0) call post_data(Tr%id_dfy_2d, Tr%df2d_y, diag) + if (Tr%id_adv_xy > 0) call post_data(Tr%id_adv_xy, Tr%advection_xy, diag, alt_h=h_diag) + if (Tr%id_adv_xy_2d > 0) then + work2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work2d(i,j) = work2d(i,j) + Tr%advection_xy(i,j,k) + enddo ; enddo ; enddo + call post_data(Tr%id_adv_xy_2d, work2d, diag) + endif + endif ; enddo + +end subroutine post_tracer_transport_diagnostics + +!> This subroutine writes out chksums for the first ntr registered tracers. +subroutine tracer_array_chksum(mesg, Tr, ntr, G) + character(len=*), intent(in) :: mesg !< message that appears on the chksum lines + type(tracer_type), intent(in) :: Tr(:) !< array of all of registered tracers + integer, intent(in) :: ntr !< number of registered tracers + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + + integer :: m + + do m=1,ntr + call hchksum(Tr(m)%t, mesg//trim(Tr(m)%name), G%HI, scale=Tr(m)%conc_scale) + enddo + +end subroutine tracer_array_chksum + +!> This subroutine writes out chksums for all the registered tracers. +subroutine tracer_Reg_chksum(mesg, Reg, G) + character(len=*), intent(in) :: mesg !< message that appears on the chksum lines + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + + integer :: m + + if (.not.associated(Reg)) return + + do m=1,Reg%ntr + call hchksum(Reg%Tr(m)%t, mesg//trim(Reg%Tr(m)%name), G%HI, scale=Reg%Tr(m)%conc_scale) + enddo + +end subroutine tracer_Reg_chksum + +!> Calculates and prints the global inventory of the first ntr tracers in the registry. +subroutine tracer_array_chkinv(mesg, G, GV, h, Tr, ntr) + character(len=*), intent(in) :: mesg !< message that appears on the chksum lines + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(tracer_type), dimension(:), intent(in) :: Tr !< array of all of registered tracers + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + integer, intent(in) :: ntr !< number of registered tracers + + ! Local variables + real :: vol_scale ! The dimensional scaling factor to convert volumes to m3 [m3 H-1 L-2 ~> 1 or m3 kg-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tr_inv ! Volumetric tracer inventory in each cell [conc m3] + real :: total_inv ! The total amount of tracer [conc m3] + integer :: is, ie, js, je, nz + integer :: i, j, k, m + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + vol_scale = GV%H_to_m*G%US%L_to_m**2 + do m=1,ntr + do k=1,nz ; do j=js,je ; do i=is,ie + tr_inv(i,j,k) = Tr(m)%conc_scale*Tr(m)%t(i,j,k) * (vol_scale * h(i,j,k) * G%areaT(i,j)*G%mask2dT(i,j)) + enddo ; enddo ; enddo + total_inv = reproducing_sum(tr_inv, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) + if (is_root_pe()) write(0,'(A,1X,A5,1X,ES25.16,1X,A)') "h-point: inventory", Tr(m)%name, total_inv, mesg + enddo + +end subroutine tracer_array_chkinv + + +!> Calculates and prints the global inventory of all tracers in the registry. +subroutine tracer_Reg_chkinv(mesg, G, GV, h, Reg) + character(len=*), intent(in) :: mesg !< message that appears on the chksum lines + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + + ! Local variables + real :: vol_scale ! The dimensional scaling factor to convert volumes to m3 [m3 H-1 L-2 ~> 1 or m3 kg-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tr_inv ! Volumetric tracer inventory in each cell [conc m3] + real :: total_inv ! The total amount of tracer [conc m3] + integer :: is, ie, js, je, nz + integer :: i, j, k, m + + if (.not.associated(Reg)) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + vol_scale = GV%H_to_m*G%US%L_to_m**2 + do m=1,Reg%ntr + do k=1,nz ; do j=js,je ; do i=is,ie + tr_inv(i,j,k) = Reg%Tr(m)%conc_scale*Reg%Tr(m)%t(i,j,k) * (vol_scale * h(i,j,k) * G%areaT(i,j)*G%mask2dT(i,j)) + enddo ; enddo ; enddo + total_inv = reproducing_sum(tr_inv, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) + if (is_root_pe()) write(0,'(A,1X,A5,1X,ES25.16,1X,A)') "h-point: inventory", Reg%Tr(m)%name, total_inv, mesg + enddo + +end subroutine tracer_Reg_chkinv + + +!> Find a tracer in the tracer registry by name. +subroutine tracer_name_lookup(Reg, n, tr_ptr, name) + type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry + type(tracer_type), pointer :: tr_ptr !< target or pointer to the tracer array + character(len=32), intent(in) :: name !< tracer name + integer, intent(out) :: n !< index to tracer registery + + do n=1,Reg%ntr + if (lowercase(Reg%Tr(n)%name) == lowercase(name)) then + tr_ptr => Reg%Tr(n) + return + endif + enddo + + call MOM_error(FATAL,"MOM cannot find registered tracer: "//name) + +end subroutine tracer_name_lookup + +!> Initialize the tracer registry. +subroutine tracer_registry_init(param_file, Reg) + type(param_file_type), intent(in) :: param_file !< open file to parse for model parameters + type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry + + integer, save :: init_calls = 0 + +! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mdl = "MOM_tracer_registry" ! This module's name. + character(len=256) :: mesg ! Message for error messages. + + if (.not.associated(Reg)) then ; allocate(Reg) + else ; return ; endif + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "", all_default=.true.) + + init_calls = init_calls + 1 + if (init_calls > 1) then + write(mesg,'("tracer_registry_init called ",I3, & + &" times with different registry pointers.")') init_calls + if (is_root_pe()) call MOM_error(WARNING,"MOM_tracer"//mesg) + endif + +end subroutine tracer_registry_init + + +!> This routine closes the tracer registry module. +subroutine tracer_registry_end(Reg) + type(tracer_registry_type), pointer :: Reg !< The tracer registry that will be deallocated + if (associated(Reg)) deallocate(Reg) +end subroutine tracer_registry_end + +end module MOM_tracer_registry diff --git a/tracer/MOM_tracer_types.F90 b/tracer/MOM_tracer_types.F90 new file mode 100644 index 0000000000..bdae8bcee9 --- /dev/null +++ b/tracer/MOM_tracer_types.F90 @@ -0,0 +1,130 @@ +!> This module contains the tracer_type and tracer_registry_type +module MOM_tracer_types + +implicit none ; private + +#include + +!> The tracer type +type, public :: tracer_type + + real, dimension(:,:,:), pointer :: t => NULL() !< tracer concentration array [CU ~> conc] +! real :: OBC_inflow_conc= 0.0 !< tracer concentration for generic inflows [CU ~> conc] +! real, dimension(:,:,:), pointer :: OBC_in_u => NULL() !< structured values for flow into the domain +! !! specified in OBCs through u-face of cell +! real, dimension(:,:,:), pointer :: OBC_in_v => NULL() !< structured values for flow into the domain +! !! specified in OBCs through v-face of cell + + real, dimension(:,:,:), pointer :: ad_x => NULL() !< diagnostic array for x-advective tracer flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: ad_y => NULL() !< diagnostic array for y-advective tracer flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: ad2d_x => NULL() !< diagnostic vertical sum x-advective tracer flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: ad2d_y => NULL() !< diagnostic vertical sum y-advective tracer flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + + real, dimension(:,:,:), pointer :: df_x => NULL() !< diagnostic array for x-diffusive tracer flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: hbd_dfx => NULL() !< diagnostic array for x-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: hbd_dfy => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: hbd_dfx_2d => NULL() !< diagnostic array for x-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: hbd_dfy_2d => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: df2d_x => NULL() !< diagnostic vertical sum x-diffusive flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: df2d_y => NULL() !< diagnostic vertical sum y-diffusive flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] +! real, dimension(:,:), pointer :: df2d_conc_x => NULL() !< diagnostic vertical sum x-diffusive content flux +! !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] +! real, dimension(:,:), pointer :: df2d_conc_y => NULL() !< diagnostic vertical sum y-diffusive content flux +! !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + + real, dimension(:,:,:), pointer :: advection_xy => NULL() !< convergence of lateral advective tracer fluxes + !! [CU H T-1 ~> conc m s-1 or conc kg m-2 s-1] +! real, dimension(:,:,:), pointer :: diff_cont_xy => NULL() !< convergence of lateral diffusive tracer fluxes +! !! [CU H T-1 ~> conc m s-1 or conc kg m-2 s-1] +! real, dimension(:,:,:), pointer :: diff_conc_xy => NULL() !< convergence of lateral diffusive tracer fluxes +! !! expressed as a change in concentration +! !! [CU T-1 ~> conc s-1] + real, dimension(:,:,:), pointer :: t_prev => NULL() !< tracer concentration array at a previous + !! timestep used for diagnostics [CU ~> conc] + real, dimension(:,:,:), pointer :: Trxh_prev => NULL() !< layer integrated tracer concentration array + !! at a previous timestep used for diagnostics + !! [CU H ~> conc m or conc kg m-2] + + character(len=32) :: name !< tracer name used for diagnostics and error messages + character(len=64) :: units !< Physical dimensions of the tracer concentration + character(len=240) :: longname !< Long name of the variable +! type(vardesc), pointer :: vd => NULL() !< metadata describing the tracer + logical :: registry_diags = .false. !< If true, use the registry to set up the + !! diagnostics associated with this tracer. + real :: conc_underflow = 0.0 !< A magnitude of tracer concentrations below + !! which values should be set to 0. [CU ~> conc] + real :: conc_scale = 1.0 !< A scaling factor used to convert the concentrations + !! of this tracer to its desired units. + character(len=64) :: cmor_name !< CMOR name of this tracer + character(len=64) :: cmor_units !< CMOR physical dimensions of the tracer + character(len=240) :: cmor_longname !< CMOR long name of the tracer + character(len=32) :: flux_nameroot = "" !< Short tracer name snippet used construct the + !! names of flux diagnostics. + character(len=64) :: flux_longname = "" !< A word or phrase used construct the long + !! names of flux diagnostics. + real :: flux_scale = 1.0 !< A scaling factor used to convert the fluxes + !! of this tracer to its desired units, + !! including a factor compensating for H scaling. + character(len=48) :: flux_units = "" !< The units for fluxes of this variable. + character(len=48) :: conv_units = "" !< The units for the flux convergence of this tracer. + real :: conv_scale = 1.0 !< A scaling factor used to convert the flux + !! convergence of this tracer to its desired units, + !! including a factor compensating for H scaling. + character(len=48) :: cmor_tendprefix = "" !< The CMOR variable prefix for tendencies of this + !! tracer, required because CMOR does not follow any + !! discernable pattern for these names. + character(len=48) :: net_surfflux_name = "" !< Name to use for net_surfflux KPP diagnostic + character(len=48) :: NLT_budget_name = "" !< Name to use for NLT_budget KPP diagnostic + character(len=128) :: net_surfflux_longname = "" !< Long name to use for net_surfflux KPP diagnostic + integer :: ind_tr_squared = -1 !< The tracer registry index for the square of this tracer + + !### THESE CAPABILITIES HAVE NOT YET BEEN IMPLEMENTED. + ! logical :: advect_tr = .true. !< If true, this tracer should be advected + ! logical :: hordiff_tr = .true. !< If true, this tracer should experience epineutral diffusion + ! logical :: kpp_nonlocal_tr = .true. !< if true, apply KPP nonlocal transport to this tracer before diffusion + logical :: remap_tr = .true. !< If true, this tracer should be vertically remapped + + integer :: diag_form = 1 !< An integer indicating which template is to be used to label diagnostics. + !>@{ Diagnostic IDs + integer :: id_tr = -1, id_tr_post_horzn = -1 + integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 + integer :: id_hbd_dfx = -1, id_hbd_dfy = -1 + integer :: id_hbd_dfx_2d = -1, id_hbd_dfy_2d = -1 + integer :: id_adx_2d = -1, id_ady_2d = -1, id_dfx_2d = -1, id_dfy_2d = -1 + integer :: id_adv_xy = -1, id_adv_xy_2d = -1 + integer :: id_dfxy_cont = -1, id_dfxy_cont_2d = -1, id_dfxy_conc = -1 + integer :: id_hbdxy_cont = -1, id_hbdxy_cont_2d = -1, id_hbdxy_conc = -1 + integer :: id_remap_conc = -1, id_remap_cont = -1, id_remap_cont_2d = -1 + integer :: id_tendency = -1, id_trxh_tendency = -1, id_trxh_tendency_2d = -1 + integer :: id_tr_vardec = -1 + integer :: id_net_surfflux = -1, id_NLT_tendency = -1, id_NLT_budget = -1 + !>@} +end type tracer_type + +!> Type to carry basic tracer information +type, public :: tracer_registry_type + integer :: ntr = 0 !< number of registered tracers + type(tracer_type) :: Tr(MAX_FIELDS_) !< array of registered tracers +! type(diag_ctrl), pointer :: diag !< structure to regulate timing of diagnostics + logical :: locked = .false. !< New tracers may be registered if locked=.false. + !! When locked=.true., no more tracers can be registered, + !! at which point common diagnostics can be set up + !! for the registered tracers +end type tracer_registry_type + + +end module MOM_tracer_types diff --git a/tracer/RGC_tracer.F90 b/tracer/RGC_tracer.F90 new file mode 100644 index 0000000000..474fcb0c23 --- /dev/null +++ b/tracer/RGC_tracer.F90 @@ -0,0 +1,324 @@ +!> This module contains the routines used to set up a +!! dynamically passive tracer. +!! Set up and use passive tracers requires the following: +!! (1) register_RGC_tracer +!! (2) apply diffusion, physics/chemistry and advect the tracer + +!********+*********+*********+*********+*********+*********+*********+** +!* * +!* By Elizabeth Yankovsky, June 2019 * +!*********+*********+*********+*********+*********+*********+*********** + +module RGC_tracer + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_hor_index, only : hor_index_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_restart, only : MOM_restart_CS +use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS, get_ALE_sponge_nz_data +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_open_boundary, only : ocean_OBC_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +!< Publicly available functions +public register_RGC_tracer, initialize_RGC_tracer +public RGC_tracer_column_physics, RGC_tracer_end + +integer, parameter :: NTR = 1 !< The number of tracers in this module. + +!> tracer control structure +type, public :: RGC_tracer_CS ; private + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + character(len = 200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package [kg kg-1] + real, pointer :: tr_aux(:,:,:,:) => NULL() !< The masked tracer concentration [kg kg-1] + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out [kg kg-1] + real :: CSL !< The length of the continental shelf (x direction) [km] + real :: lensponge !< the length of the sponge layer [km] + logical :: mask_tracers !< If true, tracers are masked out in massless layers. + logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output. + type(vardesc) :: tr_desc(NTR) !< Descriptions and metadata for the tracers. +end type RGC_tracer_CS + +contains + +!> This subroutine is used to register tracer fields +function register_RGC_tracer(G, GV, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file ! NULL() ! A pointer to one of the tracers in this module [kg kg-1] + logical :: register_RGC_tracer + integer :: isd, ied, jsd, jed, nz, m + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "RGC_register_tracer called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "RGC_TRACER_IC_FILE", CS%tracer_IC_file, & + "The name of a file from which to read the initial \n"//& + "conditions for the RGC tracers, or blank to initialize \n"//& + "them internally.", default=" ") + if (len_trim(CS%tracer_IC_file) >= 1) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + CS%tracer_IC_file = trim(inputdir)//trim(CS%tracer_IC_file) + call log_param(param_file, mdl, "INPUTDIR/RGC_TRACER_IC_FILE", & + CS%tracer_IC_file) + endif + call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & + "If true, sponges may be applied anywhere in the domain. \n"//& + "The exact location and properties of those sponges are \n"//& + "specified from MOM_initialization.F90.", default=.false.) + + call get_param(param_file, mdl, "CONT_SHELF_LENGTH", CS%CSL, & + "The length of the continental shelf (x dir, km).", & + units=G%x_ax_unit_short, default=15.0) + + call get_param(param_file, mdl, "LENSPONGE", CS%lensponge, & + "The length of the sponge layer (km).", & + units=G%x_ax_unit_short, default=10.0) + + allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) + if (CS%mask_tracers) then + allocate(CS%tr_aux(isd:ied,jsd:jed,nz,NTR), source=0.0) + endif + + do m=1,NTR + if (m < 10) then ; write(name,'("tr_RGC",I1.1)') m + else ; write(name,'("tr_RGC",I2.2)') m ; endif + write(longname,'("Concentration of RGC Tracer ",I2.2)') m + CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + + ! This is needed to force the compiler not to do a copy in the registration calls. + tr_ptr => CS%tr(:,:,:,m) + ! Register the tracer for horizontal advection & diffusion. + call register_tracer(tr_ptr, tr_Reg, param_file, G%HI, GV, & + name=name, longname=longname, units="kg kg-1", & + registry_diags=.true., flux_units="kg/s", & + restart_CS=restart_CS) + enddo + + CS%tr_Reg => tr_Reg + register_RGC_tracer = .true. +end function register_RGC_tracer + +!> Initializes the NTR tracer fields in tr(:,:,:,:) +!! and it sets up the tracer output. +subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & + layer_CSp, sponge_CSp) + + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. This is not being used for now. + type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to RGC_register_tracer. + type(sponge_CS), pointer :: layer_CSp !< A pointer to the control structure + type(ALE_sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure for the + !! sponges, if they are in use. Otherwise this may be unassociated. + + real, allocatable :: temp(:,:,:) ! A temporary array used for several sponge target values [various] + character(len=16) :: name ! A variable's name in a NetCDF file. + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers in this module [kg kg-1] + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m + integer :: IsdB, IedB, JsdB, JedB + integer :: nzdata + + if (.not.associated(CS)) return + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + h_neglect = GV%H_subroundoff + + CS%Time => day + CS%diag => diag + + if (.not.restart) then + if (len_trim(CS%tracer_IC_file) >= 1) then + ! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & + call MOM_error(FATAL, "RGC_initialize_tracer: Unable to open "// & + CS%tracer_IC_file) + do m=1,NTR + call query_vardesc(CS%tr_desc(m), name, caller="initialize_RGC_tracer") + call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) + enddo + else + do m=1,NTR + do k=1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = 0.0 + enddo ; enddo ; enddo + enddo + m=1 + do j=js,je ; do i=is,ie + !set tracer to 1.0 in the surface of the continental shelf + if (G%geoLonT(i,j) <= (CS%CSL)) then + CS%tr(i,j,1,m) = 1.0 !first layer + endif + enddo ; enddo + + endif + endif ! restart + + if ( CS%use_sponge ) then +! If sponges are used, this damps values to zero in the offshore boundary. +! For any tracers that are not damped in the sponge, the call +! to set_up_sponge_field can simply be omitted. + if (associated(sponge_CSp)) then !ALE mode + nzdata = get_ALE_sponge_nz_data(sponge_CSp) + if (nzdata>0) then + allocate(temp(G%isd:G%ied,G%jsd:G%jed,nzdata)) + do k=1,nzdata ; do j=js,je ; do i=is,ie + if (G%geoLonT(i,j) >= (G%len_lon - CS%lensponge) .AND. G%geoLonT(i,j) <= G%len_lon) then + temp(i,j,k) = 0.0 + endif + enddo ; enddo ; enddo + do m=1,1 + ! This is needed to force the compiler not to do a copy in the sponge calls. + tr_ptr => CS%tr(:,:,:,m) + call set_up_ALE_sponge_field(temp, G, GV, tr_ptr, sponge_CSp, 'RGC_tracer') + enddo + deallocate(temp) + endif + + elseif (associated(layer_CSp)) then !layer mode + if (nz>0) then + allocate(temp(G%isd:G%ied,G%jsd:G%jed,nz)) + do k=1,nz ; do j=js,je ; do i=is,ie + if (G%geoLonT(i,j) >= (G%len_lon - CS%lensponge) .AND. G%geoLonT(i,j) <= G%len_lon) then + temp(i,j,k) = 0.0 + endif + enddo ; enddo ; enddo + do m=1,1 + tr_ptr => CS%tr(:,:,:,m) + call set_up_sponge_field(temp, tr_ptr, G, GV, nz, layer_CSp) + enddo + deallocate(temp) + endif + else + call MOM_error(FATAL, "RGC_initialize_tracer: "// & + "The pointer to sponge_CSp must be associated if SPONGE is defined.") + endif !selecting mode/calling error if no pointer + endif !using sponge + +end subroutine initialize_RGC_tracer + +!> This subroutine applies diapycnal diffusion and any other column +!! tracer physics or chemistry to the tracers from this file. +!! This is a simple example of a set of advected passive tracers. +subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible + !! forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can be + !! fluxed out of the top layer in a timestep [nondim]. + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes + !! can be applied [H ~> m or kg m-2]. + +! The arguments to this subroutine are redundant in that +! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + + integer :: i, j, k, is, ie, js, je, nz, m + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + + m=1 + do j=js,je ; do i=is,ie + ! set tracer to 1.0 in the surface of the continental shelf + if (G%geoLonT(i,j) <= (CS%CSL)) then + CS%tr(i,j,1,m) = 1.0 !first layer + endif + enddo ; enddo + + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,NTR + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo; + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + + call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + else + do m=1,NTR + call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + endif + +end subroutine RGC_tracer_column_physics + +subroutine RGC_tracer_end(CS) + type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call to RGC_register_tracer. + + if (associated(CS)) then + if (associated(CS%tr)) deallocate(CS%tr) + deallocate(CS) + endif +end subroutine RGC_tracer_end + +end module RGC_tracer diff --git a/tracer/_Advection.dox b/tracer/_Advection.dox new file mode 100644 index 0000000000..4e5585fb63 --- /dev/null +++ b/tracer/_Advection.dox @@ -0,0 +1,62 @@ +/*! \page Tracer_Advection Tracer Advection + +MOM6 implements a generalised tracer advection scheme, which is a +combination of the modified flux advection scheme \cite easter1993 with +reconstructed tracer distributions. The tracer distributions may be +piecewise linear (PLM) or piecewise parabolic (PPM), which may itself +use either the \cite colella1984 (CW84) or \cite huynh1997 (H3) reconstruction. + +\section Flux_advection Flux advection +The modified flux advection scheme preserves the tracer mixing ratio in +a cell across directional splitting by accounting for changes in mass +changes. Fluxes are applied to alternate directions in turn, restricting +the applied flux so as not to evacuate all mass out of a cell. Because +of this, we need to know the stencil used during the calculation of the +reconstruction. Every iteration of the splitting algorithm, cells at the +edge of a processor's data domain are invalidated. When this invalidation +region extends below the halo, a group pass is required to refresh the +halo. A larger stencil (such as for the CW84 reconstruction) therefore +introduces more frequent updates, and may impact performance. + +\section Tracer_reconstruction Tracer reconstruction +While MOM6 only carries the mean tracer concentration in a cell, +a higher order reconstruction is computed for the purpose of +advection. Reconstructions are also modified to ensure that monotonicity +is preserved (i.e. spurious minima or maxima cannot be introduced). + +The piecewise linear (PLM) reconstruction uses the monotonic modified +van Leer scheme \cite lin1994. One might think to use the average +of the one-sided differences of mean tracer concentration within a cell +to calculate the slope of the linear reconstruction, however this method +guarantees neither monotonicity, nor positive definiteness. Instead, the +method is locally limited to the minimum of this average slope and each +of the one-sided slopes, i.e. \f[\Delta \Phi_i = \min\left\{\left|[\Delta +\Phi_i]_\text{avg}\right|, 2\left(\Phi_i - \Phi_i^\text{min}\right), +2\left(\Phi_i^\text{max} - \Phi_i\right)\right\}\f] (where +\f$\Phi_i^\text{min}\f$ is the minimum in the 3-point stencil). + +In a PPM scheme (\ref PPM), for a cell with mean tracer concentration \f$\Phi_i\f$, +the values at the left and right interfaces, \f$\Phi_{L,i}\f$ +and \f$\Phi_{R,i}\f$ must be estimated. First, an interpolation is +used to calculate \f$\Phi_{i-1/2}\f$ and \f$\Phi_{i+1/2}\f$. These +values are then modified to preserve monotonicity in each cell, which +introduces discontinuities between cell edges (e.g. \f$\Phi_{R,i}\f$ +and \f$\Phi_{L,i+1}\f$). + +The reconstruction \f$\Phi_i(\xi)\f$ then satisfies three properties: + +- total amount of tracer is conserved, \f$\int_{\xi_{i-1/2}}^{\xi_{i+1/2}} \Phi_i(\xi') \,\mathrm d\xi' = \Phi_i\f$ +- left interface value matches, \f$\Phi(\xi_{i-1/2}) = \Phi_{L,i}\f$ +- right interface value matches, \f$\Phi(\xi_{i+1/2}) = \Phi_{R,i}\f$ + +There are two methods of reconstruction for a piecewise parabolic +(PPM) profile. They differ in the estimate of interface values +\f$\Phi_{i+1/2}\f$ prior to monotonicity limiting. The CW84 +scheme makes use of the limited slope \f$\Delta\Phi_i\f$ +from PLM, above. This has the effect of requiring a larger stencil +for each reconstruction. On the other hand, the H3 scheme +reduces the requirement of this stencil, by only examining the tracer +concentrations in adjacent cells, at the same time reducing order of +accuracy of the reconstruction. + +*/ diff --git a/tracer/_Discrete_tracer.dox b/tracer/_Discrete_tracer.dox new file mode 100644 index 0000000000..60aa2a0a44 --- /dev/null +++ b/tracer/_Discrete_tracer.dox @@ -0,0 +1,5 @@ +/*! \page Discrete_Tracer Discrete Tracer Transport Equations + +\brief Discrete Tracer Transport Equations + +*/ diff --git a/tracer/_Horizontal_diffusion.dox b/tracer/_Horizontal_diffusion.dox new file mode 100644 index 0000000000..92a8f53e59 --- /dev/null +++ b/tracer/_Horizontal_diffusion.dox @@ -0,0 +1,173 @@ +/*! \page Horizontal_Diffusion Horizontal Diffusion + +\brief Horizontal diffusion of tracers + +Lateral mixing due to mesoscale eddies is believed to occur according to this figure: + +\anchor eddy_flux +\image html eddy_fluxes.png "Horizontal surface boundary layer fluxes and interior epineutral fluxes." +\image latex eddy_fluxes.png "Horizontal surface boundary layer fluxes and interior epineutral fluxes." + +We start by describing an implementation of the mixing in the interior and then +introduce a surface mixed layer implementation. A bottom mixed layer +implementation is planned for the future. + +\section Epineutral_Diffusion Epineutral Diffusion + +For the interior of the ocean, we would like to have horizontal diffusion +with the following properties: + +\li Suitable for general coordinate models +\li Preserves extrema +\li Has no need for regularization or tapering (such as needed by rotated mixing +tensors) + +The algorithm used in MOM6 is described by \cite shao2019-in-review and will be +introduced here. The aim is to allow lateral mixing of tracers within +isopycnal layers. It is appropriate for the adiabatic interior of the ocean +while a lateral mixing scheme for the surface boundary layer is described below. + +Before presenting this scheme, a quick review of polynomial +reconstructions is in order. Some choices for the vertical representation +of a finite volume quantity are shown here: + +\image html shao0.png "Polynomial reconstructions, starting with piecewise constant on the left, piecewise linear in the middle and piecewise parabolic on the right." +\image latex shao0.png "Polynomial reconstructions, starting with piecewise constant on the left, piecewise linear in the middle and piecewise parabolic on the right." + +Some desired quantities for the polynomial reconstructions to be used are: + +\li Tracer concentrations represent the cell-averages in vertical +discretization. +\li Must be monotonic and introduce no new extrema. +\li Discontinuous reconstructions are desirable to limit intracell slopes. + +The algorithm has three phases: initialization, sorting, and flux +calculation. + +\subsection Epineutral_Initialization Initialization + +We begin by generating polynomial reconstructions of the vertical tracer +quantities such as shown by the blue lines here: + +\image html shao1.png "Polynomial reconstructions of two adjacent water columns." +\image latex shao1.png "Polynomial reconstructions of two adjacent water columns." + +Because we are looking to mix along epineutral surfaces, we will need to find +surfaces of uniform density by using the temperature, salinity, and +their effect on the density, \f$\alpha\f$ and \f$\beta\f$. The next step is +to find the values of \f$\alpha\f$ and \f$\beta\f$ at the interfaces. + +Also during the initialization, the unstable parts of the water column are +set aside to be skipped by this algorithm. + +\subsection Epineutral_Sorting Sorting + +The epineutral surfaces have constant density, where we use this equation: + +\f[ + \Delta \rho = \rho_1 - \rho_2 = \frac{\alpha_1 + \alpha_2}{2} (T_1 - + T_2) + \frac{\beta_1 + \beta_2}{2} (S_1 - S_2) +\f] + +When calculating \f$\alpha\f$ and \f$\beta\f$, there's more than one way to +do it. Using a midpoint pressure gives neutral density while using a +reference pressure gives isopycnal values. + +Given two adjacent water columns, we are going to be looking to match +densities. The match does not need to be at the same level or even near each +other in depth. Starting from the top two interfaces, search the column with +the lighter surface water (second column) downward to find which layer +contains water matching that of the first column at the surface: + +\image html shao2.png "Searching the column with the lighter surface for the water matching the other column's surface water." +\image latex shao2.png "Searching the column with the lighter surface for the water matching the other column's surface water." + +If the surface density matches that of an interface, point to the interface. +Otherwise, solve for the matching density along the polynomial +reconstruction for that layer. There are again some choices: + +\li Use Newton's method to find the root with higher order polynomials. +\li Assume \f$\alpha\f$ and \f$\beta\f$ vary linearly from top to bottom +(cubic if \f$T\f$ and \f$S\f$ are parabolic). +\li Equation of state is linear from top to bottom interface (parabolic of +\f$T\f$ and \f$S\f$ are parabolic). +\li \f$\Delta \rho\f$ is linear in the vertical. + +Once the location of the first column's surface density is found in the +second column, one goes to the next interface below to find the bottom +density of the water to be mixed. Then find that density within the +first column. Iterate downward until no more matches are found. These pairs +of surfaces make up what is known as a sublayer along which the diffusion +can take place. + +\subsection Epineutral_Flux_Calculation Flux Calculation + +For each sublayer, the fluxes are based on the mean tracer quantities within +that sublayer in each column. For a tracer \f$C\f$, compute the vertical +average of that tracer within the sublayer to form \f$\overline{C}\f$. The +flux can then be computed based on: + +\f[ + F = K h_{\mbox{eff}} \frac{\overline{C_{j,k+1}} - + \overline{C_{j+1,k-1}} }{\Delta x} \Delta t +\f] + +where the effective thickness of the sublayer is: + +\f[ + h_{\mbox{eff}} = \frac{2 h_{j,n}^\gamma h_{j,n+1}^\gamma}{h_{j,n}^\gamma + + h_{j,n+1}^\gamma} +\f] + +and as shown in this figure: + +\image html shao3.png "Diagram of sublayer thickness for the sublayer bounded by surfaces \f$\\gamma_n\f$ and \f$\\gamma_{n+1}\f$." +\imagelatex{shao3.png,Diagram of sublayer thickness for the sublayer bounded by surfaces $\gamma_n$ and $\gamma_{n+1}$.,\includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true]} + +\image html shao4.png "Flux of tracer \f$C\f$ along the sublayer." +\imagelatex{shao4.png,Flux of tracer $C$ along the sublayer.,\includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true]} + +When updating the tracer state, one needs to accumulate all the fluxes +through each face as shown here: + +\image html shao5.png "Accumulate all the fluxes across a face from all the layers in the next column contributing to it." +\image latex shao5.png "Accumulate all the fluxes across a face from all the layers in the next column contributing to it." + +\section Surface_Diffusion Surface Diffusion + +As shown in figure \ref eddy_flux of the eddy fluxes, the diffusion +in the surface boundary layer is assumed to be purely horizontal. A bulk scheme +was explored but found wanting, so a layer-by-layer approach has been implemented +instead. It is this layer-by-layer code which is described here. + +For each water column, the boundary layer thickness is determined +first. This can be either via the CVMIX boundary layer thickness or +through some other means. Next, determine how many of the model layers are within +this boundary layer thickness. It is common for neighboring cells to have +differing numbers of layers within the surface boundary layer, such as +shown here: + +\image html sbl1.png "Two cells within the surface mixed layer, red on the left, blue on the right. The mixed layer depth is shown in green." +\image latex sbl1.png "Two cells within the surface mixed layer, red on the left, blue on the right. The mixed layer depth is shown in green." + +In this case, the cell on the left has four layers within the boundary layer while +the cell on the right has just two. The layer-by-layer scheme computes fluxes for +the first two layers, then has linearly reduced fluxes for the next two layers +below as shown here: + +\image html sbl2.png "Two cells within the surface mixed layer with down-gradient fluxes as shown by the black arrows." +\image latex sbl2.png "Two cells within the surface mixed layer with down-gradient fluxes as shown by the black arrows." + +In all cases, the tracer flux is always down-gradient. + +\f[ + F(k) = K h_{\mbox{eff}(k)} \left[ \phi_L(k) - \phi_R(k)\right] +\f] + +where the effective thickness of the layer \f$k\f$ is: + +\f[ + h_{\mbox{eff}(k)} = \frac{2 h_{L}(k) h_{R}(k)} {h_{L}(k) + h_{R}(k)} +\f] + +*/ diff --git a/tracer/_Passive_tracer.dox b/tracer/_Passive_tracer.dox new file mode 100644 index 0000000000..a997eb168f --- /dev/null +++ b/tracer/_Passive_tracer.dox @@ -0,0 +1,9 @@ +/*! \page Passive_Tracers Passive and Other User-defined Tracers + +\section Passive_tracers Passive Tracers + +\section Generic_tracers Generic Tracers + +\section User_tracers User-defined Tracers + +*/ diff --git a/tracer/_Tracer_Transport.dox b/tracer/_Tracer_Transport.dox new file mode 100644 index 0000000000..e62f05dfb7 --- /dev/null +++ b/tracer/_Tracer_Transport.dox @@ -0,0 +1,124 @@ +/*! \page Tracer_Transport_Equations Tracer Transport Equations + +\image html PPM_1d.png "The 1-D finite volume advection of tracers. The reddish fluid will be in the cell at the end of the timestep." +\image latex PPM_1d.png "The 1-D finite volume advection of tracers. The reddish fluid will be in the cell at the end of the timestep." + +Given a piecewise polynomial description of the tracer concentration, the new tracer cell +concentration is the average of the fluid that will be in the cell after a timestep. + +\f{eqnarray} + \int_{x_{i-1/2}}^{x_{i+1/2}} A_i^{n+1} (x) dx = + \int_{x_{i-1/2 - u \Delta t}}^{x_{i+1/2-u\Delta t}} A_i^{n} (x) dx &= \mbox{} \\ + \int_{x_{i-1/2}}^{x_{i+1/2}} A_i^{n} (x) dx - + \int_{x_{i+1/2 - u \Delta t}}^{x_{i+1/2}} A_i^{n} (x) dx &+ + \int_{x_{i-1/2 - u \Delta t}}^{x_{i-1/2}} A_i^{n} (x) dx +\f} + +Fluxes are found by analytically integrating the profile over the distance that is +swept past the face within a timestep. + +\f[ + a_i^n = \frac{1}{\Delta x} \int_{x_{i-1/2}}^{x_{i+1/2}} A_i^n(x) dx +\f] +\f[ + a_i^{n+1} = a_i^n - \frac{\Delta t}{\Delta x} (F_{i+1/2} - F_{i-1/2}) +\f] +\f[ + F_{i+1/2} = \frac{1}{\Delta t} \int_{x_{i+1/2 - u \Delta t}}^{x_{i+1/2}} A_i^n(x) dx +\f] +\f[ + F_{i-1/2} = \frac{1}{\Delta t} \int_{x_{i-1/2 - u \Delta t}}^{x_{i-1/2}} A_i^n(x) dx +\f] + +With piecewise constant profiles, this approach give first order upwind advection. +Higher order polynomials (e.g., parabolas) can give higher order accuracy. + +\section Multidimensional_Tracer_Advection Multidimensional Tracer Advection + +Using "Easter's Pseudo-compressibility" (\cite easter1993), we start with these +basic equations for a tracer \f$\psi\f$: + +\anchor ht-equation +\f[ + \frac{\partial h}{\partial t} + \vec{\nabla} \cdot (\vec{u}h) = 0 \equiv + \frac{\partial h}{\partial t} + \vec{\nabla} \cdot (\vec{U}) +\f] + +\f[ + \frac{\partial}{\partial t} (h \psi) + \vec{\nabla} \cdot (\vec{U}\psi) = 0 +\f] + +\f[ + \frac{\partial \psi}{\partial t} + \vec{u} \cdot \vec{\nabla} \psi = 0 +\f] + +We discretize the first of these equations in space: + +\f[ + \frac{\partial h}{\partial t} = \frac{1}{\Delta x} \left(U_{i-\frac{1}{2},j} - + U_{i+\frac{1}{2},j} \right) + \frac{1}{\Delta y} \left(V_{i, j-\frac{1}{2}} - + V_{i,j+\frac{1}{2}} \right) +\f] + +Using our monotonic one-dimensional flux: + +\f[ + F_{i+\frac{1}{2},j} (\psi) = U_{i+\frac{1}{2},j} \psi_{i+\frac{1}{2},j} +\f] + +we come up with an estimate based only on an update in the \f$x\f$ direction: + +\f[ + \tilde{h}_{i,j} \tilde{\psi}_{i,j} = h^n_{i,j} \psi_{i,j} + \frac{\Delta + t}{\Delta x} \left( F_{i-\frac{1}{2},j} (\psi^n) - F_{i+\frac{1}{2},j} (\psi^n) + \right) +\f] + +\f[ + \tilde{h}_{i,j} = h^n_{i,j} + \frac{\Delta + t}{\Delta x} \left( U_{i-\frac{1}{2},j} - U_{i+\frac{1}{2},j} \right) +\f] + +\f[ + \tilde{\psi}_{i,j} = \frac{\tilde{h}_{i,j} \tilde{\psi}_{i,j}}{\tilde{h}_{i,j}} +\f] + +Next, we update in the \f$y\f$ direction: + +\f[ + h^{n+1}_{i,j} \psi^{n+1}_{i,j} = \tilde{h}_{i,j} \tilde{\psi}_{i,j} + \frac{\Delta + t}{\Delta y} \left( G_{i,j-\frac{1}{2}} (\tilde{\psi}) - G_{i,j+\frac{1}{2}} + (\tilde{\psi}) \right) +\f] + +\f[ + h^{n+1}_{i,j} = \tilde{h}_{i,j} + \frac{\Delta + t}{\Delta y} \left( V_{i,j-\frac{1}{2}} - V_{i,j+\frac{1}{2}} \right) +\f] + +\f[ + \psi^{n+1}_{i,j} = \frac{h^{n+1}_{i,j} \psi^{n+1}_{i,j}}{h^{n+1}_{i,j}} +\f] + +\li This method ensures monotonicity. Strang splitting can reduce directional +splitting error. See \cite easter1993, \cite durran2010 (section 5.9.4), and +\cite russell1981 . + +\li Flux-form pseudo-compressibility advection is based on accumulated mass (or +volume) fluxes, not velocities. + +\li Additional pseudo-compressibility passes can be added to accommodate +transports exceeding cell masses. Extra passes of tracer advection are used in +MOM6 in the small fraction of cells where this is needed. + +\li Explicit layered dynamics time-steps are limited by Doppler-shifted internal +gravity wave speeds or inertial oscillations. +Flow speeds in most of the ocean volume are much smaller than the peak +internal wave speeds so that the advective time-steps can be longer. + +\li Advective mass fluxes in MOM6 are often accumulated over multiple dynamic +steps. The goal is that as we go to higher resolution, this tracer advection will +remain stable at relatively long time-steps, allowing for the inclusion of many +biogeochemical tracers without adding an undue burden in computational cost. + +*/ diff --git a/tracer/_Tracer_fluxes.dox b/tracer/_Tracer_fluxes.dox new file mode 100644 index 0000000000..fe315a56e5 --- /dev/null +++ b/tracer/_Tracer_fluxes.dox @@ -0,0 +1,9 @@ +/*! \page Tracer_Fluxes Tracer Fluxes + +\section section_Tracer_Fluxes Tracer Fluxes + +\section section_River_Runoff River Runoff + +\section section_Ice_Runoff Ice Runoff + +*/ diff --git a/tracer/_Tracer_timestep.dox b/tracer/_Tracer_timestep.dox new file mode 100644 index 0000000000..991578669c --- /dev/null +++ b/tracer/_Tracer_timestep.dox @@ -0,0 +1,31 @@ +/*! \page Tracer_Timestep Tracer Timestep + +\brief Overview of Tracer Timestep + +The MOM6 code handles advection and lateral diffusion of all tracers. For +potential temperature and salinity, it also timesteps the thermodynamics +and vertical mixing (column physics). Since evaporation and precipitation +are handled as volume changes, the layer thicknesses need to be updated: + +\f[ + \frac{\partial h_k}{\partial t} = (P - E)_k +\f] + +The full tracer equation for tracer \f$\theta\f$ is: + +\f[ + \frac{\partial}{\partial t} (h_k\theta_k) + \nabla_s \cdot + (\vec{u}h_k \theta_k) = Q_k^\theta h_k + \frac{1}{h_k} \Delta \left( + \kappa \frac{\partial \theta}{\partial z} \right) + \frac{1}{h_k} + \nabla_s (h_k K \nabla_s \theta) +\f] + +Here, the advection is on the left hand side of the equation while the +right hand side contains thermodynamic processes, vertical diffusion, and +horizontal diffusion. There is more than one choice for vertical diffusion; +these will be described elsewhere. Also, the lateral diffusion is handled +in novel ways so as to avoid introduction of new extrema and to avoid +instabilities associated with rotated mixing tensors. The lateral diffusion +is described in \ref Horizontal_Diffusion. + +*/ diff --git a/tracer/_Vertical_diffusion.dox b/tracer/_Vertical_diffusion.dox new file mode 100644 index 0000000000..14a23bb042 --- /dev/null +++ b/tracer/_Vertical_diffusion.dox @@ -0,0 +1,9 @@ +/*! \page Vertical_Diffusion Vertical Diffusion + +\brief Vertical diffusion of tracers + +The MOM6 tracer registry takes care of the tracer advection as well as horizontal +diffusion, but it is up to each individual tracer package to define its own vertical +diffusion. + +*/ diff --git a/tracer/advection_test_tracer.F90 b/tracer/advection_test_tracer.F90 new file mode 100644 index 0000000000..d8eb4d57fb --- /dev/null +++ b/tracer/advection_test_tracer.F90 @@ -0,0 +1,386 @@ +!> This tracer package is used to test advection schemes +module advection_test_tracer + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : slasher, vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public register_advection_test_tracer, initialize_advection_test_tracer +public advection_test_tracer_surface_state, advection_test_tracer_end +public advection_test_tracer_column_physics, advection_test_stock + +integer, parameter :: NTR = 11 !< The number of tracers in this module. + +!> The control structure for the advect_test_tracer module +type, public :: advection_test_tracer_CS ; private + integer :: ntr = NTR !< Number of tracers in this module + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + character(len=200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine [conc] + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out [conc] + logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. + logical :: tracers_may_reinit !< If true, the tracers may be set up via the initialization code if + !! they are not found in the restart files. Otherwise it is a fatal error + !! if the tracers are not found in the restart files of a restarted run. + real :: x_origin !< Starting x-position of the tracer [m] or [km] or [degrees_E] + real :: x_width !< Initial size in the x-direction of the tracer patch [m] or [km] or [degrees_E] + real :: y_origin !< Starting y-position of the tracer [m] or [km] or [degrees_N] + real :: y_width !< Initial size in the y-direction of the tracer patch [m] or [km] or [degrees_N] + + integer, dimension(NTR) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and + !! the surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure. + + type(vardesc) :: tr_desc(NTR) !< Descriptions and metadata for the tracers +end type advection_test_tracer_CS + +contains + +!> Register tracer fields and subroutines to be used with MOM. +function register_advection_test_tracer(G, GV, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + + ! Local variables + character(len=80) :: name, longname + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "advection_test_tracer" ! This module's name. + character(len=200) :: inputdir ! The directory where the input file can be found + character(len=48) :: flux_units ! The units for tracer fluxes, usually + ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to a tracer array [conc] + logical :: register_advection_test_tracer + integer :: isd, ied, jsd, jed, nz, m + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "register_advection_test_tracer called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "ADVECTION_TEST_X_ORIGIN", CS%x_origin, & + "The x-coordinate of the center of the test-functions.", units=G%x_ax_unit_short, default=0.) + call get_param(param_file, mdl, "ADVECTION_TEST_Y_ORIGIN", CS%y_origin, & + "The y-coordinate of the center of the test-functions.", units=G%y_ax_unit_short, default=0.) + call get_param(param_file, mdl, "ADVECTION_TEST_X_WIDTH", CS%x_width, & + "The x-width of the test-functions.", units=G%x_ax_unit_short, default=0.) + call get_param(param_file, mdl, "ADVECTION_TEST_Y_WIDTH", CS%y_width, & + "The y-width of the test-functions.", units=G%y_ax_unit_short, default=0.) + call get_param(param_file, mdl, "ADVECTION_TEST_TRACER_IC_FILE", CS%tracer_IC_file, & + "The name of a file from which to read the initial "//& + "conditions for the tracers, or blank to initialize "//& + "them internally.", default=" ") + + if (len_trim(CS%tracer_IC_file) >= 1) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + CS%tracer_IC_file = trim(slasher(inputdir))//trim(CS%tracer_IC_file) + call log_param(param_file, mdl, "INPUTDIR/ADVECTION_TEST_TRACER_IC_FILE", & + CS%tracer_IC_file) + endif + call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified from MOM_initialization.F90.", default=.false.) + + call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if the tracers are not found in the "//& + "restart files of a restarted run.", default=.false.) + + + allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) + + do m=1,NTR + if (m < 10) then ; write(name,'("tr",I1.1)') m + else ; write(name,'("tr",I2.2)') m ; endif + write(longname,'("Concentration of Tracer ",I2.2)') m + CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" + else ; flux_units = "kg s-1" ; endif + + + ! This is needed to force the compiler not to do a copy in the registration + ! calls. Curses on the designers and implementers of Fortran90. + tr_ptr => CS%tr(:,:,:,m) + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, G%HI, GV, & + name=name, longname=longname, units="kg kg-1", & + registry_diags=.true., flux_units=flux_units, & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + + ! Set coupled_tracers to be true (hard-coded above) to provide the surface + ! values to the coupler (if any). This is meta-code and its arguments will + ! currently (deliberately) give fatal errors if it is used. + if (CS%coupled_tracers) & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(name)//'_flux', & + flux_type=' ', implementation=' ', caller="register_advection_test_tracer") + enddo + + CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS + register_advection_test_tracer = .true. +end function register_advection_test_tracer + +!> Initializes the NTR tracer fields in tr(:,:,:,:) and it sets up the tracer output. +subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS, & + sponge_CSp) + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + + ! Local variables + character(len=16) :: name ! A variable's name in a NetCDF file. + real :: locx, locy ! x- and y- positions relative to the center of the tracer patch + ! normalized by its size [nondim] + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m + integer :: IsdB, IedB, JsdB, JedB + + if (.not.associated(CS)) return + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + h_neglect = GV%H_subroundoff + + CS%diag => diag + CS%ntr = NTR + do m=1,NTR + call query_vardesc(CS%tr_desc(m), name=name, & + caller="initialize_advection_test_tracer") + if ((.not.restart) .or. (CS%tracers_may_reinit .and. .not. & + query_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp))) then + do k=1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = 0.0 + enddo ; enddo ; enddo + k=1 ! Square wave + do j=js,je ; do i=is,ie + if (abs(G%geoLonT(i,j)-CS%x_origin)<0.5*CS%x_width .and. & + abs(G%geoLatT(i,j)-CS%y_origin)<0.5*CS%y_width) CS%tr(i,j,k,m) = 1.0 + enddo ; enddo + k=2 ! Triangle wave + do j=js,je ; do i=is,ie + locx = abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width + locy = abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width + CS%tr(i,j,k,m) = max(0.0, 1.0-locx)*max(0.0, 1.0-locy) + enddo ; enddo + k=3 ! Cosine bell + do j=js,je ; do i=is,ie + locx = min(1.0, abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width) * (acos(0.0)*2.) + locy = min(1.0, abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width) * (acos(0.0)*2.) + CS%tr(i,j,k,m) = (1.0+cos(locx))*(1.0+cos(locy))*0.25 + enddo ; enddo + k=4 ! Cylinder + do j=js,je ; do i=is,ie + locx = abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width + locy = abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width + if (locx**2+locy**2<=1.0) CS%tr(i,j,k,m) = 1.0 + enddo ; enddo + k=5 ! Cut cylinder + do j=js,je ; do i=is,ie + locx = (G%geoLonT(i,j)-CS%x_origin)/CS%x_width + locy = (G%geoLatT(i,j)-CS%y_origin)/CS%y_width + if (locx**2+locy**2<=1.0) CS%tr(i,j,k,m) = 1.0 + if (locx>0.0 .and. abs(locy)<0.2) CS%tr(i,j,k,m) = 0.0 + enddo ; enddo + + call set_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp) + endif ! restart + enddo + + +end subroutine initialize_advection_test_tracer + + +!> Applies diapycnal diffusion and any other column tracer physics or chemistry to the tracers +!! from this package. This is a simple example of a set of advected passive tracers. +subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [H ~> m or kg m-2] +! This subroutine applies diapycnal diffusion and any other column +! tracer physics or chemistry to the tracers from this file. +! This is a simple example of a set of advected passive tracers. + +! The arguments to this subroutine are redundant in that +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + integer :: i, j, k, is, ie, js, je, nz, m + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,CS%ntr + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + else + do m=1,NTR + call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + endif + +end subroutine advection_test_tracer_column_physics + +!> This subroutine extracts the surface fields from this tracer package that +!! are to be shared with the atmosphere in coupled configurations. +!! This particular tracer package does not report anything back to the coupler. +subroutine advection_test_tracer_surface_state(sfc_state, h, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + + ! This particular tracer package does not report anything back to the coupler. + ! The code that is here is just a rough guide for packages that would. + + integer :: m, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (.not.associated(CS)) return + + if (CS%coupled_tracers) then + do m=1,CS%ntr + ! This call loads the surface values into the appropriate array in the + ! coupler-type structure. + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + enddo + endif + +end subroutine advection_test_tracer_surface_state + +!> Calculate the mass-weighted integral of all tracer stocks, returning the number of stocks it has calculated. +!! If the stock_index is present, only the stock corresponding to that coded index is returned. +function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc]. + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock being sought. + integer :: advection_test_stock !< the number of stocks calculated here. + + ! Local variables + integer :: is, ie, js, je, nz, m + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + advection_test_stock = 0 + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + if (present(stock_index)) then ; if (stock_index > 0) then + ! Check whether this stock is available from this routine. + + ! No stocks from this routine are being checked yet. Return 0. + return + endif ; endif + + do m=1,CS%ntr + call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="advection_test_stock") + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) + enddo + advection_test_stock = CS%ntr + +end function advection_test_stock + +!> Deallocate memory associated with this module +subroutine advection_test_tracer_end(CS) + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + if (associated(CS)) then + if (associated(CS%tr)) deallocate(CS%tr) + deallocate(CS) + endif +end subroutine advection_test_tracer_end + +end module advection_test_tracer diff --git a/tracer/boundary_impulse_tracer.F90 b/tracer/boundary_impulse_tracer.F90 new file mode 100644 index 0000000000..17c1f30525 --- /dev/null +++ b/tracer/boundary_impulse_tracer.F90 @@ -0,0 +1,395 @@ +!> Implements a boundary impulse response tracer to calculate Green's functions +module boundary_impulse_tracer + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : register_restart_field, query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public register_boundary_impulse_tracer, initialize_boundary_impulse_tracer +public boundary_impulse_tracer_column_physics, boundary_impulse_tracer_surface_state +public boundary_impulse_stock, boundary_impulse_tracer_end + +!> NTR_MAX is the maximum number of tracers in this module. +integer, parameter :: NTR_MAX = 1 + +!> The control structure for the boundary impulse tracer package +type, public :: boundary_impulse_tracer_CS ; private + integer :: ntr=NTR_MAX !< The number of tracers that are actually used. + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? + logical :: tracers_may_reinit !< If true, boundary_impulse can be initialized if not found in restart file + integer, dimension(NTR_MAX) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + integer :: nkml !< Number of layers in mixed layer + real, dimension(NTR_MAX) :: land_val = -1.0 !< A value to use to fill in tracers over land + real :: remaining_source_time !< How much longer (same units as the timestep) to + !! inject the tracer at the surface [T ~> s] + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the retart control structure + + type(vardesc) :: tr_desc(NTR_MAX) !< Descriptions and metadata for the tracers +end type boundary_impulse_tracer_CS + +contains + +!> Read in runtime options and add boundary impulse tracer to tracer registry +function register_boundary_impulse_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in ) :: HI !< A horizontal index type structure + type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in ) :: param_file !< A structure to parse for run-time parameters + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + + ! Local variables + character(len=40) :: mdl = "boundary_impulse_tracer" ! This module's name. + character(len=48) :: var_name ! The variable's name. + character(len=48) :: flux_units ! The units for tracer fluxes, usually + ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. + ! This include declares and sets the variable "version". +# include "version_variable.h" + real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: rem_time_ptr => NULL() + logical :: register_boundary_impulse_tracer + integer :: isd, ied, jsd, jed, nz, m + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "register_boundary_impulse_tracer called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "IMPULSE_SOURCE_TIME", CS%remaining_source_time, & + "Length of time for the boundary tracer to be injected "//& + "into the mixed layer. After this time has elapsed, the "//& + "surface becomes a sink for the boundary impulse tracer.", & + units="s", default=31536000.0, scale=US%s_to_T) + call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if the tracers are not found in the "//& + "restart files of a restarted run.", default=.false.) + CS%ntr = NTR_MAX + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr), source=0.0) + + CS%nkml = max(GV%nkml,1) + + do m=1,CS%ntr + ! This is needed to force the compiler not to do a copy in the registration + ! calls. Curses on the designers and implementers of Fortran90. + CS%tr_desc(m) = var_desc(trim("boundary_impulse"), "kg kg-1", & + "Boundary impulse tracer", caller=mdl) + if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" + else ; flux_units = "kg s-1" ; endif + + tr_ptr => CS%tr(:,:,:,m) + call query_vardesc(CS%tr_desc(m), name=var_name, caller="register_boundary_impulse_tracer") + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, tr_desc=CS%tr_desc(m), & + registry_diags=.true., flux_units=flux_units, & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + + ! Set coupled_tracers to be true (hard-coded above) to provide the surface + ! values to the coupler (if any). This is meta-code and its arguments will + ! currently (deliberately) give fatal errors if it is used. + if (CS%coupled_tracers) & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(var_name)//'_flux', & + flux_type=' ', implementation=' ', caller="register_boundary_impulse_tracer") + enddo + ! Register remaining source time as a restart field + rem_time_ptr => CS%remaining_source_time + call register_restart_field(rem_time_ptr, "bir_remain_time", & + .not.CS%tracers_may_reinit, restart_CS, & + "Remaining time to apply BIR source", "s", conversion=US%T_to_s) + + CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS + register_boundary_impulse_tracer = .true. + +end function register_boundary_impulse_tracer + +!> Initialize tracer from restart or set to 1 at surface to initialize +subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & + sponge_CSp, tv) + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + ! Local variables + character(len=16) :: name ! A variable's name in a NetCDF file. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m + integer :: IsdB, IedB, JsdB, JedB + + if (.not.associated(CS)) return + if (CS%ntr < 1) return + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + CS%Time => day + CS%diag => diag + name = "boundary_impulse" + + do m=1,CS%ntr + call query_vardesc(CS%tr_desc(m), name=name, caller="initialize_boundary_impulse_tracer") + if ((.not.restart) .or. (.not. query_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp))) then + do k=1,CS%nkml ; do j=jsd,jed ; do i=isd,ied + CS%tr(i,j,k,m) = 1.0 + enddo ; enddo ; enddo + call set_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp) + endif + enddo ! Tracer loop + + if (associated(OBC)) then + ! Steal from updated DOME in the fullness of time. + endif + +end subroutine initialize_boundary_impulse_tracer + +!> Apply source or sink at boundary and do vertical diffusion +subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & + tv, debug, evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + logical, intent(in) :: debug !< If true calculate checksums + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [H ~> m or kg m-2] + +! This subroutine applies diapycnal diffusion and any other column +! tracer physics or chemistry to the tracers from this file. +! This is a simple example of a set of advected passive tracers. + +! The arguments to this subroutine are redundant in that +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + + ! Local variables + integer :: i, j, k, is, ie, js, je, nz, m + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + ! This uses applyTracerBoundaryFluxesInOut, usually in ALE mode + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,1), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,1), G, GV) + else + call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,1), G, GV) + endif + + ! Set surface conditions + do m=1,1 + 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 + CS%remaining_source_time = CS%remaining_source_time-dt + else + do k=1,CS%nkml ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = 0.0 + enddo ; enddo ; enddo + endif + + enddo + +end subroutine boundary_impulse_tracer_column_physics + +!> Calculate total inventory of tracer +!> This function calculates the mass-weighted integral of the boundary impulse, +!! tracer stocks returning the number of stocks it has calculated. If the stock_index +!! is present, only the stock corresponding to that coded index is returned. +function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) + type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in ) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent( out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + character(len=*), dimension(:), intent( out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent( out) :: units !< The units of the stocks calculated. + integer, optional, intent(in ) :: stock_index !< The coded index of a specific stock + !! being sought. + integer :: boundary_impulse_stock !< Return value: the number of stocks calculated here. + + ! Local variables + integer :: m + + boundary_impulse_stock = 0 + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + if (present(stock_index)) then ; if (stock_index > 0) then + ! Check whether this stock is available from this routine. + + ! No stocks from this routine are being checked yet. Return 0. + return + endif ; endif + + do m=1,1 + call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="boundary_impulse_stock") + units(m) = trim(units(m))//" kg" + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) + enddo + + boundary_impulse_stock = CS%ntr + +end function boundary_impulse_stock + +!> This subroutine extracts the surface fields from this tracer package that +!! are to be shared with the atmosphere in coupled configurations. +!! This particular tracer package does not report anything back to the coupler. +subroutine boundary_impulse_tracer_surface_state(sfc_state, h, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + + ! This particular tracer package does not report anything back to the coupler. + ! The code that is here is just a rough guide for packages that would. + + integer :: m, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (.not.associated(CS)) return + + if (CS%coupled_tracers) then + do m=1,CS%ntr + ! This call loads the surface values into the appropriate array in the + ! coupler-type structure. + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + enddo + endif + +end subroutine boundary_impulse_tracer_surface_state + +!> Performs finalization of boundary impulse tracer +subroutine boundary_impulse_tracer_end(CS) + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + if (associated(CS)) then + if (associated(CS%tr)) deallocate(CS%tr) + deallocate(CS) + endif +end subroutine boundary_impulse_tracer_end + +!> \namespace boundary_impulse_tracer +!! +!! \section section_BIT_desc Boundary Impulse Response Tracer and Transit Time Distributions +!! Transit time distributions (TTD) are the Green's function solution of the passive tracer equation between +!! the oceanic surface and interior. The name derives from the idea that the 'age' (e.g. time since last +!! contact with the atmosphere) of a water parcel is best characterized as a distribution of ages +!! because water parcels leaving the surface arrive at a particular interior point at different times. +!! The more commonly used ideal age tracer is the first moment of the TTD, equivalently referred to as the +!! mean age. +!! +!! A boundary impulse response (BIR) is a passive tracer whose surface boundary condition is a rectangle +!! function with width \f$\Delta t\f$. In the case of unsteady flow, multiple BIRs, initiated at different +!! times in the model can be used to infer the transit time distribution or Green's function between +!! the oceanic surface and interior. In the case of steady or cyclostationary flow, a single BIR is +!! sufficient. +!! +!! In the References section, both the theoretical discussion of TTDs and BIRs are listed along with +!! modeling studies which have this used framework in scientific investigations +!! +!! \section section_BIT_params Run-time parameters +!! -DO_BOUNDARY_IMPULSE_TRACER: Enables the boundary impulse tracer model +!! -IMPULSE_SOURCE_TIME: Length of time that the surface layer acts as a source of the BIR tracer +!! +!! \section section_BIT_refs References +!! \subsection TTD and BIR Theory +!! -Holzer, M., and T.M. Hall, 2000: Transit-time and tracer-age distributions in geophysical flows. +!! J. Atmos. Sci., 57, 3539-3558, doi:10.1175/1520-0469(2000)057<3539:TTATAD>2.0.CO;2. +!! -T.W.N. Haine, H. Zhang, D.W. Waugh, M. Holzer, On transit-time distributions in unsteady circulation +!! models, Ocean Modelling, Volume 21, Issues 1–2, 2008, Pages 35-45, ISSN 1463-5003 +!! http://dx.doi.org/10.1016/j.ocemod.2007.11.004. +!! \subsection section_BIT_apps Modelling applications +!! -Peacock, S., and M. Maltrud (2006), Transit-time distributions in a global ocean model, +!! J. Phys. Oceanogr., 36(3), 474–495, doi:10.1175/JPO2860.1. +!! -Maltrud, M., Bryan, F. & Peacock, Boundary impulse response functions in a century-long eddying global +!! ocean simulation, S. Environ Fluid Mech (2010) 10: 275. doi:10.1007/s10652-009-9154-3 +!! +end module boundary_impulse_tracer diff --git a/tracer/dye_example.F90 b/tracer/dye_example.F90 new file mode 100644 index 0000000000..ff2199fc80 --- /dev/null +++ b/tracer/dye_example.F90 @@ -0,0 +1,424 @@ +!> A tracer package for using dyes to diagnose regional flows. +module regional_dyes + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public register_dye_tracer, initialize_dye_tracer +public dye_tracer_column_physics, dye_tracer_surface_state +public dye_stock, regional_dyes_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> The control structure for the regional dyes tracer package +type, public :: dye_tracer_CS ; private + integer :: ntr !< The number of tracers that are actually used. + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + real, allocatable, dimension(:) :: dye_source_minlon !< Minimum longitude of region dye will be + !! injected, in [m] or [km] or [degrees_E] + real, allocatable, dimension(:) :: dye_source_maxlon !< Maximum longitude of region dye will be + !! injected, in [m] or [km] or [degrees_E] + real, allocatable, dimension(:) :: dye_source_minlat !< Minimum latitude of region dye will be + !! injected, in [m] or [km] or [degrees_N] + real, allocatable, dimension(:) :: dye_source_maxlat !< Maximum latitude of region dye will be + !! injected, in [m] or [km] or [degrees_N] + real, allocatable, dimension(:) :: dye_source_mindepth !< Minimum depth of region dye will be injected [Z ~> m]. + real, allocatable, dimension(:) :: dye_source_maxdepth !< Maximum depth of region dye will be injected [Z ~> m]. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine [CU ~> conc] + + integer, allocatable, dimension(:) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure + + type(vardesc), allocatable :: tr_desc(:) !< Descriptions and metadata for the tracers + logical :: tracers_may_reinit = .false. !< If true the tracers may be initialized if not found in a restart file +end type dye_tracer_CS + +contains + +!> This subroutine is used to register tracer fields and subroutines +!! to be used with MOM. +function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(dye_tracer_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and diffusion module. + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control structure + + ! Local variables + character(len=40) :: mdl = "regional_dyes" ! This module's name. + character(len=48) :: var_name ! The variable's name. + character(len=48) :: desc_name ! The variable's descriptor. + ! This include declares and sets the variable "version". +# include "version_variable.h" + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers [CU ~> conc] + logical :: register_dye_tracer + integer :: isd, ied, jsd, jed, nz, m + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "register_dye_tracer called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "NUM_DYE_TRACERS", CS%ntr, & + "The number of dye tracers in this run. Each tracer "//& + "should have a separate region.", default=0) + allocate(CS%dye_source_minlon(CS%ntr), & + CS%dye_source_maxlon(CS%ntr), & + CS%dye_source_minlat(CS%ntr), & + CS%dye_source_maxlat(CS%ntr), & + CS%dye_source_mindepth(CS%ntr), & + CS%dye_source_maxdepth(CS%ntr)) + allocate(CS%ind_tr(CS%ntr)) + allocate(CS%tr_desc(CS%ntr)) + + CS%dye_source_minlon(:) = -1.e30 + call get_param(param_file, mdl, "DYE_SOURCE_MINLON", CS%dye_source_minlon, & + "This is the starting longitude at which we start injecting dyes.", & + units="degrees_E", fail_if_missing=.true.) + ! units=G%x_ax_unit_short, fail_if_missing=.true.) + if (minval(CS%dye_source_minlon(:)) < -1.e29) & + call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MINLON ") + + CS%dye_source_maxlon(:) = -1.e30 + call get_param(param_file, mdl, "DYE_SOURCE_MAXLON", CS%dye_source_maxlon, & + "This is the ending longitude at which we finish injecting dyes.", & + units="degrees_E", fail_if_missing=.true.) + ! units=G%x_ax_unit_short, fail_if_missing=.true.) + if (minval(CS%dye_source_maxlon(:)) < -1.e29) & + call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MAXLON ") + + CS%dye_source_minlat(:) = -1.e30 + call get_param(param_file, mdl, "DYE_SOURCE_MINLAT", CS%dye_source_minlat, & + "This is the starting latitude at which we start injecting dyes.", & + units="degrees_N", fail_if_missing=.true.) + ! units=G%y_ax_unit_short, fail_if_missing=.true.) + if (minval(CS%dye_source_minlat(:)) < -1.e29) & + call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MINLAT ") + + CS%dye_source_maxlat(:) = -1.e30 + call get_param(param_file, mdl, "DYE_SOURCE_MAXLAT", CS%dye_source_maxlat, & + "This is the ending latitude at which we finish injecting dyes.", & + units="degrees_N", fail_if_missing=.true.) + ! units=G%y_ax_unit_short, fail_if_missing=.true.) + if (minval(CS%dye_source_maxlat(:)) < -1.e29) & + call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MAXLAT ") + + CS%dye_source_mindepth(:) = -1.e30 + call get_param(param_file, mdl, "DYE_SOURCE_MINDEPTH", CS%dye_source_mindepth, & + "This is the minimum depth at which we inject dyes.", & + units="m", scale=US%m_to_Z, fail_if_missing=.true.) + if (minval(CS%dye_source_mindepth(:)) < -1.e29*US%m_to_Z) & + call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MINDEPTH") + + CS%dye_source_maxdepth(:) = -1.e30 + call get_param(param_file, mdl, "DYE_SOURCE_MAXDEPTH", CS%dye_source_maxdepth, & + "This is the maximum depth at which we inject dyes.", & + units="m", scale=US%m_to_Z, fail_if_missing=.true.) + if (minval(CS%dye_source_maxdepth(:)) < -1.e29*US%m_to_Z) & + call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MAXDEPTH ") + + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr), source=0.0) + + do m = 1, CS%ntr + write(var_name(:),'(A,I3.3)') "dye",m + write(desc_name(:),'(A,I3.3)') "Dye Tracer ",m + CS%tr_desc(m) = var_desc(trim(var_name), "conc", trim(desc_name), caller=mdl) + + ! This is needed to force the compiler not to do a copy in the registration + ! calls. Curses on the designers and implementers of Fortran90. + tr_ptr => CS%tr(:,:,:,m) + call query_vardesc(CS%tr_desc(m), name=var_name, & + caller="register_dye_tracer") + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + tr_desc=CS%tr_desc(m), registry_diags=.true., & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + + ! Set coupled_tracers to be true (hard-coded above) to provide the surface + ! values to the coupler (if any). This is meta-code and its arguments will + ! currently (deliberately) give fatal errors if it is used. + if (CS%coupled_tracers) & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(var_name)//'_flux', & + flux_type=' ', implementation=' ', caller="register_dye_tracer") + enddo + + CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS + register_dye_tracer = .true. +end function register_dye_tracer + +!> This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) +!! and it sets up the tracer output. +subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_CSp, tv) + logical, intent(in) :: restart !< .true. if the fields have already been + !! read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_dye_tracer. + type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure + !! for the sponges, if they are in use. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + + ! Local variables + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] + real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] + integer :: i, j, k, m + + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + CS%diag => diag + + ! Establish location of source + do j=G%jsc,G%jec + call thickness_to_dz(h, tv, dz, j, G, GV) + do m=1,CS%ntr ; do i=G%isc,G%iec + ! A dye is set dependent on the center of the cell being inside the rectangular box. + if (CS%dye_source_minlon(m) < G%geoLonT(i,j) .and. & + CS%dye_source_maxlon(m) >= G%geoLonT(i,j) .and. & + CS%dye_source_minlat(m) < G%geoLatT(i,j) .and. & + CS%dye_source_maxlat(m) >= G%geoLatT(i,j) .and. & + G%mask2dT(i,j) > 0.0 ) then + z_bot = 0.0 + do k = 1, GV%ke + z_bot = z_bot - dz(i,k) + z_center = z_bot + 0.5*dz(i,k) + if ( z_center > -CS%dye_source_maxdepth(m) .and. & + z_center < -CS%dye_source_mindepth(m) ) then + CS%tr(i,j,k,m) = 1.0 + endif + enddo + endif + enddo ; enddo + enddo + +end subroutine initialize_dye_tracer + +!> This subroutine applies diapycnal diffusion and any other column +!! tracer physics or chemistry to the tracers from this file. +!! This is a simple example of a set of advected passive tracers. +!! The arguments to this subroutine are redundant in that +!! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) +subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, tv, CS, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_dye_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [H ~> m or kg m-2] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] + real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] + integer :: i, j, k, is, ie, js, je, nz, m + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,CS%ntr + do k=1,nz ; do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + else + do m=1,CS%ntr + call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + endif + + do j=js,je + call thickness_to_dz(h_new, tv, dz, j, G, GV) + do m=1,CS%ntr ; do i=is,ie + ! A dye is set dependent on the center of the cell being inside the rectangular box. + if (CS%dye_source_minlon(m) < G%geoLonT(i,j) .and. & + CS%dye_source_maxlon(m) >= G%geoLonT(i,j) .and. & + CS%dye_source_minlat(m) < G%geoLatT(i,j) .and. & + CS%dye_source_maxlat(m) >= G%geoLatT(i,j) .and. & + G%mask2dT(i,j) > 0.0 ) then + z_bot = 0.0 + do k=1,nz + z_bot = z_bot - dz(i,k) + z_center = z_bot + 0.5*dz(i,k) + if ( z_center > -CS%dye_source_maxdepth(m) .and. & + z_center < -CS%dye_source_mindepth(m) ) then + CS%tr(i,j,k,m) = 1.0 + endif + enddo + endif + enddo ; enddo + enddo + +end subroutine dye_tracer_column_physics + +!> This function calculates the mass-weighted integral of all tracer stocks, +!! returning the number of stocks it has calculated. If the stock_index +!! is present, only the stock corresponding to that coded index is returned. +function dye_stock(h, stocks, G, GV, CS, names, units, stock_index) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] + type(dye_tracer_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_dye_tracer. + character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. + integer :: dye_stock !< Return value: the number of stocks + !! calculated here. + + ! Local variables + integer :: m + + dye_stock = 0 + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + if (present(stock_index)) then ; if (stock_index > 0) then + ! Check whether this stock is available from this routine. + + ! No stocks from this routine are being checked yet. Return 0. + return + endif ; endif + + do m=1,CS%ntr + call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="dye_stock") + units(m) = trim(units(m))//" kg" + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) + enddo + dye_stock = CS%ntr + +end function dye_stock + +!> This subroutine extracts the surface fields from this tracer package that +!! are to be shared with the atmosphere in coupled configurations. +!! This particular tracer package does not report anything back to the coupler. +subroutine dye_tracer_surface_state(sfc_state, h, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_dye_tracer. + + ! This particular tracer package does not report anything back to the coupler. + ! The code that is here is just a rough guide for packages that would. + + integer :: m, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (.not.associated(CS)) return + + if (CS%coupled_tracers) then + do m=1,CS%ntr + ! This call loads the surface values into the appropriate array in the + ! coupler-type structure. + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + enddo + endif + +end subroutine dye_tracer_surface_state + +!> Clean up any allocated memory after the run. +subroutine regional_dyes_end(CS) + type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_dye_tracer. + + if (associated(CS)) then + if (associated(CS%tr)) deallocate(CS%tr) + deallocate(CS) + endif +end subroutine regional_dyes_end + +!> \namespace regional_dyes +!! +!! This file contains an example of the code that is needed to set +!! up and use a set (in this case two) of dynamically passive tracers +!! for diagnostic purposes. The tracers here are dye tracers which +!! are set to 1 within the geographical region specified. The depth +!! which a tracer is set is determined by calculating the depth from +!! the seafloor upwards through the column. + +end module regional_dyes diff --git a/tracer/dyed_obc_tracer.F90 b/tracer/dyed_obc_tracer.F90 new file mode 100644 index 0000000000..92e10187a6 --- /dev/null +++ b/tracer/dyed_obc_tracer.F90 @@ -0,0 +1,268 @@ +!> This tracer package dyes flow through open boundaries +module dyed_obc_tracer + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coupler_types, only : atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_hor_index, only : hor_index_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : MOM_restart_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public register_dyed_obc_tracer, initialize_dyed_obc_tracer +public dyed_obc_tracer_column_physics, dyed_obc_tracer_end + +!> The control structure for the dyed_obc tracer package +type, public :: dyed_obc_tracer_CS ; private + integer :: ntr !< The number of tracers that are actually used. + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + character(len=200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? + + integer, allocatable, dimension(:) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure + + type(vardesc), allocatable :: tr_desc(:) !< Descriptions and metadata for the tracers +end type dyed_obc_tracer_CS + +contains + +!> Register tracer fields and subroutines to be used with MOM. +function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(dyed_obc_tracer_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< A pointer to the tracer registry. + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + + ! Local variables + character(len=80) :: name, longname + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "dyed_obc_tracer" ! This module's name. + character(len=200) :: inputdir + character(len=48) :: flux_units ! The units for tracer fluxes, usually + ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. + real, pointer :: tr_ptr(:,:,:) => NULL() + logical :: register_dyed_obc_tracer + integer :: isd, ied, jsd, jed, nz, m + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "dyed_obc_register_tracer called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "NUM_DYE_TRACERS", CS%ntr, & + "The number of dye tracers in this run. Each tracer "//& + "should have a separate boundary segment.", default=0) + allocate(CS%ind_tr(CS%ntr)) + allocate(CS%tr_desc(CS%ntr)) + + call get_param(param_file, mdl, "dyed_obc_TRACER_IC_FILE", CS%tracer_IC_file, & + "The name of a file from which to read the initial "//& + "conditions for the dyed_obc tracers, or blank to initialize "//& + "them internally.", default=" ") + if (len_trim(CS%tracer_IC_file) >= 1) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + CS%tracer_IC_file = trim(inputdir)//trim(CS%tracer_IC_file) + call log_param(param_file, mdl, "INPUTDIR/dyed_obc_TRACER_IC_FILE", & + CS%tracer_IC_file) + endif + + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr), source=0.0) + + do m=1,CS%ntr + write(name,'("dye_",I2.2)') m + write(longname,'("Concentration of dyed_obc Tracer ",I2.2)') m + CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" + else ; flux_units = "kg s-1" ; endif + + ! This is needed to force the compiler not to do a copy in the registration + ! calls. Curses on the designers and implementers of Fortran90. + tr_ptr => CS%tr(:,:,:,m) + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + name=name, longname=longname, units="kg kg-1", & + registry_diags=.true., flux_units=flux_units, & + restart_CS=restart_CS) + + ! Set coupled_tracers to be true (hard-coded above) to provide the surface + ! values to the coupler (if any). This is meta-code and its arguments will + ! currently (deliberately) give fatal errors if it is used. + if (CS%coupled_tracers) & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(name)//'_flux', & + flux_type=' ', implementation=' ', caller="register_dyed_obc_tracer") + enddo + + CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS + register_dyed_obc_tracer = .true. +end function register_dyed_obc_tracer + +!> Initializes the CS%ntr tracer fields in tr(:,:,:,:) and sets up the tracer output. +subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< Structure specifying open boundary options. + type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to dyed_obc_register_tracer. + +! Local variables + character(len=24) :: name ! A variable's name in a NetCDF file. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m + integer :: IsdB, IedB, JsdB, JedB + + if (.not.associated(CS)) return + if (CS%ntr < 1) return + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + h_neglect = GV%H_subroundoff + + CS%Time => day + CS%diag => diag + + if (.not.restart) then + if (len_trim(CS%tracer_IC_file) >= 1) then + ! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & + call MOM_error(FATAL, "dyed_obc_initialize_tracer: Unable to open "// & + CS%tracer_IC_file) + do m=1,CS%ntr + call query_vardesc(CS%tr_desc(m), name, caller="initialize_dyed_obc_tracer") + call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) + enddo + else + do m=1,CS%ntr + do k=1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = 0.0 + enddo ; enddo ; enddo + enddo + endif + endif ! restart + +end subroutine initialize_dyed_obc_tracer + +!> This subroutine applies diapycnal diffusion and any other column +!! tracer physics or chemistry to the tracers from this file. +!! This is a simple example of a set of advected passive tracers. +!! +!! The arguments to this subroutine are redundant in that +!! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) +subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to dyed_obc_register_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [H ~> m or kg m-2] + +! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + integer :: i, j, k, is, ie, js, je, nz, m + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,CS%ntr + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + if (nz > 1) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + else + do m=1,CS%ntr + if (nz > 1) call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + endif + +end subroutine dyed_obc_tracer_column_physics + +!> Clean up memory allocations, if any. +subroutine dyed_obc_tracer_end(CS) + type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to dyed_obc_register_tracer. + + if (associated(CS)) then + if (associated(CS%tr)) deallocate(CS%tr) + + deallocate(CS) + endif +end subroutine dyed_obc_tracer_end + +!> \namespace dyed_obc_tracer +!! +!! By Kate Hedstrom, 2017, copied from DOME tracers and also +!! dye_example. +!! +!! This file contains an example of the code that is needed to set +!! up and use a set of dynamically passive tracers. These tracers +!! dye the inflowing water, one per open boundary segment. +!! +!! A single subroutine is called from within each file to register +!! each of the tracers for reinitialization and advection and to +!! register the subroutine that initializes the tracers and set up +!! their output and the subroutine that does any tracer physics or +!! chemistry along with diapycnal mixing (included here because some +!! tracers may float or swim vertically or dye diapycnal processes). + +end module dyed_obc_tracer diff --git a/tracer/ideal_age_example.F90 b/tracer/ideal_age_example.F90 new file mode 100644 index 0000000000..8492437cb6 --- /dev/null +++ b/tracer/ideal_age_example.F90 @@ -0,0 +1,626 @@ +!> A tracer package of ideal age tracers +module ideal_age_example + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_interface_heights, only : thickness_to_dz +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type, time_type_to_real +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public register_ideal_age_tracer, initialize_ideal_age_tracer +public ideal_age_tracer_column_physics, ideal_age_tracer_surface_state +public ideal_age_stock, ideal_age_example_end +public count_BL_layers + +integer, parameter :: NTR_MAX = 4 !< the maximum number of tracers in this module. + +!> The control structure for the ideal_age_tracer package +type, public :: ideal_age_tracer_CS ; private + integer :: ntr !< The number of tracers that are actually used. + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + integer :: nkbl !< The number of layers in the boundary layer. The ideal + !1 age tracers are reset in the top nkbl layers. + character(len=200) :: IC_file !< The file in which the age-tracer initial values + !! can be found, or an empty string for internal initialization. + logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package [years] or other units + real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value [years] or other units + real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface [years] or other units + real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out [years] or other units + real, dimension(NTR_MAX) :: growth_rate !< The exponential growth rate for the young value [year-1] + real, dimension(NTR_MAX) :: tracer_start_year !< The year in which tracers start aging, or at which the + !! surface value equals young_val [years]. + logical :: use_real_BL_depth !< If true, uses the BL scheme to determine the number of + !! layers above the BL depth instead of the fixed nkbl value. + integer :: BL_residence_num !< The tracer number assigned to the BL residence tracer in this module + logical :: tracers_may_reinit !< If true, these tracers be set up via the initialization code if + !! they are not found in the restart files. + logical :: tracer_ages(NTR_MAX) !< Indicates whether each tracer ages. + + integer, dimension(NTR_MAX) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart controls structure + + type(vardesc) :: tr_desc(NTR_MAX) !< Descriptions and metadata for the tracers + +end type ideal_age_tracer_CS + +contains + +!> Register the ideal age tracer fields to be used with MOM. +function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "ideal_age_example" ! This module's name. + character(len=200) :: inputdir ! The directory where the input files are. + character(len=48) :: var_name ! The variable's name. + real, pointer :: tr_ptr(:,:,:) => NULL() + logical :: register_ideal_age_tracer + logical :: do_ideal_age, do_vintage, do_ideal_age_dated, do_BL_residence + integer :: isd, ied, jsd, jed, nz, m + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "register_ideal_age_tracer called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DO_IDEAL_AGE", do_ideal_age, & + "If true, use an ideal age tracer that is set to 0 age "//& + "in the boundary layer and ages at unit rate in the interior.", & + default=.true.) + call get_param(param_file, mdl, "DO_IDEAL_VINTAGE", do_vintage, & + "If true, use an ideal vintage tracer that is set to an "//& + "exponentially increasing value in the boundary layer and "//& + "is conserved thereafter.", default=.false.) + call get_param(param_file, mdl, "DO_IDEAL_AGE_DATED", do_ideal_age_dated, & + "If true, use an ideal age tracer that is everywhere 0 "//& + "before IDEAL_AGE_DATED_START_YEAR, but the behaves like "//& + "the standard ideal age tracer - i.e. is set to 0 age in "//& + "the boundary layer and ages at unit rate in the interior.", & + default=.false.) + call get_param(param_file, mdl, "DO_BL_RESIDENCE", do_BL_residence, & + "If true, use a residence tracer that is set to 0 age "//& + "in the interior and ages at unit rate in the boundary layer.", & + default=.false.) + call get_param(param_file, mdl, "USE_REAL_BL_DEPTH", CS%use_real_BL_depth, & + "If true, the ideal age tracers will use the boundary layer "//& + "depth diagnosed from the BL or bulkmixedlayer scheme.", & + default=.false.) + call get_param(param_file, mdl, "AGE_IC_FILE", CS%IC_file, & + "The file in which the age-tracer initial values can be "//& + "found, or an empty string for internal initialization.", & + default=" ") + if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then + ! Add the directory if CS%IC_file is not already a complete path. + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) + call log_param(param_file, mdl, "INPUTDIR/AGE_IC_FILE", CS%IC_file) + endif + call get_param(param_file, mdl, "AGE_IC_FILE_IS_Z", CS%Z_IC_file, & + "If true, AGE_IC_FILE is in depth space, not layer space", & + default=.false.) + call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if the tracers are not found in the "//& + "restart files of a restarted run.", default=.false.) + + CS%ntr = 0 + if (do_ideal_age) then + CS%ntr = CS%ntr + 1 ; m = CS%ntr + CS%tr_desc(m) = var_desc("age", "yr", "Ideal Age Tracer", cmor_field_name="agessc", caller=mdl) + CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 + CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 + endif + + if (do_vintage) then + CS%ntr = CS%ntr + 1 ; m = CS%ntr + CS%tr_desc(m) = var_desc("vintage", "yr", "Exponential Vintage Tracer", & + caller=mdl) + CS%tracer_ages(m) = .false. ; CS%growth_rate(m) = 1.0/30.0 + CS%IC_val(m) = 0.0 ; CS%young_val(m) = 1e-20 ; CS%tracer_start_year(m) = 0.0 + call get_param(param_file, mdl, "IDEAL_VINTAGE_START_YEAR", CS%tracer_start_year(m), & + "The date at which the ideal vintage tracer starts.", & + units="years", default=0.0) + endif + + if (do_ideal_age_dated) then + CS%ntr = CS%ntr + 1 ; m = CS%ntr + CS%tr_desc(m) = var_desc("age_dated","yr","Ideal Age Tracer with a Start Date",& + caller=mdl) + CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 + CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 + call get_param(param_file, mdl, "IDEAL_AGE_DATED_START_YEAR", CS%tracer_start_year(m), & + "The date at which the dated ideal age tracer starts.", & + units="years", default=0.0) + endif + + CS%BL_residence_num = 0 + if (do_BL_residence) then + CS%ntr = CS%ntr + 1 ; m = CS%ntr; CS%BL_residence_num = CS%ntr + CS%tr_desc(m) = var_desc("BL_age", "yr", "BL Residence Time Tracer", caller=mdl) + CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 + CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 + endif + + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr), source=0.0) + + do m=1,CS%ntr + ! This is needed to force the compiler not to do a copy in the registration + ! calls. Curses on the designers and implementers of Fortran90. + tr_ptr => CS%tr(:,:,:,m) + call query_vardesc(CS%tr_desc(m), name=var_name, & + caller="register_ideal_age_tracer") + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, tr_desc=CS%tr_desc(m), & + registry_diags=.true., restart_CS=restart_CS, & + mandatory=.not.CS%tracers_may_reinit, & + flux_scale=GV%H_to_m) + + ! Set coupled_tracers to be true (hard-coded above) to provide the surface + ! values to the coupler (if any). This is meta-code and its arguments will + ! currently (deliberately) give fatal errors if it is used. + if (CS%coupled_tracers) & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(var_name)//'_flux', & + flux_type=' ', implementation=' ', caller="register_ideal_age_tracer") + enddo + + CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS + register_ideal_age_tracer = .true. +end function register_ideal_age_tracer + +!> Sets the ideal age traces to their initial values and sets up the tracer output +subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & + sponge_CSp) + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + +! This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) +! and it sets up the tracer output. + + ! Local variables + character(len=24) :: name ! A variable's name in a NetCDF file. + logical :: OK + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m + integer :: IsdB, IedB, JsdB, JedB + logical :: use_real_BL_depth + + if (.not.associated(CS)) return + if (CS%ntr < 1) return + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + CS%Time => day + CS%diag => diag + CS%nkbl = max(GV%nkml,1) + + do m=1,CS%ntr + call query_vardesc(CS%tr_desc(m), name=name, & + caller="initialize_ideal_age_tracer") + if ((.not.restart) .or. (CS%tracers_may_reinit .and. .not. & + query_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp))) then + + if (len_trim(CS%IC_file) > 0) then + ! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%IC_file, G%Domain)) & + call MOM_error(FATAL, "initialize_ideal_age_tracer: "// & + "Unable to open "//CS%IC_file) + + if (CS%Z_IC_file) then + OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, name,& + G, GV, US, -1e34, 0.0) ! CS%land_val(m)) + if (.not.OK) then + OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, & + trim(name), G, GV, US, -1e34, 0.0) ! CS%land_val(m)) + if (.not.OK) call MOM_error(FATAL,"initialize_ideal_age_tracer: "//& + "Unable to read "//trim(name)//" from "//& + trim(CS%IC_file)//".") + endif + else + call MOM_read_data(CS%IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) + endif + else + do k=1,nz ; do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) < 0.5) then + CS%tr(i,j,k,m) = CS%land_val(m) + else + CS%tr(i,j,k,m) = CS%IC_val(m) + endif + enddo ; enddo ; enddo + endif + + call set_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp) + endif ! restart + enddo ! Tracer loop + + if (associated(OBC)) then + ! Steal from updated DOME in the fullness of time. + endif + +end subroutine initialize_ideal_age_tracer + +!> Applies diapycnal diffusion, aging and regeneration at the surface to the ideal age tracers +subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, tv, CS, & + evap_CFL_limit, minimum_forcing_depth, Hbl) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: Hbl !< Boundary layer depth [Z ~> m] + +! This subroutine applies diapycnal diffusion and any other column +! tracer physics or chemistry to the tracers from this file. +! This is a simple example of a set of advected passive tracers. + +! The arguments to this subroutine are redundant in that +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: BL_layers ! Stores number of layers in boundary layer [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real :: young_val ! The "young" value for the tracers [years] or other units + real :: Isecs_per_year ! The inverse of the amount of time in a year [T-1 ~> s-1] + real :: year ! The time in years [years] + real :: layer_frac ! The fraction of the current layer that is within the mixed layer [nondim] + integer :: i, j, k, is, ie, js, je, nz, m, nk + character(len=255) :: msg + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (CS%use_real_BL_depth .and. .not. present(Hbl)) then + call MOM_error(FATAL,"Attempting to use real boundary layer depth for ideal age tracers, & + but no valid boundary layer scheme was found") + endif + + if (CS%use_real_BL_depth .and. present(Hbl)) then + call count_BL_layers(G, GV, h_old, Hbl, tv, BL_layers) + endif + + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,CS%ntr + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + else + do m=1,CS%ntr + call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + endif + + Isecs_per_year = 1.0 / (365.0*86400.0*US%s_to_T) + ! Set the surface value of tracer 1 to increase exponentially + ! with a 30 year time scale. + year = US%s_to_T*time_type_to_real(CS%Time) * Isecs_per_year + + do m=1,CS%ntr + + if (CS%growth_rate(m) == 0.0) then + young_val = CS%young_val(m) + else + young_val = CS%young_val(m) * & + exp((year-CS%tracer_start_year(m)) * CS%growth_rate(m)) + endif + + if (m == CS%BL_residence_num) then + + if (CS%use_real_BL_depth) then + do j=js,je ; do i=is,ie + nk = floor(BL_layers(i,j)) + + do k=1,nk + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + + k = MIN(nk+1,nz) + + if (G%mask2dT(i,j) > 0.0) then + layer_frac = BL_layers(i,j)-nk + CS%tr(i,j,k,m) = layer_frac * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & + *Isecs_per_year) + (1.-layer_frac) * young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + + + do k=nk+2,nz + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + enddo ; enddo + + else ! use real BL depth + do j=js,je ; do i=is,ie + do k=1,CS%nkbl + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + + do k=CS%nkbl+1,nz + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + enddo ; enddo + + endif ! use real BL depth + + else ! if BL residence tracer + + if (CS%use_real_BL_depth) then + do j=js,je ; do i=is,ie + nk = floor(BL_layers(i,j)) + do k=1,nk + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + + k = MIN(nk+1,nz) + if (G%mask2dT(i,j) > 0.0) then + layer_frac = BL_layers(i,j)-nk + CS%tr(i,j,k,m) = (1.-layer_frac) * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & + *Isecs_per_year) + layer_frac * young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + + do k=nk+2,nz + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + enddo ; enddo + + else ! use real BL depth + do k=1,CS%nkbl ; do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo ; enddo ; enddo + + if (CS%tracer_ages(m) .and. (year>=CS%tracer_start_year(m))) then + !$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) + do k=CS%nkbl+1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + enddo ; enddo ; enddo + endif + + + endif ! if use real BL depth + endif ! if BL residence tracer + + enddo ! loop over all tracers + +end subroutine ideal_age_tracer_column_physics + +!> Calculates the mass-weighted integral of all tracer stocks, returning the number of stocks it +!! has calculated. If stock_index is present, only the stock corresponding to that coded index is found. +function ideal_age_stock(h, stocks, G, GV, CS, names, units, stock_index) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc]. + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. + integer :: ideal_age_stock !< The number of stocks calculated here. + + ! Local variables + integer :: m + + ideal_age_stock = 0 + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + if (present(stock_index)) then ; if (stock_index > 0) then + ! Check whether this stock is available from this routine. + + ! No stocks from this routine are being checked yet. Return 0. + return + endif ; endif + + do m=1,CS%ntr + call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="ideal_age_stock") + units(m) = trim(units(m))//" kg" + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) + enddo + ideal_age_stock = CS%ntr + +end function ideal_age_stock + +!> This subroutine extracts the surface fields from this tracer package that +!! are to be shared with the atmosphere in coupled configurations. +!! This particular tracer package does not report anything back to the coupler. +subroutine ideal_age_tracer_surface_state(sfc_state, h, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + + ! This particular tracer package does not report anything back to the coupler. + ! The code that is here is just a rough guide for packages that would. + + integer :: m, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (.not.associated(CS)) return + + if (CS%coupled_tracers) then + do m=1,CS%ntr + ! This call loads the surface values into the appropriate array in the + ! coupler-type structure. + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + enddo + endif + +end subroutine ideal_age_tracer_surface_state + +!> Deallocate any memory associated with this tracer package +subroutine ideal_age_example_end(CS) + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + + if (associated(CS)) then + if (associated(CS%tr)) deallocate(CS%tr) + deallocate(CS) + endif +end subroutine ideal_age_example_end + +subroutine count_BL_layers(G, GV, h, Hbl, tv, BL_layers) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hbl !< Boundary layer depth [Z ~> m] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BL_layers !< Number of model layers in the boundary layer [nondim] + + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: current_depth ! Distance from the free surface [Z ~> m] + integer :: i, j, k, is, ie, js, je, nz, m, nk + character(len=255) :: msg + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + BL_layers(:,:) = 0. + do j=js,je + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=is,ie + current_depth = 0. + do k=1,nz + current_depth = current_depth + dz(i,k) + if (Hbl(i,j) <= current_depth) then + BL_layers(i,j) = BL_layers(i,j) + (1.0 - (current_depth - Hbl(i,j)) / dz(i,k)) + exit + else + BL_layers(i,j) = BL_layers(i,j) + 1.0 + endif + enddo + enddo + enddo + +end subroutine count_BL_layers + +!> \namespace ideal_age_example +!! +!! Originally by Robert Hallberg, 2002 +!! +!! This file contains an example of the code that is needed to set +!! up and use a set (in this case two) of dynamically passive tracers +!! for diagnostic purposes. The tracers here are an ideal age tracer +!! that ages at a rate of 1/year once it is isolated from the surface, +!! and a vintage tracer, whose surface concentration grows exponen- +!! with time with a 30-year timescale (similar to CFCs). + +end module ideal_age_example diff --git a/tracer/nw2_tracers.F90 b/tracer/nw2_tracers.F90 new file mode 100644 index 0000000000..3c8fbe4ae8 --- /dev/null +++ b/tracer/nw2_tracers.F90 @@ -0,0 +1,319 @@ +!> Ideal tracers designed to help diagnose a tracer diffusivity tensor in NeverWorld2 +module nw2_tracers + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_time_manager, only : time_type, time_type_to_real +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public register_nw2_tracers +public initialize_nw2_tracers +public nw2_tracer_column_physics +public nw2_tracers_end + +!> The control structure for the nw2_tracers package +type, public :: nw2_tracers_CS ; private + integer :: ntr = 0 !< The number of tracers that are actually used. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in g m-3? + real, allocatable , dimension(:) :: restore_rate !< The rate at which the tracer is damped toward + !! its target profile [T-1 ~> s-1] + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart controls structure +end type nw2_tracers_CS + +contains + +!> Register the NW2 tracer fields to be used with MOM. +logical function register_nw2_tracers(HI, GV, US, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(nw2_tracers_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_nw2_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "nw2_tracers" ! This module's name. + character(len=8) :: var_name ! The variable's name. + real, pointer :: tr_ptr(:,:,:) => NULL() + integer :: isd, ied, jsd, jed, nz, m, ig + integer :: n_groups ! Number of groups of three tracers (i.e. # tracers/3) + real, allocatable, dimension(:) :: timescale_in_days ! Damping timescale [days] + type(vardesc) :: tr_desc ! Descriptions and metadata for the tracers + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "register_nw2_tracer called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "NW2_TRACER_GROUPS", n_groups, & + "The number of tracer groups where a group is of three tracers "//& + "initialized and restored to sin(x), y and z, respectively. Each "//& + "group is restored with an independent restoration rate.", & + default=3) + allocate(timescale_in_days(n_groups)) + timescale_in_days = (/365., 730., 1460./) + call get_param(param_file, mdl, "NW2_TRACER_RESTORE_TIMESCALE", timescale_in_days, & + "A list of timescales, one for each tracer group.", & + units="days") + + CS%ntr = 3 * n_groups + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr), source=0.0) + allocate(CS%restore_rate(CS%ntr)) + + do m=1,CS%ntr + write(var_name(1:8),'(a6,i2.2)') 'tracer',m + tr_desc = var_desc(var_name, "1", "Ideal Tracer", caller=mdl) + ! This is needed to force the compiler not to do a copy in the registration + ! calls. Curses on the designers and implementers of Fortran90. + tr_ptr => CS%tr(:,:,:,m) + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, tr_desc=tr_desc, & + registry_diags=.true., restart_CS=restart_CS, mandatory=.false.) + ig = int( (m+2)/3 ) ! maps (1,2,3)->1, (4,5,6)->2, ... + CS%restore_rate(m) = 1.0 / ( timescale_in_days(ig) * 86400.0*US%s_to_T ) + enddo + + CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS + register_nw2_tracers = .true. +end function register_nw2_tracers + +!> Sets the NW2 traces to their initial values and sets up the tracer output +subroutine initialize_nw2_tracers(restart, day, G, GV, US, h, tv, diag, CS) + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(nw2_tracers_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_nw2_tracer. + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Vertical extent of layers [Z ~> m] + real :: rscl ! z* scaling factor [nondim] + character(len=8) :: var_name ! The variable's name. + integer :: i, j, k, m + + if (.not.associated(CS)) return + + CS%Time => day + CS%diag => diag + + ! Calculate z* interface positions + call thickness_to_dz(h, tv, dz, G, GV, US) + + if (GV%Boussinesq) then + ! First calculate interface positions in z-space (m) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + eta(i,j,GV%ke+1) = - G%mask2dT(i,j) * G%bathyT(i,j) + enddo ; enddo + do k=GV%ke,1,-1 ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) + enddo ; enddo ; enddo + ! Re-calculate for interface positions in z*-space (m) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (G%bathyT(i,j)>0.) then + rscl = G%bathyT(i,j) / ( eta(i,j,1) + G%bathyT(i,j) ) + do K=GV%ke, 1, -1 + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) * rscl + enddo + endif + enddo ; enddo + else + call MOM_error(FATAL, "NW2 tracers assume Boussinesq mode") + endif + + do m=1,CS%ntr + ! Initialize only if this is not a restart or we are using a restart + ! in which the tracers were not present + write(var_name(1:8),'(a6,i2.2)') 'tracer',m + if ((.not.restart) .or. & + (.not. query_initialized(CS%tr(:,:,:,m), var_name, CS%restart_CSp))) then + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + CS%tr(i,j,k,m) = nw2_tracer_dist(m, G, GV, eta, i, j, k) + enddo ; enddo ; enddo + call set_initialized(CS%tr(:,:,:,m), var_name, CS%restart_CSp) + endif ! restart + enddo ! Tracer loop + +end subroutine initialize_nw2_tracers + +!> Applies diapycnal diffusion, aging and regeneration at the surface to the NW2 tracers +subroutine nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, tv, CS, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(nw2_tracers_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_nw2_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [H ~> m or kg m-2] +! This subroutine applies diapycnal diffusion and any other column +! tracer physics or chemistry to the tracers from this file. +! This is a simple example of a set of advected passive tracers. + +! The arguments to this subroutine are redundant in that +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Vertical extent of layers [Z ~> m] + integer :: i, j, k, m + real :: dt_x_rate ! dt * restoring rate [nondim] + real :: rscl ! z* scaling factor [nondim] + real :: target_value ! tracer value + +! if (.not.associated(CS)) return + + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,CS%ntr + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + else + do m=1,CS%ntr + call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + endif + + ! Calculate z* interface positions + call thickness_to_dz(h_new, tv, dz, G, GV, US) + + if (GV%Boussinesq) then + ! First calculate interface positions in z-space [Z ~> m] + do j=G%jsc,G%jec ; do i=G%isc,G%iec + eta(i,j,GV%ke+1) = - G%mask2dT(i,j) * G%bathyT(i,j) + enddo ; enddo + do k=GV%ke,1,-1 ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) + enddo ; enddo ; enddo + ! Re-calculate for interface positions in z*-space [Z ~> m] + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (G%bathyT(i,j)>0.) then + rscl = G%bathyT(i,j) / ( eta(i,j,1) + G%bathyT(i,j) ) + do K=GV%ke, 1, -1 + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) * rscl + enddo + endif + enddo ; enddo + else + call MOM_error(FATAL, "NW2 tracers assume Boussinesq mode") + endif + + do m=1,CS%ntr + dt_x_rate = dt * CS%restore_rate(m) + !$OMP parallel do default(shared) private(target_value) + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + target_value = nw2_tracer_dist(m, G, GV, eta, i, j, k) + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j) * dt_x_rate * ( target_value - CS%tr(i,j,k,m) ) + enddo ; enddo ; enddo + enddo + +end subroutine nw2_tracer_column_physics + +!> The target value of a NeverWorld2 tracer label m at non-dimensional +!! position x=lon/Lx, y=lat/Ly, z=eta/H +real function nw2_tracer_dist(m, G, GV, eta, i, j, k) + integer, intent(in) :: m !< Indicates the NW2 tracer + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(in) :: eta !< Interface position [Z ~> m] + integer, intent(in) :: i !< Cell index i + integer, intent(in) :: j !< Cell index j + integer, intent(in) :: k !< Layer index k + ! Local variables + real :: pi ! 3.1415... [nondim] + real :: x, y, z ! non-dimensional relative positions [nondim] + pi = 2.*acos(0.) + x = ( G%geolonT(i,j) - G%west_lon ) / G%len_lon ! 0 ... 1 + y = -G%geolatT(i,j) / G%south_lat ! -1 ... 1 + z = - 0.5 * ( eta(i,j,K) + eta(i,j,K+1) ) / GV%max_depth ! 0 ... 1 + select case ( mod(m-1,3) ) + case (0) ! sin(2 pi x/L) + nw2_tracer_dist = sin( 2.0 * pi * x ) + case (1) ! y/L + nw2_tracer_dist = y + case (2) ! -z/L + nw2_tracer_dist = -z + case default + stop 'This should not happen. Died in nw2_tracer_dist()!' + end select + nw2_tracer_dist = nw2_tracer_dist * G%mask2dT(i,j) +end function nw2_tracer_dist + +!> Deallocate any memory associated with this tracer package +subroutine nw2_tracers_end(CS) + type(nw2_tracers_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_nw2_tracers. + + if (associated(CS)) then + if (associated(CS%tr)) deallocate(CS%tr) + deallocate(CS) + endif +end subroutine nw2_tracers_end + +!> \namespace nw2_tracers +!! +!! TBD + +end module nw2_tracers diff --git a/tracer/oil_tracer.F90 b/tracer/oil_tracer.F90 new file mode 100644 index 0000000000..40d6f27b44 --- /dev/null +++ b/tracer/oil_tracer.F90 @@ -0,0 +1,500 @@ +!> A tracer package to mimic dissolved oil. +module oil_tracer + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type, time_type_to_real +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public register_oil_tracer, initialize_oil_tracer +public oil_tracer_column_physics, oil_tracer_surface_state +public oil_stock, oil_tracer_end + +integer, parameter :: NTR_MAX = 20 !< the maximum number of tracers in this module. + +!> The control structure for the oil tracer package +type, public :: oil_tracer_CS ; private + integer :: ntr !< The number of tracers that are actually used. + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + character(len=200) :: IC_file !< The file in which the age-tracer initial values + !! can be found, or an empty string for internal initialization. + logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. + real :: oil_source_longitude !< Latitude of source location (geographic) [degrees_N] + real :: oil_source_latitude !< Longitude of source location (geographic) [degrees_E] + integer :: oil_source_i=-999 !< Local i of source location (computational index location) + integer :: oil_source_j=-999 !< Local j of source location (computational index location) + real :: oil_source_rate !< Rate of oil injection [kg T-1 ~> kg s-1] + real :: oil_start_year !< The time at which the oil source starts [years] + real :: oil_end_year !< The time at which the oil source ends [years] + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, [kg m-3] + real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value [kg m-3] + real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out [kg m-3] + real, dimension(NTR_MAX) :: oil_decay_rate !< Decay rate of oil [T-1 ~> s-1] calculated from oil_decay_days + integer, dimension(NTR_MAX) :: oil_source_k !< Layer of source + logical :: oil_may_reinit !< If true, oil tracers may be reset by the initialization code + !! if they are not found in the restart files. + integer, dimension(NTR_MAX) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + type(vardesc) :: tr_desc(NTR_MAX) !< Descriptions and metadata for the tracers + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure +end type oil_tracer_CS + +contains + +!> Register oil tracer fields and subroutines to be used with MOM. +function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(oil_tracer_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + + ! Local variables + character(len=40) :: mdl = "oil_tracer" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + real, dimension(NTR_MAX) :: oil_decay_days !< Decay time scale of oil [days] + character(len=200) :: inputdir ! The directory where the input files are. + character(len=48) :: var_name ! The variable's name. + character(len=3) :: name_tag ! String for creating identifying oils + character(len=48) :: flux_units ! The units for tracer fluxes, here + ! kg(oil) s-1 or kg(oil) m-3 kg(water) s-1. + real, pointer :: tr_ptr(:,:,:) => NULL() + logical :: register_oil_tracer + integer :: isd, ied, jsd, jed, nz, m + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "register_oil_tracer called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "OIL_IC_FILE", CS%IC_file, & + "The file in which the oil tracer initial values can be "//& + "found, or an empty string for internal initialization.", & + default=" ") + if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then + ! Add the directory if CS%IC_file is not already a complete path. + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) + call log_param(param_file, mdl, "INPUTDIR/OIL_IC_FILE", CS%IC_file) + endif + call get_param(param_file, mdl, "OIL_IC_FILE_IS_Z", CS%Z_IC_file, & + "If true, OIL_IC_FILE is in depth space, not layer space", & + default=.false.) + + call get_param(param_file, mdl, "OIL_MAY_REINIT", CS%oil_may_reinit, & + "If true, oil tracers may go through the initialization "//& + "code if they are not found in the restart files. "//& + "Otherwise it is a fatal error if the oil tracers are not "//& + "found in the restart files of a restarted run.", & + default=.false.) + call get_param(param_file, mdl, "OIL_SOURCE_LONGITUDE", CS%oil_source_longitude, & + "The geographic longitude of the oil source.", units="degrees_E", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "OIL_SOURCE_LATITUDE", CS%oil_source_latitude, & + "The geographic latitude of the oil source.", units="degrees_N", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "OIL_SOURCE_LAYER", CS%oil_source_k, & + "The layer into which the oil is introduced, or a "//& + "negative number for a vertically uniform source, "//& + "or 0 not to use this tracer.", units="Layer", default=0) + call get_param(param_file, mdl, "OIL_SOURCE_RATE", CS%oil_source_rate, & + "The rate of oil injection.", & + units="kg s-1", scale=US%T_to_s, default=1.0) + call get_param(param_file, mdl, "OIL_DECAY_DAYS", oil_decay_days, & + "The decay timescale in days (if positive), or no decay "//& + "if 0, or use the temperature dependent decay rate of "//& + "Adcroft et al. (GRL, 2010) if negative.", units="days", & + default=0.0) + call get_param(param_file, mdl, "OIL_DATED_START_YEAR", CS%oil_start_year, & + "The time at which the oil source starts", units="years", & + default=0.0) + call get_param(param_file, mdl, "OIL_DATED_END_YEAR", CS%oil_end_year, & + "The time at which the oil source ends", units="years", & + default=1.0e99) + + CS%ntr = 0 + CS%oil_decay_rate(:) = 0. + do m=1,NTR_MAX + if (CS%oil_source_k(m)/=0) then + write(name_tag(1:3),'("_",I2.2)') m + CS%ntr = CS%ntr + 1 + CS%tr_desc(m) = var_desc("oil"//trim(name_tag), "kg m-3", "Oil Tracer", caller=mdl) + CS%IC_val(m) = 0.0 + if (oil_decay_days(m) > 0.) then + CS%oil_decay_rate(m) = 1. / (86400.0*US%s_to_T * oil_decay_days(m)) + elseif (oil_decay_days(m) < 0.) then + CS%oil_decay_rate(m) = -1. + endif + endif + enddo + call log_param(param_file, mdl, "OIL_DECAY_RATE", CS%oil_decay_rate(1:CS%ntr), & + units="s-1", unscale=US%s_to_T) + + ! This needs to be changed if the units of tracer are changed above. + if (GV%Boussinesq) then ; flux_units = "kg s-1" + else ; flux_units = "kg m-3 kg s-1" ; endif + + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr), source=0.0) + + do m=1,CS%ntr + ! This is needed to force the compiler not to do a copy in the registration + ! calls. Curses on the designers and implementers of Fortran90. + tr_ptr => CS%tr(:,:,:,m) + call query_vardesc(CS%tr_desc(m), name=var_name, caller="register_oil_tracer") + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, tr_desc=CS%tr_desc(m), & + registry_diags=.true., flux_units=flux_units, restart_CS=restart_CS, & + mandatory=.not.CS%oil_may_reinit) + + ! Set coupled_tracers to be true (hard-coded above) to provide the surface + ! values to the coupler (if any). This is meta-code and its arguments will + ! currently (deliberately) give fatal errors if it is used. + if (CS%coupled_tracers) & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(var_name)//'_flux', & + flux_type=' ', implementation=' ', caller="register_oil_tracer") + enddo + + CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS + register_oil_tracer = .true. + +end function register_oil_tracer + +!> Initialize the oil tracers and set up tracer output +subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & + sponge_CSp) + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + + ! Local variables + character(len=16) :: name ! A variable's name in a NetCDF file. + logical :: OK + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m + integer :: IsdB, IedB, JsdB, JedB + + if (.not.associated(CS)) return + if (CS%ntr < 1) return + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + ! Establish location of source + do j=G%jsdB+1,G%jed ; do i=G%isdB+1,G%ied + ! This test for i,j index is specific to a lat/lon (non-rotated grid). + ! and needs to be generalized to work properly on the tri-polar grid. + if (CS%oil_source_longitude=G%geoLonBu(I-1,J) .and. & + CS%oil_source_latitude=G%geoLatBu(I,J-1) ) then + CS%oil_source_i=i + CS%oil_source_j=j + endif + enddo ; enddo + + CS%Time => day + CS%diag => diag + + do m=1,CS%ntr + call query_vardesc(CS%tr_desc(m), name=name, caller="initialize_oil_tracer") + if ((.not.restart) .or. (CS%oil_may_reinit .and. .not. & + query_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp))) then + + if (len_trim(CS%IC_file) > 0) then + ! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%IC_file, G%Domain)) & + call MOM_error(FATAL, "initialize_oil_tracer: Unable to open "//CS%IC_file) + + if (CS%Z_IC_file) then + OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, name, & + G, GV, US, -1e34, 0.0) ! CS%land_val(m)) + if (.not.OK) then + OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, & + trim(name), G, GV, US, -1e34, 0.0) ! CS%land_val(m)) + if (.not.OK) call MOM_error(FATAL,"initialize_oil_tracer: "//& + "Unable to read "//trim(name)//" from "//& + trim(CS%IC_file)//".") + endif + else + call MOM_read_data(CS%IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) + endif + else + do k=1,nz ; do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) < 0.5) then + CS%tr(i,j,k,m) = CS%land_val(m) + else + CS%tr(i,j,k,m) = CS%IC_val(m) + endif + enddo ; enddo ; enddo + endif + call set_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp) + endif ! restart + enddo ! Tracer loop + + if (associated(OBC)) then + ! Put something here... + endif + +end subroutine initialize_oil_tracer + +!> Apply sources, sinks, diapycnal mixing and rising motions to the oil tracers +subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, tv, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [H ~> m or kg m-2] +! This subroutine applies diapycnal diffusion and any other column +! tracer physics or chemistry to the tracers from this file. +! This is a simple example of a set of advected passive tracers. + +! The arguments to this subroutine are redundant in that +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real :: Isecs_per_year = 1.0 / (365.0*86400.0) ! Conversion factor from seconds to year [year s-1] + real :: vol_scale ! A conversion factor for volumes into m3 [m3 H-1 L-2 ~> 1 or m3 kg-1] + real :: year ! Time in fractional years [years] + real :: h_total ! A running sum of thicknesses [H ~> m or kg m-2] + real :: decay_timescale ! Chemical decay timescale for oil [T ~> s] + real :: ldecay ! Chemical decay rate of oil [T-1 ~> s-1] + integer :: i, j, k, is, ie, js, je, nz, m, k_max + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,CS%ntr + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + else + do m=1,CS%ntr + call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + endif + + year = time_type_to_real(CS%Time) * Isecs_per_year + + ! Decay tracer (limit decay rate to 1/dt - just in case) + do m=2,CS%ntr + do k=1,nz ; do j=js,je ; do i=is,ie + !CS%tr(i,j,k,m) = CS%tr(i,j,k,m) - dt*CS%oil_decay_rate(m)*CS%tr(i,j,k,m) ! Simple + !CS%tr(i,j,k,m) = CS%tr(i,j,k,m) - min(dt*CS%oil_decay_rate(m),1.)*CS%tr(i,j,k,m) ! Safer + if (CS%oil_decay_rate(m)>0.) then + CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - dt*CS%oil_decay_rate(m),0.)*CS%tr(i,j,k,m) ! Safest + elseif (CS%oil_decay_rate(m)<0.) then + decay_timescale = (12.0 * (3.0**(-(tv%T(i,j,k)-20.0*US%degC_to_C)/10.0*US%degC_to_C))) * & + (86400.0*US%s_to_T) ! Timescale [T ~> s] + ldecay = 1. / decay_timescale ! Rate [T-1 ~> s-1] + CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - dt*ldecay,0.)*CS%tr(i,j,k,m) + endif + enddo ; enddo ; enddo + enddo + + ! Add oil at the source location + if (year>=CS%oil_start_year .and. year<=CS%oil_end_year .and. & + CS%oil_source_i>-999 .and. CS%oil_source_j>-999) then + i = CS%oil_source_i ; j = CS%oil_source_j + k_max = nz ; h_total = 0. + vol_scale = GV%H_to_m * US%L_to_m**2 + do k=nz, 2, -1 + h_total = h_total + h_new(i,j,k) + if (h_total < 10.*GV%m_to_H) k_max=k-1 ! Find bottom most interface that is 10 m above bottom + enddo + do m=1,CS%ntr + k = CS%oil_source_k(m) + if (k>0) then + k = min(k,k_max) ! Only insert k or first layer with interface 10 m above bottom + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt / & + (vol_scale * (h_new(i,j,k)+GV%H_subroundoff) * G%areaT(i,j) ) + elseif (k<0) then + h_total = GV%H_subroundoff + do k=1, nz + h_total = h_total + h_new(i,j,k) + enddo + do k=1, nz + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt / (vol_scale * h_total * G%areaT(i,j) ) + enddo + endif + enddo + endif + +end subroutine oil_tracer_column_physics + +!> Calculate the mass-weighted integral of the oil tracer stocks, returning the number of stocks it +!! has calculated. If the stock_index is present, only the stock corresponding to that coded index is returned. +function oil_stock(h, stocks, G, GV, CS, names, units, stock_index) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. + character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. + integer :: oil_stock !< The number of stocks calculated here. + + ! Local variables + integer :: m + + oil_stock = 0 + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + if (present(stock_index)) then ; if (stock_index > 0) then + ! Check whether this stock is available from this routine. + + ! No stocks from this routine are being checked yet. Return 0. + return + endif ; endif + + do m=1,CS%ntr + call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="oil_stock") + units(m) = trim(units(m))//" kg" + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) + enddo + oil_stock = CS%ntr + +end function oil_stock + +!> This subroutine extracts the surface fields from this tracer package that +!! are to be shared with the atmosphere in coupled configurations. +!! This particular tracer package does not report anything back to the coupler. +subroutine oil_tracer_surface_state(sfc_state, h, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. + + ! This particular tracer package does not report anything back to the coupler. + ! The code that is here is just a rough guide for packages that would. + + integer :: m, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (.not.associated(CS)) return + + if (CS%coupled_tracers) then + do m=1,CS%ntr + ! This call loads the surface values into the appropriate array in the + ! coupler-type structure. + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + enddo + endif + +end subroutine oil_tracer_surface_state + +!> Deallocate memory associated with this tracer package +subroutine oil_tracer_end(CS) + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. + + if (associated(CS)) then + if (associated(CS%tr)) deallocate(CS%tr) + deallocate(CS) + endif +end subroutine oil_tracer_end + +!> \namespace oil_tracer +!! +!! By Alistair Adcroft and Robert Hallberg, 2010 * +!! +!! In the midst of the Deepwater Horizon oil spill, it became evident that +!! models were needed to predict the long-term fate of dissolved oil in the +!! open ocean. This tracer packages mimics the transport, dilution and decay +!! of dissolved oil plumes in the ocean. +!! +!! This tracer package was central to the simulations used by Adcroft et al., +!! GRL 2010, to prove that the Deepwater Horizon spill was an important regional +!! event, with implications for dissolved oxygen levels in the Gulf of Mexico, +!! but not one that would directly impact the East Coast of the U.S. + +end module oil_tracer diff --git a/tracer/pseudo_salt_tracer.F90 b/tracer/pseudo_salt_tracer.F90 new file mode 100644 index 0000000000..843d725839 --- /dev/null +++ b/tracer/pseudo_salt_tracer.F90 @@ -0,0 +1,349 @@ +!> A tracer package that mimics salinity +module pseudo_salt_tracer + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : EFP_type +use MOM_debugging, only : hchksum +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_CVMix_KPP, only : KPP_NonLocalTransport, KPP_CS +use MOM_hor_index, only : hor_index_type +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer, tracer_registry_type, tracer_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public register_pseudo_salt_tracer, initialize_pseudo_salt_tracer +public pseudo_salt_tracer_column_physics, pseudo_salt_tracer_surface_state +public pseudo_salt_stock, pseudo_salt_tracer_end + +!> The control structure for the pseudo-salt tracer +type, public :: pseudo_salt_tracer_CS ; private + type(tracer_type), pointer :: tr_ptr !< pointer to tracer inside Tr_reg + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry + real, pointer :: ps(:,:,:) => NULL() !< The array of pseudo-salt tracer used in this + !! subroutine [ppt] + real, allocatable :: diff(:,:,:) !< The difference between the pseudo-salt + !! tracer and the real salt [ppt]. + logical :: pseudo_salt_may_reinit = .true. !< Hard coding since this should not matter + + integer :: id_psd = -1 !< A diagnostic ID + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate + !! the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure + + type(vardesc) :: tr_desc !< A description and metadata for the pseudo-salt tracer +end type pseudo_salt_tracer_CS + +contains + +!> Register the pseudo-salt tracer with MOM6, and return .true. if the tracer is to be used. +function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control structure + + ! Local variables + character(len=40) :: mdl = "pseudo_salt_tracer" ! This module's name. + character(len=48) :: var_name ! The variable's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + real, pointer :: tr_ptr(:,:,:) => NULL() + logical :: register_pseudo_salt_tracer + integer :: isd, ied, jsd, jed, nz + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "register_pseudo_salt_tracer called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + allocate(CS%ps(isd:ied,jsd:jed,nz), source=0.0) + + CS%tr_desc = var_desc(trim("pseudo_salt"), "psu", & + "Pseudo salt passive tracer", caller=mdl) + + tr_ptr => CS%ps(:,:,:) + call query_vardesc(CS%tr_desc, name=var_name, caller="register_pseudo_salt_tracer") + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, name="pseudo_salt", & + longname="Pseudo salt passive tracer", units="psu", & + registry_diags=.true., restart_CS=restart_CS, & + mandatory=.not.CS%pseudo_salt_may_reinit, Tr_out=CS%tr_ptr) + + CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS + register_pseudo_salt_tracer = .true. + +end function register_pseudo_salt_tracer + +!> Initialize the pseudo-salt tracer +subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & + sponge_CSp, tv) + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing various thermodynamic variables + + ! This subroutine initializes the tracer fields in CS%ps(:,:,:). + + ! Local variables + character(len=16) :: name ! A variable's name in a NetCDF file + integer :: i, j, k, isd, ied, jsd, jed, nz + + if (.not.associated(CS)) return + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + + CS%Time => day + CS%diag => diag + name = "pseudo_salt" + + call query_vardesc(CS%tr_desc, name=name, caller="initialize_pseudo_salt_tracer") + if ((.not.restart) .or. (.not.query_initialized(CS%ps, name, CS%restart_CSp))) then + do k=1,nz ; do j=jsd,jed ; do i=isd,ied + CS%ps(i,j,k) = US%S_to_ppt*tv%S(i,j,k) + enddo ; enddo ; enddo + call set_initialized(CS%ps, name, CS%restart_CSp) + endif + + if (associated(OBC)) then + ! Steal from updated DOME in the fullness of time. + endif + + CS%id_psd = register_diag_field("ocean_model", "pseudo_salt_diff", CS%diag%axesTL, & + day, "Difference between pseudo salt passive tracer and salt tracer", "psu") + if (.not.allocated(CS%diff)) allocate(CS%diff(isd:ied,jsd:jed,nz), source=0.0) + +end subroutine initialize_pseudo_salt_tracer + +!> Apply sources, sinks and diapycnal diffusion to the tracers in this package. +subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, tv, debug, & + KPP_CSp, nonLocalTrans, evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< The amount of fluid entrained from the layer above + !! during this call [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< The amount of fluid entrained from the layer below + !! during this call [H ~> m or kg m-2] + type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic and + !! tracer forcing fields + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + logical, intent(in) :: debug !< If true calculate checksums + type(KPP_CS), optional, pointer :: KPP_CSp !< KPP control structure + real, optional, intent(in) :: nonLocalTrans(:,:,:) !< Non-local transport [nondim] + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [H ~> m or kg m-2] + + ! This subroutine applies diapycnal diffusion and any other column + ! tracer physics or chemistry to the tracers from this file. + + ! The arguments to this subroutine are redundant in that + ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + + ! Local variables + real :: net_salt(SZI_(G),SZJ_(G)) ! Net salt flux into the ocean integrated over + ! a timestep [ppt H ~> ppt m or ppt kg m-2] + real :: htot(SZI_(G)) ! Total ocean depth [H ~> m or kg m-2] + real :: FluxRescaleDepth ! Minimum total ocean depth at which fluxes start to be scaled + ! away [H ~> m or kg m-2] + real :: Ih_limit ! Inverse of FluxRescaleDepth or 0 for no limiting [H-1 ~> m-1 or m2 kg-1] + real :: scale ! Scale scales away fluxes if depth < FluxRescaleDepth [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + if (.not.associated(CS%ps)) return + + if (debug) then + call hchksum(tv%S,"salt pre pseudo-salt vertdiff", G%HI, scale=US%S_to_ppt) + call hchksum(CS%ps,"pseudo_salt pre pseudo-salt vertdiff", G%HI) + endif + + ! Compute KPP nonlocal term if necessary + if (present(KPP_CSp)) then + if (associated(KPP_CSp) .and. present(nonLocalTrans)) & + call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, fluxes%KPP_salt_flux(:,:), & + dt, CS%diag, CS%tr_ptr, CS%ps(:,:,:)) + endif + + ! This uses applyTracerBoundaryFluxesInOut, usually in ALE mode + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + ! This option uses applyTracerBoundaryFluxesInOut, usually in ALE mode + + ! Determine the time-integrated salt flux, including limiting for small total ocean depths. + net_Salt(:,:) = 0.0 + FluxRescaleDepth = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) + Ih_limit = 0.0 ; if (FluxRescaleDepth > 0.0) Ih_limit = 1.0 / FluxRescaleDepth + do j=js,je + do i=is,ie ; htot(i) = h_old(i,j,1) ; enddo + do k=2,nz ; do i=is,ie ; htot(i) = htot(i) + h_old(i,j,k) ; enddo ; enddo + do i=is,ie + scale = 1.0 ; if ((Ih_limit > 0.0) .and. (htot(i)*Ih_limit < 1.0)) scale = htot(i)*Ih_limit + net_salt(i,j) = (scale * dt * (1000.0 * fluxes%salt_flux(i,j))) * GV%RZ_to_H + enddo + enddo + + do k=1,nz ; do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%ps, dt, fluxes, h_work, evap_CFL_limit, & + minimum_forcing_depth, out_flux_optional=net_salt) + call tracer_vertdiff(h_work, ea, eb, dt, CS%ps, G, GV) + else + call tracer_vertdiff(h_old, ea, eb, dt, CS%ps, G, GV) + endif + + if (debug) then + call hchksum(tv%S, "salt post pseudo-salt vertdiff", G%HI, scale=US%S_to_ppt) + call hchksum(CS%ps, "pseudo_salt post pseudo-salt vertdiff", G%HI) + endif + + if (allocated(CS%diff)) then + do k=1,nz ; do j=js,je ; do i=is,ie + CS%diff(i,j,k) = CS%ps(i,j,k) - US%S_to_ppt*tv%S(i,j,k) + enddo ; enddo ; enddo + if (CS%id_psd>0) call post_data(CS%id_psd, CS%diff, CS%diag) + endif + +end subroutine pseudo_salt_tracer_column_physics + + +!> Calculates the mass-weighted integral of all tracer stocks, returning the number of stocks it has +!! calculated. If the stock_index is present, only the stock corresponding to that coded index is returned. +function pseudo_salt_stock(h, stocks, G, GV, CS, names, units, stock_index) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated + integer, optional, intent(in) :: stock_index !< The coded index of a specific stock + !! being sought + integer :: pseudo_salt_stock !< Return value: the number of + !! stocks calculated here + + + pseudo_salt_stock = 0 + if (.not.associated(CS)) return + if (.not.allocated(CS%diff)) return + + if (present(stock_index)) then ; if (stock_index > 0) then + ! Check whether this stock is available from this routine. + + ! No stocks from this routine are being checked yet. Return 0. + return + endif ; endif + + call query_vardesc(CS%tr_desc, name=names(1), units=units(1), caller="pseudo_salt_stock") + units(1) = trim(units(1))//" kg" + stocks(1) = global_mass_int_EFP(h, G, GV, CS%diff, on_PE_only=.true.) + + pseudo_salt_stock = 1 + +end function pseudo_salt_stock + +!> This subroutine extracts the surface fields from this tracer package that +!! are to be shared with the atmosphere in coupled configurations. +!! This particular tracer package does not report anything back to the coupler. +subroutine pseudo_salt_tracer_surface_state(sfc_state, h, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer + + ! This particular tracer package does not report anything back to the coupler. + ! The code that is here is just a rough guide for packages that would. + + if (.not.associated(CS)) return + + ! By design, this tracer package does not return any surface states. + +end subroutine pseudo_salt_tracer_surface_state + +!> Deallocate memory associated with this tracer package +subroutine pseudo_salt_tracer_end(CS) + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer + + if (associated(CS)) then + if (associated(CS%ps)) deallocate(CS%ps) + if (allocated(CS%diff)) deallocate(CS%diff) + deallocate(CS) + endif +end subroutine pseudo_salt_tracer_end + +!> \namespace pseudo_salt_tracer +!! +!! By Andrew Shao, 2016 +!! +!! This file contains the routines necessary to model a passive +!! tracer that uses the same boundary fluxes as salinity. At the +!! beginning of the run, salt is set to the same as tv%S. Any +!! deviations between this salt-like tracer and tv%S signifies a +!! difference between how active and passive tracers are treated. + +end module pseudo_salt_tracer diff --git a/tracer/tracer_example.F90 b/tracer/tracer_example.F90 new file mode 100644 index 0000000000..fa9b978f9c --- /dev/null +++ b/tracer/tracer_example.F90 @@ -0,0 +1,460 @@ +!> A sample tracer package that has striped initial conditions +module USER_tracer_example + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public USER_register_tracer_example, USER_initialize_tracer, USER_tracer_stock +public tracer_column_physics, USER_tracer_surface_state, USER_tracer_example_end + +integer, parameter :: NTR = 1 !< The number of tracers in this module. + +!> The control structure for the USER_tracer_example module +type, public :: USER_tracer_example_CS ; private + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + character(len=200) :: tracer_IC_file !< The full path to the IC file, or " " + !! to initialize internally. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, perhaps in [g kg-1]? + real :: land_val(NTR) = -1.0 !< The value of tr that is used where land is masked out, perhaps in [g kg-1]? + + real :: stripe_width !< The Gaussian width of the stripe in the initial condition + !! for the tracer_example tracers [L ~> m] + real :: stripe_lat !< The central latitude of the stripe in the initial condition + !! for the tracer_example tracers, in [degrees_N] or [km] or [m]. + logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. + + integer, dimension(NTR) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the timing of diagnostic output. + + type(vardesc) :: tr_desc(NTR) !< Descriptions of each of the tracers. +end type USER_tracer_example_CS + +contains + +!> This subroutine is used to register tracer fields and subroutines to be used with MOM. +function USER_register_tracer_example(G, GV, US, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(USER_tracer_example_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + +! Local variables + character(len=80) :: name, longname + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "tracer_example" ! This module's name. + character(len=200) :: inputdir + character(len=48) :: flux_units ! The units for tracer fluxes, usually + ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] + logical :: USER_register_tracer_example + integer :: isd, ied, jsd, jed, nz, m + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(FATAL, "USER_register_tracer_example called with an "// & + "associated control structure.") + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "TRACER_EXAMPLE_IC_FILE", CS%tracer_IC_file, & + "The name of a file from which to read the initial conditions for "//& + "the tracer_example tracers, or blank to initialize them internally.", & + default=" ") + if (len_trim(CS%tracer_IC_file) >= 1) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + CS%tracer_IC_file = trim(slasher(inputdir))//trim(CS%tracer_IC_file) + call log_param(param_file, mdl, "INPUTDIR/TRACER_EXAMPLE_IC_FILE", & + CS%tracer_IC_file) + endif + call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified from MOM_initialization.F90.", default=.false.) + call get_param(param_file, mdl, "TRACER_EXAMPLE_STRIPE_WIDTH", CS%stripe_width, & + "The Gaussian width of the stripe in the initial condition for the "//& + "tracer_example tracers.", units="m", default=1.0e5, scale=US%m_to_L) + call get_param(param_file, mdl, "TRACER_EXAMPLE_STRIPE_LAT", CS%stripe_lat, & + "The central latitude of the stripe in the initial condition for the "//& + "tracer_example tracers.", units=G%y_ax_unit_short, default=40.0) + + allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) + + do m=1,NTR + if (m < 10) then ; write(name,'("tr",I1.1)') m + else ; write(name,'("tr",I2.2)') m ; endif + write(longname,'("Concentration of Tracer ",I2.2)') m + CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + + ! This needs to be changed if the units of tracer are changed above. + if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" + else ; flux_units = "kg s-1" ; endif + + ! This pointer is needed to force the compiler not to do a copy in the registration calls. + tr_ptr => CS%tr(:,:,:,m) + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, G%HI, GV, & + name=name, longname=longname, units="kg kg-1", & + registry_diags=.true., flux_units=flux_units, & + restart_CS=restart_CS) + + ! Set coupled_tracers to be true (hard-coded above) to provide the surface + ! values to the coupler (if any). This is meta-code and its arguments will + ! currently (deliberately) give fatal errors if it is used. + if (CS%coupled_tracers) & + CS%ind_tr(m) = atmos_ocn_coupler_flux(trim(name)//'_flux', & + flux_type=' ', implementation=' ', caller="USER_register_tracer_example") + enddo + + CS%tr_Reg => tr_Reg + USER_register_tracer_example = .true. +end function USER_register_tracer_example + +!> This subroutine initializes the NTR tracer fields in tr(:,:,:,:) +!! and it sets up the tracer output. +subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & + sponge_CSp) + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous + !! call to USER_register_tracer_example. + type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure + !! for the sponges, if they are in use. + +! Local variables + real, allocatable :: temp(:,:,:) ! Target values for the tracers in the sponges, perhaps in [g kg-1] + character(len=32) :: name ! A variable's name in a NetCDF file. + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: tr_y ! Initial zonally uniform tracer concentrations, perhaps in [g kg-1] + real :: dist2 ! The distance squared from a line [L2 ~> m2]. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m + integer :: IsdB, IedB, JsdB, JedB, lntr + + if (.not.associated(CS)) return + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + lntr = NTR ! Avoids compile-time warning when NTR<2 + CS%Time => day + CS%diag => diag + + if (.not.restart) then + if (len_trim(CS%tracer_IC_file) >= 1) then +! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & + call MOM_error(FATAL, "USER_initialize_tracer: Unable to open "// & + CS%tracer_IC_file) + do m=1,NTR + call query_vardesc(CS%tr_desc(m), name, caller="USER_initialize_tracer") + call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) + enddo + else + do m=1,NTR + do k=1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = 1.0e-20 ! This could just as well be 0. + enddo ; enddo ; enddo + enddo + +! This sets a stripe of tracer across the basin. + PI = 4.0*atan(1.0) + do j=js,je + dist2 = (G%Rad_Earth_L * PI / 180.0)**2 * (G%geoLatT(i,j) - CS%stripe_lat)**2 + tr_y = 0.5 * exp( -dist2 / CS%stripe_width**2 ) + + do k=1,nz ; do i=is,ie +! This adds the stripes of tracer to every layer. + CS%tr(i,j,k,1) = CS%tr(i,j,k,1) + tr_y + enddo ; enddo + enddo + endif + endif ! restart + + if ( CS%use_sponge ) then +! If sponges are used, this example damps tracers in sponges in the +! northern half of the domain to 1 and tracers in the southern half +! to 0. For any tracers that are not damped in the sponge, the call +! to set_up_sponge_field can simply be omitted. + if (.not.associated(sponge_CSp)) & + call MOM_error(FATAL, "USER_initialize_tracer: "// & + "The pointer to sponge_CSp must be associated if SPONGE is defined.") + + allocate(temp(G%isd:G%ied,G%jsd:G%jed,nz)) + do k=1,nz ; do j=js,je ; do i=is,ie + if ((G%geoLatT(i,j) > 0.5*G%len_lat + G%south_lat) .and. (k > nz/2)) then + temp(i,j,k) = 1.0 + else + temp(i,j,k) = 0.0 + endif + enddo ; enddo ; enddo + +! do m=1,NTR + do m=1,1 + ! This pointer is needed to force the compiler not to do a copy in the sponge calls. + tr_ptr => CS%tr(:,:,:,m) + call set_up_sponge_field(temp, tr_ptr, G, GV, nz, sponge_CSp) + enddo + deallocate(temp) + endif + + if (associated(OBC)) then + call query_vardesc(CS%tr_desc(1), name, caller="USER_initialize_tracer") + if (OBC%specified_v_BCs_exist_globally) then + ! Steal from updated DOME in the fullness of time. + else + ! Steal from updated DOME in the fullness of time. + endif + ! All tracers but the first have 0 concentration in their inflows. As this + ! is the default value, the following calls are unnecessary. + !do m=2,lntr + do m=2,ntr + call query_vardesc(CS%tr_desc(m), name, caller="USER_initialize_tracer") + ! Steal from updated DOME in the fullness of time. + enddo + endif + +end subroutine USER_initialize_tracer + +!> This subroutine applies diapycnal diffusion and any other column +!! tracer physics or chemistry to the tracers from this file. +!! This is a simple example of a set of advected passive tracers. +!! The arguments to this subroutine are redundant in that +!! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) +subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous + !! call to USER_register_tracer_example. + +! Local variables + real :: hold0(SZI_(G)) ! The original topmost layer thickness, + ! with surface mass fluxes added back [H ~> m or kg m-2]. + real :: b1(SZI_(G)) ! b1 is a variable used by the tridiagonal solver [H ~> m or kg m-2]. + real :: c1(SZI_(G),SZK_(GV)) ! c1 is a variable used by the tridiagonal solver [nondim]. + real :: d1(SZI_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: diapyc_filt ! A multiplicative filter that can be set to 0 to disable diapycnal + ! advection of the tracer [nondim] + real :: dye_up ! The tracer concentration of upwelled water, perhaps in [g kg-1]? + real :: dye_down ! The tracer concentration of downwelled water, perhaps in [g kg-1]? + integer :: i, j, k, is, ie, js, je, nz, m + + ! These are the settings for most "physical" tracers, which + ! are advected diapycnally in the usual manner. + diapyc_filt = 1.0 ; dye_down = 0.0 ; dye_down = 0.0 + + ! Uncomment the following line to dye downwelling. +! diapyc_filt = 0.0 ; dye_down = 1.0 + ! Uncomment the following line to dye upwelling. +! diapyc_filt = 0.0 ; dye_up = 1.0 + ! Uncomment the following line for tracer concentrations to be set + ! to zero in any diapycnal motions. +! diapyc_filt = 0.0 ; dye_down = 0.0 ; dye_down = 0.0 + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + h_neglect = GV%H_subroundoff + + do j=js,je + do i=is,ie +! The following line is appropriate for quantities like salinity +! that are left behind by evaporation, and any surface fluxes would +! be explicitly included in the flux structure. + hold0(i) = h_old(i,j,1) +! The following line is appropriate for quantities like temperature +! that can be assumed to have the same concentration in evaporation +! as they had in the water. The explicit surface fluxes here would +! reflect differences in concentration from the ambient water, not +! the absolute fluxes. + ! hold0(i) = h_old(i,j,1) + ea(i,j,1) + b_denom_1 = h_old(i,j,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) + d1(i) = diapyc_filt * (b_denom_1 * b1(i)) + (1.0 - diapyc_filt) + do m=1,NTR + CS%tr(i,j,1,m) = b1(i)*(hold0(i)*CS%tr(i,j,1,m) + dye_up*eb(i,j,1)) + ! Add any surface tracer fluxes to the preceding line. + enddo + enddo + do k=2,nz ; do i=is,ie + c1(i,k) = diapyc_filt * eb(i,j,k-1) * b1(i) + b_denom_1 = h_old(i,j,k) + d1(i)*ea(i,j,k) + h_neglect + b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) + d1(i) = diapyc_filt * (b_denom_1 * b1(i)) + (1.0 - diapyc_filt) + do m=1,NTR + CS%tr(i,j,k,m) = b1(i) * (h_old(i,j,k)*CS%tr(i,j,k,m) + & + ea(i,j,k)*(diapyc_filt*CS%tr(i,j,k-1,m) + dye_down) + & + eb(i,j,k)*dye_up) + enddo + enddo ; enddo + do m=1,NTR ; do k=nz-1,1,-1 ; do i=is,ie + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + c1(i,k+1)*CS%tr(i,j,k+1,m) + enddo ; enddo ; enddo + enddo + +end subroutine tracer_column_physics + +!> This function calculates the mass-weighted integral of all tracer stocks, +!! returning the number of stocks it has calculated. If the stock_index +!! is present, only the stock corresponding to that coded index is returned. +function USER_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] + type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_USER_tracer. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< The coded index of a specific stock + !! being sought. + integer :: USER_tracer_stock !< Return value: the number of + !! stocks calculated here. + + ! Local variables + integer :: m + + USER_tracer_stock = 0 + if (.not.associated(CS)) return + + if (present(stock_index)) then ; if (stock_index > 0) then + ! Check whether this stock is available from this routine. + + ! No stocks from this routine are being checked yet. Return 0. + return + endif ; endif + + do m=1,NTR + call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="USER_tracer_stock") + units(m) = trim(units(m))//" kg" + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) + enddo + USER_tracer_stock = NTR + +end function USER_tracer_stock + +!> This subroutine extracts the surface fields from this tracer package that +!! are to be shared with the atmosphere in coupled configurations. +subroutine USER_tracer_surface_state(sfc_state, h, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_USER_tracer. + + ! This particular tracer package does not report anything back to the coupler. + ! The code that is here is just a rough guide for packages that would. + + integer :: m, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (.not.associated(CS)) return + + if (CS%coupled_tracers) then + do m=1,ntr + ! This call loads the surface values into the appropriate array in the + ! coupler-type structure. + call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + enddo + endif + +end subroutine USER_tracer_surface_state + +!> Clean up allocated memory at the end. +subroutine USER_tracer_example_end(CS) + type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_USER_tracer. + + if (associated(CS)) then + if (associated(CS%tr)) deallocate(CS%tr) + deallocate(CS) + endif +end subroutine USER_tracer_example_end + +!> \namespace user_tracer_example +!! +!! Original by Robert Hallberg, 2002 +!! +!! This file contains an example of the code that is needed to set +!! up and use a set (in this case one) of dynamically passive tracers. +!! +!! A single subroutine is called from within each file to register +!! each of the tracers for reinitialization and advection and to +!! register the subroutine that initializes the tracers and set up +!! their output and the subroutine that does any tracer physics or +!! chemistry along with diapycnal mixing (included here because some +!! tracers may float or swim vertically or dye diapycnal processes). +end module USER_tracer_example diff --git a/user/BFB_initialization.F90 b/user/BFB_initialization.F90 new file mode 100644 index 0000000000..67381bfdc5 --- /dev/null +++ b/user/BFB_initialization.F90 @@ -0,0 +1,181 @@ +!> Initialization of the boundary-forced-basing configuration +module BFB_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +implicit none ; private + +#include + +public BFB_set_coord +public BFB_initialize_sponges_southonly + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> This subroutine specifies the vertical coordinate in terms of temperature at the surface and at the bottom. +!! This case is set up in such a way that the temperature of the topmost layer is equal to the SST at the +!! southern edge of the domain. The temperatures are then converted to densities of the top and bottom layers +!! and linearly interpolated for the intermediate layers. +subroutine BFB_set_coord(Rlay, g_prime, GV, US, param_file) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + + real :: Rho_T0_S0 ! The density at T=0, S=0 [R ~> kg m-3] + real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + real :: SST_s, T_bot ! Temperatures at the surface and seafloor [C ~> degC] + real :: S_ref ! Reference salinity [S ~> ppt] + real :: rho_top, rho_bot ! Densities at the surface and seafloor [R ~> kg m-3] + integer :: k, nz + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "BFB_initialization" ! This module's name. + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & + "The partial derivative of density with temperature.", & + units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC) + call get_param(param_file, mdl, "DRHO_DS", dRho_dS, & + "The partial derivative of density with salinity.", & + units="kg m-3 PSU-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) + call get_param(param_file, mdl, "RHO_T0_S0", Rho_T0_S0, & + "The density at T=0, S=0.", units="kg m-3", default=1000.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "SST_S", SST_s, & + "SST at the southern edge of the domain.", & + units="degC", default=20.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "T_BOT", T_bot, & + "Bottom temperature", units="degC", default=5.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "S_REF", S_ref, & + "The initial salinities.", units="PSU", default=35.0, scale=US%ppt_to_S) + rho_top = (Rho_T0_S0 + dRho_dS*S_ref) + dRho_dT*SST_s + rho_bot = (Rho_T0_S0 + dRho_dS*S_ref) + dRho_dT*T_bot + nz = GV%ke + + do k = 1,nz + Rlay(k) = (rho_bot - rho_top)/(nz-1)*real(k-1) + rho_top + if (k==1) then + g_prime(k) = GV%g_Earth + elseif (GV%Boussinesq) then + g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / GV%Rho0 + else + g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / (0.5*(Rlay(k) + Rlay(k-1))) + endif + enddo + +end subroutine BFB_set_coord + +!> This subroutine sets up the sponges for the southern boundary of the domain. Maximum damping occurs +!! within 2 degrees lat of the boundary. The damping linearly decreases northward over the next 2 degrees. +subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, depth_tot, param_file, CSp, h) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: use_temperature !< If true, temperature and salinity are used as + !! state variables. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(sponge_CS), pointer :: CSp !< A pointer to the sponge control structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + + ! Local variables + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, in depth units [Z ~> m]. + real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] + real :: H0(SZK_(GV)) ! Resting layer thicknesses in depth units [Z ~> m]. + real :: slat ! The southern latitude of the domain [degrees_N] + real :: wlon ! The western longitude of the domain [degrees_E] + real :: lenlat ! The latitudinal length of the domain [degrees_N] + real :: lenlon ! The longitudinal length of the domain [degrees_E] + real :: nlat ! The northern latitude of the domain [degrees_N] + real :: max_damping ! The maximum damping rate [T-1 ~> s-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "BFB_initialize_sponges_southonly" ! This subroutine's name. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + +! Here the inverse damping time [T-1 ~> s-1], is set. Set Idamp to 0 +! wherever there is no sponge, and the subroutines that are called +! will automatically set up the sponges only where Idamp is positive +! and mask2dT is 1. + + ! Set up sponges for this configuration + ! call log_version(param_file, mdl, version) + + slat = G%south_lat + lenlat = G%len_lat + wlon = G%west_lon + lenlon = G%len_lon + nlat = slat + lenlat + do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz) ; enddo + + ! Use for meridional thickness profile initialization + ! do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz-1) ; enddo + + max_damping = 1.0 / (86400.0*US%s_to_T) + + eta(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 + + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) <= 0.0) then ; Idamp(i,j) = 0.0 + elseif (G%geoLatT(i,j) < slat+2.0) then ; Idamp(i,j) = max_damping + elseif (G%geoLatT(i,j) < slat+4.0) then + Idamp(i,j) = max_damping * (slat+4.0-G%geoLatT(i,j))/2.0 + else ; Idamp(i,j) = 0.0 + endif + + ! These will be streched inside of apply_sponge, so they can be in + ! depth space for Boussinesq or non-Boussinesq models. + + ! This section is used for uniform thickness initialization + do k=1,nz ; eta(i,j,k) = H0(k) ; enddo + + ! The below section is used for meridional temperature profile thickness initialization + ! do k=1,nz ; eta(i,j,k) = H0(k) ; enddo + ! if (G%geoLatT(i,j) > 40.0) then + ! do k = 1,nz + ! eta(i,j,k) = -G%Angstrom_Z*(k-1) + ! enddo + ! elseif (G%geoLatT(i,j) > 20.0) then + ! do k=1,nz + ! eta(i,j,k) = min(H0(k) + (G%geoLatT(i,j) - 20.0)*(G%max_depth - nz*G%Angstrom_Z)/20.0, & + ! -(k-1)*G%Angstrom_Z) + ! enddo + ! endif + eta(i,j,nz+1) = -G%max_depth + + enddo ; enddo + +! This call sets up the damping rates and interface heights. +! This sets the inverse damping timescale fields in the sponges. ! + call initialize_sponge(Idamp, eta, G, param_file, CSp, GV) + +! Now register all of the fields which are damped in the sponge. ! +! By default, momentum is advected vertically within the sponge, but ! +! momentum is typically not damped within the sponge. ! + +end subroutine BFB_initialize_sponges_southonly + +end module BFB_initialization diff --git a/user/BFB_surface_forcing.F90 b/user/BFB_surface_forcing.F90 new file mode 100644 index 0000000000..fcbd66e1d8 --- /dev/null +++ b/user/BFB_surface_forcing.F90 @@ -0,0 +1,255 @@ +!> Surface forcing for the boundary-forced-basin (BFB) configuration +module BFB_surface_forcing + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : post_data, query_averaging_enabled +use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_domains, only : pass_var, pass_vector, AGRID +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, param_file_type, log_version +use MOM_forcing_type, only : forcing, allocate_forcing_type +use MOM_grid, only : ocean_grid_type +use MOM_safe_alloc, only : safe_alloc_ptr +use MOM_time_manager, only : time_type, operator(+), operator(/) +use MOM_tracer_flow_control, only : call_tracer_set_forcing +use MOM_tracer_flow_control, only : tracer_flow_control_CS +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface + +implicit none ; private + +public BFB_buoyancy_forcing, BFB_surface_forcing_init + +!> Control structure for BFB_surface_forcing +type, public :: BFB_surface_forcing_CS ; private + + logical :: use_temperature !< If true, temperature and salinity are used as state variables. + logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. + real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. + real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] + real :: SST_s !< SST at the southern edge of the linear forcing ramp [C ~> degC] + real :: SST_n !< SST at the northern edge of the linear forcing ramp [C ~> degC] + real :: S_ref !< Reference salinity used throughout the domain [S ~> ppt] + real :: lfrslat !< Southern latitude where the linear forcing ramp begins [degrees_N] or [km] + real :: lfrnlat !< Northern latitude where the linear forcing ramp ends [degrees_N] or [km] + real :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] + real :: dRho_dT !< The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dRho_dS !< The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + !! Note that temperature and salinity are being used as dummy variables here. + !! All temperatures are converted into density. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. +end type BFB_surface_forcing_CS + +contains + +!> Bouyancy forcing for the boundary-forced-basin (BFB) configuration +subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL ptrs. + type(time_type), intent(in) :: day !< Time of the fluxes. + real, intent(in) :: dt !< The amount of time over which + !! the fluxes apply [T ~> s] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(BFB_surface_forcing_CS), pointer :: CS !< A pointer to the control structure + !! returned by a previous call to + !! BFB_surface_forcing_init. + ! Local variables + real :: Temp_restore ! The temperature that is being restored toward [C ~> degC]. + real :: Salin_restore ! The salinity that is being restored toward [S ~> ppt]. + real :: density_restore ! The potential density that is being restored + ! toward [R ~> kg m-3]. + real :: rhoXcp ! Reference density times heat capacity times unit scaling + ! factors [Q R C-1 ~> J m-3 degC-1] + real :: buoy_rest_const ! A constant relating density anomalies to the + ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. + integer :: i, j, is, ie, js, je + integer :: isd, ied, jsd, jed + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + ! Allocate and zero out the forcing arrays, as necessary. This portion is + ! usually not changed. + if (CS%use_temperature) then + call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) + + call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) + else ! This is the buoyancy only mode. + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) + endif + + if ( CS%use_temperature ) then + ! Set whichever fluxes are to be used here. Any fluxes that + ! are always zero do not need to be changed here. + do j=js,je ; do i=is,ie + ! Fluxes of fresh water through the surface are in units of [R Z T-1 ~> kg m-2 s-1] + ! and are positive downward - i.e. evaporation should be negative. + fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) + fluxes%lprec(i,j) = 0.0 * G%mask2dT(i,j) + + ! vprec will be set later, if it is needed for salinity restoring. + fluxes%vprec(i,j) = 0.0 + + ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. + fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%sw(i,j) = 0.0 * G%mask2dT(i,j) + enddo ; enddo + else ! This is the buoyancy only mode. + do j=js,je ; do i=is,ie + ! fluxes%buoy is the buoyancy flux into the ocean [L2 T-3 ~> m2 s-3]. A positive + ! buoyancy flux is of the same sign as heating the ocean. + fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) + enddo ; enddo + endif + + if (CS%restorebuoy) then + if (CS%use_temperature) then + call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) + ! When modifying the code, comment out this error message. It is here + ! so that the original (unmodified) version is not accidentally used. + call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & + "Temperature and salinity restoring used without modification." ) + + rhoXcp = CS%rho_restore * fluxes%C_p + do j=js,je ; do i=is,ie + ! Set Temp_restore and Salin_restore to the temperature (in [C ~> degC]) and + ! salinity (in [S ~> ppt]) that are being restored toward. + Temp_restore = 0.0 + Salin_restore = 0.0 + + fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & + (Temp_restore - sfc_state%SST(i,j)) + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const)) * & + ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) + enddo ; enddo + else + ! When modifying the code, comment out this error message. It is here + ! so that the original (unmodified) version is not accidentally used. + ! call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & + ! "Buoyancy restoring used without modification." ) + + ! The -1 is because density has the opposite sign to buoyancy. + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%rho_restore + Temp_restore = 0.0 + do j=js,je ; do i=is,ie + ! Set density_restore to an expression for the surface potential + ! density [R ~> kg m-3] that is being restored toward. + if (G%geoLatT(i,j) < CS%lfrslat) then + Temp_restore = CS%SST_s + elseif (G%geoLatT(i,j) > CS%lfrnlat) then + Temp_restore = CS%SST_n + else + Temp_restore = (CS%SST_s - CS%SST_n)/(CS%lfrslat - CS%lfrnlat) * & + (G%geoLatT(i,j) - CS%lfrslat) + CS%SST_s + endif + + density_restore = (CS%Rho_T0_S0 + CS%dRho_dS*CS%S_ref) + CS%dRho_dT*Temp_restore + fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & + (density_restore - sfc_state%sfc_density(i,j)) + enddo ; enddo + endif + endif ! end RESTOREBUOY + +end subroutine BFB_buoyancy_forcing + +!> Initialization for forcing the boundary-forced-basin (BFB) configuration +subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to + !! regulate diagnostic output. + type(BFB_surface_forcing_CS), pointer :: CS !< A pointer to the control structure for this module + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "BFB_surface_forcing" ! This module's name. + + if (associated(CS)) then + call MOM_error(WARNING, "BFB_surface_forcing_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + CS%diag => diag + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & + "If true, Temperature and salinity are used as state variables.", default=.true.) + + call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & + "The gravitational acceleration of the Earth.", & + units="m s-2", default=9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) + call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "LFR_SLAT", CS%lfrslat, & + "Southern latitude where the linear forcing ramp begins.", & + units=G%y_ax_unit_short, default=20.0) + call get_param(param_file, mdl, "LFR_NLAT", CS%lfrnlat, & + "Northern latitude where the linear forcing ramp ends.", & + units=G%y_ax_unit_short, default=40.0) + call get_param(param_file, mdl, "SST_S", CS%SST_s, & + "SST at the southern edge of the linear forcing ramp.", & + units="degC", default=20.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "SST_N", CS%SST_n, & + "SST at the northern edge of the linear forcing ramp.", & + units="degC", default=10.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "DRHO_DT", CS%dRho_dT, & + "The partial derivative of density with temperature.", & + units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC) + call get_param(param_file, mdl, "DRHO_DS", CS%dRho_dS, & + "The partial derivative of density with salinity.", & + units="kg m-3 PSU-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) + call get_param(param_file, mdl, "RHO_T0_S0", CS%Rho_T0_S0, & + "The density at T=0, S=0.", units="kg m-3", default=1000.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "S_REF", CS%S_ref, & + "The reference salinity used here throughout the domain.", & + units="PSU", default=35.0, scale=US%ppt_to_S) + + call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & + "If true, the buoyancy fluxes drive the model back "//& + "toward some specified surface state with a rate "//& + "given by FLUXCONST.", default=.false.) + if (CS%restorebuoy) then + call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) + ! Convert CS%Flux_const from m day-1 to m s-1. + CS%Flux_const = CS%Flux_const / 86400.0 + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0)) + endif + +end subroutine BFB_surface_forcing_init + +end module BFB_surface_forcing diff --git a/user/DOME2d_initialization.F90 b/user/DOME2d_initialization.F90 new file mode 100644 index 0000000000..c1ec83257d --- /dev/null +++ b/user/DOME2d_initialization.F90 @@ -0,0 +1,552 @@ +!> Initialization of the 2D DOME experiment with density water initialized on a coastal shelf. +module DOME2d_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : dz_to_thickness, dz_to_thickness_simple +use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR +use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA + +implicit none ; private + +#include + +! Public functions +public DOME2d_initialize_topography +public DOME2d_initialize_thickness +public DOME2d_initialize_temperature_salinity +public DOME2d_initialize_sponges + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +character(len=40) :: mdl = "DOME2D_initialization" !< This module's name. + +contains + +!> Initialize topography with a shelf and slope in a 2D domain +subroutine DOME2d_initialize_topography( D, G, param_file, max_depth ) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] + + ! Local variables + real :: bay_depth ! Depth of shelf, as fraction of basin depth [nondim] + real :: l1, l2 ! Fractional horizontal positions where the slope changes [nondim] + real :: x ! Fractional horizontal positions [nondim] + real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] + real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] + real :: dome2d_depth_bay ! Depth of shelf, as fraction of basin depth [nondim] + integer :: i, j + ! This include declares and sets the variable "version". +# include "version_variable.h" + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & + 'Width of shelf, as fraction of domain, in 2d DOME configuration.', & + units='nondim', default=0.1) + call get_param(param_file, mdl, "DOME2D_BASIN_WIDTH", dome2d_width_bottom, & + 'Width of deep ocean basin, as fraction of domain, in 2d DOME configuration.', & + units='nondim', default=0.3) + call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & + 'Depth of shelf, as fraction of basin depth, in 2d DOME configuration.', & + units='nondim', default=0.2) + + ! location where downslope starts + l1 = dome2d_width_bay + + ! location where downslope reaches maximum depth + l2 = 1.0 - dome2d_width_bottom + + bay_depth = dome2d_depth_bay + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + + ! Compute normalized zonal coordinate + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + + if ( x <= l1 ) then + D(i,j) = bay_depth * max_depth + elseif (( x > l1 ) .and. ( x < l2 )) then + D(i,j) = bay_depth * max_depth + (1.0-bay_depth) * max_depth * & + ( x - l1 ) / (l2 - l1) + else + D(i,j) = max_depth + endif + + enddo ; enddo + +end subroutine DOME2d_initialize_topography + +!> Initialize thicknesses according to coordinate mode +subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, just_read ) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + + ! Local variables + real :: e0(SZK_(GV)) ! The resting interface heights, in depth units [Z ~> m], usually + ! negative because it is positive upward. + real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface + ! positive upward, in depth units [Z ~> m] + real :: x ! Fractional horizontal positions [nondim] + real :: min_thickness ! Minimum layer thicknesses [Z ~> m] + real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] + real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] + real :: dome2d_depth_bay ! Depth of shelf, as fraction of basin depth [nondim] + character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) & + call MOM_mesg("MOM_initialization.F90, DOME2d_initialize_thickness: setting thickness") + + call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & + default=1.e-3, units="m", do_not_log=.true., scale=US%m_to_Z) + call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=.true.) + call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & + units="nondim", default=0.1, do_not_log=.true.) + call get_param(param_file, mdl, "DOME2D_BASIN_WIDTH", dome2d_width_bottom, & + units="nondim", default=0.3, do_not_log=.true.) + call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & + units="nondim", default=0.2, do_not_log=.true.) + + if (just_read) return ! All run-time parameters have been read, so return. + + ! WARNING: this routine specifies the interface heights so that the last layer + ! is vanished, even at maximum depth. In order to have a uniform + ! layer distribution, use this line of code within the loop: + ! e0(k) = -G%max_depth * real(k-1) / real(nz) + ! To obtain a thickness distribution where the last layer is + ! vanished and the other thicknesses uniformly distributed, use: + ! e0(k) = -G%max_depth * real(k-1) / real(nz-1) + do k=1,nz + e0(k) = -G%max_depth * real(k-1) / real(nz) + enddo + + select case ( coordinateMode(verticalCoordinate) ) + + case ( REGRIDDING_LAYER, REGRIDDING_RHO ) + + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(k) = e0(k) + if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then + eta1D(k) = eta1D(k+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then + h(i,j,1:nz-1) = GV%Angstrom_Z + h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom_Z + endif + + enddo ; enddo + + ! case ( IC_RHO_C ) + ! + ! do j=js,je ; do i=is,ie + ! eta1D(nz+1) = -depth_tot(i,j) + ! do k=nz,1,-1 + ! eta1D(k) = e0(k) + ! if (eta1D(k) < (eta1D(k+1) + min_thickness)) then + ! eta1D(k) = eta1D(k+1) + min_thickness + ! h(i,j,k) = min_thickness + ! else + ! h(i,j,k) = eta1D(k) - eta1D(k+1) + ! endif + ! enddo + ! + ! x = G%geoLonT(i,j) / G%len_lon + ! if ( x <= dome2d_width_bay ) then + ! h(i,j,1:nz-1) = min_thickness + ! h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness + ! endif + ! + ! enddo ; enddo + + case ( REGRIDDING_ZSTAR ) + + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(k) = e0(k) + if (eta1D(k) < (eta1D(k+1) + min_thickness)) then + eta1D(k) = eta1D(k+1) + min_thickness + h(i,j,k) = min_thickness + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + case ( REGRIDDING_SIGMA ) + do j=js,je ; do i=is,ie + h(i,j,:) = depth_tot(i,j) / nz + enddo ; enddo + + case default + call MOM_error(FATAL,"dome2d_initialize: "// & + "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") + + end select + +end subroutine DOME2d_initialize_thickness + + +!> Initialize temperature and salinity in the 2d DOME configuration +subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + logical, intent(in) :: just_read !< If true, this call will + !! only read parameters without changing T & S. + + real :: x ! Fractional horizontal positions [nondim] + real :: delta_S ! Change in salinity between layers [S ~> ppt] + real :: S_ref, T_ref ! Reference salinity [S ~> ppt] and temperature [C ~> degC] within surface layer + real :: S_range, T_range ! Range of salinities [S ~> ppt] and temperatures [C ~> degC] over the vertical + real :: S_surf ! Initial surface salinity [S ~> ppt] + real :: T_bay ! Temperature in the inflow embayment [C ~> degC] + real :: xi0, xi1 ! Fractional vertical positions [nondim] + real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] + real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] + real :: dome2d_depth_bay ! Depth of shelf, as fraction of basin depth [nondim] + character(len=40) :: verticalCoordinate + integer :: index_bay_z + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=.true.) + call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & + units="nondim", default=0.1, do_not_log=.true.) + call get_param(param_file, mdl, "DOME2D_BASIN_WIDTH", dome2d_width_bottom, & + units="nondim", default=0.3, do_not_log=.true.) + call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & + units="nondim", default=0.2, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units='degC', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_RANGE", S_range,' Initial salinity range', & + units="ppt", default=2.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & + units='degC', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, "Initial surface salinity", & + units="ppt", default=34.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "DOME2D_T_BAY", T_bay, & + "Temperature in the inflow embayment in the DOME2d test case", & + units="degC", default=1.0, scale=US%degC_to_C, do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + T(:,:,:) = 0.0 + S(:,:,:) = 0.0 + + ! Linear salinity profile + + select case ( coordinateMode(verticalCoordinate) ) + + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA ) + + do j=js,je ; do i=is,ie + xi0 = 0.0 + do k = 1,nz + xi1 = xi0 + h(i,j,k) / G%max_depth + S(i,j,k) = S_surf + 0.5 * S_range * (xi0 + xi1) + xi0 = xi1 + enddo + enddo ; enddo + + case ( REGRIDDING_RHO ) + + do j=js,je ; do i=is,ie + xi0 = 0.0 + do k = 1,nz + xi1 = xi0 + h(i,j,k) / G%max_depth + S(i,j,k) = S_surf + 0.5 * S_range * (xi0 + xi1) + xi0 = xi1 + enddo + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then + S(i,j,nz) = S_surf + S_range + endif + enddo ; enddo + + case ( REGRIDDING_LAYER ) + + delta_S = S_range / ( GV%ke - 1.0 ) + S(:,:,1) = S_ref + do k = 2,GV%ke + S(:,:,k) = S(:,:,k-1) + delta_S + enddo + + case default + call MOM_error(FATAL,"dome2d_initialize: "// & + "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") + + end select + + ! Modify salinity and temperature when z coordinates are used + if ( coordinateMode(verticalCoordinate) == REGRIDDING_ZSTAR ) then + index_bay_z = Nint ( dome2d_depth_bay * GV%ke ) + do j = G%jsc,G%jec ; do i = G%isc,G%iec + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then + S(i,j,1:index_bay_z) = S_ref + S_range ! Use for z coordinates + T(i,j,1:index_bay_z) = T_bay ! Use for z coordinates + endif + enddo ; enddo ! i and j loops + endif ! Z initial conditions + + ! Modify salinity and temperature when sigma coordinates are used + if ( coordinateMode(verticalCoordinate) == REGRIDDING_SIGMA ) then + do i = G%isc,G%iec ; do j = G%jsc,G%jec + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then + S(i,j,1:GV%ke) = S_ref + S_range ! Use for sigma coordinates + T(i,j,1:GV%ke) = T_bay ! Use for sigma coordinates + endif + enddo ; enddo + endif + + ! Modify temperature when rho coordinates are used + if (( coordinateMode(verticalCoordinate) == REGRIDDING_RHO ) .or. & + ( coordinateMode(verticalCoordinate) == REGRIDDING_LAYER )) then + do i = G%isc,G%iec ; do j = G%jsc,G%jec + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then + T(i,j,GV%ke) = T_bay + endif + enddo ; enddo + endif + +end subroutine DOME2d_initialize_temperature_salinity + +!> Set up sponges in 2d DOME configuration +subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_ALE, CSp, ACSp) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode + type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure + type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure + ! Local variables + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp [C ~> degC] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt [S ~> ppt] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness in height units [Z ~> m] + real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness [H ~> m or kg m-2] + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for interface heights [Z ~> m] + real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] + real :: S_ref ! Reference salinity within the surface layer [S ~> ppt] + real :: T_ref ! Reference temperature within the surface layer [C ~> degC] + real :: S_range ! Range of salinities in the vertical [S ~> ppt] + real :: T_range ! Range of temperatures in the vertical [C ~> degC] + real :: S_range_sponge ! Range of salinities in the vertical in the east sponge [S ~> ppt] + real :: S_surf ! Initial surface salinity [S ~> ppt] + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], + ! usually negative because it is positive upward. + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface + ! positive upward [Z ~> m]. + real :: d_eta(SZK_(GV)) ! The layer thickness in a column [Z ~> m]. + real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] + real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] + real :: dome2d_depth_bay ! Depth of shelf, as fraction of basin depth [nondim] + real :: dome2d_west_sponge_time_scale, dome2d_east_sponge_time_scale ! Sponge timescales [T ~> s] + real :: dome2d_west_sponge_width ! The fraction of the domain in which the western sponge for + ! restoring T/S is active [nondim] + real :: dome2d_east_sponge_width ! The fraction of the domain in which the eastern sponge for + ! restoring T/S is active [nondim] + real :: dummy1, x ! Nondimensional local variables indicating horizontal positions [nondim] + real :: z ! Vertical positions [Z ~> m] + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + call get_param(param_file, mdl, "DOME2D_WEST_SPONGE_TIME_SCALE", dome2d_west_sponge_time_scale, & + 'The time-scale on the west edge of the domain for restoring T/S '//& + 'in the sponge. If zero, the western sponge is disabled', & + units='s', default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "DOME2D_EAST_SPONGE_TIME_SCALE", dome2d_east_sponge_time_scale, & + 'The time-scale on the east edge of the domain for restoring T/S '//& + 'in the sponge. If zero, the eastern sponge is disabled', & + units='s', default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "DOME2D_WEST_SPONGE_WIDTH", dome2d_west_sponge_width, & + 'The fraction of the domain in which the western sponge for restoring T/S '//& + 'is active.', & + units='nondim', default=0.1) + call get_param(param_file, mdl, "DOME2D_EAST_SPONGE_WIDTH", dome2d_east_sponge_width, & + 'The fraction of the domain in which the eastern sponge for restoring T/S '//& + 'is active.', & + units='nondim', default=0.1) + + ! Return if sponges are not in use + if (dome2d_west_sponge_time_scale <= 0. .and. dome2d_east_sponge_time_scale <= 0.) return + + if (associated(CSp)) call MOM_error(FATAL, & + "DOME2d_initialize_sponges called with an associated control structure.") + if (associated(ACSp)) call MOM_error(FATAL, & + "DOME2d_initialize_sponges called with an associated ALE-sponge control structure.") + + call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & + units="nondim", default=0.1, do_not_log=.true.) + call get_param(param_file, mdl, "DOME2D_BASIN_WIDTH", dome2d_width_bottom, & + units="nondim", default=0.3, do_not_log=.true.) + call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & + units="nondim", default=0.2, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, units="ppt", default=35.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "T_REF", T_ref, units="degC", scale=US%degC_to_C, fail_if_missing=.false.) + call get_param(param_file, mdl, "S_RANGE", S_range, units="ppt", default=2.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "T_RANGE", T_range, units="degC", default=0.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, "Initial surface salinity", & + units="ppt", default=34.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "DOME2D_EAST_SPONGE_S_RANGE", S_range_sponge, & + "Range of salinities in the eastern sponge region in the DOME2D configuration", & + units="ppt", default=1.0, scale=US%ppt_to_S) + + ! Set the sponge damping rate as a function of position + Idamp(:,:) = 0.0 + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) > 0.) then ! Only set damping rate for wet points + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon ! Non-dimensional position within domain (0,1) + if ( dome2d_west_sponge_time_scale > 0. .and. x < dome2d_west_sponge_width ) then + ! Within half the shelf width from the left edge + dummy1 = 1. - x / dome2d_west_sponge_width + Idamp(i,j) = 1./dome2d_west_sponge_time_scale * max(0., min(1., dummy1)) + elseif ( dome2d_east_sponge_time_scale > 0. .and. x > ( 1. - dome2d_east_sponge_width ) ) then + ! Within a quarter of the basin width from the right + dummy1 = 1. - ( 1. - x ) / dome2d_east_sponge_width + Idamp(i,j) = 1./dome2d_east_sponge_time_scale * max(0., min(1., dummy1)) + else + Idamp(i,j) = 0. + endif + else + Idamp(i,j) = 0. + endif + enddo ; enddo + + + if (use_ALE) then + + ! Construct a grid (somewhat arbitrarily) to describe the sponge T/S on + do k=1,nz + e0(k) = -G%max_depth * ( real(k-1) / real(nz) ) + enddo + e0(nz+1) = -G%max_depth + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(k) = e0(k) + if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then + eta1D(k) = eta1D(k+1) + GV%Angstrom_Z + dz(i,j,k) = GV%Angstrom_Z + else + dz(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + ! Construct temperature and salinity on the arbitrary grid + T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 + do j=js,je ; do i=is,ie + z = -depth_tot(i,j) + do k = nz,1,-1 + z = z + 0.5 * dz(i,j,k) ! Position of the center of layer k + ! Use salinity stratification in the eastern sponge. + S(i,j,k) = S_surf - S_range_sponge * (z / G%max_depth) + ! Use a constant salinity in the western sponge. + if ( ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon < dome2d_west_sponge_width ) & + S(i,j,k) = S_ref + S_range + z = z + 0.5 * dz(i,j,k) ! Position of the interface k + enddo + enddo ; enddo + + ! Convert thicknesses from height units to thickness units + if (associated(tv%eqn_of_state)) then + call dz_to_thickness(dz, T, S, tv%eqn_of_state, h, G, GV, US) + else + call dz_to_thickness_simple(dz, h, G, GV, US, layer_mode=.true.) + endif + + ! Store damping rates and the grid on which the T/S sponge data will reside + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) + + if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp, 'temp', & + sp_long_name='temperature', sp_unit='degC s-1') + if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & + sp_long_name='salinity', sp_unit='g kg-1 s-1') + + else + + ! Construct interface heights to restore toward + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(K) = -G%max_depth * real(k-1) / real(nz) + if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then + eta1D(K) = eta1D(K+1) + GV%Angstrom_Z + d_eta(k) = GV%Angstrom_Z + else + d_eta(k) = (eta1D(K) - eta1D(K+1)) + endif + enddo + + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then + do k=1,nz-1 ; d_eta(k) = GV%Angstrom_Z ; enddo + d_eta(nz) = dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom_Z + endif + + eta(i,j,nz+1) = -depth_tot(i,j) + do K=nz,1,-1 + eta(i,j,K) = eta(i,j,K+1) + d_eta(k) + enddo + enddo ; enddo + call initialize_sponge(Idamp, eta, G, param_file, CSp, GV) + + endif + +end subroutine DOME2d_initialize_sponges + +end module DOME2d_initialization diff --git a/user/DOME_initialization.F90 b/user/DOME_initialization.F90 new file mode 100644 index 0000000000..858ca32f93 --- /dev/null +++ b/user/DOME_initialization.F90 @@ -0,0 +1,489 @@ +!> Configures the model for the "DOME" experiment. +!! DOME = Dynamics of Overflows and Mixing Experiment +module DOME_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer +use MOM_tracer_registry, only : tracer_registry_type, tracer_type +use MOM_tracer_registry, only : tracer_name_lookup +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, calculate_density_derivs + +implicit none ; private + +#include + +public DOME_initialize_topography +public DOME_initialize_thickness +public DOME_initialize_sponges +public DOME_set_OBC_data, register_DOME_OBC + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +! ----------------------------------------------------------------------------- +!> This subroutine sets up the DOME topography +subroutine DOME_initialize_topography(D, G, param_file, max_depth, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum model depth [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real :: min_depth ! The minimum ocean depth [Z ~> m] + real :: shelf_depth ! The ocean depth on the shelf in the DOME configuration [Z ~> m] + real :: slope ! The bottom slope in the DOME configuration [Z L-1 ~> nondim] + real :: shelf_edge_lat ! The latitude of the edge of the topographic shelf [km] + real :: inflow_lon ! The edge longitude of the DOME inflow [km] + real :: inflow_width ! The longitudinal width of the DOME inflow channel [km] + real :: km_to_L ! The conversion factor from the units of latitude to L [L km-1 ~> 1e3] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "DOME_initialize_topography" ! This subroutine's name. + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + km_to_L = 1.0e3*US%m_to_L + + call MOM_mesg(" DOME_initialization.F90, DOME_initialize_topography: setting topography", 5) + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & + "The minimum depth of the ocean.", default=0.0, units="m", scale=US%m_to_Z) + call get_param(param_file, mdl, "DOME_TOPOG_SLOPE", slope, & + "The slope of the bottom topography in the DOME configuration.", & + default=0.01, units="nondim", scale=US%L_to_Z) + call get_param(param_file, mdl, "DOME_SHELF_DEPTH", shelf_depth, & + "The bottom depth in the shelf inflow region in the DOME configuration.", & + default=600.0, units="m", scale=US%m_to_Z) + call get_param(param_file, mdl, "DOME_SHELF_EDGE_LAT", shelf_edge_lat, & + "The latitude of the shelf edge in the DOME configuration.", & + default=600.0, units="km") + call get_param(param_file, mdl, "DOME_INFLOW_LON", inflow_lon, & + "The edge longitude of the DOME inflow.", units="km", default=1000.0) + call get_param(param_file, mdl, "DOME_INFLOW_WIDTH", inflow_width, & + "The longitudinal width of the DOME inflow channel.", units="km", default=100.0) + + do j=js,je ; do i=is,ie + if (G%geoLatT(i,j) < shelf_edge_lat) then + D(i,j) = min(shelf_depth - slope * (G%geoLatT(i,j)-shelf_edge_lat)*km_to_L, max_depth) + else + if ((G%geoLonT(i,j) > inflow_lon) .AND. (G%geoLonT(i,j) < inflow_lon+inflow_width)) then + D(i,j) = shelf_depth + else + D(i,j) = 0.5*min_depth + endif + endif + + if (D(i,j) > max_depth) D(i,j) = max_depth + if (D(i,j) < min_depth) D(i,j) = 0.5*min_depth + enddo ; enddo + +end subroutine DOME_initialize_topography +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> This subroutine initializes layer thicknesses for the DOME experiment +subroutine DOME_initialize_thickness(h, depth_tot, G, GV, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually + ! negative because it is positive upward [Z ~> m]. + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface + ! positive upward [Z ~> m]. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (just_read) return ! This subroutine has no run-time parameters. + + call MOM_mesg(" DOME_initialization.F90, DOME_initialize_thickness: setting thickness", 5) + + e0(1)=0.0 + do k=2,nz + e0(K) = -G%max_depth * (real(k-1)-0.5)/real(nz-1) + enddo + + do j=G%jsc,G%jec ; do i=G%isc,G%iec +! This sets the initial thickness (in m) of the layers. The ! +! thicknesses are set to insure that: 1. each layer is at least an ! +! Angstrom thick, and 2. the interfaces are where they should be ! +! based on the resting depths and interface height perturbations, ! +! as long at this doesn't interfere with 1. ! + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(K) = e0(K) + if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then + eta1D(K) = eta1D(K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z + else + h(i,j,k) = eta1D(K) - eta1D(K+1) + endif + enddo + enddo ; enddo + +end subroutine DOME_initialize_thickness +! ----------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------- +!> This subroutine sets the inverse restoration time (Idamp), and the values +!! toward which the interface heights and an arbitrary number of tracers will be +!! restored within the sponges for the DOME configuration. ! +subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing any available + !! thermodynamic fields, including potential + !! temperature and salinity or mixed layer density. + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: PF !< A structure indicating the open file to + !! parse for model parameter values. + type(sponge_CS), pointer :: CSp !< A pointer that is set to point to the control + !! structure for this module. + + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for interface heights [Z ~> m]. + real :: temp(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for other variables [various] + real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] + + real :: e_tgt(SZK_(GV)+1) ! Target interface heights [Z ~> m]. + real :: min_depth ! The minimum depth at which to apply damping [Z ~> m] + real :: damp_W, damp_E ! Damping rates in the western and eastern sponges [T-1 ~> s-1] + real :: peak_damping ! The maximum sponge damping rates as the edges [T-1 ~> s-1] + real :: km_to_L ! The conversion factor from the units of longitude to L [L km-1 ~> 1e3] + real :: edge_dist ! The distance to an edge [L ~> m] + real :: sponge_width ! The width of the sponges [L ~> m] + character(len=40) :: mdl = "DOME_initialize_sponges" ! This subroutine's name. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + km_to_L = 1.0e3*US%m_to_L + + ! Set up sponges for the DOME configuration + call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) + call get_param(PF, mdl, "DOME_SPONGE_DAMP_RATE", peak_damping, & + "The largest damping rate in the DOME sponges.", & + default=10.0, units="day-1", scale=1.0/(86400.0*US%s_to_T)) + call get_param(PF, mdl, "DOME_SPONGE_WIDTH", sponge_width, & + "The width of the the DOME sponges.", & + default=200.0, units="km", scale=km_to_L) + + ! Here the inverse damping time [T-1 ~> s-1], is set. Set Idamp to 0 wherever + ! there is no sponge, and the subroutines that are called will automatically + ! set up the sponges only where Idamp is positive and mask2dT is 1. + + Idamp(:,:) = 0.0 + do j=js,je ; do i=is,ie ; if (depth_tot(i,j) > min_depth) then + edge_dist = (G%geoLonT(i,j) - G%west_lon) * km_to_L + if (edge_dist < 0.5*sponge_width) then + damp_W = peak_damping + elseif (edge_dist < sponge_width) then + damp_W = peak_damping * (sponge_width - edge_dist) / (0.5*sponge_width) + else + damp_W = 0.0 + endif + + edge_dist = ((G%len_lon + G%west_lon) - G%geoLonT(i,j)) * km_to_L + if (edge_dist < 0.5*sponge_width) then + damp_E = peak_damping + elseif (edge_dist < sponge_width) then + damp_E = peak_damping * (sponge_width - edge_dist) / (0.5*sponge_width) + else + damp_E = 0.0 + endif + + Idamp(i,j) = max(damp_W, damp_E) + endif ; enddo ; enddo + + e_tgt(1) = 0.0 + do K=2,nz ; e_tgt(K) = -(real(K-1)-0.5)*G%max_depth / real(nz-1) ; enddo + e_tgt(nz+1) = -G%max_depth + eta(:,:,:) = 0.0 + do K=1,nz+1 ; do j=js,je ; do i=is,ie + ! These target interface heights will be rescaled inside of apply_sponge, so + ! they can be in depth space for Boussinesq or non-Boussinesq models. + eta(i,j,K) = max(e_tgt(K), GV%Angstrom_Z*(nz+1-K) - depth_tot(i,j)) + enddo ; enddo ; enddo + + ! This call stores the sponge damping rates and target interface heights. + call initialize_sponge(Idamp, eta, G, PF, CSp, GV) + + ! Now register all of the fields which are damped in the sponge. + ! By default, momentum is advected vertically within the sponge, but + ! momentum is typically not damped within the layer-mode sponge. + +! At this point, the layer-mode DOME configuration is done. The following are here as a +! template for other configurations. + + ! The remaining calls to set_up_sponge_field can be in any order. + if ( associated(tv%T) ) then + temp(:,:,:) = 0.0 + call MOM_error(FATAL,"DOME_initialize_sponges is not set up for use with"//& + " a temperatures defined.") + ! This should use the target values of T in temp. + call set_up_sponge_field(temp, tv%T, G, GV, nz, CSp) + ! This should use the target values of S in temp. + call set_up_sponge_field(temp, tv%S, G, GV, nz, CSp) + endif + +end subroutine DOME_initialize_sponges + +!> Add DOME to the OBC registry and set up some variables that will be used to guide +!! code setting up the restart fields related to the OBCs. +subroutine register_DOME_OBC(param_file, US, OBC, tr_Reg) + type(param_file_type), intent(in) :: param_file !< parameter file. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), pointer :: OBC !< OBC registry. + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. + + if (OBC%number_of_segments /= 1) then + call MOM_error(FATAL, 'Error in register_DOME_OBC - DOME should have 1 OBC segment', .true.) + endif + + ! Store this information for use in setting up the OBC restarts for tracer reservoirs. + OBC%ntr = tr_Reg%ntr + if (.not. allocated(OBC%tracer_x_reservoirs_used)) then + allocate(OBC%tracer_x_reservoirs_used(OBC%ntr)) + allocate(OBC%tracer_y_reservoirs_used(OBC%ntr)) + OBC%tracer_x_reservoirs_used(:) = .false. + OBC%tracer_y_reservoirs_used(:) = .false. + OBC%tracer_y_reservoirs_used(1) = .true. + endif + +end subroutine register_DOME_OBC + +!> This subroutine sets the properties of flow at open boundary conditions. +!! This particular example is for the DOME inflow describe in Legg et al. 2006. +subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any + !! available thermodynamic fields, including potential + !! temperature and salinity or mixed layer density. Absent + !! fields have NULL ptrs. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: PF !< A structure indicating the open file + !! to parse for model parameter values. + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. + + ! Local variables + real :: T0(SZK_(GV)) ! A profile of target temperatures [C ~> degC] + real :: S0(SZK_(GV)) ! A profile of target salinities [S ~> ppt] + real :: pres(SZK_(GV)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. + real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3]. + real :: S_ref ! A default value for salinities [S ~> ppt] + real :: T_light ! A first guess at the temperature of the lightest layer [C ~> degC] + ! The following variables are used to set up the transport in the DOME example. + real :: tr_0 ! The total integrated inflow transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: tr_k ! The integrated inflow transport of a layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: v_k ! The velocity of a layer at the edge [L T-1 ~> m s-1] + real :: yt, yb ! The log of these variables gives the fractional velocities at the + ! top and bottom of a layer [nondim] + real :: rst, rsb ! The relative position of the top and bottom of a layer [nondim], + ! with a range from 0 for the densest water to -1 for the lightest + real :: rc ! The relative position of the center of a layer [nondim] + real :: lon_im1 ! An extrapolated value for the longitude of the western edge of a + ! v-velocity face, in the same units as G%geoLon [km] + real :: D_edge ! The thickness [Z ~> m] of the dense fluid at the + ! inner edge of the inflow + real :: RLay_range ! The range of densities [R ~> kg m-3]. + real :: Rlay_Ref ! The surface layer's target density [R ~> kg m-3]. + real :: f_0 ! The reference value of the Coriolis parameter [T-1 ~> s-1] + real :: f_inflow ! The value of the Coriolis parameter used to determine DOME inflow + ! properties [T-1 ~> s-1] + real :: g_prime_tot ! The reduced gravity across all layers [L2 Z-1 T-2 ~> m s-2] + real :: Def_Rad ! The deformation radius, based on fluid of thickness D_edge [L ~> m] + real :: inflow_lon ! The edge longitude of the DOME inflow [km] + real :: I_Def_Rad ! The inverse of the deformation radius in the same units as G%geoLon [km-1] + real :: Ri_trans ! The shear Richardson number in the transition + ! region of the specified shear profile [nondim] + character(len=32) :: name ! The name of a tracer field. + character(len=40) :: mdl = "DOME_set_OBC_data" ! This subroutine's name. + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, ntherm, ntr_id + integer :: IsdB, IedB, JsdB, JedB + type(OBC_segment_type), pointer :: segment => NULL() + type(tracer_type), pointer :: tr_ptr => NULL() + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + call get_param(PF, mdl, "DOME_INFLOW_THICKNESS", D_edge, & + "The thickness of the dense DOME inflow at the inner edge.", & + default=300.0, units="m", scale=US%m_to_Z) + call get_param(PF, mdl, "DOME_INFLOW_RI_TRANS", Ri_trans, & + "The shear Richardson number in the transition region of the specified "//& + "DOME inflow shear profile.", default=(1.0/3.0), units="nondim") + call get_param(PF, mdl, "DENSITY_RANGE", Rlay_range, & + "The range of reference potential densities in the layers.", & + units="kg m-3", default=2.0, scale=US%kg_m3_to_R) + call get_param(PF, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) + call get_param(PF, mdl, "F_0", f_0, & + "The reference value of the Coriolis parameter with the betaplane option.", & + units="s-1", default=0.0, scale=US%T_to_s) + call get_param(PF, mdl, "DOME_INFLOW_F", f_inflow, & + "The value of the Coriolis parameter that is used to determine the DOME "//& + "inflow properties.", units="s-1", default=f_0*US%s_to_T, scale=US%T_to_s) + call get_param(PF, mdl, "DOME_INFLOW_LON", inflow_lon, & + "The edge longitude of the DOME inflow.", units="km", default=1000.0) + if (associated(tv%S) .or. associated(tv%T)) then + call get_param(PF, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(PF, mdl, "DOME_T_LIGHT", T_light, & + "A first guess at the temperature of the lightest layer in the DOME test case.", & + units="degC", default=25.0, scale=US%degC_to_C) + endif + + if (.not.associated(OBC)) return + + if (GV%Boussinesq) then + g_prime_tot = (GV%g_Earth / GV%Rho0) * Rlay_range + Def_Rad = sqrt(D_edge*g_prime_tot) / abs(f_inflow) + tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5*Def_Rad) * GV%Z_to_H + else + g_prime_tot = (GV%g_Earth / (Rlay_Ref + 0.5*Rlay_range)) * Rlay_range + Def_Rad = sqrt(D_edge*g_prime_tot) / abs(f_inflow) + tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5*Def_Rad) * (Rlay_Ref + 0.5*Rlay_range) * GV%RZ_to_H + endif + + I_Def_Rad = 1.0 / (1.0e-3*US%L_to_m*Def_Rad) + + if (OBC%number_of_segments /= 1) then + call MOM_error(WARNING, 'Error in DOME OBC segment setup', .true.) + return !!! Need a better error message here + endif + + segment => OBC%segment(1) + if (.not. segment%on_pe) return + + ! Set up space for the OBCs to use for all the tracers. + ntherm = 0 + if (associated(tv%S)) ntherm = ntherm + 1 + if (associated(tv%T)) ntherm = ntherm + 1 + allocate(segment%field(ntherm+tr_Reg%ntr)) + + do k=1,nz + rst = -1.0 + if (k>1) rst = -1.0 + (real(k-1)-0.5)/real(nz-1) + + rsb = 0.0 + if (k Configures the ISOMIP test case. +module ISOMIP_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge +use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : dz_to_thickness +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type +use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR +use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA +use regrid_consts, only : REGRIDDING_SIGMA_SHELF_ZSTAR +implicit none ; private + +#include + +character(len=40) :: mdl = "ISOMIP_initialization" !< This module's name. + +! The following routines are visible to the outside world +public ISOMIP_initialize_topography +public ISOMIP_initialize_thickness +public ISOMIP_initialize_temperature_salinity +public ISOMIP_initialize_sponges + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> Initialization of topography for the ISOMIP configuration +subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum model depth [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real :: min_depth ! The minimum depth of the ocean [Z ~> m]. + ! The following variables are used to set up the bathymetry in the ISOMIP example. + real :: bmax ! maximum depth of bedrock topography [Z ~> m] + real :: b0, b2, b4, b6 ! first, second, third and fourth bedrock topography coeffs [Z ~> m] + real :: xbar ! characteristic along-flow length scale of the bedrock [L ~> m] + real :: dc ! depth of the trough compared with side walls [Z ~> m]. + real :: fc ! characteristic width of the side walls of the channel [L ~> m] + real :: wc ! half-width of the trough [L ~> m] + real :: ly ! domain width (across ice flow) [L ~> m] + real :: bx, by ! The x- and y- contributions to the bathymetric profiles at a point [Z ~> m] + real :: xtil ! x-positon normalized by the characteristic along-flow length scale [nondim] + real :: km_to_L ! The conversion factor from the axis units to L [L km-1 ~> 1e3] + logical :: is_2D ! If true, use a 2D setup + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "ISOMIP_initialize_topography" ! This subroutine's name. + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + call MOM_mesg(" ISOMIP_initialization.F90, ISOMIP_initialize_topography: setting topography", 5) + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "ISOMIP_2D", is_2D, 'If true, use a 2D setup.', default=.false.) + call get_param(param_file, mdl, "ISOMIP_MAX_BEDROCK", bmax, & + "Maximum depth of bedrock topography in the ISOMIP configuration.", & + units="m", default=720.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "ISOMIP_TROUGH_DEPTH", dc, & + "Depth of the trough compared with side walls in the ISOMIP configuration.", & + units="m", default=500.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "ISOMIP_BEDROCK_LENGTH", xbar, & + "Characteristic along-flow length scale of the bedrock in the ISOMIP configuration.", & + units="m", default=300.0e3, scale=US%m_to_L) + call get_param(param_file, mdl, "ISOMIP_TROUGH_WIDTH", wc, & + "Half-width of the trough in the ISOMIP configuration.", & + units="m", default=24.0e3, scale=US%m_to_L) + call get_param(param_file, mdl, "ISOMIP_DOMAIN_WIDTH", ly, & + "Domain width (across ice flow) in the ISOMIP configuration.", & + units="m", default=80.0e3, scale=US%m_to_L) + call get_param(param_file, mdl, "ISOMIP_SIDE_WIDTH", fc, & + "Characteristic width of the side walls of the channel in the ISOMIP configuration.", & + units="m", default=4.0e3, scale=US%m_to_L) + + km_to_L = 1.0e3*US%m_to_L + + ! The following variables should be transformed into runtime parameters. + b0 = -150.0*US%m_to_Z ; b2 = -728.8*US%m_to_Z ; b4 = 343.91*US%m_to_Z ; b6 = -50.57*US%m_to_Z + + if (is_2D) then + do j=js,je ; do i=is,ie + ! For the 2D setup take a slice through the middle of the domain + xtil = G%geoLonT(i,j)*km_to_L / xbar + !xtil = 450.*km_to_L / xbar + bx = b0 + b2*xtil**2 + b4*xtil**4 + b6*xtil**6 + + by = 2.0 * dc / (1.0 + exp(2.0*wc / fc)) + + D(i,j) = -max(bx+by, -bmax) + if (D(i,j) > max_depth) D(i,j) = max_depth + if (D(i,j) < min_depth) D(i,j) = 0.5*min_depth + enddo ; enddo + + else + do j=js,je ; do i=is,ie + ! 3D setup + ! ===== TEST ===== + !if (G%geoLonT(i,j)<500.) then + ! xtil = 500.*km_to_L / xbar + !else + ! xtil = G%geoLonT(i,j)*km_to_L / xbar + !endif + ! ===== TEST ===== + + xtil = G%geoLonT(i,j)*km_to_L / xbar + + bx = b0 + b2*xtil**2 + b4*xtil**4 + b6*xtil**6 + by = (dc / (1.0 + exp(-2.*(G%geoLatT(i,j)*km_to_L - 0.5*ly - wc) / fc))) + & + (dc / (1.0 + exp(2.*(G%geoLatT(i,j)*km_to_L - 0.5*ly + wc) / fc))) + + D(i,j) = -max(bx+by, -bmax) + if (D(i,j) > max_depth) D(i,j) = max_depth + if (D(i,j) < min_depth) D(i,j) = 0.5*min_depth + enddo ; enddo + endif + +end subroutine ISOMIP_initialize_topography + +!> Initialization of thicknesses +subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure to parse for model parameter values + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any + !! available thermodynamic fields, including + !! the eqn. of state. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + ! Local variables + real :: e0(SZK_(GV)+1) ! The resting interface heights, in depth units [Z ~> m], + ! usually negative because it is positive upward. + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface + ! positive upward, in depth units [Z ~> m]. + integer :: i, j, k, is, ie, js, je, nz + real :: min_thickness ! Minimum layer thicknesses [Z ~> m] + real :: S_sur, S_bot ! Surface and bottom salinities [S ~> ppt] + real :: T_sur, T_bot ! Surface and bottom temperatures [C ~> degC] + real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] + real :: rho_range ! The range of densities [R ~> kg m-3] + !character(len=256) :: mesg ! The text of an error message + character(len=40) :: verticalCoordinate + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) & + call MOM_mesg("ISOMIP_initialization.F90, ISOMIP_initialize_thickness: setting thickness") + + call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & + 'Minimum layer thickness', units='m', default=1.e-3, do_not_log=just_read, scale=US%m_to_Z) + call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + + select case ( coordinateMode(verticalCoordinate) ) + + case ( REGRIDDING_LAYER, REGRIDDING_RHO ) ! Initial thicknesses for isopycnal coordinates + call get_param(param_file, mdl, "ISOMIP_T_SUR", t_sur, & + "Temperature at the surface (interface)", & + units="degC", default=-1.9, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "ISOMIP_S_SUR", s_sur, & + "Salinity at the surface (interface)", & + units="ppt", default=33.8, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "ISOMIP_T_BOT", t_bot, & + "Temperature at the bottom (interface)", & + units="degC", default=-1.9, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot, & + "Salinity at the bottom (interface)", & + units="ppt", default=34.55, scale=US%ppt_to_S, do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + ! Compute min/max density using T_SUR/S_SUR and T_BOT/S_BOT + call calculate_density(T_sur, S_sur, 0.0, rho_sur, tv%eqn_of_state) + ! write(mesg,*) 'Surface density is:', rho_sur + ! call MOM_mesg(mesg,5) + call calculate_density(T_bot, S_bot, 0.0, rho_bot, tv%eqn_of_state) + ! write(mesg,*) 'Bottom density is:', rho_bot + ! call MOM_mesg(mesg,5) + rho_range = rho_bot - rho_sur + ! write(mesg,*) 'Density range is:', rho_range + ! call MOM_mesg(mesg,5) + + ! Construct notional interface positions + e0(1) = 0. + do K=2,nz + e0(k) = -G%max_depth * ( 0.5 * ( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range + e0(k) = min( 0., e0(k) ) ! Bound by surface + e0(k) = max( -G%max_depth, e0(k) ) ! Bound by possible deepest point in model + ! write(mesg,*) 'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)', & + ! G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k) + ! call MOM_mesg(mesg,5) + enddo + e0(nz+1) = -G%max_depth + + ! Calculate thicknesses + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(k) = e0(k) + if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then + eta1D(k) = eta1D(k+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR ) ! Initial thicknesses for z coordinates + if (just_read) return ! All run-time parameters have been read, so return. + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(k) = -G%max_depth * real(k-1) / real(nz) + if (eta1D(k) < (eta1D(k+1) + min_thickness)) then + eta1D(k) = eta1D(k+1) + min_thickness + h(i,j,k) = min_thickness + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + 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,:) = depth_tot(i,j) / real(nz) + enddo ; enddo + + case default + call MOM_error(FATAL,"isomip_initialize: "// & + "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") + + end select + +end subroutine ISOMIP_initialize_thickness + +!> Initial values for temperature and salinity +subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, US, param_file, & + eqn_of_state, just_read) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The nominal total bottom-to-top + !! depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + logical, intent(in) :: just_read !< If true, this call will + !! only read parameters without changing T & S. + ! Local variables + real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] + real :: xi0, xi1 ! Heights in depth units [Z ~> m]. + real :: S_sur, S_bot ! Salinity at the surface and bottom [S ~> ppt] + real :: T_sur, T_bot ! Temperature at the surface and bottom [C ~> degC] + real :: dT_dz ! Vertical gradient of temperature [C Z-1 ~> degC m-1]. + real :: dS_dz ! Vertical gradient of salinity [S Z-1 ~> ppt m-1]. + real :: T0(SZK_(GV)) ! A profile of temperatures [C ~> degC] + real :: S0(SZK_(GV)) ! A profile of salinities [S ~> ppt] + real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3]. + real :: pres(SZK_(GV)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. (zero here) + real :: drho_dT1 ! A prescribed derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: drho_dS1 ! A prescribed derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + real :: T_ref ! Default value for other temperatures [C ~> degC] + real :: S_ref ! Default value for other salinities [S ~> ppt] + logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. + !real :: rho_tmp ! A temporary density used for debugging [R ~> kg m-3] + !character(len=256) :: mesg ! The text of an error message + character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz, itt + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + pres(:) = 0.0 + + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + call get_param(param_file, mdl, "ISOMIP_T_SUR",t_sur, & + "Temperature at the surface (interface)", & + units="degC", default=-1.9, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "ISOMIP_S_SUR", s_sur, & + "Salinity at the surface (interface)", & + units="ppt", default=33.8, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "ISOMIP_T_BOT", t_bot, & + "Temperature at the bottom (interface)", & + units="degC", default=-1.9, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot, & + "Salinity at the bottom (interface)", & + units="ppt", default=34.55, scale=US%ppt_to_S, do_not_log=just_read) + + call calculate_density(T_sur, S_sur, 0.0, rho_sur, eqn_of_state) + ! write(mesg,*) 'Density in the surface layer:', rho_sur + ! call MOM_mesg(mesg,5) + call calculate_density(T_bot, S_bot, 0.0, rho_bot, eqn_of_state) + ! write(mesg,*) 'Density in the bottom layer::', rho_bot + ! call MOM_mesg(mesg,5) + + select case ( coordinateMode(verticalCoordinate) ) + + case ( REGRIDDING_RHO, REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_SIGMA ) + if (just_read) return ! All run-time parameters have been read, so return. + + dS_dz = (S_sur - S_bot) / G%max_depth + dT_dz = (T_sur - T_bot) / G%max_depth + do j=js,je ; do i=is,ie + xi0 = -depth_tot(i,j) + do k = nz,1,-1 + xi0 = xi0 + 0.5 * h(i,j,k) ! Depth in middle of layer + S(i,j,k) = S_sur + dS_dz * xi0 + T(i,j,k) = T_sur + dT_dz * xi0 + xi0 = xi0 + 0.5 * h(i,j,k) ! Depth at top of layer + enddo + enddo ; enddo + + case ( REGRIDDING_LAYER ) + call get_param(param_file, mdl, "FIT_SALINITY", fit_salin, & + "If true, accept the prescribed temperature and fit the "//& + "salinity; otherwise take salinity and fit temperature.", & + default=.false., do_not_log=just_read) + call get_param(param_file, mdl, "DRHO_DS", drho_dS1, & + "Partial derivative of density with salinity.", & + units="kg m-3 ppt-1", scale=US%kg_m3_to_R*US%S_to_ppt, & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "DRHO_DT", drho_dT1, & + "Partial derivative of density with temperature.", & + units="kg m-3 K-1", scale=US%kg_m3_to_R*US%C_to_degC, & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_Ref, & + "A reference temperature used in initialization.", & + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_Ref, & + "A reference salinity used in initialization.", & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + if (just_read) return ! All run-time parameters have been read, so return. + + ! write(mesg,*) 'read drho_dS, drho_dT', drho_dS1, drho_dT1 + ! call MOM_mesg(mesg,5) + + dS_dz = (S_sur - S_bot) / G%max_depth + dT_dz = (T_sur - T_bot) / G%max_depth + + do j=js,je ; do i=is,ie + xi0 = 0.0 + do k = 1,nz + !T0(k) = T_Ref; S0(k) = S_Ref + xi1 = xi0 + 0.5 * h(i,j,k) + S0(k) = S_sur - dS_dz * xi1 + T0(k) = T_sur - dT_dz * xi1 + xi0 = xi0 + h(i,j,k) + ! write(mesg,*) 'S,T,xi0,xi1,k',S0(k),T0(k),xi0,xi1,k + ! call MOM_mesg(mesg,5) + enddo + + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, (/1,1/) ) + ! write(mesg,*) 'computed drho_dS, drho_dT', drho_dS(1), drho_dT(1) + ! call MOM_mesg(mesg,5) + call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state) + + if (fit_salin) then + ! A first guess of the layers' salinity. + do k=nz,1,-1 + S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS1) + enddo + ! Refine the guesses for each layer. + do itt=1,6 + call calculate_density(T0, S0, pres, rho_guess, eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state) + do k=1,nz + S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS1) + enddo + enddo + + else + ! A first guess of the layers' temperatures. + do k=nz,1,-1 + T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT1 + enddo + + do itt=1,6 + call calculate_density(T0, S0, pres, rho_guess, eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state) + do k=1,nz + T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + enddo + enddo + endif + + do k=1,nz + T(i,j,k) = T0(k) ; S(i,j,k) = S0(k) + enddo + + enddo ; enddo + + case default + call MOM_error(FATAL,"isomip_initialize: "// & + "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") + + end select + + ! for debugging + !i=G%iec; j=G%jec + !do k = 1,nz + ! call calculate_density(T(i,j,k), S(i,j,k),0.0,rho_tmp,eqn_of_state, scale=US%kg_m3_to_R) + ! write(mesg,*) 'k,h,T,S,rho,Rlay',k,US%Z_to_m*h(i,j,k),US%C_to_degC*T(i,j,k),US%S_to_ppt*S(i,j,k),rho_tmp,GV%Rlay(k) + ! call MOM_mesg(mesg,5) + !enddo + +end subroutine ISOMIP_initialize_temperature_salinity + +!> Sets up the the inverse restoration time (Idamp), and +! the values towards which the interface heights and an arbitrary +! number of tracers should be restored within each sponge. +subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, ACSp) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields, potential temperature and + !! salinity or mixed layer density. + !! Absent fields have NULL ptrs. + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: PF !< A structure to parse for model parameter values + logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode + type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure + type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure + ! Local variables + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp [C ~> degC] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt [S ~> ppt] + ! real :: RHO(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for RHO [R ~> kg m-3] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge layer thicknesses in height units [Z ~> m] + real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge layer thicknesses [H ~> m or kg m-2] + real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] + real :: TNUDG ! Nudging time scale [T ~> s] + real :: S_sur, S_bot ! Surface and bottom salinities in the sponge region [S ~> ppt] + real :: T_sur, T_bot ! Surface and bottom temperatures in the sponge region [C ~> degC] + real :: T_ref ! Default value for other temperatures [C ~> degC] + real :: S_ref ! Default value for other salinities [S ~> ppt] + real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] + real :: rho_range ! The range of densities [R ~> kg m-3] + real :: dT_dz ! Vertical gradient of temperature [C Z-1 ~> degC m-1] + real :: dS_dz ! Vertical gradient of salinity [S Z-1 ~> ppt m-1] + + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually + ! negative because it is positive upward. + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m]. + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for interface heights [Z ~> m]. + real :: min_depth ! The minimum depth of the ocean [Z ~> m] + real :: min_thickness ! The minimum layer thickness [Z ~> m] + real :: xi0 ! Interface heights in depth units [Z ~> m], usually negative. + !real :: rho_tmp ! A temporary density used for debugging [R ~> kg m-3] + character(len=40) :: verticalCoordinate, filename, state_file + character(len=40) :: temp_var, salt_var, eta_var, inputdir + + character(len=40) :: mdl = "ISOMIP_initialize_sponges" ! This subroutine's name. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, "Minimum layer thickness", & + units="m", default=1.e-3, scale=US%m_to_Z) + + call get_param(PF, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE) + + call get_param(PF, mdl, "ISOMIP_TNUDG", TNUDG, "Nudging time scale for sponge layers", & + units="days", default=0.0, scale=86400.0*US%s_to_T) + + call get_param(PF, mdl, "T_REF", T_ref, "Reference temperature", & + units="degC", default=10.0, scale=US%degC_to_C, do_not_log=.true.) + + call get_param(PF, mdl, "S_REF", s_ref, "Reference salinity", & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + + call get_param(PF, mdl, "ISOMIP_S_SUR_SPONGE", s_sur, & + "Surface salinity in sponge layer.", & + units="ppt", default=US%S_to_ppt*S_ref, scale=US%ppt_to_S) + + call get_param(PF, mdl, "ISOMIP_S_BOT_SPONGE", s_bot, & + "Bottom salinity in sponge layer.", & + units="ppt", default=US%S_to_ppt*S_ref, scale=US%ppt_to_S) + + call get_param(PF, mdl, "ISOMIP_T_SUR_SPONGE", t_sur, & + "Surface temperature in sponge layer.", & + units="degC", default=US%C_to_degC*T_ref, scale=US%degC_to_C) + + call get_param(PF, mdl, "ISOMIP_T_BOT_SPONGE", t_bot, & + "Bottom temperature in sponge layer.", & + units="degC", default=US%C_to_degC*T_ref, scale=US%degC_to_C) + + T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 !; RHO(:,:,:) = 0.0 + +! Set up sponges for ISOMIP configuration + call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) + + if (associated(CSp)) call MOM_error(FATAL, & + "ISOMIP_initialize_sponges called with an associated control structure.") + if (associated(ACSp)) call MOM_error(FATAL, & + "ISOMIP_initialize_sponges called with an associated ALE-sponge control structure.") + + ! Here the inverse damping time [T-1 ~> s-1], is set. Set Idamp to 0 + ! wherever there is no sponge, and the subroutines that are called + ! will automatically set up the sponges only where Idamp is positive + ! and mask2dT is 1. + + do j=js,je ; do i=is,ie + if (depth_tot(i,j) <= min_depth) then + Idamp(i,j) = 0.0 + elseif (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then + Idamp(i,j) = (1.0/TNUDG) * max(0.0, (G%geoLonT(i,j)-790.0) / (800.0-790.0)) + else + Idamp(i,j) = 0.0 + endif + + enddo ; enddo + + ! Compute min/max density using T_SUR/S_SUR and T_BOT/S_BOT + call calculate_density(T_sur, S_sur, 0.0, rho_sur, tv%eqn_of_state) + !write (mesg,*) 'Surface density in sponge:', rho_sur + ! call MOM_mesg(mesg,5) + call calculate_density(T_bot, S_bot, 0.0, rho_bot, tv%eqn_of_state) + !write (mesg,*) 'Bottom density in sponge:', rho_bot + ! call MOM_mesg(mesg,5) + rho_range = rho_bot - rho_sur + !write (mesg,*) 'Density range in sponge:', rho_range + ! call MOM_mesg(mesg,5) + + if (use_ALE) then + + select case ( coordinateMode(verticalCoordinate) ) + + case ( REGRIDDING_RHO ) + ! Construct notional interface positions + e0(1) = 0. + do K=2,nz + e0(k) = -G%max_depth * ( 0.5 * ( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range + e0(k) = min( 0., e0(k) ) ! Bound by surface + e0(k) = max( -G%max_depth, e0(k) ) ! Bound by possible deepest point in model + ! write(mesg,*) 'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)',& + ! G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k) + ! call MOM_mesg(mesg,5) + enddo + e0(nz+1) = -G%max_depth + + ! Calculate thicknesses + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(k) = e0(k) + if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then + eta1D(k) = eta1D(k+1) + GV%Angstrom_Z + dz(i,j,k) = GV%Angstrom_Z + else + dz(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR ) ! Initial thicknesses for z coordinates + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(k) = -G%max_depth * real(k-1) / real(nz) + if (eta1D(k) < (eta1D(k+1) + min_thickness)) then + eta1D(k) = eta1D(k+1) + min_thickness + dz(i,j,k) = min_thickness + else + dz(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates + do j=js,je ; do i=is,ie + dz(i,j,:) = depth_tot(i,j) / real(nz) + enddo ; enddo + + case default + call MOM_error(FATAL,"ISOMIP_initialize_sponges: "// & + "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") + + end select + + dS_dz = (S_sur - S_bot) / G%max_depth + dT_dz = (T_sur - T_bot) / G%max_depth + do j=js,je ; do i=is,ie + xi0 = -depth_tot(i,j) + do k = nz,1,-1 + xi0 = xi0 + 0.5 * dz(i,j,k) ! Depth in middle of layer + S(i,j,k) = S_sur + dS_dz * xi0 + T(i,j,k) = T_sur + dT_dz * xi0 + xi0 = xi0 + 0.5 * dz(i,j,k) ! Depth at top of layer + enddo + enddo ; enddo + + ! Convert thicknesses from height units to thickness units + if (associated(tv%eqn_of_state)) then + call dz_to_thickness(dz, T, S, tv%eqn_of_state, h, G, GV, US) + else + call MOM_error(FATAL, "The ISOMIP test case requires an equation of state.") + endif + + ! for debugging + !i=G%iec; j=G%jec + !do k = 1,nz + ! call calculate_density(T(i,j,k), S(i,j,k), 0.0, rho_tmp, tv%eqn_of_state, scale=US%kg_m3_to_R) + ! write(mesg,*) 'Sponge - k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,GV%Rlay(k) + ! call MOM_mesg(mesg,5) + !enddo + + ! This call sets up the damping rates and interface heights in the sponges. + call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, h, nz) + + ! Now register all of the fields which are damped in the sponge. ! + ! By default, momentum is advected vertically within the sponge, but ! + ! momentum is typically not damped within the sponge. ! + + ! The remaining calls to set_up_sponge_field can be in any order. ! + if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp, 'temp', & + sp_long_name='temperature', sp_unit='degC s-1') + if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & + sp_long_name='salinity', sp_unit='g kg-1 s-1') + + + else ! layer mode + ! 1) Read eta, salt and temp from IC file + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + ! GM: get two different files, one with temp and one with salt values + ! this is work around to avoid having wrong values near the surface + ! because of the FIT_SALINITY option. To get salt values right in the + ! sponge, FIT_SALINITY=False. The oposite is true for temp. One can + ! combined the *correct* temp and salt values in one file instead. + call get_param(PF, mdl, "ISOMIP_SPONGE_FILE", state_file, & + "The name of the file with temps., salts. and interfaces to "//& + "damp toward.", fail_if_missing=.true.) + call get_param(PF, mdl, "SPONGE_PTEMP_VAR", temp_var, & + "The name of the potential temperature variable in "//& + "SPONGE_STATE_FILE.", default="Temp") + call get_param(PF, mdl, "SPONGE_SALT_VAR", salt_var, & + "The name of the salinity variable in "//& + "SPONGE_STATE_FILE.", default="Salt") + call get_param(PF, mdl, "SPONGE_ETA_VAR", eta_var, & + "The name of the interface height variable in "//& + "SPONGE_STATE_FILE.", default="eta") + + !read temp and eta + filename = trim(inputdir)//trim(state_file) + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + "ISOMIP_initialize_sponges: Unable to open "//trim(filename)) + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) + call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain, scale=US%degC_to_C) + call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain, scale=US%ppt_to_S) + + ! for debugging + !i=G%iec; j=G%jec + !do k = 1,nz + ! call calculate_density(T(i,j,k), S(i,j,k), 0.0, rho_tmp, tv%eqn_of_state, scale=US%kg_m3_to_R) + ! write(mesg,*) 'Sponge - k,eta,T,S,rho,Rlay',k,eta(i,j,k),T(i,j,k),& + ! S(i,j,k),rho_tmp,GV%Rlay(k) + ! call MOM_mesg(mesg,5) + !enddo + + ! Set the sponge damping rates so that the model will know where to + ! apply the sponges, along with the interface heights. + call initialize_sponge(Idamp, eta, G, PF, CSp, GV) + ! Apply sponge in tracer fields + call set_up_sponge_field(T, tv%T, G, GV, nz, CSp) + call set_up_sponge_field(S, tv%S, G, GV, nz, CSp) + + endif + +end subroutine ISOMIP_initialize_sponges + +!> \namespace isomip_initialization +!! +!! See this paper for details: http://www.geosci-model-dev-discuss.net/8/9859/2015/gmdd-8-9859-2015.pdf +end module ISOMIP_initialization diff --git a/user/Idealized_Hurricane.F90 b/user/Idealized_Hurricane.F90 new file mode 100644 index 0000000000..0c9d5cd330 --- /dev/null +++ b/user/Idealized_Hurricane.F90 @@ -0,0 +1,676 @@ +!> Forcing for the idealized hurricane and SCM_idealized_hurricane examples. +module Idealized_hurricane + +! This file is part of MOM6. See LICENSE.md for the license. + +! History +!-------- +! November 2014: Origination. +! October 2018: Renamed module from SCM_idealized_hurricane to idealized_hurricane +! This module is no longer exclusively for use in SCM mode. +! Legacy code that can be deleted is at the bottom (currently maintained +! only to preserve exact answers in SCM mode). +! The T/S initializations have been removed since they are redundant +! w/ T/S initializations in CVMix_tests (which should be moved +! into the main state_initialization to their utility +! for multiple example cases).. +! To do +! 1. Remove the legacy SCM_idealized_hurricane_wind_forcing code +! 2. Make the hurricane-to-background wind transition a runtime parameter +! + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : allocate_mech_forcing +use MOM_grid, only : ocean_grid_type +use MOM_safe_alloc, only : safe_alloc_ptr +use MOM_time_manager, only : time_type, operator(+), operator(/), time_type_to_real +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, surface +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public idealized_hurricane_wind_init !Public interface to initialize the idealized + ! hurricane wind profile. +public idealized_hurricane_wind_forcing !Public interface to update the idealized + ! hurricane wind profile. +public SCM_idealized_hurricane_wind_forcing !Public interface to the legacy idealized + ! hurricane wind profile for SCM. + +!> Container for parameters describing idealized wind structure +type, public :: idealized_hurricane_CS ; private + + ! Parameters used to compute Holland radial wind profile + real :: rho_a !< Mean air density [R ~> kg m-3] + real :: pressure_ambient !< Pressure at surface of ambient air [R L2 T-2 ~> Pa] + real :: pressure_central !< Pressure at surface at hurricane center [R L2 T-2 ~> Pa] + real :: rad_max_wind !< Radius of maximum winds [L ~> m] + real :: max_windspeed !< Maximum wind speeds [L T-1 ~> m s-1] + real :: hurr_translation_spd !< Hurricane translation speed [L T-1 ~> m s-1] + real :: hurr_translation_dir !< Hurricane translation direction [radians] + real :: gustiness !< Gustiness (optional, used in u*) [R L Z T-2 ~> Pa] + real :: Rho0 !< A reference ocean density [R ~> kg m-3] + real :: Hurr_cen_Y0 !< The initial y position of the hurricane + !! This experiment is conducted in a Cartesian + !! grid and this is assumed to be in meters [L ~> m] + real :: Hurr_cen_X0 !< The initial x position of the hurricane + !! This experiment is conducted in a Cartesian + !! grid and this is assumed to be in meters [L ~> m] + real :: Holland_A !< Parameter 'A' from the Holland formula [nondim] + real :: Holland_B !< Parameter 'B' from the Holland formula [nondim] + real :: Holland_AxBxDP !< 'A' x 'B' x (Pressure Ambient-Pressure central) + !! for the Holland prorfile calculation [R L2 T-2 ~> Pa] + logical :: relative_tau !< A logical to take difference between wind + !! and surface currents to compute the stress + integer :: answer_date !< The vintage of the expressions in the idealized hurricane + !! test case. Values below 20190101 recover the answers + !! from the end of 2018, while higher values use expressions + !! that are rescalable and respect rotational symmetry. + + ! Parameters used if in SCM (single column model) mode + logical :: SCM_mode !< If true this being used in Single Column Model mode + logical :: BR_BENCH !< A "benchmark" configuration (which is meant to + !! provide identical wind to reproduce a previous + !! experiment, where that wind formula contained + !! an error) + real :: dy_from_center !< (Fixed) distance in y from storm center path [L ~> m] + + ! Par + real :: PI !< Mathematical constant + real :: Deg2Rad !< Mathematical constant + +end type + +! This include declares and sets the variable "version". +#include "version_variable.h" + +character(len=40) :: mdl = "idealized_hurricane" !< This module's name. + +contains + +!> Initializes wind profile for the SCM idealized hurricane example +subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) + type(time_type), intent(in) :: Time !< Model time + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Input parameter structure + type(idealized_hurricane_CS), pointer :: CS !< Parameter container for this module + + ! Local variables + real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] + real :: C ! A temporary variable [nondim] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + + ! This include declares and sets the variable "version". +# include "version_variable.h" + + if (associated(CS)) then + call MOM_error(FATAL, "idealized_hurricane_wind_init called "// & + "with an associated control structure.") + return + endif + + allocate(CS) + + CS%pi = 4.0*atan(1.0) + CS%Deg2Rad = CS%pi/180. + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + ! Parameters for computing a wind profile + call get_param(param_file, mdl, "IDL_HURR_RHO_AIR", CS%rho_a, & + "Air density used to compute the idealized hurricane wind profile.", & + units='kg/m3', default=1.2, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "IDL_HURR_AMBIENT_PRESSURE", CS%pressure_ambient, & + "Ambient pressure used in the idealized hurricane wind profile.", & + units='Pa', default=101200., scale=US%Pa_to_RL2_T2) + call get_param(param_file, mdl, "IDL_HURR_CENTRAL_PRESSURE", CS%pressure_central, & + "Central pressure used in the idealized hurricane wind profile.", & + units='Pa', default=96800., scale=US%Pa_to_RL2_T2) + call get_param(param_file, mdl, "IDL_HURR_RAD_MAX_WIND", & + CS%rad_max_wind, "Radius of maximum winds used in the "//& + "idealized hurricane wind profile.", & + units='m', default=50.e3, scale=US%m_to_L) + call get_param(param_file, mdl, "IDL_HURR_MAX_WIND", CS%max_windspeed, & + "Maximum wind speed used in the idealized hurricane"// & + "wind profile.", units='m/s', default=65., scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "IDL_HURR_TRAN_SPEED", CS%hurr_translation_spd, & + "Translation speed of hurricane used in the idealized "//& + "hurricane wind profile.", units='m/s', default=5.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "IDL_HURR_TRAN_DIR", CS%hurr_translation_dir, & + "Translation direction (towards) of hurricane used in the "//& + "idealized hurricane wind profile.", & + units='degrees', default=180.0, scale=CS%Deg2Rad) + call get_param(param_file, mdl, "IDL_HURR_X0", CS%Hurr_cen_X0, & + "Idealized Hurricane initial X position", & + units='m', default=0., scale=US%m_to_L) + call get_param(param_file, mdl, "IDL_HURR_Y0", CS%Hurr_cen_Y0, & + "Idealized Hurricane initial Y position", & + units='m', default=0., scale=US%m_to_L) + call get_param(param_file, mdl, "IDL_HURR_TAU_CURR_REL", CS%relative_tau, & + "Current relative stress switch used in the idealized hurricane wind profile.", & + default=.false.) + + ! Parameters for SCM mode + call get_param(param_file, mdl, "IDL_HURR_SCM_BR_BENCH", CS%BR_BENCH, & + "Single column mode benchmark case switch, which is "// & + "invoking a modification (bug) in the wind profile meant to "//& + "reproduce a previous implementation.", default=.false.) + call get_param(param_file, mdl, "IDL_HURR_SCM", CS%SCM_MODE, & + "Single Column mode switch used in the SCM idealized hurricane wind profile.", & + default=.false.) + call get_param(param_file, mdl, "IDL_HURR_SCM_LOCY", CS%dy_from_center, & + "Y distance of station used in the SCM idealized hurricane "//& + "wind profile.", units='m', default=50.e3, scale=US%m_to_L) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "IDL_HURR_ANSWER_DATE", CS%answer_date, & + "The vintage of the expressions in the idealized hurricane test case. "//& + "Values below 20190101 recover the answers from the end of 2018, while higher "//& + "values use expressions that are rescalable and respect rotational symmetry.", & + default=default_answer_date) + + ! The following parameters are model run-time parameters which are used + ! and logged elsewhere and so should not be logged here. The default + ! value should be consistent with the rest of the model. + call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R, do_not_log=.true.) + call get_param(param_file, mdl, "GUST_CONST", CS%gustiness, & + "The background gustiness in the winds.", & + units="Pa", default=0.0, scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, do_not_log=.true.) + + if (CS%BR_BENCH) then + CS%rho_a = 1.2*US%kg_m3_to_R + endif + dP = CS%pressure_ambient - CS%pressure_central + if (CS%answer_date < 20190101) then + C = CS%max_windspeed / sqrt( US%R_to_kg_m3 * dP ) + CS%Holland_B = C**2 * US%R_to_kg_m3*CS%rho_a * exp(1.0) + else + CS%Holland_B = CS%max_windspeed**2 * CS%rho_a * exp(1.0) / dP + endif + CS%Holland_A = (US%L_to_m*CS%rad_max_wind)**CS%Holland_B + CS%Holland_AxBxDP = CS%Holland_A*CS%Holland_B*dP + +end subroutine idealized_hurricane_wind_init + +!> Computes the surface wind for the idealized hurricane test cases +subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) + type(surface), intent(in) :: sfc_state !< Surface state structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), intent(in) :: day !< Time in days + type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(idealized_hurricane_CS), pointer :: CS !< Container for idealized hurricane parameters + + ! Local variables + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + real :: TX, TY !< wind stress components [R L Z T-2 ~> Pa] + real :: Uocn, Vocn !< Surface ocean velocity components [L T-1 ~> m s-1] + real :: YY, XX !< storm relative position [L ~> m] + real :: XC, YC !< Storm center location [L ~> m] + real :: f_local !< Local Coriolis parameter [T-1 ~> s-1] + real :: fbench !< The benchmark 'f' value [T-1 ~> s-1] + real :: fbench_fac !< A factor that is set to 0 to use the + !! benchmark 'f' value [nondim] + real :: rel_tau_fac !< A factor that is set to 0 to disable + !! current relative stress calculation [nondim] + + ! Bounds for loops and memory allocation + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + ! Allocate the forcing arrays, if necessary. + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) + + if (CS%relative_tau) then + REL_TAU_FAC = 1. + else + REL_TAU_FAC = 0. !Multiplied to 0 surface current + endif + + !> Compute storm center location + XC = CS%Hurr_cen_X0 + (time_type_to_real(day)*US%s_to_T * CS%hurr_translation_spd * & + cos(CS%hurr_translation_dir)) + YC = CS%Hurr_cen_Y0 + (time_type_to_real(day)*US%s_to_T * CS%hurr_translation_spd * & + sin(CS%hurr_translation_dir)) + + + if (CS%BR_Bench) then + ! f reset to value used in generated wind for benchmark test + fbench = 5.5659e-05 * US%T_to_s + fbench_fac = 0.0 + else + fbench = 0.0 + fbench_fac = 1.0 + endif + + !> Computes taux + do j=js,je + do I=is-1,Ieq + Uocn = sfc_state%u(I,j) * REL_TAU_FAC + if (CS%answer_date < 20190101) then + Vocn = 0.25*(sfc_state%v(i,J)+sfc_state%v(i+1,J-1)& + +sfc_state%v(i+1,J)+sfc_state%v(i,J-1))*REL_TAU_FAC + else + Vocn =0.25*((sfc_state%v(i,J)+sfc_state%v(i+1,J-1)) +& + (sfc_state%v(i+1,J)+sfc_state%v(i,J-1))) * REL_TAU_FAC + endif + f_local = abs(0.5*(G%CoriolisBu(I,J)+G%CoriolisBu(I,J-1)))*fbench_fac + fbench + ! Calculate position as a function of time. + if (CS%SCM_mode) then + YY = YC + CS%dy_from_center + XX = XC + else + YY = G%geoLatCu(I,j)*1000.*US%m_to_L - YC + XX = G%geoLonCu(I,j)*1000.*US%m_to_L - XC + endif + call idealized_hurricane_wind_profile(CS, US, f_local, YY, XX, Uocn, Vocn, TX, TY) + forces%taux(I,j) = G%mask2dCu(I,j) * TX + enddo + enddo + !> Computes tauy + do J=js-1,Jeq + do i=is,ie + if (CS%answer_date < 20190101) then + Uocn = 0.25*(sfc_state%u(I,j)+sfc_state%u(I-1,j+1) + & + sfc_state%u(I-1,j)+sfc_state%u(I,j+1))*REL_TAU_FAC + else + Uocn = 0.25*((sfc_state%u(I,j)+sfc_state%u(I-1,j+1)) + & + (sfc_state%u(I-1,j)+sfc_state%u(I,j+1))) * REL_TAU_FAC + endif + Vocn = sfc_state%v(i,J) * REL_TAU_FAC + f_local = abs(0.5*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))*fbench_fac + fbench + ! Calculate position as a function of time. + if (CS%SCM_mode) then + YY = YC + CS%dy_from_center + XX = XC + else + YY = G%geoLatCv(i,J)*1000.*US%m_to_L - YC + XX = G%geoLonCv(i,J)*1000.*US%m_to_L - XC + endif + call idealized_hurricane_wind_profile(CS, US, f_local, YY, XX, Uocn, Vocn, TX, TY) + forces%tauy(i,J) = G%mask2dCv(i,J) * TY + enddo + enddo + + !> Get Ustar + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + ! This expression can be changed if desired, but need not be. + forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(US%L_to_Z * (CS%gustiness/CS%Rho0 + & + sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) + enddo ; enddo ; endif + + !> Get tau_mag [R L Z T-2 ~> Pa] + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gustiness + & + sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) + enddo ; enddo ; endif + +end subroutine idealized_hurricane_wind_forcing + +!> Calculate the wind speed at a location as a function of time. +subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx, Ty) + ! Author: Brandon Reichl + ! Date: Nov-20-2014 + ! Aug-14-2018 Generalized for non-SCM configuration + + ! Input parameters + type(idealized_hurricane_CS), pointer :: CS !< Container for idealized hurricane parameters + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: absf !< Input Coriolis magnitude [T-1 ~> s-1] + real, intent(in) :: YY !< Location in m relative to center y [L ~> m] + real, intent(in) :: XX !< Location in m relative to center x [L ~> m] + real, intent(in) :: UOCN !< X surface current [L T-1 ~> m s-1] + real, intent(in) :: VOCN !< Y surface current [L T-1 ~> m s-1] + real, intent(out) :: Tx !< X stress [R L Z T-2 ~> Pa] + real, intent(out) :: Ty !< Y stress [R L Z T-2 ~> Pa] + + ! Local variables + + ! Wind profile terms + real :: U10 ! The 10 m wind speed [L T-1 ~> m s-1] + real :: radius ! The distance from the hurricane center [L ~> m] + real :: radius10 ! 10 times the distance from the hurricane center [L ~> m] + real :: radius_km ! The distance from the hurricane center, perhaps in km [L ~> m] or [1000 L ~> km] + real :: radiusB + real :: tmp ! A temporary variable [R L T-1 ~> kg m-2 s-1] + real :: du10 ! The magnitude of the difference between the 10 m wind and the ocean flow [L T-1 ~> m s-1] + real :: du ! The difference between the zonal 10 m wind and the zonal ocean flow [L T-1 ~> m s-1] + real :: dv ! The difference between the meridional 10 m wind and the zonal ocean flow [L T-1 ~> m s-1] + real :: CD + + !Wind angle variables + real :: Alph !< The resulting inflow angle (positive outward) + real :: Rstr + real :: A0 + real :: A1 + real :: P1 + real :: Adir + real :: V_TS ! Meridional hurricane translation speed [L T-1 ~> m s-1] + real :: U_TS ! Zonal hurricane translation speed [L T-1 ~> m s-1] + + ! Implementing Holland (1980) parameteric wind profile + + radius = SQRT(XX**2 + YY**2) + + !/ BGR + ! rkm - r converted to km for Holland prof. + ! used in km due to error, correct implementation should + ! not need rkm, but to match winds w/ experiment this must + ! be maintained. Causes winds far from storm center to be a + ! couple of m/s higher than the correct Holland prof. + if (CS%BR_Bench) then + radius_km = radius/1000. + else + ! if not comparing to benchmark, then use correct Holland prof. + radius_km = radius + endif + radiusB = (US%L_to_m*radius)**CS%Holland_B + + !/ + ! Calculate U10 in the interior (inside of 10x radius of maximum wind), + ! while adjusting U10 to 0 outside of 12x radius of maximum wind. + if (CS%answer_date < 20190101) then + if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < 10.*CS%rad_max_wind) ) then + U10 = sqrt(CS%Holland_AxBxDP*exp(-CS%Holland_A/radiusB) / (CS%rho_a*radiusB) + & + 0.25*(radius_km*absf)**2) - 0.5*radius_km*absf + elseif ( (radius > 10.*CS%rad_max_wind) .and. (radius < 15.*CS%rad_max_wind) ) then + radius10 = CS%rad_max_wind*10. + if (CS%BR_Bench) then + radius_km = radius10/1000. + else + radius_km = radius10 + endif + radiusB = (US%L_to_m*radius10)**CS%Holland_B + + U10 = (sqrt(CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) / (CS%rho_a*radiusB) + & + 0.25*(radius_km*absf)**2) - 0.5*radius_km*absf) & + * (15. - radius/CS%rad_max_wind)/5. + else + U10 = 0. + endif + else ! This is mathematically equivalent to that is above but more accurate. + if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < 10.*CS%rad_max_wind) ) then + tmp = ( 0.5*radius_km*absf) * (CS%rho_a*radiusB) + U10 = (CS%Holland_AxBxDP * exp(-CS%Holland_A/radiusB)) / & + ( tmp + sqrt(CS%Holland_AxBxDP*exp(-CS%Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + elseif ( (radius > 10.*CS%rad_max_wind) .and. (radius < 15.*CS%rad_max_wind) ) then + radius_km = 10.0 * CS%rad_max_wind + if (CS%BR_Bench) radius_km = radius_km/1000. + radiusB = (10.0*US%L_to_m*CS%rad_max_wind)**CS%Holland_B + tmp = ( 0.5*radius_km*absf) * (CS%rho_a*radiusB) + U10 = (3.0 - radius/(5.0*CS%rad_max_wind)) * (CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) ) / & + ( tmp + sqrt(CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + else + U10 = 0.0 + endif + endif + + Adir = atan2(YY,XX) + + !\ + + ! Wind angle model following Zhang and Ulhorn (2012) + ! ALPH is inflow angle positive outward. + RSTR = min(10., radius / CS%rad_max_wind) + A0 = -0.9*RSTR - 0.09*US%L_T_to_m_s*CS%max_windspeed - 14.33 + A1 = -A0*(0.04*RSTR + 0.05*US%L_T_to_m_s*CS%hurr_translation_spd + 0.14) + P1 = (6.88*RSTR - 9.60*US%L_T_to_m_s*CS%hurr_translation_spd + 85.31) * CS%Deg2Rad + ALPH = A0 - A1*cos(CS%hurr_translation_dir-Adir-P1) + if ( (radius > 10.*CS%rad_max_wind) .and.& + (radius < 15.*CS%rad_max_wind) ) then + ALPH = ALPH*(15.0 - radius/CS%rad_max_wind)/5. + elseif (radius > 15.*CS%rad_max_wind) then + ALPH = 0.0 + endif + ALPH = ALPH * CS%Deg2Rad + + ! Calculate translation speed components + U_TS = CS%hurr_translation_spd * 0.5*cos(CS%hurr_translation_dir) + V_TS = CS%hurr_translation_spd * 0.5*sin(CS%hurr_translation_dir) + + ! Set output (relative) winds + dU = U10*sin(Adir-CS%Pi-Alph) - Uocn + U_TS + dV = U10*cos(Adir-Alph) - Vocn + V_TS + + ! Use a simple drag coefficient as a function of U10 (from Sullivan et al., 2010) + du10 = sqrt(du**2+dv**2) + if (dU10 < 11.0*US%m_s_to_L_T) then + Cd = 1.2e-3 + elseif (dU10 < 20.0*US%m_s_to_L_T) then + if (CS%answer_date < 20190101) then + Cd = (0.49 + 0.065*US%L_T_to_m_s*U10)*1.e-3 + else + Cd = (0.49 + 0.065*US%L_T_to_m_s*dU10)*1.e-3 + endif + else + Cd = 1.8e-3 + endif + + ! Compute stress vector + TX = US%L_to_Z * CS%rho_a * Cd * sqrt(dU**2 + dV**2) * dU + TY = US%L_to_Z * CS%rho_a * Cd * sqrt(dU**2 + dV**2) * dV + +end subroutine idealized_hurricane_wind_profile + +!> This subroutine is primarily needed as a legacy for reproducing answers. +!! It is included as an additional subroutine rather than padded into the previous +!! routine with flags to ease its eventual removal. Its functionality is replaced +!! with the new routines and it can be deleted when answer changes are acceptable. +subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) + type(surface), intent(in) :: sfc_state !< Surface state structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), intent(in) :: day !< Time in days + type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(idealized_hurricane_CS), pointer :: CS !< Container for SCM parameters + ! Local variables + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + real :: pie, Deg2Rad + real :: du10 ! The magnitude of the difference between the 10 m wind and the ocean flow [L T-1 ~> m s-1] + real :: U10 ! The 10 m wind speed [L T-1 ~> m s-1] + real :: A, B, C ! For wind profile expression + real :: rad ! The distance from the hurricane center [L ~> m] + real :: rkm ! The distance from the hurricane center, sometimes scaled to km [L ~> m] or [1000 L ~> km] + real :: f_local ! The local Coriolis parameter [T-1 ~> s-1] + real :: xx ! x-position [L ~> m] + real :: t0 !for location + real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] + real :: rB + real :: Cd ! Air-sea drag coefficient + real :: Uocn, Vocn ! Surface ocean velocity components [L T-1 ~> m s-1] + real :: dU, dV ! Air-sea differential motion [L T-1 ~> m s-1] + !Wind angle variables + real :: Alph,Rstr, A0, A1, P1, Adir, transdir + real :: V_TS, U_TS ! Components of the translation speed [L T-1 ~> m s-1] + logical :: BR_Bench + ! Bounds for loops and memory allocation + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + ! Allocate the forcing arrays, if necessary. + + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) + pie = 4.0*atan(1.0) ; Deg2Rad = pie/180. + !/ BR + ! Implementing Holland (1980) parameteric wind profile + !------------------------------------------------------| + BR_Bench = .true. !true if comparing to LES runs | + t0 = 129600. !TC 'eye' crosses (0,0) at 36 hours| + transdir = pie !translation direction (-x) | + !------------------------------------------------------| + dP = CS%pressure_ambient - CS%pressure_central + if (CS%answer_date < 20190101) then + C = CS%max_windspeed / sqrt( US%R_to_kg_m3*dP ) + B = C**2 * US%R_to_kg_m3*CS%rho_a * exp(1.0) + if (BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test + B = C**2 * 1.2 * exp(1.0) + endif + elseif (BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test + B = (CS%max_windspeed**2 / dP ) * 1.2*US%kg_m3_to_R * exp(1.0) + else + B = (CS%max_windspeed**2 /dP ) * CS%rho_a * exp(1.0) + endif + + A = (US%L_to_m*CS%rad_max_wind / 1000.)**B + f_local = G%CoriolisBu(is,js) ! f=f(x,y) but in the SCM is constant + if (BR_Bench) then + ! f reset to value used in generated wind for benchmark test + f_local = 5.5659e-05*US%T_to_s + endif + !/ BR + ! Calculate x position as a function of time. + xx = US%s_to_T*( t0 - time_type_to_real(day)) * CS%hurr_translation_spd * cos(transdir) + rad = sqrt(xx**2 + CS%dy_from_center**2) + !/ BR + ! rkm - rad converted to km for Holland prof. + ! used in km due to error, correct implementation should + ! not need rkm, but to match winds w/ experiment this must + ! be maintained. Causes winds far from storm center to be a + ! couple of m/s higher than the correct Holland prof. + if (BR_Bench) then + rkm = rad/1000. + rB = (US%L_to_m*rkm)**B + else + ! if not comparing to benchmark, then use correct Holland prof. + rkm = rad + rB = (US%L_to_m*rad)**B + endif + !/ BR + ! Calculate U10 in the interior (inside of 10x radius of maximum wind), + ! while adjusting U10 to 0 outside of 12x radius of maximum wind. + ! Note that rho_a is set to 1.2 following generated wind for experiment + if (rad > 0.001*CS%rad_max_wind .AND. rad < 10.*CS%rad_max_wind) then + U10 = sqrt( A*B*dP*exp(-A/rB)/(1.2*US%kg_m3_to_R*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local + elseif (rad > 10.*CS%rad_max_wind .AND. rad < 12.*CS%rad_max_wind) then + rad=(CS%rad_max_wind)*10. + if (BR_Bench) then + rkm = rad/1000. + rB = (US%L_to_m*rkm)**B + else + rkm = rad + rB = (US%L_to_m*rad)**B + endif + U10 = ( sqrt( A*B*dP*exp(-A/rB)/(1.2*US%kg_m3_to_R*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local) & + * (12. - rad/CS%rad_max_wind)/2. + else + U10 = 0. + endif + Adir = atan2(CS%dy_from_center,xx) + + !/ BR + ! Wind angle model following Zhang and Ulhorn (2012) + ! ALPH is inflow angle positive outward. + RSTR = min(10., rad / CS%rad_max_wind) + A0 = -0.9*RSTR - 0.09*US%L_T_to_m_s*CS%max_windspeed - 14.33 + A1 = -A0 *(0.04*RSTR + 0.05*US%L_T_to_m_s*CS%hurr_translation_spd + 0.14) + P1 = (6.88*RSTR - 9.60*US%L_T_to_m_s*CS%hurr_translation_spd + 85.31)*pie/180. + ALPH = A0 - A1*cos( (TRANSDIR - ADIR ) - P1) + if (rad > 10.*CS%rad_max_wind .AND. rad < 12.*CS%rad_max_wind) then + ALPH = ALPH* (12. - rad/CS%rad_max_wind)/2. + elseif (rad > 12.*CS%rad_max_wind) then + ALPH = 0.0 + endif + ALPH = ALPH * Deg2Rad + !/BR + ! Prepare for wind calculation + ! X_TS is component of translation speed added to wind vector + ! due to background steering wind. + U_TS = CS%hurr_translation_spd*0.5*cos(transdir) + V_TS = CS%hurr_translation_spd*0.5*sin(transdir) + + ! Set the surface wind stresses, in [R L Z T-2 ~> Pa]. A positive taux + ! accelerates the ocean to the (pseudo-)east. + ! The i-loop extends to is-1 so that taux can be used later in the + ! calculation of ustar - otherwise the lower bound would be Isq. + do j=js,je ; do I=is-1,Ieq + !/BR + ! Turn off surface current for stress calculation to be + ! consistent with test case. + Uocn = 0. ! sfc_state%u(I,j) + Vocn = 0. ! 0.25*( (sfc_state%v(i,J) + sfc_state%v(i+1,J-1)) + & + ! (sfc_state%v(i+1,J) + sfc_state%v(i,J-1)) ) + !/BR + ! Wind vector calculated from location/direction (sin/cos flipped b/c + ! cyclonic wind is 90 deg. phase shifted from position angle). + dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS + dV = U10*cos(Adir-Alph) - Vocn + V_TS + !/----------------------------------------------------| + !BR + ! Add a simple drag coefficient as a function of U10 | + !/----------------------------------------------------| + du10 = sqrt(du**2+dv**2) + if (dU10 < 11.0*US%m_s_to_L_T) then + Cd = 1.2e-3 + elseif (dU10 < 20.0*US%m_s_to_L_T) then + if (CS%answer_date < 20190101) then + Cd = (0.49 + 0.065 * US%L_T_to_m_s*U10 )*0.001 + else + Cd = (0.49 + 0.065 * US%L_T_to_m_s*dU10 )*0.001 + endif + else + Cd = 0.0018 + endif + forces%taux(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCu(I,j) * Cd*du10*dU + enddo ; enddo + !/BR + ! See notes above + do J=js-1,Jeq ; do i=is,ie + Uocn = 0. ! 0.25*( (sfc_state%u(I,j) + sfc_state%u(I-1,j+1)) + & + ! (sfc_state%u(I-1,j) + sfc_state%u(I,j+1)) ) + Vocn = 0. ! sfc_state%v(i,J) + dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS + dV = U10*cos(Adir-Alph) - Vocn + V_TS + du10=sqrt(du**2+dv**2) + if (dU10 < 11.0*US%m_s_to_L_T) then + Cd = 1.2e-3 + elseif (dU10 < 20.0*US%m_s_to_L_T) then + if (CS%answer_date < 20190101) then + Cd = (0.49 + 0.065 * US%L_T_to_m_s*U10 )*0.001 + else + Cd = (0.49 + 0.065 * US%L_T_to_m_s*dU10 )*0.001 + endif + else + Cd = 0.0018 + endif + forces%tauy(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCv(I,j) * Cd*dU10*dV + enddo ; enddo + + ! Set the surface friction velocity [Z T-1 ~> m s-1]. ustar is always positive. + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + ! This expression can be changed if desired, but need not be. + forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(US%L_to_Z * (CS%gustiness/CS%Rho0 + & + sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) + enddo ; enddo ; endif + + !> Set magnitude of the wind stress [R L Z T-2 ~> Pa] + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gustiness + & + sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) + enddo ; enddo ; endif + +end subroutine SCM_idealized_hurricane_wind_forcing + +end module idealized_hurricane diff --git a/user/Kelvin_initialization.F90 b/user/Kelvin_initialization.F90 new file mode 100644 index 0000000000..1fc8a2f564 --- /dev/null +++ b/user/Kelvin_initialization.F90 @@ -0,0 +1,375 @@ +!> Configures the model for the Kelvin wave experiment. +!! +!! Kelvin = coastally-trapped Kelvin waves from the ROMS examples. +!! Initialize with level surfaces and drive the wave in at the west, +!! radiate out at the east. +module Kelvin_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : OBC_segment_type, register_OBC +use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_E +use MOM_open_boundary, only : OBC_DIRECTION_S, OBC_DIRECTION_W +use MOM_open_boundary, only : OBC_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_time_manager, only : time_type, time_type_to_real + +implicit none ; private + +#include + +public Kelvin_set_OBC_data, Kelvin_initialize_topography +public register_Kelvin_OBC, Kelvin_OBC_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure for Kelvin wave open boundaries. +type, public :: Kelvin_OBC_CS ; private + integer :: mode = 0 !< Vertical mode + real :: coast_angle = 0 !< Angle of coastline [rad] + real :: coast_offset1 = 0 !< Longshore distance to coastal angle [L ~> m] + real :: coast_offset2 = 0 !< Offshore distance to coastal angle [L ~> m] + real :: H0 = 0 !< Bottom depth [Z ~> m] + real :: F_0 !< Coriolis parameter [T-1 ~> s-1] + real :: rho_range !< Density range [R ~> kg m-3] + real :: rho_0 !< Mean density [R ~> kg m-3] + real :: wave_period !< Period of the mode-0 waves [T ~> s] + real :: ssh_amp !< Amplitude of the sea surface height forcing for mode-0 waves [Z ~> m] + real :: inflow_amp !< Amplitude of the boundary velocity forcing for internal waves [L T-1 ~> m s-1] +end type Kelvin_OBC_CS + +! This include declares and sets the variable "version". +#include "version_variable.h" + +contains + +!> Add Kelvin wave to OBC registry. +function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) + type(param_file_type), intent(in) :: param_file !< parameter file. + type(Kelvin_OBC_CS), pointer :: CS !< Kelvin wave control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. + + ! Local variables + logical :: register_Kelvin_OBC + character(len=40) :: mdl = "register_Kelvin_OBC" !< This subroutine's name. + character(len=32) :: casename = "Kelvin wave" !< This case's name. + character(len=200) :: config + + if (associated(CS)) then + call MOM_error(WARNING, "register_Kelvin_OBC called with an "// & + "associated control structure.") + return + endif + allocate(CS) + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "KELVIN_WAVE_MODE", CS%mode, & + "Vertical Kelvin wave mode imposed at upstream open boundary.", & + default=0) + call get_param(param_file, mdl, "F_0", CS%F_0, & + default=0.0, units="s-1", scale=US%T_to_s, do_not_log=.true.) + call get_param(param_file, mdl, "TOPO_CONFIG", config, fail_if_missing=.true., do_not_log=.true.) + if (trim(config) == "Kelvin") then + call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_1", CS%coast_offset1, & + "The distance along the southern and northern boundaries "//& + "at which the coasts angle in.", & + units="km", default=100.0, scale=1.0e3*US%m_to_L) + call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_2", CS%coast_offset2, & + "The distance from the southern and northern boundaries "//& + "at which the coasts angle in.", & + units="km", default=10.0, scale=1.0e3*US%m_to_L) + call get_param(param_file, mdl, "ROTATED_COAST_ANGLE", CS%coast_angle, & + "The angle of the southern bondary beyond X=ROTATED_COAST_OFFSET.", & + units="degrees", default=11.3, scale=atan(1.0)/45.) ! Convert to radians + else + CS%coast_offset1 = 0.0 ; CS%coast_offset2 = 0.0 ; CS%coast_angle = 0.0 + endif + if (CS%mode == 0) then + call get_param(param_file, mdl, "KELVIN_WAVE_PERIOD", CS%wave_period, & + "The period of the Kelvin wave forcing at the open boundaries. "//& + "The default value is the M2 tide period.", & + units="s", default=12.42*3600.0, scale=US%s_to_T) + call get_param(param_file, mdl, "KELVIN_WAVE_SSH_AMP", CS%ssh_amp, & + "The amplitude of the Kelvin wave sea surface height anomaly forcing "//& + "at the open boundaries.", units="m", default=1.0, scale=US%m_to_Z) + else + call get_param(param_file, mdl, "DENSITY_RANGE", CS%rho_range, & + units="kg m-3", default=2.0, scale=US%kg_m3_to_R, do_not_log=.true.) + call get_param(param_file, mdl, "RHO_0", CS%rho_0, & + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R, do_not_log=.true.) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", CS%H0, & + units="m", default=1000.0, scale=US%m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "KELVIN_WAVE_INFLOW_AMP", CS%inflow_amp, & + "The amplitude of the Kelvin wave sea surface inflow velocity forcing "//& + "at the open boundaries.", units="m s-1", default=1.0, scale=US%m_s_to_L_T) + endif + + ! Register the Kelvin open boundary. + call register_OBC(casename, param_file, OBC_Reg) + register_Kelvin_OBC = .true. + +end function register_Kelvin_OBC + +!> Clean up the Kelvin wave OBC from registry. +subroutine Kelvin_OBC_end(CS) + type(Kelvin_OBC_CS), pointer :: CS !< Kelvin wave control structure. + + if (associated(CS)) then + deallocate(CS) + endif +end subroutine Kelvin_OBC_end + +! ----------------------------------------------------------------------------- +!> This subroutine sets up the Kelvin topography and land mask +subroutine Kelvin_initialize_topography(D, G, param_file, max_depth, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum model depth [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + character(len=40) :: mdl = "Kelvin_initialize_topography" ! This subroutine's name. + real :: min_depth ! The minimum and maximum depths [Z ~> m]. + real :: coast_angle ! Angle of coastline [rad] + real :: coast_offset1 ! Longshore distance to coastal angle [L ~> m] + real :: coast_offset2 ! Offshore distance to coastal angle [L ~> m] + integer :: i, j + + call MOM_mesg(" Kelvin_initialization.F90, Kelvin_initialize_topography: setting topography", 5) + + call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_1", coast_offset1, & + units="km", default=100.0, do_not_log=.true.) + call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_2", coast_offset2, & + units="km", default=10.0, do_not_log=.true.) + call get_param(param_file, mdl, "ROTATED_COAST_ANGLE", coast_angle, & + units="degrees", default=11.3, scale=(atan(1.0)/45.), do_not_log=.true.) ! Convert to radians + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + D(i,j) = max_depth + ! Southern side + if ((G%geoLonT(i,j) - G%west_lon > coast_offset1) .AND. & + (atan2(G%geoLatT(i,j) - G%south_lat + coast_offset2, & + G%geoLonT(i,j) - G%west_lon - coast_offset1) < coast_angle)) & + D(i,j) = 0.5*min_depth + ! Northern side + if ((G%geoLonT(i,j) - G%west_lon < G%len_lon - coast_offset1) .AND. & + (atan2(G%len_lat + G%south_lat + coast_offset2 - G%geoLatT(i,j), & + G%len_lon + G%west_lon - coast_offset1 - G%geoLonT(i,j)) < coast_angle)) & + D(i,j) = 0.5*min_depth + + if (D(i,j) > max_depth) D(i,j) = max_depth + if (D(i,j) < min_depth) D(i,j) = 0.5*min_depth + enddo ; enddo + +end subroutine Kelvin_initialize_topography + +!> This subroutine sets the properties of flow at open boundary conditions. +subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(Kelvin_OBC_CS), pointer :: CS !< Kelvin wave control structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2]. + type(time_type), intent(in) :: Time !< model time. + + ! The following variables are used to set up the transport in the Kelvin example. + real :: time_sec ! The time in the run [T ~> s] + real :: cff ! The wave speed [L T-1 ~> m s-1] + real :: N0 ! Brunt-Vaisala frequency times a rescaling of slopes [L Z-1 T-1 ~> s-1] + real :: lambda ! Offshore decay scale [L-1 ~> m-1] + real :: omega ! Wave frequency [T-1 ~> s-1] + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: depth_tot(SZI_(G),SZJ_(G)) ! The total depth of the ocean [Z ~> m] + real :: mag_SSH ! An overall magnitude of the external wave sea surface height at the coastline [Z ~> m] + real :: mag_int ! An overall magnitude of the internal wave at the coastline [L2 T-2 ~> m2 s-2] + real :: x1, y1 ! Various positions [L ~> m] + real :: x, y ! Various positions [L ~> m] + real :: val1 ! The periodicity factor [nondim] + real :: val2 ! The local wave amplitude [Z ~> m] + real :: km_to_L_scale ! A scaling factor from longitudes in km to L [L km-1 ~> 1e3] + real :: sina, cosa ! The sine and cosine of the coast angle [nondim] + type(OBC_segment_type), pointer :: segment => NULL() + integer :: i, j, k, n, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(OBC)) call MOM_error(FATAL, 'Kelvin_initialization.F90: '// & + 'Kelvin_set_OBC_data() was called but OBC type was not initialized!') + + time_sec = US%s_to_T*time_type_to_real(Time) + PI = 4.0*atan(1.0) + km_to_L_scale = 1000.0*US%m_to_L + + do j=jsd,jed ; do i=isd,ied + depth_tot(i,j) = 0.0 + enddo ; enddo + do k=1,nz ; do j=jsd,jed ; do i=isd,ied + depth_tot(i,j) = depth_tot(i,j) + GV%H_to_Z * h(i,j,k) + enddo ; enddo ; enddo + + if (CS%mode == 0) then + mag_SSH = CS%ssh_amp + omega = 2.0 * PI / CS%wave_period + val1 = sin(omega * time_sec) + else + mag_int = CS%inflow_amp**2 + N0 = sqrt((CS%rho_range / CS%rho_0) * (GV%g_Earth / CS%H0)) + lambda = PI * CS%mode * CS%F_0 / (CS%H0 * N0) + ! Two wavelengths in domain + omega = (4.0 * CS%H0 * N0) / (CS%mode * US%m_to_L*G%len_lon) + endif + + sina = sin(CS%coast_angle) + cosa = cos(CS%coast_angle) + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + ! Apply values to the inflow end only. + if (segment%direction == OBC_DIRECTION_E) cycle + if (segment%direction == OBC_DIRECTION_N) cycle + + ! This should be somewhere else... + !### This is supposed to be a timescale [T ~> s] but appears to be a rate in [s-1]. + segment%Velocity_nudging_timescale_in = US%s_to_T * 1.0/(0.3*86400) + + if (segment%direction == OBC_DIRECTION_W) then + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + jsd = segment%HI%jsd ; jed = segment%HI%jed + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + do j=jsd,jed ; do I=IsdB,IedB + x1 = km_to_L_scale * G%geoLonCu(I,j) + y1 = km_to_L_scale * G%geoLatCu(I,j) + x = (x1 - CS%coast_offset1) * cosa + y1 * sina + y = -(x1 - CS%coast_offset1) * sina + y1 * cosa + if (CS%mode == 0) then + ! Use inside bathymetry + cff = sqrt(GV%g_Earth * depth_tot(i+1,j) ) + val2 = mag_SSH * exp(- CS%F_0 * y / cff) + segment%SSH(I,j) = val2 * cos(omega * time_sec) + segment%normal_vel_bt(I,j) = val2 * (val1 * cff * cosa / depth_tot(i+1,j) ) + if (segment%nudged) then + do k=1,nz + segment%nudged_normal_vel(I,j,k) = val2 * (val1 * cff * cosa / depth_tot(i+1,j) ) + enddo + elseif (segment%specified) then + do k=1,nz + segment%normal_vel(I,j,k) = val2 * (val1 * cff * cosa / depth_tot(i+1,j) ) + segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) + enddo + endif + else + ! Baroclinic, not rotated yet + segment%SSH(I,j) = 0.0 + segment%normal_vel_bt(I,j) = 0.0 + if (segment%nudged) then + do k=1,nz + segment%nudged_normal_vel(I,j,k) = mag_int * lambda / CS%F_0 * & + exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & + cos(omega * time_sec) + enddo + elseif (segment%specified) then + do k=1,nz + segment%normal_vel(I,j,k) = mag_int * lambda / CS%F_0 * & + exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & + cos(omega * time_sec) + segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) + enddo + endif + endif + enddo ; enddo + if (allocated(segment%tangential_vel)) then + do J=JsdB+1,JedB-1 ; do I=IsdB,IedB + x1 = km_to_L_scale * G%geoLonBu(I,J) + y1 = km_to_L_scale * G%geoLatBu(I,J) + x = (x1 - CS%coast_offset1) * cosa + y1 * sina + y = - (x1 - CS%coast_offset1) * sina + y1 * cosa + cff = sqrt(GV%g_Earth * depth_tot(i+1,j) ) + val2 = mag_SSH * exp(- CS%F_0 * y / cff) + if (CS%mode == 0) then ; do k=1,nz + segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & + ( 0.5*(depth_tot(i+1,j+1) + depth_tot(i+1,j) ) ) + + enddo ; endif + enddo ; enddo + endif + else ! Must be south + isd = segment%HI%isd ; ied = segment%HI%ied + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + do J=JsdB,JedB ; do i=isd,ied + x1 = km_to_L_scale * G%geoLonCv(i,J) + y1 = km_to_L_scale * G%geoLatCv(i,J) + x = (x1 - CS%coast_offset1) * cosa + y1 * sina + y = - (x1 - CS%coast_offset1) * sina + y1 * cosa + if (CS%mode == 0) then + cff = sqrt(GV%g_Earth * depth_tot(i,j+1) ) + val2 = mag_SSH * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) + segment%SSH(I,j) = val2 * cos(omega * time_sec) + segment%normal_vel_bt(I,j) = (val1 * cff * sina / depth_tot(i,j+1) ) * val2 + if (segment%nudged) then + do k=1,nz + segment%nudged_normal_vel(I,j,k) = (val1 * cff * sina / depth_tot(i,j+1)) * val2 + enddo + elseif (segment%specified) then + do k=1,nz + segment%normal_vel(I,j,k) = (val1 * cff * sina / depth_tot(i,j+1) ) * val2 + segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) + enddo + endif + else + ! Not rotated yet + segment%SSH(i,J) = 0.0 + segment%normal_vel_bt(i,J) = 0.0 + if (segment%nudged) then + do k=1,nz + segment%nudged_normal_vel(i,J,k) = mag_int * lambda / CS%F_0 * & + exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa + enddo + elseif (segment%specified) then + do k=1,nz + segment%normal_vel(i,J,k) = mag_int * lambda / CS%F_0 * & + exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa + segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) + enddo + endif + endif + enddo ; enddo + if (allocated(segment%tangential_vel)) then + do J=JsdB,JedB ; do I=IsdB+1,IedB-1 + x1 = km_to_L_scale * G%geoLonBu(I,J) + y1 = km_to_L_scale * G%geoLatBu(I,J) + x = (x1 - CS%coast_offset1) * cosa + y1 * sina + y = - (x1 - CS%coast_offset1) * sina + y1 * cosa + cff = sqrt(GV%g_Earth * depth_tot(i,j+1) ) + val2 = mag_SSH * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) + if (CS%mode == 0) then ; do k=1,nz + segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & + ( 0.5*(depth_tot(i+1,j+1) + depth_tot(i,j+1)) ) + enddo ; endif + enddo ; enddo + endif + endif + enddo + +end subroutine Kelvin_set_OBC_data + +end module Kelvin_initialization diff --git a/user/MOM_controlled_forcing.F90 b/user/MOM_controlled_forcing.F90 new file mode 100644 index 0000000000..363a41f72f --- /dev/null +++ b/user/MOM_controlled_forcing.F90 @@ -0,0 +1,649 @@ +!> Use control-theory to adjust the surface heat flux and precipitation. +!! +!! Adjustments are based on the time-mean or periodically (seasonally) varying +!! anomalies from the observed state. +!! +!! The techniques behind this are described in Hallberg and Adcroft (2018, in prep.). +module MOM_controlled_forcing + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : post_data, query_averaging_enabled, enable_averages, disable_averaging +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr +use MOM_domains, only : pass_var, pass_vector, AGRID, To_South, To_West, To_All +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_time_manager, only : time_type, operator(+), operator(/), operator(-) +use MOM_time_manager, only : get_date, set_date +use MOM_time_manager, only : time_type_to_real, real_to_time +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface + +implicit none ; private + +#include + +public apply_ctrl_forcing, register_ctrl_forcing_restarts +public controlled_forcing_init, controlled_forcing_end + +!> Control structure for MOM_controlled_forcing +type, public :: ctrl_forcing_CS ; private + logical :: use_temperature !< If true, temperature and salinity are used as state variables. + logical :: do_integrated !< If true, use time-integrated anomalies to control the surface state. + integer :: num_cycle !< The number of elements in the forcing cycle. + real :: heat_int_rate !< The rate at which heating anomalies accumulate [T-1 ~> s-1] + real :: prec_int_rate !< The rate at which precipitation anomalies accumulate [T-1 ~> s-1] + real :: heat_cyc_rate !< The rate at which cyclical heating anomalies accumulate [T-1 ~> s-1] + real :: prec_cyc_rate !< The rate at which cyclical precipitation anomalies + !! accumulate [T-1 ~> s-1] + real :: Len2 !< The square of the length scale over which the anomalies + !! are smoothed via a Laplacian filter [L2 ~> m2] + real :: lam_heat !< A constant of proportionality between SST anomalies + !! and heat fluxes [Q R Z T-1 C-1 ~> W m-2 degC-1] + real :: lam_prec !< A constant of proportionality between SSS anomalies + !! (normalised by mean SSS) and precipitation [R Z T-1 ~> kg m-2 s-1] + real :: lam_cyc_heat !< A constant of proportionality between cyclical SST + !! anomalies and corrective heat fluxes [Q R Z T-1 C-1 ~> W m-2 degC-1] + real :: lam_cyc_prec !< A constant of proportionality between cyclical SSS + !! anomalies (normalised by mean SSS) and corrective + !! precipitation [R Z T-1 ~> kg m-2 s-1] + + real, pointer, dimension(:,:) :: & + heat_0 => NULL(), & !< The non-periodic integrative corrective heat flux that has been + !! evolved to control mean SST anomalies [Q R Z T-1 ~> W m-2] + precip_0 => NULL() !< The non-periodic integrative corrective precipitation that has been + !! evolved to control mean SSS anomalies [R Z T-1 ~> kg m-2 s-1] + + ! The final dimension of each of the six variables that follow is for the periodic bins. + real, pointer, dimension(:,:,:) :: & + heat_cyc => NULL(), & !< The periodic integrative corrective heat flux that has been evolved + !! to control periodic (seasonal) SST anomalies [Q R Z T-1 ~> W m-2]. + !! The third dimension is the periodic bins. + precip_cyc => NULL() !< The non-periodic integrative corrective precipitation that has been + !! evolved to control periodic (seasonal) SSS anomalies [R Z T-1 ~> kg m-2 s-1]. + !! The third dimension is the periodic bins. + real, pointer, dimension(:) :: & + avg_time => NULL() !< The accumulated averaging time in each part of the cycle [T ~> s] or + !! a negative value to indicate that the variables like avg_SST_anom are + !! the actual averages, and not time integrals. + !! The dimension is the periodic bins. + real, pointer, dimension(:,:,:) :: & + avg_SST_anom => NULL(), & !< The time-averaged periodic sea surface temperature anomalies [C ~> degC], + !! or (at some points in the code), the time-integrated periodic + !! temperature anomalies [T C ~> s degC]. + !! The third dimension is the periodic bins. + avg_SSS_anom => NULL(), & !< The time-averaged periodic sea surface salinity anomalies [S ~> ppt], + !! or (at some points in the code), the time-integrated periodic + !! salinity anomalies [T S ~> s ppt]. + !! The third dimension is the periodic bins. + avg_SSS => NULL() !< The time-averaged periodic sea surface salinities [S ~> ppt], or (at + !! some points in the code), the time-integrated periodic + !! salinities [T S ~> s ppt]. + !! The third dimension is the periodic bins. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + integer :: id_heat_0 = -1 !< Diagnostic handle for the steady heat flux + integer :: id_prec_0 = -1 !< Diagnostic handle for the steady precipitation +end type ctrl_forcing_CS + +contains + +!> This subroutine determines corrective surface forcing fields using simple control theory. +subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_precip, & + day_start, dt, G, US, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SST_anom !< The sea surface temperature anomalies [C ~> degC] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SSS_anom !< The sea surface salinity anomlies [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SSS_mean !< The mean sea surface salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: virt_heat !< Virtual (corrective) heat + !! fluxes that are augmented in this + !! subroutine [Q R Z T-1 ~> W m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: virt_precip !< Virtual (corrective) + !! precipitation fluxes that are augmented + !! in this subroutine [R Z T-1 ~> kg m-2 s-1] + type(time_type), intent(in) :: day_start !< Start time of the fluxes. + real, intent(in) :: dt !< Length of time over which these fluxes + !! will be applied [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ctrl_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to ctrl_forcing_init. + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G)) :: & + flux_heat_x, & ! Zonal smoothing flux of the virtual heat fluxes [L2 Q R Z T-1 ~> W] + flux_prec_x ! Zonal smoothing flux of the virtual precipitation [L2 R Z T-1 ~> kg s-1] + real, dimension(SZI_(G),SZJB_(G)) :: & + flux_heat_y, & ! Meridional smoothing flux of the virtual heat fluxes [L2 Q R Z T-1 ~> W] + flux_prec_y ! Meridional smoothing flux of the virtual precipitation [L2 R Z T-1 ~> kg s-1] + type(time_type) :: day_end + real :: coef ! A heat-flux coefficient [L2 ~> m2] + real :: mr_st, mr_end, mr_mid ! Position of various times in the periodic cycle [nondim] + real :: mr_prev, mr_next ! Position of various times in the periodic cycle [nondim] + real :: dt_wt ! The timestep times a fractional weight used to accumulate averages [T ~> s] + real :: dt_heat_rate, dt_prec_rate ! Timestep times the flux accumulation rate [nondim] + real :: dt1_heat_rate, dt1_prec_rate, dt2_heat_rate, dt2_prec_rate ! [nondim] + real :: wt_per1, wt_st, wt_end, wt_mid ! Averaging weights [nondim] + integer :: m_st, m_end, m_mid, m_u1, m_u2, m_u3 ! Indices (nominally months) in the periodic cycle + integer :: yr, mon, day, hr, min, sec + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if (.not.associated(CS)) return + if ((CS%num_cycle <= 0) .and. (.not.CS%do_integrated)) return + + day_end = day_start + real_to_time(US%T_to_s*dt) + + do j=js,je ; do i=is,ie + virt_heat(i,j) = 0.0 ; virt_precip(i,j) = 0.0 + enddo ; enddo + + if (CS%do_integrated) then + dt_heat_rate = dt * CS%heat_int_rate + dt_prec_rate = dt * CS%prec_int_rate + call pass_var(CS%heat_0, G%Domain, complete=.false.) + call pass_var(CS%precip_0, G%Domain) + + do j=js,je ; do I=is-1,ie + coef = CS%Len2 * (G%dy_Cu(I,j)*G%IdxCu(I,j)) + flux_heat_x(I,j) = coef * (CS%heat_0(i,j) - CS%heat_0(i+1,j)) + flux_prec_x(I,j) = coef * (CS%precip_0(i,j) - CS%precip_0(i+1,j)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + coef = CS%Len2 * (G%dx_Cv(i,J)*G%IdyCv(i,J)) + flux_heat_y(i,J) = coef * (CS%heat_0(i,j) - CS%heat_0(i,j+1)) + flux_prec_y(i,J) = coef * (CS%precip_0(i,j) - CS%precip_0(i,j+1)) + enddo ; enddo + do j=js,je ; do i=is,ie + CS%heat_0(i,j) = CS%heat_0(i,j) + dt_heat_rate * ( & + -CS%lam_heat*G%mask2dT(i,j)*SST_anom(i,j) + & + (G%IareaT(i,j) * ((flux_heat_x(I-1,j) - flux_heat_x(I,j)) + & + (flux_heat_y(i,J-1) - flux_heat_y(i,J))) ) ) + + CS%precip_0(i,j) = CS%precip_0(i,j) + dt_prec_rate * ( & + CS%lam_prec * G%mask2dT(i,j)*(SSS_anom(i,j) / SSS_mean(i,j)) + & + (G%IareaT(i,j) * ((flux_prec_x(I-1,j) - flux_prec_x(I,j)) + & + (flux_prec_y(i,J-1) - flux_prec_y(i,J))) ) ) + + virt_heat(i,j) = virt_heat(i,j) + CS%heat_0(i,j) + virt_precip(i,j) = virt_precip(i,j) + CS%precip_0(i,j) + enddo ; enddo + endif + + if (CS%num_cycle > 0) then + ! Determine the current period, with values that run from 0 to CS%num_cycle. + call get_date(day_start, yr, mon, day, hr, min, sec) + mr_st = CS%num_cycle * (time_type_to_real(day_start - set_date(yr, 1, 1)) / & + time_type_to_real(set_date(yr+1, 1, 1) - set_date(yr, 1, 1))) + + call get_date(day_end, yr, mon, day, hr, min, sec) + mr_end = CS%num_cycle * (time_type_to_real(day_end - set_date(yr, 1, 1)) / & + time_type_to_real(set_date(yr+1, 1, 1) - set_date(yr, 1, 1))) + + ! The Chapeau functions are centered at whole integer values that are nominally + ! the end of the month to enable simple conversion from the fractional-years times + ! CS%num_cycle. + + ! The month-average temperatures have as an index the month number. + + m_end = periodic_int(real(ceiling(mr_end)), CS%num_cycle) + m_mid = periodic_int(real(ceiling(mr_st)), CS%num_cycle) + m_st = periodic_int(mr_st, CS%num_cycle) + + mr_st = periodic_real(mr_st, CS%num_cycle) + mr_end = periodic_real(mr_end, CS%num_cycle) + ! mr_mid = periodic_real(ceiling(mr_st), CS%num_cycle) + mr_prev = periodic_real(real(floor(mr_st)), CS%num_cycle) + mr_next = periodic_real(real(m_end), CS%num_cycle) + if (m_mid == m_end) then ; mr_mid = mr_end ! There is only one cell. + else ; mr_mid = periodic_real(real(m_mid), CS%num_cycle) ; endif + + ! There may be two cells that run from mr_st to mr_mid and mr_mid to mr_end. + + ! The values of m for weights are all calculated relative to mr_prev, so + ! check whether mr_mid, etc., need to be shifted by CS%num_cycle, so that these + ! values satisfiy mr_prev <= mr_st < mr_mid <= mr_end <= mr_next. + if (mr_st < mr_prev) mr_prev = mr_prev - CS%num_cycle + if (mr_mid < mr_st) mr_mid = mr_mid + CS%num_cycle + if (mr_end < mr_st) mr_end = mr_end + CS%num_cycle + if (mr_next < mr_prev) mr_next = mr_next + CS%num_cycle + + !### These might be removed later - they are to check the coding. + if ((mr_mid < mr_st) .or. (mr_mid > mr_prev + 1.)) call MOM_error(FATAL, & + "apply ctrl_forcing: m_mid interpolation out of bounds; fix the code.") + if ((mr_end < mr_st) .or. (mr_end > mr_prev + 2.)) call MOM_error(FATAL, & + "apply ctrl_forcing: m_end interpolation out of bounds; fix the code.") + if (mr_end > mr_next) call MOM_error(FATAL, & + "apply ctrl_forcing: mr_next interpolation out of bounds; fix the code.") + + wt_per1 = 1.0 + if (mr_mid < mr_end) wt_per1 = (mr_mid - mr_st) / (mr_end - mr_st) + + ! Find the 3 Chapeau-function weights, bearing in mind that m_end may be m_mid. + wt_st = wt_per1 * (1. + (mr_prev - 0.5*(mr_st + mr_mid))) + wt_end = (1.0-wt_per1) * (1. + (0.5*(mr_end + mr_mid) - mr_next)) + wt_mid = 1.0 - (wt_st + wt_end) + if ((wt_st < 0.0) .or. (wt_end < 0.0) .or. (wt_mid < 0.0)) & + call MOM_error(FATAL, "apply_ctrl_forcing: Negative m weights") + if ((wt_st > 1.0) .or. (wt_end > 1.0) .or. (wt_mid > 1.0)) & + call MOM_error(FATAL, "apply_ctrl_forcing: Excessive m weights") + + ! Add to vert_heat and vert_precip. + do j=js,je ; do i=is,ie + virt_heat(i,j) = virt_heat(i,j) + (wt_st * CS%heat_cyc(i,j,m_st) + & + (wt_mid * CS%heat_cyc(i,j,m_mid) + & + wt_end * CS%heat_cyc(i,j,m_end))) + virt_precip(i,j) = virt_precip(i,j) + (wt_st * CS%precip_cyc(i,j,m_st) + & + (wt_mid * CS%precip_cyc(i,j,m_mid) + & + wt_end * CS%precip_cyc(i,j,m_end))) + enddo ; enddo + + ! If different from the last period, take the average and determine the + ! chapeau weighting + + ! The Chapeau functions are centered at whole integer values that are nominally + ! the end of the month to enable simple conversion from the fractional-years times + ! CS%num_cycle. + + ! The month-average temperatures have as an index the month number, so the averages + ! apply to indicies m_end and m_mid. + + if (CS%avg_time(m_end) <= 0.0) then ! zero out the averages. + CS%avg_time(m_end) = 0.0 + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_end) = 0.0 + CS%avg_SSS_anom(i,j,m_end) = 0.0 ; CS%avg_SSS(i,j,m_end) = 0.0 + enddo ; enddo + endif + if (CS%avg_time(m_mid) <= 0.0) then ! zero out the averages. + CS%avg_time(m_mid) = 0.0 + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_mid) = 0.0 + CS%avg_SSS_anom(i,j,m_mid) = 0.0 ; CS%avg_SSS(i,j,m_mid) = 0.0 + enddo ; enddo + endif + + ! Accumulate the average anomalies for this period. + dt_wt = wt_per1 * dt + CS%avg_time(m_mid) = CS%avg_time(m_mid) + dt_wt + ! These loops temporarily change the units of the CS%avg_ variables to [C T ~> degC s] + ! or [S T ~> ppt s]. + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_mid) = CS%avg_SST_anom(i,j,m_mid) + & + dt_wt * G%mask2dT(i,j) * SST_anom(i,j) + CS%avg_SSS_anom(i,j,m_mid) = CS%avg_SSS_anom(i,j,m_mid) + & + dt_wt * G%mask2dT(i,j) * SSS_anom(i,j) + CS%avg_SSS(i,j,m_mid) = CS%avg_SSS(i,j,m_mid) + dt_wt * SSS_mean(i,j) + enddo ; enddo + if (wt_per1 < 1.0) then + dt_wt = (1.0-wt_per1) * dt + CS%avg_time(m_end) = CS%avg_time(m_end) + dt_wt + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_end) = CS%avg_SST_anom(i,j,m_end) + & + dt_wt * G%mask2dT(i,j) * SST_anom(i,j) + CS%avg_SSS_anom(i,j,m_end) = CS%avg_SSS_anom(i,j,m_end) + & + dt_wt * G%mask2dT(i,j) * SSS_anom(i,j) + CS%avg_SSS(i,j,m_end) = CS%avg_SSS(i,j,m_end) + dt_wt * SSS_mean(i,j) + enddo ; enddo + endif + + ! Update the Chapeau magnitudes for 4 cycles ago. + m_u1 = periodic_int(m_st - 4.0, CS%num_cycle) + m_u2 = periodic_int(m_st - 3.0, CS%num_cycle) + m_u3 = periodic_int(m_st - 2.0, CS%num_cycle) + + ! These loops restore the units of the CS%avg variables to [degC] or [ppt] + if (CS%avg_time(m_u1) > 0.0) then + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_u1) = CS%avg_SST_anom(i,j,m_u1) / CS%avg_time(m_u1) + CS%avg_SSS_anom(i,j,m_u1) = CS%avg_SSS_anom(i,j,m_u1) / CS%avg_time(m_u1) + CS%avg_SSS(i,j,m_u1) = CS%avg_SSS(i,j,m_u1) / CS%avg_time(m_u1) + enddo ; enddo + CS%avg_time(m_u1) = -1.0 + endif + if (CS%avg_time(m_u2) > 0.0) then + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_u2) = CS%avg_SST_anom(i,j,m_u2) / CS%avg_time(m_u2) + CS%avg_SSS_anom(i,j,m_u2) = CS%avg_SSS_anom(i,j,m_u2) / CS%avg_time(m_u2) + CS%avg_SSS(i,j,m_u2) = CS%avg_SSS(i,j,m_u2) / CS%avg_time(m_u2) + enddo ; enddo + CS%avg_time(m_u2) = -1.0 + endif + if (CS%avg_time(m_u3) > 0.0) then + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_u3) = CS%avg_SST_anom(i,j,m_u3) / CS%avg_time(m_u3) + CS%avg_SSS_anom(i,j,m_u3) = CS%avg_SSS_anom(i,j,m_u3) / CS%avg_time(m_u3) + CS%avg_SSS(i,j,m_u3) = CS%avg_SSS(i,j,m_u3) / CS%avg_time(m_u3) + enddo ; enddo + CS%avg_time(m_u3) = -1.0 + endif + + dt1_heat_rate = wt_per1 * dt * CS%heat_cyc_rate + dt1_prec_rate = wt_per1 * dt * CS%prec_cyc_rate + dt2_heat_rate = (1.0-wt_per1) * dt * CS%heat_cyc_rate + dt2_prec_rate = (1.0-wt_per1) * dt * CS%prec_cyc_rate + + if (wt_per1 < 1.0) then + call pass_var(CS%heat_cyc(:,:,m_u2), G%Domain, complete=.false.) + call pass_var(CS%precip_cyc(:,:,m_u2), G%Domain, complete=.false.) + endif + call pass_var(CS%heat_cyc(:,:,m_u1), G%Domain, complete=.false.) + call pass_var(CS%precip_cyc(:,:,m_u1), G%Domain) + + if ((CS%avg_time(m_u1) == -1.0) .and. (CS%avg_time(m_u2) == -1.0)) then + do j=js,je ; do I=is-1,ie + coef = CS%Len2 * (G%dy_Cu(I,j)*G%IdxCu(I,j)) + flux_heat_x(I,j) = coef * (CS%heat_cyc(i,j,m_u1) - CS%heat_cyc(i+1,j,m_u1)) + flux_prec_x(I,j) = coef * (CS%precip_cyc(i,j,m_u1) - CS%precip_cyc(i+1,j,m_u1)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + coef = CS%Len2 * (G%dx_Cv(i,J)*G%IdyCv(i,J)) + flux_heat_y(i,J) = coef * (CS%heat_cyc(i,j,m_u1) - CS%heat_cyc(i,j+1,m_u1)) + flux_prec_y(i,J) = coef * (CS%precip_cyc(i,j,m_u1) - CS%precip_cyc(i,j+1,m_u1)) + enddo ; enddo + do j=js,je ; do i=is,ie + CS%heat_cyc(i,j,m_u1) = CS%heat_cyc(i,j,m_u1) + dt1_heat_rate * ( & + -CS%lam_cyc_heat*(CS%avg_SST_anom(i,j,m_u2) - CS%avg_SST_anom(i,j,m_u1)) + & + (G%IareaT(i,j) * ((flux_heat_x(I-1,j) - flux_heat_x(I,j)) + & + (flux_heat_y(i,J-1) - flux_heat_y(i,J))) ) ) + + CS%precip_cyc(i,j,m_u1) = CS%precip_cyc(i,j,m_u1) + dt1_prec_rate * ( & + CS%lam_prec * (CS%avg_SSS_anom(i,j,m_u2) - CS%avg_SSS_anom(i,j,m_u1)) / & + (0.5*(CS%avg_SSS(i,j,m_u2) + CS%avg_SSS(i,j,m_u1))) + & + (G%IareaT(i,j) * ((flux_prec_x(I-1,j) - flux_prec_x(I,j)) + & + (flux_prec_y(i,J-1) - flux_prec_y(i,J))) ) ) + enddo ; enddo + endif + + if ((wt_per1 < 1.0) .and. (CS%avg_time(m_u1) == -1.0) .and. (CS%avg_time(m_u2) == -1.0)) then + do j=js,je ; do I=is-1,ie + coef = CS%Len2 * (G%dy_Cu(I,j)*G%IdxCu(I,j)) + flux_heat_x(I,j) = coef * (CS%heat_cyc(i,j,m_u2) - CS%heat_cyc(i+1,j,m_u2)) + flux_prec_x(I,j) = coef * (CS%precip_cyc(i,j,m_u2) - CS%precip_cyc(i+1,j,m_u2)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + coef = CS%Len2 * (G%dx_Cv(i,J)*G%IdyCv(i,J)) + flux_heat_y(i,J) = coef * (CS%heat_cyc(i,j,m_u2) - CS%heat_cyc(i,j+1,m_u2)) + flux_prec_y(i,J) = coef * (CS%precip_cyc(i,j,m_u2) - CS%precip_cyc(i,j+1,m_u2)) + enddo ; enddo + do j=js,je ; do i=is,ie + CS%heat_cyc(i,j,m_u2) = CS%heat_cyc(i,j,m_u2) + dt1_heat_rate * ( & + -CS%lam_cyc_heat*(CS%avg_SST_anom(i,j,m_u3) - CS%avg_SST_anom(i,j,m_u2)) + & + (G%IareaT(i,j) * ((flux_heat_x(I-1,j) - flux_heat_x(I,j)) + & + (flux_heat_y(i,J-1) - flux_heat_y(i,J))) ) ) + + CS%precip_cyc(i,j,m_u2) = CS%precip_cyc(i,j,m_u2) + dt1_prec_rate * ( & + CS%lam_prec * (CS%avg_SSS_anom(i,j,m_u3) - CS%avg_SSS_anom(i,j,m_u2)) / & + (0.5*(CS%avg_SSS(i,j,m_u3) + CS%avg_SSS(i,j,m_u2))) + & + (G%IareaT(i,j) * ((flux_prec_x(I-1,j) - flux_prec_x(I,j)) + & + (flux_prec_y(i,J-1) - flux_prec_y(i,J))) ) ) + enddo ; enddo + endif + + endif ! (CS%num_cycle > 0) + + if (CS%do_integrated .and. ((CS%id_heat_0 > 0) .or. (CS%id_prec_0 > 0))) then + call enable_averages(dt, day_start + real_to_time(US%T_to_s*dt), CS%diag) + if (CS%id_heat_0 > 0) call post_data(CS%id_heat_0, CS%heat_0, CS%diag) + if (CS%id_prec_0 > 0) call post_data(CS%id_prec_0, CS%precip_0, CS%diag) + call disable_averaging(CS%diag) + endif + +end subroutine apply_ctrl_forcing + +!> This function maps rval into an integer in the range from 1 to num_period. +function periodic_int(rval, num_period) result (m) + real, intent(in) :: rval !< Input for mapping [nondim] + integer, intent(in) :: num_period !< Maximum output. + integer :: m !< Return value. + + m = floor(rval) + if (m <= 0) then + m = m + num_period * (1 + (abs(m) / num_period)) + elseif (m > num_period) then + m = m - num_period * ((m-1) / num_period) + endif +end function + +!> This function shifts rval by an integer multiple of num_period so that +!! 0 <= val_out < num_period. +function periodic_real(rval, num_period) result(val_out) + real, intent(in) :: rval !< Input to be shifted into valid range [nondim] + integer, intent(in) :: num_period !< Maximum valid value. + real :: val_out !< Return value [nondim] + integer :: nshft + + if (rval < 0) then ; nshft = floor(abs(rval) / num_period) + 1 + elseif (rval < num_period) then ; nshft = 0 + else ; nshft = -1*floor(rval / num_period) ; endif + + val_out = rval + nshft * num_period +end function + + +!> This subroutine is used to allocate and register any fields in this module +!! that should be written to or read from the restart file. +subroutine register_ctrl_forcing_restarts(G, US, param_file, CS, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(ctrl_forcing_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module. + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + + logical :: controlled, use_temperature + character (len=8) :: period_str + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (associated(CS)) then + call MOM_error(WARNING, "register_ctrl_forcing_restarts called "//& + "with an associated control structure.") + return + endif + + controlled = .false. + call read_param(param_file, "CONTROLLED_FORCING", controlled) + if (.not.controlled) return + + use_temperature = .true. + call read_param(param_file, "ENABLE_THERMODYNAMICS", use_temperature) + if (.not.use_temperature) call MOM_error(FATAL, & + "register_ctrl_forcing_restarts: CONTROLLED_FORCING only works with "//& + "ENABLE_THERMODYNAMICS defined.") + + allocate(CS) + + CS%do_integrated = .true. ; CS%num_cycle = 0 + call read_param(param_file, "CTRL_FORCE_INTEGRATED", CS%do_integrated) + call read_param(param_file, "CTRL_FORCE_NUM_CYCLE", CS%num_cycle) + + if (CS%do_integrated) then + allocate(CS%heat_0(isd:ied,jsd:jed), source=0.0) + allocate(CS%precip_0(isd:ied,jsd:jed), source=0.0) + + call register_restart_field(CS%heat_0, "Ctrl_heat", .false., restart_CS, & + longname="Control Integrative Heating", & + units="W m-2", conversion=US%QRZ_T_to_W_m2, z_grid='1') + call register_restart_field(CS%precip_0, "Ctrl_precip", .false., restart_CS, & + longname="Control Integrative Precipitation", & + units="kg m-2 s-1", conversion=US%RZ_T_to_kg_m2s, z_grid='1') + endif + + if (CS%num_cycle > 0) then + allocate(CS%heat_cyc(isd:ied,jsd:jed,CS%num_cycle), source=0.0) + allocate(CS%precip_cyc(isd:ied,jsd:jed,CS%num_cycle), source=0.0) + allocate(CS%avg_time(CS%num_cycle), source=0.0) + allocate(CS%avg_SST_anom(isd:ied,jsd:jed,CS%num_cycle), source=0.0) + allocate(CS%avg_SSS_anom(isd:ied,jsd:jed,CS%num_cycle), source=0.0) + allocate(CS%avg_SSS(isd:ied,jsd:jed,CS%num_cycle), source=0.0) + + write (period_str, '(i8)') CS%num_cycle + period_str = trim('p ')//trim(adjustl(period_str)) + + call register_restart_field(CS%heat_cyc, "Ctrl_heat_cycle", .false., restart_CS, & + longname="Cyclical Control Heating", & + units="W m-2", conversion=US%QRZ_T_to_W_m2, z_grid='1', t_grid=period_str) + call register_restart_field(CS%precip_cyc, "Ctrl_precip_cycle", .false., restart_CS, & + longname="Cyclical Control Precipitation", & + units="kg m-2 s-1", conversion=US%RZ_T_to_kg_m2s, z_grid='1', t_grid=period_str) + call register_restart_field(CS%avg_time, "avg_time", .false., restart_CS, & + longname="Cyclical accumulated averaging time", & + units="sec", conversion=US%T_to_s, z_grid='1', t_grid=period_str) + call register_restart_field(CS%avg_SST_anom, "avg_SST_anom", .false., restart_CS, & + longname="Cyclical average SST Anomaly", & + units="degC", conversion=US%C_to_degC, z_grid='1', t_grid=period_str) + call register_restart_field(CS%avg_SSS_anom, "avg_SSS_anom", .false., restart_CS, & + longname="Cyclical average SSS Anomaly", & + units="g kg-1", conversion=US%S_to_ppt, z_grid='1', t_grid=period_str) + call register_restart_field(CS%avg_SSS_anom, "avg_SSS", .false., restart_CS, & + longname="Cyclical average SSS", & + units="g kg-1", conversion=US%S_to_ppt, z_grid='1', t_grid=period_str) + endif + +end subroutine register_ctrl_forcing_restarts + +!> Set up this modules control structure. +subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ctrl_forcing_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module. + + ! Local variables + real :: smooth_len ! A smoothing lengthscale [L ~> m] + logical :: do_integrated + integer :: num_cycle + integer :: i, j, isc, iec, jsc, jec, m + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_controlled_forcing" ! This module's name. + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + ! These should have already been called. + ! call read_param(param_file, "CTRL_FORCE_INTEGRATED", CS%do_integrated) + ! call read_param(param_file, "CTRL_FORCE_NUM_CYCLE", CS%num_cycle) + + if (associated(CS)) then + do_integrated = CS%do_integrated ; num_cycle = CS%num_cycle + else + do_integrated = .false. ; num_cycle = 0 + endif + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call log_param(param_file, mdl, "CTRL_FORCE_INTEGRATED", do_integrated, & + "If true, use a PI controller to determine the surface "//& + "forcing that is consistent with the observed mean properties.", & + default=.false.) + call log_param(param_file, mdl, "CTRL_FORCE_NUM_CYCLE", num_cycle, & + "The number of cycles per year in the controlled forcing, "//& + "or 0 for no cyclic forcing.", default=0) + + if (.not.associated(CS)) return + + CS%diag => diag + + call get_param(param_file, mdl, "CTRL_FORCE_HEAT_INT_RATE", CS%heat_int_rate, & + "The integrated rate at which heat flux anomalies are accumulated.", & + units="s-1", default=0.0, scale=US%T_to_s) + call get_param(param_file, mdl, "CTRL_FORCE_PREC_INT_RATE", CS%prec_int_rate, & + "The integrated rate at which precipitation anomalies are accumulated.", & + units="s-1", default=0.0, scale=US%T_to_s) + call get_param(param_file, mdl, "CTRL_FORCE_HEAT_CYC_RATE", CS%heat_cyc_rate, & + "The integrated rate at which cyclical heat flux anomalies are accumulated.", & + units="s-1", default=0.0, scale=US%T_to_s) + call get_param(param_file, mdl, "CTRL_FORCE_PREC_CYC_RATE", CS%prec_cyc_rate, & + "The integrated rate at which cyclical precipitation anomalies are accumulated.", & + units="s-1", default=0.0, scale=US%T_to_s) + call get_param(param_file, mdl, "CTRL_FORCE_SMOOTH_LENGTH", smooth_len, & + "The length scales over which controlled forcing anomalies are smoothed.", & + units="m", default=0.0, scale=US%m_to_L) + call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_HEAT", CS%lam_heat, & + "A constant of proportionality between SST anomalies "//& + "and controlling heat fluxes", & + units="W m-2 K-1", default=0.0, scale=US%W_m2_to_QRZ_T*US%C_to_degC) + call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_PREC", CS%lam_prec, & + "A constant of proportionality between SSS anomalies "//& + "(normalised by mean SSS) and controlling precipitation.", & + units="kg m-2 s-1", default=0.0, scale=US%kg_m2s_to_RZ_T) + call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_CYC_HEAT", CS%lam_cyc_heat, & + "A constant of proportionality between SST anomalies "//& + "and cyclical controlling heat fluxes", & + units="W m-2 K-1", default=0.0, scale=US%W_m2_to_QRZ_T*US%C_to_degC) + call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_CYC_PREC", CS%lam_cyc_prec, & + "A constant of proportionality between SSS anomalies "//& + "(normalised by mean SSS) and cyclical controlling precipitation.", & + units="kg m-2 s-1", default=0.0, scale=US%kg_m2s_to_RZ_T) + + CS%Len2 = smooth_len**2 + + if (CS%do_integrated) then + CS%id_heat_0 = register_diag_field('ocean_model', 'Ctrl_heat', diag%axesT1, Time, & + 'Control Corrective Heating', 'W m-2', conversion=US%QRZ_T_to_W_m2) + CS%id_prec_0 = register_diag_field('ocean_model', 'Ctrl_prec', diag%axesT1, Time, & + 'Control Corrective Precipitation', 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + endif + +end subroutine controlled_forcing_init + +!> Clean up this modules control structure. +subroutine controlled_forcing_end(CS) + type(ctrl_forcing_CS), pointer :: CS !< A pointer to the control structure + !! returned by a previous call to + !! controlled_forcing_init, it will be + !! deallocated here. + + if (associated(CS)) then + if (associated(CS%heat_0)) deallocate(CS%heat_0) + if (associated(CS%precip_0)) deallocate(CS%precip_0) + if (associated(CS%heat_cyc)) deallocate(CS%heat_cyc) + if (associated(CS%precip_cyc)) deallocate(CS%precip_cyc) + if (associated(CS%avg_SST_anom)) deallocate(CS%avg_SST_anom) + if (associated(CS%avg_SSS_anom)) deallocate(CS%avg_SSS_anom) + if (associated(CS%avg_SSS)) deallocate(CS%avg_SSS) + + deallocate(CS) + endif + CS => NULL() + +end subroutine controlled_forcing_end + +!> \namespace mom_controlled_forcing +!! * +!! By Robert Hallberg, July 2011 * +!! * +!! This program contains the subroutines that use control-theory * +!! to adjust the surface heat flux and precipitation, based on the * +!! time-mean or periodically (seasonally) varying anomalies from the * +!! observed state. The techniques behind this are described in * +!! Hallberg and Adcroft (2011, in prep.). * +!! * +!! Macros written all in capital letters are defined in MOM_memory.h. * +!! * +!! A small fragment of the grid is shown below: * +!! * +!! j+1 x ^ x ^ x At x: q * +!! j+1 > o > o > At ^: v, tauy * +!! j x ^ x ^ x At >: u, taux * +!! j > o > o > At o: h, fluxes. * +!! j-1 x ^ x ^ x * +!! i-1 i i+1 At x & ^: * +!! i i+1 At > & o: * +!! * +!! The boundaries always run through q grid points (x). * +end module MOM_controlled_forcing diff --git a/user/MOM_wave_interface.F90 b/user/MOM_wave_interface.F90 new file mode 100644 index 0000000000..9a951cf655 --- /dev/null +++ b/user/MOM_wave_interface.F90 @@ -0,0 +1,2121 @@ +!> Interface for surface waves +module MOM_wave_interface + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_data_override, only : data_override_init, data_override +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc +use MOM_diag_mediator, only : diag_ctrl +use MOM_domains, only : pass_var, pass_vector, AGRID +use MOM_domains, only : To_South, To_West, To_All +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : mech_forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : file_exists, get_var_sizes, read_variable +use MOM_io, only : vardesc, var_desc +use MOM_safe_alloc, only : safe_alloc_ptr +use MOM_time_manager, only : time_type, operator(+), operator(/) +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, surface +use MOM_verticalgrid, only : verticalGrid_type +use MOM_restart, only : register_restart_pair, MOM_restart_CS + +implicit none ; private + +#include + +public MOM_wave_interface_init ! Public interface to fully initialize the wave routines. +public query_wave_properties ! Public interface to obtain information from the waves control structure. +public Update_Surface_Waves ! Public interface to update wave information at the + ! coupler/driver level. +public Update_Stokes_Drift ! Public interface to update the Stokes drift profiles + ! called in step_mom. +public get_Langmuir_Number ! Public interface to compute Langmuir number called from + ! ePBL or KPP routines. +public Stokes_PGF ! Public interface to compute Stokes-shear induced pressure gradient force anomaly +public StokesMixing ! NOT READY - Public interface to add down-Stokes gradient + ! momentum mixing (e.g. the approach of Harcourt 2013/2015) +public CoriolisStokes ! NOT READY - Public interface to add Coriolis-Stokes acceleration + ! of the mean currents, needed for comparison with LES. It is + ! presently advised against implementing in non-1d settings without + ! serious consideration of the full 3d wave-averaged Navier-Stokes + ! CL2 effects. +public Waves_end ! public interface to deallocate and free wave related memory. +public get_wave_method ! public interface to obtain the wave method string +public waves_register_restarts ! public interface to register wave restart fields + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Container for all surface wave related parameters +type, public :: wave_parameters_CS ; private + + ! Main surface wave options and publicly visible variables + logical, public :: UseWaves = .false. !< Flag to enable surface gravity wave feature + logical, public :: Stokes_VF = .false. !< True if Stokes vortex force is used + logical, public :: Passive_Stokes_VF = .false. !< Computes Stokes VF, but doesn't affect dynamics + logical, public :: Stokes_PGF = .false. !< True if Stokes shear pressure Gradient force is used + logical, public :: Passive_Stokes_PGF = .false. !< Keeps Stokes_PGF on, but doesn't affect dynamics + logical, public :: Stokes_DDT = .false. !< Developmental: + !! True if Stokes d/dt is used + logical, public :: Passive_Stokes_DDT = .false. !< Keeps Stokes_DDT on, but doesn't affect dynamics + + real, allocatable, dimension(:,:,:), public :: & + Us_x !< 3d zonal Stokes drift profile [L T-1 ~> m s-1] + !! Horizontal -> U points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + Us_y !< 3d meridional Stokes drift profile [L T-1 ~> m s-1] + !! Horizontal -> V points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + ddt_Us_x !< 3d time tendency of zonal Stokes drift profile [L T-2 ~> m s-2] + !! Horizontal -> U points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + ddt_Us_y !< 3d time tendency of meridional Stokes drift profile [L T-2 ~> m s-2] + !! Horizontal -> V points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + Us_x_from_ddt !< Check of 3d zonal Stokes drift profile [L T-1 ~> m s-1] + !! Horizontal -> U points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + Us_y_from_ddt !< Check of 3d meridional Stokes drift profile [L T-1 ~> m s-1] + !! Horizontal -> V points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + Us_x_prev !< 3d zonal Stokes drift profile, previous dynamics call [L T-1 ~> m s-1] + !! Horizontal -> U points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + Us_y_prev !< 3d meridional Stokes drift profile, previous dynamics call [L T-1 ~> m s-1] + !! Horizontal -> V points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + KvS !< Viscosity for Stokes Drift shear [H Z T-1 ~> m2 s-1 or Pa s] + real, allocatable, dimension(:), public :: & + WaveNum_Cen !< Wavenumber bands for read/coupled [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:), public :: & + UStk_Hb !< Surface Stokes Drift spectrum (zonal) [L T-1 ~> m s-1] + !! Horizontal -> H-points + !! 3rd dimension -> Freq/Wavenumber + real, allocatable, dimension(:,:,:), public :: & + VStk_Hb !< Surface Stokes Drift spectrum (meridional) [L T-1 ~> m s-1] + !! Horizontal -> H-points + !! 3rd dimension -> Freq/Wavenumber + real, allocatable, dimension(:,:), public :: & + Omega_w2x !< wind direction ccw from model x- axis [nondim radians] + integer, public :: NumBands = 0 !< Number of wavenumber/frequency partitions + !! Must match the number of bands provided + !! via either coupling or file. + + ! The remainder of this control structure is private + integer :: WaveMethod = -99 !< Options for including wave information + !! Valid (tested) choices are: + !! 0 - Test Profile + !! 1 - Surface Stokes Drift Bands + !! 2 - DHH85 + !! 3 - LF17 + !! -99 - No waves computed, but empirical Langmuir number used. + logical :: LagrangianMixing !< This feature is in development and not ready + !! True if Stokes drift is present and mixing + !! should be applied to Lagrangian current + !! (mean current + Stokes drift). + !! See Reichl et al., 2016 KPP-LT approach + logical :: StokesMixing !< This feature is in development and not ready. + !! True if vertical mixing of momentum + !! should be applied directly to Stokes current + !! (with separate mixing parameter for Eulerian + !! mixing contribution). + !! See Harcourt 2013, 2015 Second-Moment approach + logical :: CoriolisStokes !< This feature is in development and not ready. + ! True if Coriolis-Stokes acceleration should be applied. + real :: Stokes_min_thick_avg !< A layer thickness below which the cell-center Stokes drift is + !! used instead of the cell average [Z ~> m]. This is only used if + !! WAVE_INTERFACE_ANSWER_DATE < 20230101. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the + !! surface wave calculations. Values below 20230101 recover the + !! answers from the end of 2022, while higher values use updated + !! and more robust forms of the same expressions. + + ! Options if WaveMethod is Surface Stokes Drift Bands (1) + integer :: PartitionMode !< Method for partition mode (meant to check input) + !! 0 - wavenumbers + !! 1 - frequencies + integer :: DataSource !< Integer that specifies where the model Looks for data + !! Valid choices are: + !! 1 - FMS DataOverride Routine + !! 2 - Reserved For Coupler + !! 3 - User input (fixed values, useful for 1d testing) + + ! Options if using FMS DataOverride Routine + character(len=40) :: SurfBandFileName !< Filename if using DataOverride + real :: land_speed !< A large Stokes velocity that can be used to indicate land values in + !! a data override file [L T-1 ~> m s-1]. Stokes drift components larger + !! than this are set to zero in data override calls for the Stokes drift. + logical :: DataOver_initialized !< Flag for DataOverride Initialization + + ! Options for computing Langmuir number + real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number [nondim] + real :: LA_HBL_min !< Minimum boundary layer depth for averaging Langmuir number [Z ~> m] + logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number + real :: g_Earth !< The gravitational acceleration, equivalent to GV%g_Earth but with + !! different dimensional rescaling appropriate for deep-water gravity + !! waves [Z T-2 ~> m s-2] + real :: I_g_Earth !< The inverse of the gravitational acceleration, with dimensional rescaling + !! appropriate for deep-water gravity waves [T2 Z-1 ~> s2 m-1] + ! Surface Wave Dependent 1d/2d/3d vars + real, allocatable, dimension(:) :: & + Freq_Cen !< Central frequency for wave bands, including a factor of 2*pi [T-1 ~> s-1] + real, allocatable, dimension(:) :: & + PrescribedSurfStkX !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] + real, allocatable, dimension(:) :: & + PrescribedSurfStkY !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: & + La_Turb !< Aligned Turbulent Langmuir number [nondim] + !! Horizontal -> H points + real, allocatable, dimension(:,:) :: & + US0_x !< Surface Stokes Drift (zonal) [L T-1 ~> m s-1] + !! Horizontal -> U points + real, allocatable, dimension(:,:) :: & + US0_y !< Surface Stokes Drift (meridional) [L T-1 ~> m s-1] + !! Horizontal -> V points + real, allocatable, dimension(:,:,:) :: & + STKx0 !< Stokes Drift spectrum (zonal) [L T-1 ~> m s-1] + !! Horizontal -> U points + !! 3rd dimension -> Freq/Wavenumber + real, allocatable, dimension(:,:,:) :: & + STKy0 !< Stokes Drift spectrum (meridional) [L T-1 ~> m s-1] + !! Horizontal -> V points + !! 3rd dimension -> Freq/Wavenumber + + real :: La_min !< An arbitrary lower-bound on the Langmuir number [nondim]. + !! Langmuir number is sqrt(u_star/u_stokes). When both are small + !! but u_star is orders of magnitude smaller, the Langmuir number could + !! have unintended consequences. Since both are small it can be safely + !! capped to avoid such consequences. + real :: La_Stk_backgnd !< A small background Stokes velocity used in the denominator of + !! some expressions for the Langmuir number [L T-1 ~> m s-1] + + ! Parameters used in estimating the wind speed or wave properties from the friction velocity + real :: VonKar = -1.0 !< The von Karman coefficient as used in the MOM_wave_interface module [nondim] + real :: rho_air !< A typical density of air at sea level, as used in wave calculations [R ~> kg m-3] + real :: nu_air !< The viscosity of air, as used in wave calculations [Z2 T-1 ~> m2 s-1] + real :: rho_ocn !< A typical surface density of seawater, as used in wave calculations in + !! comparison with the density of air [R ~> kg m-3]. The default is RHO_0. + real :: SWH_from_u10sq !< A factor for converting the square of the 10 m wind speed to the + !! significant wave height [Z T2 L-2 ~> s2 m-1] + real :: Charnock_min !< The minimum value of the Charnock coefficient, which relates the square of + !! the air friction velocity divided by the gravitational acceleration to the + !! wave roughness length [nondim] + real :: Charnock_slope_U10 !< The partial derivative of the Charnock coefficient with the 10 m wind + !! speed [T L-1 ~> s m-1]. Note that in eq. 13 of the Edson et al. 2013 describing + !! the COARE 3.5 bulk flux algorithm, this slope is given as 0.017. However, 0.0017 + !! reproduces the curve in their figure 6, so that is the default value used in MOM6. + real :: Charnock_intercept !< The intercept of the fit for the Charnock coefficient in the limit of + !! no wind [nondim]. Note that this can be negative because CHARNOCK_MIN will keep + !! the final value for the Charnock coefficient from being from being negative. + + ! Options used with the test profile + real :: TP_STKX0 !< Test profile x-stokes drift amplitude [L T-1 ~> m s-1] + real :: TP_STKY0 !< Test profile y-stokes drift amplitude [L T-1 ~> m s-1] + real :: TP_WVL !< Test profile wavelength [Z ~> m] + + ! Options for use with the Donelan et al., 1985 (DHH85) spectrum + logical :: WaveAgePeakFreq !< Flag to use wave age to determine the peak frequency with DHH85 + logical :: StaticWaves !< Flag to disable updating DHH85 Stokes drift + logical :: DHH85_is_set !< The if the wave properties have been set when WaveMethod = DHH85. + real :: WaveAge !< The fixed wave age used with the DHH85 spectrum [nondim] + real :: WaveWind !< Wind speed for the DHH85 spectrum [L T-1 ~> m s-1] + real :: omega_min !< Minimum wave frequency with the DHH85 spectrum [T-1 ~> s-1] + real :: omega_max !< Maximum wave frequency with the DHH85 spectrum [T-1 ~> s-1] + + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. + + !>@{ Diagnostic handles + integer, public :: id_PFu_Stokes = -1 , id_PFv_Stokes = -1 + integer, public :: id_3dstokes_x_from_ddt = -1 , id_3dstokes_y_from_ddt = -1 + integer :: id_P_deltaStokes_L = -1, id_P_deltaStokes_i = -1 + integer :: id_surfacestokes_x = -1 , id_surfacestokes_y = -1 + integer :: id_3dstokes_x = -1 , id_3dstokes_y = -1 + integer :: id_ddt_3dstokes_x = -1 , id_ddt_3dstokes_y = -1 + integer :: id_La_turb = -1 + !>@} + +end type wave_parameters_CS + +! Switches needed in import_stokes_drift +!>@{ Enumeration values for the wave method +integer, parameter :: TESTPROF = 0, SURFBANDS = 1, DHH85 = 2, LF17 = 3, EFACTOR = 4, NULL_WaveMethod = -99 +!>@} +!>@{ Enumeration values for the wave data source +integer, parameter :: DATAOVR = 1, COUPLER = 2, INPUT = 3 +!>@} + +! Strings for the wave method +character*(5), parameter :: NULL_STRING = "EMPTY" !< null wave method string +character*(12), parameter :: TESTPROF_STRING = "TEST_PROFILE" !< test profile string +character*(13), parameter :: SURFBANDS_STRING = "SURFACE_BANDS" !< surface bands string +character*(5), parameter :: DHH85_STRING = "DHH85" !< DHH85 wave method string +character*(4), parameter :: LF17_STRING = "LF17" !< LF17 wave method string +character*(7), parameter :: EFACTOR_STRING = "EFACTOR" !< EFACTOR (based on vr12-ma) wave method string + +contains + +!> Initializes parameters related to MOM_wave_interface +subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) + type(time_type), target, intent(in) :: Time !< Model time + type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Input parameter structure + type(wave_parameters_CS), pointer :: CS !< Wave parameter control structure + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostic Pointer + + ! Local variables + character(len=40) :: mdl = "MOM_wave_interface" !< This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character*(13) :: TMPSTRING1, TMPSTRING2 + character*(12), parameter :: DATAOVR_STRING = "DATAOVERRIDE" + character*(7), parameter :: COUPLER_STRING = "COUPLER" + character*(5), parameter :: INPUT_STRING = "INPUT" + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags + logical :: use_waves + logical :: StatisticalWaves + + ! Dummy Check + if (.not. associated(CS)) then + call MOM_error(FATAL, "wave_interface_init called without an associated control structure.") + return + endif + + call get_param(param_file, mdl, "USE_WAVES", use_waves, & + "If true, enables surface wave modules.", default=.false.) + + ! Check if using LA_LI2016 + call get_param(param_file, mdl, "USE_LA_LI2016", StatisticalWaves, & + do_not_log=.true.,default=.false.) + + if (.not.(use_waves .or. StatisticalWaves)) return + + CS%UseWaves = use_waves + CS%diag => diag + CS%Time => Time + + CS%g_Earth = US%L_to_Z**2*GV%g_Earth + CS%I_g_Earth = 1.0 / CS%g_Earth + + ! Add any initializations needed here + CS%DataOver_initialized = .false. + + call log_version(param_file, mdl, version) + + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + + call get_param(param_file, mdl, "WAVE_INTERFACE_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the surface wave "//& + "calculations. Values below 20230101 recover the answers from the end of 2022, "//& + "while higher values use updated and more robust forms of the same expressions:\n"//& + "\t < 20230101 - Original answers for wave interface routines\n"//& + "\t >= 20230101 - More robust expressions for Update_Stokes_Drift\n"//& + "\t >= 20230102 - More robust expressions for get_StokesSL_LiFoxKemper\n"//& + "\t >= 20230103 - More robust expressions for ust_2_u10_coare3p5", & + default=20221231, do_not_log=.not.GV%Boussinesq) + !### In due course change the default to default=default_answer_date) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + + ! Langmuir number Options + call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & + "The depth (normalized by BLD) to average Stokes drift over in "//& + "Langmuir number calculation, where La = sqrt(ust/Stokes).", & + units="nondim", default=0.04) + call get_param(param_file, mdl, "LA_DEPTH_MIN", CS%LA_HBL_min, & + "The minimum depth over which to average the Stokes drift in the Langmuir "//& + "number calculation.", units="m", default=0.1, scale=US%m_to_Z) + + if (StatisticalWaves) then + CS%WaveMethod = LF17 + call set_LF17_wave_params(param_file, mdl, GV, US, CS) + if (.not.use_waves) return + else + CS%WaveMethod = NULL_WaveMethod + end if + + ! Wave modified physics + ! Presently these are all in research mode + call get_param(param_file, mdl, "LAGRANGIAN_MIXING", CS%LagrangianMixing, & + "Flag to use Lagrangian Mixing of momentum", default=.false., & + do_not_log=.not.use_waves) + if (CS%LagrangianMixing) then + ! Force Code Intervention + call MOM_error(FATAL,"Should you be enabling Lagrangian Mixing? Code not ready.") + endif + call get_param(param_file, mdl, "STOKES_MIXING", CS%StokesMixing, & + "Flag to use Stokes Mixing of momentum", default=.false., & + do_not_log=.not.use_waves) + if (CS%StokesMixing) then + ! Force Code Intervention + call MOM_error(FATAL, "Should you be enabling Stokes Mixing? Code not ready.") + endif + call get_param(param_file, mdl, "CORIOLIS_STOKES", CS%CoriolisStokes, & + "Flag to use Coriolis Stokes acceleration", default=.false., & + do_not_log=.not.use_waves) + if (CS%CoriolisStokes) then + ! Force Code Intervention + call MOM_error(FATAL, "Should you be enabling Coriolis-Stokes? Code not ready.") + endif + + call get_param(param_file, mdl, "STOKES_VF", CS%Stokes_VF, & + "Flag to use Stokes vortex force", & + Default=.false.) + call get_param(param_file, mdl, "PASSIVE_STOKES_VF", CS%Passive_Stokes_VF, & + "Flag to make Stokes vortex force diagnostic only.", & + Default=.false.) + call get_param(param_file, mdl, "STOKES_PGF", CS%Stokes_PGF, & + "Flag to use Stokes-induced pressure gradient anomaly", & + Default=.false.) + call get_param(param_file, mdl, "PASSIVE_STOKES_PGF", CS%Passive_Stokes_PGF, & + "Flag to make Stokes-induced pressure gradient anomaly diagnostic only.", & + Default=.false.) + call get_param(param_file, mdl, "STOKES_DDT", CS%Stokes_DDT, & + "Flag to use Stokes d/dt", & + Default=.false.) + call get_param(param_file, mdl, "PASSIVE_STOKES_DDT", CS%Passive_Stokes_DDT, & + "Flag to make Stokes d/dt diagnostic only", & + Default=.false.) + + ! Get Wave Method and write to integer WaveMethod + call get_param(param_file,mdl,"WAVE_METHOD",TMPSTRING1, & + "Choice of wave method, valid options include: \n"// & + " TEST_PROFILE - Prescribed from surface Stokes drift \n"// & + " and a decay wavelength.\n"// & + " SURFACE_BANDS - Computed from multiple surface values \n"// & + " and decay wavelengths.\n"// & + " DHH85 - Uses Donelan et al. 1985 empirical \n"// & + " wave spectrum with prescribed values. \n"// & + " LF17 - Infers Stokes drift profile from wind \n"// & + " speed following Li and Fox-Kemper 2017.\n"// & + " EFACTOR - Applies an enhancement factor to the KPP\n"//& + " turbulent velocity scale received \n"// & + " directly from WW3 and is based on the \n"// & + " surface layer and projected Langmuir \n"// & + " number (Li 2016)\n", & + default=NULL_STRING) + select case (TRIM(TMPSTRING1)) + case (NULL_STRING)! No Waves + call MOM_error(FATAL, "wave_interface_init called with no specified "//& + "WAVE_METHOD.") + case (TESTPROF_STRING)! Test Profile + CS%WaveMethod = TESTPROF + call get_param(param_file, mdl, "TP_STKX_SURF", CS%TP_STKX0, & + 'Surface Stokes (x) for test profile', & + units='m/s', default=0.1, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "TP_STKY_SURF", CS%TP_STKY0, & + 'Surface Stokes (y) for test profile', & + units='m/s', default=0.0, scale=US%m_s_to_L_T) + call get_param(param_file,mdl, "TP_WVL", CS%TP_WVL, & + 'Wavelength for test profile', & + units='m', default=50.0, scale=US%m_to_Z) + case (SURFBANDS_STRING)! Surface Stokes Drift Bands + CS%WaveMethod = SURFBANDS + call get_param(param_file, mdl, "SURFBAND_MIN_THICK_AVG", CS%Stokes_min_thick_avg, & + "A layer thickness below which the cell-center Stokes drift is used instead of "//& + "the cell average. This is only used if WAVE_INTERFACE_ANSWER_DATE < 20230101.", & + units="m", default=0.1, scale=US%m_to_Z, do_not_log=(CS%answer_date>=20230101)) + call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, & + "Choice of SURFACE_BANDS data mode, valid options include: \n"//& + " DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"//& + " COUPLER - Look for variables from coupler pass \n"//& + " INPUT - Testing with fixed values.", default=NULL_STRING) + select case (TRIM(TMPSTRING2)) + case (NULL_STRING)! Default + call MOM_error(FATAL, "wave_interface_init called with SURFACE_BANDS"//& + " but no SURFBAND_SOURCE.") + case (DATAOVR_STRING)! Using Data Override + CS%DataSource = DATAOVR + call get_param(param_file, mdl, "SURFBAND_FILENAME", CS%SurfBandFileName, & + "Filename of surface Stokes drift input band data.", default="StkSpec.nc") + call get_param(param_file, mdl, "SURFBAND_OVERRIDE_LAND_SPEED", CS%land_speed, & + "A large Stokes velocity that can be used to indicate land values in "//& + "a data override file. Stokes drift components larger than this are "//& + "set to zero in data override calls for the Stokes drift.", & + units="m s-1", default=10.0, scale=US%m_s_to_L_T) + case (COUPLER_STRING)! Reserved for coupling + CS%DataSource = COUPLER + ! This is just to make something work, but it needs to be read from the wavemodel. + call get_param(param_file, mdl, "STK_BAND_COUPLER",CS%NumBands, & + "STK_BAND_COUPLER is the number of Stokes drift bands in the coupler. "//& + "This has to be consistent with the number of Stokes drift bands in WW3, "//& + "or the model will fail.", default=1) + allocate( CS%WaveNum_Cen(CS%NumBands), source=0.0 ) + allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands), source=0.0 ) + allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,CS%NumBands), source=0.0 ) + allocate( CS%UStk_Hb(G%isc:G%iec,G%jsc:G%jec,CS%NumBands), source=0.0 ) + allocate( CS%VStk_Hb(G%isc:G%iec,G%jsc:G%jec,CS%NumBands), source=0.0 ) + allocate( CS%Omega_w2x(G%isc:G%iec,G%jsc:G%jec) , source=0.0 ) + CS%PartitionMode = 0 + call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & + "Central wavenumbers for surface Stokes drift bands.", & + units='rad/m', default=0.12566, scale=US%Z_to_m) + case (INPUT_STRING)! A method to input the Stokes band (globally uniform) + CS%DataSource = INPUT + call get_param(param_file, mdl, "SURFBAND_NB", CS%NumBands, & + "Prescribe number of wavenumber bands for Stokes drift. "//& + "Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and "//& + "STOKES_Y, there are no safety checks in the code.", default=1) + allocate( CS%WaveNum_Cen(1:CS%NumBands), source=0.0 ) + allocate( CS%PrescribedSurfStkX(1:CS%NumBands), source=0.0 ) + allocate( CS%PrescribedSurfStkY(1:CS%NumBands), source=0.0 ) + allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:CS%NumBands), source=0.0 ) + allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:CS%NumBands), source=0.0 ) + + CS%PartitionMode = 0 + call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & + "Central wavenumbers for surface Stokes drift bands.", & + units='rad/m', default=0.12566, scale=US%Z_to_m) + call get_param(param_file, mdl, "SURFBAND_STOKES_X", CS%PrescribedSurfStkX, & + "X-direction surface Stokes drift for bands.", & + units='m/s', default=0.15, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "SURFBAND_STOKES_Y", CS%PrescribedSurfStkY, & + "Y-direction surface Stokes drift for bands.", & + units='m/s', default=0.0, scale=US%m_s_to_L_T) + case default! No method provided + call MOM_error(FATAL,'Check WAVE_METHOD.') + end select + + case (DHH85_STRING) !Donelan et al., 1985 spectrum + CS%WaveMethod = DHH85 + call MOM_error(WARNING,"DHH85 only ever set-up for uniform cases w/"//& + " Stokes drift in x-direction.") + call get_param(param_file, mdl, "DHH85_AGE_FP", CS%WaveAgePeakFreq, & + "Choose true to use waveage in peak frequency.", default=.false.) + call get_param(param_file, mdl, "DHH85_AGE", CS%WaveAge, & + "Wave Age for DHH85 spectrum.", & + units='nondim', default=1.2) + call get_param(param_file, mdl, "DHH85_WIND", CS%WaveWind, & + "Wind speed for DHH85 spectrum.", & + units='m s-1', default=10.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "DHH85_MIN_WAVE_FREQ", CS%omega_min, & + "Minimum wave frequency for the DHH85 spectrum.", & + units='s-1', default=0.1, scale=US%T_to_s) + call get_param(param_file, mdl, "DHH85_MAX_WAVE_FREQ", CS%omega_max, & + "Maximum wave frequency for the DHH85 spectrum.", & + units='s-1', default=10.0, scale=US%T_to_s) ! The default is about a 30 cm cutoff wavelength. + call get_param(param_file, mdl, "STATIC_DHH85", CS%StaticWaves, & + "Flag to disable updating DHH85 Stokes drift.", default=.false.) + case (LF17_STRING) !Li and Fox-Kemper 17 wind-sea Langmuir number + CS%WaveMethod = LF17 + call set_LF17_wave_params(param_file, mdl, GV, US, CS) + case (EFACTOR_STRING) !Li and Fox-Kemper 16 + CS%WaveMethod = EFACTOR + case default + call MOM_error(FATAL,'Check WAVE_METHOD.') + end select + + ! Langmuir number Options (Note that CS%LA_FracHBL is set above.) + call get_param(param_file, mdl, "LA_MISALIGNMENT", CS%LA_Misalignment, & + "Flag (logical) if using misalignment between shear and waves in LA", & + default=.false.) + call get_param(param_file, mdl, "MIN_LANGMUIR", CS%La_min, & + "A minimum value for all Langmuir numbers that is not physical, "//& + "but is likely only encountered when the wind is very small and "//& + "therefore its effects should be mostly benign.", & + units="nondim", default=0.05) + call get_param(param_file, mdl, "LANGMUIR_STOKES_BACKGROUND", CS%La_Stk_backgnd, & + "A small background Stokes velocity used in the denominator of some "//& + "expressions for the Langmuir number.", & + units="m s-1", default=1.0e-10, scale=US%m_s_to_L_T, do_not_log=(CS%WaveMethod==LF17)) + + ! Allocate and initialize + ! a. Stokes driftProfiles + allocate(CS%Us_x(G%isdB:G%IedB,G%jsd:G%jed,G%ke), source=0.0) + allocate(CS%Us_y(G%isd:G%Ied,G%jsdB:G%jedB,G%ke), source=0.0) + if (CS%Stokes_DDT) then + !allocate(CS%Us_x_prev(G%isdB:G%IedB,G%jsd:G%jed,G%ke), source=0.0) + !allocate(CS%Us_y_prev(G%isd:G%Ied,G%jsdB:G%jedB,G%ke), source=0.0) + allocate(CS%ddt_Us_x(G%isdB:G%IedB,G%jsd:G%jed,G%ke), source=0.0) + allocate(CS%ddt_Us_y(G%isd:G%Ied,G%jsdB:G%jedB,G%ke), source=0.0) + allocate(CS%Us_x_from_ddt(G%isdB:G%IedB,G%jsd:G%jed,G%ke), source=0.0) + allocate(CS%Us_y_from_ddt(G%isd:G%Ied,G%jsdB:G%jedB,G%ke), source=0.0) + endif + ! b. Surface Values + allocate(CS%US0_x(G%isdB:G%iedB,G%jsd:G%jed), source=0.0) + allocate(CS%US0_y(G%isd:G%ied,G%jsdB:G%jedB), source=0.0) + ! c. Langmuir number + allocate(CS%La_turb(G%isc:G%iec,G%jsc:G%jec), source=0.0) + ! d. Viscosity for Stokes drift + if (CS%StokesMixing) then + allocate(CS%KvS(G%isd:G%Ied,G%jsd:G%jed,GV%ke), source=0.0) + endif + + ! Initialize Wave related outputs + CS%id_surfacestokes_y = register_diag_field('ocean_model','surface_stokes_y', & + CS%diag%axesCv1,Time,'Surface Stokes drift (y)', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_surfacestokes_x = register_diag_field('ocean_model','surface_stokes_x', & + CS%diag%axesCu1,Time,'Surface Stokes drift (x)', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_3dstokes_y = register_diag_field('ocean_model','3d_stokes_y', & + CS%diag%axesCvL,Time,'3d Stokes drift (y)', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_3dstokes_x = register_diag_field('ocean_model','3d_stokes_x', & + CS%diag%axesCuL,Time,'3d Stokes drift (x)', 'm s-1', conversion=US%L_T_to_m_s) + if (CS%Stokes_DDT) then + CS%id_ddt_3dstokes_y = register_diag_field('ocean_model','dvdt_Stokes', & + CS%diag%axesCvL,Time,'d/dt Stokes drift (meridional)', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_ddt_3dstokes_x = register_diag_field('ocean_model','dudt_Stokes', & + CS%diag%axesCuL,Time,'d/dt Stokes drift (zonal)', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_3dstokes_y_from_ddt = register_diag_field('ocean_model','3d_stokes_y_from_ddt', & + CS%diag%axesCvL,Time,'3d Stokes drift from ddt (y)', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_3dstokes_x_from_ddt = register_diag_field('ocean_model','3d_stokes_x_from_ddt', & + CS%diag%axesCuL,Time,'3d Stokes drift from ddt (x)', 'm s-1', conversion=US%L_T_to_m_s) + endif + CS%id_PFv_Stokes = register_diag_field('ocean_model','PFv_Stokes', & + CS%diag%axesCvL,Time,'PF from Stokes drift (meridional)','m s-2',conversion=US%L_T2_to_m_s2) + CS%id_PFu_Stokes = register_diag_field('ocean_model','PFu_Stokes', & + CS%diag%axesCuL,Time,'PF from Stokes drift (zonal)','m s-2',conversion=US%L_T2_to_m_s2) + CS%id_P_deltaStokes_i = register_diag_field('ocean_model','P_deltaStokes_i', & + CS%diag%axesTi,Time,'Interfacial pressure anomaly from Stokes drift used in PFu_Stokes',& + 'm2 s-2',conversion=US%L_T_to_m_s**2) + CS%id_P_deltaStokes_L = register_diag_field('ocean_model','P_deltaStokes_L', & + CS%diag%axesTL,Time,'Layer averaged pressure anomaly from Stokes drift used in PFu_Stokes',& + 'm2 s-2',conversion=US%L_T_to_m_s**2) + CS%id_La_turb = register_diag_field('ocean_model','La_turbulent', & + CS%diag%axesT1,Time,'Surface (turbulent) Langmuir number','nondim') + +end subroutine MOM_wave_interface_init + +!> Set the parameters that are used to determine the averaged Stokes drift and Langmuir numbers +subroutine set_LF17_wave_params(param_file, mdl, GV, US, CS) + type(param_file_type), intent(in) :: param_file !< Input parameter structure + character(len=*), intent(in) :: mdl !< A module name to use in the get_param calls + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(wave_parameters_CS), pointer :: CS !< Wave parameter control structure + + ! A separate routine is used to set these parameters because there are multiple ways that the + ! underlying parameterizations are enabled. + + call get_param(param_file, mdl, "VISCOSITY_AIR", CS%nu_air, & + "A typical viscosity of air at sea level, as used in wave calculations", & + units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) + call get_param(param_file, mdl, "VON_KARMAN_WAVES", CS%vonKar, & + "The value the von Karman constant as used for surface wave calculations.", & + units="nondim", default=0.40) ! The default elsewhere in MOM6 is usually 0.41. + call get_param(param_file, mdl, "RHO_AIR", CS%rho_air, & + "A typical density of air at sea level, as used in wave calculations", & + units="kg m-3", default=1.225, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "RHO_SFC_WAVES", CS%Rho_ocn, & + "A typical surface density of seawater, as used in wave calculations in "//& + "comparison with the density of air. The default is RHO_0.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "WAVE_HEIGHT_SCALE_FACTOR", CS%SWH_from_u10sq, & + "A factor relating the square of the 10 m wind speed to the significant "//& + "wave height, with a default value based on the Pierson-Moskowitz spectrum.", & + units="s2 m-1", default=0.0246, scale=US%m_to_Z*US%L_T_to_m_s**2) + call get_param(param_file, mdl, "CHARNOCK_MIN", CS%Charnock_min, & + "The minimum value of the Charnock coefficient, which relates the square of "//& + "the air friction velocity divided by the gravitational acceleration to the "//& + "wave roughness length.", units="nondim", default=0.028) + call get_param(param_file, mdl, "CHARNOCK_SLOPE_U10", CS%Charnock_slope_U10, & + "The partial derivative of the Charnock coefficient with the 10 m wind speed. "//& + "Note that in eq. 13 of the Edson et al. 2013 describing the COARE 3.5 bulk "//& + "flux algorithm, this slope is given as 0.017. However, 0.0017 reproduces "//& + "the curve in their figure 6, so that is the default value used in MOM6.", & + units="s m-1", default=0.0017, scale=US%L_T_to_m_s) + call get_param(param_file, mdl, "CHARNOCK_0_WIND_INTERCEPT", CS%Charnock_intercept, & + "The intercept of the fit for the Charnock coefficient in the limit of no wind. "//& + "Note that this can be negative because CHARNOCK_MIN will keep the final "//& + "value for the Charnock coefficient from being from being negative.", & + units="nondim", default=-0.005) + +end subroutine set_LF17_wave_params + +!> This interface provides the caller with information from the waves control structure. +subroutine query_wave_properties(CS, NumBands, WaveNumbers, US) + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + integer, optional, intent(out) :: NumBands !< If present, this returns the number of + !!< wavenumber partitions in the wave discretization + real, dimension(:), optional, intent(out) :: Wavenumbers !< If present this returns the characteristic + !! wavenumbers of the wave discretization [m-1] or [Z-1 ~> m-1] + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type that is used to undo + !! the dimensional scaling of the output variables, if present + integer :: n + + if (present(NumBands)) NumBands = CS%NumBands + if (present(Wavenumbers)) then + if (size(Wavenumbers) < CS%NumBands) call MOM_error(FATAL, "query_wave_properties called "//& + "with a Wavenumbers array that is smaller than the number of bands.") + if (present(US)) then + do n=1,CS%NumBands ; Wavenumbers(n) = US%m_to_Z * CS%WaveNum_Cen(n) ; enddo + else + do n=1,CS%NumBands ; Wavenumbers(n) = CS%WaveNum_Cen(n) ; enddo + endif + endif + +end subroutine query_wave_properties + +!> Subroutine that handles updating of surface wave/Stokes drift related properties +subroutine Update_Surface_Waves(G, GV, US, Time_present, dt, CS, forces) + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(time_type), intent(in) :: Time_present !< Model Time + type(time_type), intent(in) :: dt !< Time increment as a time-type + type(mech_forcing), intent(in), optional :: forces !< MOM_forcing_type + ! Local variables + type(time_type) :: Stokes_Time + integer :: i, j, b + + if (CS%WaveMethod == TESTPROF) then + ! Do nothing + elseif (CS%WaveMethod == SURFBANDS) then + if (CS%DataSource == DATAOVR) then + ! Updating Stokes drift time to center of time increment. + ! This choice makes sense for the thermodynamics, but for the + ! dynamics it may be more useful to update to the end of the + ! time increment. + Stokes_Time = Time_present + dt/2 + call Surface_Bands_by_data_override(Stokes_Time, G, GV, US, CS) + elseif (CS%DataSource == COUPLER) then + if (.not.present(FORCES)) then + call MOM_error(FATAL,"The option SURFBAND = COUPLER can not be used with "//& + "this driver. If you are using a coupled driver with a wave model then "//& + "check the arguments in the subroutine call to Update_Surface_Waves, "//& + "otherwise select another option for SURFBAND_SOURCE.") + endif + if (size(CS%WaveNum_Cen) /= size(forces%stk_wavenumbers)) then + call MOM_error(FATAL, "Number of wavenumber bands in WW3 does not match that in MOM6. "//& + "Make sure that STK_BAND_COUPLER in MOM6 input is equal to the number of bands in "//& + "ww3_grid.inp, and that your mod_def.ww3 is up to date.") + endif + + do b=1,CS%NumBands + CS%WaveNum_Cen(b) = forces%stk_wavenumbers(b) + !Interpolate from a grid to c grid + do j=G%jsc,G%jec + do I=G%iscB,G%iecB + CS%STKx0(I,j,b) = 0.5*(forces%UStkb(i,j,b)+forces%UStkb(i+1,j,b)) + enddo + enddo + do J=G%jscB,G%jecB + do i=G%isc,G%iec + CS%STKY0(i,J,b) = 0.5*(forces%VStkb(i,j,b)+forces%VStkb(i,j+1,b)) + enddo + enddo + call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain) + enddo + do j=G%jsc,G%jec + do i=G%isc,G%iec + !CS%Omega_w2x(i,j) = forces%omega_w2x(i,j) + do b=1,CS%NumBands + CS%UStk_Hb(i,j,b) = US%m_s_to_L_T*forces%UStkb(i,j,b) + CS%VStk_Hb(i,j,b) = US%m_s_to_L_T*forces%VStkb(i,j,b) + enddo + enddo + enddo + elseif (CS%DataSource == INPUT) then + do b=1,CS%NumBands + do j=G%jsd,G%jed + do I=G%isdB,G%iedB + CS%STKx0(I,j,b) = CS%PrescribedSurfStkX(b) + enddo + enddo + do J=G%jsdB, G%jedB + do i=G%isd,G%ied + CS%STKY0(i,J,b) = CS%PrescribedSurfStkY(b) + enddo + enddo + enddo + endif + endif + +end subroutine Update_Surface_Waves + +!> Constructs the Stokes Drift profile on the model grid based on +!! desired coupling options +subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Thickness in height units [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: ustar !< Wind friction velocity [Z T-1 ~> m s-1]. + real, intent(in) :: dt !< Time-step for computing Stokes-tendency [T ~> s] + logical, intent(in) :: dynamics_step !< True if this call is on a dynamics step + + ! Local Variables + real :: Top, MidPoint, Bottom ! Positions within the layer [Z ~> m] + real :: level_thick ! The thickness of each layer [Z ~> m] + real :: DecayScale ! A vertical decay scale in the test profile [Z-1 ~> m-1] + real :: CMN_FAC ! A nondimensional factor [nondim] + real :: WN ! Model wavenumber [Z-1 ~> m-1] + real :: UStokes ! A Stokes drift velocity [L T-1 ~> m s-1] + real :: PI ! 3.1415926535... [nondim] + real :: La ! The local Langmuir number [nondim] + integer :: i, j, k, b + real :: I_dt ! The inverse of the time step [T-1 ~> s-1] + + if (CS%WaveMethod==EFACTOR) return + + if (allocated(CS%US_x) .and. allocated(CS%US_y)) then + call pass_vector(CS%US_x(:,:,:),CS%US_y(:,:,:), G%Domain) + endif + + ! 1. If Test Profile Option is chosen + ! Computing mid-point value from surface value and decay wavelength + if (CS%WaveMethod==TESTPROF) then + PI = 4.0*atan(1.0) + DecayScale = 4.*PI / CS%TP_WVL !4pi + do j=G%jsc,G%jec + do I=G%iscB,G%iecB + Bottom = 0.0 + MidPoint = 0.0 + do k = 1,GV%ke + Top = Bottom + MidPoint = Bottom - 0.25*(dz(I,j,k)+dz(I-1,j,k)) + Bottom = Bottom - 0.5*(dz(I,j,k)+dz(I-1,j,k)) + CS%Us_x(I,j,k) = CS%TP_STKX0*exp(MidPoint*DecayScale) + enddo + enddo + enddo + do J=G%jscB,G%jecB + do i=G%isc,G%iec + Bottom = 0.0 + MidPoint = 0.0 + do k = 1,GV%ke + Top = Bottom + MidPoint = Bottom - 0.25*(dz(i,J,k)+dz(i,J-1,k)) + Bottom = Bottom - 0.5*(dz(i,J,k)+dz(i,J-1,k)) + CS%Us_y(i,J,k) = CS%TP_STKY0*exp(MidPoint*DecayScale) + enddo + enddo + enddo + call pass_vector(CS%Us_x(:,:,:),CS%Us_y(:,:,:), G%Domain, To_All) + ! 2. If Surface Bands is chosen + ! In wavenumber mode compute integral for layer averaged Stokes drift. + ! In frequency mode compuate value at midpoint. + elseif (CS%WaveMethod==SURFBANDS) then + CS%Us_x(:,:,:) = 0.0 + CS%Us_y(:,:,:) = 0.0 + CS%Us0_x(:,:) = 0.0 + CS%Us0_y(:,:) = 0.0 + ! Computing X direction Stokes drift + do j=G%jsc,G%jec + do I=G%iscB,G%iecB + ! 1. First compute the surface Stokes drift + ! by summing over the partitions. + do b = 1,CS%NumBands + CS%US0_x(I,j) = CS%US0_x(I,j) + CS%STKx0(I,j,b) + enddo + ! 2. Second compute the level averaged Stokes drift + bottom = 0.0 + do k = 1,GV%ke + Top = Bottom + level_thick = 0.5*(dz(I,j,k)+dz(I-1,j,k)) + MidPoint = Top - 0.5*level_thick + Bottom = Top - level_thick + + if (CS%answer_date >= 20230101) then + ! Use more accurate and numerically stable expressions that work even for vanished layers. + do b = 1,CS%NumBands + if (CS%PartitionMode == 0) then + ! Average over a layer using the bin's central wavenumber. + CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) + else + ! Use an analytic expression for the average of an exponential over a layer + WN = CS%Freq_Cen(b)**2 * CS%I_g_Earth + CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) + endif + CS%US_x(I,j,k) = CS%US_x(I,j,k) + CS%STKx0(I,j,b)*CMN_FAC + enddo + + elseif (level_thick > CS%Stokes_min_thick_avg) then + ! -> Stokes drift in thin layers not averaged. + do b = 1,CS%NumBands + if (CS%PartitionMode == 0) then + ! In wavenumber we are averaging over level + CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b))) & + / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) + else + ! Use a numerical integration and then divide by layer thickness + WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g + CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + endif + CS%US_x(I,j,k) = CS%US_x(I,j,k) + CS%STKx0(I,j,b)*CMN_FAC + enddo + else ! Take the value at the midpoint + do b = 1,CS%NumBands + if (CS%PartitionMode == 0) then + CMN_FAC = exp(MidPoint * 2. * CS%WaveNum_Cen(b)) + else + CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) + endif + CS%US_x(I,j,k) = CS%US_x(I,j,k) + CS%STKx0(I,j,b)*CMN_FAC + enddo + endif + enddo + enddo + enddo + + ! Computing Y direction Stokes drift + do J=G%jscB,G%jecB + do i=G%isc,G%iec + ! Set the surface value to that at z=0 + do b = 1,CS%NumBands + CS%US0_y(i,J) = CS%US0_y(i,J) + CS%STKy0(i,J,b) + enddo + ! Compute the level averages. + bottom = 0.0 + do k = 1,GV%ke + Top = Bottom + level_thick = 0.5*(dz(i,J,k)+dz(i,J-1,k)) + MidPoint = Top - 0.5*level_thick + Bottom = Top - level_thick + + if (CS%answer_date >= 20230101) then + ! Use more accurate and numerically stable expressions that work even for vanished layers. + do b = 1,CS%NumBands + if (CS%PartitionMode == 0) then + ! Average over a layer using the bin's central wavenumber. + CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) + else + ! Use an analytic expression for the average of an exponential over a layer + WN = CS%Freq_Cen(b)**2 * CS%I_g_Earth + CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) + endif + CS%US_y(i,J,k) = CS%US_y(i,J,k) + CS%STKy0(i,J,b)*CMN_FAC + enddo + elseif (level_thick > CS%Stokes_min_thick_avg) then + ! -> Stokes drift in thin layers not averaged. + do b = 1,CS%NumBands + if (CS%PartitionMode == 0) then + ! In wavenumber we are averaging over level + CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b))) & + / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) + else + ! Use a numerical integration and then divide by layer thickness + WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g + CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + endif + CS%US_y(i,J,k) = CS%US_y(i,J,k) + CS%STKy0(i,J,b)*CMN_FAC + enddo + else ! Take the value at the midpoint + do b = 1,CS%NumBands + if (CS%PartitionMode == 0) then + CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) + else + CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) + endif + CS%US_y(i,J,k) = CS%US_y(i,J,k) + CS%STKy0(i,J,b)*CMN_FAC + enddo + endif + enddo + enddo + enddo + call pass_vector(CS%Us_x(:,:,:),CS%Us_y(:,:,:), G%Domain, To_All) + call pass_vector(CS%Us0_x(:,:),CS%Us0_y(:,:), G%Domain) + elseif (CS%WaveMethod == DHH85) then + if (.not.(CS%StaticWaves .and. CS%DHH85_is_set)) then + do j=G%jsc,G%jec + do I=G%iscB,G%iecB + bottom = 0.0 + do k = 1,GV%ke + Top = Bottom + MidPoint = Top - 0.25*(dz(I,j,k)+dz(I-1,j,k)) + Bottom = Top - 0.5*(dz(I,j,k)+dz(I-1,j,k)) + !bgr note that this is using a u-point I on h-point ustar + ! this code has only been previous used for uniform + ! grid cases. This needs fixed if DHH85 is used for non + ! uniform cases. + call DHH85_mid(GV, US, CS, MidPoint, UStokes) + ! Putting into x-direction (no option for direction + CS%US_x(I,j,k) = UStokes + enddo + enddo + enddo + do J=G%jscB,G%jecB + do i=G%isc,G%iec + Bottom = 0.0 + do k = 1,GV%ke + Top = Bottom + MidPoint = Bottom - 0.25*(dz(i,J,k)+dz(i,J-1,k)) + Bottom = Bottom - 0.5*(dz(i,J,k)+dz(i,J-1,k)) + !bgr note that this is using a v-point J on h-point ustar + ! this code has only been previous used for uniform + ! grid cases. This needs fixed if DHH85 is used for non + ! uniform cases. + ! call DHH85_mid(GV, US, CS, Midpoint, UStokes) + ! Putting into x-direction, so setting y direction to 0 + CS%US_y(i,J,k) = 0.0 + ! For rotational symmetry there should be the option for this to become = UStokes + ! bgr - see note above, but this is true + ! if this is used for anything + ! other than simple LES comparison + enddo + enddo + enddo + CS%DHH85_is_set = .true. + endif + call pass_vector(CS%Us_x(:,:,:),CS%Us_y(:,:,:), G%Domain) + else! Keep this else, fallback to 0 Stokes drift + CS%Us_x(:,:,:) = 0. + CS%Us_y(:,:,:) = 0. + endif + + ! Turbulent Langmuir number is computed here and available to use anywhere. + ! SL Langmuir number requires mixing layer depth, and therefore is computed + ! in the routine it is needed by (e.g. KPP or ePBL). + do j=G%jsc, G%jec + do i=G%isc,G%iec + call get_Langmuir_Number( La, G, GV, US, dz(i,j,1), ustar(i,j), i, j, & + dz(i,j,:), CS, Override_MA=.false.) + CS%La_turb(i,j) = La + enddo + enddo + + ! Finding tendency of Stokes drift over the time step to apply + ! as an acceleration to the models current. + if ( dynamics_step .and. CS%Stokes_DDT ) then + I_dt = 1.0 / dt + CS%ddt_us_x(:,:,:) = (CS%US_x(:,:,:) - CS%US_x_prev(:,:,:)) * I_dt + CS%ddt_us_y(:,:,:) = (CS%US_y(:,:,:) - CS%US_y_prev(:,:,:)) * I_dt + CS%US_x_prev(:,:,:) = CS%US_x(:,:,:) + CS%US_y_prev(:,:,:) = CS%US_y(:,:,:) + endif + + ! Output any desired quantities + if (CS%id_surfacestokes_y>0) & + call post_data(CS%id_surfacestokes_y, CS%us0_y, CS%diag) + if (CS%id_surfacestokes_x>0) & + call post_data(CS%id_surfacestokes_x, CS%us0_x, CS%diag) + if (CS%id_3dstokes_y>0) & + call post_data(CS%id_3dstokes_y, CS%us_y, CS%diag) + if (CS%id_3dstokes_x>0) & + call post_data(CS%id_3dstokes_x, CS%us_x, CS%diag) + if (CS%Stokes_DDT) then + if (CS%id_ddt_3dstokes_x>0) & + call post_data(CS%id_ddt_3dstokes_x, CS%ddt_us_x, CS%diag) + if (CS%id_ddt_3dstokes_y>0) & + call post_data(CS%id_ddt_3dstokes_y, CS%ddt_us_y, CS%diag) + if (CS%id_3dstokes_x_from_ddt>0) & + call post_data(CS%id_3dstokes_x_from_ddt, CS%us_x_from_ddt, CS%diag) + if (CS%id_3dstokes_y_from_ddt>0) & + call post_data(CS%id_3dstokes_y_from_ddt, CS%us_y_from_ddt, CS%diag) + endif + if (CS%id_La_turb>0) & + call post_data(CS%id_La_turb, CS%La_turb, CS%diag) + +end subroutine Update_Stokes_Drift + +!> Return the value of (1 - exp(-x))/x, using an accurate expression for small values of x. +real function one_minus_exp_x(x) + real, intent(in) :: x !< The argument of the function ((1 - exp(-x))/x) [nondim] + real, parameter :: C1_6 = 1.0/6.0 ! A rational fraction [nondim] + if (abs(x) <= 2.0e-5) then + ! The Taylor series expression for exp(-x) gives a more accurate expression for 64-bit reals. + one_minus_exp_x = 1.0 - x * (0.5 - C1_6*x) + else + one_minus_exp_x = (1.0 - exp(-x)) / x + endif +end function one_minus_exp_x + +!> A subroutine to fill the Stokes drift from a NetCDF file +!! using the data_override procedures. +subroutine Surface_Bands_by_data_override(Time, G, GV, US, CS) + type(time_type), intent(in) :: Time !< Time to get Stokes drift bands + type(wave_parameters_CS), pointer :: CS !< Wave structure + type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal Stokes drift of band at h-points [L T-1 ~> m s-1] + real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional Stokes drift of band at h-points [L T-1 ~> m s-1] + integer, dimension(4) :: sizes ! The sizes of the various dimensions of the variable. + character(len=48) :: dim_name(4) ! The names of the dimensions of the variable. + character(len=20) :: varname ! The name of an input variable for data override. + real :: PI ! 3.1415926535... [nondim] + logical :: wavenumber_exists + integer :: ndims, b, i, j + + if (.not.CS%DataOver_initialized) then + call data_override_init(G%Domain) + CS%DataOver_initialized = .true. + + if (.not.file_exists(CS%SurfBandFileName)) & + call MOM_error(FATAL, "MOM_wave_interface is unable to find file "//trim(CS%SurfBandFileName)) + + ! Check if input has wavenumber or frequency variables. + + ! Read the number of wavenumber bands in the file, if the variable 'wavenumber' exists. + call get_var_sizes(CS%SurfBandFileName, 'wavenumber', ndims, sizes, dim_names=dim_name) + wavenumber_exists = (ndims > -1) + + if (.not.wavenumber_exists) then + ! Read the number of frequency bands in the file, if the variable 'frequency' exists. + call get_var_sizes(CS%SurfBandFileName, 'frequency', ndims, sizes, dim_names=dim_name) + if (ndims < 0) & + call MOM_error(FATAL, "error finding variable 'wavenumber' or 'frequency' in file "//& + trim(CS%SurfBandFileName)//" in MOM_wave_interface.") + endif + + CS%NUMBANDS = sizes(1) + ! Allocate the wavenumber bins + allocate( CS%WaveNum_Cen(CS%NUMBANDS), source=0.0 ) + + if (wavenumber_exists) then + ! Wavenumbers found, so this file uses the old method: + CS%PartitionMode = 0 + + ! Reading wavenumber bins + call read_variable(CS%SurfBandFileName, dim_name(1), CS%WaveNum_Cen, scale=US%Z_to_m) + + else + ! Frequencies found, so this file uses the newer method: + CS%PartitionMode = 1 + + ! Allocate the frequency bins + allocate( CS%Freq_Cen(CS%NUMBANDS), source=0.0 ) + + ! Reading frequencies + PI = 4.0*atan(1.0) + call read_variable(CS%SurfBandFileName, dim_name(1), CS%Freq_Cen, scale=2.*PI*US%T_to_s) + + do b = 1,CS%NumBands + CS%WaveNum_Cen(b) = CS%Freq_Cen(b)**2 / CS%g_Earth + enddo + endif + + if (.not.allocated(CS%STKx0)) then + allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NUMBANDS), source=0.0 ) + endif + if (.not.allocated(CS%STKy0)) then + allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,CS%NUMBANDS), source=0.0 ) + endif + endif + + do b = 1,CS%NumBands + temp_x(:,:) = 0.0 + temp_y(:,:) = 0.0 + varname = ' ' + write(varname, "(A3,I0)") 'Usx', b + call data_override(G%Domain, trim(varname), temp_x, Time, scale=US%m_s_to_L_T) + varname = ' ' + write(varname, "(A3,I0)") 'Usy', b + call data_override(G%Domain, trim(varname), temp_y, Time, scale=US%m_s_to_L_T) + ! Update halo on h-grid + call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) + ! Filter land values + do j = G%jsd,G%jed + do i = G%Isd,G%Ied + if ((abs(temp_x(i,j)) > CS%land_speed) .or. (abs(temp_y(i,j)) > CS%land_speed)) then + ! Assume land-mask and zero out + temp_x(i,j) = 0.0 + temp_y(i,j) = 0.0 + endif + enddo + enddo + + ! Interpolate to u/v grids + do j = G%jsc,G%jec + do I = G%IscB,G%IecB + CS%STKx0(I,j,b) = 0.5 * (temp_x(i,j) + temp_x(i+1,j)) + enddo + enddo + do J = G%JscB,G%JecB + do i = G%isc,G%iec + CS%STKy0(i,J,b) = 0.5 * (temp_y(i,j) + temp_y(i,j+1)) + enddo + enddo + enddo !Closes b-loop + + ! Update halo on u/v grids + call pass_vector(CS%STKx0(:,:,:), CS%STKy0(:,:,:), G%Domain, To_ALL) + +end subroutine Surface_Bands_by_data_override + +!> Interface to get Langmuir number based on options stored in wave structure +!! +!! Note this can be called with an unallocated Waves pointer, which is okay if we +!! want the wind-speed only dependent Langmuir number. Therefore, we need to be +!! careful about what we try to access here. +subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, dz, Waves, & + U_H, V_H, Override_MA ) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, intent(out) :: LA !< Langmuir number [nondim] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: HBL !< (Positive) thickness of boundary layer [Z ~> m] + real, intent(in) :: ustar !< Friction velocity [Z T-1 ~> m s-1] + integer, intent(in) :: i !< Meridional index of h-point + integer, intent(in) :: j !< Zonal index of h-point + real, dimension(SZK_(GV)), intent(in) :: dz !< Grid layer thickness [Z ~> m] + type(Wave_parameters_CS), pointer :: Waves !< Surface wave control structure. + real, dimension(SZK_(GV)), & + optional, intent(in) :: U_H !< Zonal velocity at H point [L T-1 ~> m s-1] or [m s-1] + real, dimension(SZK_(GV)), & + optional, intent(in) :: V_H !< Meridional velocity at H point [L T-1 ~> m s-1] or [m s-1] + logical, optional, intent(in) :: Override_MA !< Override to use misalignment in LA + !! calculation. This can be used if diagnostic + !! LA outputs are desired that are different than + !! those used by the dynamical model. + + +!Local Variables + real :: Top, Bottom, MidPoint ! Positions within each layer [Z ~> m] + real :: Dpt_LASL ! Averaging depth for Stokes drift [Z ~> m] + real :: ShearDirection ! Shear angular direction from atan2 [radians] + real :: WaveDirection ! Wave angular direction from atan2 [radians] + real :: LA_STKx, LA_STKy, LA_STK ! Stokes velocities in [L T-1 ~> m s-1] + logical :: ContinueLoop, USE_MA + real, dimension(SZK_(GV)) :: US_H, VS_H ! Profiles of Stokes velocities [L T-1 ~> m s-1] + real, allocatable :: StkBand_X(:), StkBand_Y(:) ! Stokes drifts by band [L T-1 ~> m s-1] + integer :: k, BB + + ! Compute averaging depth for Stokes drift (negative) + Dpt_LASL = -1.0*max(Waves%LA_FracHBL*HBL, Waves%LA_HBL_min) + + USE_MA = Waves%LA_Misalignment + if (present(Override_MA)) USE_MA = Override_MA + + ! If requesting to use misalignment in the Langmuir number compute the Shear Direction + if (USE_MA) then + if (.not.(present(U_H).and.present(V_H))) call MOM_error(FATAL, & + "Get_LA_waves requested to consider misalignment, but velocities were not provided.") + ContinueLoop = .true. + bottom = 0.0 + do k = 1,GV%ke + Top = Bottom + MidPoint = Bottom + 0.5*dz(k) + Bottom = Bottom + dz(k) + !### Given the sign convention that Dpt_LASL is negative, the next line seems to have a bug. + ! To correct this bug, this line should be changed to: + ! if (MidPoint > abs(Dpt_LASL) .and. (k > 1) .and. ContinueLoop) then + if (MidPoint > Dpt_LASL .and. k > 1 .and. ContinueLoop) then + ShearDirection = atan2(V_H(1)-V_H(k), U_H(1)-U_H(k)) + ContinueLoop = .false. + endif + enddo + endif + + if (Waves%WaveMethod==TESTPROF) then + do k = 1,GV%ke + US_H(k) = 0.5*(Waves%US_X(I,j,k)+Waves%US_X(I-1,j,k)) + VS_H(k) = 0.5*(Waves%US_Y(i,J,k)+Waves%US_Y(i,J-1,k)) + enddo + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, US_H, LA_STKx) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, VS_H, LA_STKy) + LA_STK = sqrt(LA_STKX*LA_STKX+LA_STKY*LA_STKY) + elseif (Waves%WaveMethod==SURFBANDS) then + allocate(StkBand_X(Waves%NumBands), StkBand_Y(Waves%NumBands)) + do bb = 1,Waves%NumBands + StkBand_X(bb) = 0.5*(Waves%STKx0(I,j,bb)+Waves%STKx0(I-1,j,bb)) + StkBand_Y(bb) = 0.5*(Waves%STKy0(i,J,bb)+Waves%STKy0(i,J-1,bb)) + enddo + call Get_SL_Average_Band(GV, Dpt_LASL, Waves%NumBands, Waves%WaveNum_Cen, StkBand_X, LA_STKx ) + call Get_SL_Average_Band(GV, Dpt_LASL, Waves%NumBands, Waves%WaveNum_Cen, StkBand_Y, LA_STKy ) + LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) + deallocate(StkBand_X, StkBand_Y) + elseif (Waves%WaveMethod==DHH85) then + ! Temporarily integrating profile rather than spectrum for simplicity + do k = 1,GV%ke + US_H(k) = 0.5*(Waves%US_X(I,j,k)+Waves%US_X(I-1,j,k)) + VS_H(k) = 0.5*(Waves%US_Y(i,J,k)+Waves%US_Y(i,J-1,k)) + enddo + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, US_H, LA_STKx) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, VS_H, LA_STKy) + LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) + elseif (Waves%WaveMethod==LF17) then + call get_StokesSL_LiFoxKemper(ustar, HBL*Waves%LA_FracHBL, GV, US, Waves, LA_STK, LA) + elseif (Waves%WaveMethod==Null_WaveMethod) then + call MOM_error(FATAL, "Get_Langmuir_number called without defining a WaveMethod. "//& + "Suggest to make sure USE_LT is set/overridden to False or choose "//& + "a wave method (or set USE_LA_LI2016 to use statistical waves).") + endif + + if (.not.(Waves%WaveMethod==LF17)) then + ! This expression uses an arbitrary lower bound on Langmuir number. + ! We shouldn't expect values lower than this, but there is also no good reason to cap it here + ! other than to prevent large enhancements in unconstrained parts of the curve fit parameterizations. + LA = max(Waves%La_min, sqrt(US%Z_to_L*ustar / (LA_STK + Waves%La_Stk_backgnd))) + endif + + if (Use_MA) then + WaveDirection = atan2(LA_STKy, LA_STKx) + LA = LA / sqrt(max(1.e-8, cos( WaveDirection - ShearDirection))) + endif + +end subroutine get_Langmuir_Number + +!> function to return the wave method string set in the param file +function get_wave_method(CS) + character(:), allocatable :: get_wave_method + type(wave_parameters_CS), pointer :: CS !< Control structure + + if (associated(CS)) then + select case(CS%WaveMethod) + case (Null_WaveMethod) + get_wave_method = NULL_STRING + case (TESTPROF) + get_wave_method = TESTPROF_STRING + case (SURFBANDS) + get_wave_method = SURFBANDS_STRING + case (DHH85) + get_wave_method = DHH85_STRING + case (LF17) + get_wave_method = LF17_STRING + case (EFACTOR) + get_wave_method = EFACTOR_STRING + end select + else + get_wave_method = NULL_STRING + endif +end function get_wave_method + +!> Get SL averaged Stokes drift from Li/FK 17 method +!! +!! Original description: +!! - This function returns the enhancement factor, given the 10-meter +!! wind [m s-1], friction velocity [m s-1] and the boundary layer depth [m]. +!! +!! Update (Jan/25): +!! - Converted from function to subroutine, now returns Langmuir number. +!! - Compute 10m wind internally, so only ustar and hbl need passed to +!! subroutine. +!! +!! Qing Li, 160606 +!! - BGR port from CVMix to MOM6 Jan/25/2017 +!! - BGR change output to LA from Efactor +!! - BGR remove u10 input +!! - BGR note: fixed parameter values should be changed to "get_params" +subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) + real, intent(in) :: ustar !< water-side surface friction velocity [Z T-1 ~> m s-1]. + real, intent(in) :: hbl !< boundary layer depth [Z ~> m]. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + real, intent(out) :: UStokes_SL !< Surface layer averaged Stokes drift [L T-1 ~> m s-1] + real, intent(out) :: LA !< Langmuir number [nondim] + ! Local variables + ! parameters + real, parameter :: u19p5_to_u10 = 1.075 ! ratio of U19.5 to U10 (Holthuijsen, 2007) [nondim] + real, parameter :: fm_into_fp = 1.296 ! ratio of mean frequency to peak frequency for + ! Pierson-Moskowitz spectrum (Webb, 2011) [nondim] + real, parameter :: us_to_u10 = 0.0162 ! ratio of surface Stokes drift to U10 [nondim] + real, parameter :: r_loss = 0.667 ! loss ratio of Stokes transport [nondim] + real :: UStokes ! The surface Stokes drift [L T-1 ~> m s-1] + real :: hm0 ! The significant wave height [Z ~> m] + real :: fm ! The mean wave frequency [T-1 ~> s-1] + real :: fp ! The peak wave frequency [T-1 ~> s-1] + real :: kphil ! A peak wavenumber in the Phillips spectrum [Z-1 ~> m-1] + real :: kstar ! A rescaled wavenumber? [Z-1 ~> m-1] + real :: vstokes ! The total Stokes transport [Z L T-1 ~> m2 s-1] + real :: z0 ! The boundary layer depth [Z ~> m] + real :: z0i ! The inverse of the boundary layer depth [Z-1 ~> m-1] + real :: r1, r2, r3, r4 ! Nondimensional ratios [nondim] + real :: r5 ! A single expression that combines r2 and r4 [nondim] + real :: root_2kz ! The square root of twice the peak wavenumber times the + ! boundary layer depth [nondim] + real :: u10 ! The 10 m wind speed [L T-1 ~> m s-1] + real :: PI ! 3.1415926535... [nondim] + + PI = 4.0*atan(1.0) + UStokes_sl = 0.0 + LA = 1.e8 + if (ustar > 0.0) then + ! This code should be revised to minimize the number of divisions and cancel out common factors. + + ! Computing u10 based on u_star and COARE 3.5 relationships + call ust_2_u10_coare3p5(ustar*sqrt(CS%rho_ocn/CS%rho_air), u10, GV, US, CS) + ! surface Stokes drift + UStokes = us_to_u10*u10 + ! + ! significant wave height from Pierson-Moskowitz spectrum (Bouws, 1998) + hm0 = CS%SWH_from_u10sq * u10**2 + ! + ! peak frequency (PM, Bouws, 1998) + fp = 0.877 * (US%L_to_Z*GV%g_Earth) / (2.0 * PI * u19p5_to_u10 * u10) + ! + ! mean frequency + fm = fm_into_fp * fp + ! + ! total Stokes transport (a factor r_loss is applied to account + ! for the effect of directional spreading, multidirectional waves + ! and the use of PM peak frequency and PM significant wave height + ! on estimating the Stokes transport) + vstokes = 0.125 * PI * r_loss * US%Z_to_L * fm * hm0**2 + ! + ! the general peak wavenumber for Phillips' spectrum + ! (Breivik et al., 2016) with correction of directional spreading + kphil = 0.176 * UStokes / vstokes + + ! Combining all of the expressions above gives kPhil as the following + ! where the first two lines are just a constant: + ! kphil = ((0.176 * us_to_u10 * u19p5_to_u10) / & + ! (0.5*0.125 * r_loss * fm_into_fp * 0.877 * CS%SWH_from_u10sq**2)) / & + ! (GV%g_Earth * u10**2) + + ! surface layer + z0 = abs(hbl) + + if (CS%answer_date < 20230102) then + z0i = 1.0 / z0 + + ! Surface layer averaged Stokes drift with Stokes drift profile + ! estimated from Phillips' spectrum (Breivik et al., 2016) + ! The directional spreading effect from Webb and Fox-Kemper, 2015 is also included. + kstar = kphil * 2.56 + + ! Terms 1 to 4, as written in the appendix of Li et al. (2017) + r1 = ( 0.151 / kphil * z0i - 0.84 ) * & + ( 1.0 - exp(-2.0 * kphil * z0) ) + r2 = -( 0.84 + 0.0591 / kphil * z0i ) * & + sqrt( 2.0 * PI * kphil * z0 ) * & + erfc( sqrt( 2.0 * kphil * z0 ) ) + r3 = ( 0.0632 / kstar * z0i + 0.125 ) * & + (1.0 - exp(-2.0 * kstar * z0) ) + r4 = ( 0.125 + 0.0946 / kstar * z0i ) * & + sqrt( 2.0 * PI * kstar * z0) * & + erfc( sqrt( 2.0 * kstar * z0 ) ) + UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) + else + ! The following is equivalent to the code above, but avoids singularities + r1 = ( 0.302 - 1.68*(kphil*z0) ) * one_minus_exp_x(2.0 * (kphil * z0)) + r3 = ( 0.1264 + 0.64*(kphil*z0) ) * one_minus_exp_x(5.12 * (kphil * z0)) + + root_2kz = sqrt(2.0 * kphil * z0) + ! r2 = -( 0.84 + 0.0591*2.0 / (root_2kz**2) ) * sqrt(PI) * root_2kz * erfc( root_2kz ) + ! r4 = ( 0.2 + 0.059125*2.0 / (root_2kz**2) ) * sqrt(PI) * root_2kz * erfc( 1.6 * root_2kz ) + + ! r5 = r2 + r4 (with a small correction to one coefficient to avoid a singularity when z0 = 0): + ! The correction leads to <1% relative differences in (r2+r4) for root_2kz > 0.05, but without + ! it the values of r2 + r4 are qualitatively wrong (>50% errors) for root_2kz < 0.0015 . + ! It has been verified that these two expressions for r5 are the same to 6 decimal places for + ! root_2kz between 1e-10 and 1e-3, but that the first one degrades for smaller values. + if (root_2kz > 1e-3) then + r5 = sqrt(PI) * (root_2kz * (-0.84 * erfc(root_2kz) + 0.2 * erfc(1.6*root_2kz)) + & + 0.1182 * (erfc(1.6*root_2kz) - erfc(root_2kz)) / root_2kz) + else + ! It is more accurate to replace erf with the first two terms of its Taylor series + ! erf(z) = (2/sqrt(pi)) * z * (1. - (1/3)*z**2 + (1/10)*z**4 - (1/42)*z**6 + ...) + ! and then cancel or combine common terms and drop negligibly small terms. + r5 = -0.64*sqrt(PI)*root_2kz + (-0.14184 + 1.0839648 * root_2kz**2) + endif + UStokes_sl = UStokes * (0.715 + ((r1 + r3) + r5)) + endif + + if (UStokes_sl /= 0.0) LA = sqrt(US%Z_to_L*ustar / UStokes_sl) + endif + +end subroutine Get_StokesSL_LiFoxKemper + +!> Get SL Averaged Stokes drift from a Stokes drift Profile +subroutine Get_SL_Average_Prof( GV, AvgDepth, dz, Profile, Average ) + type(verticalGrid_type), & + intent(in) :: GV !< Ocean vertical grid structure + real, intent(in) :: AvgDepth !< Depth to average over (negative) [Z ~> m] + real, dimension(SZK_(GV)), & + intent(in) :: dz !< Grid thickness [Z ~> m] + real, dimension(SZK_(GV)), & + intent(in) :: Profile !< Profile of quantity to be averaged in arbitrary units [A] + !! (used here for Stokes drift) + real, intent(out) :: Average !< Output quantity averaged over depth AvgDepth [A] + !! (used here for Stokes drift) + !Local variables + real :: Top, Bottom ! Depths, negative downward [Z ~> m] + real :: Sum ! The depth weighted vertical sum of a quantity [A Z ~> A m] + integer :: k + + ! Initializing sum + Sum = 0.0 + + ! Integrate + bottom = 0.0 + do k = 1, GV%ke + Top = Bottom + Bottom = Bottom - dz(k) + if (AvgDepth < Bottom) then ! The whole cell is within H_LA + Sum = Sum + Profile(k) * dz(k) + elseif (AvgDepth < Top) then ! A partial cell is within H_LA + Sum = Sum + Profile(k) * (Top-AvgDepth) + exit + else + exit + endif + enddo + + ! Divide by AvgDepth or the depth in the column, whichever is smaller. + if (abs(AvgDepth) <= abs(Bottom)) then + Average = Sum / abs(AvgDepth) + elseif (abs(Bottom) > 0.0) then + Average = Sum / abs(Bottom) + else + Average = 0.0 + endif + +end subroutine Get_SL_Average_Prof + +!> Get SL averaged Stokes drift from the banded Spectrum method +subroutine Get_SL_Average_Band( GV, AvgDepth, NB, WaveNumbers, SurfStokes, Average ) + type(verticalGrid_type), & + intent(in) :: GV !< Ocean vertical grid + real, intent(in) :: AvgDepth !< Depth to average over [Z ~> m]. + integer, intent(in) :: NB !< Number of bands used + real, dimension(NB), & + intent(in) :: WaveNumbers !< Wavenumber corresponding to each band [Z-1 ~> m-1] + real, dimension(NB), & + intent(in) :: SurfStokes !< Surface Stokes drift for each band [L T-1 ~> m s-1] + real, intent(out) :: Average !< Output average Stokes drift over depth AvgDepth [L T-1 ~> m s-1] + + ! Local variables + integer :: bb + + ! Loop over bands + Average = 0.0 + do bb = 1, NB + ! Factor includes analytical integration of e(2kz) + ! - divided by (-H_LA) to get average from integral. + Average = Average + SurfStokes(BB) * & + (1.-EXP(-abs(AvgDepth * 2.0 * WaveNumbers(BB)))) / & + abs(AvgDepth * 2.0 * WaveNumbers(BB)) + + ! For accuracy when AvgDepth is small change the above to: + ! Average = Average + SurfStokes(BB) * one_minus_exp_x(abs(AvgDepth * 2.0 * WaveNumbers(BB))) + enddo + +end subroutine Get_SL_Average_Band + +!> Compute the Stokes drift at a given depth +!! +!! Taken from Qing Li (Brown) +!! use for comparing MOM6 simulation to his LES +!! computed at z mid point (I think) and not depth averaged. +!! Should be fine to integrate in frequency from 0.1 to sqrt(-0.2*grav*2pi/dz +subroutine DHH85_mid(GV, US, CS, zpt, UStokes) + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + real, intent(in) :: zpt !< Depth to get Stokes drift [Z ~> m]. + real, intent(out) :: UStokes !< Stokes drift [L T-1 ~> m s-1] + ! + real :: ann, Bnn, Snn, Cnn, Dnn ! Nondimensional factors [nondim] + real :: omega_peak ! The peak wave frequency [T-1 ~> s-1] + real :: omega ! The average frequency in the band [T-1 ~> s-1] + real :: domega ! The width in frequency of the band [T-1 ~> s-1] + real :: u10 ! The wind speed for this spectrum [Z T-1 ~> m s-1] + real :: wavespec ! The wave spectrum [L Z T ~> m2 s] + real :: Stokes ! The Stokes displacement per cycle [L ~> m] + real :: PI ! 3.1415926535... [nondim] + integer :: Nomega ! The number of wavenumber bands + integer :: OI + + u10 = CS%WaveWind*US%L_to_Z + + !/ + NOmega = 1000 + domega = (CS%omega_max - CS%omega_min) / real(NOmega) + + ! + if (CS%WaveAgePeakFreq) then + omega_peak = CS%g_Earth / (CS%WaveAge * u10) + else + PI = 4.0*atan(1.0) + omega_peak = 2. * PI * 0.13 * CS%g_Earth / u10 + endif + !/ + Ann = 0.006 * CS%WaveAge**(-0.55) + Bnn = 1.0 + Snn = 0.08 * (1.0 + 4.0 * CS%WaveAge**3) + Cnn = 1.7 + if (CS%WaveAge < 1.) then + Cnn = Cnn - 6.0*log10(CS%WaveAge) + endif + !/ + UStokes = 0.0 + omega = CS%omega_min + 0.5*domega + do oi = 1,nomega-1 + Dnn = exp ( -0.5 * (omega-omega_peak)**2 / (Snn**2 * omega_peak**2) ) + ! wavespec units [L Z T ~> m2 s] + wavespec = US%Z_to_L * (Ann * CS%g_Earth**2 / (omega_peak*omega**4 ) ) * & + exp(-bnn*(omega_peak/omega)**4)*Cnn**Dnn + ! Stokes units [L ~> m] (multiply by frequency range for units of [L T-1 ~> m s-1]) + Stokes = 2.0 * wavespec * omega**3 * & + exp( 2.0 * omega**2 * zpt / CS%g_Earth) / CS%g_Earth + UStokes = UStokes + Stokes*domega + omega = omega + domega + enddo + +end subroutine DHH85_mid + +!> Explicit solver for Stokes mixing. +!! Still in development do not use. +subroutine StokesMixing(G, GV, dt, h, dz, u, v, Waves ) + type(ocean_grid_type), & + intent(in) :: G !< Ocean grid + type(verticalGrid_type), & + intent(in) :: GV !< Ocean vertical grid + real, intent(in) :: dt !< Time step of MOM6 [T ~> s] for explicit solver + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Vertical distance between interfaces around a layer [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Velocity i-component [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Velocity j-component [L T-1 ~> m s-1] + type(Wave_parameters_CS), & + pointer :: Waves !< Surface wave related control structure. + ! Local variables + real :: dTauUp, dTauDn ! Vertical momentum fluxes [H L T-2 ~> m2 s-2 or Pa] + real :: h_lay ! The layer thickness at a velocity point [H ~> m or kg m-2] + real :: dz_lay ! The distance between interfaces at a velocity point [Z ~> m] + integer :: i, j, k + +! This is a template to think about down-Stokes mixing. +! This is not ready for use... + + do k = 1, GV%ke + do j = G%jsc, G%jec + do I = G%iscB, G%iecB + h_lay = 0.5*(h(i,j,k)+h(i+1,j,k)) + dz_lay = 0.5*(dz(i,j,k)+dz(i+1,j,k)) + dTauUp = 0.0 + if (k > 1) & + dTauUp = (0.5*(waves%Kvs(i,j,k)+waves%Kvs(i+1,j,k))) * & + (waves%us_x(i,j,k-1)-waves%us_x(i,j,k)) / & + (0.5*(dz_lay + 0.5*(dz(i,j,k-1)+dz(i+1,j,k-1)) )) + dTauDn = 0.0 + if (k < GV%ke-1) & + dTauDn = (0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i+1,j,k+1))) * & + (waves%us_x(i,j,k)-waves%us_x(i,j,k+1)) / & + (0.5*(dz_lay + 0.5*(dz(i,j,k+1)+dz(i+1,j,k+1)) )) + u(i,j,k) = u(i,j,k) + dt * (dTauUp-dTauDn) / h_lay + enddo + enddo + enddo + + do k = 1, GV%ke + do J = G%jscB, G%jecB + do i = G%isc, G%iec + h_lay = 0.5*(h(i,j,k)+h(i,j+1,k)) + dz_lay = 0.5*(dz(i,j,k)+dz(i,j+1,k)) + dTauUp = 0. + if (k > 1) & + dTauUp = (0.5*(waves%Kvs(i,j,k)+waves%Kvs(i,j+1,k))) * & + (waves%us_y(i,j,k-1)-waves%us_y(i,j,k)) / & + (0.5*(dz_lay + 0.5*(dz(i,j,k-1)+dz(i,j+1,k-1)) )) + dTauDn = 0.0 + if (k < GV%ke-1) & + dTauDn = (0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i,j+1,k+1))) * & + (waves%us_y(i,j,k)-waves%us_y(i,j,k+1)) / & + (0.5*(dz_lay + 0.5*(dz(i,j,k+1)+dz(i,j+1,k+1)) )) + v(i,J,k) = v(i,J,k) + dt * (dTauUp-dTauDn) / h_lay + enddo + enddo + enddo + +end subroutine StokesMixing + +!> Solver to add Coriolis-Stokes to model +!! Still in development and not meant for general use. +!! Can be activated (with code intervention) for LES comparison +!! CHECK THAT RIGHT TIMESTEP IS PASSED IF YOU USE THIS** +!! +!! Not accessed in the standard code. +subroutine CoriolisStokes(G, GV, dt, h, u, v, Waves) + type(ocean_grid_type), & + intent(in) :: G !< Ocean grid + type(verticalGrid_type), & + intent(in) :: GV !< Ocean vertical grid + real, intent(in) :: dt !< Time step of MOM6 [T ~> s] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Velocity i-component [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Velocity j-component [L T-1 ~> m s-1] + type(Wave_parameters_CS), & + pointer :: Waves !< Surface wave related control structure. + + ! Local variables + real :: DVel ! A rescaled velocity change [L T-2 ~> m s-2] + integer :: i, j, k + + do k = 1, GV%ke + do j = G%jsc, G%jec + do I = G%iscB, G%iecB + DVel = 0.25*(Waves%us_y(i,j+1,k)+Waves%us_y(i-1,j+1,k))*G%CoriolisBu(i,j+1) + & + 0.25*(Waves%us_y(i,j,k)+Waves%us_y(i-1,j,k))*G%CoriolisBu(i,j) + u(I,j,k) = u(I,j,k) + DVEL*dt + enddo + enddo + enddo + + do k = 1, GV%ke + do J = G%jscB, G%jecB + do i = G%isc, G%iec + DVel = 0.25*(Waves%us_x(i+1,j,k)+Waves%us_x(i+1,j-1,k))*G%CoriolisBu(i+1,j) + & + 0.25*(Waves%us_x(i,j,k)+Waves%us_x(i,j-1,k))*G%CoriolisBu(i,j) + v(i,J,k) = v(i,j,k) - DVEL*dt + enddo + enddo + enddo +end subroutine CoriolisStokes + +!> Computes tendency due to Stokes pressure gradient force anomaly +!! including analytical integration of Stokes shear using multiple-exponential decay +!! Stokes drift profile and vertical integration of the resulting pressure +!! anomaly to the total pressure gradient force +subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) + type(ocean_grid_type), & + intent(in) :: G !< Ocean grid + type(verticalGrid_type), & + intent(in) :: GV !< Ocean vertical grid + type(unit_scale_type), & + intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)),& + intent(in) :: dz !< Layer thicknesses in height units [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< Lagrangian Velocity i-component [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< Lagrangian Velocity j-component [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: PFu_Stokes !< PGF Stokes-shear i-component [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: PFv_Stokes !< PGF Stokes-shear j-component [L T-2 ~> m s-2] + type(Wave_parameters_CS), & + pointer :: CS !< Surface wave related control structure. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: P_deltaStokes_L ! The Stokes induced pressure anomaly, + ! layer averaged [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: P_deltaStokes_i ! The Stokes induced pressure anomaly + ! at interfaces [L2 T-2 ~> m2 s-2] + real :: P_Stokes_l, P_Stokes_r ! Stokes-induced pressure anomaly over layer (left/right of point) [L2 T-2 ~> m2 s-2] + real :: P_Stokes_l0, P_Stokes_r0 ! Stokes-induced pressure anomaly at interface + ! (left/right of point) [L2 T-2 ~> m2 s-2] + real :: dP_Stokes_l_dz, dP_Stokes_r_dz ! Contribution of layer to integrated Stokes pressure anomaly for summation + ! (left/right of point) [L3 T-2 ~> m3 s-2] + real :: dP_Stokes_l, dP_Stokes_r ! Net increment of Stokes pressure anomaly across layer for summation + ! (left/right of point) [L2 T-2 ~> m2 s-2] + real :: uE_l, uE_r, vE_l, vE_r ! Eulerian velocity components (left/right of point) [L T-1 ~> m s-1] + real :: uS0_l, uS0_r, vS0_l, vS0_r ! Surface Stokes velocity components (left/right of point) [L T-1 ~> m s-1] + real :: zi_l(SZK_(G)+1), zi_r(SZK_(G)+1) ! The height of the edges of the cells (left/right of point) [Z ~> m]. + real :: idz_l(SZK_(G)), idz_r(SZK_(G)) ! The inverse thickness of the cells (left/right of point) [Z-1 ~> m-1] + real :: h_l, h_r ! The thickness of the cell (left/right of point) [Z ~> m]. + real :: dexp2kzL, dexp4kzL, dexp2kzR, dexp4kzR ! Analytical evaluation of multi-exponential decay + ! contribution to Stokes pressure anomalies [nondim]. + real :: TwoK, FourK ! Wavenumbers multiplied by a factor [Z-1 ~> m-1] + real :: iTwoK, iFourK ! Inverses of wavenumbers [Z ~> m] + + integer :: i, j, k, l + + !--------------------------------------------------------------- + ! Compute the Stokes contribution to the pressure gradient force + !--------------------------------------------------------------- + ! Notes on the algorithm/code: + ! This code requires computing velocities at bounding h points + ! of the u/v points to get the pressure-gradient. In this + ! implementation there are several redundant calculations as the + ! left/right points are computed at each cell while integrating + ! in the vertical, requiring about twice the calculations. The + ! velocities at the tracer points could be precomputed and + ! stored, but this would require more memory and cycling through + ! large 3d arrays while computing the pressures. This could be + ! explored as a way to speed up this code. + !--------------------------------------------------------------- + + PFu_Stokes(:,:,:) = 0.0 + PFv_Stokes(:,:,:) = 0.0 + if (CS%id_P_deltaStokes_i > 0) P_deltaStokes_i(:,:,:) = 0.0 + if (CS%id_P_deltaStokes_L > 0) P_deltaStokes_L(:,:,:) = 0.0 + + ! First compute PGFu. The Stokes-induced pressure anomaly diagnostic is stored from this calculation. + ! > Seeking PGFx at (I,j), meaning we need to compute pressure at h-points (i,j) and (i+1,j). + ! UL(i,j) -> found as average of I-1 & I on j + ! UR(i+1,j) -> found as average of I & I+1 on j + ! VL(i,j) -> found on i as average of J-1 & J + ! VR(i+1,j) -> found on i+1 as average of J-1 & J + ! + do j = G%jsc, G%jec ; do I = G%iscB, G%iecB + if (G%mask2dCu(I,j)>0.5) then + P_Stokes_l0 = 0.0 + P_Stokes_r0 = 0.0 + ! We don't need to precompute the grid in physical space arrays and could have done this during + ! the next loop, but this gives flexibility if the loop directions (integrations) are performed + ! upwards instead of downwards (it seems downwards is the better approach). + zi_l(1) = 0.0 + zi_r(1) = 0.0 + do k = 1, G%ke + h_l = dz(i,j,k) + h_r = dz(i+1,j,k) + zi_l(k+1) = zi_l(k) - h_l + zi_r(k+1) = zi_r(k) - h_r + !### If the code were properly refactored, the following hard-coded constants would be unnecessary. + Idz_l(k) = 1./max(0.1*US%m_to_Z, h_l) + Idz_r(k) = 1./max(0.1*US%m_to_Z, h_r) + enddo + do k = 1,G%ke + ! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the + ! Lagrangian velocity. This requires the wave acceleration terms to be activated together. + uE_l = 0.5*((u(I-1,j,k)-CS%Us_x(I-1,j,k))*G%mask2dCu(I-1,j) + & + (u(I,j,k)-CS%Us_x(I-1,j,k))*G%mask2dCu(I,j)) + uE_r = 0.5*((u(I,j,k)-CS%Us_x(I,j,k))*G%mask2dCu(I,j) + & + (u(I+1,j,k)-CS%Us_x(I+1,j,k))*G%mask2dCu(I+1,j)) + vE_l = 0.5*((v(i,J-1,k)-CS%Us_y(i,J-1,k))*G%mask2dCv(i,J-1) + & + (v(i,J,k)-CS%Us_y(i,J,k))*G%mask2dCv(i,J)) + vE_r = 0.5*((v(i+1,J-1,k)-CS%Us_y(i+1,J-1,k))*G%mask2dCv(i+1,J-1) + & + (v(i+1,J,k)-CS%Us_y(i+1,J,k))*G%mask2dCv(i+1,J)) + + dP_Stokes_l_dz = 0.0 + dP_Stokes_r_dz = 0.0 + dP_Stokes_l = 0.0 + dP_Stokes_r = 0.0 + + do l = 1, CS%numbands + + ! Computing (left/right) surface Stokes drift velocities at wavenumber band + uS0_l = 0.5*(CS%Stkx0(I-1,j,l)*G%mask2dCu(I-1,j) + & + CS%Stkx0(I,j,l)*G%mask2dCu(I,j)) + uS0_r = 0.5*(CS%Stkx0(I,j,l)*G%mask2dCu(I,j) + & + CS%Stkx0(I+1,j,l)*G%mask2dCu(I+1,j)) + vS0_l = 0.5*(CS%Stky0(i,J-1,l)*G%mask2dCv(i,J-1) + & + CS%Stky0(i,J,l)*G%mask2dCv(i,J)) + vS0_r = 0.5*(CS%Stky0(i+1,J-1,l)*G%mask2dCv(i+1,J-1) + & + CS%Stky0(i+1,J,l)*G%mask2dCv(i+1,J)) + + ! Wavenumber terms that are useful to simplify the pressure calculations + TwoK = 2.*CS%WaveNum_Cen(l) + FourK = 2.*TwoK + iTwoK = 1./TwoK + iFourK = 1./(FourK) + dexp2kzL = exp(TwoK*zi_l(k))-exp(TwoK*zi_l(k+1)) + dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1)) + dexp4kzL = exp(FourK*zi_l(k))-exp(FourK*zi_l(k+1)) + dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1)) + + ! Compute Pressure at interface and integrated over layer on left/right bounding points. + ! These are summed over wavenumber bands. + if (G%mask2dT(i,j)>0.5) then + dP_Stokes_l_dz = dP_Stokes_l_dz + & + ((uE_l*uS0_l+vE_l*vS0_l)*iTwoK*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzL) + dP_Stokes_l = dP_Stokes_l + (uE_l*uS0_l+vE_l*vS0_l)*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzL + endif + if (G%mask2dT(i+1,j)>0.5) then + dP_Stokes_r_dz = dP_Stokes_r_dz + & + ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzR) + dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzR + endif + enddo + + ! Summing PF over bands + ! > Increment the Layer averaged pressure + P_Stokes_l = P_Stokes_l0 + dP_Stokes_l_dz*Idz_l(k) + P_Stokes_r = P_Stokes_r0 + dP_Stokes_r_dz*Idz_r(k) + ! > Increment the Interface pressure + P_Stokes_l0 = P_Stokes_l0 + dP_Stokes_l + P_Stokes_r0 = P_Stokes_r0 + dP_Stokes_r + + ! Pressure force anomaly is finite difference across the cell. + PFu_Stokes(I,j,k) = (P_Stokes_r - P_Stokes_l)*G%IdxCu(I,j) + + ! Choose to output the pressure delta on the h-points from the PFu calculation. + if (G%mask2dT(i,j)>0.5 .and. CS%id_P_deltaStokes_L > 0) P_deltaStokes_L(i,j,k) = P_Stokes_l + if (G%mask2dT(i,j)>0.5 .and. CS%id_P_deltaStokes_i > 0) P_deltaStokes_i(i,j,k+1) = P_Stokes_l0 + + enddo + endif + enddo ; enddo + + ! Next compute PGFv. The Stokes-induced pressure anomaly diagnostic is stored from this calculation. + ! > Seeking PGFy at (i,J), meaning we need to compute pressure at h-points (i,j) and (i,j+1). + ! UL(i,j) -> found as average of I-1 & I on j + ! UR(i,j+1) -> found as average of I-1 & I on j+1 + ! VL(i,j) -> found on i as average of J-1 & J + ! VR(i,j+1) -> found on i as average of J & J+1 + ! + do J = G%jscB, G%jecB ; do i = G%isc, G%iec + if (G%mask2dCv(i,J)>0.5) then + P_Stokes_l0 = 0.0 + P_Stokes_r0 = 0.0 + zi_l(1) = 0.0 + zi_r(1) = 0.0 + do k = 1, G%ke + h_l = dz(i,j,k) + h_r = dz(i,j+1,k) + zi_l(k+1) = zi_l(k) - h_l + zi_r(k+1) = zi_r(k) - h_r + !### If the code were properly refactored, the following hard-coded constants would be unnecessary. + Idz_l(k) = 1. / max(0.1*US%m_to_Z, h_l) + Idz_r(k) = 1. / max(0.1*US%m_to_Z, h_r) + enddo + do k = 1,G%ke + ! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the + ! Lagrangian velocity. This requires the wave acceleration terms to be activated together. + uE_l = 0.5*((u(I-1,j,k)-CS%Us_x(I-1,j,k))*G%mask2dCu(I-1,j) + & + (u(I,j,k)-CS%Us_x(I,j,k))*G%mask2dCu(I,j)) + uE_r = 0.5*((u(I-1,j+1,k)-CS%Us_x(I-1,j+1,k))*G%mask2dCu(I-1,j+1) + & + (u(I,j+1,k)-CS%Us_x(I,j+1,k))*G%mask2dCu(I,j+1)) + vE_l = 0.5*((v(i,J-1,k)-CS%Us_y(i,J-1,k))*G%mask2dCv(i,J-1) + & + (v(i,J,k)-CS%Us_y(i,J,k))*G%mask2dCv(i,J)) + vE_r = 0.5*((v(i,J,k)-CS%Us_y(i,J,k))*G%mask2dCv(i,J) + & + (v(i,J+1,k)-CS%Us_y(i,J+1,k))*G%mask2dCv(i,J+1)) + + dP_Stokes_l_dz = 0.0 + dP_Stokes_r_dz = 0.0 + dP_Stokes_l = 0.0 + dP_Stokes_r = 0.0 + + do l = 1, CS%numbands + + ! Computing (left/right) surface Stokes drift velocities at wavenumber band + uS0_l = 0.5*(CS%Stkx0(I-1,j,l)*G%mask2dCu(I-1,j) + & + CS%Stkx0(I,j,l)*G%mask2dCu(I,j)) + uS0_r = 0.5*(CS%Stkx0(I-1,j+1,l)*G%mask2dCu(I-1,j+1) + & + CS%Stkx0(I,j+1,l)*G%mask2dCu(I,j+1)) + vS0_l = 0.5*(CS%Stky0(i,J-1,l)*G%mask2dCv(i,J-1) + & + CS%Stky0(i,J,l)*G%mask2dCv(i,J)) + vS0_r = 0.5*(CS%Stky0(i,J,l)*G%mask2dCv(i,J) + & + CS%Stky0(i,J+1,l)*G%mask2dCv(i,J+1)) + + ! Wavenumber terms that are useful to simplify the pressure calculations + TwoK = 2.*CS%WaveNum_Cen(l) + FourK = 2.*TwoK + iTwoK = 1./TwoK + iFourK = 1./(FourK) + dexp2kzL = exp(TwoK*zi_l(k))-exp(TwoK*zi_l(k+1)) + dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1)) + dexp4kzL = exp(FourK*zi_l(k))-exp(FourK*zi_l(k+1)) + dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1)) + + ! Compute Pressure at interface and integrated over layer on left/right bounding points. + ! These are summed over wavenumber bands. + if (G%mask2dT(i,j)>0.5) then + dP_Stokes_l_dz = dP_Stokes_l_dz + & + ((uE_l*uS0_l+vE_l*vS0_l)*iTwoK*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzL) + dP_Stokes_l = dP_Stokes_l + (uE_l*uS0_l+vE_l*vS0_l)*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzL + endif + if (G%mask2dT(i,j+1)>0.5) then + dP_Stokes_r_dz = dP_Stokes_r_dz + & + ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzR) + dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzR + endif + enddo + + ! Summing PF over bands + ! > Increment the Layer averaged pressure + P_Stokes_l = P_Stokes_l0 + dP_Stokes_l_dz*Idz_l(k) + P_Stokes_r = P_Stokes_r0 + dP_Stokes_r_dz*Idz_r(k) + ! > Increment the Interface pressure + P_Stokes_l0 = P_Stokes_l0 + dP_Stokes_l + P_Stokes_r0 = P_Stokes_r0 + dP_Stokes_r + + ! Pressure force anomaly is finite difference across the cell. + PFv_Stokes(I,j,k) = (P_Stokes_r - P_Stokes_l)*G%IdyCv(i,J) + + enddo + endif + enddo ; enddo + + if (CS%id_PFv_Stokes>0) & + call post_data(CS%id_PFv_Stokes, PFv_Stokes, CS%diag) + if (CS%id_PFu_Stokes>0) & + call post_data(CS%id_PFu_Stokes, PFu_Stokes, CS%diag) + if (CS%id_P_deltaStokes_L>0) & + call post_data(CS%id_P_deltaStokes_L, P_deltaStokes_L, CS%diag) + if (CS%id_P_deltaStokes_i>0) & + call post_data(CS%id_P_deltaStokes_i, P_deltaStokes_i, CS%diag) + +end subroutine Stokes_PGF + + +!> Computes wind speed from ustar_air based on COARE 3.5 Cd relationship +!! Probably doesn't belong in this module, but it is used here to estimate +!! wind speed for wind-wave relationships. Should be a fine way to estimate +!! the neutral wind-speed as written here. +subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) + real, intent(in) :: USTair !< Wind friction velocity [Z T-1 ~> m s-1] + real, intent(out) :: U10 !< 10-m neutral wind speed [L T-1 ~> m s-1] + type(verticalGrid_type), intent(in) :: GV !< vertical grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + + ! Local variables + real :: z0sm, z0, z0rough ! Roughness lengths [Z ~> m] + real :: ten_m_scale ! The 10 m reference height, in rescaled units [Z ~> m] + real :: I_ten_m_scale ! The inverse of the 10 m reference height, in rescaled units [Z-1 ~> m-1] + real :: u10a ! The previous guess for u10 [L T-1 ~> m s-1] + real :: alpha ! The Charnock coeffient relating the wind friction velocity squared to the + ! roughness length [nondim] + real :: Cd ! The drag coefficient [nondim] + real :: I_sqrtCd ! The inverse of the square root of the drag coefficient [nondim] + real :: I_vonKar ! The inverse of the von Karman coefficient [nondim] + integer :: CT + + ! Uses empirical formula for z0 to convert ustar_air to u10 based on the + ! COARE 3.5 paper (Edson et al., 2013) + ! alpha=m*U10+b + ! Note in Edson et al. 2013, eq. 13 m is given as 0.017. However, + ! m=0.0017 reproduces the curve in their figure 6. + + if (CS%vonKar < 0.0) call MOM_error(FATAL, & + "ust_2_u10_coare3p5 called with a negative value of Waves%vonKar") + + z0sm = 0.11 * CS%nu_air / USTair ! Compute z0smooth from ustar guess + u10a = 1000.0*US%m_s_to_L_T ! An insanely large upper bound for u10. + + if (CS%answer_date < 20230103) then + u10 = US%Z_to_L*USTair / sqrt(0.001) ! Guess for u10 + ten_m_scale = 10.0*US%m_to_Z + CT=0 + do while (abs(u10a/u10 - 1.) > 0.001) + CT=CT+1 + u10a = u10 + alpha = min(CS%Charnock_min, CS%Charnock_slope_U10 * u10 + CS%Charnock_intercept) + z0rough = alpha * (US%Z_to_L*USTair)**2 / GV%g_Earth ! Compute z0rough from ustar guess + z0 = z0sm + z0rough + Cd = ( CS%vonKar / log(ten_m_scale / z0) )**2 ! Compute Cd from derived roughness + u10 = US%Z_to_L*USTair/sqrt(Cd) ! Compute new u10 from derived Cd, while loop + ! ends and checks for convergence...CT counter + ! makes sure loop doesn't run away if function + ! doesn't converge. This code was produced offline + ! and converged rapidly (e.g. 2 cycles) + ! for ustar=0.0001:0.0001:10. + if (CT>20) then + u10 = US%Z_to_L*USTair/sqrt(0.0015) ! I don't expect to get here, but just + ! in case it will output a reasonable value. + exit + endif + enddo + + else ! Use more efficient expressions that are mathematically equivalent to those above. + u10 = US%Z_to_L*USTair * sqrt(1000.0) ! First guess for u10. + ! In the line above 1000 is the inverse of a plausible first guess of the drag coefficient. + I_vonKar = 1.0 / CS%vonKar + I_ten_m_scale = 0.1*US%Z_to_m + + do CT=1,20 + if (abs(u10a - u10) <= 0.001*u10) exit ! Check for convergence. + u10a = u10 + alpha = min(CS%Charnock_min, CS%Charnock_slope_U10 * u10 + CS%Charnock_intercept) + z0rough = alpha * (CS%I_g_Earth * USTair**2) ! Compute z0rough from ustar guess + z0 = z0sm + z0rough + I_sqrtCd = abs(log(z0 * I_ten_m_scale)) * I_vonKar ! Compute Cd from derived roughness + u10 = US%Z_to_L*USTair * I_sqrtCd ! Compute new u10 from the derived Cd. + enddo + + ! Output a reasonable estimate of u10 if the iteration has not converged. The hard-coded + ! number 25.82 is 1/sqrt(0.0015) to 4 decimal places, but the exact value should not matter. + if (abs(u10a - u10) > 0.001*u10) u10 = US%Z_to_L*USTair * 25.82 + endif + +end subroutine ust_2_u10_coare3p5 + +!> Clear pointers, deallocate memory +subroutine Waves_end(CS) + type(wave_parameters_CS), pointer :: CS !< Control structure + + if (allocated(CS%WaveNum_Cen)) deallocate( CS%WaveNum_Cen ) + if (allocated(CS%Freq_Cen)) deallocate( CS%Freq_Cen ) + if (allocated(CS%Us_x)) deallocate( CS%Us_x ) + if (allocated(CS%Us_y)) deallocate( CS%Us_y ) + if (allocated(CS%La_turb)) deallocate( CS%La_turb ) + if (allocated(CS%STKx0)) deallocate( CS%STKx0 ) + if (allocated(CS%STKy0)) deallocate( CS%STKy0 ) + if (allocated(CS%UStk_Hb)) deallocate( CS%UStk_Hb ) + if (allocated(CS%VStk_Hb)) deallocate( CS%VStk_Hb ) + if (allocated(CS%Omega_w2x)) deallocate( CS%Omega_w2x ) + if (allocated(CS%KvS)) deallocate( CS%KvS ) + if (allocated(CS%Us0_y)) deallocate( CS%Us0_y ) + if (allocated(CS%Us0_x)) deallocate( CS%Us0_x ) + + deallocate( CS ) + +end subroutine Waves_end + +!> Register wave restart fields. To be called before MOM_wave_interface_init +subroutine waves_register_restarts(CS, HI, GV, US, param_file, restart_CSp) + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + type(hor_index_type), intent(inout) :: HI !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Input parameter structure + type(MOM_restart_CS), pointer :: restart_CSp !< Restart structure, data intent(inout) + ! Local variables + type(vardesc) :: vd(2) + logical :: use_waves + logical :: StatisticalWaves + logical :: time_tendency_term + character(len=40) :: mdl = "MOM_wave_interface" !< This module's name. + + if (associated(CS)) then + call MOM_error(FATAL, "waves_register_restarts: Called with initialized waves control structure") + endif + allocate(CS) + + call get_param(param_file, mdl, "USE_WAVES", use_waves, & + "If true, enables surface wave modules.", do_not_log=.true., default=.false.) + + ! Check if using LA_LI2016 + call get_param(param_file,mdl,"USE_LA_LI2016",StatisticalWaves, & + do_not_log=.true.,default=.false.) + + if (.not.(use_waves .or. StatisticalWaves)) return + + call get_param(param_file, mdl, "STOKES_DDT", time_tendency_term, do_not_log=.true., default=.false.) + + if (time_tendency_term) then + ! Allocate wave fields needed for restart file + allocate(CS%Us_x_prev(HI%isdB:HI%IedB,HI%jsd:HI%jed,GV%ke), source=0.0) + allocate(CS%Us_y_prev(HI%isd:HI%Ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) + + ! Register to restart files. If these are not found in a restart file, they stay 0. + vd(1) = var_desc("Us_x_prev", "m s-1", "3d zonal Stokes drift profile",& + hor_grid='u', z_grid='L') + vd(2) = var_desc("Us_y_prev", "m s-1", "3d meridional Stokes drift profile",& + hor_grid='v', z_grid='L') + call register_restart_pair(CS%US_x_prev, CS%US_y_prev, vd(1), vd(2), .false., & + restart_CSp, conversion=US%L_T_to_m_s) + endif + +end subroutine waves_register_restarts + +!> \namespace mom_wave_interface +!! +!! \author Brandon Reichl, 2018. +!! +!! This module should be moved as wave coupling progresses and +!! likely will should mirror the iceberg or sea-ice model set-up. +!! +!! This module is meant to contain the routines to read in and +!! interpret surface wave data for MOM6. In its original form, the +!! capabilities include setting the Stokes drift in the model (from a +!! variety of sources including prescribed, empirical, and input +!! files). In short order, the plan is to also amend the subroutine +!! to accept Stokes drift information from an external coupler. +!! Eventually, it will be necessary to break this file apart so that +!! general wave information may be stored in the control structure +!! and the Stokes drift effect can be isolated from processes such as +!! sea-state dependent momentum fluxes, gas fluxes, and other wave +!! related air-sea interaction and boundary layer phenomenon. +!! +!! The Stokes drift are stored on the C-grid with the conventional +!! protocol to interpolate to the h-grid to compute Langmuir number, +!! the primary quantity needed for Langmuir turbulence +!! parameterizations in both the ePBL and KPP approach. This module +!! also computes full 3d Stokes drift profiles, which will be useful +!! if second-order type boundary layer parameterizations are +!! implemented (perhaps via GOTM, work in progress). + +end module MOM_wave_interface diff --git a/user/Neverworld_initialization.F90 b/user/Neverworld_initialization.F90 new file mode 100644 index 0000000000..05de663d46 --- /dev/null +++ b/user/Neverworld_initialization.F90 @@ -0,0 +1,313 @@ +!> Initialization for the "Neverworld" configuration +module Neverworld_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +use random_numbers_mod, only: initializeRandomNumberStream, getRandomNumbers, randomNumberStream + +implicit none ; private + +#include + +public Neverworld_initialize_topography +public Neverworld_initialize_thickness + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> This subroutine sets up the Neverworld test case topography. +subroutine Neverworld_initialize_topography(D, G, param_file, max_depth) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth in the units of depth_max + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + + ! Local variables + real :: PI ! 3.1415926... calculated as 4*atan(1) + real :: x, y ! Lateral positions normalized by the domain size [nondim] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "Neverworld_initialize_topography" ! This subroutine's name. + real :: nl_top_amp ! Amplitude of large-scale topographic features as a fraction of the maximum depth [nondim] + real :: nl_roughness_amp ! Amplitude of topographic roughness as a fraction of the maximum depth [nondim] + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + call MOM_mesg(" Neverworld_initialization.F90, Neverworld_initialize_topography: setting topography", 5) + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "NL_ROUGHNESS_AMP", nl_roughness_amp, & + "Amplitude of wavy signal in bathymetry.", units="nondim", default=0.05) + call get_param(param_file, mdl, "NL_CONTINENT_AMP", nl_top_amp, & + "Scale factor for topography - 0.0 for no continents.", units="nondim", default=1.0) + + PI = 4.0*atan(1.0) + +! Calculate the depth of the bottom. + do j=js,je ; do i=is,ie + x = (G%geoLonT(i,j)-G%west_lon) / G%len_lon + y = (G%geoLatT(i,j)-G%south_lat) / G%len_lat +! This sets topography that has a reentrant channel to the south. + D(i,j) = 1.0 - 1.1 * spike(y-1,0.12) - 1.1 * spike(y,0.12) - & !< The great northern wall and Antarctica + nl_top_amp*( & + (1.2 * spike(x,0.2) + 1.2 * spike(x-1.0,0.2)) * spike(MIN(0.0,y-0.3),0.2) & !< South America + + 1.2 * spike(x-0.5,0.2) * spike(MIN(0.0,y-0.55),0.2) & !< Africa + + 1.2 * (spike(x,0.12) + spike(x-1,0.12)) * spike(MAX(0.0,y-0.06),0.12) & !< Antarctic Peninsula + + 0.1 * (cosbell(x,0.1) + cosbell(x-1,0.1)) & !< Drake Passage ridge + + 0.5 * cosbell(x-0.16,0.05) * (cosbell(y-0.18,0.13)**0.4) & !< Scotia Arc East + + 0.4 * (cosbell(x-0.09,0.08)**0.4) * cosbell(y-0.26,0.05) & !< Scotia Arc North + + 0.4 * (cosbell(x-0.08,0.08)**0.4) * cosbell(y-0.1,0.05)) & !< Scotia Arc South + - nl_roughness_amp * cos(14*PI*x) * sin(14*PI*y) & !< roughness + - nl_roughness_amp * cos(20*PI*x) * cos(20*PI*y) !< roughness + if (D(i,j) < 0.0) D(i,j) = 0.0 + D(i,j) = D(i,j) * max_depth + enddo ; enddo + +end subroutine Neverworld_initialize_topography + +!> Returns the value of a cosine-bell function evaluated at x/L +real function cosbell(x, L) + real , intent(in) :: x !< non-dimensional position [nondim] + real , intent(in) :: L !< non-dimensional width [nondim] + real :: PI !< 3.1415926... calculated as 4*atan(1) + + PI = 4.0*atan(1.0) + cosbell = 0.5 * (1 + cos(PI*MIN(ABS(x/L),1.0))) +end function cosbell + +!> Returns the value of a sin-spike function evaluated at x/L +real function spike(x, L) + + real , intent(in) :: x !< non-dimensional position [nondim] + real , intent(in) :: L !< non-dimensional width [nondim] + real :: PI !< 3.1415926... calculated as 4*atan(1) + + PI = 4.0*atan(1.0) + spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) +end function spike + +!> Returns the value of a triangular function centered at x=x0 with value 1 +!! and linearly decreasing to 0 at x=x0+/-L, and 0 otherwise. +!! If clip is present the top of the cone is cut off at "clip", which +!! effectively defaults to 1. +real function cone(x, x0, L, clip) + real, intent(in) :: x !< non-dimensional coordinate [nondim] + real, intent(in) :: x0 !< position of peak [nondim] + real, intent(in) :: L !< half-width of base of cone [nondim] + real, optional, intent(in) :: clip !< clipping height of cone [nondim] + + cone = max( 0., 1. - abs(x - x0) / L ) + if (present(clip)) cone = min(clip, cone) +end function cone + +!> Returns an s-curve s(x) s.t. s(x0)<=0, s(x0+L)>=1 and cubic in between. +real function scurve(x, x0, L) + real, intent(in) :: x !< non-dimensional coordinate [nondim] + real, intent(in) :: x0 !< position of peak [nondim] + real, intent(in) :: L !< half-width of base of cone [nondim] + real :: s + + s = max( 0., min( 1.,( x - x0 ) / L ) ) + scurve = ( 3. - 2.*s ) * ( s * s ) +end function scurve + +! None of the following 7 functions appear to be used. + +!> Returns a "coastal" profile. +real function cstprof(x, x0, L, lf, bf, sf, sh) + real, intent(in) :: x !< non-dimensional coordinate [nondim] + real, intent(in) :: x0 !< position of peak [nondim] + real, intent(in) :: L !< width of profile [nondim] + real, intent(in) :: lf !< fraction of width that is "land" [nondim] + real, intent(in) :: bf !< fraction of width that is "beach" [nondim] + real, intent(in) :: sf !< fraction of width that is "continental slope" [nondim] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: s + + s = max( 0., min( 1.,( x - x0 ) / L ) ) + cstprof = sh * scurve(s-lf,0.,bf) + (1.-sh) * scurve(s - (1.-sf),0.,sf) +end function cstprof + +!> Distance between points x,y and a line segment (x0,y0) and (x0,y1). +real function dist_line_fixed_x(x, y, x0, y0, y1) + real, intent(in) :: x !< non-dimensional x-coordinate [nondim] + real, intent(in) :: y !< non-dimensional y-coordinate [nondim] + real, intent(in) :: x0 !< x-position of line segment [nondim] + real, intent(in) :: y0 !< y-position of line segment end[nondim] + real, intent(in) :: y1 !< y-position of line segment end[nondim] + real :: dx, yr, dy + + dx = x - x0 + yr = min( max(y0,y1), max( min(y0,y1), y ) ) ! bound y by y0,y1 + dy = y - yr ! =0 within y0y1 + dist_line_fixed_x = sqrt( dx*dx + dy*dy ) +end function dist_line_fixed_x + +!> Distance between points x,y and a line segment (x0,y0) and (x1,y0). +real function dist_line_fixed_y(x, y, x0, x1, y0) + real, intent(in) :: x !< non-dimensional x-coordinate [nondim] + real, intent(in) :: y !< non-dimensional y-coordinate [nondim] + real, intent(in) :: x0 !< x-position of line segment end[nondim] + real, intent(in) :: x1 !< x-position of line segment end[nondim] + real, intent(in) :: y0 !< y-position of line segment [nondim] + + dist_line_fixed_y = dist_line_fixed_x(y, x, y0, x0, x1) +end function dist_line_fixed_y + +!> A "coast profile" applied in an N-S line from lon0,lat0 to lon0,lat1. +real function NS_coast(lon, lat, lon0, lat0, lat1, dlon, sh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon0 !< Longitude of coast [degrees_E] + real, intent(in) :: lat0 !< Latitude of coast end [degrees_N] + real, intent(in) :: lat1 !< Latitude of coast end [degrees_N] + real, intent(in) :: dlon !< "Radius" of coast profile [degrees] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_x( lon, lat, lon0, lat0, lat1 ) + NS_coast = cstprof(r, 0., dlon, 0.125, 0.125, 0.5, sh) +end function NS_coast + +!> A "coast profile" applied in an E-W line from lon0,lat0 to lon1,lat0. +real function EW_coast(lon, lat, lon0, lon1, lat0, dlat, sh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon0 !< Longitude of coast end [degrees_E] + real, intent(in) :: lon1 !< Longitude of coast end [degrees_E] + real, intent(in) :: lat0 !< Latitude of coast [degrees_N] + real, intent(in) :: dlat !< "Radius" of coast profile [degrees] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_y( lon, lat, lon0, lon1, lat0 ) + EW_coast = cstprof(r, 0., dlat, 0.125, 0.125, 0.5, sh) +end function EW_coast + +!> A NS ridge +real function NS_ridge(lon, lat, lon0, lat0, lat1, dlon, rh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon0 !< Longitude of ridge center [degrees_E] + real, intent(in) :: lat0 !< Latitude of ridge end [degrees_N] + real, intent(in) :: lat1 !< Latitude of ridge end [degrees_N] + real, intent(in) :: dlon !< "Radius" of ridge profile [degrees] + real, intent(in) :: rh !< depth of ridge as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_x( lon, lat, lon0, lat0, lat1 ) + NS_ridge = 1. - rh * cone(r, 0., dlon) +end function NS_ridge + + +!> A circular ridge +real function circ_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridge_height) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon0 !< Longitude of center of ring [degrees_E] + real, intent(in) :: lat0 !< Latitude of center of ring [degrees_N] + real, intent(in) :: ring_radius !< Radius of ring [degrees] + real, intent(in) :: ring_thickness !< Radial thickness of ring [degrees] + real, intent(in) :: ridge_height !< Ridge height as fraction of full depth [nondim] + real :: r + + r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point + r = abs( r - ring_radius) ! Pseudo-distance from a circle + r = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height + circ_ridge = 1. - r ! Fractional depths (1-frac_ridge_height) .. 1 +end function circ_ridge + +!> This subroutine initializes layer thicknesses for the Neverworld test case, +!! by finding the depths of interfaces in a specified latitude-dependent +!! temperature profile with an exponentially decaying thermocline on top of a +!! linear stratification. +subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file, P_ref) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< The thickness that is being + !! initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open + !! file to parse for model + !! parameter values. + real, intent(in) :: P_Ref !< The coordinate-density + !! reference pressure [R L2 T-2 ~> Pa]. + ! Local variables + real :: e0(SZK_(GV)+1) ! The resting interface heights, in depth units [Z ~> m], + ! usually negative because it is positive upward. + real, dimension(SZK_(GV)) :: h_profile ! Vector of initial thickness profile [Z ~> m]. + real :: e_interface ! Current interface position [Z ~> m]. + real :: x, y ! horizontal coordinates for computation of the initial perturbation normalized + ! by the domain sizes [nondim] + real :: r1, r2 ! radial coordinates for computation of initial perturbation, normalized + ! by the domain sizes [nondim] + real :: pert_amp ! Amplitude of perturbations as a fraction of layer thicknesses [nondim] + real :: h_noise ! Amplitude of noise to scale h by [nondim] + real :: noise ! Fractional noise in the layer thicknesses [nondim] + type(randomNumberStream) :: rns ! Random numbers for stochastic tidal parameterization + character(len=40) :: mdl = "Neverworld_initialize_thickness" ! This subroutine's name. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call MOM_mesg(" Neverworld_initialization.F90, Neverworld_initialize_thickness: setting thickness", 5) + call get_param(param_file, mdl, "INIT_THICKNESS_PROFILE", h_profile, & + "Profile of initial layer thicknesses.", units="m", scale=US%m_to_Z, & + fail_if_missing=.true.) + call get_param(param_file, mdl, "NL_THICKNESS_PERT_AMP", pert_amp, & + "Amplitude of finite scale perturbations as fraction of depth.", & + units="nondim", default=0.) + call get_param(param_file, mdl, "NL_THICKNESS_NOISE_AMP", h_noise, & + "Amplitude of noise to scale layer by.", units="nondim", default=0.) + + ! e0 is the notional position of interfaces + e0(1) = 0. ! The surface + do k=1,nz + e0(k+1) = e0(k) - h_profile(k) + enddo + + do j=js,je ; do i=is,ie + e_interface = -depth_tot(i,j) + do k=nz,2,-1 + h(i,j,k) = e0(k) - e_interface ! Nominal thickness + x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon + y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat + r1 = sqrt((x-0.7)**2+(y-0.2)**2) + r2 = sqrt((x-0.3)**2+(y-0.25)**2) + h(i,j,k) = h(i,j,k) + pert_amp * (e0(k) - e0(nz+1)) * & + (spike(r1,0.15)-spike(r2,0.15)) ! Prescribed perturbation + if (h_noise /= 0.) then + rns = initializeRandomNumberStream( int( 4096*(x + (y+1.)) ) ) + call getRandomNumbers(rns, noise) ! x will be in (0,1) + noise = h_noise * 2. * ( noise - 0.5 ) ! range -h_noise to h_noise + h(i,j,k) = ( 1. + noise ) * h(i,j,k) + endif + h(i,j,k) = max( GV%Angstrom_Z, h(i,j,k) ) ! Limit to non-negative + e_interface = e_interface + h(i,j,k) ! Actual position of upper interface + enddo + h(i,j,1) = e0(1) - e_interface ! Nominal thickness + h(i,j,1) = max( GV%Angstrom_Z, h(i,j,1) ) ! Limit to non-negative + enddo ; enddo + +end subroutine Neverworld_initialize_thickness + +end module Neverworld_initialization diff --git a/user/Phillips_initialization.F90 b/user/Phillips_initialization.F90 new file mode 100644 index 0000000000..e0d2cafeae --- /dev/null +++ b/user/Phillips_initialization.F90 @@ -0,0 +1,409 @@ +!> Initialization for the "Phillips" channel configuration +module Phillips_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public Phillips_initialize_thickness +public Phillips_initialize_velocity +public Phillips_initialize_sponges +public Phillips_initialize_topography + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +! This include declares and sets the variable "version". +#include "version_variable.h" + +contains + +!> Initialize the thickness field for the Phillips model test case. +subroutine Phillips_initialize_thickness(h, depth_tot, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + + real :: eta0(SZK_(GV)+1) ! The 1-d nominal positions of the interfaces [Z ~> m] + real :: eta_im(SZJ_(G),SZK_(GV)+1) ! A temporary array for zonal-mean eta [Z ~> m] + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m] + real :: jet_width ! The width of the zonal-mean jet [km] + real :: jet_height ! The interface height scale associated with the zonal-mean jet [Z ~> m] + real :: y_2 ! The y-position relative to the center of the domain [km] + real :: half_strat ! The fractional depth where the stratification is centered [nondim] + real :: half_depth ! The depth where the stratification is centered [Z ~> m] + logical :: reentrant_y ! If true, model is re-entrant in the y direction + character(len=40) :: mdl = "Phillips_initialize_thickness" ! This subroutine's name. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + real :: pi ! The ratio of the circumference of a circle to its diameter [nondim] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + eta_im(:,:) = 0.0 + + if (.not.just_read) call log_version(param_file, mdl, version) + call get_param(param_file, mdl, "HALF_STRAT_DEPTH", half_strat, & + "The fractional depth where the stratification is centered.", & + units="nondim", default=0.5, do_not_log=just_read) + call get_param(param_file, mdl, "JET_WIDTH", jet_width, & + "The width of the zonal-mean jet.", units="km", & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & + "The interface height scale associated with the "//& + "zonal-mean jet.", units="m", scale=US%m_to_Z, & + fail_if_missing=.not.just_read, do_not_log=just_read) + ! If re-entrant in the Y direction, we use a sine function instead of a + ! tanh. The ratio len_lat/jet_width should be an integer in this case. + call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & + default=.false., do_not_log=.true.) + + if (just_read) return ! All run-time parameters have been read, so return. + + half_depth = G%max_depth*half_strat + eta0(1) = 0.0 ; eta0(nz+1) = -G%max_depth + do k=2,1+nz/2 ; eta0(k) = -half_depth*(2.0*(k-1)/real(nz)) ; enddo + do k=2+nz/2,nz+1 + eta0(k) = -G%max_depth - 2.0*(G%max_depth-half_depth) * ((k-(nz+1))/real(nz)) + enddo + pi = 4.0*atan(1.0) + + do j=js,je + eta_im(j,1) = 0.0 ; eta_im(j,nz+1) = -G%max_depth + enddo + do K=2,nz ; do j=js,je + y_2 = G%geoLatT(is,j) - G%south_lat - 0.5*G%len_lat + eta_im(j,K) = eta0(k) + jet_height * tanh(y_2 / jet_width) + ! or ... + jet_height * atan(y_2 / jet_width) + if (reentrant_y) then + y_2 = 2.*pi*y_2 + eta_im(j,K) = eta0(k) + jet_height * sin(y_2 / jet_width) + endif + if (eta_im(j,K) > 0.0) eta_im(j,K) = 0.0 + if (eta_im(j,K) < -G%max_depth) eta_im(j,K) = -G%max_depth + enddo ; enddo + + do j=js,je ; do i=is,ie + ! This sets the initial thickness in [H ~> m or kg m-2] of the layers. The + ! thicknesses are set to insure that: 1. each layer is at least an Angstrom thick, and + ! 2. the interfaces are where they should be based on the resting depths and interface + ! height perturbations, as long at this doesn't interfere with 1. + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(K) = eta_im(j,K) + if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then + eta1D(K) = eta1D(K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z + else + h(i,j,k) = eta1D(K) - eta1D(K+1) + endif + enddo + enddo ; enddo + +end subroutine Phillips_initialize_thickness + +!> Initialize the velocity fields for the Phillips model test case +subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: u !< i-component of velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: v !< j-component of velocity [L T-1 ~> m s-1] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to + !! parse for modelparameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing u & v. + + real :: jet_width ! The width of the zonal-mean jet [km] + real :: jet_height ! The interface height scale associated with the zonal-mean jet [Z ~> m] + real :: x_2 ! The x-position relative to the center of the domain [nondim] + real :: y_2 ! The y-position relative to the center of the domain [km] or [nondim] + real :: velocity_amplitude ! The amplitude of velocity perturbations [L T-1 ~> m s-1] + real :: pi ! The ratio of the circumference of a circle to its diameter [nondim] + integer :: i, j, k, is, ie, js, je, nz, m + logical :: reentrant_y ! If true, model is re-entrant in the y direction + character(len=40) :: mdl = "Phillips_initialize_velocity" ! This subroutine's name. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) call log_version(param_file, mdl, version) + call get_param(param_file, mdl, "VELOCITY_IC_PERTURB_AMP", velocity_amplitude, & + "The magnitude of the initial velocity perturbation.", & + units="m s-1", default=0.001, scale=US%m_s_to_L_T, do_not_log=just_read) + call get_param(param_file, mdl, "JET_WIDTH", jet_width, & + "The width of the zonal-mean jet.", units="km", & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & + "The interface height scale associated with the "//& + "zonal-mean jet.", units="m", scale=US%m_to_Z, & + fail_if_missing=.not.just_read, do_not_log=just_read) + ! If re-entrant in the Y direction, we use a sine function instead of a + ! tanh. The ratio len_lat/jet_width should be an integer in this case. + call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & + default=.false., do_not_log=.true.) + + if (just_read) return ! All run-time parameters have been read, so return. + + u(:,:,:) = 0.0 + v(:,:,:) = 0.0 + + pi = 4.0*atan(1.0) + + ! Use thermal wind shear to give a geostrophically balanced flow. + do k=nz-1,1 ; do j=js,je ; do I=is-1,ie + y_2 = G%geoLatCu(I,j) - G%south_lat - 0.5*G%len_lat + if (reentrant_y) then + y_2 = 2.*pi*y_2 + u(I,j,k) = u(I,j,k+1) + (1.e-3 * (jet_height / (US%m_to_L*jet_width)) * & + cos(y_2/jet_width) ) + else +! This uses d/d y_2 atan(y_2 / jet_width) +! u(I,j,k) = u(I,j,k+1) + ( jet_height / & +! (1.0e3*US%m_to_L*jet_width * (1.0 + (y_2 / jet_width)**2))) * & +! (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) +! This uses d/d y_2 tanh(y_2 / jet_width) + u(I,j,k) = u(I,j,k+1) + (1e-3 * (jet_height / (US%m_to_L*jet_width)) * & + (sech(y_2 / jet_width))**2 ) * & + (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) + endif + enddo ; enddo ; enddo + + do k=1,nz ; do j=js,je ; do I=is-1,ie + y_2 = (G%geoLatCu(I,j) - G%south_lat - 0.5*G%len_lat) / G%len_lat + x_2 = (G%geoLonCu(I,j) - G%west_lon - 0.5*G%len_lon) / G%len_lon + if (G%geoLonCu(I,j) == G%west_lon) then + ! This modification is required so that the perturbations are identical for + ! symmetric and non-symmetric memory. It is exactly equivalent to + ! taking the longitude at the eastern edge of the domain, so that x_2 ~= 0.5. + x_2 = ((G%west_lon + G%len_lon*REAL(G%ieg-(G%isg-1))/REAL(G%Domain%niglobal)) - & + G%west_lon - 0.5*G%len_lon) / G%len_lon + endif + u(I,j,k) = u(I,j,k) + velocity_amplitude * ((real(k)-0.5)/real(nz)) * & + (0.5 - abs(2.0*x_2) + 0.1*abs(cos(10.0*pi*x_2)) - abs(sin(5.0*pi*y_2))) + do m=1,10 + u(I,j,k) = u(I,j,k) + 0.2*velocity_amplitude * ((real(k)-0.5)/real(nz)) * & + cos(2.0*m*pi*x_2 + 2*m) * cos(6.0*pi*y_2) + enddo + enddo ; enddo ; enddo + +end subroutine Phillips_initialize_velocity + +!> Sets up the the inverse restoration time (Idamp), and the values towards which the interface +!! heights and an arbitrary number of tracers should be restored within each sponge for the Phillips +!! model test case +subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers + !! to any available thermodynamic + !! fields, potential temperature and + !! salinity or mixed layer density. + !! Absent fields have NULL ptrs. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(sponge_CS), pointer :: CSp !< A pointer that is set to point to + !! the control structure for the + !! sponge module. + real, intent(in), dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h !< Thickness field [H ~> m or kg m-2]. + + ! Local variables + real :: eta0(SZK_(GV)+1) ! The 1-d nominal positions of the interfaces [Z ~> m] + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for interface heights [Z ~> m]. + real :: temp(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for other variables [various] + real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] + real :: eta_im(SZJ_(G),SZK_(GV)+1) ! A temporary array for zonal-mean eta [Z ~> m]. + real :: Idamp_im(SZJ_(G)) ! The inverse zonal-mean damping rate [T-1 ~> s-1]. + real :: damp_rate ! The inverse zonal-mean damping rate [T-1 ~> s-1]. + real :: jet_width ! The width of the zonal mean jet [km]. + real :: jet_height ! The interface height scale associated with the zonal-mean jet [Z ~> m]. + real :: y_2 ! The y-position relative to the channel center [km]. + real :: half_strat ! The fractional depth where the straficiation is centered [nondim]. + real :: half_depth ! The depth where the stratification is centered [Z ~> m]. + real :: pi ! The ratio of the circumference of a circle to its diameter [nondim] + logical :: reentrant_y ! If true, model is re-entrant in the y direction + character(len=40) :: mdl = "Phillips_initialize_sponges" ! This subroutine's name. + + integer :: j, k, is, ie, js, je, isd, ied, jsd, jed, nz + logical, save :: first_call = .true. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + eta(:,:,:) = 0.0 ; temp(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 + eta_im(:,:) = 0.0 ; Idamp_im(:) = 0.0 + + if (first_call) call log_version(param_file, mdl, version) + first_call = .false. + call get_param(param_file, mdl, "HALF_STRAT_DEPTH", half_strat, & + "The fractional depth where the stratificaiton is centered.", & + units="nondim", default=0.5) + call get_param(param_file, mdl, "SPONGE_RATE", damp_rate, & + "The rate at which the zonal-mean sponges damp.", & + units="s-1", default=1.0/(10.0*86400.0), scale=US%T_to_s) + + call get_param(param_file, mdl, "JET_WIDTH", jet_width, & + "The width of the zonal-mean jet.", units="km", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & + "The interface height scale associated with the "//& + "zonal-mean jet.", units="m", scale=US%m_to_Z, & + fail_if_missing=.true.) + ! If re-entrant in the Y direction, we use a sine function instead of a + ! tanh. The ratio len_lat/jet_width should be an integer in this case. + call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & + default=.false., do_not_log=.true.) + + half_depth = G%max_depth*half_strat + eta0(1) = 0.0 ; eta0(nz+1) = -G%max_depth + do k=2,1+nz/2 ; eta0(k) = -half_depth*(2.0*(k-1)/real(nz)) ; enddo + do k=2+nz/2,nz+1 + eta0(k) = -G%max_depth - 2.0*(G%max_depth-half_depth) * ((k-(nz+1))/real(nz)) + enddo + pi = 4.0*atan(1.0) + + do j=js,je + Idamp_im(j) = damp_rate + eta_im(j,1) = 0.0 ; eta_im(j,nz+1) = -G%max_depth + enddo + do K=2,nz ; do j=js,je + y_2 = G%geoLatT(is,j) - G%south_lat - 0.5*G%len_lat + eta_im(j,K) = eta0(k) + jet_height * tanh(y_2 / jet_width) +! jet_height * atan(y_2 / jet_width) + if (reentrant_y) then + y_2 = 2.*pi*y_2 + eta_im(j,K) = eta0(k) + jet_height * sin(y_2 / jet_width) + endif + if (eta_im(j,K) > 0.0) eta_im(j,K) = 0.0 + if (eta_im(j,K) < -G%max_depth) eta_im(j,K) = -G%max_depth + enddo ; enddo + + call initialize_sponge(Idamp, eta, G, param_file, CSp, GV, Idamp_im, eta_im) + +end subroutine Phillips_initialize_sponges + +!> sech calculates the hyperbolic secant. +function sech(x) + real, intent(in) :: x !< Input value [nondim]. + real :: sech !< Result [nondim]. + + ! This is here to prevent overflows or underflows. + if (abs(x) > 228.) then + sech = 0.0 + else + sech = 2.0 / (exp(x) + exp(-x)) + endif +end function sech + +!> Initialize topography. +subroutine Phillips_initialize_topography(D, G, param_file, max_depth, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum model depth [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: Htop ! The maximum height of the topography above max_depth [Z ~> m] + real :: Wtop ! meridional width of topographic features [km] + real :: Ltop ! zonal width of topographic features [km] + real :: offset ! meridional offset from the center of topographic features [km] + real :: dist ! zonal width of topographic features [km] + real :: x1, x2, x3, x4, y1, y2 ! Various positions in the domain [km] + integer :: i, j, is, ie, js, je + character(len=40) :: mdl = "Phillips_initialize_topography" ! This subroutine's name. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + PI = 4.0*atan(1.0) + + call get_param(param_file, mdl, "PHILLIPS_HTOP", Htop, & + "The maximum height of the topography.", units="m", scale=US%m_to_Z, & + fail_if_missing=.true.) +! Htop=0.375*max_depth ! max height of topog. above max_depth + Wtop = 0.5*G%len_lat ! meridional width of drake and mount + Ltop = 0.25*G%len_lon ! zonal width of topographic features + offset = 0.1*G%len_lat ! meridional offset from center + dist = 0.333*G%len_lon ! distance between drake and mount + ! should be longer than Ltop/2 + + y1 = G%south_lat+0.5*G%len_lat+offset-0.5*Wtop ; y2 = y1+Wtop + x1 = G%west_lon+0.1*G%len_lon ; x2 = x1+Ltop ; x3 = x1+dist ; x4 = x3+3.0/2.0*Ltop + + do j=js,je ; do i=is,ie + D(i,j)=0.0 + if (G%geoLonT(i,j)>x1 .and. G%geoLonT(i,j)y1 .and. G%geoLatT(i,j)x3 .and. G%geoLonT(i,j)y1 .and. G%geoLatT(i,j) \namespace phillips_initialization +!! +!! By Robert Hallberg, April 1994 - June 2002 +!! +!! This subroutine initializes the fields for the simulations. +!! The one argument passed to initialize, Time, is set to the +!! current time of the simulation. The fields which are initialized +!! here are: +!! u - Zonal velocity [L T-1 ~> m s-1]. +!! v - Meridional velocity [L T-1 ~> m s-1]. +!! h - Layer thickness [H ~> m or kg m-2] (must be positive) +!! D - Basin depth [Z ~> m] (positive downward) +!! f - The Coriolis parameter [T-1 ~> s-1]. +!! If ENABLE_THERMODYNAMICS is defined: +!! T - Temperature [C ~> degC]. +!! S - Salinity [S ~> ppt]. +!! If SPONGE is defined: +!! A series of subroutine calls are made to set up the damping +!! rates and reference profiles for all variables that are damped +!! in the sponge. +!! Any user provided tracer code is also first linked through this +!! subroutine. +!! +!! Forcing-related fields (taux, tauy, buoy, ustar, etc.) are set +!! in MOM_surface_forcing.F90. +!! +!! These variables are all set in the set of subroutines (in this +!! file) Phillips_initialize_thickness, Phillips_initialize_velocity, +!! Phillips_initialize_topography and Phillips_initialize_sponges +!! that seet up fields that are specific to the Phillips instability +!! test case. + +end module Phillips_initialization diff --git a/user/RGC_initialization.F90 b/user/RGC_initialization.F90 new file mode 100644 index 0000000000..1cf4835efa --- /dev/null +++ b/user/RGC_initialization.F90 @@ -0,0 +1,203 @@ +!> Configures the models sponges for the Rotating Gravity Current (RGC) experiment. +module RGC_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +!*********************************************************************** +!* By Elizabeth Yankovsky, May 2018 * +!*********************************************************************** + +use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge +use MOM_ALE_sponge, only : set_up_ALE_sponge_vel_field +use MOM_domains, only : pass_var +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge +use MOM_sponge, only : set_up_sponge_ML_density +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, EOS_domain +implicit none ; private + +#include + +public RGC_initialize_sponges + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> Sets up the the inverse restoration time, and the values towards which the interface heights, +!! velocities and tracers should be restored within the sponges for the RGC test case. +subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, CSp, ACSp) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers + !! to any available thermodynamic + !! fields, potential temperature and + !! salinity or mixed layer density. + !! Absent fields have NULL pointers. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + target, intent(in) :: u !< Array with the u velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(in) :: v !< Array with the v velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: PF !< A structure to parse for model parameter values. + logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode + type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure + type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure + + ! Local variables + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temperature [C ~> degC] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salinity [S ~> ppt] + real :: U1(SZIB_(G),SZJ_(G),SZK_(GV)) ! A temporary array for u [L T-1 ~> m s-1] + real :: V1(SZI_(G),SZJB_(G),SZK_(GV)) ! A temporary array for v [L T-1 ~> m s-1] + real :: tmp(SZI_(G),SZJ_(G)) ! A temporary array for tracers. + real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness at h points [H ~> m or kg m-2] + real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate at h points [T-1 ~> s-1] + real :: TNUDG ! Nudging time scale [T ~> s] + real :: pres(SZI_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa] + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, positive upward [Z ~> m] + logical :: sponge_uv ! Nudge velocities (u and v) towards zero + real :: min_depth ! The minimum depth of the ocean [Z ~> m] + real :: dummy1 ! The position relative to the sponge width [nondim] + real :: min_thickness ! A minimum layer thickness [H ~> m or kg m-2] (unused) + real :: lensponge ! The width of the sponge [km] + character(len=40) :: filename, state_file + character(len=40) :: temp_var, salt_var, eta_var, inputdir, h_var + + character(len=40) :: mdl = "RGC_initialize_sponges" ! This subroutine's name. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, nz, iscB, iecB, jscB, jecB + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + iscB = G%iscB ; iecB = G%iecB; jscB = G%jscB ; jecB = G%jecB + + ! The variable min_thickness is unused, and can probably be eliminated. + call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & + units='m', default=1.e-3, scale=GV%m_to_H) + + call get_param(PF, mdl, "RGC_TNUDG", TNUDG, 'Nudging time scale for sponge layers', & + units='days', default=0.0, scale=86400.0*US%s_to_T) + + call get_param(PF, mdl, "LENSPONGE", lensponge, & + "The length of the sponge layer.", & + units=G%x_ax_unit_short, default=10.0) + + call get_param(PF, mdl, "SPONGE_UV", sponge_uv, & + "Nudge velocities (u and v) towards zero in the sponge layer.", & + default=.false., do_not_log=.true.) + + T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 + + call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) + + if (associated(CSp)) call MOM_error(FATAL, & + "RGC_initialize_sponges called with an associated control structure.") + if (associated(ACSp)) call MOM_error(FATAL, & + "RGC_initialize_sponges called with an associated ALE-sponge control structure.") + + ! Here the inverse damping time [T-1 ~> s-1], is set. Set Idamp to 0 + ! wherever there is no sponge, and the subroutines that are called + ! will automatically set up the sponges only where Idamp is positive + ! and mask2dT is 1. + + do j=js,je ; do i=is,ie + if ((depth_tot(i,j) <= min_depth) .or. (G%geoLonT(i,j) <= lensponge)) then + Idamp(i,j) = 0.0 + elseif (G%geoLonT(i,j) >= (G%len_lon - lensponge) .AND. G%geoLonT(i,j) <= G%len_lon) then + dummy1 = (G%geoLonT(i,j)-(G%len_lon - lensponge))/(lensponge) + Idamp(i,j) = (1.0/TNUDG) * max(0.0,dummy1) + else + Idamp(i,j) = 0.0 + endif + enddo ; enddo + + + ! 1) Read eta, salt and temp from IC file + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(PF, mdl, "RGC_SPONGE_FILE", state_file, & + "The name of the file with temps., salts. and interfaces to \n"// & + " damp toward.", fail_if_missing=.true.) + call get_param(PF, mdl, "SPONGE_PTEMP_VAR", temp_var, & + "The name of the potential temperature variable in \n"//& + "SPONGE_STATE_FILE.", default="Temp") + call get_param(PF, mdl, "SPONGE_SALT_VAR", salt_var, & + "The name of the salinity variable in \n"//& + "SPONGE_STATE_FILE.", default="Salt") + call get_param(PF, mdl, "SPONGE_ETA_VAR", eta_var, & + "The name of the interface height variable in \n"//& + "SPONGE_STATE_FILE.", default="eta") + call get_param(PF, mdl, "SPONGE_H_VAR", h_var, & + "The name of the layer thickness variable in \n"//& + "SPONGE_STATE_FILE.", default="h") + + !read temp and eta + filename = trim(inputdir)//trim(state_file) + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " RGC_initialize_sponges: Unable to open "//trim(filename)) + call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain, scale=US%degC_to_C) + call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain, scale=US%ppt_to_S) + if (use_ALE) then + + call MOM_read_data(filename, h_var, h(:,:,:), G%Domain, scale=GV%m_to_H) + call pass_var(h, G%domain) + + call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, h, nz) + + ! The remaining calls to set_up_sponge_field can be in any order. + if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp, 'temp', & + sp_long_name='temperature', sp_unit='degC s-1') + if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & + sp_long_name='salinity', sp_unit='g kg-1 s-1') + + if (sponge_uv) then + U1(:,:,:) = 0.0 ; V1(:,:,:) = 0.0 + call set_up_ALE_sponge_vel_field(U1, V1, G, GV, u, v, ACSp) + endif + + + else ! layer mode + + !read eta + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) + + ! Set the sponge damping rates so that the model will know where to + ! apply the sponges, along with the interface heights. + call initialize_sponge(Idamp, eta, G, PF, CSp, GV) + + if ( GV%nkml>0 ) then + ! This call to set_up_sponge_ML_density registers the target values of the + ! mixed layer density, which is used in determining which layers can be + ! inflated without causing static instabilities. + do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), tv%eqn_of_state, EOSdom) + enddo + + call set_up_sponge_ML_density(tmp, G, CSp) + endif + + ! Apply sponge in tracer fields + call set_up_sponge_field(T, tv%T, G, GV, nz, CSp) + call set_up_sponge_field(S, tv%S, G, GV, nz, CSp) + + endif + +end subroutine RGC_initialize_sponges + +end module RGC_initialization diff --git a/user/Rossby_front_2d_initialization.F90 b/user/Rossby_front_2d_initialization.F90 new file mode 100644 index 0000000000..33c7641a00 --- /dev/null +++ b/user/Rossby_front_2d_initialization.F90 @@ -0,0 +1,376 @@ +!> Initial conditions for the 2D Rossby front test +module Rossby_front_2d_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR +use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA + +implicit none ; private + +#include + +! Private (module-wise) parameters +character(len=40) :: mdl = "Rossby_front_2d_initialization" !< This module's name. +! This include declares and sets the variable "version". +#include "version_variable.h" + +public Rossby_front_initialize_thickness +public Rossby_front_initialize_temperature_salinity +public Rossby_front_initialize_velocity + +! Parameters defining the initial conditions of this test case +real, parameter :: frontFractionalWidth = 0.5 !< Width of front as fraction of domain [nondim] +real, parameter :: HMLmin = 0.25 !< Shallowest ML as fractional depth of ocean [nondim] +real, parameter :: HMLmax = 0.75 !< Deepest ML as fractional depth of ocean [nondim] + +contains + +!> Initialization of thicknesses in 2D Rossby front test +subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + + ! Local variables + real :: Tz ! Vertical temperature gradient [C H-1 ~> degC m2 kg-1] + real :: Dml ! Mixed layer depth [H ~> m or kg m-2] + real :: eta ! An interface height depth [H ~> m or kg m-2] + real :: stretch ! A nondimensional stretching factor [nondim] + real :: h0 ! The stretched thickness per layer [H ~> m or kg m-2] + real :: T_range ! Range of temperatures over the vertical [C ~> degC] + real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: max_depth ! Maximum depth of the model bathymetry [H ~> m or kg m-2] + character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) & + call MOM_mesg("Rossby_front_2d_initialization.F90, Rossby_front_initialize_thickness: setting thickness") + + if (.not.just_read) call log_version(param_file, mdl, version, "") + ! Read parameters needed to set thickness + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & + units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & + units="kg m-3 degC-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) + + if (just_read) return ! All run-time parameters have been read, so return. + + if (max_depth <= 0.0) call MOM_error(FATAL, & + "Rossby_front_initialize_thickness, Rossby_front_initialize_thickness: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + + Tz = T_range / max_depth + + if (GV%Boussinesq) then + select case ( coordinateMode(verticalCoordinate) ) + + case (REGRIDDING_LAYER, REGRIDDING_RHO) + ! This code is identical to the REGRIDDING_ZSTAR case but probably should not be. + do j = G%jsc,G%jec ; do i = G%isc,G%iec + Dml = Hml( G, G%geoLatT(i,j), max_depth ) + eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) + stretch = ( ( max_depth + eta ) / max_depth ) + h0 = ( max_depth / real(nz) ) * stretch + do k = 1, nz + h(i,j,k) = h0 + enddo + enddo ; enddo + + case (REGRIDDING_ZSTAR, REGRIDDING_SIGMA) + do j = G%jsc,G%jec ; do i = G%isc,G%iec + Dml = Hml( G, G%geoLatT(i,j), max_depth ) + ! The free surface height is set so that the bottom pressure gradient is 0. + eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) + stretch = ( ( max_depth + eta ) / max_depth ) + h0 = ( max_depth / real(nz) ) * stretch + do k = 1, nz + h(i,j,k) = h0 + enddo + enddo ; enddo + + case default + call MOM_error(FATAL,"Rossby_front_initialize: "// & + "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") + + end select + else + ! In non-Boussinesq mode with a flat bottom, the only requirement for no bottom pressure + ! gradient and no abyssal flow is that all columns have the same mass. + h0 = max_depth / real(nz) + do k=1,nz ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + h(i,j,k) = h0 + enddo ; enddo ; enddo + endif + +end subroutine Rossby_front_initialize_thickness + + +!> Initialization of temperature and salinity in the Rossby front test +subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, US, & + param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handle + logical, intent(in) :: just_read !< If true, this call will + !! only read parameters without changing T & S. + ! Local variables + real :: T_ref ! Reference temperature within the surface layer [C ~> degC] + real :: S_ref ! Reference salinity within the surface layer [S ~> ppt] + real :: T_range ! Range of temperatures over the vertical [C ~> degC] + real :: zc ! Position of the middle of the cell [H ~> m or kg m-2] + real :: zi ! Bottom interface position relative to the sea surface [H ~> m or kg m-2] + real :: dTdz ! Vertical temperature gradient [C H-1 ~> degC m-1 or degC m2 kg-1] + real :: Dml ! Mixed layer depth [H ~> m or kg m-2] + real :: max_depth ! Maximum depth of the model bathymetry [H ~> m or kg m-2] + character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & + units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) + + if (just_read) return ! All run-time parameters have been read, so return. + + if (max_depth <= 0.0) call MOM_error(FATAL, & + "Rossby_front_initialize_thickness, Rossby_front_initialize_temperature_salinity: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + + T(:,:,:) = 0.0 + S(:,:,:) = S_ref + dTdz = T_range / max_depth + + ! This sets the temperature to the value at the base of the specified mixed layer + ! depth from a horizontally uniform constant thermal stratification. + do j = G%jsc,G%jec ; do i = G%isc,G%iec + zi = 0. + Dml = Hml(G, G%geoLatT(i,j), max_depth) + do k = 1, nz + zi = zi - h(i,j,k) ! Bottom interface position + zc = zi - 0.5*h(i,j,k) ! Position of middle of cell + T(i,j,k) = T_ref + dTdz * min( zc, -Dml ) ! Linear temperature profile below the mixed layer + enddo + enddo ; enddo + +end subroutine Rossby_front_initialize_temperature_salinity + + +!> Initialization of u and v in the Rossby front test +subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: u !< i-component of velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: v !< j-component of velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), & + intent(in) :: h !< Thickness [H ~> m or kg m-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If present and true, this call will only + !! read parameters without setting u & v. + + real :: T_range ! Range of temperatures over the vertical [C ~> degC] + real :: T_ref ! Reference temperature within the surface layer [C ~> degC] + real :: S_ref ! Reference salinity within the surface layer [S ~> ppt] + real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f with rescaling + ! [L2 H-1 T-1 C-1 ~> m s-1 degC-1 or m4 kg-1 s-1 degC-1] + real :: Rho_T0_S0 ! The density at T=0, S=0 [R ~> kg m-3] + real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + real :: dSpV_dT ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real :: T_here ! The temperature in the middle of a layer [C ~> degC] + real :: dTdz ! Vertical temperature gradient [C H-1 ~> degC m-1 or degC m2 kg-1] + real :: Dml ! Mixed layer depth [H ~> m or kg m-2] + real :: zi, zc, zm ! Depths in thickness units [H ~> m or kg m-2]. + real :: f ! The local Coriolis parameter [T-1 ~> s-1] + real :: I_f ! The Adcroft reciprocal of the local Coriolis parameter [T ~> s] + real :: Ty ! The meridional temperature gradient [C L-1 ~> degC m-1] + real :: hAtU ! Interpolated layer thickness in height units [H ~> m or kg m-2]. + real :: u_int ! The zonal velocity at an interface [L T-1 ~> m s=1] + real :: max_depth ! Maximum depth of the model bathymetry [H ~> m or kg m-2] + integer :: i, j, k, is, ie, js, je, nz + character(len=40) :: verticalCoordinate + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & + units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=.true.) + call get_param(param_file, mdl, "RHO_T0_S0", Rho_T0_S0, & + units="kg m-3", default=1000.0, scale=US%kg_m3_to_R, do_not_log=.true.) + call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & + units="kg m-3 degC-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) + call get_param(param_file, mdl, "DRHO_DS", dRho_dS, & + units="kg m-3 ppt-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt, do_not_log=.true.) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) + + if (just_read) return ! All run-time parameters have been read, so return. + + if (max_depth <= 0.0) call MOM_error(FATAL, & + "Rossby_front_initialize_thickness, Rossby_front_initialize_velocity: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + + v(:,:,:) = 0.0 + u(:,:,:) = 0.0 + + if (GV%Boussinesq) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 + f = 0.5* (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) + dUdT = 0.0 ; if (abs(f) > 0.0) & + dUdT = ( GV%H_to_Z*GV%g_Earth*dRho_dT ) / ( f * GV%Rho0 ) + Dml = Hml( G, G%geoLatCu(I,j), max_depth ) + Ty = dTdy( G, T_range, G%geoLatCu(I,j), US ) + zi = 0. + do k = 1, nz + hAtU = 0.5 * (h(i,j,k) + h(i+1,j,k)) + zi = zi - hAtU ! Bottom interface position + zc = zi - 0.5*hAtU ! Position of middle of cell + zm = max( zc + Dml, 0. ) ! Height above bottom of mixed layer + u(I,j,k) = dUdT * Ty * zm ! Thermal wind starting at base of ML + enddo + enddo ; enddo + else + ! With an equation of state that is linear in density, the nonlinearies in + ! specific volume require that temperature be calculated for each layer. + + dTdz = T_range / max_depth + + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 + f = 0.5* (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) + I_f = 0.0 ; if (abs(f) > 0.0) I_f = 1.0 / f + Dml = Hml( G, G%geoLatCu(I,j), max_depth ) + Ty = dTdy( G, T_range, G%geoLatCu(I,j), US ) + zi = -max_depth + u_int = 0.0 ! The velocity at an interface + ! Work upward in non-Boussinesq mode + do k = nz, 1, -1 + hAtU = 0.5 * (h(i,j,k) + h(i+1,j,k)) + zc = zi + 0.5*hAtU ! Position of middle of cell + T_here = T_ref + dTdz * min(zc, -Dml) ! Linear temperature profile below the mixed layer + dSpV_dT = -dRho_dT / (Rho_T0_S0 + (dRho_dS * S_ref + dRho_dT * T_here) )**2 + dUdT = -( GV%H_to_RZ * GV%g_Earth * dSpV_dT ) * I_f + + ! There is thermal wind shear only within the mixed layer. + u(I,j,k) = u_int + dUdT * Ty * min(max((zi + Dml) + 0.5*hAtU, 0.0), 0.5*hAtU) + u_int = u_int + dUdT * Ty * min(max((zi + Dml) + hAtU, 0.0), hAtU) + + zi = zi + hAtU ! Update the layer top interface position + enddo + enddo ; enddo + endif +end subroutine Rossby_front_initialize_velocity + +!> Pseudo coordinate across domain used by Hml() and dTdy() +!! returns a coordinate from -PI/2 .. PI/2 squashed towards the +!! center of the domain [radians]. +real function yPseudo( G, lat ) + type(ocean_grid_type), intent(in) :: G !< Grid structure + real, intent(in) :: lat !< Latitude in arbitrary units, often [km] + ! Local + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + + PI = 4.0 * atan(1.0) + yPseudo = ( ( lat - G%south_lat ) / G%len_lat ) - 0.5 ! -1/2 .. 1/.2 + yPseudo = PI * max(-0.5, min(0.5, yPseudo / frontFractionalWidth)) +end function yPseudo + + +!> Analytic prescription of mixed layer depth in 2d Rossby front test, +!! in the same units as max_depth (usually [Z ~> m] or [H ~> m or kg m-2]) +real function Hml( G, lat, max_depth ) + type(ocean_grid_type), intent(in) :: G !< Grid structure + real, intent(in) :: lat !< Latitude in arbitrary units, often [km] + real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m] or [H ~> m or kg m-2] + ! Local + real :: dHML, HMLmean ! The range and mean of the mixed layer depths [Z ~> m] or [H ~> m or kg m-2] + + dHML = 0.5 * ( HMLmax - HMLmin ) * max_depth + HMLmean = 0.5 * ( HMLmin + HMLmax ) * max_depth + Hml = HMLmean + dHML * sin( yPseudo(G, lat) ) +end function Hml + + +!> Analytic prescription of mixed layer temperature gradient in [C L-1 ~> degC m-1] in 2d Rossby front test +real function dTdy( G, dT, lat, US ) + type(ocean_grid_type), intent(in) :: G !< Grid structure + real, intent(in) :: dT !< Top to bottom temperature difference [C ~> degC] + real, intent(in) :: lat !< Latitude in [km] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! Local + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: dHML ! The range of the mixed layer depths [Z ~> m] + real :: dHdy ! The mixed layer depth gradient [Z L-1 ~> m m-1] + real :: km_to_L ! Horizontal axis unit conversion factor when AXIS_UNITS = 'k' (1000 m) [L km-1 ~> 1000] + + PI = 4.0 * atan(1.0) + km_to_L = 1.0e3*US%m_to_L + dHML = 0.5 * ( HMLmax - HMLmin ) * G%max_depth + dHdy = dHML * ( PI / ( frontFractionalWidth * G%len_lat * km_to_L ) ) * cos( yPseudo(G, lat) ) + dTdy = -( dT / G%max_depth ) * dHdy + +end function dTdy + + +!> \namespace rossby_front_2d_initialization +!! +!! \section section_Rossby_front_2d Description of the 2d Rossby front initial conditions +!! +!! Consistent with a linear equation of state, the system has a constant stratification +!! below the mixed layer, stratified in temperature only. Isotherms are flat below the +!! mixed layer and vertical within. Salinity is constant. The mixed layer has a half sine +!! form so that there are no mixed layer or temperature gradients at the side walls. +!! +!! Below the mixed layer the potential temperature, \f$\theta(z)\f$, is given by +!! \f[ \theta(z) = \theta_0 - \Delta \theta \left( z + h_{ML} \right) \f] +!! where \f$ \theta_0 \f$ and \f$ \Delta \theta \f$ are external model parameters. +!! +!! The depth of the mixed layer, \f$H_{ML}\f$ is +!! \f[ h_{ML}(y) = h_{min} + \left( h_{max} - h_{min} \right) \cos{\pi y/L} \f]. +!! The temperature in mixed layer is given by the reference temperature at \f$z=h_{ML}\f$ +!! so that +!! \f{eqnarray} \theta(y,z) = +!! \theta_0 - \Delta \theta \left( z + h_{ML} \right) & \forall & z < h_{ML}(y) T.B.D. +!! \f} + +end module Rossby_front_2d_initialization diff --git a/user/SCM_CVMix_tests.F90 b/user/SCM_CVMix_tests.F90 new file mode 100644 index 0000000000..be515f22ca --- /dev/null +++ b/user/SCM_CVMix_tests.F90 @@ -0,0 +1,283 @@ +!> Initial conditions and forcing for the single column model (SCM) CVMix test set. +module SCM_CVMix_tests + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domains, only : pass_var, pass_vector, TO_ALL +use MOM_error_handler, only : MOM_error, FATAL +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_grid, only : ocean_grid_type +use MOM_verticalgrid, only : verticalGrid_type +use MOM_safe_alloc, only : safe_alloc_ptr +use MOM_unit_scaling, only : unit_scale_type +use MOM_time_manager, only : time_type, operator(+), operator(/), time_type_to_real +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, surface + +implicit none ; private + +#include + +public SCM_CVMix_tests_TS_init +public SCM_CVMix_tests_surface_forcing_init +public SCM_CVMix_tests_wind_forcing +public SCM_CVMix_tests_buoyancy_forcing +public SCM_CVMix_tests_CS + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Container for surface forcing parameters +type SCM_CVMix_tests_CS ; private + logical :: UseWindStress !< True to use wind stress + logical :: UseHeatFlux !< True to use heat flux + logical :: UseEvaporation !< True to use evaporation + logical :: UseDiurnalSW !< True to use diurnal sw radiation + real :: tau_x !< (Constant) Wind stress, X [R L Z T-2 ~> Pa] + real :: tau_y !< (Constant) Wind stress, Y [R L Z T-2 ~> Pa] + real :: surf_HF !< (Constant) Heat flux [C Z T-1 ~> m degC s-1] + real :: surf_evap !< (Constant) Evaporation rate [Z T-1 ~> m s-1] + real :: Max_sw !< maximum of diurnal sw radiation [C Z T-1 ~> degC m s-1] + real :: Rho0 !< reference density [R ~> kg m-3] + real :: rho_restore !< The density that is used to convert piston velocities + !! into salt or heat fluxes [R ~> kg m-3] +end type + +! This include declares and sets the variable "version". +#include "version_variable.h" + +character(len=40) :: mdl = "SCM_CVMix_tests" !< This module's name. + +contains + +!> Initializes temperature and salinity for the SCM CVMix test example +subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Input parameter structure + logical, intent(in) :: just_read !< If present and true, this call + !! will only read parameters without changing T & S. + ! Local variables + real :: UpperLayerTempMLD !< Upper layer Temp MLD thickness [Z ~> m]. + real :: UpperLayerSaltMLD !< Upper layer Salt MLD thickness [Z ~> m]. + real :: UpperLayerTemp !< Upper layer temperature (SST if thickness 0) [C ~> degC] + real :: UpperLayerSalt !< Upper layer salinity (SSS if thickness 0) [S ~> ppt] + real :: LowerLayerTemp !< Temp at top of lower layer [C ~> degC] + real :: LowerLayerSalt !< Salt at top of lower layer [S ~> ppt] + real :: LowerLayerdTdz !< Temp gradient in lower layer [C Z-1 ~> degC m-1]. + real :: LowerLayerdSdz !< Salt gradient in lower layer [S Z-1 ~> ppt m-1]. + real :: LowerLayerMinTemp !< Minimum temperature in lower layer [C ~> degC] + real :: zC, DZ, top, bottom ! Depths and thicknesses [Z ~> m]. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (.not.just_read) call log_version(param_file, mdl, version) + call get_param(param_file, mdl, "SCM_TEMP_MLD", UpperLayerTempMLD, & + 'Initial temp mixed layer depth', & + units='m', default=0.0, scale=US%m_to_Z, do_not_log=just_read) + call get_param(param_file, mdl, "SCM_SALT_MLD", UpperLayerSaltMLD, & + 'Initial salt mixed layer depth', & + units='m', default=0.0, scale=US%m_to_Z, do_not_log=just_read) + call get_param(param_file, mdl, "SCM_L1_SALT", UpperLayerSalt, & + 'Layer 2 surface salinity', units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "SCM_L1_TEMP", UpperLayerTemp, & + 'Layer 1 surface temperature', units="degC", default=20.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "SCM_L2_SALT", LowerLayerSalt, & + 'Layer 2 surface salinity', units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "SCM_L2_TEMP", LowerLayerTemp, & + 'Layer 2 surface temperature', units="degC", default=20.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "SCM_L2_DTDZ", LowerLayerdTdZ, & + 'Initial temperature stratification in layer 2', & + units='C/m', default=0.0, scale=US%degC_to_C*US%Z_to_m, do_not_log=just_read) + call get_param(param_file, mdl, "SCM_L2_DSDZ", LowerLayerdSdZ, & + 'Initial salinity stratification in layer 2', & + units='PPT/m', default=0.0, scale=US%ppt_to_S*US%Z_to_m, do_not_log=just_read) + call get_param(param_file, mdl, "SCM_L2_MINTEMP",LowerLayerMinTemp, & + 'Layer 2 minimum temperature', units="degC", default=4.0, scale=US%degC_to_C, do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + do j=js,je ; do i=is,ie + top = 0. ! Reference to surface + bottom = 0. + do k=1,nz + bottom = bottom - h(i,j,k) ! Interface below layer [Z ~> m] + zC = 0.5*( top + bottom ) ! Z of middle of layer [Z ~> m] + DZ = min(0., zC + UpperLayerTempMLD) + T(i,j,k) = max(LowerLayerMinTemp,LowerLayerTemp + LowerLayerdTdZ * DZ) + DZ = min(0., zC + UpperLayerSaltMLD) + S(i,j,k) = LowerLayerSalt + LowerLayerdSdZ * DZ + top = bottom + enddo ! k + enddo ; enddo + +end subroutine SCM_CVMix_tests_TS_init + +!> Initializes surface forcing for the CVMix test case suite +subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) + type(time_type), intent(in) :: Time !< Model time + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(param_file_type), intent(in) :: param_file !< Input parameter structure + type(SCM_CVMix_tests_CS), pointer :: CS !< Parameter container + + + ! This include declares and sets the variable "version". +# include "version_variable.h" + type(unit_scale_type), pointer :: US => NULL() !< A dimensional unit scaling type + + US => G%US + + if (associated(CS)) then + call MOM_error(FATAL, "SCM_CVMix_tests_surface_forcing_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "SCM_USE_WIND_STRESS", CS%UseWindStress, & + "Wind Stress switch used in the SCM CVMix surface forcing.", & + default=.false.) + call get_param(param_file, mdl, "SCM_USE_HEAT_FLUX", CS%UseHeatFlux, & + "Heat flux switch used in the SCM CVMix test surface forcing.", & + default=.false.) + call get_param(param_file, mdl, "SCM_USE_EVAPORATION", CS%UseEvaporation, & + "Evaporation switch used in the SCM CVMix test surface forcing.", & + default=.false.) + call get_param(param_file, mdl, "SCM_USE_DIURNAL_SW", CS%UseDiurnalSW, & + "Diurnal sw radation switch used in the SCM CVMix test surface forcing.", & + default=.false.) + if (CS%UseWindStress) then + call get_param(param_file, mdl, "SCM_TAU_X", CS%tau_x, & + "Constant X-dir wind stress used in the SCM CVMix test surface forcing.", & + units='N/m2', scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, fail_if_missing=.true.) + call get_param(param_file, mdl, "SCM_TAU_Y", CS%tau_y, & + "Constant y-dir wind stress used in the SCM CVMix test surface forcing.", & + units='N/m2', scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, fail_if_missing=.true.) + endif + if (CS%UseHeatFlux) then + call get_param(param_file, mdl, "SCM_HEAT_FLUX", CS%surf_HF, & + "Constant surface heat flux used in the SCM CVMix test surface forcing.", & + units='m K/s', scale=US%m_to_Z*US%degC_to_C*US%T_to_s, fail_if_missing=.true.) + endif + if (CS%UseEvaporation) then + call get_param(param_file, mdl, "SCM_EVAPORATION", CS%surf_evap, & + "Constant surface evaporation used in the SCM CVMix test surface forcing.", & + units='m/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) + endif + if (CS%UseDiurnalSW) then + call get_param(param_file, mdl, "SCM_DIURNAL_SW_MAX", CS%Max_sw, & + "Maximum diurnal sw radiation used in the SCM CVMix test surface forcing.", & + units='m K/s', scale=US%m_to_Z*US%degC_to_C*US%T_to_s, fail_if_missing=.true.) + endif + call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat fluxes.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) + +end subroutine SCM_CVMix_tests_surface_forcing_init + +subroutine SCM_CVMix_tests_wind_forcing(sfc_state, forces, day, G, US, CS) + type(surface), intent(in) :: sfc_state !< Surface state structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), intent(in) :: day !< Time in days + type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(SCM_CVMix_tests_CS), pointer :: CS !< Container for SCM parameters + ! Local variables + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + real :: mag_tau ! The magnitude of the wind stress [R L Z T-2 ~> Pa] + ! Bounds for loops and memory allocation + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + do j=js,je ; do I=Isq,Ieq + forces%taux(I,j) = CS%tau_x + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + forces%tauy(i,J) = CS%tau_y + enddo ; enddo + call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) + + mag_tau = sqrt(CS%tau_x*CS%tau_x + CS%tau_y*CS%tau_y) + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + forces%ustar(i,j) = sqrt( US%L_to_Z * mag_tau / CS%Rho0 ) + enddo ; enddo ; endif + + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = mag_tau + enddo ; enddo ; endif + +end subroutine SCM_CVMix_tests_wind_forcing + + +subroutine SCM_CVMix_tests_buoyancy_forcing(sfc_state, fluxes, day, G, US, CS) + type(surface), intent(in) :: sfc_state !< Surface state structure + type(forcing), intent(inout) :: fluxes !< Surface fluxes structure + type(time_type), intent(in) :: day !< Current model time + type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(SCM_CVMix_tests_CS), pointer :: CS !< Container for SCM parameters + + ! Local variables + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + + PI = 4.0*atan(1.0) + + ! Bounds for loops and memory allocation + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (CS%UseHeatFlux) then + ! Note CVMix test inputs give Heat flux in [Z C T-1 ~> m K/s] + ! therefore must convert to [Q R Z T-1 ~> W m-2] by multiplying + ! by Rho0*Cp + do J=Jsq,Jeq ; do i=is,ie + fluxes%sens(i,J) = CS%surf_HF * CS%rho_restore * fluxes%C_p + enddo ; enddo + endif + + if (CS%UseEvaporation) then + do J=Jsq,Jeq ; do i=is,ie + ! Note CVMix test inputs give evaporation in [Z T-1 ~> m s-1] + ! This therefore must be converted to mass flux in [R Z T-1 ~> kg m-2 s-1] + ! by multiplying by density and some unit conversion factors. + fluxes%evap(i,J) = CS%surf_evap * CS%rho_restore + enddo ; enddo + endif + + if (CS%UseDiurnalSW) then + do J=Jsq,Jeq ; do i=is,ie + ! Note CVMix test inputs give max sw rad in [Z C T-1 ~> m degC s-1] + ! therefore must convert to [Q R Z T-1 ~> W m-2] by multiplying by Rho0*Cp + ! Note diurnal cycle peaks at Noon. + fluxes%sw(i,J) = CS%Max_sw * max(0.0, cos(2*PI*(time_type_to_real(DAY)/86400.0 - 0.5))) * & + CS%rho_restore * fluxes%C_p + enddo ; enddo + endif + +end subroutine SCM_CVMix_tests_buoyancy_forcing + +end module SCM_CVMix_tests diff --git a/user/adjustment_initialization.F90 b/user/adjustment_initialization.F90 new file mode 100644 index 0000000000..4a1d6c3d9f --- /dev/null +++ b/user/adjustment_initialization.F90 @@ -0,0 +1,319 @@ +!> Configures the model for the geostrophic adjustment test case. +module adjustment_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR +use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA + +implicit none ; private + +character(len=40) :: mdl = "adjustment_initialization" !< This module's name. + +#include + +public adjustment_initialize_thickness +public adjustment_initialize_temperature_salinity + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> Initializes the layer thicknesses in the adjustment test case +subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + ! Local variables + real :: e0(SZK_(GV)+1) ! The resting interface heights, in depth units [Z ~> m], usually + ! negative because it is positive upward. + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface + ! positive upward, in depth units [Z ~> m]. + real :: dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + ! In this subroutine it is hard coded at 1.0 kg m-3 ppt-1. + real :: x, y, yy ! Fractional positions in the x- and y-directions [nondim] + real :: y_lat ! y-positions in the units of latitude [m] or [km] or [degrees] + real :: S_ref ! Reference salinity within surface layer [S ~> ppt] + real :: S_range ! Range of salinities in the vertical [S ~> ppt] + real :: dSdz ! Vertical salinity gradient [S Z-1 ~> ppt m-1] + real :: delta_S ! The local salinity perturbation [S ~> ppt] + real :: delta_S_strat ! Top-to-bottom salinity difference of stratification [S ~> ppt] + real :: min_thickness ! The minimum layer thickness [Z ~> m] + real :: adjustment_delta ! Interface height anomalies, positive downward [Z ~> m] + real :: adjustment_width ! Width of the frontal zone [m] or [km] or [degrees] + real :: adjustment_deltaS ! Salinity difference across front [S ~> ppt] + real :: front_wave_amp ! Amplitude of trans-frontal wave perturbation [m] or [km] or [degrees] + real :: front_wave_length ! Wave-length of trans-frontal wave perturbation [m] or [km] or [degrees] + real :: front_wave_asym ! Amplitude of frontal asymmetric perturbation [m] or [km] or [degrees] + real :: target_values(SZK_(GV)+1) ! Target densities or density anomalies [R ~> kg m-3] + character(len=20) :: verticalCoordinate + ! This include declares and sets the variable "version". +# include "version_variable.h" + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) & + call MOM_mesg("adjustment_initialize_thickness: setting thickness") + + ! Parameters used by main model initialization + if (.not.just_read) call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='ppt', scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & + default=1.0e-3, units='m', scale=US%m_to_Z, do_not_log=just_read) + call get_param(param_file, mdl, "DRHO_DS", dRho_dS, & + "The partial derivative of density with salinity with a linear equation of state.", & + units="kg m-3 ppt-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) + + ! Parameters specific to this experiment configuration + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + call get_param(param_file, mdl, "ADJUSTMENT_WIDTH", adjustment_width, & + "Width of frontal zone", & + units=G%x_ax_unit_short, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "DELTA_S_STRAT", delta_S_strat, & + "Top-to-bottom salinity difference of stratification", & + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "ADJUSTMENT_DELTAS", adjustment_deltaS, & + "Salinity difference across front", & + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "FRONT_WAVE_AMP", front_wave_amp, & + "Amplitude of trans-frontal wave perturbation", & + units=G%x_ax_unit_short, default=0., do_not_log=just_read) + call get_param(param_file, mdl, "FRONT_WAVE_LENGTH", front_wave_length, & + "Wave-length of trans-frontal wave perturbation", & + units=G%x_ax_unit_short, default=0., do_not_log=just_read) + call get_param(param_file, mdl, "FRONT_WAVE_ASYM", front_wave_asym, & + "Amplitude of frontal asymmetric perturbation", & + units=G%x_ax_unit_short, default=0., do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + ! WARNING: this routine specifies the interface heights so that the last layer + ! is vanished, even at maximum depth. In order to have a uniform + ! layer distribution, use this line of code within the loop: + ! e0(k) = -G%max_depth * real(k-1) / real(nz) + ! To obtain a thickness distribution where the last layer is + ! vanished and the other thicknesses uniformly distributed, use: + ! e0(k) = -G%max_depth * real(k-1) / real(nz-1) + + dSdz = -delta_S_strat / G%max_depth + + select case ( coordinateMode(verticalCoordinate) ) + + case ( REGRIDDING_LAYER, REGRIDDING_RHO ) + if (delta_S_strat /= 0.) then + ! This was previously coded ambiguously. + adjustment_delta = (adjustment_deltaS / delta_S_strat) * G%max_depth + do k=1,nz+1 + e0(k) = adjustment_delta - (G%max_depth + 2*adjustment_delta) * (real(k-1) / real(nz)) + enddo + else + adjustment_delta = 2.*G%max_depth + do k=1,nz+1 + e0(k) = -G%max_depth * (real(k-1) / real(nz)) + enddo + endif + if (nz > 1) then + target_values(1) = ( GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2)) ) + target_values(nz+1) = ( GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) ) + else ! This might not be needed, but it avoids segmentation faults if nz=1. + target_values(1) = 0.0 + target_values(nz+1) = 2.0 * GV%Rlay(1) + endif + do k = 2,nz + target_values(k) = target_values(k-1) + ( GV%Rlay(nz) - GV%Rlay(1) ) / (nz-1) + enddo + target_values(:) = target_values(:) - 1000.0*US%kg_m3_to_R + do j=js,je ; do i=is,ie + if (front_wave_length /= 0.) then + y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) + yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / adjustment_width + yy = min(1.0, yy); yy = max(-1.0, yy) + yy = yy * 2. * acos( 0. ) + y_lat = front_wave_amp*sin(y) + front_wave_asym*sin(yy) + else + y_lat = 0. + endif + x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y_lat ) / adjustment_width + x = min(1.0, x); x = max(-1.0, x) + x = x * acos( 0. ) + delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) + do k=2,nz + if (dRho_dS*dSdz /= 0.) then + eta1D(k) = ( target_values(k) - dRho_dS*( S_ref + delta_S ) ) / (dRho_dS*dSdz) + else + eta1D(k) = e0(k) - (0.5*adjustment_delta) * sin( x ) + endif + eta1D(k) = max( eta1D(k), -G%max_depth ) + eta1D(k) = min( eta1D(k), 0. ) + enddo + eta1D(1) = 0.; eta1D(nz+1) = -G%max_depth + do k=nz,1,-1 + if (eta1D(k) > 0.) then + eta1D(k) = max( eta1D(k+1) + min_thickness, 0. ) + h(i,j,k) = max( eta1D(k) - eta1D(k+1), min_thickness ) + elseif (eta1D(k) <= (eta1D(k+1) + min_thickness)) then + eta1D(k) = eta1D(k+1) + min_thickness + h(i,j,k) = min_thickness + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA ) + do k=1,nz+1 + eta1D(k) = -G%max_depth * (real(k-1) / real(nz)) + eta1D(k) = max(min(eta1D(k), 0.), -G%max_depth) + enddo + do j=js,je ; do i=is,ie + do k=nz,1,-1 + h(i,j,k) = eta1D(k) - eta1D(k+1) + enddo + enddo ; enddo + + case default + call MOM_error(FATAL, "adjustment_initialize_thickness: "// & + "Unrecognized i.c. setup - set ADJUSTMENT_IC") + + end select + +end subroutine adjustment_initialize_thickness + +!> Initialization of temperature and salinity in the adjustment test case +subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: T !< The temperature that is being initialized [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: S !< The salinity that is being initialized [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< The model thicknesses [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to + !! parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T & S. + + real :: x, y, yy ! Fractional positions in the x- and y-directions [nondim] + real :: y_lat ! y-position in the units of latitude [m] or [km] or [degrees] + real :: S_ref ! Reference salinity within surface layer [S ~> ppt] + real :: T_ref ! Reference temperature within surface layer [C ~> degC] + real :: S_range ! Range of salinities in the vertical [S ~> ppt] + real :: T_range ! Range of temperatures in the vertical [C ~> degC] + real :: dSdz ! Vertical salinity gradient [S Z-1 ~> ppt m-1] + real :: delta_S ! The local salinity perturbation [S ~> ppt] + real :: delta_S_strat ! Top-to-bottom salinity difference of stratification [S ~> ppt] + real :: adjustment_width ! Width of the frontal zone [m] or [km] or [degrees] + real :: adjustment_deltaS ! Salinity difference across front [S ~> ppt] + real :: front_wave_amp ! Amplitude of trans-frontal wave perturbation [m] or [km] or [degrees] + real :: front_wave_length ! Wave-length of trans-frontal wave perturbation [m] or [km] or [degrees] + real :: front_wave_asym ! Amplitude of frontal asymmetric perturbation [m] or [km] or [degrees] + real :: eta1d(SZK_(GV)+1) ! Interface heights [Z ~> m] + character(len=20) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + ! Parameters used by main model initialization + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_RANGE", S_range, 'Initial salinity range', & + default=2.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & + default=1.0, units='degC', scale=US%degC_to_C, do_not_log=just_read) + ! Parameters specific to this experiment configuration BUT logged in previous s/r + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + call get_param(param_file, mdl, "ADJUSTMENT_WIDTH", adjustment_width, & + units=G%x_ax_unit_short, fail_if_missing=.not.just_read, do_not_log=.true.) + call get_param(param_file, mdl, "ADJUSTMENT_DELTAS", adjustment_deltaS, & + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=.true.) + call get_param(param_file, mdl, "DELTA_S_STRAT", delta_S_strat, & + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=.true.) + call get_param(param_file, mdl, "FRONT_WAVE_AMP", front_wave_amp, & + units=G%x_ax_unit_short, default=0., do_not_log=.true.) + call get_param(param_file, mdl, "FRONT_WAVE_LENGTH", front_wave_length, & + units=G%x_ax_unit_short, default=0., do_not_log=.true.) + call get_param(param_file, mdl, "FRONT_WAVE_ASYM", front_wave_asym, & + units=G%x_ax_unit_short, default=0., do_not_log=.true.) + + if (just_read) return ! All run-time parameters have been read, so return. + + T(:,:,:) = 0.0 + S(:,:,:) = 0.0 + + ! Linear salinity profile + select case ( coordinateMode(verticalCoordinate) ) + + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA ) + dSdz = -delta_S_strat / G%max_depth + do j=js,je ; do i=is,ie + eta1d(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1d(k) = eta1d(k+1) + h(i,j,k) + enddo + if (front_wave_length /= 0.) then + y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) + yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / front_wave_length + yy = min(1.0, yy); yy = max(-1.0, yy) + yy = yy * 2. * acos( 0. ) + y_lat = front_wave_amp*sin(y) + front_wave_asym*sin(yy) + else + y_lat = 0. + endif + x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y_lat ) / adjustment_width + x = min(1.0, x); x = max(-1.0, x) + x = x * acos( 0. ) + delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) + do k=1,nz + S(i,j,k) = S_ref + delta_S + 0.5 * ( eta1D(k)+eta1D(k+1) ) * dSdz + x = abs(S(i,j,k) - 0.5*real(nz-1)/real(nz)*S_range)/S_range*real(2*nz) + x = 1. - min(1., x) + T(i,j,k) = T_range * x + enddo + ! x = sum(T(i,j,:)*h(i,j,:)) + ! T(i,j,:) = (T(i,j,:) / x) * (G%max_depth*1.5/real(nz)) + enddo ; enddo + + case ( REGRIDDING_LAYER, REGRIDDING_RHO ) + do k = 1,nz + S(:,:,k) = S_ref + S_range * ( (real(k)-0.5) / real( nz ) ) + ! x = abs(S(1,1,k) - 0.5*real(nz-1)/real(nz)*S_range)/S_range*real(2*nz) + ! x = 1.-min(1., x) + ! T(:,:,k) = T_range * x + enddo + + case default + call MOM_error(FATAL, "adjustment_initialize_temperature_salinity: "// & + "Unrecognized i.c. setup - set ADJUSTMENT_IC") + + end select + +end subroutine adjustment_initialize_temperature_salinity + +end module adjustment_initialization diff --git a/user/baroclinic_zone_initialization.F90 b/user/baroclinic_zone_initialization.F90 new file mode 100644 index 0000000000..e2c6182231 --- /dev/null +++ b/user/baroclinic_zone_initialization.F90 @@ -0,0 +1,157 @@ +!> Initial conditions for an idealized baroclinic zone +module baroclinic_zone_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include +#include "version_variable.h" + +! Private (module-wise) parameters +character(len=40) :: mdl = "baroclinic_zone_initialization" !< This module's name. + +public baroclinic_zone_init_temperature_salinity + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> Reads the parameters unique to this module +subroutine bcz_params(G, GV, US, param_file, S_ref, dSdz, delta_S, dSdx, T_ref, dTdz, & + delta_T, dTdx, L_zone, just_read) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handle + real, intent(out) :: S_ref !< Reference salinity [S ~> ppt] + real, intent(out) :: dSdz !< Salinity stratification [S Z-1 ~> ppt m-1] + real, intent(out) :: delta_S !< Salinity difference across baroclinic zone [S ~> ppt] + real, intent(out) :: dSdx !< Linear salinity gradient, often in [S km-1 ~> ppt km-1] + !! or [S degrees_E-1 ~> ppt degrees_E-1], depending on + !! the value of G%x_axis_units + real, intent(out) :: T_ref !< Reference temperature [C ~> degC] + real, intent(out) :: dTdz !< Temperature stratification [C Z-1 ~> degC m-1] + real, intent(out) :: delta_T !< Temperature difference across baroclinic zone [C ~> degC] + real, intent(out) :: dTdx !< Linear temperature gradient, often in [C km-1 ~> degC km-1] + !! or [C degrees_E-1 ~> degC degrees_E-1], depending on + !! the value of G%x_axis_units + real, intent(out) :: L_zone !< Width of baroclinic zone, often in [km] or [degrees_N], + !! depending on the value of G%y_axis_units + logical, intent(in) :: just_read !< If true, this call will + !! only read parameters without changing h. + + if (.not.just_read) & + call log_version(param_file, mdl, version, 'Initialization of an analytic baroclinic zone') + call openParameterBlock(param_file,'BCZIC') + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + units='ppt', default=35., scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "DSDZ", dSdz, 'Salinity stratification', & + units='ppt m-1', default=0.0, scale=US%ppt_to_S*US%Z_to_m, do_not_log=just_read) + call get_param(param_file, mdl, "DELTA_S",delta_S, 'Salinity difference across baroclinic zone', & + units='ppt', default=0.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "DSDX", dSdx,'Meridional salinity difference', & + units='ppt '//trim(G%x_ax_unit_short)//'-1', default=0.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units='degC', default=10., scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "DTDZ", dTdz, 'Temperature stratification', & + units='degC m-1', default=0.0, scale=US%degC_to_C*US%Z_to_m, do_not_log=just_read) + call get_param(param_file, mdl, "DELTA_T", delta_T,'Temperature difference across baroclinic zone', & + units='degC', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "DTDX", dTdx,'Meridional temperature difference', & + units='degC '//trim(G%x_ax_unit_short)//'-1', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "L_ZONE", L_zone, 'Width of baroclinic zone', & + units=G%y_ax_unit_short, default=0.5*G%len_lat, do_not_log=just_read) + call closeParameterBlock(param_file) + +end subroutine bcz_params + +!> Initialization of temperature and salinity with the baroclinic zone initial conditions +subroutine baroclinic_zone_init_temperature_salinity(T, S, h, depth_tot, G, GV, US, param_file, & + just_read) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< The model thicknesses [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T & S. + + integer :: i, j, k, is, ie, js, je, nz + real :: T_ref, delta_T ! Parameters describing temperature distribution [C ~> degC] + real :: dTdz ! Vertical temperature gradients [C Z-1 ~> degC m-1] + real :: dTdx ! Zonal temperature gradients [C axis_units-1 ~> degC axis_units-1] + real :: S_ref, delta_S ! Parameters describing salinity distribution [S ~> ppt] + real :: dSdz ! Vertical salinity gradients [S Z-1 ~> ppt m-1] + real :: dSdx ! Zonal salinity gradients [S axis_units-1 ~> ppt axis_units-1] + real :: L_zone ! Width of baroclinic zone, often in [km] or [degrees_N], depending + ! on the value of G%y_axis_units + real :: zc, zi ! Depths in depth units [Z ~> m] + real :: x ! X-position relative to the domain center [degrees_E] or [km] or [m] + real :: y ! Y-position relative to the domain center [degrees_N] or [km] or [m] + real :: fn ! A smooth function based on the position in the baroclinic zone [nondim] + real :: xs, xd, yd ! Fractional x- and y-positions relative to the domain extent [nondim] + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call bcz_params(G, GV, US, param_file, S_ref, dSdz, delta_S, dSdx, T_ref, dTdz, & + delta_T, dTdx, L_zone, just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + T(:,:,:) = 0. + S(:,:,:) = 0. + PI = 4.*atan(1.) + + do j = G%jsc,G%jec ; do i = G%isc,G%iec + zi = -depth_tot(i,j) + x = G%geoLonT(i,j) - (G%west_lon + 0.5*G%len_lon) ! Relative to center of domain + xd = x / G%len_lon ! -1/2 < xd 1/2 + y = G%geoLatT(i,j) - (G%south_lat + 0.5*G%len_lat) ! Relative to center of domain + yd = y / G%len_lat ! -1/2 < yd 1/2 + if (L_zone/=0.) then + xs = min(1., max(-1., x/L_zone)) ! -1 < ys < 1 + fn = sin((0.5*PI)*xs) + else + xs = sign(1., x) ! +/- 1 + fn = xs + endif + do k = nz, 1, -1 + zc = zi + 0.5*h(i,j,k) ! Position of middle of cell + zi = zi + h(i,j,k) ! Top interface position + T(i,j,k) = T_ref + dTdz * zc & ! Linear temperature stratification + + dTdx * x & ! Linear gradient + + delta_T * fn ! Smooth fn of width L_zone + S(i,j,k) = S_ref + dSdz * zc & ! Linear temperature stratification + + dSdx * x & ! Linear gradient + + delta_S * fn ! Smooth fn of width L_zone + enddo + enddo ; enddo + +end subroutine baroclinic_zone_init_temperature_salinity + +!> \namespace baroclinic_zone_initialization +!! +!! \section section_baroclinic_zone Description of the baroclinic zone initial conditions +!! +!! yada yada yada + +end module baroclinic_zone_initialization diff --git a/user/basin_builder.F90 b/user/basin_builder.F90 new file mode 100644 index 0000000000..42083b2672 --- /dev/null +++ b/user/basin_builder.F90 @@ -0,0 +1,335 @@ +!> An idealized topography building system +module basin_builder + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_string_functions, only : lowercase +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +#include + +public basin_builder_topography + +! This include declares and sets the variable "version". +# include "version_variable.h" +character(len=40) :: mdl = "basin_builder" !< This module's name. + +contains + +!> Constructs idealized topography from simple functions +subroutine basin_builder_topography(D, G, param_file, max_depth) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth in the units of depth_max + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + ! Local variables + character(len=17) :: pname1, pname2 ! For construction of parameter names + character(len=20) :: funcs ! Basin build function + real, dimension(20) :: pars ! Parameters for each function + real :: lon ! Longitude [degrees_E] + real :: lat ! Latitude [degrees_N] + integer :: i, j, n, n_funcs + + call MOM_mesg(" basin_builder.F90, basin_builder_topography: setting topography", 5) + call log_version(param_file, mdl, version, "") + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + D(i,j) = 1.0 + enddo ; enddo + + call get_param(param_file, mdl, "BBUILDER_N", n_funcs, & + "Number of pieces of topography to use.", fail_if_missing=.true.) + + do n=1,n_funcs + write( pname1, "('BBUILDER_',i3.3,'_FUNC')" ) n + write( pname2, "('BBUILDER_',i3.3,'_PARS')" ) n + call get_param(param_file, mdl, pname1, funcs, & + "The basin builder function to apply with parameters "//& + trim(pname2)//". Choices are: NS_COAST, EW_COAST, "//& + "CIRC_CONIC_RIDGE, NS_CONIC_RIDGE, CIRC_SCURVE_RIDGE, "//& + "NS_SCURVE_RIDGE.", & + fail_if_missing=.true.) + pars(:) = 0. + if (trim(lowercase(funcs)) == 'ns_coast') then + call get_param(param_file, mdl, pname2, pars(1:5), & + "NS_COAST parameters: longitude, starting latitude, "//& + "ending latitude, footprint radius, shelf depth.", & + units="degrees_E,degrees_N,degrees_N,degrees,m", & + fail_if_missing=.true.) + pars(5) = pars(5) / max_depth + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), NS_coast(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) + enddo ; enddo + elseif (trim(lowercase(funcs)) == 'ns_conic_ridge') then + call get_param(param_file, mdl, pname2, pars(1:5), & + "NS_CONIC_RIDGE parameters: longitude, starting latitude, "//& + "ending latitude, footprint radius, ridge height.", & + units="degrees_E,degrees_N,degrees_N,degrees,m", & + fail_if_missing=.true.) + pars(5) = pars(5) / max_depth + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), NS_conic_ridge(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) + enddo ; enddo + elseif (trim(lowercase(funcs)) == 'ns_scurve_ridge') then + call get_param(param_file, mdl, pname2, pars(1:5), & + "NS_SCURVE_RIDGE parameters: longitude, starting latitude, "//& + "ending latitude, footprint radius, ridge height.", & + units="degrees_E,degrees_N,degrees_N,degrees,m", & + fail_if_missing=.true.) + pars(5) = pars(5) / max_depth + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), NS_scurve_ridge(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) + enddo ; enddo + elseif (trim(lowercase(funcs)) == 'angled_coast') then + call get_param(param_file, mdl, pname2, pars(1:4), & + "ANGLED_COAST parameters: longitude intersection with Equator, "//& + "latitude intersection with Prime Meridian, footprint radius, shelf depth.", & + units="degrees_E,degrees_N,degrees,m", & + fail_if_missing=.true.) + pars(4) = pars(4) / max_depth + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), angled_coast(lon, lat, pars(1), pars(2), pars(3), pars(4)) ) + enddo ; enddo + elseif (trim(lowercase(funcs)) == 'ew_coast') then + call get_param(param_file, mdl, pname2, pars(1:5), & + "EW_COAST parameters: latitude, starting longitude, "//& + "ending longitude, footprint radius, shelf depth.", & + units="degrees_N,degrees_E,degrees_E,degrees,m", & + fail_if_missing=.true.) + pars(5) = pars(5) / max_depth + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), EW_coast(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) + enddo ; enddo + elseif (trim(lowercase(funcs)) == 'circ_conic_ridge') then + call get_param(param_file, mdl, pname2, pars(1:5), & + "CIRC_CONIC_RIDGE parameters: center longitude, center latitude, "//& + "ring radius, footprint radius, ridge height.", & + units="degrees_E,degrees_N,degrees,degrees,m", & + fail_if_missing=.true.) + pars(5) = pars(5) / max_depth + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), circ_conic_ridge(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) + enddo ; enddo + elseif (trim(lowercase(funcs)) == 'circ_scurve_ridge') then + call get_param(param_file, mdl, pname2, pars(1:5), & + "CIRC_SCURVe_RIDGE parameters: center longitude, center latitude, "//& + "ring radius, footprint radius, ridge height.", & + units="degrees_E,degrees_N,degrees,degrees,m", & + fail_if_missing=.true.) + pars(5) = pars(5) / max_depth + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), circ_scurve_ridge(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) + enddo ; enddo + else + call MOM_error(FATAL, "basin_builder.F90, basin_builer_topography:\n"//& + "Unrecognized function "//trim(funcs)) + endif + + enddo ! n + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! Dimensionalize by scaling 1 to max_depth + D(i,j) = D(i,j) * max_depth + enddo ; enddo + +end subroutine basin_builder_topography + +!> Returns the value of a triangular function centered at x=x0 with value 1 +!! and linearly decreasing to 0 at x=x0+/-L, and 0 otherwise. +!! If clip is present the top of the cone is cut off at "clip", which +!! effectively defaults to 1. +real function cone(x, x0, L, clip) + real, intent(in) :: x !< non-dimensional coordinate [nondim] + real, intent(in) :: x0 !< position of peak [nondim] + real, intent(in) :: L !< half-width of base of cone [nondim] + real, optional, intent(in) :: clip !< clipping height of cone [nondim] + + cone = max( 0., 1. - abs(x - x0) / L ) + if (present(clip)) cone = min(clip, cone) +end function cone + +!> Returns an s-curve s(x) s.t. s(x0)<=0, s(x0+L)>=1 and cubic in between. +real function scurve(x, x0, L) + real, intent(in) :: x !< non-dimensional coordinate [nondim] + real, intent(in) :: x0 !< position of peak [nondim] + real, intent(in) :: L !< half-width of base of cone [nondim] + real :: s + + s = max( 0., min( 1.,( x - x0 ) / L ) ) + scurve = ( 3. - 2.*s ) * ( s * s ) +end function scurve + +!> Returns a "coastal" profile. +real function cstprof(x, x0, L, lf, bf, sf, sh) + real, intent(in) :: x !< non-dimensional coordinate [nondim] + real, intent(in) :: x0 !< position of peak [nondim] + real, intent(in) :: L !< width of profile [nondim] + real, intent(in) :: lf !< fraction of width that is "land" [nondim] + real, intent(in) :: bf !< fraction of width that is "beach" [nondim] + real, intent(in) :: sf !< fraction of width that is "continental slope" [nondim] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: s + + s = max( 0., min( 1.,( x - x0 ) / L ) ) + cstprof = sh * scurve(s-lf,0.,bf) + (1.-sh) * scurve(s - (1.-sf),0.,sf) +end function cstprof + +!> Distance between points x,y and a line segment (x0,y0) and (x0,y1). +real function dist_line_fixed_x(x, y, x0, y0, y1) + real, intent(in) :: x !< non-dimensional x-coordinate [nondim] + real, intent(in) :: y !< non-dimensional y-coordinate [nondim] + real, intent(in) :: x0 !< x-position of line segment [nondim] + real, intent(in) :: y0 !< y-position of line segment end[nondim] + real, intent(in) :: y1 !< y-position of line segment end[nondim] + real :: dx, yr, dy + + dx = x - x0 + yr = min( max(y0,y1), max( min(y0,y1), y ) ) ! bound y by y0,y1 + dy = y - yr ! =0 within y0y1 + dist_line_fixed_x = sqrt( dx*dx + dy*dy ) +end function dist_line_fixed_x + +!> Distance between points x,y and a line segment (x0,y0) and (x1,y0). +real function dist_line_fixed_y(x, y, x0, x1, y0) + real, intent(in) :: x !< non-dimensional x-coordinate [nondim] + real, intent(in) :: y !< non-dimensional y-coordinate [nondim] + real, intent(in) :: x0 !< x-position of line segment end[nondim] + real, intent(in) :: x1 !< x-position of line segment end[nondim] + real, intent(in) :: y0 !< y-position of line segment [nondim] + + dist_line_fixed_y = dist_line_fixed_x(y, x, y0, x0, x1) +end function dist_line_fixed_y + +!> An "angled coast profile". +real function angled_coast(lon, lat, lon_eq, lat_mer, dr, sh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon_eq !< Longitude intersection with Equator [degrees_E] + real, intent(in) :: lat_mer !< Latitude intersection with Prime Meridian [degrees_N] + real, intent(in) :: dr !< "Radius" of coast profile [degrees] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: r + + r = 1/sqrt( lat_mer*lat_mer + lon_eq*lon_eq ) + r = r * ( lat_mer*lon + lon_eq*lat - lon_eq*lat_mer) + angled_coast = cstprof(r, 0., dr, 0.125, 0.125, 0.5, sh) +end function angled_coast + +!> A "coast profile" applied in an N-S line from lonC,lat0 to lonC,lat1. +real function NS_coast(lon, lat, lonC, lat0, lat1, dlon, sh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lonC !< Longitude of coast [degrees_E] + real, intent(in) :: lat0 !< Latitude of coast end [degrees_N] + real, intent(in) :: lat1 !< Latitude of coast end [degrees_N] + real, intent(in) :: dlon !< "Radius" of coast profile [degrees] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_x( lon, lat, lonC, lat0, lat1 ) + NS_coast = cstprof(r, 0., dlon, 0.125, 0.125, 0.5, sh) +end function NS_coast + +!> A "coast profile" applied in an E-W line from lon0,latC to lon1,latC. +real function EW_coast(lon, lat, latC, lon0, lon1, dlat, sh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: latC !< Latitude of coast [degrees_N] + real, intent(in) :: lon0 !< Longitude of coast end [degrees_E] + real, intent(in) :: lon1 !< Longitude of coast end [degrees_E] + real, intent(in) :: dlat !< "Radius" of coast profile [degrees] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_y( lon, lat, lon0, lon1, latC ) + EW_coast = cstprof(r, 0., dlat, 0.125, 0.125, 0.5, sh) +end function EW_coast + +!> A NS ridge with a cone profile +real function NS_conic_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lonC !< Longitude of ridge center [degrees_E] + real, intent(in) :: lat0 !< Latitude of ridge end [degrees_N] + real, intent(in) :: lat1 !< Latitude of ridge end [degrees_N] + real, intent(in) :: dlon !< "Radius" of ridge profile [degrees] + real, intent(in) :: rh !< depth of ridge as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_x( lon, lat, lonC, lat0, lat1 ) + NS_conic_ridge = 1. - rh * cone(r, 0., dlon) +end function NS_conic_ridge + +!> A NS ridge with an scurve profile +real function NS_scurve_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lonC !< Longitude of ridge center [degrees_E] + real, intent(in) :: lat0 !< Latitude of ridge end [degrees_N] + real, intent(in) :: lat1 !< Latitude of ridge end [degrees_N] + real, intent(in) :: dlon !< "Radius" of ridge profile [degrees] + real, intent(in) :: rh !< depth of ridge as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_x( lon, lat, lonC, lat0, lat1 ) + NS_scurve_ridge = 1. - rh * (1. - scurve(r, 0., dlon) ) +end function NS_scurve_ridge + +!> A circular ridge with cutoff conic profile +real function circ_conic_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridge_height) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon0 !< Longitude of center of ring [degrees_E] + real, intent(in) :: lat0 !< Latitude of center of ring [degrees_N] + real, intent(in) :: ring_radius !< Radius of ring [degrees] + real, intent(in) :: ring_thickness !< Radial thickness of ring [degrees] + real, intent(in) :: ridge_height !< Ridge height as fraction of full depth [nondim] + real :: r + + r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point + r = abs( r - ring_radius) ! Pseudo-distance from a circle + r = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height + circ_conic_ridge = 1. - r ! nondim depths (1-frac_ridge_height) .. 1 +end function circ_conic_ridge + +!> A circular ridge with cutoff scurve profile +real function circ_scurve_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridge_height) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon0 !< Longitude of center of ring [degrees_E] + real, intent(in) :: lat0 !< Latitude of center of ring [degrees_N] + real, intent(in) :: ring_radius !< Radius of ring [degrees] + real, intent(in) :: ring_thickness !< Radial thickness of ring [degrees] + real, intent(in) :: ridge_height !< Ridge height as fraction of full depth [nondim] + real :: r + + r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point + r = abs( r - ring_radius) ! Pseudo-distance from a circle + r = 1. - scurve(r, 0., ring_thickness) ! 0 .. 1 + r = r * ridge_height ! 0 .. frac_ridge_height + circ_scurve_ridge = 1. - r ! nondim depths (1-frac_ridge_height) .. 1 +end function circ_scurve_ridge + +end module basin_builder diff --git a/user/benchmark_initialization.F90 b/user/benchmark_initialization.F90 new file mode 100644 index 0000000000..333f53895e --- /dev/null +++ b/user/benchmark_initialization.F90 @@ -0,0 +1,302 @@ +!> Initialization for the "bench mark" configuration +module benchmark_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type + +implicit none ; private + +#include + +public benchmark_initialize_topography +public benchmark_initialize_thickness +public benchmark_init_temperature_salinity + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> This subroutine sets up the benchmark test case topography. +subroutine benchmark_initialize_topography(D, G, param_file, max_depth, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum model depth [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real :: min_depth ! The minimum basin depth [Z ~> m] + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: D0 ! A constant to make the maximum basin depth MAXIMUM_DEPTH [Z ~> m] + real :: x ! Longitude relative to the domain edge, normalized by its extent [nondim] + real :: y ! Latitude relative to the domain edge, normalized by its extent [nondim] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "benchmark_initialize_topography" ! This subroutine's name. + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + call MOM_mesg(" benchmark_initialization.F90, benchmark_initialize_topography: setting topography", 5) + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) + + PI = 4.0*atan(1.0) + D0 = max_depth / 0.5 + +! Calculate the depth of the bottom. + do j=js,je ; do i=is,ie + x = (G%geoLonT(i,j)-G%west_lon) / G%len_lon + y = (G%geoLatT(i,j)-G%south_lat) / G%len_lat +! This sets topography that has a reentrant channel to the south. + D(i,j) = -D0 * ( y*(1.0 + 0.6*cos(4.0*PI*x)) & + + 0.75*exp(-6.0*y) & + + 0.05*cos(10.0*PI*x) - 0.7 ) + if (D(i,j) > max_depth) D(i,j) = max_depth + if (D(i,j) < min_depth) D(i,j) = 0. + enddo ; enddo + +end subroutine benchmark_initialize_topography + +!> Initializes layer thicknesses for the benchmark test case, +!! by finding the depths of interfaces in a specified latitude-dependent +!! temperature profile with an exponentially decaying thermocline on top of a +!! linear stratification. +subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, eqn_of_state, & + P_Ref, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + real, intent(in) :: P_Ref !< The coordinate-density + !! reference pressure [R L2 T-2 ~> Pa]. + logical, intent(in) :: just_read !< If true, this call will + !! only read parameters without changing h. + ! Local variables + real :: e0(SZK_(GV)+1) ! The resting interface heights, in depth units [Z ~> m], + ! usually negative because it is positive upward. + real :: e_pert(SZK_(GV)+1) ! Interface height perturbations, positive upward, + ! in depth units [Z ~> m]. + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface + ! positive upward, in depth units [Z ~> m]. + real :: SST ! The initial sea surface temperature [C ~> degC]. + real :: S_ref ! A default value for salinities [S ~> ppt] + real :: T_light ! A first guess at the temperature of the lightest layer [C ~> degC] + real :: T_int ! The initial temperature of an interface [C ~> degC]. + real :: ML_depth ! The specified initial mixed layer depth, in depth units [Z ~> m]. + real :: thermocline_scale ! The e-folding scale of the thermocline, in depth units [Z ~> m]. + real, dimension(SZK_(GV)) :: & + T0, S0, & ! Profiles of temperature [C ~> degC] and salinity [S ~> ppt] + rho_guess, & ! Potential density at T0 & S0 [R ~> kg m-3]. + drho_dT, & ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1]. + drho_dS ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + real :: pres(SZK_(GV)) ! Reference pressure [R L2 T-2 ~> Pa]. + real :: a_exp ! The fraction of the overall stratification that is exponential [nondim] + real :: I_ts, I_md ! Inverse lengthscales [Z-1 ~> m-1]. + real :: T_frac ! A ratio of the interface temperature to the range + ! between SST and the bottom temperature [nondim]. + real :: err ! The normalized error between the profile's temperature and the + ! interface temperature for a given z [nondim] + real :: derr_dz ! The derivative of the normalized error between the profile's + ! temperature and the interface temperature with z [Z-1 ~> m-1] + real :: pi ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: z ! A work variable for the interface position [Z ~> m] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "benchmark_initialize_thickness" ! This subroutine's name. + integer :: i, j, k, k1, is, ie, js, je, nz, itt + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "BENCHMARK_ML_DEPTH_IC", ML_depth, & + "Initial mixed layer depth in the benchmark test case.", & + units='m', default=50.0, scale=US%m_to_Z, do_not_log=just_read) + call get_param(param_file, mdl, "BENCHMARK_THERMOCLINE_SCALE", thermocline_scale, & + "Initial thermocline depth scale in the benchmark test case.", & + default=500.0, units="m", scale=US%m_to_Z, do_not_log=just_read) + call get_param(param_file, mdl, "BENCHMARK_T_LIGHT", T_light, & + "A first guess at the temperature of the lightest layer in the benchmark test case.", & + units="degC", default=29.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, & + "The uniform salinities used to initialize the benchmark test case.", & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + + if (just_read) return ! This subroutine has no run-time parameters. + + call MOM_mesg(" benchmark_initialization.F90, benchmark_initialize_thickness: setting thickness", 5) + + k1 = GV%nk_rho_varies + 1 + + a_exp = 0.9 + +! This block calculates T0(k) for the purpose of diagnosing where the +! interfaces will be found. + do k=1,nz + pres(k) = P_Ref ; S0(k) = S_ref + enddo + T0(k1) = T_light + call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state) + call calculate_density_derivs(T0(k1), S0(k1), pres(k1), drho_dT(k1), drho_dS(k1), eqn_of_state) + +! A first guess of the layers' temperatures. + do k=1,nz + T0(k) = T0(k1) + (GV%Rlay(k) - rho_guess(k1)) / drho_dT(k1) + enddo + +! Refine the guesses for each layer. + do itt=1,6 + call calculate_density(T0, S0, pres, rho_guess, eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state) + do k=1,nz + T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + enddo + enddo + + pi = 4.0*atan(1.0) + I_ts = 1.0 / thermocline_scale + I_md = 1.0 / G%max_depth + do j=js,je ; do i=is,ie + SST = 0.5*(T0(k1)+T0(nz)) - 0.9*0.5*(T0(k1)-T0(nz)) * & + cos(pi*(G%geoLatT(i,j)-G%south_lat)/(G%len_lat)) + + do k=1,nz ; e_pert(K) = 0.0 ; enddo + + ! This sets the initial thickness (in [Z ~> m]) of the layers. The thicknesses + ! are set to insure that: + ! 1. each layer is at least GV%Angstrom_Z thick, and + ! 2. the interfaces are where they should be based on the resting depths and + ! interface height perturbations, as long at this doesn't interfere with 1. + eta1D(nz+1) = -depth_tot(i,j) + + do k=nz,2,-1 + T_int = 0.5*(T0(k) + T0(k-1)) + T_frac = (T_int - T0(nz)) / (SST - T0(nz)) + ! Find the z such that T_frac = a exp(z/thermocline_scale) + (1-a) (z+D)/D + z = 0.0 + do itt=1,6 + err = a_exp * exp(z*I_ts) + (1.0 - a_exp) * (z*I_md + 1.0) - T_frac + derr_dz = a_exp * I_ts * exp(z*I_ts) + (1.0 - a_exp) * I_md + z = z - err / derr_dz + enddo + e0(K) = z +! e0(K) = -ML_depth + thermocline_scale * log((T_int - T0(nz)) / (SST - T0(nz))) + + eta1D(K) = e0(K) + e_pert(K) + + if (eta1D(K) > -ML_depth) eta1D(K) = -ML_depth + + if (eta1D(K) < eta1D(K+1) + GV%Angstrom_Z) & + eta1D(K) = eta1D(K+1) + GV%Angstrom_Z + + h(i,j,k) = max(eta1D(K) - eta1D(K+1), GV%Angstrom_Z) + enddo + h(i,j,1) = max(0.0 - eta1D(2), GV%Angstrom_Z) + + enddo ; enddo + +end subroutine benchmark_initialize_thickness + +!> Initializes layer temperatures and salinities for benchmark +subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & + eqn_of_state, P_Ref, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature + !! that is being initialized [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is being + !! initialized [S ~> ppt] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for + !! model parameter values. + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + real, intent(in) :: P_Ref !< The coordinate-density + !! reference pressure [R L2 T-2 ~> Pa] + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T & S. + ! Local variables + real :: T0(SZK_(GV)) ! A profile of temperatures [C ~> degC] + real :: S0(SZK_(GV)) ! A profile of salinities [S ~> ppt] + real :: S_ref ! A default value for salinities [S ~> ppt] + real :: T_light ! A first guess at the temperature of the lightest layer [C ~> degC] + real :: pres(SZK_(GV)) ! Reference pressure [R L2 T-2 ~> Pa] + real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3] + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: SST ! The initial sea surface temperature [C ~> degC] + character(len=40) :: mdl = "benchmark_init_temperature_salinity" ! This subroutine's name. + integer :: i, j, k, k1, is, ie, js, je, nz, itt + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call get_param(param_file, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "BENCHMARK_T_LIGHT", T_light, & + units="degC", default=29.0, scale=US%degC_to_C, do_not_log=.true.) + + if (just_read) return ! All run-time parameters have been read, so return. + + k1 = GV%nk_rho_varies + 1 + + do k=1,nz + pres(k) = P_Ref ; S0(k) = S_ref + enddo + + T0(k1) = T_light + call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, (/k1,k1/) ) + +! A first guess of the layers' temperatures. ! + do k=1,nz + T0(k) = T0(k1) + (GV%Rlay(k) - rho_guess(k1)) / drho_dT(k1) + enddo + +! Refine the guesses for each layer. ! + do itt = 1,6 + call calculate_density(T0, S0, pres, rho_guess, eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state) + do k=1,nz + T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + enddo + enddo + + do k=1,nz ; do j=js,je ; do i=is,ie + T(i,j,k) = T0(k) + S(i,j,k) = S0(k) + enddo ; enddo ; enddo + PI = 4.0*atan(1.0) + do j=js,je ; do i=is,ie + SST = 0.5*(T0(k1)+T0(nz)) - 0.9*0.5*(T0(k1)-T0(nz)) * & + cos(PI*(G%geoLatT(i,j)-G%south_lat)/(G%len_lat)) + do k=1,k1-1 + T(i,j,k) = SST + enddo + enddo ; enddo + +end subroutine benchmark_init_temperature_salinity + +end module benchmark_initialization diff --git a/user/circle_obcs_initialization.F90 b/user/circle_obcs_initialization.F90 new file mode 100644 index 0000000000..ab9ab385de --- /dev/null +++ b/user/circle_obcs_initialization.F90 @@ -0,0 +1,122 @@ +!> Configures the model for the "circle_obcs" experiment which tests +!! Open Boundary Conditions radiating an SSH anomaly. +module circle_obcs_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public circle_obcs_initialize_thickness + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> This subroutine initializes layer thicknesses for the circle_obcs experiment. +subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + + real :: e0(SZK_(GV)+1) ! The resting interface heights, in depth units [Z ~> m], usually + ! negative because it is positive upward. + real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface + ! positive upward, in depth units [Z ~> m]. + real :: IC_amp ! The amplitude of the initial height displacement [Z ~> m]. + real :: diskrad ! Radius of the elevated disk [km] or [degrees] or [m] + real :: rad ! Distance from the center of the elevated disk [km] or [degrees] or [m] + real :: lonC ! The x-position of a point [km] or [degrees] or [m] + real :: latC ! The y-position of a point [km] or [degrees] or [m] + real :: xOffset ! The x-offset of the elevated disc center relative to the domain + ! center [km] or [degrees] or [m] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "circle_obcs_initialization" ! This module's name. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) & + call MOM_mesg(" circle_obcs_initialization.F90, circle_obcs_initialize_thickness: setting thickness", 5) + + if (.not.just_read) call log_version(param_file, mdl, version, "") + ! Parameters read by cartesian grid initialization + call get_param(param_file, mdl, "DISK_RADIUS", diskrad, & + "The radius of the initially elevated disk in the "//& + "circle_obcs test case.", units=G%x_ax_unit_short, & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "DISK_X_OFFSET", xOffset, & + "The x-offset of the initially elevated disk in the "//& + "circle_obcs test case.", units=G%x_ax_unit_short, & + default=0.0, do_not_log=just_read) + call get_param(param_file, mdl, "DISK_IC_AMPLITUDE", IC_amp, & + "Initial amplitude of interface height displacements "//& + "in the circle_obcs test case.", & + units='m', default=5.0, scale=US%m_to_Z, do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + do k=1,nz + e0(K) = -G%max_depth * real(k-1) / real(nz) + enddo + + ! Uniform thicknesses for base state + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(K) = e0(K) + if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then + eta1D(K) = eta1D(K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z + else + h(i,j,k) = eta1D(K) - eta1D(K+1) + endif + enddo + enddo ; enddo + + ! Perturb base state by circular anomaly in center + k=nz + latC = G%south_lat + 0.5*G%len_lat + lonC = G%west_lon + 0.5*G%len_lon + xOffset + do j=js,je ; do i=is,ie + rad = sqrt((G%geoLonT(i,j)-lonC)**2+(G%geoLatT(i,j)-latC)**2)/(diskrad) + ! if (rad <= 6.*diskrad) h(i,j,k) = h(i,j,k)+10.0*exp( -0.5*( rad**2 ) ) + rad = min( rad, 1. ) ! Flatten outside radius of diskrad + rad = rad*(2.*asin(1.)) ! Map 0-1 to 0-pi + if (nz==1) then + ! The model is barotropic + h(i,j,k) = h(i,j,k) + IC_amp * 0.5*(1.+cos(rad)) ! cosine bell + else + ! The model is baroclinic + do k = 1, nz + h(i,j,k) = h(i,j,k) - 0.5*(1.+cos(rad)) * IC_amp * real( 2*k-nz ) + enddo + endif + enddo ; enddo + +end subroutine circle_obcs_initialize_thickness + +end module circle_obcs_initialization diff --git a/user/dense_water_initialization.F90 b/user/dense_water_initialization.F90 new file mode 100644 index 0000000000..2daf03ccb1 --- /dev/null +++ b/user/dense_water_initialization.F90 @@ -0,0 +1,338 @@ +!> Initialization routines for the dense water formation +!! and overflow experiment. +module dense_water_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_EOS, only : EOS_type +use MOM_error_handler, only : MOM_error, FATAL +use MOM_file_parser, only : get_param, param_file_type +use MOM_interface_heights, only : dz_to_thickness, dz_to_thickness_simple +use MOM_grid, only : ocean_grid_type +use MOM_sponge, only : sponge_CS +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public dense_water_initialize_topography +public dense_water_initialize_TS +public dense_water_initialize_sponges + +character(len=40) :: mdl = "dense_water_initialization" !< Module name + +real, parameter :: default_sill = 0.2 !< Default depth of the sill [nondim] +real, parameter :: default_shelf = 0.4 !< Default depth of the shelf [nondim] +real, parameter :: default_mld = 0.25 !< Default depth of the mixed layer [nondim] + +contains + +!> Initialize the topography field for the dense water experiment +subroutine dense_water_initialize_topography(D, G, param_file, max_depth) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] + + ! Local variables + real, dimension(5) :: domain_params ! nondimensional widths of all domain sections [nondim] + real :: sill_frac ! Depth of the sill separating downslope from upslope, as a fraction of + ! the basin depth [nondim] + real :: shelf_frac ! Depth of the shelf region accumulating dense water for overflow, + ! as a fraction the basin depth [nondim] + real :: x ! Horizontal position normalized by the domain width [nondim] + integer :: i, j + + call get_param(param_file, mdl, "DENSE_WATER_DOMAIN_PARAMS", domain_params, & + "Fractional widths of all the domain sections for the dense water experiment.\n"//& + "As a 5-element vector:\n"//& + " - open ocean, the section at maximum depth\n"//& + " - downslope, the downward overflow slope\n"//& + " - sill separating downslope from upslope\n"//& + " - upslope, the upward slope accumulating dense water\n"//& + " - the shelf in the dense formation region.", & + units="nondim", fail_if_missing=.true.) + call get_param(param_file, mdl, "DENSE_WATER_SILL_DEPTH", sill_frac, & + "Depth of the sill separating downslope from upslope, as fraction of basin depth.", & + units="nondim", default=default_sill) + call get_param(param_file, mdl, "DENSE_WATER_SHELF_DEPTH", shelf_frac, & + "Depth of the shelf region accumulating dense water for overflow, as fraction of basin depth.", & + units="nondim", default=default_shelf) + + do i = 2, 5 + ! turn widths into positions + domain_params(i) = domain_params(i-1) + domain_params(i) + enddo + + do j = G%jsc,G%jec + do i = G%isc,G%iec + ! compute normalised zonal coordinate + x = (G%geoLonT(i,j) - G%west_lon) / G%len_lon + + if (x <= domain_params(1)) then + ! open ocean region + D(i,j) = max_depth + elseif (x <= domain_params(2)) then + ! downslope region, linear + D(i,j) = max_depth - (1.0 - sill_frac) * max_depth * & + (x - domain_params(1)) / (domain_params(2) - domain_params(1)) + elseif (x <= domain_params(3)) then + ! sill region + D(i,j) = sill_frac * max_depth + elseif (x <= domain_params(4)) then + ! upslope region + D(i,j) = sill_frac * max_depth + (shelf_frac - sill_frac) * max_depth * & + (x - domain_params(3)) / (domain_params(4) - domain_params(3)) + else + ! shelf region + D(i,j) = shelf_frac * max_depth + endif + enddo + enddo + +end subroutine dense_water_initialize_topography + +!> Initialize the temperature and salinity for the dense water experiment +subroutine dense_water_initialize_TS(G, GV, US, param_file, T, S, h, just_read) + type(ocean_grid_type), intent(in) :: G !< Horizontal grid control structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Output temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Output salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [Z ~> m] + logical, intent(in) :: just_read !< If true, this call will + !! only read parameters without changing T & S. + ! Local variables + real :: mld ! The initial mixed layer depth as a fraction of the maximum depth [nondim] + real :: S_ref, S_range ! The reference salinity and its range in the initial conditions [S ~> ppt] + real :: T_ref ! The reference temperature [C ~> degC] + real :: zi, zmid ! Depths from the surface nondimensionalized by the maximum depth [nondim] + integer :: i, j, k, nz + + nz = GV%ke + + call get_param(param_file, mdl, "DENSE_WATER_MLD", mld, & + "Depth of unstratified mixed layer as a fraction of the water column.", & + units="nondim", default=default_mld, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl,"T_REF", T_ref, 'Reference temperature', & + units='degC', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl,"S_RANGE", S_range, 'Initial salinity range', & + units="ppt", default=2.0, scale=US%ppt_to_S, do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + ! uniform temperature everywhere + T(:,:,:) = T_ref + + do j = G%jsc,G%jec + do i = G%isc,G%iec + zi = 0. + do k = 1,nz + ! nondimensional middle of layer + zmid = zi + 0.5 * h(i,j,k) / G%max_depth + + if (zmid < mld) then + ! use reference salinity in the mixed layer + S(i,j,k) = S_ref + else + ! linear between bottom of mixed layer and bottom + S(i,j,k) = S_ref + S_range * (zmid - mld) / (1.0 - mld) + endif + + zi = zi + h(i,j,k) / G%max_depth + enddo + enddo + enddo +end subroutine dense_water_initialize_TS + +!> Initialize the restoring sponges for the dense water experiment +subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_ALE, CSp, ACSp) + type(ocean_grid_type), intent(in) :: G !< Horizontal grid control structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + logical, intent(in) :: use_ALE !< ALE flag + type(sponge_CS), pointer :: CSp !< Layered sponge control structure pointer + type(ALE_sponge_CS), pointer :: ACSp !< ALE sponge control structure pointer + + ! Local variables + real :: west_sponge_time_scale, east_sponge_time_scale ! Sponge timescales [T ~> s] + real :: west_sponge_width ! The fraction of the domain in which the western (outflow) sponge is active [nondim] + real :: east_sponge_width ! The fraction of the domain in which the eastern (outflow) sponge is active [nondim] + + real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! sponge layer thicknesses in height units [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h ! sponge layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: T ! sponge temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: S ! sponge salinity [S ~> ppt] + real, dimension(SZK_(GV)+1) :: e0, eta1D ! interface positions for ALE sponge [Z ~> m] + real :: x ! Horizontal position normalized by the domain width [nondim] + real :: zi, zmid ! Depths from the surface nondimensionalized by the maximum depth [nondim] + real :: dist ! Distance from the edge of a sponge normalized by the width of that sponge [nondim] + real :: mld ! The initial mixed layer depth as a fraction of the maximum depth [nondim] + real :: S_ref, S_range ! The reference salinity and its range in the initial conditions [S ~> ppt] + real :: S_dense ! The salinity of the dense water being formed on the shelf [S ~> ppt] + real :: T_ref ! The reference temperature [C ~> degC] + real :: sill_frac ! Fractional depths of the sill, relative to the maximum depth [nondim] + integer :: i, j, k, nz + + nz = GV%ke + + call get_param(param_file, mdl, "DENSE_WATER_WEST_SPONGE_TIME_SCALE", west_sponge_time_scale, & + "The time scale on the west (outflow) of the domain for restoring. "//& + "If zero, the sponge is disabled.", units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "DENSE_WATER_WEST_SPONGE_WIDTH", west_sponge_width, & + "The fraction of the domain in which the western (outflow) sponge is active.", & + units="nondim", default=0.1) + call get_param(param_file, mdl, "DENSE_WATER_EAST_SPONGE_TIME_SCALE", east_sponge_time_scale, & + "The time scale on the east (outflow) of the domain for restoring. "//& + "If zero, the sponge is disabled.", units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "DENSE_WATER_EAST_SPONGE_WIDTH", east_sponge_width, & + "The fraction of the domain in which the eastern (outflow) sponge is active.", & + units="nondim", default=0.1) + call get_param(param_file, mdl, "DENSE_WATER_EAST_SPONGE_SALT", S_dense, & + "Salt anomaly of the dense water being formed in the overflow region.", & + units="ppt", default=4.0, scale=US%ppt_to_S) + + call get_param(param_file, mdl, "DENSE_WATER_MLD", mld, & + units="nondim", default=default_mld, do_not_log=.true.) + call get_param(param_file, mdl, "DENSE_WATER_SILL_DEPTH", sill_frac, & + units="nondim", default=default_sill, do_not_log=.true.) + + call get_param(param_file, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "S_RANGE", S_range, & + units="ppt", default=2.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "T_REF", T_ref, & + units='degC', scale=US%degC_to_C, fail_if_missing=.true., do_not_log=.true.) + + ! no active sponges + if (west_sponge_time_scale <= 0. .and. east_sponge_time_scale <= 0.) return + + ! everywhere is initially unsponged + Idamp(:,:) = 0.0 + + do j = G%jsc, G%jec + do i = G%isc,G%iec + if (G%mask2dT(i,j) > 0.) then + ! nondimensional x position + x = (G%geoLonT(i,j) - G%west_lon) / G%len_lon + + if (west_sponge_time_scale > 0. .and. x < west_sponge_width) then + dist = 1. - x / west_sponge_width + ! scale restoring by depth into sponge + Idamp(i,j) = 1. / west_sponge_time_scale * max(0., min(1., dist)) + elseif (east_sponge_time_scale > 0. .and. x > (1. - east_sponge_width)) then + dist = 1. - (1. - x) / east_sponge_width + Idamp(i,j) = 1. / east_sponge_time_scale * max(0., min(1., dist)) + endif + endif + enddo + enddo + + if (use_ALE) then + ! construct a uniform grid for the sponge + do k = 1,nz + e0(k) = -G%max_depth * (real(k - 1) / real(nz)) + enddo + e0(nz+1) = -G%max_depth + + do j = G%jsc,G%jec + do i = G%isc,G%iec + eta1D(nz+1) = -depth_tot(i,j) + do k = nz,1,-1 + eta1D(k) = e0(k) + + if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then + ! is this layer vanished? + eta1D(k) = eta1D(k+1) + GV%Angstrom_Z + dz(i,j,k) = GV%Angstrom_Z + else + dz(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo + enddo + + ! construct temperature and salinity for the sponge + ! start with initial condition + T(:,:,:) = T_ref + S(:,:,:) = S_ref + + do j = G%jsc,G%jec + do i = G%isc,G%iec + zi = 0. + x = (G%geoLonT(i,j) - G%west_lon) / G%len_lon + do k = 1,nz + ! nondimensional middle of layer + zmid = zi + 0.5 * dz(i,j,k) / G%max_depth + + if (x > (1. - east_sponge_width)) then + !if (zmid >= 0.9 * sill_frac) & + S(i,j,k) = S_ref + S_dense + else + ! linear between bottom of mixed layer and bottom + if (zmid >= mld) & + S(i,j,k) = S_ref + S_range * (zmid - mld) / (1.0 - mld) + endif + + zi = zi + dz(i,j,k) / G%max_depth + enddo + enddo + enddo + + ! Convert thicknesses from height units to thickness units + if (associated(tv%eqn_of_state)) then + call dz_to_thickness(dz, T, S, tv%eqn_of_state, h, G, GV, US) + else + call dz_to_thickness_simple(dz, h, G, GV, US, layer_mode=.true.) + endif + + ! This call sets up the damping rates and interface heights in the sponges. + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) + + if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp, 'temp', & + sp_long_name='temperature', sp_unit='degC s-1') + if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & + sp_long_name='salinity', sp_unit='g kg-1 s-1') + else + call MOM_error(FATAL, "dense_water_initialize_sponges: trying to use non ALE sponge") + endif +end subroutine dense_water_initialize_sponges + +end module dense_water_initialization + +!> \namespace dense_water_initialization +!! +!! This experiment consists of a shelf accumulating dense water, which spills +!! over an upward slope and a sill, before flowing down a slope into an open +!! ocean region. It's intended as a test of one of the motivating situations +!! for the adaptive coordinate. +!! +!! The nondimensional widths of the 5 regions are controlled by the +!! DENSE_WATER_DOMAIN_PARAMS, and the heights of the sill and shelf +!! as a fraction of the total domain depth are controlled by +!! DENSE_WATER_SILL_DEPTH and DENSE_WATER_SHELF_DEPTH. +!! +!! The density in the domain is governed by a linear equation of state, and +!! is set up with a mixed layer of non-dimensional depth DENSE_WATER_MLD +!! below which there is a linear stratification from S_REF, increasing +!! by S_RANGE to the bottom. +!! +!! To force the experiment, there are sponges on the inflow and outflow of the +!! domain. The inflow sponge has a salinity anomaly of +!! DENSE_WATER_EAST_SPONGE_SALT through the entire depth. The outflow +!! sponge simply restores to the initial condition. Both sponges have controllable +!! widths and restoring timescales. diff --git a/user/dumbbell_initialization.F90 b/user/dumbbell_initialization.F90 new file mode 100644 index 0000000000..3d968d85d0 --- /dev/null +++ b/user/dumbbell_initialization.F90 @@ -0,0 +1,500 @@ +!> Configures the model for the idealized dumbbell test case. +module dumbbell_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domains, only : sum_across_PEs +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : dz_to_thickness, dz_to_thickness_simple +use MOM_interface_heights, only : thickness_to_dz +use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR +use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA, REGRIDDING_HYCOM1 +use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge + +implicit none ; private + +#include + +character(len=40) :: mdl = "dumbbell_initialization" !< This module's name. + +public dumbbell_initialize_topography +public dumbbell_initialize_thickness +public dumbbell_initialize_temperature_salinity +public dumbbell_initialize_sponges + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> Initialization of topography. +subroutine dumbbell_initialize_topography( D, G, param_file, max_depth ) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] + + ! Local variables + real :: x, y ! Fractional x- and y- positions [nondim] + real :: dblen ! Lateral length scale for dumbbell [km] or [m] + real :: dbfrac ! Meridional fraction for narrow part of dumbbell [nondim] + logical :: dbrotate ! If true, rotate this configuration + integer :: i, j + + call get_param(param_file, mdl, "DUMBBELL_LEN", dblen, & + 'Lateral Length scale for dumbbell.', & + units=G%x_ax_unit_short, default=600., do_not_log=.false.) + call get_param(param_file, mdl, "DUMBBELL_FRACTION", dbfrac, & + 'Meridional fraction for narrow part of dumbbell.', & + units='nondim', default=0.5, do_not_log=.false.) + call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & + 'Logical for rotation of dumbbell domain.', & + default=.false., do_not_log=.false.) + + if (G%x_axis_units(1:1) == 'm') then + dblen = dblen*1.e3 + endif + + if (dbrotate) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + x = ( G%geoLonT(i,j) ) / G%len_lon + y = ( G%geoLatT(i,j) ) / dblen + D(i,j) = G%max_depth + if ((y>=-0.25 .and. y<=0.25) .and. (x <= -0.5*dbfrac .or. x >= 0.5*dbfrac)) then + D(i,j) = 0.0 + endif + enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + x = ( G%geoLonT(i,j) ) / dblen + y = ( G%geoLatT(i,j) ) / G%len_lat + D(i,j) = G%max_depth + if ((x>=-0.25 .and. x<=0.25) .and. (y <= -0.5*dbfrac .or. y >= 0.5*dbfrac)) then + D(i,j) = 0.0 + endif + enddo ; enddo + endif + +end subroutine dumbbell_initialize_topography + +!> Initializes the layer thicknesses to be uniform in the dumbbell test case +subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually + ! negative because it is positive upward. + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface + ! positive upward [Z ~> m]. + real :: min_thickness ! The minimum layer thicknesses [Z ~> m]. + real :: S_ref ! A default value for salinities [S ~> ppt]. + real :: S_surf ! The surface salinity [S ~> ppt] + real :: S_range ! The range of salinities in this test case [S ~> ppt] + real :: S_light, S_dense ! The lightest and densest salinities in the sponges [S ~> ppt]. + real :: eta_IC_quanta ! The granularity of quantization of initial interface heights [Z-1 ~> m-1]. + real :: x ! Along-channel position in the axis units [m] or [km] or [deg] + logical :: dbrotate ! If true, rotate the domain. + logical :: use_ALE ! True if ALE is being used, False if in layered mode + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=20) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) & + call MOM_mesg("dumbbell_initialization.F90, dumbbell_initialize_thickness: setting thickness") + + if (.not.just_read) call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & + 'Minimum thickness for layer', & + units='m', default=1.0e-3, scale=US%m_to_Z, do_not_log=just_read) + call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, default=.false., do_not_log=.true.) + if (.not. use_ALE) verticalCoordinate = "LAYER" + + ! WARNING: this routine specifies the interface heights so that the last layer + ! is vanished, even at maximum depth. In order to have a uniform + ! layer distribution, use this line of code within the loop: + ! e0(k) = -G%max_depth * real(k-1) / real(nz) + ! To obtain a thickness distribution where the last layer is + ! vanished and the other thicknesses uniformly distributed, use: + ! e0(k) = -G%max_depth * real(k-1) / real(nz-1) + !do k=1,nz+1 + ! e0(k) = -G%max_depth * real(k-1) / real(nz) + !enddo + + select case ( coordinateMode(verticalCoordinate) ) + case ( REGRIDDING_LAYER) ! Initial thicknesses for isopycnal coordinates + call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & + 'Logical for rotation of dumbbell domain.', & + default=.false., do_not_log=just_read) + do j=js,je + do i=is,ie + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + if (dbrotate) then + ! This is really y in the rotated case + x = G%geoLatT(i,j) + else + x = G%geoLonT(i,j) + endif + eta1D(1) = 0.0 + eta1D(nz+1) = -depth_tot(i,j) + if (x<0.0) then + do k=nz,2, -1 + eta1D(k) = eta1D(k+1) + min_thickness + enddo + else + do k=2,nz + eta1D(k) = eta1D(k-1) - min_thickness + enddo + endif + do k=1,nz + h(i,j,k) = eta1D(k) - eta1D(k+1) + enddo + enddo + enddo + + case ( REGRIDDING_RHO, REGRIDDING_HYCOM1) ! Initial thicknesses for isopycnal coordinates + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, & + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "INITIAL_S_RANGE", S_range, & + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "INTERFACE_IC_QUANTA", eta_IC_quanta, & + "The granularity of initial interface height values "//& + "per meter, to avoid sensivity to order-of-arithmetic changes.", & + default=2048.0, units="m-1", scale=US%Z_to_m, do_not_log=just_read) + if (just_read) return ! All run-time parameters have been read, so return. + + do K=1,nz+1 + ! Salinity of layer k is S_light + (k-1)/(nz-1) * (S_dense - S_light) + ! Salinity of interface K is S_light + (K-3/2)/(nz-1) * (S_dense - S_light) + ! Salinity at depth z should be S(z) = S_surf - S_range * z/max_depth + ! Equating: S_surf - S_range * z/max_depth = S_light + (K-3/2)/(nz-1) * (S_dense - S_light) + ! Equating: - S_range * z/max_depth = S_light - S_surf + (K-3/2)/(nz-1) * (S_dense - S_light) + ! Equating: z/max_depth = - ( S_light - S_surf + (K-3/2)/(nz-1) * (S_dense - S_light) ) / S_range + e0(K) = - G%max_depth * ( ( S_light - S_surf ) + ( S_dense - S_light ) * & + ( (real(K)-1.5) / real(nz-1) ) ) / S_range + ! Force round numbers ... the above expression has irrational factors ... + if (eta_IC_quanta > 0.0) & + e0(K) = nint(eta_IC_quanta*e0(K)) / eta_IC_quanta + e0(K) = min(real(1-K)*GV%Angstrom_Z, e0(K)) ! Bound by surface + e0(K) = max(-G%max_depth, e0(K)) ! Bound by bottom + enddo + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(k) = e0(k) + if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then + eta1D(k) = eta1D(k+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + case ( REGRIDDING_ZSTAR ) ! Initial thicknesses for z coordinates + if (just_read) return ! All run-time parameters have been read, so return. + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(k) = -G%max_depth * real(k-1) / real(nz) + if (eta1D(k) < (eta1D(k+1) + min_thickness)) then + eta1D(k) = eta1D(k+1) + min_thickness + h(i,j,k) = min_thickness + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + 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,:) = depth_tot(i,j) / real(nz) + enddo ; enddo + +end select + +end subroutine dumbbell_initialize_thickness + +!> Initial values for temperature and salinity for the dumbbell test case +subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + logical, intent(in) :: just_read !< If true, this call will + !! only read parameters without changing h. + + ! Local variables + integer :: i, j, k, is, ie, js, je, nz + real :: S_surf ! The surface salinity [S ~> ppt] + real :: S_range ! The range of salinities in this test case [S ~> ppt] + real :: T_surf ! The surface temperature [C ~> degC] + real :: x ! The fractional position in the domain [nondim] + real :: dblen ! The size of the dumbbell test case [km] or [m] + logical :: dbrotate ! If true, rotate the domain. + logical :: use_ALE ! If false, use layer mode. + character(len=20) :: verticalCoordinate, density_profile + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + ! layer mode + call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, default=.false., do_not_log=.true.) + if (.not. use_ALE) call MOM_error(FATAL, "dumbbell_initialize_temperature_salinity: "//& + "Please use 'fit' for 'TS_CONFIG' in the LAYER mode.") + + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + call get_param(param_file, mdl, "INITIAL_DENSITY_PROFILE", density_profile, & + 'Initial profile shape. Valid values are "linear", "parabolic" '// & + 'and "exponential".', default='linear', do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_T_SURF", T_surf, & + 'Initial surface temperature in the DUMBBELL configuration', & + units='degC', default=20., scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_SREF", S_surf, & + 'DUMBBELL REFERENCE SALINITY', & + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_S_RANGE", S_range, & + 'DUMBBELL salinity range (right-left)', & + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_LEN", dblen, & + 'Lateral Length scale for dumbbell ', & + units=G%x_ax_unit_short, default=600., do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & + 'Logical for rotation of dumbbell domain.', & + default=.false., do_not_log=just_read) + + if (G%x_axis_units(1:1) == 'm') then + dblen = dblen*1.e3 + endif + + do j=G%jsc,G%jec + do i=G%isc,G%iec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + if (dbrotate) then + ! This is really y in the rotated case + x = ( G%geoLatT(i,j) ) / dblen + else + x = ( G%geoLonT(i,j) ) / dblen + endif + do k=1,nz + T(i,j,k) = T_surf + enddo + if (x>=0. ) then + do k=1,nz + S(i,j,k) = S_surf + 0.5*S_range + enddo + endif + if (x<0. ) then + do k=1,nz + S(i,j,k) = S_surf - 0.5*S_range + enddo + endif + + enddo + enddo + +end subroutine dumbbell_initialize_temperature_salinity + +!> Initialize the restoring sponges for the dumbbell test case +subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_file, use_ALE, CSp, ACSp) + type(ocean_grid_type), intent(in) :: G !< Horizontal grid control structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + logical, intent(in) :: use_ALE !< ALE flag + type(sponge_CS), pointer :: CSp !< Layered sponge control structure pointer + type(ALE_sponge_CS), pointer :: ACSp !< ALE sponge control structure pointer + + real :: sponge_time_scale ! The damping time scale [T ~> s] + + real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale [T-1 ~> s-1] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge thicknesses in height units [Z ~> m] + real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge thicknesses [H ~> m or kg m-2] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge salinities [S ~> ppt] + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge tempertures [C ~> degC], used only to convert thicknesses + ! in non-Boussinesq mode + real, dimension(SZK_(GV)+1) :: eta1D ! Interface positions for ALE sponge [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! A temporary array for interface heights [Z ~> m]. + + integer :: i, j, k, nz + real :: x ! The fractional position in the domain [nondim] + real :: dblen ! The size of the dumbbell test case [km] or [m] + real :: min_thickness ! The minimum layer thickness [Z ~> m] + real :: S_ref, S_range ! A reference salinity and the range of salinities in this test case [S ~> ppt] + real :: T_surf ! The surface temperature [C ~> degC] + logical :: dbrotate ! If true, rotate the domain. + + call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & + 'Lateral Length scale for dumbbell ', & + units='km', default=600., do_not_log=.true.) + call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & + 'Logical for rotation of dumbbell domain.', & + default=.false., do_not_log=.true.) + + if (G%x_axis_units(1:1) == 'm') then + dblen = dblen*1.e3 + endif + + nz = GV%ke + + call get_param(param_file, mdl, "DUMBBELL_SPONGE_TIME_SCALE", sponge_time_scale, & + "The time scale in the reservoir for restoring. If zero, the sponge is disabled.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "DUMBBELL_T_SURF", T_surf, & + 'Initial surface temperature in the DUMBBELL configuration', & + units='degC', default=20., scale=US%degC_to_C, do_not_log=.true.) + call get_param(param_file, mdl, "DUMBBELL_SREF", S_ref, & + 'DUMBBELL REFERENCE SALINITY', & + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "DUMBBELL_S_RANGE", S_range, & + 'DUMBBELL salinity range (right-left)', & + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & + 'Minimum thickness for layer', & + units='m', default=1.0e-3, scale=US%m_to_Z, do_not_log=.true.) + + ! no active sponges + if (sponge_time_scale <= 0.) return + + ! everywhere is initially unsponged + Idamp(:,:) = 0.0 + + do j = G%jsc, G%jec + do i = G%isc,G%iec + if (G%mask2dT(i,j) > 0.) then + ! nondimensional x position + if (dbrotate) then + ! This is really y in the rotated case + x = ( G%geoLatT(i,j) ) / dblen + else + x = ( G%geoLonT(i,j) ) / dblen + endif + if (x > 0.25 .or. x < -0.25) then + ! scale restoring by depth into sponge + Idamp(i,j) = 1. / sponge_time_scale + endif + endif + enddo + enddo + + if (use_ALE) then + ! construct a uniform grid for the sponge + do j=G%jsc,G%jec ; do i=G%isc,G%iec + eta1D(nz+1) = depth_tot(i,j) + do k=nz,1,-1 + eta1D(k) = -G%max_depth * real(k-1) / real(nz) + if (eta1D(k) < (eta1D(k+1) + min_thickness)) then + eta1D(k) = eta1D(k+1) + min_thickness + dz(i,j,k) = min_thickness + else + dz(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + ! construct temperature and salinity for the sponge + ! start with initial condition + S(:,:,:) = 0.0 + T(:,:,:) = T_surf + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + if (dbrotate) then + ! This is really y in the rotated case + x = ( G%geoLatT(i,j) ) / dblen + else + x = ( G%geoLonT(i,j) ) / dblen + endif + if (x>=0.25 ) then + do k=1,nz + S(i,j,k) = S_ref + 0.5*S_range + enddo + endif + if (x<=-0.25 ) then + do k=1,nz + S(i,j,k) = S_ref - 0.5*S_range + enddo + endif + enddo ; enddo + + ! Convert thicknesses from height units to thickness units + if (associated(tv%eqn_of_state)) then + call dz_to_thickness(dz, T, S, tv%eqn_of_state, h, G, GV, US) + else + call dz_to_thickness_simple(dz, h, G, GV, US, layer_mode=.true.) + endif + + ! Store damping rates and the grid on which the T/S sponge data will reside + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) + + if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & + sp_long_name='salinity', sp_unit='g kg-1 s-1') + else + ! Convert thicknesses from thickness units to height units + call thickness_to_dz(h_in, tv, dz, G, GV, US) + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + eta(i,j,1) = 0.0 + do k=2,nz + eta(i,j,k) = eta(i,j,k-1) - dz(i,j,k-1) + enddo + eta(i,j,nz+1) = -depth_tot(i,j) + do k=1,nz + S(i,j,k)= tv%S(i,j,k) + enddo + enddo ; enddo + + ! This call sets up the damping rates and interface heights. + ! This sets the inverse damping timescale fields in the sponges. ! + call initialize_sponge(Idamp, eta, G, param_file, CSp, GV) + + ! The remaining calls to set_up_sponge_field can be in any order. ! + if ( associated(tv%S) ) call set_up_sponge_field(S, tv%S, G, GV, nz, CSp) + endif + +end subroutine dumbbell_initialize_sponges + +end module dumbbell_initialization diff --git a/user/dumbbell_surface_forcing.F90 b/user/dumbbell_surface_forcing.F90 new file mode 100644 index 0000000000..288ccd89fa --- /dev/null +++ b/user/dumbbell_surface_forcing.F90 @@ -0,0 +1,276 @@ +!> Surface forcing for the dumbbell test case +module dumbbell_surface_forcing + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : post_data, query_averaging_enabled +use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_domains, only : pass_var, pass_vector, AGRID +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, param_file_type, log_version +use MOM_forcing_type, only : forcing, allocate_forcing_type +use MOM_grid, only : ocean_grid_type +use MOM_safe_alloc, only : safe_alloc_ptr +use MOM_time_manager, only : time_type, operator(+), operator(/), get_time +use MOM_tracer_flow_control, only : call_tracer_set_forcing +use MOM_tracer_flow_control, only : tracer_flow_control_CS +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface + +implicit none ; private + +public dumbbell_dynamic_forcing, dumbbell_buoyancy_forcing, dumbbell_surface_forcing_init + +!> Control structure for the dumbbell test case forcing +type, public :: dumbbell_surface_forcing_CS ; private + logical :: use_temperature !< If true, temperature and salinity are used as state variables. + logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. + real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: Flux_const !< The restoring rate at the surface [R Z T-1 ~> kg m-2 s-1]. +! real :: gust_const !< A constant unresolved background gustiness +! !! that contributes to ustar [R L Z T-2 ~> Pa]. + real :: slp_amplitude !< The amplitude of pressure loading [R L2 T-2 ~> Pa] applied + !! to the reservoirs + real :: slp_period !< Period of sinusoidal pressure wave [days] + real, dimension(:,:), allocatable :: & + forcing_mask !< A mask regulating where forcing occurs [nondim] + real, dimension(:,:), allocatable :: & + S_restore !< The surface salinity field toward which to restore [S ~> ppt]. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the + !! timing of diagnostic output. +end type dumbbell_surface_forcing_CS + +contains + +!> Surface buoyancy (heat and fresh water) fluxes for the dumbbell test case +subroutine dumbbell_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL ptrs. + type(time_type), intent(in) :: day !< Time of the fluxes. + real, intent(in) :: dt !< The amount of time over which + !! the fluxes apply [T ~> s] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(dumbbell_surface_forcing_CS), pointer :: CS !< A control structure returned by a previous + !! call to dumbbell_surface_forcing_init + ! Local variables + integer :: i, j, is, ie, js, je + integer :: isd, ied, jsd, jed + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + + ! Allocate and zero out the forcing arrays, as necessary. + if (CS%use_temperature) then + call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) + + call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) + else ! This is the buoyancy only mode. + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) + endif + + + ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. + + if ( CS%use_temperature ) then + ! Set whichever fluxes are to be used here. Any fluxes that + ! are always zero do not need to be changed here. + do j=js,je ; do i=is,ie + ! Fluxes of fresh water through the surface are in units of [R Z T-1 ~> kg m-2 s-1] + ! and are positive downward - i.e. evaporation should be negative. + fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) + fluxes%lprec(i,j) = 0.0 * G%mask2dT(i,j) + + ! vprec will be set later, if it is needed for salinity restoring. + fluxes%vprec(i,j) = 0.0 + + ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. + fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%sw(i,j) = 0.0 * G%mask2dT(i,j) + enddo ; enddo + else ! This is the buoyancy only mode. + do j=js,je ; do i=is,ie + ! fluxes%buoy is the buoyancy flux into the ocean [L2 T-3 ~> m2 s-3]. A positive + ! buoyancy flux is of the same sign as heating the ocean. + fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) + enddo ; enddo + endif + + if (CS%use_temperature .and. CS%restorebuoy) then + do j=js,je ; do i=is,ie + if (CS%forcing_mask(i,j)>0.) then + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * CS%Flux_const) * & + ((CS%S_restore(i,j) - sfc_state%SSS(i,j)) / (0.5 * (CS%S_restore(i,j) + sfc_state%SSS(i,j)))) + + endif + enddo ; enddo + endif + +end subroutine dumbbell_buoyancy_forcing + +!> Dynamic forcing for the dumbbell test case +subroutine dumbbell_dynamic_forcing(sfc_state, fluxes, day, dt, G, US, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL ptrs. + type(time_type), intent(in) :: day !< Time of the fluxes. + real, intent(in) :: dt !< The amount of time over which + !! the fluxes apply [T ~> s] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(dumbbell_surface_forcing_CS), pointer :: CS !< A control structure returned by a previous + !! call to dumbbell_surface_forcing_init + ! Local variables + integer :: i, j, is, ie, js, je + integer :: isd, ied, jsd, jed + integer :: idays, isecs + real :: deg_rad ! A conversion factor from degrees to radians [nondim] + real :: rdays ! The elapsed time [days] + + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + deg_rad = atan(1.0)*4.0/180. + + call get_time(day,isecs,idays) + rdays = real(idays) + real(isecs)/8.64e4 + ! This could be: rdays = time_type_to_real(day)/8.64e4 + + ! Allocate and zero out the forcing arrays, as necessary. + call safe_alloc_ptr(fluxes%p_surf, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%p_surf_full, isd, ied, jsd, jed) + + do j=js,je ; do i=is,ie + fluxes%p_surf(i,j) = CS%forcing_mask(i,j)* CS%slp_amplitude * & + G%mask2dT(i,j) * sin(deg_rad*(rdays/CS%slp_period)) + fluxes%p_surf_full(i,j) = CS%forcing_mask(i,j) * CS%slp_amplitude * & + G%mask2dT(i,j) * sin(deg_rad*(rdays/CS%slp_period)) + enddo ; enddo + +end subroutine dumbbell_dynamic_forcing + +!> Reads and sets up the forcing for the dumbbell test case +subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to + !! regulate diagnostic output. + type(dumbbell_surface_forcing_CS), & + pointer :: CS !< A pointer to the control structure for this module + ! Local variables + real :: S_surf ! Initial surface salinity [S ~> ppt] + real :: S_range ! Range of the initial vertical distribution of salinity [S ~> ppt] + real :: x ! Latitude normalized by the domain size [nondim] + real :: Rho0 ! The density used in the Boussinesq approximation [R ~> kg m-3] + real :: rho_restore ! The density that is used to convert piston velocities into salt + ! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] + integer :: i, j + logical :: dbrotate ! If true, rotate the domain. +# include "version_variable.h" + character(len=40) :: mdl = "dumbbell_surface_forcing" ! This module's name. + + if (associated(CS)) then + call MOM_error(WARNING, "dumbbell_surface_forcing_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + CS%diag => diag + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & + "If true, Temperature and salinity are used as state variables.", default=.true.) + + call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & + "The gravitational acceleration of the Earth.", & + units="m s-2", default=9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) + call get_param(param_file, mdl, "RHO_0", Rho0, & + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "DUMBBELL_SLP_AMP", CS%slp_amplitude, & + "Amplitude of SLP forcing in reservoirs.", & + units="Pa", default=10000.0, scale=US%Pa_to_RL2_T2) + call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & + "Periodicity of SLP forcing in reservoirs.", & + units="days", default=1.0) + call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & + 'Logical for rotation of dumbbell domain.',& + default=.false., do_not_log=.true.) + call get_param(param_file, mdl,"INITIAL_SSS", S_surf, & + "Initial surface salinity", & + units="ppt", default=34.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, & + "Initial salinity range (bottom - surface)", & + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) + + call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & + "If true, the buoyancy fluxes drive the model back "//& + "toward some specified surface state with a rate "//& + "given by FLUXCONST.", default=.false.) + if (CS%restorebuoy) then + call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0)) + ! Convert FLUXCONST from m day-1 to m s-1 and Flux_const to [R Z T-1 ~> kg m-2 s-1] + CS%Flux_const = rho_restore * (CS%Flux_const / 86400.0) + + + allocate(CS%forcing_mask(G%isd:G%ied, G%jsd:G%jed), source=0.0) + allocate(CS%S_restore(G%isd:G%ied, G%jsd:G%jed)) + + do j=G%jsc,G%jec + do i=G%isc,G%iec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) +! x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon - 0.5 +! y = ( G%geoLatT(i,j) - G%south_lat ) / G%len_lat - 0.5 + if (dbrotate) then + ! This is really y in the rotated case + x = ( G%geoLatT(i,j) - G%south_lat ) / G%len_lat - 0.5 + else + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon - 0.5 + endif + CS%forcing_mask(i,j)=0 + CS%S_restore(i,j) = S_surf + if ((x>0.25)) then + CS%forcing_mask(i,j) = 1 + CS%S_restore(i,j) = S_surf + S_range + elseif ((x<-0.25)) then + CS%forcing_mask(i,j) = 1 + CS%S_restore(i,j) = S_surf - S_range + endif + enddo + enddo + endif + +end subroutine dumbbell_surface_forcing_init + +end module dumbbell_surface_forcing diff --git a/user/dyed_channel_initialization.F90 b/user/dyed_channel_initialization.F90 new file mode 100644 index 0000000000..2dde65148b --- /dev/null +++ b/user/dyed_channel_initialization.F90 @@ -0,0 +1,198 @@ +!> Initialization for the dyed_channel configuration +module dyed_channel_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer +use MOM_open_boundary, only : OBC_registry_type, register_OBC +use MOM_time_manager, only : time_type, time_type_to_real +use MOM_tracer_registry, only : tracer_registry_type, tracer_name_lookup +use MOM_tracer_registry, only : tracer_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public dyed_channel_set_OBC_tracer_data, dyed_channel_OBC_end +public register_dyed_channel_OBC, dyed_channel_update_flow + +!> Control structure for dyed-channel open boundaries. +type, public :: dyed_channel_OBC_CS ; private + real :: zonal_flow = 8.57 !< Mean inflow [L T-1 ~> m s-1] + real :: tidal_amp = 0.0 !< Sloshing amplitude [L T-1 ~> m s-1] + real :: frequency = 0.0 !< Sloshing frequency [T-1 ~> s-1] +end type dyed_channel_OBC_CS + +integer :: ntr = 0 !< Number of dye tracers + !! \todo This is a module variable. Move this variable into the control structure. + +contains + +!> Add dyed channel to OBC registry. +function register_dyed_channel_OBC(param_file, CS, US, OBC_Reg) + type(param_file_type), intent(in) :: param_file !< parameter file. + type(dyed_channel_OBC_CS), pointer :: CS !< Dyed channel control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. + ! Local variables + logical :: register_dyed_channel_OBC + character(len=32) :: casename = "dyed channel" ! This case's name. + character(len=40) :: mdl = "register_dyed_channel_OBC" ! This subroutine's name. + + if (associated(CS)) then + call MOM_error(WARNING, "register_dyed_channel_OBC called with an "// & + "associated control structure.") + return + endif + allocate(CS) + + call get_param(param_file, mdl, "CHANNEL_MEAN_FLOW", CS%zonal_flow, & + "Mean zonal flow imposed at upstream open boundary.", & + units="m/s", default=8.57, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "CHANNEL_TIDAL_AMP", CS%tidal_amp, & + "Sloshing amplitude imposed at upstream open boundary.", & + units="m/s", default=0.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "CHANNEL_FLOW_FREQUENCY", CS%frequency, & + "Frequency of oscillating zonal flow.", & + units="s-1", default=0.0, scale=US%T_to_s) + + ! Register the open boundaries. + call register_OBC(casename, param_file, OBC_Reg) + register_dyed_channel_OBC = .true. + +end function register_dyed_channel_OBC + +!> Clean up the dyed_channel OBC from registry. +subroutine dyed_channel_OBC_end(CS) + type(dyed_channel_OBC_CS), pointer :: CS !< Dyed channel control structure. + + if (associated(CS)) then + deallocate(CS) + endif +end subroutine dyed_channel_OBC_end + +!> This subroutine sets the dye and flow properties at open boundary conditions. +subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. + ! Local variables + character(len=40) :: mdl = "dyed_channel_set_OBC_tracer_data" ! This subroutine's name. + character(len=80) :: name, longname + integer :: m, n, ntr_id + real :: dye ! Inflow dye concentrations [arbitrary] + type(tracer_type), pointer :: tr_ptr => NULL() + + if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & + 'dyed_channel_set_OBC_data() was called but OBC type was not initialized!') + + call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & + "The number of dye tracers in this run. Each tracer "//& + "should have a separate boundary segment.", default=0, & + do_not_log=.true.) + + if (OBC%number_of_segments < ntr) then + call MOM_error(WARNING, "Error in dyed_obc segment setup") + return !!! Need a better error message here + endif + +! ! Set the inflow values of the dyes, one per segment. +! ! We know the order: north, south, east, west + do m=1,ntr + write(name,'("dye_",I2.2)') m + write(longname,'("Concentration of dyed_obc Tracer ",I2.2, " on segment ",I2.2)') m, m + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + + do n=1,OBC%number_of_segments + if (n == m) then + dye = 1.0 + else + dye = 0.0 + endif + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, & + OBC%segment(n), OBC_scalar=dye) + enddo + enddo + +end subroutine dyed_channel_set_OBC_tracer_data + +!> This subroutine updates the long-channel flow +subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, Time) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(dyed_channel_OBC_CS), pointer :: CS !< Dyed channel control structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(time_type), intent(in) :: Time !< model time. + ! Local variables + real :: flow ! The OBC velocity [L T-1 ~> m s-1] + real :: PI ! 3.1415926535... [nondim] + real :: time_sec ! The elapsed time since the start of the calendar [T ~> s] + integer :: i, j, k, l, isd, ied, jsd, jed + integer :: IsdB, IedB, JsdB, JedB + type(OBC_segment_type), pointer :: segment => NULL() + + if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & + 'dyed_channel_update_flow() was called but OBC type was not initialized!') + + time_sec = US%s_to_T * time_type_to_real(Time) + PI = 4.0*atan(1.0) + + do l=1, OBC%number_of_segments + segment => OBC%segment(l) + if (.not. segment%on_pe) cycle + if (segment%gradient) cycle + if (segment%oblique .and. .not. segment%nudged .and. .not. segment%Flather) cycle + + if (segment%is_E_or_W) then + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + if (CS%frequency == 0.0) then + flow = CS%zonal_flow + else + flow = CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec) + endif + do k=1,GV%ke + do j=jsd,jed ; do I=IsdB,IedB + if (segment%specified .or. segment%nudged) then + segment%normal_vel(I,j,k) = flow + endif + if (segment%specified) then + segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) + endif + enddo ; enddo + enddo + do j=jsd,jed ; do I=IsdB,IedB + segment%normal_vel_bt(I,j) = flow + enddo ; enddo + else + isd = segment%HI%isd ; ied = segment%HI%ied + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + do J=JsdB,JedB ; do i=isd,ied + segment%normal_vel_bt(i,J) = 0.0 + enddo ; enddo + endif + enddo + +end subroutine dyed_channel_update_flow + +!> \namespace dyed_channel_initialization +!! +!! Setting dyes, one for painting the inflow on each side. +end module dyed_channel_initialization diff --git a/user/dyed_obcs_initialization.F90 b/user/dyed_obcs_initialization.F90 new file mode 100644 index 0000000000..7d1c0635f9 --- /dev/null +++ b/user/dyed_obcs_initialization.F90 @@ -0,0 +1,86 @@ +!> Dyed open boundary conditions +module dyed_obcs_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer +use MOM_tracer_registry, only : tracer_registry_type, tracer_name_lookup +use MOM_tracer_registry, only : tracer_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public dyed_obcs_set_OBC_data + +integer :: ntr = 0 !< Number of dye tracers + !! \todo This is a module variable. Move this variable into the control structure. + +contains + +!> This subroutine sets the dye properties at open boundary conditions. +subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. + ! Local variables + character(len=40) :: mdl = "dyed_obcs_set_OBC_data" ! This subroutine's name. + character(len=80) :: name, longname + integer :: is, ie, js, je, isd, ied, jsd, jed, m, n, nz, ntr_id + integer :: IsdB, IedB, JsdB, JedB + real :: dye ! Inflow dye concentration [arbitrary] + type(tracer_type), pointer :: tr_ptr => NULL() + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(OBC)) return + + call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & + "The number of dye tracers in this run. Each tracer "//& + "should have a separate boundary segment.", default=0, & + do_not_log=.true.) + + if (OBC%number_of_segments < ntr) then + call MOM_error(WARNING, "Error in dyed_obc segment setup") + return !!! Need a better error message here + endif + +! ! Set the inflow values of the dyes, one per segment. +! ! We know the order: north, south, east, west + do m=1,ntr + write(name,'("dye_",I2.2)') m + write(longname,'("Concentration of dyed_obc Tracer ",I2.2, " on segment ",I2.2)') m, m + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + + do n=1,OBC%number_of_segments + if (n == m) then + dye = 1.0 + else + dye = 0.0 + endif + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, & + OBC%segment(n), OBC_scalar=dye) + enddo + enddo + +end subroutine dyed_obcs_set_OBC_data + +!> \namespace dyed_obcs_initialization +!! +!! Setting dyes, one for painting the inflow on each side. +end module dyed_obcs_initialization diff --git a/user/external_gwave_initialization.F90 b/user/external_gwave_initialization.F90 new file mode 100644 index 0000000000..437edc49b2 --- /dev/null +++ b/user/external_gwave_initialization.F90 @@ -0,0 +1,82 @@ +!> Initialization for the "external gravity wave wave" configuration +module external_gwave_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +implicit none ; private + +#include + +public external_gwave_initialize_thickness + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> This subroutine initializes layer thicknesses for the external_gwave experiment. +subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + ! Local variables + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface + ! positive upward [Z ~> m]. + real :: ssh_anomaly_height ! Vertical height of ssh anomaly [Z ~> m] + real :: ssh_anomaly_width ! Lateral width of anomaly, often in [km] or [degrees_E] + character(len=40) :: mdl = "external_gwave_initialize_thickness" ! This subroutine's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + integer :: i, j, k, is, ie, js, je, nz + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: Xnondim ! A normalized x position [nondim] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) & + call MOM_mesg(" external_gwave_initialization.F90, external_gwave_initialize_thickness: setting thickness", 5) + + if (.not.just_read) call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "SSH_ANOMALY_HEIGHT", ssh_anomaly_height, & + "The vertical displacement of the SSH anomaly. ", & + units="m", scale=US%m_to_Z, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "SSH_ANOMALY_WIDTH", ssh_anomaly_width, & + "The lateral width of the SSH anomaly. ", & + units=G%x_ax_unit_short, fail_if_missing=.not.just_read, do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + PI = 4.0*atan(1.0) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + Xnondim = (G%geoLonT(i,j)-G%west_lon-0.5*G%len_lon) / ssh_anomaly_width + Xnondim = min(1., abs(Xnondim)) + eta1D(1) = ssh_anomaly_height * 0.5 * ( 1. + cos(PI*Xnondim) ) ! Cosine bell + do k=2,nz + eta1D(K) = -G%max_depth & ! Stretch interior interfaces with SSH + + (eta1D(1)+G%max_depth) * ( real(nz+1-k)/real(nz) ) ! Stratification + enddo + eta1D(nz+1) = -G%max_depth ! Force bottom interface to bottom + do k=1,nz + h(i,j,k) = eta1D(K) - eta1D(K+1) + enddo + enddo ; enddo + +end subroutine external_gwave_initialize_thickness + +end module external_gwave_initialization diff --git a/user/lock_exchange_initialization.F90 b/user/lock_exchange_initialization.F90 new file mode 100644 index 0000000000..ab08d4068d --- /dev/null +++ b/user/lock_exchange_initialization.F90 @@ -0,0 +1,90 @@ +!> Initialization of the "lock exchange" experiment. +!! lock_exchange = A 2-d density driven hydraulic exchange flow. +module lock_exchange_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public lock_exchange_initialize_thickness + +contains + +!> This subroutine initializes layer thicknesses for the lock_exchange experiment. +! ----------------------------------------------------------------------------- +subroutine lock_exchange_initialize_thickness(h, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + + real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface + ! positive upward [Z ~> m]. + real :: front_displacement ! Vertical displacement across front [Z ~> m] + real :: thermocline_thickness ! Thickness of stratified region [Z ~> m] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "lock_exchange_initialize_thickness" ! This subroutine's name. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) & + call MOM_mesg(" lock_exchange_initialization.F90, lock_exchange_initialize_thickness: setting thickness", 5) + + if (.not.just_read) call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "FRONT_DISPLACEMENT", front_displacement, & + "The vertical displacement of interfaces across the front. "//& + "A value larger in magnitude that MAX_DEPTH is truncated,", & + units="m", fail_if_missing=.not.just_read, do_not_log=just_read, scale=US%m_to_Z) + call get_param(param_file, mdl, "THERMOCLINE_THICKNESS", thermocline_thickness, & + "The thickness of the thermocline in the lock exchange "//& + "experiment. A value of zero creates a two layer system "//& + "with vanished layers in between the two inflated layers.", & + default=0., units="m", do_not_log=just_read, scale=US%m_to_Z) + + if (just_read) return ! All run-time parameters have been read, so return. + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + do k=2,nz + eta1D(K) = -0.5 * G%max_depth & ! Middle of column + - thermocline_thickness * ( (real(k-1))/real(nz) -0.5 ) ! Stratification + if (G%geoLonT(i,j)-G%west_lon < 0.5 * G%len_lon) then + eta1D(K) = eta1D(K) + 0.5 * front_displacement + elseif (G%geoLonT(i,j)-G%west_lon > 0.5 * G%len_lon) then + eta1D(K) = eta1D(K) - 0.5 * front_displacement + endif + enddo + eta1D(nz+1) = -G%max_depth ! Force bottom interface to bottom + do k=nz,2,-1 ! Make sure interfaces increase upwards + eta1D(K) = max( eta1D(K), eta1D(K+1) + GV%Angstrom_Z ) + enddo + eta1D(1) = 0. ! Force bottom interface to bottom + do k=2,nz ! Make sure interfaces decrease downwards + eta1D(K) = min( eta1D(K), eta1D(K-1) - GV%Angstrom_Z ) + enddo + do k=nz,1,-1 + h(i,j,k) = eta1D(K) - eta1D(K+1) + enddo + enddo ; enddo + +end subroutine lock_exchange_initialize_thickness +! ----------------------------------------------------------------------------- + +end module lock_exchange_initialization diff --git a/user/seamount_initialization.F90 b/user/seamount_initialization.F90 new file mode 100644 index 0000000000..60aef08cb4 --- /dev/null +++ b/user/seamount_initialization.F90 @@ -0,0 +1,308 @@ +!> Configures the model for the idealized seamount test case. +module seamount_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domains, only : sum_across_PEs +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR +use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA + +implicit none ; private + +#include + +character(len=40) :: mdl = "seamount_initialization" !< This module's name. + +! The following routines are visible to the outside world +public seamount_initialize_topography +public seamount_initialize_thickness +public seamount_initialize_temperature_salinity + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> Initialization of topography. +subroutine seamount_initialize_topography( D, G, param_file, max_depth ) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] + + ! Local variables + real :: delta ! Height of the seamount as a fraction of the maximum ocean depth [nondim] + real :: x, y ! Normalized positions relative to the domain center [nondim] + real :: Lx, Ly ! Seamount length scales normalized by the relevant domain sizes [nondim] + real :: rLx, rLy ! The Adcroft reciprocals of Lx and Ly [nondim] + integer :: i, j + + call get_param(param_file, mdl,"SEAMOUNT_DELTA", delta, & + "Non-dimensional height of seamount.", & + units="nondim", default=0.5) + call get_param(param_file, mdl,"SEAMOUNT_X_LENGTH_SCALE", Lx, & + "Length scale of seamount in x-direction. "//& + "Set to zero make topography uniform in the x-direction.", & + units=G%x_ax_unit_short, default=20.) + call get_param(param_file, mdl,"SEAMOUNT_Y_LENGTH_SCALE", Ly, & + "Length scale of seamount in y-direction. "//& + "Set to zero make topography uniform in the y-direction.", & + units=G%y_ax_unit_short, default=0.) + + Lx = Lx / G%len_lon + Ly = Ly / G%len_lat + rLx = 0. ; if (Lx>0.) rLx = 1. / Lx + rLy = 0. ; if (Ly>0.) rLy = 1. / Ly + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon - 0.5 + y = ( G%geoLatT(i,j) - G%south_lat ) / G%len_lat - 0.5 + D(i,j) = G%max_depth * ( 1.0 - delta * exp(-(rLx*x)**2 -(rLy*y)**2) ) + enddo ; enddo + +end subroutine seamount_initialize_topography + +!> Initialization of thicknesses. +!! This subroutine initializes the layer thicknesses to be uniform. +subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually + ! negative because it is positive upward. + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m] + real :: min_thickness ! The minimum layer thicknesses [Z ~> m]. + real :: S_ref ! A default value for salinities [S ~> ppt]. + real :: S_surf, S_range, S_light, S_dense ! Various salinities [S ~> ppt]. + real :: eta_IC_quanta ! The granularity of quantization of intial interface heights [Z-1 ~> m-1]. + character(len=20) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) & + call MOM_mesg("seamount_initialization.F90, seamount_initialize_thickness: setting thickness") + + call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness, & + 'Minimum thickness for layer', & + units='m', default=1.0e-3, do_not_log=just_read, scale=US%m_to_Z) + call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE",verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + + ! WARNING: this routine specifies the interface heights so that the last layer + ! is vanished, even at maximum depth. In order to have a uniform + ! layer distribution, use this line of code within the loop: + ! e0(k) = -G%max_depth * real(k-1) / real(nz) + ! To obtain a thickness distribution where the last layer is + ! vanished and the other thicknesses uniformly distributed, use: + ! e0(k) = -G%max_depth * real(k-1) / real(nz-1) + !do k=1,nz+1 + ! e0(k) = -G%max_depth * real(k-1) / real(nz) + !enddo + + select case ( coordinateMode(verticalCoordinate) ) + + case ( REGRIDDING_LAYER, REGRIDDING_RHO ) ! Initial thicknesses for isopycnal coordinates + call get_param(param_file, mdl,"INITIAL_SSS", S_surf, & + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, & + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "INTERFACE_IC_QUANTA", eta_IC_quanta, & + "The granularity of initial interface height values "//& + "per meter, to avoid sensivity to order-of-arithmetic changes.", & + default=2048.0, units="m-1", scale=US%Z_to_m, do_not_log=just_read) + if (just_read) return ! All run-time parameters have been read, so return. + + do K=1,nz+1 + ! Salinity of layer k is S_light + (k-1)/(nz-1) * (S_dense - S_light) + ! Salinity of interface K is S_light + (K-3/2)/(nz-1) * (S_dense - S_light) + ! Salinity at depth z should be S(z) = S_surf - S_range * z/max_depth + ! Equating: S_surf - S_range * z/max_depth = S_light + (K-3/2)/(nz-1) * (S_dense - S_light) + ! Equating: - S_range * z/max_depth = S_light - S_surf + (K-3/2)/(nz-1) * (S_dense - S_light) + ! Equating: z/max_depth = - ( S_light - S_surf + (K-3/2)/(nz-1) * (S_dense - S_light) ) / S_range + e0(K) = - G%max_depth * ( ( S_light - S_surf ) + ( S_dense - S_light ) * & + ( (real(K)-1.5) / real(nz-1) ) ) / S_range + ! Force round numbers ... the above expression has irrational factors ... + if (eta_IC_quanta > 0.0) & + e0(K) = nint(eta_IC_quanta*e0(K)) / eta_IC_quanta + e0(K) = min(real(1-K)*GV%Angstrom_Z, e0(K)) ! Bound by surface + e0(K) = max(-G%max_depth, e0(K)) ! Bound by bottom + enddo + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(k) = e0(k) + if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then + eta1D(k) = eta1D(k+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + case ( REGRIDDING_ZSTAR ) ! Initial thicknesses for z coordinates + if (just_read) return ! All run-time parameters have been read, so return. + do j=js,je ; do i=is,ie + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(k) = -G%max_depth * real(k-1) / real(nz) + if (eta1D(k) < (eta1D(k+1) + min_thickness)) then + eta1D(k) = eta1D(k+1) + min_thickness + h(i,j,k) = min_thickness + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + 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,:) = depth_tot(i,j) / real(nz) + enddo ; enddo + +end select + +end subroutine seamount_initialize_thickness + +!> Initial values for temperature and salinity +subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + logical, intent(in) :: just_read !< If true, this call will + !! only read parameters without changing T & S. + + ! Local variables + real :: xi0, xi1 ! Fractional positions within the depth range [nondim] + real :: r ! A nondimensional sharpness parameter with an exponetial profile [nondim] + real :: S_Ref ! Default salinity range parameters [S ~> ppt]. + real :: T_Ref ! Default temperature range parameters [C ~> degC]. + real :: S_Light, S_Dense, S_surf, S_range ! Salinity range parameters [S ~> ppt]. + real :: T_Light, T_Dense, T_surf, T_range ! Temperature range parameters [C ~> degC]. + real :: res_rat ! The ratio of density space resolution in the denser part + ! of the range to that in the lighter part of the range. + ! Setting this greater than 1 increases the resolution for + ! the denser water [nondim]. + real :: a1, frac_dense, k_frac ! Nondimensional temporary variables [nondim] + integer :: i, j, k, is, ie, js, je, nz, k_light + + character(len=20) :: verticalCoordinate, density_profile + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + call get_param(param_file, mdl,"INITIAL_DENSITY_PROFILE", density_profile, & + 'Initial profile shape. Valid values are "linear", "parabolic" '//& + 'and "exponential".', default='linear', do_not_log=just_read) + call get_param(param_file, mdl,"INITIAL_SSS", S_surf, & + 'Initial surface salinity', & + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl,"INITIAL_SST", T_surf, & + 'Initial surface temperature', & + units="degC", default=0., scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, & + 'Initial salinity range (bottom - surface)', & + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl,"INITIAL_T_RANGE", T_range, & + 'Initial temperature range (bottom - surface)', & + units="degC", default=0., scale=US%degC_to_C, do_not_log=just_read) + + select case ( coordinateMode(verticalCoordinate) ) + case ( REGRIDDING_LAYER ) ! Initial thicknesses for layer isopycnal coordinates + ! These parameters are used in MOM_fixed_initialization.F90 when CONFIG_COORD="ts_range" + call get_param(param_file, mdl, "T_REF", T_ref, & + units="degC", default=10.0, scale=US%degC_to_C, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_T_LIGHT", T_light, & + units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_T_DENSE", T_dense, & + units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, & + units="nondim", default=1.0, do_not_log=.true.) + if (just_read) return ! All run-time parameters have been read, so return. + + ! Emulate the T,S used in the "ts_range" coordinate configuration code + k_light = GV%nk_rho_varies + 1 + do j=js,je ; do i=is,ie + T(i,j,k_light) = T_light ; S(i,j,k_light) = S_light + enddo ; enddo + a1 = 2.0 * res_rat / (1.0 + res_rat) + do k=k_light+1,nz + k_frac = real(k-k_light)/real(nz-k_light) + frac_dense = a1 * k_frac + (1.0 - a1) * k_frac**2 + do j=js,je ; do i=is,ie + T(i,j,k) = frac_dense * (T_Dense - T_Light) + T_Light + S(i,j,k) = frac_dense * (S_Dense - S_Light) + S_Light + enddo ; enddo + enddo + case ( REGRIDDING_SIGMA, REGRIDDING_ZSTAR, REGRIDDING_RHO ) ! All other coordinate use FV initialization + if (just_read) return ! All run-time parameters have been read, so return. + do j=js,je ; do i=is,ie + xi0 = 0.0 + do k = 1,nz + xi1 = xi0 + h(i,j,k) / G%max_depth + select case ( trim(density_profile) ) + case ('linear') + !S(i,j,k) = S_surf + S_range * 0.5 * (xi0 + xi1) + S(i,j,k) = S_surf + ( 0.5 * S_range ) * (xi0 + xi1) ! Coded this way to reproduce old hard-coded answers + T(i,j,k) = T_surf + T_range * 0.5 * (xi0 + xi1) + case ('parabolic') + S(i,j,k) = S_surf + S_range * (2.0 / 3.0) * (xi1**3 - xi0**3) / (xi1 - xi0) + T(i,j,k) = T_surf + T_range * (2.0 / 3.0) * (xi1**3 - xi0**3) / (xi1 - xi0) + case ('exponential') + r = 0.8 ! small values give sharp profiles + S(i,j,k) = S_surf + S_range * (exp(xi1/r)-exp(xi0/r)) / (xi1 - xi0) + T(i,j,k) = T_surf + T_range * (exp(xi1/r)-exp(xi0/r)) / (xi1 - xi0) + case default + call MOM_error(FATAL, 'Unknown value for "INITIAL_DENSITY_PROFILE"') + end select + xi0 = xi1 + enddo + enddo ; enddo + end select + +end subroutine seamount_initialize_temperature_salinity + +end module seamount_initialization diff --git a/user/shelfwave_initialization.F90 b/user/shelfwave_initialization.F90 new file mode 100644 index 0000000000..df46a142f1 --- /dev/null +++ b/user/shelfwave_initialization.F90 @@ -0,0 +1,184 @@ +!> Configures the model for the idealized shelfwave test case. +module shelfwave_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domains, only : sum_across_PEs +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_W +use MOM_open_boundary, only : OBC_segment_type, register_OBC +use MOM_open_boundary, only : OBC_registry_type +use MOM_time_manager, only : time_type, time_type_to_real +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +character(len=40) :: mdl = "shelfwave_initialization" !< This module's name. + +! The following routines are visible to the outside world +public shelfwave_initialize_topography +public shelfwave_set_OBC_data +public register_shelfwave_OBC, shelfwave_OBC_end + +!> Control structure for shelfwave open boundaries. +type, public :: shelfwave_OBC_CS ; private + real :: my_amp !< Amplitude of the open boundary current inflows [L T-1 ~> m s-1] + real :: Lx = 100.0 !< Long-shore length scale of bathymetry [km] or [m] + real :: Ly = 50.0 !< Cross-shore length scale [km] or [m] + real :: f0 = 1.e-4 !< Coriolis parameter [T-1 ~> s-1] + real :: jj = 1.0 !< Cross-shore wave mode [nondim] + real :: kk !< Cross-shore wavenumber [km-1] or [m-1] + real :: ll !< Longshore wavenumber [km-1] or [m-1] + real :: alpha !< Exponential decay rate in the y-direction [km-1] or [m-1] + real :: omega !< Frequency of the shelf wave [T-1 ~> s-1] +end type shelfwave_OBC_CS + +contains + +!> Add shelfwave to OBC registry. +function register_shelfwave_OBC(param_file, CS, G, US, OBC_Reg) + type(param_file_type), intent(in) :: param_file !< parameter file. + type(shelfwave_OBC_CS), pointer :: CS !< shelfwave control structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(OBC_registry_type), pointer :: OBC_Reg !< Open boundary condition registry. + logical :: register_shelfwave_OBC + + ! Local variables + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + character(len=32) :: casename = "shelfwave" !< This case's name. + + PI = 4.0*atan(1.0) + + if (associated(CS)) then + call MOM_error(WARNING, "register_shelfwave_OBC called with an "// & + "associated control structure.") + return + endif + allocate(CS) + + ! Register the tracer for horizontal advection & diffusion. + call register_OBC(casename, param_file, OBC_Reg) + call get_param(param_file, mdl, "F_0", CS%f0, & + default=0.0, units="s-1", scale=US%T_to_s, do_not_log=.true.) + call get_param(param_file, mdl,"SHELFWAVE_X_WAVELENGTH", CS%Lx, & + "Length scale of shelfwave in x-direction.",& + units=G%x_ax_unit_short, default=100.) + call get_param(param_file, mdl, "SHELFWAVE_Y_LENGTH_SCALE", CS%Ly, & + "Length scale of exponential dropoff of topography in the y-direction.", & + units=G%y_ax_unit_short, default=50.) + call get_param(param_file, mdl, "SHELFWAVE_Y_MODE", CS%jj, & + "Cross-shore wave mode.", & + units="nondim", default=1.) + call get_param(param_file, mdl, "SHELFWAVE_AMPLITUDE", CS%my_amp, & + "Amplitude of the open boundary current inflows in the shelfwave configuration.", & + units="m s-1", default=1.0, scale=US%m_s_to_L_T) + + CS%alpha = 1. / CS%Ly + CS%ll = 2. * PI / CS%Lx + CS%kk = CS%jj * PI / G%len_lat + CS%omega = 2 * CS%alpha * CS%f0 * CS%ll / & + (CS%kk*CS%kk + CS%alpha*CS%alpha + CS%ll*CS%ll) + register_shelfwave_OBC = .true. + +end function register_shelfwave_OBC + +!> Clean up the shelfwave OBC from registry. +subroutine shelfwave_OBC_end(CS) + type(shelfwave_OBC_CS), pointer :: CS !< shelfwave control structure. + + if (associated(CS)) then + deallocate(CS) + endif +end subroutine shelfwave_OBC_end + +!> Initialization of topography. +subroutine shelfwave_initialize_topography( D, G, param_file, max_depth, US ) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum model depth [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real :: y ! Position relative to the southern boundary [km] or [m] or [degrees_N] + real :: rLy ! Exponential decay rate of the topography [km-1] or [m-1] or [degrees_N-1] + real :: Ly ! Exponential decay lengthscale of the topography [km] or [m] or [degrees_N] + real :: H0 ! The minimum depth of the ocean [Z ~> m] + integer :: i, j + + call get_param(param_file, mdl,"SHELFWAVE_Y_LENGTH_SCALE", Ly, & + units=G%y_ax_unit_short, default=50., do_not_log=.true.) + call get_param(param_file, mdl,"MINIMUM_DEPTH", H0, & + units="m", default=10., scale=US%m_to_Z, do_not_log=.true.) + + rLy = 0. ; if (Ly>0.) rLy = 1. / Ly + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + y = ( G%geoLatT(i,j) - G%south_lat ) + D(i,j) = H0 * exp(2 * rLy * y) + enddo ; enddo + +end subroutine shelfwave_initialize_topography + +!> This subroutine sets the properties of flow at open boundary conditions. +subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(shelfwave_OBC_CS), pointer :: CS !< tidal bay control structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] + type(time_type), intent(in) :: Time !< model time. + + ! The following variables are used to set up the transport in the shelfwave example. + real :: time_sec ! The time in the run [T ~> s] + real :: cos_wt, sin_wt ! Cosine and sine associated with the propagating x-direction structure [nondim] + real :: cos_ky, sin_ky ! Cosine and sine associated with the y-direction structure [nondim] + real :: x, y ! Positions relative to the western and southern boundaries [km] or [m] or [degrees] + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, n + integer :: IsdB, IedB, JsdB, JedB + type(OBC_segment_type), pointer :: segment => NULL() + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(OBC)) return + + time_sec = US%s_to_T*time_type_to_real(Time) + do n = 1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%direction /= OBC_DIRECTION_W) cycle + + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + jsd = segment%HI%jsd ; jed = segment%HI%jed + do j=jsd,jed ; do I=IsdB,IedB + x = G%geoLonCu(I,j) - G%west_lon + y = G%geoLatCu(I,j) - G%south_lat + sin_wt = sin(CS%ll*x - CS%omega*time_sec) + cos_wt = cos(CS%ll*x - CS%omega*time_sec) + sin_ky = sin(CS%kk * y) + cos_ky = cos(CS%kk * y) + segment%normal_vel_bt(I,j) = CS%my_amp * exp(- CS%alpha * y) * cos_wt * & + (CS%alpha * sin_ky + CS%kk * cos_ky) +! segment%tangential_vel_bt(I,j) = CS%my_amp * CS%ll * exp(- CS%alpha * y) * sin_wt * sin_ky +! segment%vorticity_bt(I,j) = CS%my_amp * exp(- CS%alpha * y) * cos_wt * sin_ky& +! (CS%ll**2 + CS%kk**2 + CS%alpha**2) + enddo ; enddo + enddo + +end subroutine shelfwave_set_OBC_data + +end module shelfwave_initialization diff --git a/user/sloshing_initialization.F90 b/user/sloshing_initialization.F90 new file mode 100644 index 0000000000..4381d42038 --- /dev/null +++ b/user/sloshing_initialization.F90 @@ -0,0 +1,255 @@ +!> Initialization for the "sloshing" internal waves configuration. +module sloshing_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domains, only : sum_across_PEs +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +! The following routines are visible to the outside world +public sloshing_initialize_topography +public sloshing_initialize_thickness +public sloshing_initialize_temperature_salinity + +contains + +!> Initialization of topography. +subroutine sloshing_initialize_topography( D, G, param_file, max_depth ) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] + + ! Local variables + integer :: i, j + + do i=G%isc,G%iec ; do j=G%jsc,G%jec + D(i,j) = max_depth + enddo ; enddo + +end subroutine sloshing_initialize_topography + + +!> Initialization of thicknesses +!! This routine is called when THICKNESS_CONFIG is set to 'sloshing' +!! +!! This routine initializes layer positions to set off a sloshing motion in +!! the zonal direction in a rectangular basin. All layers have initially the +!! same thickness but all interfaces (except bottom and sea surface) are +!! displaced according to a half-period cosine, with maximum value on the +!! left and minimum value on the right. This sets off a regular sloshing motion. +subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + + ! Local variables + real :: displ(SZK_(GV)+1) ! The interface displacement [Z ~> m]. + real :: z_unif(SZK_(GV)+1) ! Fractional uniform interface heights [nondim]. + real :: z_inter(SZK_(GV)+1) ! Interface heights [Z ~> m] + real :: a0 ! The displacement amplitude [Z ~> m]. + real :: weight_z ! A depth-space weighting [nondim]. + real :: x1, y1, x2, y2 ! Dimensonless parameters specifying the depth profile [nondim] + real :: x, t ! Dimensionless depth coordinates scales [nondim] + logical :: use_IC_bug ! If true, set the initial conditions retaining an old bug. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "sloshing_initialization" !< This module's name. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.just_read) call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "SLOSHING_IC_AMPLITUDE", a0, & + "Initial amplitude of sloshing internal interface height "//& + "displacements it the sloshing test case.", & + units='m', default=75.0, scale=US%m_to_Z, do_not_log=just_read) + call get_param(param_file, mdl, "SLOSHING_IC_BUG", use_IC_bug, & + "If true, use code with a bug to set the sloshing initial conditions.", & + default=.false., do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + ! Define thicknesses + do j=G%jsc,G%jec ; do i=G%isc,G%iec + + ! Define uniform interfaces + do k = 0,nz + z_unif(k+1) = -real(k)/real(nz) + enddo + + ! 1. Define stratification + do k = 1,nz+1 + + ! Thin pycnocline in the middle + !z_inter(k) = (2.0**(n-1)) * (z_unif(k) + 0.5)**n - 0.5 + + ! Thin pycnocline in the middle (piecewise linear profile) + x1 = 0.30; y1 = 0.48; x2 = 0.70; y2 = 0.52 + + x = -z_unif(k) + + if ( x <= x1 ) then + t = y1*x/x1 + elseif ( (x > x1 ) .and. ( x < x2 )) then + t = y1 + (y2-y1) * (x-x1) / (x2-x1) + else + t = y2 + (1.0-y2) * (x-x2) / (1.0-x2) + endif + + t = - z_unif(k) + + z_inter(k) = -t * G%max_depth + + enddo + + ! 2. Define displacement + ! a0 is set via get_param; by default a0 is a 75m Displacement amplitude in depth units. + do k = 1,nz+1 + + weight_z = - 4.0 * ( z_unif(k) + 0.5 )**2 + 1.0 + + x = G%geoLonT(i,j) / G%len_lon + if (use_IC_bug) then + displ(k) = a0 * cos(acos(-1.0)*x) + weight_z * US%m_to_Z ! There is a flag to fix this bug. + else + displ(k) = a0 * cos(acos(-1.0)*x) * weight_z + endif + + if ( k == 1 ) then + displ(k) = 0.0 + endif + + if ( k == nz+1 ) then + displ(k) = 0.0 + endif + + z_inter(k) = z_inter(k) + displ(k) + + enddo + + ! 3. The last interface must coincide with the seabed + z_inter(nz+1) = -depth_tot(i,j) + ! Modify interface heights to make sure all thicknesses are strictly positive + do k = nz,1,-1 + if ( z_inter(k) < (z_inter(k+1) + GV%Angstrom_Z) ) then + z_inter(k) = z_inter(k+1) + GV%Angstrom_Z + endif + enddo + + ! 4. Define layers + do k = 1,nz + h(i,j,k) = z_inter(k) - z_inter(k+1) + enddo + + enddo ; enddo + +end subroutine sloshing_initialize_thickness + + +!> Initialization of temperature and salinity +!! +!! This subroutine initializes linear profiles for T and S according to +!! reference surface layer salinity and temperature and a specified range. +!! Note that the linear distribution is set up with respect to the layer +!! number, not the physical position). +subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse + !! for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T & S. + + ! Local variables + real :: delta_T ! Temperature difference between layers [C ~> degC] + real :: S_ref, T_ref ! Reference salinity [S ~> ppt] and temperature [C ~> degC] within surface layer + real :: S_range, T_range ! Range of salinities [S ~> ppt] and temperatures [C ~> degC] over the vertical + real :: S_surf ! Initial surface salinity [S ~> ppt] + real :: T_pert ! A perturbed temperature [C ~> degC] + integer :: kdelta ! Half the number of layers with the temperature perturbation + real :: deltah ! Thickness of each layer [Z ~> m] + real :: xi0, xi1 ! Fractional vertical positions [nondim] + character(len=40) :: mdl = "sloshing_initialization" ! This module's name. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference value for salinity', & + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference value for temperature', & + units='degC', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + + ! The default is to assume an increase by 2 ppt for the salinity and a uniform temperature. + call get_param(param_file, mdl, "S_RANGE", S_range, 'Initial salinity range.', & + units="ppt", default=2.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & + units='degC', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, "Initial surface salinity", & + units="ppt", default=34.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "SLOSHING_T_PERT", T_pert, & + 'A mid-column temperature perturbation in the sloshing test case', & + units='degC', default=1.0, scale=US%degC_to_C, do_not_log=just_read) + + if (just_read) return ! All run-time parameters have been read, so return. + + ! Prescribe salinity + !delta_S = S_range / ( GV%ke - 1.0 ) + + !S(:,:,1) = S_ref + !do k = 2,GV%ke + ! S(:,:,k) = S(:,:,k-1) + delta_S + !enddo + + deltah = G%max_depth / nz + do j=js,je ; do i=is,ie + xi0 = 0.0 + do k = 1,nz + xi1 = xi0 + deltah / G%max_depth ! = xi0 + 1.0 / real(nz) + S(i,j,k) = S_surf + 0.5 * S_range * (xi0 + xi1) + xi0 = xi1 + enddo + enddo ; enddo + + ! Prescribe temperature + delta_T = T_range / ( GV%ke - 1.0 ) + + T(:,:,1) = T_ref + do k = 2,GV%ke + T(:,:,k) = T(:,:,k-1) + delta_T + enddo + kdelta = 2 + ! Perhaps the following lines should instead assign T() = T_pert + T_ref + T(:,:,GV%ke/2 - (kdelta-1):GV%ke/2 + kdelta) = T_pert + +end subroutine sloshing_initialize_temperature_salinity + +!> \namespace sloshing_initialization +!! +!! The module configures the model for the non-rotating sloshing test case. +end module sloshing_initialization diff --git a/user/soliton_initialization.F90 b/user/soliton_initialization.F90 new file mode 100644 index 0000000000..06a781ec94 --- /dev/null +++ b/user/soliton_initialization.F90 @@ -0,0 +1,120 @@ +!> Initial conditions for the Equatorial Rossby soliton test (Boyd). +module soliton_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR +use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA + +implicit none ; private + +#include + +! Private (module-wise) parameters +character(len=40) :: mdl = "soliton_initialization" !< This module's name. + +public soliton_initialize_thickness +public soliton_initialize_velocity + +contains + +!> Initialization of thicknesses in Equatorial Rossby soliton test +subroutine soliton_initialize_thickness(h, depth_tot, G, GV, US) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + + integer :: i, j, k, is, ie, js, je, nz + real :: x, y, x0, y0 + real :: val1, val2, val3, val4 + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call MOM_mesg("soliton_initialization.F90, soliton_initialize_thickness: setting thickness") + + x0 = 2.0*G%len_lon/3.0 + y0 = 0.0 + val1 = 0.395 + val2 = US%m_to_Z * 0.771*(val1*val1) + + do j = G%jsc,G%jec ; do i = G%isc,G%iec + do k = 1, nz + x = G%geoLonT(i,j)-x0 + y = G%geoLatT(i,j)-y0 + val3 = exp(-val1*x) + val4 = val2 * ( 2.0*val3 / (1.0 + (val3*val3)) )**2 + h(i,j,k) = (0.25*val4*(6.0*y*y + 3.0) * exp(-0.5*y*y) + depth_tot(i,j)) + enddo + enddo ; enddo + +end subroutine soliton_initialize_thickness + + +!> Initialization of u and v in the equatorial Rossby soliton test +subroutine soliton_initialize_velocity(u, v, G, GV, US) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: u !< i-component of velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: v !< j-component of velocity [L T-1 ~> m s-1] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real :: x, x0 ! Positions in the same units as geoLonT. + real :: y, y0 ! Positions in the same units as geoLatT. + real :: val1 ! A zonal decay scale in the inverse of the units of geoLonT. + real :: val2 ! An overall velocity amplitude [L T-1 ~> m s-1] + real :: val3 ! A decay factor [nondim] + real :: val4 ! The local velocity amplitude [L T-1 ~> m s-1] + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + x0 = 2.0*G%len_lon/3.0 + y0 = 0.0 + val1 = 0.395 + val2 = US%m_s_to_L_T * 0.771*(val1*val1) + + v(:,:,:) = 0.0 + u(:,:,:) = 0.0 + + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 + do k = 1, nz + x = 0.5*(G%geoLonT(i+1,j)+G%geoLonT(i,j))-x0 + y = 0.5*(G%geoLatT(i+1,j)+G%geoLatT(i,j))-y0 + val3 = exp(-val1*x) + val4 = val2*((2.0*val3/(1.0+(val3*val3)))**2) + u(I,j,k) = 0.25*val4*(6.0*y*y-9.0) * exp(-0.5*y*y) + enddo + enddo ; enddo + do j = G%jsc-1,G%jec+1 ; do I = G%isc,G%iec + do k = 1, nz + x = 0.5*(G%geoLonT(i,j+1)+G%geoLonT(i,j))-x0 + y = 0.5*(G%geoLatT(i,j+1)+G%geoLatT(i,j))-y0 + val3 = exp(-val1*x) + val4 = val2*((2.0*val3/(1.0+(val3*val3)))**2) + v(i,J,k) = 2.0*val4*y*(-2.0*val1*tanh(val1*x)) * exp(-0.5*y*y) + enddo + enddo ; enddo + +end subroutine soliton_initialize_velocity + + +!> \namespace soliton_initialization +!! +!! \section section_soliton Description of the equatorial Rossby soliton initial +!! conditions +!! + +end module soliton_initialization diff --git a/user/supercritical_initialization.F90 b/user/supercritical_initialization.F90 new file mode 100644 index 0000000000..ddb38a9cdf --- /dev/null +++ b/user/supercritical_initialization.F90 @@ -0,0 +1,83 @@ +!> The "super critical" configuration +module supercritical_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_segment_type +use MOM_time_manager, only : time_type, time_type_to_real +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public supercritical_set_OBC_data + +contains + +!> This subroutine sets the properties of flow at open boundary conditions. +subroutine supercritical_set_OBC_data(OBC, G, GV, US, param_file) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + ! Local variables + character(len=40) :: mdl = "supercritical_set_OBC_data" ! This subroutine's name. + real :: zonal_flow ! Inflow speed [L T-1 ~> m s-1] + integer :: i, j, k, l + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + + if (.not.associated(OBC)) call MOM_error(FATAL, 'supercritical_initialization.F90: '// & + 'supercritical_set_OBC_data() was called but OBC type was not initialized!') + + call get_param(param_file, mdl, "SUPERCRITICAL_ZONAL_FLOW", zonal_flow, & + "Constant zonal flow imposed at upstream open boundary.", & + units="m/s", default=8.57, scale=US%m_s_to_L_T) + + do l=1, OBC%number_of_segments + segment => OBC%segment(l) + if (.not. segment%on_pe) cycle + if (segment%gradient) cycle + if (segment%oblique .and. .not. segment%nudged .and. .not. segment%Flather) cycle + + if (segment%is_E_or_W) then + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + do k=1,GV%ke + do j=jsd,jed ; do I=IsdB,IedB + if (segment%specified .or. segment%nudged) then + segment%normal_vel(I,j,k) = zonal_flow + endif + if (segment%specified) then + segment%normal_trans(I,j,k) = zonal_flow * G%dyCu(I,j) + endif + enddo ; enddo + enddo + do j=jsd,jed ; do I=IsdB,IedB + segment%normal_vel_bt(I,j) = zonal_flow + enddo ; enddo + else + isd = segment%HI%isd ; ied = segment%HI%ied + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + do J=JsdB,JedB ; do i=isd,ied + segment%normal_vel_bt(i,J) = 0.0 + enddo ; enddo + endif + enddo + +end subroutine supercritical_set_OBC_data + +!> \namespace supercritical_initialization +!! +!! The module configures the model for the "supercritical" experiment. +!! https://marine.rutgers.edu/po/index.php?model=test-problems&title=supercritical +end module supercritical_initialization diff --git a/user/tidal_bay_initialization.F90 b/user/tidal_bay_initialization.F90 new file mode 100644 index 0000000000..37a908d3a8 --- /dev/null +++ b/user/tidal_bay_initialization.F90 @@ -0,0 +1,128 @@ +!> Configures the model for the "tidal_bay" experiment. +!! tidal_bay = Tidally resonant bay from Zygmunt Kowalik's class on tides. +module tidal_bay_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : reproducing_sum +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : OBC_segment_type, register_OBC +use MOM_open_boundary, only : OBC_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_time_manager, only : time_type, time_type_to_real + +implicit none ; private + +#include + +public tidal_bay_set_OBC_data +public register_tidal_bay_OBC + +!> Control structure for tidal bay open boundaries. +type, public :: tidal_bay_OBC_CS ; private + real :: tide_flow = 3.0e6 !< Maximum tidal flux with the tidal bay configuration [L2 Z T-1 ~> m3 s-1] + real :: tide_period !< The period associated with the tidal bay configuration [T ~> s] + real :: tide_ssh_amp !< The magnitude of the sea surface height anomalies at the inflow + !! with the tidal bay configuration [Z ~> m] +end type tidal_bay_OBC_CS + +contains + +!> Add tidal bay to OBC registry. +function register_tidal_bay_OBC(param_file, CS, US, OBC_Reg) + type(param_file_type), intent(in) :: param_file !< parameter file. + type(tidal_bay_OBC_CS), intent(inout) :: CS !< tidal bay control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. + logical :: register_tidal_bay_OBC + character(len=32) :: casename = "tidal bay" !< This case's name. + character(len=40) :: mdl = "tidal_bay_initialization" ! This module's name. + + call get_param(param_file, mdl, "TIDAL_BAY_FLOW", CS%tide_flow, & + "Maximum total tidal volume flux.", & + units="m3 s-1", default=3.0e6, scale=US%m_s_to_L_T*US%m_to_L*US%m_to_Z) + call get_param(param_file, mdl, "TIDAL_BAY_PERIOD", CS%tide_period, & + "Period of the inflow in the tidal bay configuration.", & + units="s", default=12.0*3600.0, scale=US%s_to_T) + call get_param(param_file, mdl, "TIDAL_BAY_SSH_ANOM", CS%tide_ssh_amp, & + "Magnitude of the sea surface height anomalies at the inflow with the "//& + "tidal bay configuration.", & + units="m", default=0.1, scale=US%m_to_Z) + + ! Register the open boundaries. + call register_OBC(casename, param_file, OBC_Reg) + register_tidal_bay_OBC = .true. + +end function register_tidal_bay_OBC + +!> This subroutine sets the properties of flow at open boundary conditions. +subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(tidal_bay_OBC_CS), intent(in) :: CS !< tidal bay control structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] + type(time_type), intent(in) :: Time !< model time. + + ! The following variables are used to set up the transport in the tidal_bay example. + real :: time_sec ! Elapsed model time [T ~> s] + real :: cff_eta ! The sea surface height anomalies associated with the inflow [Z ~> m] + real :: my_flux ! The vlume flux through the face [L2 Z T-1 ~> m3 s-1] + real :: total_area ! The total face area of the OBCs [L Z ~> m2] + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: flux_scale ! A scaling factor for the areas [m2 H-1 L-1 ~> nondim or m3 kg-1] + real, allocatable :: my_area(:,:) ! The total OBC inflow area [m2] + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, n + integer :: IsdB, IedB, JsdB, JedB + type(OBC_segment_type), pointer :: segment => NULL() + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + PI = 4.0*atan(1.0) + + if (.not.associated(OBC)) return + + allocate(my_area(1:1,js:je)) + + flux_scale = GV%H_to_m*US%L_to_m + + time_sec = US%s_to_T*time_type_to_real(Time) + cff_eta = CS%tide_ssh_amp * sin(2.0*PI*time_sec / CS%tide_period) + my_area = 0.0 + my_flux = 0.0 + segment => OBC%segment(1) + + do j=segment%HI%jsc,segment%HI%jec ; do I=segment%HI%IscB,segment%HI%IecB + if (OBC%segnum_u(I,j) /= OBC_NONE) then + do k=1,nz + ! This area has to be in MKS units to work with reproducing_sum. + my_area(1,j) = my_area(1,j) + h(I,j,k)*flux_scale*G%dyCu(I,j) + enddo + endif + enddo ; enddo + total_area = reproducing_sum(my_area) + my_flux = - CS%tide_flow * SIN(2.0*PI*time_sec / CS%tide_period) + + do n = 1, OBC%number_of_segments + segment => OBC%segment(n) + + if (.not. segment%on_pe) cycle + + segment%normal_vel_bt(:,:) = my_flux / (US%m_to_Z*US%m_to_L*total_area) + segment%SSH(:,:) = cff_eta + + enddo ! end segment loop + +end subroutine tidal_bay_set_OBC_data + +end module tidal_bay_initialization diff --git a/user/user_change_diffusivity.F90 b/user/user_change_diffusivity.F90 new file mode 100644 index 0000000000..9a56c12b9c --- /dev/null +++ b/user/user_change_diffusivity.F90 @@ -0,0 +1,269 @@ +!> Increments the diapycnal diffusivity in a specified band of latitudes and densities. +module user_change_diffusivity + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, EOS_domain + +implicit none ; private + +#include + +public user_change_diff, user_change_diff_init, user_change_diff_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure for user_change_diffusivity +type, public :: user_change_diff_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + real :: Kd_add !< The scale of a diffusivity that is added everywhere without + !! any filtering or scaling [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: lat_range(4) !< 4 values that define the latitude range over which + !! a diffusivity scaled by Kd_add is added [degrees_N]. + real :: rho_range(4) !< 4 values that define the coordinate potential + !! density range over which a diffusivity scaled by + !! Kd_add is added [R ~> kg m-3]. + logical :: use_abs_lat !< If true, use the absolute value of latitude when + !! setting lat_range. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. +end type user_change_diff_CS + +contains + +!> This subroutine provides an interface for a user to use to modify the +!! main code to alter the diffusivities as needed. The specific example +!! implemented here augments the diffusivity for a specified range of latitude +!! and coordinate potential density. +subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_int_add) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers + !! to any available thermodynamic + !! fields. Absent fields have NULL ptrs. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(user_change_diff_CS), pointer :: CS !< This module's control structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity of each + !! layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at each + !! interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: T_f !< Temperature with massless + !! layers filled in vertically [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: S_f !< Salinity with massless + !! layers filled in vertically [S ~> ppt]. + real, dimension(:,:,:), optional, pointer :: Kd_int_add !< The diapycnal + !! diffusivity that is being added at + !! each interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + ! Local variables + real :: Rcv(SZI_(G),SZK_(GV)) ! The coordinate density in layers [R ~> kg m-3]. + real :: p_ref(SZI_(G)) ! An array of tv%P_Ref pressures [R L2 T-2 ~> Pa]. + real :: rho_fn ! The density dependence of the input function, 0-1 [nondim]. + real :: lat_fn ! The latitude dependence of the input function, 0-1 [nondim]. + logical :: use_EOS ! If true, density is calculated from T & S using an + ! equation of state. + logical :: store_Kd_add ! Save the added diffusivity as a diagnostic if true. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, nz + integer :: isd, ied, jsd, jed + + character(len=200) :: mesg + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (.not.associated(CS)) call MOM_error(FATAL,"user_set_diffusivity: "//& + "Module must be initialized before it is used.") + + if (.not.CS%initialized) call MOM_error(FATAL,"user_set_diffusivity: "//& + "Module must be initialized before it is used.") + + use_EOS = associated(tv%eqn_of_state) + if (.not.use_EOS) return + store_Kd_add = .false. + if (present(Kd_int_add)) store_Kd_add = associated(Kd_int_add) + + if (.not.range_OK(CS%lat_range)) then + write(mesg, '(4(1pe15.6))') CS%lat_range(1:4) + call MOM_error(FATAL, "user_set_diffusivity: bad latitude range: \n "//& + trim(mesg)) + endif + if (.not.range_OK(CS%rho_range)) then + write(mesg, '(4(1pe15.6))') CS%rho_range(1:4) + call MOM_error(FATAL, "user_set_diffusivity: bad density range: \n "//& + trim(mesg)) + endif + + if (store_Kd_add) Kd_int_add(:,:,:) = 0.0 + + do i=is,ie ; p_ref(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + if (present(T_f) .and. present(S_f)) then + do k=1,nz + call calculate_density(T_f(:,j,k), S_f(:,j,k), p_ref, Rcv(:,k), tv%eqn_of_state, EOSdom) + enddo + else + do k=1,nz + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), tv%eqn_of_state, EOSdom) + enddo + endif + + if (present(Kd_lay)) then + do k=1,nz ; do i=is,ie + if (CS%use_abs_lat) then + lat_fn = val_weights(abs(G%geoLatT(i,j)), CS%lat_range) + else + lat_fn = val_weights(G%geoLatT(i,j), CS%lat_range) + endif + rho_fn = val_weights(Rcv(i,k), CS%rho_range) + if (rho_fn * lat_fn > 0.0) & + Kd_lay(i,j,k) = Kd_lay(i,j,k) + CS%Kd_add * rho_fn * lat_fn + enddo ; enddo + endif + if (present(Kd_int)) then + do K=2,nz ; do i=is,ie + if (CS%use_abs_lat) then + lat_fn = val_weights(abs(G%geoLatT(i,j)), CS%lat_range) + else + lat_fn = val_weights(G%geoLatT(i,j), CS%lat_range) + endif + rho_fn = val_weights( 0.5*(Rcv(i,k-1) + Rcv(i,k)), CS%rho_range) + if (rho_fn * lat_fn > 0.0) then + Kd_int(i,j,K) = Kd_int(i,j,K) + CS%Kd_add * rho_fn * lat_fn + if (store_Kd_add) Kd_int_add(i,j,K) = CS%Kd_add * rho_fn * lat_fn + endif + enddo ; enddo + endif + enddo + +end subroutine user_change_diff + +!> This subroutine checks whether the 4 values of range are in ascending order. +function range_OK(range) result(OK) + real, dimension(4), intent(in) :: range !< Four values to check [arbitrary] + logical :: OK !< Return value. + + OK = ((range(1) <= range(2)) .and. (range(2) <= range(3)) .and. & + (range(3) <= range(4))) + +end function range_OK + +!> This subroutine returns a value that goes smoothly from 0 to 1, stays +!! at 1, and then goes smoothly back to 0 at the four values of range. The +!! transitions are cubic, and have zero first derivatives where the curves +!! hit 0 and 1. The values in range must be in ascending order, as can be +!! checked by calling range_OK. +function val_weights(val, range) result(ans) + real, intent(in) :: val !< Value for which we need an answer [arbitrary units]. + real, dimension(4), intent(in) :: range !< Range over which the answer is non-zero [arbitrary units]. + real :: ans !< Return value [nondim]. + ! Local variables + real :: x ! A nondimensional number between 0 and 1 [nondim]. + + ans = 0.0 + if ((val > range(1)) .and. (val < range(4))) then + if (val < range(2)) then + ! x goes from 0 to 1; ans goes from 0 to 1, with 0 derivatives at the ends. + x = (val - range(1)) / (range(2) - range(1)) + ans = x**2 * (3.0 - 2.0 * x) + elseif (val > range(3)) then + ! x goes from 0 to 1; ans goes from 0 to 1, with 0 derivatives at the ends. + x = (range(4) - val) / (range(4) - range(3)) + ans = x**2 * (3.0 - 2.0 * x) + else + ans = 1.0 + endif + endif + +end function val_weights + +!> Set up the module control structure. +subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for + !! model parameter values. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to + !! regulate diagnostic output. + type(user_change_diff_CS), pointer :: CS !< A pointer that is set to + !! point to the control + !! structure for this module. + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "user_set_diffusivity" ! This module's name. + character(len=200) :: mesg + + if (associated(CS)) then + call MOM_error(WARNING, "diabatic_entrain_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + CS%initialized = .true. + CS%diag => diag + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "USER_KD_ADD", CS%Kd_add, & + "A user-specified additional diffusivity over a range of "//& + "latitude and density.", default=0.0, units="m2 s-1", scale=GV%m2_s_to_HZ_T) + if (CS%Kd_add /= 0.0) then + call get_param(param_file, mdl, "USER_KD_ADD_LAT_RANGE", CS%lat_range(:), & + "Four successive values that define a range of latitudes "//& + "over which the user-specified extra diffusivity is "//& + "applied. The four values specify the latitudes at "//& + "which the extra diffusivity starts to increase from 0, "//& + "hits its full value, starts to decrease again, and is "//& + "back to 0.", units="degrees_N", default=-1.0e9) + call get_param(param_file, mdl, "USER_KD_ADD_RHO_RANGE", CS%rho_range(:), & + "Four successive values that define a range of potential "//& + "densities over which the user-given extra diffusivity "//& + "is applied. The four values specify the density at "//& + "which the extra diffusivity starts to increase from 0, "//& + "hits its full value, starts to decrease again, and is "//& + "back to 0.", units="kg m-3", default=-1.0e9, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "USER_KD_ADD_USE_ABS_LAT", CS%use_abs_lat, & + "If true, use the absolute value of latitude when "//& + "checking whether a point fits into range of latitudes.", & + default=.false.) + endif + + if (.not.range_OK(CS%lat_range)) then + write(mesg, '(4(1pe15.6))') CS%lat_range(1:4) + call MOM_error(FATAL, "user_set_diffusivity: bad latitude range: \n "//& + trim(mesg)) + endif + if (.not.range_OK(CS%rho_range)) then + write(mesg, '(4(1pe15.6))') CS%rho_range(1:4) + call MOM_error(FATAL, "user_set_diffusivity: bad density range: \n "//& + trim(mesg)) + endif + +end subroutine user_change_diff_init + +!> Clean up the module control structure. +subroutine user_change_diff_end(CS) + type(user_change_diff_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module. + + if (associated(CS)) deallocate(CS) + +end subroutine user_change_diff_end + +end module user_change_diffusivity diff --git a/user/user_initialization.F90 b/user/user_initialization.F90 new file mode 100644 index 0000000000..207f009c9c --- /dev/null +++ b/user/user_initialization.F90 @@ -0,0 +1,269 @@ +!> A template of a user to code up customized initial conditions. +module user_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N +use MOM_open_boundary, only : OBC_DIRECTION_S +use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public USER_set_coord, USER_initialize_topography, USER_initialize_thickness +public USER_initialize_velocity, USER_init_temperature_salinity +public USER_initialize_sponges, USER_set_OBC_data, USER_set_rotation + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> A module variable that should not be used. +!! \todo Move this module variable into a control structure. +logical :: first_call = .true. + +contains + +!> Set vertical coordinates. +subroutine USER_set_coord(Rlay, g_prime, GV, US, param_file) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + + call MOM_error(FATAL, & + "USER_initialization.F90, USER_set_coord: " // & + "Unmodified user routine called - you must edit the routine to use it") + Rlay(:) = 0.0 + g_prime(:) = 0.0 + + if (first_call) call write_user_log(param_file) + +end subroutine USER_set_coord + +!> Initialize topography. +subroutine USER_initialize_topography(D, G, param_file, max_depth, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth [Z ~> m] + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum model depth [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + call MOM_error(FATAL, & + "USER_initialization.F90, USER_initialize_topography: " // & + "Unmodified user routine called - you must edit the routine to use it") + + D(:,:) = 0.0 + + if (first_call) call write_user_log(param_file) + +end subroutine USER_initialize_topography + +!> Initialize thicknesses in depth units. These will be converted to thickness units later. +subroutine USER_initialize_thickness(h, G, GV, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thicknesses being initialized [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open + !! file to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will + !! only read parameters without changing h. + + call MOM_error(FATAL, & + "USER_initialization.F90, USER_initialize_thickness: " // & + "Unmodified user routine called - you must edit the routine to use it") + + if (just_read) return ! All run-time parameters have been read, so return. + + h(:,:,1:GV%ke) = 0.0 ! h should be set in [Z ~> m]. It will be converted to thickness units + ! [H ~> m or kg m-2] once the temperatures and salinities are known. + + if (first_call) call write_user_log(param_file) + +end subroutine USER_initialize_thickness + +!> initialize velocities. +subroutine USER_initialize_velocity(u, v, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)), intent(out) :: u !< i-component of velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)), intent(out) :: v !< j-component of velocity [L T-1 ~> m s-1] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + logical, intent(in) :: just_read !< If true, this call will + !! only read parameters without changing u & v. + + call MOM_error(FATAL, & + "USER_initialization.F90, USER_initialize_velocity: " // & + "Unmodified user routine called - you must edit the routine to use it") + + if (just_read) return ! All run-time parameters have been read, so return. + + u(:,:,1) = 0.0 + v(:,:,1) = 0.0 + + if (first_call) call write_user_log(param_file) + +end subroutine USER_initialize_velocity + +!> This function puts the initial layer temperatures and salinities +!! into T(:,:,:) and S(:,:,:). +subroutine USER_init_temperature_salinity(T, S, G, GV, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt]. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + logical, intent(in) :: just_read !< If true, this call will only + !! read parameters without changing T & S. + + call MOM_error(FATAL, & + "USER_initialization.F90, USER_init_temperature_salinity: " // & + "Unmodified user routine called - you must edit the routine to use it") + + if (just_read) return ! All run-time parameters have been read, so return. + + T(:,:,1) = 0.0 + S(:,:,1) = 0.0 + + if (first_call) call write_user_log(param_file) + +end subroutine USER_init_temperature_salinity + +!> Set up the sponges. +subroutine USER_initialize_sponges(G, GV, use_temp, tv, param_file, CSp, h) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + logical, intent(in) :: use_temp !< If true, temperature and salinity are state variables. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers + !! to any available thermodynamic + !! fields, potential temperature and + !! salinity or mixed layer density. + !! Absent fields have NULL ptrs. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(sponge_CS), pointer :: CSp !< A pointer to the sponge control structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + call MOM_error(FATAL, & + "USER_initialization.F90, USER_initialize_sponges: " // & + "Unmodified user routine called - you must edit the routine to use it") + + if (first_call) call write_user_log(param_file) + +end subroutine USER_initialize_sponges + +!> This subroutine sets the properties of flow at open boundary conditions. +subroutine USER_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any + !! available thermodynamic fields, including potential + !! temperature and salinity or mixed layer density. Absent + !! fields have NULL ptrs. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. +! call MOM_error(FATAL, & +! "USER_initialization.F90, USER_set_OBC_data: " // & +! "Unmodified user routine called - you must edit the routine to use it") + + if (first_call) call write_user_log(param_file) + +end subroutine USER_set_OBC_data + +subroutine USER_set_rotation(G, param_file) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + call MOM_error(FATAL, & + "USER_initialization.F90, USER_set_rotation: " // & + "Unmodified user routine called - you must edit the routine to use it") + + if (first_call) call write_user_log(param_file) + +end subroutine USER_set_rotation + +!> Write output about the parameter values being used. +subroutine write_user_log(param_file) + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "user_initialization" ! This module's name. + + call log_version(param_file, mdl, version) + first_call = .false. + +end subroutine write_user_log + +!> \namespace user_initialization +!! +!! This subroutine initializes the fields for the simulations. +!! The one argument passed to initialize, Time, is set to the +!! current time of the simulation. The fields which might be initialized +!! here are: +!! - u - Zonal velocity [Z T-1 ~> m s-1]. +!! - v - Meridional velocity [Z T-1 ~> m s-1]. +!! - h - Layer thickness [H ~> m or kg m-2]. (Must be positive.) +!! - G%bathyT - Basin depth [Z ~> m]. +!! - G%CoriolisBu - The Coriolis parameter [T-1 ~> s-1]. +!! - GV%g_prime - The reduced gravity at each interface [L2 Z-1 T-2 ~> m s-2]. +!! - GV%Rlay - Layer potential density (coordinate variable) [R ~> kg m-3]. +!! If ENABLE_THERMODYNAMICS is defined: +!! - T - Temperature [C ~> degC]. +!! - S - Salinity [S ~> ppt]. +!! If BULKMIXEDLAYER is defined: +!! - Rml - Mixed layer and buffer layer potential densities [R ~> kg m-3]. +!! If SPONGE is defined: +!! - A series of subroutine calls are made to set up the damping +!! rates and reference profiles for all variables that are damped +!! in the sponge. +!! +!! Any user provided tracer code is also first linked through this +!! subroutine. +!! +!! These variables are all set in the set of subroutines (in this +!! file) USER_initialize_bottom_depth, USER_initialize_thickness, +!! USER_initialize_velocity, USER_initialize_temperature_salinity, +!! USER_initialize_mixed_layer_density, USER_initialize_sponges, +!! USER_set_coord, and USER_set_ref_profile. +!! +!! The names of these subroutines should be self-explanatory. They +!! start with "USER_" to indicate that they will likely have to be +!! modified for each simulation to set the initial conditions and +!! boundary conditions. Most of these take two arguments: an integer +!! argument specifying whether the fields are to be calculated +!! internally or read from a NetCDF file; and a string giving the +!! path to that file. If the field is initialized internally, the +!! path is ignored. + +end module user_initialization diff --git a/user/user_revise_forcing.F90 b/user/user_revise_forcing.F90 new file mode 100644 index 0000000000..ce767d7479 --- /dev/null +++ b/user/user_revise_forcing.F90 @@ -0,0 +1,61 @@ +!> Provides a template for users to code updating the forcing fluxes. +module user_revise_forcing + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domains, only : pass_var, pass_vector, AGRID +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, MOM_read_data +use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_time_manager, only : time_type, operator(+), operator(/) +use MOM_tracer_flow_control, only : call_tracer_set_forcing +use MOM_tracer_flow_control, only : tracer_flow_control_CS +use MOM_variables, only : surface + +implicit none ; private + +public user_alter_forcing, user_revise_forcing_init + +!> Control structure for user_revise_forcing +type, public :: user_revise_forcing_CS ; private + real :: cdrag !< The quadratic bottom drag coefficient [nondim] +end type user_revise_forcing_CS + +contains + +!> This subroutine sets the surface wind stresses. +subroutine user_alter_forcing(sfc_state, fluxes, day, G, CS) + type(surface), intent(in) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL ptrs. + type(time_type), intent(in) :: day !< Time of the fluxes. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(user_revise_forcing_CS), pointer :: CS !< A pointer to the control structure + !! returned by a previous call to + !! surface_forcing_init. + return + +end subroutine user_alter_forcing + +!> Initialize the user_revise_forcing control structure +subroutine user_revise_forcing_init(param_file,CS) + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to + !! parse for model parameter values. + type(user_revise_forcing_CS), pointer :: CS !< A pointer to the control structure + !! returned by a previous call to + !! surface_forcing_init. + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "user_revise_forcing" !< This module's name. + + call log_version(param_file, mdl, version) + +end subroutine user_revise_forcing_init + +end module user_revise_forcing From 077c135fb9e7638688c9d968c4becaddde2931b4 Mon Sep 17 00:00:00 2001 From: Sinakhani Date: Wed, 16 Oct 2024 11:38:46 -0500 Subject: [PATCH 3/7] Gradient model is updated --- .../lateral/MOM_lateral_mixing_coeffs.F90 | 333 +++++++++++------- 1 file changed, 210 insertions(+), 123 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 4f1dbb89ac..f0bb980c63 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -10,7 +10,7 @@ module MOM_lateral_mixing_coeffs use MOM_domains, only : create_group_pass, do_group_pass use MOM_domains, only : group_pass_type, pass_var, pass_vector use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_interface_heights, only : find_eta, thickness_to_dz +use MOM_interface_heights, only : find_eta use MOM_isopycnal_slopes, only : calc_isoneutral_slopes use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type @@ -27,6 +27,7 @@ module MOM_lateral_mixing_coeffs type, public :: VarMix_CS logical :: initialized = .false. !< True if this control structure has been initialized. logical :: use_variable_mixing !< If true, use the variable mixing. + logical :: use_gradient_model !< If true, use the gradient model. logical :: Resoln_scaling_used !< If true, a resolution function is used somewhere to scale !! away one of the viscosities or diffusivities when the !! deformation radius is well resolved. @@ -59,26 +60,25 @@ module MOM_lateral_mixing_coeffs !! This parameter is set depending on other parameters. logical :: calculate_depth_fns !< If true, calculate all the depth factors. !! This parameter is set depending on other parameters. - logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rates. + logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rate. !! This parameter is set depending on other parameters. logical :: use_stanley_iso !< If true, use Stanley parameterization in MOM_isopycnal_slopes logical :: use_simpler_Eady_growth_rate !< If true, use a simpler method to calculate the !! Eady growth rate that avoids division by layer thickness. !! This parameter is set depending on other parameters. - logical :: full_depth_Eady_growth_rate !< If true, calculate the Eady growth rate based on an - !! average that includes contributions from sea-level changes - !! in its denominator, rather than just the nominal depth of - !! the bathymetry. This only applies when using the model - !! interface heights as a proxy for isopycnal slopes. real :: cropping_distance !< Distance from surface or bottom to filter out outcropped or !! incropped interfaces for the Eady growth rate calc [Z ~> m] real :: h_min_N2 !< The minimum vertical distance to use in the denominator of the - !! bouyancy frequency used in the slope calculation [H ~> m or kg m-2] + !! bouyancy frequency used in the slope calculation [Z ~> m] real, allocatable :: SN_u(:,:) !< S*N at u-points [T-1 ~> s-1] real, allocatable :: SN_v(:,:) !< S*N at v-points [T-1 ~> s-1] + real, allocatable :: UH_grad(:,:,:) !< Grad model at u-points [T-1 ~> s-1] + real, allocatable :: VH_grad(:,:,:) !< Grad model at v-points [T-1 ~> s-1] real, allocatable :: L2u(:,:) !< Length scale^2 at u-points [L2 ~> m2] real, allocatable :: L2v(:,:) !< Length scale^2 at v-points [L2 ~> m2] + real, allocatable :: L2grad_u(:,:) !< Grad length scale^2 at u-points [L2 ~> m2] + real, allocatable :: L2grad_v(:,:) !< Grad length scale^2 at v-points [L2 ~> m2] real, allocatable :: cg1(:,:) !< The first baroclinic gravity wave speed [L T-1 ~> m s-1]. real, allocatable :: Res_fn_h(:,:) !< Non-dimensional function of the ratio the first baroclinic !! deformation radius to the grid spacing at h points [nondim]. @@ -130,6 +130,7 @@ module MOM_lateral_mixing_coeffs logical :: use_Visbeck !< Use Visbeck formulation for thickness diffusivity integer :: VarMix_Ktop !< Top layer to start downward integrals real :: Visbeck_L_scale !< Fixed length scale in Visbeck formula [L ~> m], or if negative a scaling + real :: grad_L_scale !< Fixed length scale in Gradient formula [non-dimension] !! factor [nondim] relating this length scale squared to the cell area real :: Eady_GR_D_scale !< Depth over which to average SN [Z ~> m] real :: Res_coef_khth !< A coefficient [nondim] that determines the function @@ -140,7 +141,7 @@ module MOM_lateral_mixing_coeffs !! F = 1 / (1 + (Res_coef_visc*Ld/dx)^Res_fn_power) real :: depth_scaled_khth_h0 !< The depth above which KHTH is linearly scaled away [Z ~> m] real :: depth_scaled_khth_exp !< The exponent used in the depth dependent scaling function for KHTH [nondim] - real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [Z2 T-1 ~> m2 s-1] integer :: Res_fn_power_khth !< The power of dx/Ld in the KhTh resolution function. Any !! positive integer power may be used, but even powers !! and especially 2 are coded to be more efficient. @@ -156,7 +157,7 @@ module MOM_lateral_mixing_coeffs ! Diagnostics !>@{ !! Diagnostic identifier - integer :: id_SN_u=-1, id_SN_v=-1, id_L2u=-1, id_L2v=-1, id_Res_fn = -1 + integer :: id_SN_u=-1, id_SN_v=-1, id_UH_grad=-1, id_VH_grad=-1, id_L2u=-1, id_L2v=-1, id_L2grad_u=-1, id_L2grad_v=-1, id_Res_fn = -1 integer :: id_N2_u=-1, id_N2_v=-1, id_S2_u=-1, id_S2_v=-1 integer :: id_dzu=-1, id_dzv=-1, id_dzSxN=-1, id_dzSyN=-1 integer :: id_Rd_dx=-1, id_KH_u_QG = -1, id_KH_v_QG = -1 @@ -454,21 +455,17 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) if (CS%id_Res_fn > 0) call post_data(CS%id_Res_fn, CS%Res_fn_h, CS%diag) endif - if (CS%debug) then - call hchksum(CS%cg1, "calc_resoln_fn cg1", G%HI, haloshift=1, scale=US%L_T_to_m_s) - call uvchksum("Res_fn_[uv]", CS%Res_fn_u, CS%Res_fn_v, G%HI, haloshift=0, & - scale=1.0, scalar_pair=.true.) - endif - end subroutine calc_resoln_function !> Calculates and stores functions of isopycnal slopes, e.g. Sx, Sy, S*N, mostly used in the Visbeck et al. !! style scaling of diffusivity -subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) +subroutine calc_slope_functions(h, uh, vh, tv, dt, G, GV, US, CS, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)),intent(inout) :: uh !< Layer thickness times u [UH ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)),intent(inout) :: vh !< Layer thickness times v [VH ~> m2 s-1 or kg m-1 s-1] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, intent(in) :: dt !< Time increment [T ~> s] type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure @@ -499,7 +496,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) call calc_Visbeck_coeffs_old(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) else !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) - call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true.) + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, uh, vh, .true.) endif endif @@ -510,8 +507,12 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) if (CS%id_dzSyN > 0) call post_data(CS%id_dzSyN, dzSyN, CS%diag) if (CS%id_SN_u > 0) call post_data(CS%id_SN_u, CS%SN_u, CS%diag) if (CS%id_SN_v > 0) call post_data(CS%id_SN_v, CS%SN_v, CS%diag) + if (CS%id_UH_grad > 0) call post_data(CS%id_UH_grad, CS%UH_grad, CS%diag) + if (CS%id_VH_grad > 0) call post_data(CS%id_VH_grad, CS%VH_grad, CS%diag) if (CS%id_L2u > 0) call post_data(CS%id_L2u, CS%L2u, CS%diag) if (CS%id_L2v > 0) call post_data(CS%id_L2v, CS%L2v, CS%diag) + if (CS%id_L2grad_u > 0) call post_data(CS%id_L2grad_u, CS%L2grad_u, CS%diag) + if (CS%id_L2grad_v > 0) call post_data(CS%id_L2grad_v, CS%L2grad_v, CS%diag) if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) endif @@ -617,7 +618,7 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C !$OMP parallel do default(shared) private(S2,H_v,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) do J=js-1,je do i=is,ie - CS%SN_v(i,J) = 0. ; H_v(i) = 0. ; S2_v(i,J) = 0. + CS%SN_v(i,J) = 0.; H_v(i) = 0. ; S2_v(i,J) = 0. enddo do K=2,nz ; do i=is,ie Hdn = sqrt( h(i,j,k) * h(i,j+1,k) ) @@ -695,7 +696,7 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, integer :: i, j, k, l_seg logical :: crop - dz_neglect = GV%dZ_subroundoff + dz_neglect = GV%H_subroundoff * GV%H_to_Z D_scale = CS%Eady_GR_D_scale if (D_scale<=0.) D_scale = 64.*GV%max_depth ! 0 means use full depth so choose something big r_crp_dist = 1. / max( dz_neglect, CS%cropping_distance ) @@ -822,35 +823,42 @@ end subroutine calc_Eady_growth_rate_2D !> The original calc_slope_function() that calculated slopes using !! interface positions only, not accounting for density variations. -subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes) +!> Computes UH_grad and VH_grad for gradient model +subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, uh, vh, calculate_slopes) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uh !< Interface height times u [ZU ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vh !< Interface height times v [ZU ~> m2 s-1] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface position [Z ~> m] - ! type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables logical, intent(in) :: calculate_slopes !< If true, calculate slopes - !! internally otherwise use slopes stored in CS + !! internally otherwise use slopes stored in CS +!> logical, intent(in) :: use_gradient_model !< If true, calculate gradient model + real :: Lgrid !< Grid lengthscale for the gradient model [H ~> m] ! Local variables real :: E_x(SZIB_(G),SZJ_(G)) ! X-slope of interface at u points [Z L-1 ~> nondim] (for diagnostics) real :: E_y(SZI_(G),SZJB_(G)) ! Y-slope of interface at v points [Z L-1 ~> nondim] (for diagnostics) - real :: dz_tot(SZI_(G),SZJ_(G)) ! The total thickness of the water columns [Z ~> m] - ! real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! The vertical distance across each layer [Z ~> m] + real :: U_xH_x(SZIB_(G), SZJ_(G)) ! X-slope of U and H [T-1 ~> s-1] + real :: U_yH_y(SZI_(G), SZJB_(G)) ! Y-slope of U and H [T-1 ~> s-1] + real :: V_xH_x(SZIB_(G), SZJ_(G)) ! X-slope of V and H [T-1 ~> s-1] + real :: V_yH_y(SZI_(G), SZJB_(G)) ! Y-slope of V and H [T-1 ~> s-1] real :: H_cutoff ! Local estimate of a minimum thickness for masking [H ~> m or kg m-2] - real :: dZ_cutoff ! A minimum water column depth for masking [H ~> m or kg m-2] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: S2 ! Interface slope squared [Z2 L-2 ~> nondim] real :: N2 ! Brunt-Vaisala frequency squared [L2 Z-2 T-2 ~> s-2] + real :: gradUH ! Gradient model frequency, zonal transport [T-1 ~> s-1] + real :: gradVH ! Gradient model frequency, merid transport [T-1 ~> s-1] real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. real :: S2N2_u_local(SZIB_(G),SZJ_(G),SZK_(GV)) ! The depth integral of the slope times ! the buoyancy frequency squared at u-points [Z T-2 ~> m s-2] real :: S2N2_v_local(SZI_(G),SZJB_(G),SZK_(GV)) ! The depth integral of the slope times ! the buoyancy frequency squared at v-points [Z T-2 ~> m s-2] - logical :: use_dztot ! If true, use the total water column thickness rather than the - ! bathymetric depth for certain calculations. + real :: UH_grad_local(SZIB_(G), SZJ_(G),SZK_(GV)) ! The depth integral of grad slopes for UH at u-points + real :: VH_grad_local(SZI_(G), SZJB_(G),SZK_(GV)) ! The depth integral of grad slopes for VH at v-points integer :: is, ie, js, je, nz integer :: i, j, k integer :: l_seg @@ -863,36 +871,39 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop "%SN_u is not associated with use_variable_mixing.") if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:"// & "%SN_v is not associated with use_variable_mixing.") + if (.not. allocated(CS%UH_grad)) call MOM_error(FATAL, "calc_slope_function:"// & + "%UH_grad is not associated with use_gradient_model.") + if (.not. allocated(CS%VH_grad)) call MOM_error(FATAL, "calc_slope_function:"// & + "%VH_grad is not associated with use_gradient_model.") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke h_neglect = GV%H_subroundoff H_cutoff = real(2*nz) * (GV%Angstrom_H + h_neglect) - dZ_cutoff = real(2*nz) * (GV%Angstrom_Z + GV%dz_subroundoff) - - use_dztot = CS%full_depth_Eady_growth_rate ! .or. .not.(GV%Boussinesq or GV%semi_Boussinesq) - - if (use_dztot) then - !$OMP parallel do default(shared) - do j=js-1,je+1 ; do i=is-1,ie+1 - dz_tot(i,j) = e(i,j,1) - e(i,j,nz+1) - enddo ; enddo - ! The following mathematically equivalent expression is more expensive but is less - ! sensitive to roundoff for large Z_ref: - ! call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) - ! do j=js-1,je+1 - ! do i=is-1,ie+1 ; dz_tot(i,j) = 0.0 ; enddo - ! do k=1,nz ; do i=is-1,ie+1 - ! dz_tot(i,j) = dz_tot(i,j) + dz(i,j,k) - ! enddo ; enddo - ! enddo - endif + ! To set length scale for gradient model ! To set the length scale based on the deformation radius, use wave_speed to ! calculate the first-mode gravity wave speed and then blend the equatorial ! and midlatitude deformation radii, using calc_resoln_function as a template. !$OMP parallel do default(shared) private(E_x,E_y,S2,Hdn,Hup,H_geom,N2) + ! Set the length scale at u-points. +!$OMP do + do j=js,je ; do I=is-1,ie +! CS%L2u(I,j) = CS%Visbeck_L_scale**2 + Lgrid = sqrt(G%dxCu(I,j)**2 + G%dyCu(I,j)**2) +! CS%L2grad_u(I,j) = CS%grad_L_scale * Lgrid**2 + CS%L2grad_u(I,j) = 1.0 * Lgrid**2 + enddo ; enddo + ! Set length scale at v-points +!$OMP do + do J=js-1,je ; do i=is,ie +! CS%L2v(i,J) = CS%Visbeck_L_scale**2 + Lgrid = sqrt(G%dxCv(i,J)**2 + G%dyCv(i,J)**2) +! CS%L2grad_v(i,J) = CS%grad_L_scale * Lgrid**2 + CS%L2grad_v(i,J) = 1.0 * Lgrid**2 + enddo ; enddo +!$OMP do do k=nz,CS%VarMix_Ktop,-1 if (calculate_slopes) then @@ -900,100 +911,145 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop do j=js-1,je+1 ; do I=is-1,ie E_x(I,j) = (e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) ! Mask slopes where interface intersects topography - if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. + if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. enddo ; enddo do J=js-1,je ; do i=is-1,ie+1 E_y(i,J) = (e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) ! Mask slopes where interface intersects topography - if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. + if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) E_y(I,j) = 0. enddo ; enddo else ! This branch is not used. do j=js-1,je+1 ; do I=is-1,ie E_x(I,j) = CS%slope_x(I,j,k) - if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. + if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. enddo ; enddo - do J=js-1,je ; do i=is-1,ie+1 + do j=js-1,je ; do I=is-1,ie+1 E_y(i,J) = CS%slope_y(i,J,k) - if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. + if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) E_y(I,j) = 0. + enddo ; enddo + endif + + if (calculate_slopes) then + ! Calculate the gradient slopes U_xH_x, V_xH_x, U_yH_y, V_yH_y on u- and v-points respectively + do j=js-1,je+1 ; do I=is-1,ie + U_xH_x(I,j) =1.0*(G%IdxCu(I+1,j)*G%IdyCu(I+1,j)*uh(I+1,j,K) - G%IdxCu(I,j)*G%IdyCu(I,j)*uh(I,j,k))*( & + G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dyCu(I,j) * (1.0*(h(I+1,j,K) - h(I,j,K))/( & + h(I+1,j,K) + h(I,j,K) + h_neglect)) + V_xH_x(I,j) =1.0*(G%IdxCv(I+1,j)*G%IdxCv(I+1,j)*vh(I+1,j,K) - G%IdxCv(I,j)*G%IdxCv(I,j)*vh(I,j,k))*( & + G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dyCu(I,j) * (1.0*(h(I+1,j,K) - h(I,j,K))/( & + h(I+1,j,K) + h(I,j,K) + h_neglect)) + ! Mask slopes where interface intersects topography + if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) U_xH_x(I,j) = 0. + if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) V_xH_x(I,j) = 0. + enddo ; enddo + do J=js-1,je ; do i=is-1,ie+1 + U_yH_y(i,J) =1.0*(G%IdyCu(i,J+1)*G%IdyCu(i,J+1)*uh(i,J+1,K) - G%IdyCu(i,J)*G%IdyCu(i,J)*uh(i,J,k))*( & + G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCu(i,J) * (1.0*(h(i,J+1,K) - h(i,J,K))/( & + h(i,J+1,K) + h(i,J,K) + h_neglect)) + V_yH_y(i,J) =1.0*(G%IdyCv(i,J+1)*G%IdxCv(i,J+1)*vh(i,J,K) - G%IdyCv(i,J)*G%IdxCv(i,J)*vh(i,J,k))*( & + G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCv(I,j) * (1.0*(h(i,J+1,K) - h(i,J,K))/( & + h(i,J+1,K) + h(i,J,K) + h_neglect)) + ! Mask slopes where interface intersects topography + if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) U_yH_y(I,j) = 0. + if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) V_yH_y(I,j) = 0. + enddo ; enddo + else ! This branch is not used. + do j=js-1,je+1 ; do I=is-1,ie + U_xH_x(I,j) =1.0*(G%IdxCu(I+1,j)*G%IdyCu(I+1,j)*uh(I+1,j,K) - G%IdxCu(I,j)*G%IdyCu(I,j)*uh(I,j,k))*( & + G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dyCu(I,j) * (1.0*(h(I+1,j,K) - h(I,j,K))/( & + h(I+1,j,K) + h(I,j,K) + h_neglect)) + V_xH_x(I,j) =1.0*(G%IdxCv(I+1,j)*G%IdxCv(I+1,j)*vh(I+1,j,K) - G%IdxCv(I,j)*G%IdxCv(I,j)*vh(I,j,k))*( & + G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dy_Cu(I,j) * (1.0*(h(I+1,j,K) - h(I,j,K))/( & + h(I+1,j,K) + h(I,j,K) + h_neglect)) + if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) U_xH_x(I,j) = 0. + if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) V_xH_x(I,j) = 0. + enddo ; enddo + do j=js-1,je ; do I=is-1,ie+1 + U_yH_y(i,J) =1.0*(G%IdyCu(i,J+1)*G%IdyCu(i,J+1)*uh(i,J+1,K) - G%IdyCu(i,J)*G%IdyCu(i,J)*uh(i,J,k))*( & + G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCu(i,J) * (1.0*(h(i,J+1,K) - h(i,J,K))/( & + h(i,J+1,K) + h(i,J,K) + h_neglect)) + V_yH_y(i,J) =1.0*(G%IdyCv(i,J+1)*G%IdxCv(i,J+1)*vh(i,J,K) - G%IdyCv(i,J)*G%IdxCv(i,J)*vh(i,J,k))*( & + G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCv(I,j) * (1.0*(h(i,J+1,K) - h(i,J,K))/( & + h(i,J+1,K) + h(i,J,K) + h_neglect)) + if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) U_yH_y(I,j) = 0. + if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) V_yH_y(I,j) = 0. enddo ; enddo endif ! Calculate N*S*h from this layer and add to the sum do j=js,je ; do I=is-1,ie S2 = ( E_x(I,j)**2 + 0.25*( & - (E_y(i,J)**2+E_y(i+1,J-1)**2) + (E_y(i+1,J)**2+E_y(i,J-1)**2) ) ) - if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) S2 = 0.0 - + (E_y(I,j)**2+E_y(I+1,j-1)**2) + (E_y(I+1,j)**2+E_y(I,j-1)**2) ) ) Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i+1,j,k)*h(i+1,j,k-1) / (h(i+1,j,k) + h(i+1,j,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - ! N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) - S2N2_u_local(I,j,k) = (H_geom * S2) * (GV%g_prime(k) / max(Hdn, Hup, CS%h_min_N2) ) + N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) + gradUH = U_xH_x(I,j) + 0.25*(U_yH_y(I,j)+U_yH_y(I,j-1)+U_yH_y(I+1,j)+U_yH_y(I+1,j-1)) + if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) & + S2 = 0.0 + S2N2_u_local(I,j,k) = (H_geom * GV%H_to_Z) * S2 * N2 + UH_grad_local(I,j,k) = gradUH enddo ; enddo do J=js-1,je ; do i=is,ie S2 = ( E_y(i,J)**2 + 0.25*( & - (E_x(I,j)**2+E_x(I-1,j+1)**2) + (E_x(I,j+1)**2+E_x(I-1,j)**2) ) ) - if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) S2 = 0.0 - + (E_x(i,J)**2+E_x(i-1,J+1)**2) + (E_x(i,J+1)**2+E_x(i-1,J)**2) ) ) Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i,j+1,k)*h(i,j+1,k-1) / (h(i,j+1,k) + h(i,j+1,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - ! N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) - S2N2_v_local(i,J,k) = (H_geom * S2) * (GV%g_prime(k) / (max(Hdn, Hup, CS%h_min_N2))) + N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) + gradVH = 0.25*(V_xH_x(i,J)+V_xH_x(i-1,J)+V_xH_x(i,J+1)+V_xH_x(i-1,J+1))+V_yH_y(i,J) + if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) & + S2 = 0.0 + S2N2_v_local(i,J,k) = (H_geom * GV%H_to_Z) * S2 * N2 + VH_grad_local(i,J,k) = gradVH enddo ; enddo enddo ! k - !$OMP parallel do default(shared) do j=js,je - do I=is-1,ie ; CS%SN_u(I,j) = 0.0 ; enddo + do I=is-1,ie ; CS%SN_u(I,j) = 0.0 ; enddo do k=nz,CS%VarMix_Ktop,-1 ; do I=is-1,ie CS%SN_u(I,j) = CS%SN_u(I,j) + S2N2_u_local(I,j,k) + CS%UH_grad(I,j,k) = UH_grad_local(I,j,k) +!! print*, "UH_grad=", CS%UH_grad(I,j,k) enddo ; enddo ! SN above contains S^2*N^2*H, convert to vertical average of S*N - - if (use_dztot) then - do I=is-1,ie + do I=is-1,ie + !### Replace G%bathT+G%Z_ref here with (e(i,j,1) - e(i,j,nz+1)). + !SN_u(I,j) = sqrt( SN_u(I,j) / ( max(G%bathyT(i,j), G%bathyT(i+1,j)) + (G%Z_ref + GV%Angstrom_Z) ) ) + !The code below behaves better than the line above. Not sure why? AJA + if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > H_cutoff*GV%H_to_Z ) then CS%SN_u(I,j) = G%OBCmaskCu(I,j) * sqrt( CS%SN_u(I,j) / & - max(dz_tot(i,j), dz_tot(i+1,j), GV%dz_subroundoff) ) - enddo - else - do I=is-1,ie - if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > dZ_cutoff ) then - CS%SN_u(I,j) = G%OBCmaskCu(I,j) * sqrt( CS%SN_u(I,j) / & - (max(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref) ) - else - CS%SN_u(I,j) = 0.0 - endif - enddo - endif + (max(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref) ) +!! CS%UH_grad(I,j) = G%OBCmaskCu(I,j) * ( CS%UH_grad(I,j) / (max(G%bathyT(I,j), G%bathyT(I+1,j)) + G%Z_ref) ) + else + CS%SN_u(I,j) = 0.0 +!! CS%UH_grad(I,j) = 0.0 + endif + enddo enddo !$OMP parallel do default(shared) do J=js-1,je - do i=is,ie ; CS%SN_v(i,J) = 0.0 ; enddo + do i=is,ie ; CS%SN_v(i,J) = 0.0 ; enddo do k=nz,CS%VarMix_Ktop,-1 ; do i=is,ie CS%SN_v(i,J) = CS%SN_v(i,J) + S2N2_v_local(i,J,k) + CS%VH_grad(i,J,k) = VH_grad_local(i,J,k) +!! print*, "VH_grad=", CS%VH_grad(I,j,k) enddo ; enddo - if (use_dztot) then - do i=is,ie + do i=is,ie + !### Replace G%bathT+G%Z_ref here with (e(i,j,1) - e(i,j,nz+1)). + !SN_v(i,J) = sqrt( SN_v(i,J) / ( max(G%bathyT(i,J), G%bathyT(i,J+1)) + (G%Z_ref + GV%Angstrom_Z) ) ) + !The code below behaves better than the line above. Not sure why? AJA + if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > H_cutoff*GV%H_to_Z ) then CS%SN_v(i,J) = G%OBCmaskCv(i,J) * sqrt( CS%SN_v(i,J) / & - max(dz_tot(i,j), dz_tot(i,j+1), GV%dz_subroundoff) ) - enddo - else - do i=is,ie - ! There is a primordial horizontal indexing bug on the following line from the previous - ! versions of the code. This comment should be deleted by the end of 2024. - ! if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > dZ_cutoff ) then - if ( min(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref > dZ_cutoff ) then - CS%SN_v(i,J) = G%OBCmaskCv(i,J) * sqrt( CS%SN_v(i,J) / & - (max(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref) ) - else - CS%SN_v(i,J) = 0.0 - endif - enddo - endif + (max(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref) ) +! CS%VH_grad(i,J) = G%OBCmaskCv(i,J) * (CS%VH_grad(i,J) / (max(G%bathyT(i,J), G%bathyT(i,J+1)) + G%Z_ref) ) + else + CS%SN_v(i,J) = 0.0 +! CS%VH_grad(i,J) = 0.0 + endif + enddo enddo - end subroutine calc_slope_functions_using_just_e !> Calculates the Leith Laplacian and bi-harmonic viscosity coefficients @@ -1031,7 +1087,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo real :: Ih ! The inverse of a combination of thicknesses [H-1 ~> m-1 or m2 kg-1] real :: f ! A copy of the Coriolis parameter [T-1 ~> s-1] real :: inv_PI3 ! The inverse of pi cubed [nondim] - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq,nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -1051,8 +1107,8 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo h_at_slope_below = 2. * ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) * h(i+1,j,k+1) ) / & ( ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) + h(i+1,j,k+1) ) & + ( h(i,j,k+1) * h(i+1,j,k+1) ) * ( h(i,j,k) + h(i+1,j,k) ) + GV%H_subroundoff**2 ) - Ih = 1. / ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) - dslopex_dz(I,j) = 2. * ( CS%slope_x(i,j,k) - CS%slope_x(i,j,k+1) ) * (GV%Z_to_H * Ih) + Ih = 1./ ( ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) * GV%H_to_Z ) + dslopex_dz(I,j) = 2. * ( CS%slope_x(i,j,k) - CS%slope_x(i,j,k+1) ) * Ih h_at_u(I,j) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo @@ -1065,8 +1121,8 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo h_at_slope_below = 2. * ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) * h(i,j+1,k+1) ) / & ( ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) + h(i,j+1,k+1) ) & + ( h(i,j,k+1) * h(i,j+1,k+1) ) * ( h(i,j,k) + h(i,j+1,k) ) + GV%H_subroundoff**2 ) - Ih = 1. / ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) - dslopey_dz(i,J) = 2. * ( CS%slope_y(i,j,k) - CS%slope_y(i,j,k+1) ) * (GV%Z_to_H * Ih) + Ih = 1./ ( ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) * GV%H_to_Z ) + dslopey_dz(i,J) = 2. * ( CS%slope_y(i,j,k) - CS%slope_y(i,j,k+1) ) * Ih h_at_v(i,J) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo @@ -1149,16 +1205,20 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ! for the epipycnal tracer diffusivity [nondim] real :: KhTh_Slope_Cff ! The nondimensional coefficient in the Visbeck formula ! for the interface depth diffusivity [nondim] + real :: Grad_L_Scale ! The nondimensional coefficient in the gradient formula + ! for the depth diffusivity [nondim] real :: oneOrTwo ! A variable that may be 1 or 2, depending on which form ! of the equatorial deformation radius us used [nondim] real :: N2_filter_depth ! A depth below which stratification is treated as monotonic when - ! calculating the first-mode wave speed [H ~> m or kg m-2] + ! calculating the first-mode wave speed [Z ~> m] real :: KhTr_passivity_coeff ! Coefficient setting the ratio between along-isopycnal tracer ! mixing and interface height mixing [nondim] real :: absurdly_small_freq ! A miniscule frequency that is used to avoid division by 0 [T-1 ~> s-1]. The ! default value is roughly (pi / (the age of the universe)). logical :: Gill_equatorial_Ld, use_FGNV_streamfn, use_MEKE, in_use integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. + logical :: remap_answers_2018 integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust @@ -1192,9 +1252,9 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%calculate_cg1 = .false. CS%calculate_Rd_dx = .false. CS%calculate_res_fns = .false. - CS%use_simpler_Eady_growth_rate = .false. - CS%full_depth_Eady_growth_rate = .false. + CS%use_simpler_Eady_growth_rate = .false. CS%calculate_depth_fns = .false. + CS%use_gradient_model = .false. ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USE_VARIABLE_MIXING", CS%use_variable_mixing,& @@ -1203,6 +1263,11 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "not used. If KHTR_SLOPE_CFF>0 or KhTh_Slope_Cff>0, "//& "this is set to true regardless of what is in the "//& "parameter file.", default=.false.) + call get_param(param_file, mdl, "USE_GRADIENT_MODEL", CS%use_gradient_model,& + "If true, use the gradient model formula for eddy diffusivity. This "//& + "allows diagnostics to be created even if the scheme is "//& + "not used. If Grad_L_Scale>0, this is set to true regardless of what "//& + "is in the parameter file.", default=.false.) call get_param(param_file, mdl, "USE_VISBECK", CS%use_Visbeck,& "If true, use the Visbeck et al. (1997) formulation for \n"//& "thickness diffusivity.", default=.false.) @@ -1287,9 +1352,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) in_use = .true. call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & "The depth below which N2 is monotonized to avoid stratification "//& - "artifacts from altering the equivalent barotropic mode structure. "//& - "This monotonzization is disabled if this parameter is negative.", & - units="m", default=-1.0, scale=GV%m_to_H) + "artifacts from altering the equivalent barotropic mode structure.",& + units="m", default=2000., scale=US%m_to_Z) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke), source=0.0) endif @@ -1313,7 +1377,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) + units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) endif if (CS%calculate_Eady_growth_rate) then @@ -1348,18 +1412,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "The minimum vertical distance to use in the denominator of the "//& "bouyancy frequency used in the slope calculation.", & units="m", default=1.0, scale=GV%m_to_H, do_not_log=CS%use_stored_slopes) - - call get_param(param_file, mdl, "FULL_DEPTH_EADY_GROWTH_RATE", CS%full_depth_Eady_growth_rate, & - "If true, calculate the Eady growth rate based on average slope times "//& - "stratification that includes contributions from sea-level changes "//& - "in its denominator, rather than just the nominal depth of the bathymetry. "//& - "This only applies when using the model interface heights as a proxy for "//& - "isopycnal slopes.", default=.not.(GV%Boussinesq.or.GV%semi_Boussinesq), & - do_not_log=CS%use_stored_slopes) endif endif - if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then + if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then in_use = .true. call get_param(param_file, mdl, "VISBECK_L_SCALE", CS%Visbeck_L_scale, & "The fixed length scale in the Visbeck formula, or if negative a nondimensional "//& @@ -1388,6 +1444,27 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'm2', conversion=US%L_to_m**2) endif + if (CS%use_gradient_model) then + in_use = .true. + call get_param(param_file, mdl, "GRAD_L_SCALE", CS%grad_L_scale, & + "The fixed length scale in the gradient formula.", units="m", & + default=1.0) + allocate(CS%UH_grad(IsdB:IedB,jsd:jed,GV%ke), source=0.0) + allocate(CS%VH_grad(isd:ied,JsdB:JedB,GV%ke), source=0.0) + allocate(CS%L2grad_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%L2grad_v(isd:ied,JsdB:JedB), source=0.0) + endif + + CS%id_UH_grad = register_diag_field('ocean_model', 'UH_grad', diag%axesCu1, Time, & + 'Inverse gradient eddy time-scale, U_xH_x+U_yH_y, at u-points', 's^-1') + CS%id_VH_grad = register_diag_field('ocean_model', 'VH_grad', diag%axesCv1, Time, & + 'Inverse gradient eddy time-scale, V_xH_x+V_yH_y, at v-points', 's^-1') + CS%id_L2grad_u = register_diag_field('ocean_model', 'L2grad_u', diag%axesCu1, Time, & + 'Length scale squared for gradient coefficient, at u-points', 'm^2') + CS%id_L2grad_v = register_diag_field('ocean_model', 'L2grad_v', diag%axesCv1, Time, & + 'Length scale squared for gradient coefficient, at v-points', 'm^2') + + if (CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) then CS%id_N2_u = register_diag_field('ocean_model', 'N2_u', diag%axesCui, Time, & 'Square of Brunt-Vaisala frequency, N^2, at u-points, as used in Visbeck et al.', & @@ -1438,7 +1515,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%id_Res_fn = register_diag_field('ocean_model', 'Res_fn', diag%axesT1, Time, & 'Resolution function for scaling diffusivities', 'nondim') - + call get_param(param_file, mdl, "KH_RES_SCALE_COEF", CS%Res_coef_khth, & "A coefficient that determines how KhTh is scaled away if "//& "RESOLN_SCALED_... is true, as "//& @@ -1561,13 +1638,23 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=(default_answer_date<20190101)) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) + ! Revise inconsistent default answer dates for remapping. + if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions.", & - default=default_answer_date, do_not_log=.not.GV%Boussinesq) - if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) + "robust and accurate forms of mathematically equivalent expressions. "//& + "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& + "latter takes precedence.", default=default_answer_date) call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & "The fractional tolerance for finding the wave speeds.", & From b7cad7eba15db2a982e301678d7a3be5cf0255fb Mon Sep 17 00:00:00 2001 From: Sinakhani Date: Wed, 16 Oct 2024 11:39:09 -0500 Subject: [PATCH 4/7] Gradient model is updated --- .../lateral/MOM_thickness_diffuse.F90 | 33 ++++++++++++++++--- 1 file changed, 29 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 2638ca71e1..bcba8f2021 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -38,6 +38,7 @@ module MOM_thickness_diffuse logical :: initialized = .false. !< True if this control structure has been initialized. real :: Khth !< Background isopycnal depth diffusivity [L2 T-1 ~> m2 s-1] real :: Khth_Slope_Cff !< Slope dependence coefficient of Khth [nondim] + real :: Grad_L_Scale !< Gradient model coefficient [nondim] real :: max_Khth_CFL !< Maximum value of the diffusive CFL for isopycnal height diffusion [nondim] real :: Khth_Min !< Minimum value of Khth [L2 T-1 ~> m2 s-1] real :: Khth_Max !< Maximum value of Khth [L2 T-1 ~> m2 s-1], or 0 for no max @@ -192,16 +193,17 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp use_VarMix = .false. ; Resoln_scaled = .false. ; use_stored_slopes = .false. khth_use_ebt_struct = .false. ; use_Visbeck = .false. ; use_QG_Leith = .false. - Depth_scaled = .false. + Depth_scaled = .false. if (VarMix%use_variable_mixing) then - use_VarMix = VarMix%use_variable_mixing .and. (CS%KHTH_Slope_Cff > 0.) + use_VarMix = VarMix%use_variable_mixing .and. (CS%KHTH_Slope_Cff > 0.) .or. (CS%Grad_L_Scale > 0.) Resoln_scaled = VarMix%Resoln_scaled_KhTh Depth_scaled = VarMix%Depth_scaled_KhTh use_stored_slopes = VarMix%use_stored_slopes khth_use_ebt_struct = VarMix%khth_use_ebt_struct use_Visbeck = VarMix%use_Visbeck use_QG_Leith = VarMix%use_QG_Leith_GM +!> use_gradient_model = VarMix%use_gradient_model if (allocated(VarMix%cg1)) cg1 => VarMix%cg1 else cg1 => null() @@ -312,6 +314,17 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif endif + if (use_VarMix) then + if (CS%Grad_L_Scale > 0.0) then + !$OMP do + do k=1,nz ; do j=js,je ; do I=is-1,ie + KH_u(I,j,k) = 1.0*CS%Grad_L_Scale*VarMix%L2grad_u(I,j)*VarMix%UH_grad(I,j,k) +!! print*, "KH_u=", KH_u(I,j,k) + enddo ; enddo ; enddo + endif + endif + + if (CS%use_GME_thickness_diffuse) then !$OMP do do k=1,nz+1 ; do j=js,je ; do I=is-1,ie @@ -408,6 +421,16 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif endif + if (use_VarMix) then + if (CS%Grad_L_Scale > 0.0) then !< Gradient model + !$OMP do + do k=1,nz ; do J=js-1,je ; do i=is,ie + KH_v(i,J,k) = 1.0*CS%Grad_L_Scale*VarMix%L2grad_v(i,J)*VarMix%VH_grad(i,J,k) +!! print*, "KH_v=", KH_v(i,J,k) + enddo ; enddo ; enddo + endif + endif + if (CS%use_GME_thickness_diffuse) then !$OMP do do k=1,nz+1 ; do J=js-1,je ; do i=is,ie @@ -773,11 +796,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV I4dt = 0.25 / dt I_slope_max2 = 1.0 / (CS%slope_max**2) - G_scale = GV%g_Earth * GV%H_to_Z h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 ; hn_2 = 0.5*h_neglect dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect**2 - G_rho0 = GV%g_Earth / GV%Rho0 + if (GV%Boussinesq) G_rho0 = GV%g_Earth / GV%Rho0 N2_floor = CS%N2_floor * US%Z_to_L**2 use_EOS = associated(tv%eqn_of_state) @@ -2132,6 +2154,9 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "KHTH_SLOPE_CFF", CS%KHTH_Slope_Cff, & "The nondimensional coefficient in the Visbeck formula for "//& "the interface depth diffusivity", units="nondim", default=0.0) + call get_param(param_file, mdl, "GRAD_L_SCALE", CS%GRAD_L_Scale, & + "The nondimensional coefficient in the Gradient model for "//& + "the thickness depth diffusivity", units="nondim", default=1.0) call get_param(param_file, mdl, "KHTH_MIN", CS%KHTH_Min, & "The minimum horizontal thickness diffusivity.", & default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) From 554d15b2da4765f05b69270ccef2e0feebffa865 Mon Sep 17 00:00:00 2001 From: Sinakhani Date: Wed, 16 Oct 2024 13:13:38 -0500 Subject: [PATCH 5/7] MOM.F90 is updated to accommodate the Gradient model --- src/core/MOM.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index de58a2f3bb..6d0714d7b9 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1125,6 +1125,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & u => NULL(), & ! u : zonal velocity component [L T-1 ~> m s-1] v => NULL(), & ! v : meridional velocity component [L T-1 ~> m s-1] h => NULL() ! h : layer thickness [H ~> m or kg m-2] + uh => NULL(), & ! uh : layer thickness times u [UH ~> m2 s-1 or kg m-1 s-1] + vh => NULL() ! vh : layer thickness times v [VH ~> m2 s-1 or kg m-1 s-1] logical :: calc_dtbt ! Indicates whether the dynamically adjusted ! barotropic time step needs to be updated. @@ -1138,7 +1140,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - u => CS%u ; v => CS%v ; h => CS%h + u => CS%u ; v => CS%v ; h => CS%h ; uh => CS%uh ; vh => CS%vh showCallTree = callTree_showQuery() call cpu_clock_begin(id_clock_dynamics) @@ -1159,7 +1161,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (CS%thickness_diffuse) then call cpu_clock_begin(id_clock_thick_diff) if (CS%VarMix%use_variable_mixing) & - call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) + call calc_slope_functions(h, uh, vh, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) call cpu_clock_end(id_clock_thick_diff) @@ -1297,7 +1299,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (CS%thickness_diffuse) then call cpu_clock_begin(id_clock_thick_diff) if (CS%VarMix%use_variable_mixing) & - call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) + call calc_slope_functions(h, uh, vh, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) @@ -1907,7 +1909,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_depth_function(G, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) + call calc_slope_functions(CS%h, CS%uh, CS%vh, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, CS%visc, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) From d8e2f3c9b6201e39e0ae7eb3af15f2c8662cc039 Mon Sep 17 00:00:00 2001 From: Sinakhani Date: Fri, 18 Oct 2024 13:34:38 -0500 Subject: [PATCH 6/7] Gradient model is updated --- .../lateral/MOM_lateral_mixing_coeffs.F90 | 38 +++++++++---------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index e2e7eaa5ea..f0bb980c63 100644 --- a/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -27,7 +27,7 @@ module MOM_lateral_mixing_coeffs type, public :: VarMix_CS logical :: initialized = .false. !< True if this control structure has been initialized. logical :: use_variable_mixing !< If true, use the variable mixing. -!> logical :: use_gradient_model !< If true, use the gradient model. + logical :: use_gradient_model !< If true, use the gradient model. logical :: Resoln_scaling_used !< If true, a resolution function is used somewhere to scale !! away one of the viscosities or diffusivities when the !! deformation radius is well resolved. @@ -933,21 +933,21 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, uh, vh, calcul ! Calculate the gradient slopes U_xH_x, V_xH_x, U_yH_y, V_yH_y on u- and v-points respectively do j=js-1,je+1 ; do I=is-1,ie U_xH_x(I,j) =1.0*(G%IdxCu(I+1,j)*G%IdyCu(I+1,j)*uh(I+1,j,K) - G%IdxCu(I,j)*G%IdyCu(I,j)*uh(I,j,k))*( & - G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dyCu(I,j) * (2.0*(h(I+1,j,K) - h(I,j,K))/( & + G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dyCu(I,j) * (1.0*(h(I+1,j,K) - h(I,j,K))/( & h(I+1,j,K) + h(I,j,K) + h_neglect)) V_xH_x(I,j) =1.0*(G%IdxCv(I+1,j)*G%IdxCv(I+1,j)*vh(I+1,j,K) - G%IdxCv(I,j)*G%IdxCv(I,j)*vh(I,j,k))*( & - G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dyCu(I,j) * (2.0*(h(I+1,j,K) - h(I,j,K))/( & + G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dyCu(I,j) * (1.0*(h(I+1,j,K) - h(I,j,K))/( & h(I+1,j,K) + h(I,j,K) + h_neglect)) ! Mask slopes where interface intersects topography if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) U_xH_x(I,j) = 0. if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) V_xH_x(I,j) = 0. enddo ; enddo do J=js-1,je ; do i=is-1,ie+1 - U_yH_y(i,J) =1.0*(G%IdyCu(i,J+1)**G%IdyCu(i,J+1)*uh(i,J+1,K) - G%IdyCu(i,J)*G%IdyCu(i,J)*uh(i,J,k))*( & - G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCu(i,J) * (2.0*(h(i,J+1,K) - h(i,J,K))/( & + U_yH_y(i,J) =1.0*(G%IdyCu(i,J+1)*G%IdyCu(i,J+1)*uh(i,J+1,K) - G%IdyCu(i,J)*G%IdyCu(i,J)*uh(i,J,k))*( & + G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCu(i,J) * (1.0*(h(i,J+1,K) - h(i,J,K))/( & h(i,J+1,K) + h(i,J,K) + h_neglect)) V_yH_y(i,J) =1.0*(G%IdyCv(i,J+1)*G%IdxCv(i,J+1)*vh(i,J,K) - G%IdyCv(i,J)*G%IdxCv(i,J)*vh(i,J,k))*( & - G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCv(I,j) * (2.0*(h(i,J+1,K) - h(i,J,K))/( & + G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCv(I,j) * (1.0*(h(i,J+1,K) - h(i,J,K))/( & h(i,J+1,K) + h(i,J,K) + h_neglect)) ! Mask slopes where interface intersects topography if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) U_yH_y(I,j) = 0. @@ -956,20 +956,20 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, uh, vh, calcul else ! This branch is not used. do j=js-1,je+1 ; do I=is-1,ie U_xH_x(I,j) =1.0*(G%IdxCu(I+1,j)*G%IdyCu(I+1,j)*uh(I+1,j,K) - G%IdxCu(I,j)*G%IdyCu(I,j)*uh(I,j,k))*( & - G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dyCu(I,j) * (2.0*(h(I+1,j,K) - h(I,j,K))/( & + G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dyCu(I,j) * (1.0*(h(I+1,j,K) - h(I,j,K))/( & h(I+1,j,K) + h(I,j,K) + h_neglect)) V_xH_x(I,j) =1.0*(G%IdxCv(I+1,j)*G%IdxCv(I+1,j)*vh(I+1,j,K) - G%IdxCv(I,j)*G%IdxCv(I,j)*vh(I,j,k))*( & - G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dy_Cu(I,j) * (2.0*(h(I+1,j,K) - h(I,j,K))/( & + G%IareaT(I+1,j) + G%IareaT(I,j)) * G%dy_Cu(I,j) * (1.0*(h(I+1,j,K) - h(I,j,K))/( & h(I+1,j,K) + h(I,j,K) + h_neglect)) if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) U_xH_x(I,j) = 0. if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) V_xH_x(I,j) = 0. enddo ; enddo do j=js-1,je ; do I=is-1,ie+1 U_yH_y(i,J) =1.0*(G%IdyCu(i,J+1)*G%IdyCu(i,J+1)*uh(i,J+1,K) - G%IdyCu(i,J)*G%IdyCu(i,J)*uh(i,J,k))*( & - G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCu(i,J) * (2.0*(h(i,J+1,K) - h(i,J,K))/( & + G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCu(i,J) * (1.0*(h(i,J+1,K) - h(i,J,K))/( & h(i,J+1,K) + h(i,J,K) + h_neglect)) V_yH_y(i,J) =1.0*(G%IdyCv(i,J+1)*G%IdxCv(i,J+1)*vh(i,J,K) - G%IdyCv(i,J)*G%IdxCv(i,J)*vh(i,J,k))*( & - G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCv(I,j) * (2.0*(h(i,J+1,K) - h(i,J,K))/( & + G%IareaT(i,J+1) + G%IareaT(i,J)) * G%dxCv(I,j) * (1.0*(h(i,J+1,K) - h(i,J,K))/( & h(i,J+1,K) + h(i,J,K) + h_neglect)) if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) U_yH_y(I,j) = 0. if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) V_yH_y(I,j) = 0. @@ -987,7 +987,6 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, uh, vh, calcul gradUH = U_xH_x(I,j) + 0.25*(U_yH_y(I,j)+U_yH_y(I,j-1)+U_yH_y(I+1,j)+U_yH_y(I+1,j-1)) if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) & S2 = 0.0 - gradUH = 0.0 S2N2_u_local(I,j,k) = (H_geom * GV%H_to_Z) * S2 * N2 UH_grad_local(I,j,k) = gradUH enddo ; enddo @@ -1001,7 +1000,6 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, uh, vh, calcul gradVH = 0.25*(V_xH_x(i,J)+V_xH_x(i-1,J)+V_xH_x(i,J+1)+V_xH_x(i-1,J+1))+V_yH_y(i,J) if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) & S2 = 0.0 - gradVH = 0.0 S2N2_v_local(i,J,k) = (H_geom * GV%H_to_Z) * S2 * N2 VH_grad_local(i,J,k) = gradVH enddo ; enddo @@ -1013,6 +1011,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, uh, vh, calcul do k=nz,CS%VarMix_Ktop,-1 ; do I=is-1,ie CS%SN_u(I,j) = CS%SN_u(I,j) + S2N2_u_local(I,j,k) CS%UH_grad(I,j,k) = UH_grad_local(I,j,k) +!! print*, "UH_grad=", CS%UH_grad(I,j,k) enddo ; enddo ! SN above contains S^2*N^2*H, convert to vertical average of S*N do I=is-1,ie @@ -1035,6 +1034,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, uh, vh, calcul do k=nz,CS%VarMix_Ktop,-1 ; do i=is,ie CS%SN_v(i,J) = CS%SN_v(i,J) + S2N2_v_local(i,J,k) CS%VH_grad(i,J,k) = VH_grad_local(i,J,k) +!! print*, "VH_grad=", CS%VH_grad(I,j,k) enddo ; enddo do i=is,ie !### Replace G%bathT+G%Z_ref here with (e(i,j,1) - e(i,j,nz+1)). @@ -1050,7 +1050,6 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, uh, vh, calcul endif enddo enddo - end subroutine calc_slope_functions_using_just_e !> Calculates the Leith Laplacian and bi-harmonic viscosity coefficients @@ -1255,6 +1254,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%calculate_res_fns = .false. CS%use_simpler_Eady_growth_rate = .false. CS%calculate_depth_fns = .false. + CS%use_gradient_model = .false. ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USE_VARIABLE_MIXING", CS%use_variable_mixing,& @@ -1263,11 +1263,11 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "not used. If KHTR_SLOPE_CFF>0 or KhTh_Slope_Cff>0, "//& "this is set to true regardless of what is in the "//& "parameter file.", default=.false.) - ! call get_param(param_file, mdl, "USE_GRADIENT_MODEL", CS%use_gradient_model,& - ! "If true, use the gradient model formula for eddy diffusivity. This "//& - ! "allows diagnostics to be created even if the scheme is "//& - ! "not used. If Grad_L_Scale>0, this is set to true regardless of what "//& - ! "is in the parameter file.", default=.false.) + call get_param(param_file, mdl, "USE_GRADIENT_MODEL", CS%use_gradient_model,& + "If true, use the gradient model formula for eddy diffusivity. This "//& + "allows diagnostics to be created even if the scheme is "//& + "not used. If Grad_L_Scale>0, this is set to true regardless of what "//& + "is in the parameter file.", default=.false.) call get_param(param_file, mdl, "USE_VISBECK", CS%use_Visbeck,& "If true, use the Visbeck et al. (1997) formulation for \n"//& "thickness diffusivity.", default=.false.) @@ -1444,7 +1444,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'm2', conversion=US%L_to_m**2) endif - if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then + if (CS%use_gradient_model) then in_use = .true. call get_param(param_file, mdl, "GRAD_L_SCALE", CS%grad_L_scale, & "The fixed length scale in the gradient formula.", units="m", & From b90c189ca6c92d267d83ccae26ab4a6fc563456b Mon Sep 17 00:00:00 2001 From: Sinakhani Date: Fri, 18 Oct 2024 13:34:51 -0500 Subject: [PATCH 7/7] Gradient model is updated --- parameterizations/lateral/MOM_thickness_diffuse.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/parameterizations/lateral/MOM_thickness_diffuse.F90 b/parameterizations/lateral/MOM_thickness_diffuse.F90 index c3e251a7e9..bcba8f2021 100644 --- a/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -318,7 +318,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%Grad_L_Scale > 0.0) then !$OMP do do k=1,nz ; do j=js,je ; do I=is-1,ie - KH_u(I,j,k) = CS%Grad_L_Scale*VarMix%L2grad_u(I,j)*VarMix%UH_grad(I,j,k) + KH_u(I,j,k) = 1.0*CS%Grad_L_Scale*VarMix%L2grad_u(I,j)*VarMix%UH_grad(I,j,k) +!! print*, "KH_u=", KH_u(I,j,k) enddo ; enddo ; enddo endif endif @@ -424,7 +425,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%Grad_L_Scale > 0.0) then !< Gradient model !$OMP do do k=1,nz ; do J=js-1,je ; do i=is,ie - KH_v(i,J,k) = CS%Grad_L_Scale*VarMix%L2grad_v(i,J)*VarMix%VH_grad(i,J,k) + KH_v(i,J,k) = 1.0*CS%Grad_L_Scale*VarMix%L2grad_v(i,J)*VarMix%VH_grad(i,J,k) +!! print*, "KH_v=", KH_v(i,J,k) enddo ; enddo ; enddo endif endif